1 /* Matching subroutines in all sizes, shapes and colors.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
29 int gfc_matching_procptr_assignment
= 0;
30 bool gfc_matching_prefix
= false;
32 /* Stack of SELECT TYPE statements. */
33 gfc_select_type_stack
*select_type_stack
= NULL
;
35 /* For debugging and diagnostic purposes. Return the textual representation
36 of the intrinsic operator OP. */
38 gfc_op2string (gfc_intrinsic_op op
)
46 case INTRINSIC_UMINUS
:
52 case INTRINSIC_CONCAT
:
56 case INTRINSIC_DIVIDE
:
95 case INTRINSIC_ASSIGN
:
98 case INTRINSIC_PARENTHESES
:
105 gfc_internal_error ("gfc_op2string(): Bad code");
110 /******************** Generic matching subroutines ************************/
112 /* This function scans the current statement counting the opened and closed
113 parenthesis to make sure they are balanced. */
116 gfc_match_parens (void)
118 locus old_loc
, where
;
122 old_loc
= gfc_current_locus
;
129 c
= gfc_next_char_literal (instring
);
132 if (quote
== ' ' && ((c
== '\'') || (c
== '"')))
138 if (quote
!= ' ' && c
== quote
)
145 if (c
== '(' && quote
== ' ')
148 where
= gfc_current_locus
;
150 if (c
== ')' && quote
== ' ')
153 where
= gfc_current_locus
;
157 gfc_current_locus
= old_loc
;
161 gfc_error ("Missing ')' in statement at or before %L", &where
);
166 gfc_error ("Missing '(' in statement at or before %L", &where
);
174 /* See if the next character is a special character that has
175 escaped by a \ via the -fbackslash option. */
178 gfc_match_special_char (gfc_char_t
*res
)
186 switch ((c
= gfc_next_char_literal (1)))
219 /* Hexadecimal form of wide characters. */
220 len
= (c
== 'x' ? 2 : (c
== 'u' ? 4 : 8));
222 for (i
= 0; i
< len
; i
++)
224 char buf
[2] = { '\0', '\0' };
226 c
= gfc_next_char_literal (1);
227 if (!gfc_wide_fits_in_byte (c
)
228 || !gfc_check_digit ((unsigned char) c
, 16))
231 buf
[0] = (unsigned char) c
;
233 n
+= strtol (buf
, NULL
, 16);
239 /* Unknown backslash codes are simply not expanded. */
248 /* In free form, match at least one space. Always matches in fixed
252 gfc_match_space (void)
257 if (gfc_current_form
== FORM_FIXED
)
260 old_loc
= gfc_current_locus
;
262 c
= gfc_next_ascii_char ();
263 if (!gfc_is_whitespace (c
))
265 gfc_current_locus
= old_loc
;
269 gfc_gobble_whitespace ();
275 /* Match an end of statement. End of statement is optional
276 whitespace, followed by a ';' or '\n' or comment '!'. If a
277 semicolon is found, we continue to eat whitespace and semicolons. */
290 old_loc
= gfc_current_locus
;
291 gfc_gobble_whitespace ();
293 c
= gfc_next_ascii_char ();
299 c
= gfc_next_ascii_char ();
316 gfc_current_locus
= old_loc
;
317 return (flag
) ? MATCH_YES
: MATCH_NO
;
321 /* Match a literal integer on the input, setting the value on
322 MATCH_YES. Literal ints occur in kind-parameters as well as
323 old-style character length specifications. If cnt is non-NULL it
324 will be set to the number of digits. */
327 gfc_match_small_literal_int (int *value
, int *cnt
)
333 old_loc
= gfc_current_locus
;
336 gfc_gobble_whitespace ();
337 c
= gfc_next_ascii_char ();
343 gfc_current_locus
= old_loc
;
352 old_loc
= gfc_current_locus
;
353 c
= gfc_next_ascii_char ();
358 i
= 10 * i
+ c
- '0';
363 gfc_error ("Integer too large at %C");
368 gfc_current_locus
= old_loc
;
377 /* Match a small, constant integer expression, like in a kind
378 statement. On MATCH_YES, 'value' is set. */
381 gfc_match_small_int (int *value
)
388 m
= gfc_match_expr (&expr
);
392 p
= gfc_extract_int (expr
, &i
);
393 gfc_free_expr (expr
);
406 /* This function is the same as the gfc_match_small_int, except that
407 we're keeping the pointer to the expr. This function could just be
408 removed and the previously mentioned one modified, though all calls
409 to it would have to be modified then (and there were a number of
410 them). Return MATCH_ERROR if fail to extract the int; otherwise,
411 return the result of gfc_match_expr(). The expr (if any) that was
412 matched is returned in the parameter expr. */
415 gfc_match_small_int_expr (int *value
, gfc_expr
**expr
)
421 m
= gfc_match_expr (expr
);
425 p
= gfc_extract_int (*expr
, &i
);
438 /* Matches a statement label. Uses gfc_match_small_literal_int() to
439 do most of the work. */
442 gfc_match_st_label (gfc_st_label
**label
)
448 old_loc
= gfc_current_locus
;
450 m
= gfc_match_small_literal_int (&i
, &cnt
);
456 gfc_error ("Too many digits in statement label at %C");
462 gfc_error ("Statement label at %C is zero");
466 *label
= gfc_get_st_label (i
);
471 gfc_current_locus
= old_loc
;
476 /* Match and validate a label associated with a named IF, DO or SELECT
477 statement. If the symbol does not have the label attribute, we add
478 it. We also make sure the symbol does not refer to another
479 (active) block. A matched label is pointed to by gfc_new_block. */
482 gfc_match_label (void)
484 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
487 gfc_new_block
= NULL
;
489 m
= gfc_match (" %n :", name
);
493 if (gfc_get_symbol (name
, NULL
, &gfc_new_block
))
495 gfc_error ("Label name '%s' at %C is ambiguous", name
);
499 if (gfc_new_block
->attr
.flavor
== FL_LABEL
)
501 gfc_error ("Duplicate construct label '%s' at %C", name
);
505 if (gfc_add_flavor (&gfc_new_block
->attr
, FL_LABEL
,
506 gfc_new_block
->name
, NULL
) == FAILURE
)
513 /* See if the current input looks like a name of some sort. Modifies
514 the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long.
515 Note that options.c restricts max_identifier_length to not more
516 than GFC_MAX_SYMBOL_LEN. */
519 gfc_match_name (char *buffer
)
525 old_loc
= gfc_current_locus
;
526 gfc_gobble_whitespace ();
528 c
= gfc_next_ascii_char ();
529 if (!(ISALPHA (c
) || (c
== '_' && gfc_option
.flag_allow_leading_underscore
)))
531 if (gfc_error_flag_test() == 0 && c
!= '(')
532 gfc_error ("Invalid character in name at %C");
533 gfc_current_locus
= old_loc
;
543 if (i
> gfc_option
.max_identifier_length
)
545 gfc_error ("Name at %C is too long");
549 old_loc
= gfc_current_locus
;
550 c
= gfc_next_ascii_char ();
552 while (ISALNUM (c
) || c
== '_' || (gfc_option
.flag_dollar_ok
&& c
== '$'));
554 if (c
== '$' && !gfc_option
.flag_dollar_ok
)
556 gfc_error ("Invalid character '$' at %C. Use -fdollar-ok to allow it "
562 gfc_current_locus
= old_loc
;
568 /* Match a valid name for C, which is almost the same as for Fortran,
569 except that you can start with an underscore, etc.. It could have
570 been done by modifying the gfc_match_name, but this way other
571 things C allows can be added, such as no limits on the length.
572 Right now, the length is limited to the same thing as Fortran..
573 Also, by rewriting it, we use the gfc_next_char_C() to prevent the
574 input characters from being automatically lower cased, since C is
575 case sensitive. The parameter, buffer, is used to return the name
576 that is matched. Return MATCH_ERROR if the name is too long
577 (though this is a self-imposed limit), MATCH_NO if what we're
578 seeing isn't a name, and MATCH_YES if we successfully match a C
582 gfc_match_name_C (char *buffer
)
588 old_loc
= gfc_current_locus
;
589 gfc_gobble_whitespace ();
591 /* Get the next char (first possible char of name) and see if
592 it's valid for C (either a letter or an underscore). */
593 c
= gfc_next_char_literal (1);
595 /* If the user put nothing expect spaces between the quotes, it is valid
596 and simply means there is no name= specifier and the name is the fortran
597 symbol name, all lowercase. */
598 if (c
== '"' || c
== '\'')
601 gfc_current_locus
= old_loc
;
605 if (!ISALPHA (c
) && c
!= '_')
607 gfc_error ("Invalid C name in NAME= specifier at %C");
611 /* Continue to read valid variable name characters. */
614 gcc_assert (gfc_wide_fits_in_byte (c
));
616 buffer
[i
++] = (unsigned char) c
;
618 /* C does not define a maximum length of variable names, to my
619 knowledge, but the compiler typically places a limit on them.
620 For now, i'll use the same as the fortran limit for simplicity,
621 but this may need to be changed to a dynamic buffer that can
622 be realloc'ed here if necessary, or more likely, a larger
624 if (i
> gfc_option
.max_identifier_length
)
626 gfc_error ("Name at %C is too long");
630 old_loc
= gfc_current_locus
;
632 /* Get next char; param means we're in a string. */
633 c
= gfc_next_char_literal (1);
634 } while (ISALNUM (c
) || c
== '_');
637 gfc_current_locus
= old_loc
;
639 /* See if we stopped because of whitespace. */
642 gfc_gobble_whitespace ();
643 c
= gfc_peek_ascii_char ();
644 if (c
!= '"' && c
!= '\'')
646 gfc_error ("Embedded space in NAME= specifier at %C");
651 /* If we stopped because we had an invalid character for a C name, report
652 that to the user by returning MATCH_NO. */
653 if (c
!= '"' && c
!= '\'')
655 gfc_error ("Invalid C name in NAME= specifier at %C");
663 /* Match a symbol on the input. Modifies the pointer to the symbol
664 pointer if successful. */
667 gfc_match_sym_tree (gfc_symtree
**matched_symbol
, int host_assoc
)
669 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
672 m
= gfc_match_name (buffer
);
677 return (gfc_get_ha_sym_tree (buffer
, matched_symbol
))
678 ? MATCH_ERROR
: MATCH_YES
;
680 if (gfc_get_sym_tree (buffer
, NULL
, matched_symbol
, false))
688 gfc_match_symbol (gfc_symbol
**matched_symbol
, int host_assoc
)
693 m
= gfc_match_sym_tree (&st
, host_assoc
);
698 *matched_symbol
= st
->n
.sym
;
700 *matched_symbol
= NULL
;
703 *matched_symbol
= NULL
;
708 /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
709 we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
713 gfc_match_intrinsic_op (gfc_intrinsic_op
*result
)
715 locus orig_loc
= gfc_current_locus
;
718 gfc_gobble_whitespace ();
719 ch
= gfc_next_ascii_char ();
724 *result
= INTRINSIC_PLUS
;
729 *result
= INTRINSIC_MINUS
;
733 if (gfc_next_ascii_char () == '=')
736 *result
= INTRINSIC_EQ
;
742 if (gfc_peek_ascii_char () == '=')
745 gfc_next_ascii_char ();
746 *result
= INTRINSIC_LE
;
750 *result
= INTRINSIC_LT
;
754 if (gfc_peek_ascii_char () == '=')
757 gfc_next_ascii_char ();
758 *result
= INTRINSIC_GE
;
762 *result
= INTRINSIC_GT
;
766 if (gfc_peek_ascii_char () == '*')
769 gfc_next_ascii_char ();
770 *result
= INTRINSIC_POWER
;
774 *result
= INTRINSIC_TIMES
;
778 ch
= gfc_peek_ascii_char ();
782 gfc_next_ascii_char ();
783 *result
= INTRINSIC_NE
;
789 gfc_next_ascii_char ();
790 *result
= INTRINSIC_CONCAT
;
794 *result
= INTRINSIC_DIVIDE
;
798 ch
= gfc_next_ascii_char ();
802 if (gfc_next_ascii_char () == 'n'
803 && gfc_next_ascii_char () == 'd'
804 && gfc_next_ascii_char () == '.')
806 /* Matched ".and.". */
807 *result
= INTRINSIC_AND
;
813 if (gfc_next_ascii_char () == 'q')
815 ch
= gfc_next_ascii_char ();
818 /* Matched ".eq.". */
819 *result
= INTRINSIC_EQ_OS
;
824 if (gfc_next_ascii_char () == '.')
826 /* Matched ".eqv.". */
827 *result
= INTRINSIC_EQV
;
835 ch
= gfc_next_ascii_char ();
838 if (gfc_next_ascii_char () == '.')
840 /* Matched ".ge.". */
841 *result
= INTRINSIC_GE_OS
;
847 if (gfc_next_ascii_char () == '.')
849 /* Matched ".gt.". */
850 *result
= INTRINSIC_GT_OS
;
857 ch
= gfc_next_ascii_char ();
860 if (gfc_next_ascii_char () == '.')
862 /* Matched ".le.". */
863 *result
= INTRINSIC_LE_OS
;
869 if (gfc_next_ascii_char () == '.')
871 /* Matched ".lt.". */
872 *result
= INTRINSIC_LT_OS
;
879 ch
= gfc_next_ascii_char ();
882 ch
= gfc_next_ascii_char ();
885 /* Matched ".ne.". */
886 *result
= INTRINSIC_NE_OS
;
891 if (gfc_next_ascii_char () == 'v'
892 && gfc_next_ascii_char () == '.')
894 /* Matched ".neqv.". */
895 *result
= INTRINSIC_NEQV
;
902 if (gfc_next_ascii_char () == 't'
903 && gfc_next_ascii_char () == '.')
905 /* Matched ".not.". */
906 *result
= INTRINSIC_NOT
;
913 if (gfc_next_ascii_char () == 'r'
914 && gfc_next_ascii_char () == '.')
916 /* Matched ".or.". */
917 *result
= INTRINSIC_OR
;
931 gfc_current_locus
= orig_loc
;
936 /* Match a loop control phrase:
938 <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
940 If the final integer expression is not present, a constant unity
941 expression is returned. We don't return MATCH_ERROR until after
942 the equals sign is seen. */
945 gfc_match_iterator (gfc_iterator
*iter
, int init_flag
)
947 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
948 gfc_expr
*var
, *e1
, *e2
, *e3
;
952 /* Match the start of an iterator without affecting the symbol table. */
954 start
= gfc_current_locus
;
955 m
= gfc_match (" %n =", name
);
956 gfc_current_locus
= start
;
961 m
= gfc_match_variable (&var
, 0);
965 gfc_match_char ('=');
969 if (var
->ref
!= NULL
)
971 gfc_error ("Loop variable at %C cannot be a sub-component");
975 if (var
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
977 gfc_error ("Loop variable '%s' at %C cannot be INTENT(IN)",
978 var
->symtree
->n
.sym
->name
);
982 var
->symtree
->n
.sym
->attr
.implied_index
= 1;
984 m
= init_flag
? gfc_match_init_expr (&e1
) : gfc_match_expr (&e1
);
987 if (m
== MATCH_ERROR
)
990 if (gfc_match_char (',') != MATCH_YES
)
993 m
= init_flag
? gfc_match_init_expr (&e2
) : gfc_match_expr (&e2
);
996 if (m
== MATCH_ERROR
)
999 if (gfc_match_char (',') != MATCH_YES
)
1001 e3
= gfc_int_expr (1);
1005 m
= init_flag
? gfc_match_init_expr (&e3
) : gfc_match_expr (&e3
);
1006 if (m
== MATCH_ERROR
)
1010 gfc_error ("Expected a step value in iterator at %C");
1022 gfc_error ("Syntax error in iterator at %C");
1033 /* Tries to match the next non-whitespace character on the input.
1034 This subroutine does not return MATCH_ERROR. */
1037 gfc_match_char (char c
)
1041 where
= gfc_current_locus
;
1042 gfc_gobble_whitespace ();
1044 if (gfc_next_ascii_char () == c
)
1047 gfc_current_locus
= where
;
1052 /* General purpose matching subroutine. The target string is a
1053 scanf-like format string in which spaces correspond to arbitrary
1054 whitespace (including no whitespace), characters correspond to
1055 themselves. The %-codes are:
1057 %% Literal percent sign
1058 %e Expression, pointer to a pointer is set
1059 %s Symbol, pointer to the symbol is set
1060 %n Name, character buffer is set to name
1061 %t Matches end of statement.
1062 %o Matches an intrinsic operator, returned as an INTRINSIC enum.
1063 %l Matches a statement label
1064 %v Matches a variable expression (an lvalue)
1065 % Matches a required space (in free form) and optional spaces. */
1068 gfc_match (const char *target
, ...)
1070 gfc_st_label
**label
;
1079 old_loc
= gfc_current_locus
;
1080 va_start (argp
, target
);
1090 gfc_gobble_whitespace ();
1101 vp
= va_arg (argp
, void **);
1102 n
= gfc_match_expr ((gfc_expr
**) vp
);
1113 vp
= va_arg (argp
, void **);
1114 n
= gfc_match_variable ((gfc_expr
**) vp
, 0);
1125 vp
= va_arg (argp
, void **);
1126 n
= gfc_match_symbol ((gfc_symbol
**) vp
, 0);
1137 np
= va_arg (argp
, char *);
1138 n
= gfc_match_name (np
);
1149 label
= va_arg (argp
, gfc_st_label
**);
1150 n
= gfc_match_st_label (label
);
1161 ip
= va_arg (argp
, int *);
1162 n
= gfc_match_intrinsic_op ((gfc_intrinsic_op
*) ip
);
1173 if (gfc_match_eos () != MATCH_YES
)
1181 if (gfc_match_space () == MATCH_YES
)
1187 break; /* Fall through to character matcher. */
1190 gfc_internal_error ("gfc_match(): Bad match code %c", c
);
1195 /* gfc_next_ascii_char converts characters to lower-case, so we shouldn't
1196 expect an upper case character here! */
1197 gcc_assert (TOLOWER (c
) == c
);
1199 if (c
== gfc_next_ascii_char ())
1209 /* Clean up after a failed match. */
1210 gfc_current_locus
= old_loc
;
1211 va_start (argp
, target
);
1214 for (; matches
> 0; matches
--)
1216 while (*p
++ != '%');
1224 /* Matches that don't have to be undone */
1229 (void) va_arg (argp
, void **);
1234 vp
= va_arg (argp
, void **);
1235 gfc_free_expr ((struct gfc_expr
*)*vp
);
1248 /*********************** Statement level matching **********************/
1250 /* Matches the start of a program unit, which is the program keyword
1251 followed by an obligatory symbol. */
1254 gfc_match_program (void)
1259 m
= gfc_match ("% %s%t", &sym
);
1263 gfc_error ("Invalid form of PROGRAM statement at %C");
1267 if (m
== MATCH_ERROR
)
1270 if (gfc_add_flavor (&sym
->attr
, FL_PROGRAM
, sym
->name
, NULL
) == FAILURE
)
1273 gfc_new_block
= sym
;
1279 /* Match a simple assignment statement. */
1282 gfc_match_assignment (void)
1284 gfc_expr
*lvalue
, *rvalue
;
1288 old_loc
= gfc_current_locus
;
1291 m
= gfc_match (" %v =", &lvalue
);
1294 gfc_current_locus
= old_loc
;
1295 gfc_free_expr (lvalue
);
1300 m
= gfc_match (" %e%t", &rvalue
);
1303 gfc_current_locus
= old_loc
;
1304 gfc_free_expr (lvalue
);
1305 gfc_free_expr (rvalue
);
1309 gfc_set_sym_referenced (lvalue
->symtree
->n
.sym
);
1311 new_st
.op
= EXEC_ASSIGN
;
1312 new_st
.expr1
= lvalue
;
1313 new_st
.expr2
= rvalue
;
1315 gfc_check_do_variable (lvalue
->symtree
);
1321 /* Match a pointer assignment statement. */
1324 gfc_match_pointer_assignment (void)
1326 gfc_expr
*lvalue
, *rvalue
;
1330 old_loc
= gfc_current_locus
;
1332 lvalue
= rvalue
= NULL
;
1333 gfc_matching_procptr_assignment
= 0;
1335 m
= gfc_match (" %v =>", &lvalue
);
1342 if (lvalue
->symtree
->n
.sym
->attr
.proc_pointer
1343 || gfc_is_proc_ptr_comp (lvalue
, NULL
))
1344 gfc_matching_procptr_assignment
= 1;
1346 m
= gfc_match (" %e%t", &rvalue
);
1347 gfc_matching_procptr_assignment
= 0;
1351 new_st
.op
= EXEC_POINTER_ASSIGN
;
1352 new_st
.expr1
= lvalue
;
1353 new_st
.expr2
= rvalue
;
1358 gfc_current_locus
= old_loc
;
1359 gfc_free_expr (lvalue
);
1360 gfc_free_expr (rvalue
);
1365 /* We try to match an easy arithmetic IF statement. This only happens
1366 when just after having encountered a simple IF statement. This code
1367 is really duplicate with parts of the gfc_match_if code, but this is
1371 match_arithmetic_if (void)
1373 gfc_st_label
*l1
, *l2
, *l3
;
1377 m
= gfc_match (" ( %e ) %l , %l , %l%t", &expr
, &l1
, &l2
, &l3
);
1381 if (gfc_reference_st_label (l1
, ST_LABEL_TARGET
) == FAILURE
1382 || gfc_reference_st_label (l2
, ST_LABEL_TARGET
) == FAILURE
1383 || gfc_reference_st_label (l3
, ST_LABEL_TARGET
) == FAILURE
)
1385 gfc_free_expr (expr
);
1389 if (gfc_notify_std (GFC_STD_F95_OBS
, "Obsolescent feature: Arithmetic IF "
1390 "statement at %C") == FAILURE
)
1393 new_st
.op
= EXEC_ARITHMETIC_IF
;
1394 new_st
.expr1
= expr
;
1403 /* The IF statement is a bit of a pain. First of all, there are three
1404 forms of it, the simple IF, the IF that starts a block and the
1407 There is a problem with the simple IF and that is the fact that we
1408 only have a single level of undo information on symbols. What this
1409 means is for a simple IF, we must re-match the whole IF statement
1410 multiple times in order to guarantee that the symbol table ends up
1411 in the proper state. */
1413 static match
match_simple_forall (void);
1414 static match
match_simple_where (void);
1417 gfc_match_if (gfc_statement
*if_type
)
1420 gfc_st_label
*l1
, *l2
, *l3
;
1421 locus old_loc
, old_loc2
;
1425 n
= gfc_match_label ();
1426 if (n
== MATCH_ERROR
)
1429 old_loc
= gfc_current_locus
;
1431 m
= gfc_match (" if ( %e", &expr
);
1435 old_loc2
= gfc_current_locus
;
1436 gfc_current_locus
= old_loc
;
1438 if (gfc_match_parens () == MATCH_ERROR
)
1441 gfc_current_locus
= old_loc2
;
1443 if (gfc_match_char (')') != MATCH_YES
)
1445 gfc_error ("Syntax error in IF-expression at %C");
1446 gfc_free_expr (expr
);
1450 m
= gfc_match (" %l , %l , %l%t", &l1
, &l2
, &l3
);
1456 gfc_error ("Block label not appropriate for arithmetic IF "
1458 gfc_free_expr (expr
);
1462 if (gfc_reference_st_label (l1
, ST_LABEL_TARGET
) == FAILURE
1463 || gfc_reference_st_label (l2
, ST_LABEL_TARGET
) == FAILURE
1464 || gfc_reference_st_label (l3
, ST_LABEL_TARGET
) == FAILURE
)
1466 gfc_free_expr (expr
);
1470 if (gfc_notify_std (GFC_STD_F95_OBS
, "Obsolescent feature: Arithmetic IF "
1471 "statement at %C") == FAILURE
)
1474 new_st
.op
= EXEC_ARITHMETIC_IF
;
1475 new_st
.expr1
= expr
;
1480 *if_type
= ST_ARITHMETIC_IF
;
1484 if (gfc_match (" then%t") == MATCH_YES
)
1486 new_st
.op
= EXEC_IF
;
1487 new_st
.expr1
= expr
;
1488 *if_type
= ST_IF_BLOCK
;
1494 gfc_error ("Block label is not appropriate for IF statement at %C");
1495 gfc_free_expr (expr
);
1499 /* At this point the only thing left is a simple IF statement. At
1500 this point, n has to be MATCH_NO, so we don't have to worry about
1501 re-matching a block label. From what we've got so far, try
1502 matching an assignment. */
1504 *if_type
= ST_SIMPLE_IF
;
1506 m
= gfc_match_assignment ();
1510 gfc_free_expr (expr
);
1511 gfc_undo_symbols ();
1512 gfc_current_locus
= old_loc
;
1514 /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled
1515 assignment was found. For MATCH_NO, continue to call the various
1517 if (m
== MATCH_ERROR
)
1520 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1522 m
= gfc_match_pointer_assignment ();
1526 gfc_free_expr (expr
);
1527 gfc_undo_symbols ();
1528 gfc_current_locus
= old_loc
;
1530 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1532 /* Look at the next keyword to see which matcher to call. Matching
1533 the keyword doesn't affect the symbol table, so we don't have to
1534 restore between tries. */
1536 #define match(string, subr, statement) \
1537 if (gfc_match(string) == MATCH_YES) { m = subr(); goto got_match; }
1541 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
)
1542 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
)
1543 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
)
1544 match ("call", gfc_match_call
, ST_CALL
)
1545 match ("close", gfc_match_close
, ST_CLOSE
)
1546 match ("continue", gfc_match_continue
, ST_CONTINUE
)
1547 match ("cycle", gfc_match_cycle
, ST_CYCLE
)
1548 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
)
1549 match ("end file", gfc_match_endfile
, ST_END_FILE
)
1550 match ("exit", gfc_match_exit
, ST_EXIT
)
1551 match ("flush", gfc_match_flush
, ST_FLUSH
)
1552 match ("forall", match_simple_forall
, ST_FORALL
)
1553 match ("go to", gfc_match_goto
, ST_GOTO
)
1554 match ("if", match_arithmetic_if
, ST_ARITHMETIC_IF
)
1555 match ("inquire", gfc_match_inquire
, ST_INQUIRE
)
1556 match ("nullify", gfc_match_nullify
, ST_NULLIFY
)
1557 match ("open", gfc_match_open
, ST_OPEN
)
1558 match ("pause", gfc_match_pause
, ST_NONE
)
1559 match ("print", gfc_match_print
, ST_WRITE
)
1560 match ("read", gfc_match_read
, ST_READ
)
1561 match ("return", gfc_match_return
, ST_RETURN
)
1562 match ("rewind", gfc_match_rewind
, ST_REWIND
)
1563 match ("stop", gfc_match_stop
, ST_STOP
)
1564 match ("wait", gfc_match_wait
, ST_WAIT
)
1565 match ("where", match_simple_where
, ST_WHERE
)
1566 match ("write", gfc_match_write
, ST_WRITE
)
1568 /* The gfc_match_assignment() above may have returned a MATCH_NO
1569 where the assignment was to a named constant. Check that
1570 special case here. */
1571 m
= gfc_match_assignment ();
1574 gfc_error ("Cannot assign to a named constant at %C");
1575 gfc_free_expr (expr
);
1576 gfc_undo_symbols ();
1577 gfc_current_locus
= old_loc
;
1581 /* All else has failed, so give up. See if any of the matchers has
1582 stored an error message of some sort. */
1583 if (gfc_error_check () == 0)
1584 gfc_error ("Unclassifiable statement in IF-clause at %C");
1586 gfc_free_expr (expr
);
1591 gfc_error ("Syntax error in IF-clause at %C");
1594 gfc_free_expr (expr
);
1598 /* At this point, we've matched the single IF and the action clause
1599 is in new_st. Rearrange things so that the IF statement appears
1602 p
= gfc_get_code ();
1603 p
->next
= gfc_get_code ();
1605 p
->next
->loc
= gfc_current_locus
;
1610 gfc_clear_new_st ();
1612 new_st
.op
= EXEC_IF
;
1621 /* Match an ELSE statement. */
1624 gfc_match_else (void)
1626 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1628 if (gfc_match_eos () == MATCH_YES
)
1631 if (gfc_match_name (name
) != MATCH_YES
1632 || gfc_current_block () == NULL
1633 || gfc_match_eos () != MATCH_YES
)
1635 gfc_error ("Unexpected junk after ELSE statement at %C");
1639 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1641 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1642 name
, gfc_current_block ()->name
);
1650 /* Match an ELSE IF statement. */
1653 gfc_match_elseif (void)
1655 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1659 m
= gfc_match (" ( %e ) then", &expr
);
1663 if (gfc_match_eos () == MATCH_YES
)
1666 if (gfc_match_name (name
) != MATCH_YES
1667 || gfc_current_block () == NULL
1668 || gfc_match_eos () != MATCH_YES
)
1670 gfc_error ("Unexpected junk after ELSE IF statement at %C");
1674 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1676 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1677 name
, gfc_current_block ()->name
);
1682 new_st
.op
= EXEC_IF
;
1683 new_st
.expr1
= expr
;
1687 gfc_free_expr (expr
);
1692 /* Free a gfc_iterator structure. */
1695 gfc_free_iterator (gfc_iterator
*iter
, int flag
)
1701 gfc_free_expr (iter
->var
);
1702 gfc_free_expr (iter
->start
);
1703 gfc_free_expr (iter
->end
);
1704 gfc_free_expr (iter
->step
);
1711 /* Match a BLOCK statement. */
1714 gfc_match_block (void)
1718 if (gfc_match_label () == MATCH_ERROR
)
1721 if (gfc_match (" block") != MATCH_YES
)
1724 /* For this to be a correct BLOCK statement, the line must end now. */
1725 m
= gfc_match_eos ();
1726 if (m
== MATCH_ERROR
)
1735 /* Match a DO statement. */
1740 gfc_iterator iter
, *ip
;
1742 gfc_st_label
*label
;
1745 old_loc
= gfc_current_locus
;
1748 iter
.var
= iter
.start
= iter
.end
= iter
.step
= NULL
;
1750 m
= gfc_match_label ();
1751 if (m
== MATCH_ERROR
)
1754 if (gfc_match (" do") != MATCH_YES
)
1757 m
= gfc_match_st_label (&label
);
1758 if (m
== MATCH_ERROR
)
1761 /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
1763 if (gfc_match_eos () == MATCH_YES
)
1765 iter
.end
= gfc_logical_expr (1, NULL
);
1766 new_st
.op
= EXEC_DO_WHILE
;
1770 /* Match an optional comma, if no comma is found, a space is obligatory. */
1771 if (gfc_match_char (',') != MATCH_YES
&& gfc_match ("% ") != MATCH_YES
)
1774 /* Check for balanced parens. */
1776 if (gfc_match_parens () == MATCH_ERROR
)
1779 /* See if we have a DO WHILE. */
1780 if (gfc_match (" while ( %e )%t", &iter
.end
) == MATCH_YES
)
1782 new_st
.op
= EXEC_DO_WHILE
;
1786 /* The abortive DO WHILE may have done something to the symbol
1787 table, so we start over. */
1788 gfc_undo_symbols ();
1789 gfc_current_locus
= old_loc
;
1791 gfc_match_label (); /* This won't error. */
1792 gfc_match (" do "); /* This will work. */
1794 gfc_match_st_label (&label
); /* Can't error out. */
1795 gfc_match_char (','); /* Optional comma. */
1797 m
= gfc_match_iterator (&iter
, 0);
1800 if (m
== MATCH_ERROR
)
1803 iter
.var
->symtree
->n
.sym
->attr
.implied_index
= 0;
1804 gfc_check_do_variable (iter
.var
->symtree
);
1806 if (gfc_match_eos () != MATCH_YES
)
1808 gfc_syntax_error (ST_DO
);
1812 new_st
.op
= EXEC_DO
;
1816 && gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
1819 new_st
.label1
= label
;
1821 if (new_st
.op
== EXEC_DO_WHILE
)
1822 new_st
.expr1
= iter
.end
;
1825 new_st
.ext
.iterator
= ip
= gfc_get_iterator ();
1832 gfc_free_iterator (&iter
, 0);
1838 /* Match an EXIT or CYCLE statement. */
1841 match_exit_cycle (gfc_statement st
, gfc_exec_op op
)
1843 gfc_state_data
*p
, *o
;
1847 if (gfc_match_eos () == MATCH_YES
)
1851 m
= gfc_match ("% %s%t", &sym
);
1852 if (m
== MATCH_ERROR
)
1856 gfc_syntax_error (st
);
1860 if (sym
->attr
.flavor
!= FL_LABEL
)
1862 gfc_error ("Name '%s' in %s statement at %C is not a loop name",
1863 sym
->name
, gfc_ascii_statement (st
));
1868 /* Find the loop mentioned specified by the label (or lack of a label). */
1869 for (o
= NULL
, p
= gfc_state_stack
; p
; p
= p
->previous
)
1870 if (p
->state
== COMP_DO
&& (sym
== NULL
|| sym
== p
->sym
))
1872 else if (o
== NULL
&& p
->state
== COMP_OMP_STRUCTURED_BLOCK
)
1878 gfc_error ("%s statement at %C is not within a loop",
1879 gfc_ascii_statement (st
));
1881 gfc_error ("%s statement at %C is not within loop '%s'",
1882 gfc_ascii_statement (st
), sym
->name
);
1889 gfc_error ("%s statement at %C leaving OpenMP structured block",
1890 gfc_ascii_statement (st
));
1893 else if (st
== ST_EXIT
1894 && p
->previous
!= NULL
1895 && p
->previous
->state
== COMP_OMP_STRUCTURED_BLOCK
1896 && (p
->previous
->head
->op
== EXEC_OMP_DO
1897 || p
->previous
->head
->op
== EXEC_OMP_PARALLEL_DO
))
1899 gcc_assert (p
->previous
->head
->next
!= NULL
);
1900 gcc_assert (p
->previous
->head
->next
->op
== EXEC_DO
1901 || p
->previous
->head
->next
->op
== EXEC_DO_WHILE
);
1902 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
1906 /* Save the first statement in the loop - needed by the backend. */
1907 new_st
.ext
.whichloop
= p
->head
;
1915 /* Match the EXIT statement. */
1918 gfc_match_exit (void)
1920 return match_exit_cycle (ST_EXIT
, EXEC_EXIT
);
1924 /* Match the CYCLE statement. */
1927 gfc_match_cycle (void)
1929 return match_exit_cycle (ST_CYCLE
, EXEC_CYCLE
);
1933 /* Match a number or character constant after a STOP or PAUSE statement. */
1936 gfc_match_stopcode (gfc_statement st
)
1946 if (gfc_match_eos () != MATCH_YES
)
1948 m
= gfc_match_small_literal_int (&stop_code
, &cnt
);
1949 if (m
== MATCH_ERROR
)
1952 if (m
== MATCH_YES
&& cnt
> 5)
1954 gfc_error ("Too many digits in STOP code at %C");
1960 /* Try a character constant. */
1961 m
= gfc_match_expr (&e
);
1962 if (m
== MATCH_ERROR
)
1966 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1970 if (gfc_match_eos () != MATCH_YES
)
1974 if (gfc_pure (NULL
))
1976 gfc_error ("%s statement not allowed in PURE procedure at %C",
1977 gfc_ascii_statement (st
));
1981 new_st
.op
= st
== ST_STOP
? EXEC_STOP
: EXEC_PAUSE
;
1983 new_st
.ext
.stop_code
= stop_code
;
1988 gfc_syntax_error (st
);
1997 /* Match the (deprecated) PAUSE statement. */
2000 gfc_match_pause (void)
2004 m
= gfc_match_stopcode (ST_PAUSE
);
2007 if (gfc_notify_std (GFC_STD_F95_DEL
, "Deleted feature: PAUSE statement"
2016 /* Match the STOP statement. */
2019 gfc_match_stop (void)
2021 return gfc_match_stopcode (ST_STOP
);
2025 /* Match a CONTINUE statement. */
2028 gfc_match_continue (void)
2030 if (gfc_match_eos () != MATCH_YES
)
2032 gfc_syntax_error (ST_CONTINUE
);
2036 new_st
.op
= EXEC_CONTINUE
;
2041 /* Match the (deprecated) ASSIGN statement. */
2044 gfc_match_assign (void)
2047 gfc_st_label
*label
;
2049 if (gfc_match (" %l", &label
) == MATCH_YES
)
2051 if (gfc_reference_st_label (label
, ST_LABEL_UNKNOWN
) == FAILURE
)
2053 if (gfc_match (" to %v%t", &expr
) == MATCH_YES
)
2055 if (gfc_notify_std (GFC_STD_F95_DEL
, "Deleted feature: ASSIGN "
2060 expr
->symtree
->n
.sym
->attr
.assign
= 1;
2062 new_st
.op
= EXEC_LABEL_ASSIGN
;
2063 new_st
.label1
= label
;
2064 new_st
.expr1
= expr
;
2072 /* Match the GO TO statement. As a computed GOTO statement is
2073 matched, it is transformed into an equivalent SELECT block. No
2074 tree is necessary, and the resulting jumps-to-jumps are
2075 specifically optimized away by the back end. */
2078 gfc_match_goto (void)
2080 gfc_code
*head
, *tail
;
2083 gfc_st_label
*label
;
2087 if (gfc_match (" %l%t", &label
) == MATCH_YES
)
2089 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
2092 new_st
.op
= EXEC_GOTO
;
2093 new_st
.label1
= label
;
2097 /* The assigned GO TO statement. */
2099 if (gfc_match_variable (&expr
, 0) == MATCH_YES
)
2101 if (gfc_notify_std (GFC_STD_F95_DEL
, "Deleted feature: Assigned GOTO "
2106 new_st
.op
= EXEC_GOTO
;
2107 new_st
.expr1
= expr
;
2109 if (gfc_match_eos () == MATCH_YES
)
2112 /* Match label list. */
2113 gfc_match_char (',');
2114 if (gfc_match_char ('(') != MATCH_YES
)
2116 gfc_syntax_error (ST_GOTO
);
2123 m
= gfc_match_st_label (&label
);
2127 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
2131 head
= tail
= gfc_get_code ();
2134 tail
->block
= gfc_get_code ();
2138 tail
->label1
= label
;
2139 tail
->op
= EXEC_GOTO
;
2141 while (gfc_match_char (',') == MATCH_YES
);
2143 if (gfc_match (")%t") != MATCH_YES
)
2148 gfc_error ("Statement label list in GOTO at %C cannot be empty");
2151 new_st
.block
= head
;
2156 /* Last chance is a computed GO TO statement. */
2157 if (gfc_match_char ('(') != MATCH_YES
)
2159 gfc_syntax_error (ST_GOTO
);
2168 m
= gfc_match_st_label (&label
);
2172 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
2176 head
= tail
= gfc_get_code ();
2179 tail
->block
= gfc_get_code ();
2183 cp
= gfc_get_case ();
2184 cp
->low
= cp
->high
= gfc_int_expr (i
++);
2186 tail
->op
= EXEC_SELECT
;
2187 tail
->ext
.case_list
= cp
;
2189 tail
->next
= gfc_get_code ();
2190 tail
->next
->op
= EXEC_GOTO
;
2191 tail
->next
->label1
= label
;
2193 while (gfc_match_char (',') == MATCH_YES
);
2195 if (gfc_match_char (')') != MATCH_YES
)
2200 gfc_error ("Statement label list in GOTO at %C cannot be empty");
2204 /* Get the rest of the statement. */
2205 gfc_match_char (',');
2207 if (gfc_match (" %e%t", &expr
) != MATCH_YES
)
2210 if (gfc_notify_std (GFC_STD_F95_OBS
, "Obsolescent feature: Computed GOTO "
2211 "at %C") == FAILURE
)
2214 /* At this point, a computed GOTO has been fully matched and an
2215 equivalent SELECT statement constructed. */
2217 new_st
.op
= EXEC_SELECT
;
2218 new_st
.expr1
= NULL
;
2220 /* Hack: For a "real" SELECT, the expression is in expr. We put
2221 it in expr2 so we can distinguish then and produce the correct
2223 new_st
.expr2
= expr
;
2224 new_st
.block
= head
;
2228 gfc_syntax_error (ST_GOTO
);
2230 gfc_free_statements (head
);
2235 /* Frees a list of gfc_alloc structures. */
2238 gfc_free_alloc_list (gfc_alloc
*p
)
2245 gfc_free_expr (p
->expr
);
2251 /* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
2252 an accessible derived type. */
2255 match_derived_type_spec (gfc_typespec
*ts
)
2258 gfc_symbol
*derived
;
2260 old_locus
= gfc_current_locus
;
2262 if (gfc_match_symbol (&derived
, 1) == MATCH_YES
)
2264 if (derived
->attr
.flavor
== FL_DERIVED
)
2266 ts
->type
= BT_DERIVED
;
2267 ts
->u
.derived
= derived
;
2272 /* Enforce F03:C476. */
2273 gfc_error ("'%s' at %L is not an accessible derived type",
2274 derived
->name
, &gfc_current_locus
);
2279 gfc_current_locus
= old_locus
;
2284 /* Match a Fortran 2003 type-spec (F03:R401). This is similar to
2285 gfc_match_decl_type_spec() from decl.c, with the following exceptions:
2286 It only includes the intrinsic types from the Fortran 2003 standard
2287 (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
2288 the implicit_flag is not needed, so it was removed. Derived types are
2289 identified by their name alone. */
2292 match_type_spec (gfc_typespec
*ts
)
2298 old_locus
= gfc_current_locus
;
2300 if (gfc_match ("integer") == MATCH_YES
)
2302 ts
->type
= BT_INTEGER
;
2303 ts
->kind
= gfc_default_integer_kind
;
2307 if (gfc_match ("real") == MATCH_YES
)
2310 ts
->kind
= gfc_default_real_kind
;
2314 if (gfc_match ("double precision") == MATCH_YES
)
2317 ts
->kind
= gfc_default_double_kind
;
2321 if (gfc_match ("complex") == MATCH_YES
)
2323 ts
->type
= BT_COMPLEX
;
2324 ts
->kind
= gfc_default_complex_kind
;
2328 if (gfc_match ("character") == MATCH_YES
)
2330 ts
->type
= BT_CHARACTER
;
2334 if (gfc_match ("logical") == MATCH_YES
)
2336 ts
->type
= BT_LOGICAL
;
2337 ts
->kind
= gfc_default_logical_kind
;
2341 m
= match_derived_type_spec (ts
);
2344 old_locus
= gfc_current_locus
;
2345 if (gfc_match (" :: ") != MATCH_YES
)
2347 gfc_current_locus
= old_locus
;
2348 /* Enfore F03:C401. */
2349 if (ts
->u
.derived
->attr
.abstract
)
2351 gfc_error ("Derived type '%s' at %L may not be ABSTRACT",
2352 ts
->u
.derived
->name
, &old_locus
);
2357 else if (m
== MATCH_ERROR
&& gfc_match (" :: ") == MATCH_YES
)
2360 /* If a type is not matched, simply return MATCH_NO. */
2361 gfc_current_locus
= old_locus
;
2366 gfc_gobble_whitespace ();
2367 if (gfc_peek_ascii_char () == '*')
2369 gfc_error ("Invalid type-spec at %C");
2373 m
= gfc_match_kind_spec (ts
, false);
2376 m
= MATCH_YES
; /* No kind specifier found. */
2382 m
= gfc_match_char_spec (ts
);
2385 m
= MATCH_YES
; /* No kind specifier found. */
2391 /* Match an ALLOCATE statement. */
2394 gfc_match_allocate (void)
2396 gfc_alloc
*head
, *tail
;
2397 gfc_expr
*stat
, *errmsg
, *tmp
, *source
;
2402 bool saw_stat
, saw_errmsg
, saw_source
, b1
, b2
, b3
;
2405 stat
= errmsg
= source
= tmp
= NULL
;
2406 saw_stat
= saw_errmsg
= saw_source
= false;
2408 if (gfc_match_char ('(') != MATCH_YES
)
2411 /* Match an optional type-spec. */
2412 old_locus
= gfc_current_locus
;
2413 m
= match_type_spec (&ts
);
2414 if (m
== MATCH_ERROR
)
2416 else if (m
== MATCH_NO
)
2417 ts
.type
= BT_UNKNOWN
;
2420 if (gfc_match (" :: ") == MATCH_YES
)
2422 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: typespec in "
2423 "ALLOCATE at %L", &old_locus
) == FAILURE
)
2428 ts
.type
= BT_UNKNOWN
;
2429 gfc_current_locus
= old_locus
;
2436 head
= tail
= gfc_get_alloc ();
2439 tail
->next
= gfc_get_alloc ();
2443 m
= gfc_match_variable (&tail
->expr
, 0);
2446 if (m
== MATCH_ERROR
)
2449 if (gfc_check_do_variable (tail
->expr
->symtree
))
2452 if (gfc_pure (NULL
) && gfc_impure_variable (tail
->expr
->symtree
->n
.sym
))
2454 gfc_error ("Bad allocate-object at %C for a PURE procedure");
2458 /* The ALLOCATE statement had an optional typespec. Check the
2460 if (ts
.type
!= BT_UNKNOWN
)
2462 /* Enforce F03:C624. */
2463 if (!gfc_type_compatible (&tail
->expr
->ts
, &ts
))
2465 gfc_error ("Type of entity at %L is type incompatible with "
2466 "typespec", &tail
->expr
->where
);
2470 /* Enforce F03:C627. */
2471 if (ts
.kind
!= tail
->expr
->ts
.kind
)
2473 gfc_error ("Kind type parameter for entity at %L differs from "
2474 "the kind type parameter of the typespec",
2475 &tail
->expr
->where
);
2480 if (tail
->expr
->ts
.type
== BT_DERIVED
)
2481 tail
->expr
->ts
.u
.derived
= gfc_use_derived (tail
->expr
->ts
.u
.derived
);
2483 /* FIXME: disable the checking on derived types and arrays. */
2484 sym
= tail
->expr
->symtree
->n
.sym
;
2485 b1
= !(tail
->expr
->ref
2486 && (tail
->expr
->ref
->type
== REF_COMPONENT
2487 || tail
->expr
->ref
->type
== REF_ARRAY
));
2488 if (sym
&& sym
->ts
.type
== BT_CLASS
)
2489 b2
= !(sym
->ts
.u
.derived
->components
->attr
.allocatable
2490 || sym
->ts
.u
.derived
->components
->attr
.pointer
);
2492 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
2493 || sym
->attr
.proc_pointer
);
2494 b3
= sym
&& sym
->ns
&& sym
->ns
->proc_name
2495 && (sym
->ns
->proc_name
->attr
.allocatable
2496 || sym
->ns
->proc_name
->attr
.pointer
2497 || sym
->ns
->proc_name
->attr
.proc_pointer
);
2498 if (b1
&& b2
&& !b3
)
2500 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
2501 "or an allocatable variable");
2505 if (gfc_peek_ascii_char () == '(' && !sym
->attr
.dimension
)
2507 gfc_error ("Shape specification for allocatable scalar at %C");
2511 if (gfc_match_char (',') != MATCH_YES
)
2516 m
= gfc_match (" stat = %v", &tmp
);
2517 if (m
== MATCH_ERROR
)
2524 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
2531 if (gfc_check_do_variable (stat
->symtree
))
2534 if (gfc_match_char (',') == MATCH_YES
)
2535 goto alloc_opt_list
;
2538 m
= gfc_match (" errmsg = %v", &tmp
);
2539 if (m
== MATCH_ERROR
)
2543 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: ERRMSG tag at %L",
2544 &tmp
->where
) == FAILURE
)
2550 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
2557 if (gfc_match_char (',') == MATCH_YES
)
2558 goto alloc_opt_list
;
2561 m
= gfc_match (" source = %e", &tmp
);
2562 if (m
== MATCH_ERROR
)
2566 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: SOURCE tag at %L",
2567 &tmp
->where
) == FAILURE
)
2573 gfc_error ("Redundant SOURCE tag found at %L ", &tmp
->where
);
2577 /* The next 2 conditionals check C631. */
2578 if (ts
.type
!= BT_UNKNOWN
)
2580 gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
2581 &tmp
->where
, &old_locus
);
2587 gfc_error ("SOURCE tag at %L requires only a single entity in "
2588 "the allocation-list", &tmp
->where
);
2595 if (gfc_match_char (',') == MATCH_YES
)
2596 goto alloc_opt_list
;
2599 gfc_gobble_whitespace ();
2601 if (gfc_peek_char () == ')')
2606 if (gfc_match (" )%t") != MATCH_YES
)
2609 new_st
.op
= EXEC_ALLOCATE
;
2610 new_st
.expr1
= stat
;
2611 new_st
.expr2
= errmsg
;
2612 new_st
.expr3
= source
;
2613 new_st
.ext
.alloc
.list
= head
;
2614 new_st
.ext
.alloc
.ts
= ts
;
2619 gfc_syntax_error (ST_ALLOCATE
);
2622 gfc_free_expr (errmsg
);
2623 gfc_free_expr (source
);
2624 gfc_free_expr (stat
);
2625 gfc_free_expr (tmp
);
2626 gfc_free_alloc_list (head
);
2631 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
2632 a set of pointer assignments to intrinsic NULL(). */
2635 gfc_match_nullify (void)
2643 if (gfc_match_char ('(') != MATCH_YES
)
2648 m
= gfc_match_variable (&p
, 0);
2649 if (m
== MATCH_ERROR
)
2654 if (gfc_check_do_variable (p
->symtree
))
2657 if (gfc_pure (NULL
) && gfc_impure_variable (p
->symtree
->n
.sym
))
2659 gfc_error ("Illegal variable in NULLIFY at %C for a PURE procedure");
2663 /* build ' => NULL() '. */
2664 e
= gfc_get_expr ();
2665 e
->where
= gfc_current_locus
;
2666 e
->expr_type
= EXPR_NULL
;
2667 e
->ts
.type
= BT_UNKNOWN
;
2669 /* Chain to list. */
2674 tail
->next
= gfc_get_code ();
2678 tail
->op
= EXEC_POINTER_ASSIGN
;
2682 if (gfc_match (" )%t") == MATCH_YES
)
2684 if (gfc_match_char (',') != MATCH_YES
)
2691 gfc_syntax_error (ST_NULLIFY
);
2694 gfc_free_statements (new_st
.next
);
2696 gfc_free_expr (new_st
.expr1
);
2697 new_st
.expr1
= NULL
;
2698 gfc_free_expr (new_st
.expr2
);
2699 new_st
.expr2
= NULL
;
2704 /* Match a DEALLOCATE statement. */
2707 gfc_match_deallocate (void)
2709 gfc_alloc
*head
, *tail
;
2710 gfc_expr
*stat
, *errmsg
, *tmp
;
2713 bool saw_stat
, saw_errmsg
, b1
, b2
;
2716 stat
= errmsg
= tmp
= NULL
;
2717 saw_stat
= saw_errmsg
= false;
2719 if (gfc_match_char ('(') != MATCH_YES
)
2725 head
= tail
= gfc_get_alloc ();
2728 tail
->next
= gfc_get_alloc ();
2732 m
= gfc_match_variable (&tail
->expr
, 0);
2733 if (m
== MATCH_ERROR
)
2738 if (gfc_check_do_variable (tail
->expr
->symtree
))
2741 sym
= tail
->expr
->symtree
->n
.sym
;
2743 if (gfc_pure (NULL
) && gfc_impure_variable (sym
))
2745 gfc_error ("Illegal allocate-object at %C for a PURE procedure");
2749 /* FIXME: disable the checking on derived types. */
2750 b1
= !(tail
->expr
->ref
2751 && (tail
->expr
->ref
->type
== REF_COMPONENT
2752 || tail
->expr
->ref
->type
== REF_ARRAY
));
2753 if (sym
&& sym
->ts
.type
== BT_CLASS
)
2754 b2
= !(sym
->ts
.u
.derived
->components
->attr
.allocatable
2755 || sym
->ts
.u
.derived
->components
->attr
.pointer
);
2757 b2
= sym
&& !(sym
->attr
.allocatable
|| sym
->attr
.pointer
2758 || sym
->attr
.proc_pointer
);
2761 gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
2762 "or an allocatable variable");
2766 if (gfc_match_char (',') != MATCH_YES
)
2771 m
= gfc_match (" stat = %v", &tmp
);
2772 if (m
== MATCH_ERROR
)
2778 gfc_error ("Redundant STAT tag found at %L ", &tmp
->where
);
2779 gfc_free_expr (tmp
);
2786 if (gfc_check_do_variable (stat
->symtree
))
2789 if (gfc_match_char (',') == MATCH_YES
)
2790 goto dealloc_opt_list
;
2793 m
= gfc_match (" errmsg = %v", &tmp
);
2794 if (m
== MATCH_ERROR
)
2798 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: ERRMSG at %L",
2799 &tmp
->where
) == FAILURE
)
2804 gfc_error ("Redundant ERRMSG tag found at %L ", &tmp
->where
);
2805 gfc_free_expr (tmp
);
2812 if (gfc_match_char (',') == MATCH_YES
)
2813 goto dealloc_opt_list
;
2816 gfc_gobble_whitespace ();
2818 if (gfc_peek_char () == ')')
2822 if (gfc_match (" )%t") != MATCH_YES
)
2825 new_st
.op
= EXEC_DEALLOCATE
;
2826 new_st
.expr1
= stat
;
2827 new_st
.expr2
= errmsg
;
2828 new_st
.ext
.alloc
.list
= head
;
2833 gfc_syntax_error (ST_DEALLOCATE
);
2836 gfc_free_expr (errmsg
);
2837 gfc_free_expr (stat
);
2838 gfc_free_alloc_list (head
);
2843 /* Match a RETURN statement. */
2846 gfc_match_return (void)
2850 gfc_compile_state s
;
2853 if (gfc_match_eos () == MATCH_YES
)
2856 if (gfc_find_state (COMP_SUBROUTINE
) == FAILURE
)
2858 gfc_error ("Alternate RETURN statement at %C is only allowed within "
2863 if (gfc_notify_std (GFC_STD_F95_OBS
, "Obsolescent feature: Alternate RETURN "
2864 "at %C") == FAILURE
)
2867 if (gfc_current_form
== FORM_FREE
)
2869 /* The following are valid, so we can't require a blank after the
2873 char c
= gfc_peek_ascii_char ();
2874 if (ISALPHA (c
) || ISDIGIT (c
))
2878 m
= gfc_match (" %e%t", &e
);
2881 if (m
== MATCH_ERROR
)
2884 gfc_syntax_error (ST_RETURN
);
2891 gfc_enclosing_unit (&s
);
2892 if (s
== COMP_PROGRAM
2893 && gfc_notify_std (GFC_STD_GNU
, "Extension: RETURN statement in "
2894 "main program at %C") == FAILURE
)
2897 new_st
.op
= EXEC_RETURN
;
2904 /* Match the call of a type-bound procedure, if CALL%var has already been
2905 matched and var found to be a derived-type variable. */
2908 match_typebound_call (gfc_symtree
* varst
)
2913 base
= gfc_get_expr ();
2914 base
->expr_type
= EXPR_VARIABLE
;
2915 base
->symtree
= varst
;
2916 base
->where
= gfc_current_locus
;
2917 gfc_set_sym_referenced (varst
->n
.sym
);
2919 m
= gfc_match_varspec (base
, 0, true, true);
2921 gfc_error ("Expected component reference at %C");
2925 if (gfc_match_eos () != MATCH_YES
)
2927 gfc_error ("Junk after CALL at %C");
2931 if (base
->expr_type
== EXPR_COMPCALL
)
2932 new_st
.op
= EXEC_COMPCALL
;
2933 else if (base
->expr_type
== EXPR_PPC
)
2934 new_st
.op
= EXEC_CALL_PPC
;
2937 gfc_error ("Expected type-bound procedure or procedure pointer component "
2941 new_st
.expr1
= base
;
2947 /* Match a CALL statement. The tricky part here are possible
2948 alternate return specifiers. We handle these by having all
2949 "subroutines" actually return an integer via a register that gives
2950 the return number. If the call specifies alternate returns, we
2951 generate code for a SELECT statement whose case clauses contain
2952 GOTOs to the various labels. */
2955 gfc_match_call (void)
2957 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2958 gfc_actual_arglist
*a
, *arglist
;
2968 m
= gfc_match ("% %n", name
);
2974 if (gfc_get_ha_sym_tree (name
, &st
))
2979 /* If this is a variable of derived-type, it probably starts a type-bound
2981 if ((sym
->attr
.flavor
!= FL_PROCEDURE
2982 || gfc_is_function_return_value (sym
, gfc_current_ns
))
2983 && (sym
->ts
.type
== BT_DERIVED
|| sym
->ts
.type
== BT_CLASS
))
2984 return match_typebound_call (st
);
2986 /* If it does not seem to be callable (include functions so that the
2987 right association is made. They are thrown out in resolution.)
2989 if (!sym
->attr
.generic
2990 && !sym
->attr
.subroutine
2991 && !sym
->attr
.function
)
2993 if (!(sym
->attr
.external
&& !sym
->attr
.referenced
))
2995 /* ...create a symbol in this scope... */
2996 if (sym
->ns
!= gfc_current_ns
2997 && gfc_get_sym_tree (name
, NULL
, &st
, false) == 1)
3000 if (sym
!= st
->n
.sym
)
3004 /* ...and then to try to make the symbol into a subroutine. */
3005 if (gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
3009 gfc_set_sym_referenced (sym
);
3011 if (gfc_match_eos () != MATCH_YES
)
3013 m
= gfc_match_actual_arglist (1, &arglist
);
3016 if (m
== MATCH_ERROR
)
3019 if (gfc_match_eos () != MATCH_YES
)
3023 /* If any alternate return labels were found, construct a SELECT
3024 statement that will jump to the right place. */
3027 for (a
= arglist
; a
; a
= a
->next
)
3028 if (a
->expr
== NULL
)
3033 gfc_symtree
*select_st
;
3034 gfc_symbol
*select_sym
;
3035 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3037 new_st
.next
= c
= gfc_get_code ();
3038 c
->op
= EXEC_SELECT
;
3039 sprintf (name
, "_result_%s", sym
->name
);
3040 gfc_get_ha_sym_tree (name
, &select_st
); /* Can't fail. */
3042 select_sym
= select_st
->n
.sym
;
3043 select_sym
->ts
.type
= BT_INTEGER
;
3044 select_sym
->ts
.kind
= gfc_default_integer_kind
;
3045 gfc_set_sym_referenced (select_sym
);
3046 c
->expr1
= gfc_get_expr ();
3047 c
->expr1
->expr_type
= EXPR_VARIABLE
;
3048 c
->expr1
->symtree
= select_st
;
3049 c
->expr1
->ts
= select_sym
->ts
;
3050 c
->expr1
->where
= gfc_current_locus
;
3053 for (a
= arglist
; a
; a
= a
->next
)
3055 if (a
->expr
!= NULL
)
3058 if (gfc_reference_st_label (a
->label
, ST_LABEL_TARGET
) == FAILURE
)
3063 c
->block
= gfc_get_code ();
3065 c
->op
= EXEC_SELECT
;
3067 new_case
= gfc_get_case ();
3068 new_case
->high
= new_case
->low
= gfc_int_expr (i
);
3069 c
->ext
.case_list
= new_case
;
3071 c
->next
= gfc_get_code ();
3072 c
->next
->op
= EXEC_GOTO
;
3073 c
->next
->label1
= a
->label
;
3077 new_st
.op
= EXEC_CALL
;
3078 new_st
.symtree
= st
;
3079 new_st
.ext
.actual
= arglist
;
3084 gfc_syntax_error (ST_CALL
);
3087 gfc_free_actual_arglist (arglist
);
3092 /* Given a name, return a pointer to the common head structure,
3093 creating it if it does not exist. If FROM_MODULE is nonzero, we
3094 mangle the name so that it doesn't interfere with commons defined
3095 in the using namespace.
3096 TODO: Add to global symbol tree. */
3099 gfc_get_common (const char *name
, int from_module
)
3102 static int serial
= 0;
3103 char mangled_name
[GFC_MAX_SYMBOL_LEN
+ 1];
3107 /* A use associated common block is only needed to correctly layout
3108 the variables it contains. */
3109 snprintf (mangled_name
, GFC_MAX_SYMBOL_LEN
, "_%d_%s", serial
++, name
);
3110 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, mangled_name
);
3114 st
= gfc_find_symtree (gfc_current_ns
->common_root
, name
);
3117 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, name
);
3120 if (st
->n
.common
== NULL
)
3122 st
->n
.common
= gfc_get_common_head ();
3123 st
->n
.common
->where
= gfc_current_locus
;
3124 strcpy (st
->n
.common
->name
, name
);
3127 return st
->n
.common
;
3131 /* Match a common block name. */
3133 match
match_common_name (char *name
)
3137 if (gfc_match_char ('/') == MATCH_NO
)
3143 if (gfc_match_char ('/') == MATCH_YES
)
3149 m
= gfc_match_name (name
);
3151 if (m
== MATCH_ERROR
)
3153 if (m
== MATCH_YES
&& gfc_match_char ('/') == MATCH_YES
)
3156 gfc_error ("Syntax error in common block name at %C");
3161 /* Match a COMMON statement. */
3164 gfc_match_common (void)
3166 gfc_symbol
*sym
, **head
, *tail
, *other
, *old_blank_common
;
3167 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3174 old_blank_common
= gfc_current_ns
->blank_common
.head
;
3175 if (old_blank_common
)
3177 while (old_blank_common
->common_next
)
3178 old_blank_common
= old_blank_common
->common_next
;
3185 m
= match_common_name (name
);
3186 if (m
== MATCH_ERROR
)
3189 gsym
= gfc_get_gsymbol (name
);
3190 if (gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= GSYM_COMMON
)
3192 gfc_error ("Symbol '%s' at %C is already an external symbol that "
3193 "is not COMMON", name
);
3197 if (gsym
->type
== GSYM_UNKNOWN
)
3199 gsym
->type
= GSYM_COMMON
;
3200 gsym
->where
= gfc_current_locus
;
3206 if (name
[0] == '\0')
3208 t
= &gfc_current_ns
->blank_common
;
3209 if (t
->head
== NULL
)
3210 t
->where
= gfc_current_locus
;
3214 t
= gfc_get_common (name
, 0);
3223 while (tail
->common_next
)
3224 tail
= tail
->common_next
;
3227 /* Grab the list of symbols. */
3230 m
= gfc_match_symbol (&sym
, 0);
3231 if (m
== MATCH_ERROR
)
3236 /* Store a ref to the common block for error checking. */
3237 sym
->common_block
= t
;
3239 /* See if we know the current common block is bind(c), and if
3240 so, then see if we can check if the symbol is (which it'll
3241 need to be). This can happen if the bind(c) attr stmt was
3242 applied to the common block, and the variable(s) already
3243 defined, before declaring the common block. */
3244 if (t
->is_bind_c
== 1)
3246 if (sym
->ts
.type
!= BT_UNKNOWN
&& sym
->ts
.is_c_interop
!= 1)
3248 /* If we find an error, just print it and continue,
3249 cause it's just semantic, and we can see if there
3251 gfc_error_now ("Variable '%s' at %L in common block '%s' "
3252 "at %C must be declared with a C "
3253 "interoperable kind since common block "
3255 sym
->name
, &(sym
->declared_at
), t
->name
,
3259 if (sym
->attr
.is_bind_c
== 1)
3260 gfc_error_now ("Variable '%s' in common block "
3261 "'%s' at %C can not be bind(c) since "
3262 "it is not global", sym
->name
, t
->name
);
3265 if (sym
->attr
.in_common
)
3267 gfc_error ("Symbol '%s' at %C is already in a COMMON block",
3272 if (((sym
->value
!= NULL
&& sym
->value
->expr_type
!= EXPR_NULL
)
3273 || sym
->attr
.data
) && gfc_current_state () != COMP_BLOCK_DATA
)
3275 if (gfc_notify_std (GFC_STD_GNU
, "Initialized symbol '%s' at %C "
3276 "can only be COMMON in "
3277 "BLOCK DATA", sym
->name
)
3282 if (gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
3286 tail
->common_next
= sym
;
3292 /* Deal with an optional array specification after the
3294 m
= gfc_match_array_spec (&as
);
3295 if (m
== MATCH_ERROR
)
3300 if (as
->type
!= AS_EXPLICIT
)
3302 gfc_error ("Array specification for symbol '%s' in COMMON "
3303 "at %C must be explicit", sym
->name
);
3307 if (gfc_add_dimension (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
3310 if (sym
->attr
.pointer
)
3312 gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
3313 "POINTER array", sym
->name
);
3322 sym
->common_head
= t
;
3324 /* Check to see if the symbol is already in an equivalence group.
3325 If it is, set the other members as being in common. */
3326 if (sym
->attr
.in_equivalence
)
3328 for (e1
= gfc_current_ns
->equiv
; e1
; e1
= e1
->next
)
3330 for (e2
= e1
; e2
; e2
= e2
->eq
)
3331 if (e2
->expr
->symtree
->n
.sym
== sym
)
3338 for (e2
= e1
; e2
; e2
= e2
->eq
)
3340 other
= e2
->expr
->symtree
->n
.sym
;
3341 if (other
->common_head
3342 && other
->common_head
!= sym
->common_head
)
3344 gfc_error ("Symbol '%s', in COMMON block '%s' at "
3345 "%C is being indirectly equivalenced to "
3346 "another COMMON block '%s'",
3347 sym
->name
, sym
->common_head
->name
,
3348 other
->common_head
->name
);
3351 other
->attr
.in_common
= 1;
3352 other
->common_head
= t
;
3358 gfc_gobble_whitespace ();
3359 if (gfc_match_eos () == MATCH_YES
)
3361 if (gfc_peek_ascii_char () == '/')
3363 if (gfc_match_char (',') != MATCH_YES
)
3365 gfc_gobble_whitespace ();
3366 if (gfc_peek_ascii_char () == '/')
3375 gfc_syntax_error (ST_COMMON
);
3378 if (old_blank_common
)
3379 old_blank_common
->common_next
= NULL
;
3381 gfc_current_ns
->blank_common
.head
= NULL
;
3382 gfc_free_array_spec (as
);
3387 /* Match a BLOCK DATA program unit. */
3390 gfc_match_block_data (void)
3392 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3396 if (gfc_match_eos () == MATCH_YES
)
3398 gfc_new_block
= NULL
;
3402 m
= gfc_match ("% %n%t", name
);
3406 if (gfc_get_symbol (name
, NULL
, &sym
))
3409 if (gfc_add_flavor (&sym
->attr
, FL_BLOCK_DATA
, sym
->name
, NULL
) == FAILURE
)
3412 gfc_new_block
= sym
;
3418 /* Free a namelist structure. */
3421 gfc_free_namelist (gfc_namelist
*name
)
3425 for (; name
; name
= n
)
3433 /* Match a NAMELIST statement. */
3436 gfc_match_namelist (void)
3438 gfc_symbol
*group_name
, *sym
;
3442 m
= gfc_match (" / %s /", &group_name
);
3445 if (m
== MATCH_ERROR
)
3450 if (group_name
->ts
.type
!= BT_UNKNOWN
)
3452 gfc_error ("Namelist group name '%s' at %C already has a basic "
3453 "type of %s", group_name
->name
,
3454 gfc_typename (&group_name
->ts
));
3458 if (group_name
->attr
.flavor
== FL_NAMELIST
3459 && group_name
->attr
.use_assoc
3460 && gfc_notify_std (GFC_STD_GNU
, "Namelist group name '%s' "
3461 "at %C already is USE associated and can"
3462 "not be respecified.", group_name
->name
)
3466 if (group_name
->attr
.flavor
!= FL_NAMELIST
3467 && gfc_add_flavor (&group_name
->attr
, FL_NAMELIST
,
3468 group_name
->name
, NULL
) == FAILURE
)
3473 m
= gfc_match_symbol (&sym
, 1);
3476 if (m
== MATCH_ERROR
)
3479 if (sym
->attr
.in_namelist
== 0
3480 && gfc_add_in_namelist (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
3483 /* Use gfc_error_check here, rather than goto error, so that
3484 these are the only errors for the next two lines. */
3485 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
)
3487 gfc_error ("Assumed size array '%s' in namelist '%s' at "
3488 "%C is not allowed", sym
->name
, group_name
->name
);
3492 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.u
.cl
->length
== NULL
)
3494 gfc_error ("Assumed character length '%s' in namelist '%s' at "
3495 "%C is not allowed", sym
->name
, group_name
->name
);
3499 nl
= gfc_get_namelist ();
3503 if (group_name
->namelist
== NULL
)
3504 group_name
->namelist
= group_name
->namelist_tail
= nl
;
3507 group_name
->namelist_tail
->next
= nl
;
3508 group_name
->namelist_tail
= nl
;
3511 if (gfc_match_eos () == MATCH_YES
)
3514 m
= gfc_match_char (',');
3516 if (gfc_match_char ('/') == MATCH_YES
)
3518 m2
= gfc_match (" %s /", &group_name
);
3519 if (m2
== MATCH_YES
)
3521 if (m2
== MATCH_ERROR
)
3535 gfc_syntax_error (ST_NAMELIST
);
3542 /* Match a MODULE statement. */
3545 gfc_match_module (void)
3549 m
= gfc_match (" %s%t", &gfc_new_block
);
3553 if (gfc_add_flavor (&gfc_new_block
->attr
, FL_MODULE
,
3554 gfc_new_block
->name
, NULL
) == FAILURE
)
3561 /* Free equivalence sets and lists. Recursively is the easiest way to
3565 gfc_free_equiv (gfc_equiv
*eq
)
3570 gfc_free_equiv (eq
->eq
);
3571 gfc_free_equiv (eq
->next
);
3572 gfc_free_expr (eq
->expr
);
3577 /* Match an EQUIVALENCE statement. */
3580 gfc_match_equivalence (void)
3582 gfc_equiv
*eq
, *set
, *tail
;
3586 gfc_common_head
*common_head
= NULL
;
3594 eq
= gfc_get_equiv ();
3598 eq
->next
= gfc_current_ns
->equiv
;
3599 gfc_current_ns
->equiv
= eq
;
3601 if (gfc_match_char ('(') != MATCH_YES
)
3605 common_flag
= FALSE
;
3610 m
= gfc_match_equiv_variable (&set
->expr
);
3611 if (m
== MATCH_ERROR
)
3616 /* count the number of objects. */
3619 if (gfc_match_char ('%') == MATCH_YES
)
3621 gfc_error ("Derived type component %C is not a "
3622 "permitted EQUIVALENCE member");
3626 for (ref
= set
->expr
->ref
; ref
; ref
= ref
->next
)
3627 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
3629 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
3630 "be an array section");
3634 sym
= set
->expr
->symtree
->n
.sym
;
3636 if (gfc_add_in_equivalence (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
3639 if (sym
->attr
.in_common
)
3642 common_head
= sym
->common_head
;
3645 if (gfc_match_char (')') == MATCH_YES
)
3648 if (gfc_match_char (',') != MATCH_YES
)
3651 set
->eq
= gfc_get_equiv ();
3657 gfc_error ("EQUIVALENCE at %C requires two or more objects");
3661 /* If one of the members of an equivalence is in common, then
3662 mark them all as being in common. Before doing this, check
3663 that members of the equivalence group are not in different
3666 for (set
= eq
; set
; set
= set
->eq
)
3668 sym
= set
->expr
->symtree
->n
.sym
;
3669 if (sym
->common_head
&& sym
->common_head
!= common_head
)
3671 gfc_error ("Attempt to indirectly overlap COMMON "
3672 "blocks %s and %s by EQUIVALENCE at %C",
3673 sym
->common_head
->name
, common_head
->name
);
3676 sym
->attr
.in_common
= 1;
3677 sym
->common_head
= common_head
;
3680 if (gfc_match_eos () == MATCH_YES
)
3682 if (gfc_match_char (',') != MATCH_YES
)
3684 gfc_error ("Expecting a comma in EQUIVALENCE at %C");
3692 gfc_syntax_error (ST_EQUIVALENCE
);
3698 gfc_free_equiv (gfc_current_ns
->equiv
);
3699 gfc_current_ns
->equiv
= eq
;
3705 /* Check that a statement function is not recursive. This is done by looking
3706 for the statement function symbol(sym) by looking recursively through its
3707 expression(e). If a reference to sym is found, true is returned.
3708 12.5.4 requires that any variable of function that is implicitly typed
3709 shall have that type confirmed by any subsequent type declaration. The
3710 implicit typing is conveniently done here. */
3712 recursive_stmt_fcn (gfc_expr
*, gfc_symbol
*);
3715 check_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
, int *f ATTRIBUTE_UNUSED
)
3721 switch (e
->expr_type
)
3724 if (e
->symtree
== NULL
)
3727 /* Check the name before testing for nested recursion! */
3728 if (sym
->name
== e
->symtree
->n
.sym
->name
)
3731 /* Catch recursion via other statement functions. */
3732 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
3733 && e
->symtree
->n
.sym
->value
3734 && recursive_stmt_fcn (e
->symtree
->n
.sym
->value
, sym
))
3737 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
3738 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
3743 if (e
->symtree
&& sym
->name
== e
->symtree
->n
.sym
->name
)
3746 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
3747 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
3759 recursive_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
)
3761 return gfc_traverse_expr (e
, sym
, check_stmt_fcn
, 0);
3765 /* Match a statement function declaration. It is so easy to match
3766 non-statement function statements with a MATCH_ERROR as opposed to
3767 MATCH_NO that we suppress error message in most cases. */
3770 gfc_match_st_function (void)
3772 gfc_error_buf old_error
;
3777 m
= gfc_match_symbol (&sym
, 0);
3781 gfc_push_error (&old_error
);
3783 if (gfc_add_procedure (&sym
->attr
, PROC_ST_FUNCTION
,
3784 sym
->name
, NULL
) == FAILURE
)
3787 if (gfc_match_formal_arglist (sym
, 1, 0) != MATCH_YES
)
3790 m
= gfc_match (" = %e%t", &expr
);
3794 gfc_free_error (&old_error
);
3795 if (m
== MATCH_ERROR
)
3798 if (recursive_stmt_fcn (expr
, sym
))
3800 gfc_error ("Statement function at %L is recursive", &expr
->where
);
3806 if (gfc_notify_std (GFC_STD_F95_OBS
, "Obsolescent feature: "
3807 "Statement function at %C") == FAILURE
)
3813 gfc_pop_error (&old_error
);
3818 /***************** SELECT CASE subroutines ******************/
3820 /* Free a single case structure. */
3823 free_case (gfc_case
*p
)
3825 if (p
->low
== p
->high
)
3827 gfc_free_expr (p
->low
);
3828 gfc_free_expr (p
->high
);
3833 /* Free a list of case structures. */
3836 gfc_free_case_list (gfc_case
*p
)
3848 /* Match a single case selector. */
3851 match_case_selector (gfc_case
**cp
)
3856 c
= gfc_get_case ();
3857 c
->where
= gfc_current_locus
;
3859 if (gfc_match_char (':') == MATCH_YES
)
3861 m
= gfc_match_init_expr (&c
->high
);
3864 if (m
== MATCH_ERROR
)
3869 m
= gfc_match_init_expr (&c
->low
);
3870 if (m
== MATCH_ERROR
)
3875 /* If we're not looking at a ':' now, make a range out of a single
3876 target. Else get the upper bound for the case range. */
3877 if (gfc_match_char (':') != MATCH_YES
)
3881 m
= gfc_match_init_expr (&c
->high
);
3882 if (m
== MATCH_ERROR
)
3884 /* MATCH_NO is fine. It's OK if nothing is there! */
3892 gfc_error ("Expected initialization expression in CASE at %C");
3900 /* Match the end of a case statement. */
3903 match_case_eos (void)
3905 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3908 if (gfc_match_eos () == MATCH_YES
)
3911 /* If the case construct doesn't have a case-construct-name, we
3912 should have matched the EOS. */
3913 if (!gfc_current_block ())
3916 gfc_gobble_whitespace ();
3918 m
= gfc_match_name (name
);
3922 if (strcmp (name
, gfc_current_block ()->name
) != 0)
3924 gfc_error ("Expected block name '%s' of SELECT construct at %C",
3925 gfc_current_block ()->name
);
3929 return gfc_match_eos ();
3933 /* Match a SELECT statement. */
3936 gfc_match_select (void)
3941 m
= gfc_match_label ();
3942 if (m
== MATCH_ERROR
)
3945 m
= gfc_match (" select case ( %e )%t", &expr
);
3949 new_st
.op
= EXEC_SELECT
;
3950 new_st
.expr1
= expr
;
3956 /* Push the current selector onto the SELECT TYPE stack. */
3959 select_type_push (gfc_symbol
*sel
)
3961 gfc_select_type_stack
*top
= gfc_get_select_type_stack ();
3962 top
->selector
= sel
;
3964 top
->prev
= select_type_stack
;
3966 select_type_stack
= top
;
3970 /* Set the temporary for the current SELECT TYPE selector. */
3973 select_type_set_tmp (gfc_typespec
*ts
)
3975 char name
[GFC_MAX_SYMBOL_LEN
];
3978 if (!gfc_type_is_extensible (ts
->u
.derived
))
3981 if (ts
->type
== BT_CLASS
)
3982 sprintf (name
, "tmp$class$%s", ts
->u
.derived
->name
);
3984 sprintf (name
, "tmp$type$%s", ts
->u
.derived
->name
);
3985 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp
, false);
3986 gfc_add_type (tmp
->n
.sym
, ts
, NULL
);
3987 gfc_set_sym_referenced (tmp
->n
.sym
);
3988 gfc_add_pointer (&tmp
->n
.sym
->attr
, NULL
);
3989 gfc_add_flavor (&tmp
->n
.sym
->attr
, FL_VARIABLE
, name
, NULL
);
3990 if (ts
->type
== BT_CLASS
)
3992 gfc_build_class_symbol (&tmp
->n
.sym
->ts
, &tmp
->n
.sym
->attr
,
3994 tmp
->n
.sym
->attr
.class_ok
= 1;
3997 select_type_stack
->tmp
= tmp
;
4001 /* Match a SELECT TYPE statement. */
4004 gfc_match_select_type (void)
4006 gfc_expr
*expr1
, *expr2
= NULL
;
4008 char name
[GFC_MAX_SYMBOL_LEN
];
4010 m
= gfc_match_label ();
4011 if (m
== MATCH_ERROR
)
4014 m
= gfc_match (" select type ( ");
4018 gfc_current_ns
= gfc_build_block_ns (gfc_current_ns
);
4020 m
= gfc_match (" %n => %e", name
, &expr2
);
4023 expr1
= gfc_get_expr();
4024 expr1
->expr_type
= EXPR_VARIABLE
;
4025 if (gfc_get_sym_tree (name
, NULL
, &expr1
->symtree
, false))
4027 expr1
->symtree
->n
.sym
->ts
= expr2
->ts
;
4028 expr1
->symtree
->n
.sym
->attr
.referenced
= 1;
4029 expr1
->symtree
->n
.sym
->attr
.class_ok
= 1;
4033 m
= gfc_match (" %e ", &expr1
);
4038 m
= gfc_match (" )%t");
4042 /* Check for F03:C811. */
4043 if (!expr2
&& (expr1
->expr_type
!= EXPR_VARIABLE
|| expr1
->ref
!= NULL
))
4045 gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
4046 "use associate-name=>");
4050 /* Check for F03:C813. */
4051 if (expr1
->ts
.type
!= BT_CLASS
&& !(expr2
&& expr2
->ts
.type
== BT_CLASS
))
4053 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
4058 new_st
.op
= EXEC_SELECT_TYPE
;
4059 new_st
.expr1
= expr1
;
4060 new_st
.expr2
= expr2
;
4061 new_st
.ext
.ns
= gfc_current_ns
;
4063 select_type_push (expr1
->symtree
->n
.sym
);
4069 /* Match a CASE statement. */
4072 gfc_match_case (void)
4074 gfc_case
*c
, *head
, *tail
;
4079 if (gfc_current_state () != COMP_SELECT
)
4081 gfc_error ("Unexpected CASE statement at %C");
4085 if (gfc_match ("% default") == MATCH_YES
)
4087 m
= match_case_eos ();
4090 if (m
== MATCH_ERROR
)
4093 new_st
.op
= EXEC_SELECT
;
4094 c
= gfc_get_case ();
4095 c
->where
= gfc_current_locus
;
4096 new_st
.ext
.case_list
= c
;
4100 if (gfc_match_char ('(') != MATCH_YES
)
4105 if (match_case_selector (&c
) == MATCH_ERROR
)
4115 if (gfc_match_char (')') == MATCH_YES
)
4117 if (gfc_match_char (',') != MATCH_YES
)
4121 m
= match_case_eos ();
4124 if (m
== MATCH_ERROR
)
4127 new_st
.op
= EXEC_SELECT
;
4128 new_st
.ext
.case_list
= head
;
4133 gfc_error ("Syntax error in CASE specification at %C");
4136 gfc_free_case_list (head
); /* new_st is cleaned up in parse.c. */
4141 /* Match a TYPE IS statement. */
4144 gfc_match_type_is (void)
4149 if (gfc_current_state () != COMP_SELECT_TYPE
)
4151 gfc_error ("Unexpected TYPE IS statement at %C");
4155 if (gfc_match_char ('(') != MATCH_YES
)
4158 c
= gfc_get_case ();
4159 c
->where
= gfc_current_locus
;
4161 /* TODO: Once unlimited polymorphism is implemented, we will need to call
4162 match_type_spec here. */
4163 if (match_derived_type_spec (&c
->ts
) == MATCH_ERROR
)
4166 if (gfc_match_char (')') != MATCH_YES
)
4169 m
= match_case_eos ();
4172 if (m
== MATCH_ERROR
)
4175 new_st
.op
= EXEC_SELECT_TYPE
;
4176 new_st
.ext
.case_list
= c
;
4178 /* Create temporary variable. */
4179 select_type_set_tmp (&c
->ts
);
4184 gfc_error ("Syntax error in TYPE IS specification at %C");
4188 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
4193 /* Match a CLASS IS or CLASS DEFAULT statement. */
4196 gfc_match_class_is (void)
4201 if (gfc_current_state () != COMP_SELECT_TYPE
)
4204 if (gfc_match ("% default") == MATCH_YES
)
4206 m
= match_case_eos ();
4209 if (m
== MATCH_ERROR
)
4212 new_st
.op
= EXEC_SELECT_TYPE
;
4213 c
= gfc_get_case ();
4214 c
->where
= gfc_current_locus
;
4215 c
->ts
.type
= BT_UNKNOWN
;
4216 new_st
.ext
.case_list
= c
;
4220 m
= gfc_match ("% is");
4223 if (m
== MATCH_ERROR
)
4226 if (gfc_match_char ('(') != MATCH_YES
)
4229 c
= gfc_get_case ();
4230 c
->where
= gfc_current_locus
;
4232 if (match_derived_type_spec (&c
->ts
) == MATCH_ERROR
)
4235 if (c
->ts
.type
== BT_DERIVED
)
4236 c
->ts
.type
= BT_CLASS
;
4238 if (gfc_match_char (')') != MATCH_YES
)
4241 m
= match_case_eos ();
4244 if (m
== MATCH_ERROR
)
4247 new_st
.op
= EXEC_SELECT_TYPE
;
4248 new_st
.ext
.case_list
= c
;
4250 /* Create temporary variable. */
4251 select_type_set_tmp (&c
->ts
);
4256 gfc_error ("Syntax error in CLASS IS specification at %C");
4260 gfc_free_case_list (c
); /* new_st is cleaned up in parse.c. */
4265 /********************* WHERE subroutines ********************/
4267 /* Match the rest of a simple WHERE statement that follows an IF statement.
4271 match_simple_where (void)
4277 m
= gfc_match (" ( %e )", &expr
);
4281 m
= gfc_match_assignment ();
4284 if (m
== MATCH_ERROR
)
4287 if (gfc_match_eos () != MATCH_YES
)
4290 c
= gfc_get_code ();
4294 c
->next
= gfc_get_code ();
4297 gfc_clear_new_st ();
4299 new_st
.op
= EXEC_WHERE
;
4305 gfc_syntax_error (ST_WHERE
);
4308 gfc_free_expr (expr
);
4313 /* Match a WHERE statement. */
4316 gfc_match_where (gfc_statement
*st
)
4322 m0
= gfc_match_label ();
4323 if (m0
== MATCH_ERROR
)
4326 m
= gfc_match (" where ( %e )", &expr
);
4330 if (gfc_match_eos () == MATCH_YES
)
4332 *st
= ST_WHERE_BLOCK
;
4333 new_st
.op
= EXEC_WHERE
;
4334 new_st
.expr1
= expr
;
4338 m
= gfc_match_assignment ();
4340 gfc_syntax_error (ST_WHERE
);
4344 gfc_free_expr (expr
);
4348 /* We've got a simple WHERE statement. */
4350 c
= gfc_get_code ();
4354 c
->next
= gfc_get_code ();
4357 gfc_clear_new_st ();
4359 new_st
.op
= EXEC_WHERE
;
4366 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
4367 new_st if successful. */
4370 gfc_match_elsewhere (void)
4372 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4376 if (gfc_current_state () != COMP_WHERE
)
4378 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
4384 if (gfc_match_char ('(') == MATCH_YES
)
4386 m
= gfc_match_expr (&expr
);
4389 if (m
== MATCH_ERROR
)
4392 if (gfc_match_char (')') != MATCH_YES
)
4396 if (gfc_match_eos () != MATCH_YES
)
4398 /* Only makes sense if we have a where-construct-name. */
4399 if (!gfc_current_block ())
4404 /* Better be a name at this point. */
4405 m
= gfc_match_name (name
);
4408 if (m
== MATCH_ERROR
)
4411 if (gfc_match_eos () != MATCH_YES
)
4414 if (strcmp (name
, gfc_current_block ()->name
) != 0)
4416 gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
4417 name
, gfc_current_block ()->name
);
4422 new_st
.op
= EXEC_WHERE
;
4423 new_st
.expr1
= expr
;
4427 gfc_syntax_error (ST_ELSEWHERE
);
4430 gfc_free_expr (expr
);
4435 /******************** FORALL subroutines ********************/
4437 /* Free a list of FORALL iterators. */
4440 gfc_free_forall_iterator (gfc_forall_iterator
*iter
)
4442 gfc_forall_iterator
*next
;
4447 gfc_free_expr (iter
->var
);
4448 gfc_free_expr (iter
->start
);
4449 gfc_free_expr (iter
->end
);
4450 gfc_free_expr (iter
->stride
);
4457 /* Match an iterator as part of a FORALL statement. The format is:
4459 <var> = <start>:<end>[:<stride>]
4461 On MATCH_NO, the caller tests for the possibility that there is a
4462 scalar mask expression. */
4465 match_forall_iterator (gfc_forall_iterator
**result
)
4467 gfc_forall_iterator
*iter
;
4471 where
= gfc_current_locus
;
4472 iter
= XCNEW (gfc_forall_iterator
);
4474 m
= gfc_match_expr (&iter
->var
);
4478 if (gfc_match_char ('=') != MATCH_YES
4479 || iter
->var
->expr_type
!= EXPR_VARIABLE
)
4485 m
= gfc_match_expr (&iter
->start
);
4489 if (gfc_match_char (':') != MATCH_YES
)
4492 m
= gfc_match_expr (&iter
->end
);
4495 if (m
== MATCH_ERROR
)
4498 if (gfc_match_char (':') == MATCH_NO
)
4499 iter
->stride
= gfc_int_expr (1);
4502 m
= gfc_match_expr (&iter
->stride
);
4505 if (m
== MATCH_ERROR
)
4509 /* Mark the iteration variable's symbol as used as a FORALL index. */
4510 iter
->var
->symtree
->n
.sym
->forall_index
= true;
4516 gfc_error ("Syntax error in FORALL iterator at %C");
4521 gfc_current_locus
= where
;
4522 gfc_free_forall_iterator (iter
);
4527 /* Match the header of a FORALL statement. */
4530 match_forall_header (gfc_forall_iterator
**phead
, gfc_expr
**mask
)
4532 gfc_forall_iterator
*head
, *tail
, *new_iter
;
4536 gfc_gobble_whitespace ();
4541 if (gfc_match_char ('(') != MATCH_YES
)
4544 m
= match_forall_iterator (&new_iter
);
4545 if (m
== MATCH_ERROR
)
4550 head
= tail
= new_iter
;
4554 if (gfc_match_char (',') != MATCH_YES
)
4557 m
= match_forall_iterator (&new_iter
);
4558 if (m
== MATCH_ERROR
)
4563 tail
->next
= new_iter
;
4568 /* Have to have a mask expression. */
4570 m
= gfc_match_expr (&msk
);
4573 if (m
== MATCH_ERROR
)
4579 if (gfc_match_char (')') == MATCH_NO
)
4587 gfc_syntax_error (ST_FORALL
);
4590 gfc_free_expr (msk
);
4591 gfc_free_forall_iterator (head
);
4596 /* Match the rest of a simple FORALL statement that follows an
4600 match_simple_forall (void)
4602 gfc_forall_iterator
*head
;
4611 m
= match_forall_header (&head
, &mask
);
4618 m
= gfc_match_assignment ();
4620 if (m
== MATCH_ERROR
)
4624 m
= gfc_match_pointer_assignment ();
4625 if (m
== MATCH_ERROR
)
4631 c
= gfc_get_code ();
4633 c
->loc
= gfc_current_locus
;
4635 if (gfc_match_eos () != MATCH_YES
)
4638 gfc_clear_new_st ();
4639 new_st
.op
= EXEC_FORALL
;
4640 new_st
.expr1
= mask
;
4641 new_st
.ext
.forall_iterator
= head
;
4642 new_st
.block
= gfc_get_code ();
4644 new_st
.block
->op
= EXEC_FORALL
;
4645 new_st
.block
->next
= c
;
4650 gfc_syntax_error (ST_FORALL
);
4653 gfc_free_forall_iterator (head
);
4654 gfc_free_expr (mask
);
4660 /* Match a FORALL statement. */
4663 gfc_match_forall (gfc_statement
*st
)
4665 gfc_forall_iterator
*head
;
4674 m0
= gfc_match_label ();
4675 if (m0
== MATCH_ERROR
)
4678 m
= gfc_match (" forall");
4682 m
= match_forall_header (&head
, &mask
);
4683 if (m
== MATCH_ERROR
)
4688 if (gfc_match_eos () == MATCH_YES
)
4690 *st
= ST_FORALL_BLOCK
;
4691 new_st
.op
= EXEC_FORALL
;
4692 new_st
.expr1
= mask
;
4693 new_st
.ext
.forall_iterator
= head
;
4697 m
= gfc_match_assignment ();
4698 if (m
== MATCH_ERROR
)
4702 m
= gfc_match_pointer_assignment ();
4703 if (m
== MATCH_ERROR
)
4709 c
= gfc_get_code ();
4711 c
->loc
= gfc_current_locus
;
4713 gfc_clear_new_st ();
4714 new_st
.op
= EXEC_FORALL
;
4715 new_st
.expr1
= mask
;
4716 new_st
.ext
.forall_iterator
= head
;
4717 new_st
.block
= gfc_get_code ();
4718 new_st
.block
->op
= EXEC_FORALL
;
4719 new_st
.block
->next
= c
;
4725 gfc_syntax_error (ST_FORALL
);
4728 gfc_free_forall_iterator (head
);
4729 gfc_free_expr (mask
);
4730 gfc_free_statements (c
);