1 /* Matching subroutines in all sizes, shapes and colors.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, 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 COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
30 /* For matching and debugging purposes. Order matters here! The
31 unary operators /must/ precede the binary plus and minus, or
32 the expression parser breaks. */
34 mstring intrinsic_operators
[] = {
35 minit ("+", INTRINSIC_UPLUS
),
36 minit ("-", INTRINSIC_UMINUS
),
37 minit ("+", INTRINSIC_PLUS
),
38 minit ("-", INTRINSIC_MINUS
),
39 minit ("**", INTRINSIC_POWER
),
40 minit ("//", INTRINSIC_CONCAT
),
41 minit ("*", INTRINSIC_TIMES
),
42 minit ("/", INTRINSIC_DIVIDE
),
43 minit (".and.", INTRINSIC_AND
),
44 minit (".or.", INTRINSIC_OR
),
45 minit (".eqv.", INTRINSIC_EQV
),
46 minit (".neqv.", INTRINSIC_NEQV
),
47 minit (".eq.", INTRINSIC_EQ
),
48 minit ("==", INTRINSIC_EQ
),
49 minit (".ne.", INTRINSIC_NE
),
50 minit ("/=", INTRINSIC_NE
),
51 minit (".ge.", INTRINSIC_GE
),
52 minit (">=", INTRINSIC_GE
),
53 minit (".le.", INTRINSIC_LE
),
54 minit ("<=", INTRINSIC_LE
),
55 minit (".lt.", INTRINSIC_LT
),
56 minit ("<", INTRINSIC_LT
),
57 minit (".gt.", INTRINSIC_GT
),
58 minit (">", INTRINSIC_GT
),
59 minit (".not.", INTRINSIC_NOT
),
60 minit ("parens", INTRINSIC_PARENTHESES
),
61 minit (NULL
, INTRINSIC_NONE
)
65 /******************** Generic matching subroutines ************************/
67 /* See if the next character is a special character that has
68 escaped by a \ via the -fbackslash option. */
71 gfc_match_special_char (int *c
)
78 switch (gfc_next_char_literal (1))
108 /* Unknown backslash codes are simply not expanded. */
117 /* In free form, match at least one space. Always matches in fixed
121 gfc_match_space (void)
126 if (gfc_current_form
== FORM_FIXED
)
129 old_loc
= gfc_current_locus
;
131 c
= gfc_next_char ();
132 if (!gfc_is_whitespace (c
))
134 gfc_current_locus
= old_loc
;
138 gfc_gobble_whitespace ();
144 /* Match an end of statement. End of statement is optional
145 whitespace, followed by a ';' or '\n' or comment '!'. If a
146 semicolon is found, we continue to eat whitespace and semicolons. */
158 old_loc
= gfc_current_locus
;
159 gfc_gobble_whitespace ();
161 c
= gfc_next_char ();
167 c
= gfc_next_char ();
184 gfc_current_locus
= old_loc
;
185 return (flag
) ? MATCH_YES
: MATCH_NO
;
189 /* Match a literal integer on the input, setting the value on
190 MATCH_YES. Literal ints occur in kind-parameters as well as
191 old-style character length specifications. If cnt is non-NULL it
192 will be set to the number of digits. */
195 gfc_match_small_literal_int (int *value
, int *cnt
)
201 old_loc
= gfc_current_locus
;
203 gfc_gobble_whitespace ();
204 c
= gfc_next_char ();
210 gfc_current_locus
= old_loc
;
219 old_loc
= gfc_current_locus
;
220 c
= gfc_next_char ();
225 i
= 10 * i
+ c
- '0';
230 gfc_error ("Integer too large at %C");
235 gfc_current_locus
= old_loc
;
244 /* Match a small, constant integer expression, like in a kind
245 statement. On MATCH_YES, 'value' is set. */
248 gfc_match_small_int (int *value
)
255 m
= gfc_match_expr (&expr
);
259 p
= gfc_extract_int (expr
, &i
);
260 gfc_free_expr (expr
);
273 /* Matches a statement label. Uses gfc_match_small_literal_int() to
274 do most of the work. */
277 gfc_match_st_label (gfc_st_label
**label
)
283 old_loc
= gfc_current_locus
;
285 m
= gfc_match_small_literal_int (&i
, &cnt
);
291 gfc_error ("Too many digits in statement label at %C");
297 gfc_error ("Statement label at %C is zero");
301 *label
= gfc_get_st_label (i
);
306 gfc_current_locus
= old_loc
;
311 /* Match and validate a label associated with a named IF, DO or SELECT
312 statement. If the symbol does not have the label attribute, we add
313 it. We also make sure the symbol does not refer to another
314 (active) block. A matched label is pointed to by gfc_new_block. */
317 gfc_match_label (void)
319 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
322 gfc_new_block
= NULL
;
324 m
= gfc_match (" %n :", name
);
328 if (gfc_get_symbol (name
, NULL
, &gfc_new_block
))
330 gfc_error ("Label name '%s' at %C is ambiguous", name
);
334 if (gfc_new_block
->attr
.flavor
== FL_LABEL
)
336 gfc_error ("Duplicate construct label '%s' at %C", name
);
340 if (gfc_add_flavor (&gfc_new_block
->attr
, FL_LABEL
,
341 gfc_new_block
->name
, NULL
) == FAILURE
)
348 /* Try and match the input against an array of possibilities. If one
349 potential matching string is a substring of another, the longest
350 match takes precedence. Spaces in the target strings are optional
351 spaces that do not necessarily have to be found in the input
352 stream. In fixed mode, spaces never appear. If whitespace is
353 matched, it matches unlimited whitespace in the input. For this
354 reason, the 'mp' member of the mstring structure is used to track
355 the progress of each potential match.
357 If there is no match we return the tag associated with the
358 terminating NULL mstring structure and leave the locus pointer
359 where it started. If there is a match we return the tag member of
360 the matched mstring and leave the locus pointer after the matched
363 A '%' character is a mandatory space. */
366 gfc_match_strings (mstring
*a
)
368 mstring
*p
, *best_match
;
369 int no_match
, c
, possibles
;
374 for (p
= a
; p
->string
!= NULL
; p
++)
383 match_loc
= gfc_current_locus
;
385 gfc_gobble_whitespace ();
387 while (possibles
> 0)
389 c
= gfc_next_char ();
391 /* Apply the next character to the current possibilities. */
392 for (p
= a
; p
->string
!= NULL
; p
++)
399 /* Space matches 1+ whitespace(s). */
400 if ((gfc_current_form
== FORM_FREE
) && gfc_is_whitespace (c
))
418 match_loc
= gfc_current_locus
;
426 gfc_current_locus
= match_loc
;
428 return (best_match
== NULL
) ? no_match
: best_match
->tag
;
432 /* See if the current input looks like a name of some sort. Modifies
433 the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long.
434 Note that options.c restricts max_identifier_length to not more
435 than GFC_MAX_SYMBOL_LEN. */
438 gfc_match_name (char *buffer
)
443 old_loc
= gfc_current_locus
;
444 gfc_gobble_whitespace ();
446 c
= gfc_next_char ();
447 if (!(ISALPHA (c
) || (c
== '_' && gfc_option
.flag_allow_leading_underscore
)))
449 if (gfc_error_flag_test() == 0)
450 gfc_error ("Invalid character in name at %C");
451 gfc_current_locus
= old_loc
;
461 if (i
> gfc_option
.max_identifier_length
)
463 gfc_error ("Name at %C is too long");
467 old_loc
= gfc_current_locus
;
468 c
= gfc_next_char ();
470 while (ISALNUM (c
) || c
== '_' || (gfc_option
.flag_dollar_ok
&& c
== '$'));
473 gfc_current_locus
= old_loc
;
479 /* Match a symbol on the input. Modifies the pointer to the symbol
480 pointer if successful. */
483 gfc_match_sym_tree (gfc_symtree
**matched_symbol
, int host_assoc
)
485 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
488 m
= gfc_match_name (buffer
);
493 return (gfc_get_ha_sym_tree (buffer
, matched_symbol
))
494 ? MATCH_ERROR
: MATCH_YES
;
496 if (gfc_get_sym_tree (buffer
, NULL
, matched_symbol
))
504 gfc_match_symbol (gfc_symbol
**matched_symbol
, int host_assoc
)
509 m
= gfc_match_sym_tree (&st
, host_assoc
);
514 *matched_symbol
= st
->n
.sym
;
516 *matched_symbol
= NULL
;
519 *matched_symbol
= NULL
;
524 /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
525 we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
529 gfc_match_intrinsic_op (gfc_intrinsic_op
*result
)
533 op
= (gfc_intrinsic_op
) gfc_match_strings (intrinsic_operators
);
535 if (op
== INTRINSIC_NONE
)
543 /* Match a loop control phrase:
545 <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
547 If the final integer expression is not present, a constant unity
548 expression is returned. We don't return MATCH_ERROR until after
549 the equals sign is seen. */
552 gfc_match_iterator (gfc_iterator
*iter
, int init_flag
)
554 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
555 gfc_expr
*var
, *e1
, *e2
, *e3
;
559 /* Match the start of an iterator without affecting the symbol table. */
561 start
= gfc_current_locus
;
562 m
= gfc_match (" %n =", name
);
563 gfc_current_locus
= start
;
568 m
= gfc_match_variable (&var
, 0);
572 gfc_match_char ('=');
576 if (var
->ref
!= NULL
)
578 gfc_error ("Loop variable at %C cannot be a sub-component");
582 if (var
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
584 gfc_error ("Loop variable '%s' at %C cannot be INTENT(IN)",
585 var
->symtree
->n
.sym
->name
);
589 var
->symtree
->n
.sym
->attr
.implied_index
= 1;
591 m
= init_flag
? gfc_match_init_expr (&e1
) : gfc_match_expr (&e1
);
594 if (m
== MATCH_ERROR
)
597 if (gfc_match_char (',') != MATCH_YES
)
600 m
= init_flag
? gfc_match_init_expr (&e2
) : gfc_match_expr (&e2
);
603 if (m
== MATCH_ERROR
)
606 if (gfc_match_char (',') != MATCH_YES
)
608 e3
= gfc_int_expr (1);
612 m
= init_flag
? gfc_match_init_expr (&e3
) : gfc_match_expr (&e3
);
613 if (m
== MATCH_ERROR
)
617 gfc_error ("Expected a step value in iterator at %C");
629 gfc_error ("Syntax error in iterator at %C");
640 /* Tries to match the next non-whitespace character on the input.
641 This subroutine does not return MATCH_ERROR. */
644 gfc_match_char (char c
)
648 where
= gfc_current_locus
;
649 gfc_gobble_whitespace ();
651 if (gfc_next_char () == c
)
654 gfc_current_locus
= where
;
659 /* General purpose matching subroutine. The target string is a
660 scanf-like format string in which spaces correspond to arbitrary
661 whitespace (including no whitespace), characters correspond to
662 themselves. The %-codes are:
664 %% Literal percent sign
665 %e Expression, pointer to a pointer is set
666 %s Symbol, pointer to the symbol is set
667 %n Name, character buffer is set to name
668 %t Matches end of statement.
669 %o Matches an intrinsic operator, returned as an INTRINSIC enum.
670 %l Matches a statement label
671 %v Matches a variable expression (an lvalue)
672 % Matches a required space (in free form) and optional spaces. */
675 gfc_match (const char *target
, ...)
677 gfc_st_label
**label
;
686 old_loc
= gfc_current_locus
;
687 va_start (argp
, target
);
697 gfc_gobble_whitespace ();
708 vp
= va_arg (argp
, void **);
709 n
= gfc_match_expr ((gfc_expr
**) vp
);
720 vp
= va_arg (argp
, void **);
721 n
= gfc_match_variable ((gfc_expr
**) vp
, 0);
732 vp
= va_arg (argp
, void **);
733 n
= gfc_match_symbol ((gfc_symbol
**) vp
, 0);
744 np
= va_arg (argp
, char *);
745 n
= gfc_match_name (np
);
756 label
= va_arg (argp
, gfc_st_label
**);
757 n
= gfc_match_st_label (label
);
768 ip
= va_arg (argp
, int *);
769 n
= gfc_match_intrinsic_op ((gfc_intrinsic_op
*) ip
);
780 if (gfc_match_eos () != MATCH_YES
)
788 if (gfc_match_space () == MATCH_YES
)
794 break; /* Fall through to character matcher. */
797 gfc_internal_error ("gfc_match(): Bad match code %c", c
);
801 if (c
== gfc_next_char ())
811 /* Clean up after a failed match. */
812 gfc_current_locus
= old_loc
;
813 va_start (argp
, target
);
816 for (; matches
> 0; matches
--)
826 /* Matches that don't have to be undone */
831 (void) va_arg (argp
, void **);
836 vp
= va_arg (argp
, void **);
850 /*********************** Statement level matching **********************/
852 /* Matches the start of a program unit, which is the program keyword
853 followed by an obligatory symbol. */
856 gfc_match_program (void)
861 m
= gfc_match ("% %s%t", &sym
);
865 gfc_error ("Invalid form of PROGRAM statement at %C");
869 if (m
== MATCH_ERROR
)
872 if (gfc_add_flavor (&sym
->attr
, FL_PROGRAM
, sym
->name
, NULL
) == FAILURE
)
881 /* Match a simple assignment statement. */
884 gfc_match_assignment (void)
886 gfc_expr
*lvalue
, *rvalue
;
890 old_loc
= gfc_current_locus
;
893 m
= gfc_match (" %v =", &lvalue
);
896 gfc_current_locus
= old_loc
;
897 gfc_free_expr (lvalue
);
901 if (lvalue
->symtree
->n
.sym
->attr
.protected
902 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
)
904 gfc_current_locus
= old_loc
;
905 gfc_free_expr (lvalue
);
906 gfc_error ("Setting value of PROTECTED variable at %C");
911 m
= gfc_match (" %e%t", &rvalue
);
914 gfc_current_locus
= old_loc
;
915 gfc_free_expr (lvalue
);
916 gfc_free_expr (rvalue
);
920 gfc_set_sym_referenced (lvalue
->symtree
->n
.sym
);
922 new_st
.op
= EXEC_ASSIGN
;
923 new_st
.expr
= lvalue
;
924 new_st
.expr2
= rvalue
;
926 gfc_check_do_variable (lvalue
->symtree
);
932 /* Match a pointer assignment statement. */
935 gfc_match_pointer_assignment (void)
937 gfc_expr
*lvalue
, *rvalue
;
941 old_loc
= gfc_current_locus
;
943 lvalue
= rvalue
= NULL
;
945 m
= gfc_match (" %v =>", &lvalue
);
952 m
= gfc_match (" %e%t", &rvalue
);
956 if (lvalue
->symtree
->n
.sym
->attr
.protected
957 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
)
959 gfc_error ("Assigning to a PROTECTED pointer at %C");
964 new_st
.op
= EXEC_POINTER_ASSIGN
;
965 new_st
.expr
= lvalue
;
966 new_st
.expr2
= rvalue
;
971 gfc_current_locus
= old_loc
;
972 gfc_free_expr (lvalue
);
973 gfc_free_expr (rvalue
);
978 /* We try to match an easy arithmetic IF statement. This only happens
979 when just after having encountered a simple IF statement. This code
980 is really duplicate with parts of the gfc_match_if code, but this is
984 match_arithmetic_if (void)
986 gfc_st_label
*l1
, *l2
, *l3
;
990 m
= gfc_match (" ( %e ) %l , %l , %l%t", &expr
, &l1
, &l2
, &l3
);
994 if (gfc_reference_st_label (l1
, ST_LABEL_TARGET
) == FAILURE
995 || gfc_reference_st_label (l2
, ST_LABEL_TARGET
) == FAILURE
996 || gfc_reference_st_label (l3
, ST_LABEL_TARGET
) == FAILURE
)
998 gfc_free_expr (expr
);
1002 if (gfc_notify_std (GFC_STD_F95_OBS
, "Obsolescent: arithmetic IF statement "
1003 "at %C") == FAILURE
)
1006 new_st
.op
= EXEC_ARITHMETIC_IF
;
1016 /* The IF statement is a bit of a pain. First of all, there are three
1017 forms of it, the simple IF, the IF that starts a block and the
1020 There is a problem with the simple IF and that is the fact that we
1021 only have a single level of undo information on symbols. What this
1022 means is for a simple IF, we must re-match the whole IF statement
1023 multiple times in order to guarantee that the symbol table ends up
1024 in the proper state. */
1026 static match
match_simple_forall (void);
1027 static match
match_simple_where (void);
1030 gfc_match_if (gfc_statement
*if_type
)
1033 gfc_st_label
*l1
, *l2
, *l3
;
1038 n
= gfc_match_label ();
1039 if (n
== MATCH_ERROR
)
1042 old_loc
= gfc_current_locus
;
1044 m
= gfc_match (" if ( %e", &expr
);
1048 if (gfc_match_char (')') != MATCH_YES
)
1050 gfc_error ("Syntax error in IF-expression at %C");
1051 gfc_free_expr (expr
);
1055 m
= gfc_match (" %l , %l , %l%t", &l1
, &l2
, &l3
);
1061 gfc_error ("Block label not appropriate for arithmetic IF "
1063 gfc_free_expr (expr
);
1067 if (gfc_reference_st_label (l1
, ST_LABEL_TARGET
) == FAILURE
1068 || gfc_reference_st_label (l2
, ST_LABEL_TARGET
) == FAILURE
1069 || gfc_reference_st_label (l3
, ST_LABEL_TARGET
) == FAILURE
)
1071 gfc_free_expr (expr
);
1075 if (gfc_notify_std (GFC_STD_F95_OBS
, "Obsolescent: arithmetic IF "
1076 "statement at %C") == FAILURE
)
1079 new_st
.op
= EXEC_ARITHMETIC_IF
;
1085 *if_type
= ST_ARITHMETIC_IF
;
1089 if (gfc_match (" then%t") == MATCH_YES
)
1091 new_st
.op
= EXEC_IF
;
1093 *if_type
= ST_IF_BLOCK
;
1099 gfc_error ("Block label is not appropriate IF statement at %C");
1100 gfc_free_expr (expr
);
1104 /* At this point the only thing left is a simple IF statement. At
1105 this point, n has to be MATCH_NO, so we don't have to worry about
1106 re-matching a block label. From what we've got so far, try
1107 matching an assignment. */
1109 *if_type
= ST_SIMPLE_IF
;
1111 m
= gfc_match_assignment ();
1115 gfc_free_expr (expr
);
1116 gfc_undo_symbols ();
1117 gfc_current_locus
= old_loc
;
1119 /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled
1120 assignment was found. For MATCH_NO, continue to call the various
1122 if (m
== MATCH_ERROR
)
1125 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1127 m
= gfc_match_pointer_assignment ();
1131 gfc_free_expr (expr
);
1132 gfc_undo_symbols ();
1133 gfc_current_locus
= old_loc
;
1135 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match. */
1137 /* Look at the next keyword to see which matcher to call. Matching
1138 the keyword doesn't affect the symbol table, so we don't have to
1139 restore between tries. */
1141 #define match(string, subr, statement) \
1142 if (gfc_match(string) == MATCH_YES) { m = subr(); goto got_match; }
1146 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
)
1147 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
)
1148 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
)
1149 match ("call", gfc_match_call
, ST_CALL
)
1150 match ("close", gfc_match_close
, ST_CLOSE
)
1151 match ("continue", gfc_match_continue
, ST_CONTINUE
)
1152 match ("cycle", gfc_match_cycle
, ST_CYCLE
)
1153 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
)
1154 match ("end file", gfc_match_endfile
, ST_END_FILE
)
1155 match ("exit", gfc_match_exit
, ST_EXIT
)
1156 match ("flush", gfc_match_flush
, ST_FLUSH
)
1157 match ("forall", match_simple_forall
, ST_FORALL
)
1158 match ("go to", gfc_match_goto
, ST_GOTO
)
1159 match ("if", match_arithmetic_if
, ST_ARITHMETIC_IF
)
1160 match ("inquire", gfc_match_inquire
, ST_INQUIRE
)
1161 match ("nullify", gfc_match_nullify
, ST_NULLIFY
)
1162 match ("open", gfc_match_open
, ST_OPEN
)
1163 match ("pause", gfc_match_pause
, ST_NONE
)
1164 match ("print", gfc_match_print
, ST_WRITE
)
1165 match ("read", gfc_match_read
, ST_READ
)
1166 match ("return", gfc_match_return
, ST_RETURN
)
1167 match ("rewind", gfc_match_rewind
, ST_REWIND
)
1168 match ("stop", gfc_match_stop
, ST_STOP
)
1169 match ("where", match_simple_where
, ST_WHERE
)
1170 match ("write", gfc_match_write
, ST_WRITE
)
1172 /* The gfc_match_assignment() above may have returned a MATCH_NO
1173 where the assignment was to a named constant. Check that
1174 special case here. */
1175 m
= gfc_match_assignment ();
1178 gfc_error ("Cannot assign to a named constant at %C");
1179 gfc_free_expr (expr
);
1180 gfc_undo_symbols ();
1181 gfc_current_locus
= old_loc
;
1185 /* All else has failed, so give up. See if any of the matchers has
1186 stored an error message of some sort. */
1187 if (gfc_error_check () == 0)
1188 gfc_error ("Unclassifiable statement in IF-clause at %C");
1190 gfc_free_expr (expr
);
1195 gfc_error ("Syntax error in IF-clause at %C");
1198 gfc_free_expr (expr
);
1202 /* At this point, we've matched the single IF and the action clause
1203 is in new_st. Rearrange things so that the IF statement appears
1206 p
= gfc_get_code ();
1207 p
->next
= gfc_get_code ();
1209 p
->next
->loc
= gfc_current_locus
;
1214 gfc_clear_new_st ();
1216 new_st
.op
= EXEC_IF
;
1225 /* Match an ELSE statement. */
1228 gfc_match_else (void)
1230 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1232 if (gfc_match_eos () == MATCH_YES
)
1235 if (gfc_match_name (name
) != MATCH_YES
1236 || gfc_current_block () == NULL
1237 || gfc_match_eos () != MATCH_YES
)
1239 gfc_error ("Unexpected junk after ELSE statement at %C");
1243 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1245 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1246 name
, gfc_current_block ()->name
);
1254 /* Match an ELSE IF statement. */
1257 gfc_match_elseif (void)
1259 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1263 m
= gfc_match (" ( %e ) then", &expr
);
1267 if (gfc_match_eos () == MATCH_YES
)
1270 if (gfc_match_name (name
) != MATCH_YES
1271 || gfc_current_block () == NULL
1272 || gfc_match_eos () != MATCH_YES
)
1274 gfc_error ("Unexpected junk after ELSE IF statement at %C");
1278 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1280 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1281 name
, gfc_current_block ()->name
);
1286 new_st
.op
= EXEC_IF
;
1291 gfc_free_expr (expr
);
1296 /* Free a gfc_iterator structure. */
1299 gfc_free_iterator (gfc_iterator
*iter
, int flag
)
1305 gfc_free_expr (iter
->var
);
1306 gfc_free_expr (iter
->start
);
1307 gfc_free_expr (iter
->end
);
1308 gfc_free_expr (iter
->step
);
1315 /* Match a DO statement. */
1320 gfc_iterator iter
, *ip
;
1322 gfc_st_label
*label
;
1325 old_loc
= gfc_current_locus
;
1328 iter
.var
= iter
.start
= iter
.end
= iter
.step
= NULL
;
1330 m
= gfc_match_label ();
1331 if (m
== MATCH_ERROR
)
1334 if (gfc_match (" do") != MATCH_YES
)
1337 m
= gfc_match_st_label (&label
);
1338 if (m
== MATCH_ERROR
)
1341 /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */
1343 if (gfc_match_eos () == MATCH_YES
)
1345 iter
.end
= gfc_logical_expr (1, NULL
);
1346 new_st
.op
= EXEC_DO_WHILE
;
1350 /* Match an optional comma, if no comma is found, a space is obligatory. */
1351 if (gfc_match_char (',') != MATCH_YES
&& gfc_match ("% ") != MATCH_YES
)
1354 /* See if we have a DO WHILE. */
1355 if (gfc_match (" while ( %e )%t", &iter
.end
) == MATCH_YES
)
1357 new_st
.op
= EXEC_DO_WHILE
;
1361 /* The abortive DO WHILE may have done something to the symbol
1362 table, so we start over. */
1363 gfc_undo_symbols ();
1364 gfc_current_locus
= old_loc
;
1366 gfc_match_label (); /* This won't error. */
1367 gfc_match (" do "); /* This will work. */
1369 gfc_match_st_label (&label
); /* Can't error out. */
1370 gfc_match_char (','); /* Optional comma. */
1372 m
= gfc_match_iterator (&iter
, 0);
1375 if (m
== MATCH_ERROR
)
1378 gfc_check_do_variable (iter
.var
->symtree
);
1380 if (gfc_match_eos () != MATCH_YES
)
1382 gfc_syntax_error (ST_DO
);
1386 new_st
.op
= EXEC_DO
;
1390 && gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
1393 new_st
.label
= label
;
1395 if (new_st
.op
== EXEC_DO_WHILE
)
1396 new_st
.expr
= iter
.end
;
1399 new_st
.ext
.iterator
= ip
= gfc_get_iterator ();
1406 gfc_free_iterator (&iter
, 0);
1412 /* Match an EXIT or CYCLE statement. */
1415 match_exit_cycle (gfc_statement st
, gfc_exec_op op
)
1417 gfc_state_data
*p
, *o
;
1421 if (gfc_match_eos () == MATCH_YES
)
1425 m
= gfc_match ("% %s%t", &sym
);
1426 if (m
== MATCH_ERROR
)
1430 gfc_syntax_error (st
);
1434 if (sym
->attr
.flavor
!= FL_LABEL
)
1436 gfc_error ("Name '%s' in %s statement at %C is not a loop name",
1437 sym
->name
, gfc_ascii_statement (st
));
1442 /* Find the loop mentioned specified by the label (or lack of a label). */
1443 for (o
= NULL
, p
= gfc_state_stack
; p
; p
= p
->previous
)
1444 if (p
->state
== COMP_DO
&& (sym
== NULL
|| sym
== p
->sym
))
1446 else if (o
== NULL
&& p
->state
== COMP_OMP_STRUCTURED_BLOCK
)
1452 gfc_error ("%s statement at %C is not within a loop",
1453 gfc_ascii_statement (st
));
1455 gfc_error ("%s statement at %C is not within loop '%s'",
1456 gfc_ascii_statement (st
), sym
->name
);
1463 gfc_error ("%s statement at %C leaving OpenMP structured block",
1464 gfc_ascii_statement (st
));
1467 else if (st
== ST_EXIT
1468 && p
->previous
!= NULL
1469 && p
->previous
->state
== COMP_OMP_STRUCTURED_BLOCK
1470 && (p
->previous
->head
->op
== EXEC_OMP_DO
1471 || p
->previous
->head
->op
== EXEC_OMP_PARALLEL_DO
))
1473 gcc_assert (p
->previous
->head
->next
!= NULL
);
1474 gcc_assert (p
->previous
->head
->next
->op
== EXEC_DO
1475 || p
->previous
->head
->next
->op
== EXEC_DO_WHILE
);
1476 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
1480 /* Save the first statement in the loop - needed by the backend. */
1481 new_st
.ext
.whichloop
= p
->head
;
1489 /* Match the EXIT statement. */
1492 gfc_match_exit (void)
1494 return match_exit_cycle (ST_EXIT
, EXEC_EXIT
);
1498 /* Match the CYCLE statement. */
1501 gfc_match_cycle (void)
1503 return match_exit_cycle (ST_CYCLE
, EXEC_CYCLE
);
1507 /* Match a number or character constant after a STOP or PAUSE statement. */
1510 gfc_match_stopcode (gfc_statement st
)
1520 if (gfc_match_eos () != MATCH_YES
)
1522 m
= gfc_match_small_literal_int (&stop_code
, &cnt
);
1523 if (m
== MATCH_ERROR
)
1526 if (m
== MATCH_YES
&& cnt
> 5)
1528 gfc_error ("Too many digits in STOP code at %C");
1534 /* Try a character constant. */
1535 m
= gfc_match_expr (&e
);
1536 if (m
== MATCH_ERROR
)
1540 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1544 if (gfc_match_eos () != MATCH_YES
)
1548 if (gfc_pure (NULL
))
1550 gfc_error ("%s statement not allowed in PURE procedure at %C",
1551 gfc_ascii_statement (st
));
1555 new_st
.op
= st
== ST_STOP
? EXEC_STOP
: EXEC_PAUSE
;
1557 new_st
.ext
.stop_code
= stop_code
;
1562 gfc_syntax_error (st
);
1571 /* Match the (deprecated) PAUSE statement. */
1574 gfc_match_pause (void)
1578 m
= gfc_match_stopcode (ST_PAUSE
);
1581 if (gfc_notify_std (GFC_STD_F95_DEL
, "Obsolete: PAUSE statement at %C")
1589 /* Match the STOP statement. */
1592 gfc_match_stop (void)
1594 return gfc_match_stopcode (ST_STOP
);
1598 /* Match a CONTINUE statement. */
1601 gfc_match_continue (void)
1603 if (gfc_match_eos () != MATCH_YES
)
1605 gfc_syntax_error (ST_CONTINUE
);
1609 new_st
.op
= EXEC_CONTINUE
;
1614 /* Match the (deprecated) ASSIGN statement. */
1617 gfc_match_assign (void)
1620 gfc_st_label
*label
;
1622 if (gfc_match (" %l", &label
) == MATCH_YES
)
1624 if (gfc_reference_st_label (label
, ST_LABEL_UNKNOWN
) == FAILURE
)
1626 if (gfc_match (" to %v%t", &expr
) == MATCH_YES
)
1628 if (gfc_notify_std (GFC_STD_F95_DEL
, "Obsolete: ASSIGN "
1633 expr
->symtree
->n
.sym
->attr
.assign
= 1;
1635 new_st
.op
= EXEC_LABEL_ASSIGN
;
1636 new_st
.label
= label
;
1645 /* Match the GO TO statement. As a computed GOTO statement is
1646 matched, it is transformed into an equivalent SELECT block. No
1647 tree is necessary, and the resulting jumps-to-jumps are
1648 specifically optimized away by the back end. */
1651 gfc_match_goto (void)
1653 gfc_code
*head
, *tail
;
1656 gfc_st_label
*label
;
1660 if (gfc_match (" %l%t", &label
) == MATCH_YES
)
1662 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
1665 new_st
.op
= EXEC_GOTO
;
1666 new_st
.label
= label
;
1670 /* The assigned GO TO statement. */
1672 if (gfc_match_variable (&expr
, 0) == MATCH_YES
)
1674 if (gfc_notify_std (GFC_STD_F95_DEL
, "Obsolete: Assigned GOTO "
1679 new_st
.op
= EXEC_GOTO
;
1682 if (gfc_match_eos () == MATCH_YES
)
1685 /* Match label list. */
1686 gfc_match_char (',');
1687 if (gfc_match_char ('(') != MATCH_YES
)
1689 gfc_syntax_error (ST_GOTO
);
1696 m
= gfc_match_st_label (&label
);
1700 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
1704 head
= tail
= gfc_get_code ();
1707 tail
->block
= gfc_get_code ();
1711 tail
->label
= label
;
1712 tail
->op
= EXEC_GOTO
;
1714 while (gfc_match_char (',') == MATCH_YES
);
1716 if (gfc_match (")%t") != MATCH_YES
)
1721 gfc_error ("Statement label list in GOTO at %C cannot be empty");
1724 new_st
.block
= head
;
1729 /* Last chance is a computed GO TO statement. */
1730 if (gfc_match_char ('(') != MATCH_YES
)
1732 gfc_syntax_error (ST_GOTO
);
1741 m
= gfc_match_st_label (&label
);
1745 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
1749 head
= tail
= gfc_get_code ();
1752 tail
->block
= gfc_get_code ();
1756 cp
= gfc_get_case ();
1757 cp
->low
= cp
->high
= gfc_int_expr (i
++);
1759 tail
->op
= EXEC_SELECT
;
1760 tail
->ext
.case_list
= cp
;
1762 tail
->next
= gfc_get_code ();
1763 tail
->next
->op
= EXEC_GOTO
;
1764 tail
->next
->label
= label
;
1766 while (gfc_match_char (',') == MATCH_YES
);
1768 if (gfc_match_char (')') != MATCH_YES
)
1773 gfc_error ("Statement label list in GOTO at %C cannot be empty");
1777 /* Get the rest of the statement. */
1778 gfc_match_char (',');
1780 if (gfc_match (" %e%t", &expr
) != MATCH_YES
)
1783 /* At this point, a computed GOTO has been fully matched and an
1784 equivalent SELECT statement constructed. */
1786 new_st
.op
= EXEC_SELECT
;
1789 /* Hack: For a "real" SELECT, the expression is in expr. We put
1790 it in expr2 so we can distinguish then and produce the correct
1792 new_st
.expr2
= expr
;
1793 new_st
.block
= head
;
1797 gfc_syntax_error (ST_GOTO
);
1799 gfc_free_statements (head
);
1804 /* Frees a list of gfc_alloc structures. */
1807 gfc_free_alloc_list (gfc_alloc
*p
)
1814 gfc_free_expr (p
->expr
);
1820 /* Match an ALLOCATE statement. */
1823 gfc_match_allocate (void)
1825 gfc_alloc
*head
, *tail
;
1832 if (gfc_match_char ('(') != MATCH_YES
)
1838 head
= tail
= gfc_get_alloc ();
1841 tail
->next
= gfc_get_alloc ();
1845 m
= gfc_match_variable (&tail
->expr
, 0);
1848 if (m
== MATCH_ERROR
)
1851 if (gfc_check_do_variable (tail
->expr
->symtree
))
1855 && gfc_impure_variable (tail
->expr
->symtree
->n
.sym
))
1857 gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a "
1862 if (tail
->expr
->ts
.type
== BT_DERIVED
)
1863 tail
->expr
->ts
.derived
= gfc_use_derived (tail
->expr
->ts
.derived
);
1865 if (gfc_match_char (',') != MATCH_YES
)
1868 m
= gfc_match (" stat = %v", &stat
);
1869 if (m
== MATCH_ERROR
)
1877 if (stat
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
1879 gfc_error ("STAT variable '%s' of ALLOCATE statement at %C cannot "
1880 "be INTENT(IN)", stat
->symtree
->n
.sym
->name
);
1884 if (gfc_pure (NULL
) && gfc_impure_variable (stat
->symtree
->n
.sym
))
1886 gfc_error ("Illegal STAT variable in ALLOCATE statement at %C "
1887 "for a PURE procedure");
1891 if (stat
->symtree
->n
.sym
->attr
.flavor
!= FL_VARIABLE
)
1893 gfc_error ("STAT expression at %C must be a variable");
1897 gfc_check_do_variable(stat
->symtree
);
1900 if (gfc_match (" )%t") != MATCH_YES
)
1903 new_st
.op
= EXEC_ALLOCATE
;
1905 new_st
.ext
.alloc_list
= head
;
1910 gfc_syntax_error (ST_ALLOCATE
);
1913 gfc_free_expr (stat
);
1914 gfc_free_alloc_list (head
);
1919 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
1920 a set of pointer assignments to intrinsic NULL(). */
1923 gfc_match_nullify (void)
1931 if (gfc_match_char ('(') != MATCH_YES
)
1936 m
= gfc_match_variable (&p
, 0);
1937 if (m
== MATCH_ERROR
)
1942 if (gfc_check_do_variable (p
->symtree
))
1945 if (gfc_pure (NULL
) && gfc_impure_variable (p
->symtree
->n
.sym
))
1947 gfc_error ("Illegal variable in NULLIFY at %C for a PURE procedure");
1951 /* build ' => NULL() '. */
1952 e
= gfc_get_expr ();
1953 e
->where
= gfc_current_locus
;
1954 e
->expr_type
= EXPR_NULL
;
1955 e
->ts
.type
= BT_UNKNOWN
;
1957 /* Chain to list. */
1962 tail
->next
= gfc_get_code ();
1966 tail
->op
= EXEC_POINTER_ASSIGN
;
1970 if (gfc_match (" )%t") == MATCH_YES
)
1972 if (gfc_match_char (',') != MATCH_YES
)
1979 gfc_syntax_error (ST_NULLIFY
);
1982 gfc_free_statements (new_st
.next
);
1987 /* Match a DEALLOCATE statement. */
1990 gfc_match_deallocate (void)
1992 gfc_alloc
*head
, *tail
;
1999 if (gfc_match_char ('(') != MATCH_YES
)
2005 head
= tail
= gfc_get_alloc ();
2008 tail
->next
= gfc_get_alloc ();
2012 m
= gfc_match_variable (&tail
->expr
, 0);
2013 if (m
== MATCH_ERROR
)
2018 if (gfc_check_do_variable (tail
->expr
->symtree
))
2022 && gfc_impure_variable (tail
->expr
->symtree
->n
.sym
))
2024 gfc_error ("Illegal deallocate-expression in DEALLOCATE at %C "
2025 "for a PURE procedure");
2029 if (gfc_match_char (',') != MATCH_YES
)
2032 m
= gfc_match (" stat = %v", &stat
);
2033 if (m
== MATCH_ERROR
)
2041 if (stat
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
2043 gfc_error ("STAT variable '%s' of DEALLOCATE statement at %C "
2044 "cannot be INTENT(IN)", stat
->symtree
->n
.sym
->name
);
2048 if (gfc_pure(NULL
) && gfc_impure_variable (stat
->symtree
->n
.sym
))
2050 gfc_error ("Illegal STAT variable in DEALLOCATE statement at %C "
2051 "for a PURE procedure");
2055 if (stat
->symtree
->n
.sym
->attr
.flavor
!= FL_VARIABLE
)
2057 gfc_error ("STAT expression at %C must be a variable");
2061 gfc_check_do_variable(stat
->symtree
);
2064 if (gfc_match (" )%t") != MATCH_YES
)
2067 new_st
.op
= EXEC_DEALLOCATE
;
2069 new_st
.ext
.alloc_list
= head
;
2074 gfc_syntax_error (ST_DEALLOCATE
);
2077 gfc_free_expr (stat
);
2078 gfc_free_alloc_list (head
);
2083 /* Match a RETURN statement. */
2086 gfc_match_return (void)
2090 gfc_compile_state s
;
2094 if (gfc_match_eos () == MATCH_YES
)
2097 if (gfc_find_state (COMP_SUBROUTINE
) == FAILURE
)
2099 gfc_error ("Alternate RETURN statement at %C is only allowed within "
2104 if (gfc_current_form
== FORM_FREE
)
2106 /* The following are valid, so we can't require a blank after the
2110 c
= gfc_peek_char ();
2111 if (ISALPHA (c
) || ISDIGIT (c
))
2115 m
= gfc_match (" %e%t", &e
);
2118 if (m
== MATCH_ERROR
)
2121 gfc_syntax_error (ST_RETURN
);
2128 gfc_enclosing_unit (&s
);
2129 if (s
== COMP_PROGRAM
2130 && gfc_notify_std (GFC_STD_GNU
, "Extension: RETURN statement in "
2131 "main program at %C") == FAILURE
)
2134 new_st
.op
= EXEC_RETURN
;
2141 /* Match a CALL statement. The tricky part here are possible
2142 alternate return specifiers. We handle these by having all
2143 "subroutines" actually return an integer via a register that gives
2144 the return number. If the call specifies alternate returns, we
2145 generate code for a SELECT statement whose case clauses contain
2146 GOTOs to the various labels. */
2149 gfc_match_call (void)
2151 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2152 gfc_actual_arglist
*a
, *arglist
;
2162 m
= gfc_match ("% %n", name
);
2168 if (gfc_get_ha_sym_tree (name
, &st
))
2172 gfc_set_sym_referenced (sym
);
2174 if (!sym
->attr
.generic
2175 && !sym
->attr
.subroutine
2176 && gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2179 if (gfc_match_eos () != MATCH_YES
)
2181 m
= gfc_match_actual_arglist (1, &arglist
);
2184 if (m
== MATCH_ERROR
)
2187 if (gfc_match_eos () != MATCH_YES
)
2191 /* If any alternate return labels were found, construct a SELECT
2192 statement that will jump to the right place. */
2195 for (a
= arglist
; a
; a
= a
->next
)
2196 if (a
->expr
== NULL
)
2201 gfc_symtree
*select_st
;
2202 gfc_symbol
*select_sym
;
2203 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2205 new_st
.next
= c
= gfc_get_code ();
2206 c
->op
= EXEC_SELECT
;
2207 sprintf (name
, "_result_%s", sym
->name
);
2208 gfc_get_ha_sym_tree (name
, &select_st
); /* Can't fail. */
2210 select_sym
= select_st
->n
.sym
;
2211 select_sym
->ts
.type
= BT_INTEGER
;
2212 select_sym
->ts
.kind
= gfc_default_integer_kind
;
2213 gfc_set_sym_referenced (select_sym
);
2214 c
->expr
= gfc_get_expr ();
2215 c
->expr
->expr_type
= EXPR_VARIABLE
;
2216 c
->expr
->symtree
= select_st
;
2217 c
->expr
->ts
= select_sym
->ts
;
2218 c
->expr
->where
= gfc_current_locus
;
2221 for (a
= arglist
; a
; a
= a
->next
)
2223 if (a
->expr
!= NULL
)
2226 if (gfc_reference_st_label (a
->label
, ST_LABEL_TARGET
) == FAILURE
)
2231 c
->block
= gfc_get_code ();
2233 c
->op
= EXEC_SELECT
;
2235 new_case
= gfc_get_case ();
2236 new_case
->high
= new_case
->low
= gfc_int_expr (i
);
2237 c
->ext
.case_list
= new_case
;
2239 c
->next
= gfc_get_code ();
2240 c
->next
->op
= EXEC_GOTO
;
2241 c
->next
->label
= a
->label
;
2245 new_st
.op
= EXEC_CALL
;
2246 new_st
.symtree
= st
;
2247 new_st
.ext
.actual
= arglist
;
2252 gfc_syntax_error (ST_CALL
);
2255 gfc_free_actual_arglist (arglist
);
2260 /* Given a name, return a pointer to the common head structure,
2261 creating it if it does not exist. If FROM_MODULE is nonzero, we
2262 mangle the name so that it doesn't interfere with commons defined
2263 in the using namespace.
2264 TODO: Add to global symbol tree. */
2267 gfc_get_common (const char *name
, int from_module
)
2270 static int serial
= 0;
2271 char mangled_name
[GFC_MAX_SYMBOL_LEN
+ 1];
2275 /* A use associated common block is only needed to correctly layout
2276 the variables it contains. */
2277 snprintf (mangled_name
, GFC_MAX_SYMBOL_LEN
, "_%d_%s", serial
++, name
);
2278 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, mangled_name
);
2282 st
= gfc_find_symtree (gfc_current_ns
->common_root
, name
);
2285 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, name
);
2288 if (st
->n
.common
== NULL
)
2290 st
->n
.common
= gfc_get_common_head ();
2291 st
->n
.common
->where
= gfc_current_locus
;
2292 strcpy (st
->n
.common
->name
, name
);
2295 return st
->n
.common
;
2299 /* Match a common block name. */
2302 match_common_name (char *name
)
2306 if (gfc_match_char ('/') == MATCH_NO
)
2312 if (gfc_match_char ('/') == MATCH_YES
)
2318 m
= gfc_match_name (name
);
2320 if (m
== MATCH_ERROR
)
2322 if (m
== MATCH_YES
&& gfc_match_char ('/') == MATCH_YES
)
2325 gfc_error ("Syntax error in common block name at %C");
2330 /* Match a COMMON statement. */
2333 gfc_match_common (void)
2335 gfc_symbol
*sym
, **head
, *tail
, *other
, *old_blank_common
;
2336 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2343 old_blank_common
= gfc_current_ns
->blank_common
.head
;
2344 if (old_blank_common
)
2346 while (old_blank_common
->common_next
)
2347 old_blank_common
= old_blank_common
->common_next
;
2354 m
= match_common_name (name
);
2355 if (m
== MATCH_ERROR
)
2358 gsym
= gfc_get_gsymbol (name
);
2359 if (gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= GSYM_COMMON
)
2361 gfc_error ("Symbol '%s' at %C is already an external symbol that "
2362 "is not COMMON", name
);
2366 if (gsym
->type
== GSYM_UNKNOWN
)
2368 gsym
->type
= GSYM_COMMON
;
2369 gsym
->where
= gfc_current_locus
;
2375 if (name
[0] == '\0')
2377 if (gfc_current_ns
->is_block_data
)
2379 gfc_warning ("BLOCK DATA unit cannot contain blank COMMON "
2382 t
= &gfc_current_ns
->blank_common
;
2383 if (t
->head
== NULL
)
2384 t
->where
= gfc_current_locus
;
2388 t
= gfc_get_common (name
, 0);
2397 while (tail
->common_next
)
2398 tail
= tail
->common_next
;
2401 /* Grab the list of symbols. */
2404 m
= gfc_match_symbol (&sym
, 0);
2405 if (m
== MATCH_ERROR
)
2410 if (sym
->attr
.in_common
)
2412 gfc_error ("Symbol '%s' at %C is already in a COMMON block",
2417 if (gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2420 if (sym
->value
!= NULL
&& sym
->value
->expr_type
!= EXPR_NULL
2421 && (name
[0] == '\0' || !sym
->attr
.data
))
2423 if (name
[0] == '\0')
2424 gfc_error ("Previously initialized symbol '%s' in "
2425 "blank COMMON block at %C", sym
->name
);
2427 gfc_error ("Previously initialized symbol '%s' in "
2428 "COMMON block '%s' at %C", sym
->name
, name
);
2432 if (gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2435 /* Derived type names must have the SEQUENCE attribute. */
2436 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.derived
->attr
.sequence
)
2438 gfc_error ("Derived type variable in COMMON at %C does not "
2439 "have the SEQUENCE attribute");
2444 tail
->common_next
= sym
;
2450 /* Deal with an optional array specification after the
2452 m
= gfc_match_array_spec (&as
);
2453 if (m
== MATCH_ERROR
)
2458 if (as
->type
!= AS_EXPLICIT
)
2460 gfc_error ("Array specification for symbol '%s' in COMMON "
2461 "at %C must be explicit", sym
->name
);
2465 if (gfc_add_dimension (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2468 if (sym
->attr
.pointer
)
2470 gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
2471 "POINTER array", sym
->name
);
2480 sym
->common_head
= t
;
2482 /* Check to see if the symbol is already in an equivalence group.
2483 If it is, set the other members as being in common. */
2484 if (sym
->attr
.in_equivalence
)
2486 for (e1
= gfc_current_ns
->equiv
; e1
; e1
= e1
->next
)
2488 for (e2
= e1
; e2
; e2
= e2
->eq
)
2489 if (e2
->expr
->symtree
->n
.sym
== sym
)
2496 for (e2
= e1
; e2
; e2
= e2
->eq
)
2498 other
= e2
->expr
->symtree
->n
.sym
;
2499 if (other
->common_head
2500 && other
->common_head
!= sym
->common_head
)
2502 gfc_error ("Symbol '%s', in COMMON block '%s' at "
2503 "%C is being indirectly equivalenced to "
2504 "another COMMON block '%s'",
2505 sym
->name
, sym
->common_head
->name
,
2506 other
->common_head
->name
);
2509 other
->attr
.in_common
= 1;
2510 other
->common_head
= t
;
2516 gfc_gobble_whitespace ();
2517 if (gfc_match_eos () == MATCH_YES
)
2519 if (gfc_peek_char () == '/')
2521 if (gfc_match_char (',') != MATCH_YES
)
2523 gfc_gobble_whitespace ();
2524 if (gfc_peek_char () == '/')
2533 gfc_syntax_error (ST_COMMON
);
2536 if (old_blank_common
)
2537 old_blank_common
->common_next
= NULL
;
2539 gfc_current_ns
->blank_common
.head
= NULL
;
2540 gfc_free_array_spec (as
);
2545 /* Match a BLOCK DATA program unit. */
2548 gfc_match_block_data (void)
2550 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2554 if (gfc_match_eos () == MATCH_YES
)
2556 gfc_new_block
= NULL
;
2560 m
= gfc_match ("% %n%t", name
);
2564 if (gfc_get_symbol (name
, NULL
, &sym
))
2567 if (gfc_add_flavor (&sym
->attr
, FL_BLOCK_DATA
, sym
->name
, NULL
) == FAILURE
)
2570 gfc_new_block
= sym
;
2576 /* Free a namelist structure. */
2579 gfc_free_namelist (gfc_namelist
*name
)
2583 for (; name
; name
= n
)
2591 /* Match a NAMELIST statement. */
2594 gfc_match_namelist (void)
2596 gfc_symbol
*group_name
, *sym
;
2600 m
= gfc_match (" / %s /", &group_name
);
2603 if (m
== MATCH_ERROR
)
2608 if (group_name
->ts
.type
!= BT_UNKNOWN
)
2610 gfc_error ("Namelist group name '%s' at %C already has a basic "
2611 "type of %s", group_name
->name
,
2612 gfc_typename (&group_name
->ts
));
2616 if (group_name
->attr
.flavor
== FL_NAMELIST
2617 && group_name
->attr
.use_assoc
2618 && gfc_notify_std (GFC_STD_GNU
, "Namelist group name '%s' "
2619 "at %C already is USE associated and can"
2620 "not be respecified.", group_name
->name
)
2624 if (group_name
->attr
.flavor
!= FL_NAMELIST
2625 && gfc_add_flavor (&group_name
->attr
, FL_NAMELIST
,
2626 group_name
->name
, NULL
) == FAILURE
)
2631 m
= gfc_match_symbol (&sym
, 1);
2634 if (m
== MATCH_ERROR
)
2637 if (sym
->attr
.in_namelist
== 0
2638 && gfc_add_in_namelist (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2641 /* Use gfc_error_check here, rather than goto error, so that
2642 these are the only errors for the next two lines. */
2643 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
)
2645 gfc_error ("Assumed size array '%s' in namelist '%s' at "
2646 "%C is not allowed", sym
->name
, group_name
->name
);
2650 if (sym
->ts
.type
== BT_CHARACTER
&& sym
->ts
.cl
->length
== NULL
)
2652 gfc_error ("Assumed character length '%s' in namelist '%s' at "
2653 "%C is not allowed", sym
->name
, group_name
->name
);
2657 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SHAPE
2658 && gfc_notify_std (GFC_STD_GNU
, "Assumed shape array '%s' in "
2659 "namelist '%s' at %C is an extension.",
2660 sym
->name
, group_name
->name
) == FAILURE
)
2663 nl
= gfc_get_namelist ();
2667 if (group_name
->namelist
== NULL
)
2668 group_name
->namelist
= group_name
->namelist_tail
= nl
;
2671 group_name
->namelist_tail
->next
= nl
;
2672 group_name
->namelist_tail
= nl
;
2675 if (gfc_match_eos () == MATCH_YES
)
2678 m
= gfc_match_char (',');
2680 if (gfc_match_char ('/') == MATCH_YES
)
2682 m2
= gfc_match (" %s /", &group_name
);
2683 if (m2
== MATCH_YES
)
2685 if (m2
== MATCH_ERROR
)
2699 gfc_syntax_error (ST_NAMELIST
);
2706 /* Match a MODULE statement. */
2709 gfc_match_module (void)
2713 m
= gfc_match (" %s%t", &gfc_new_block
);
2717 if (gfc_add_flavor (&gfc_new_block
->attr
, FL_MODULE
,
2718 gfc_new_block
->name
, NULL
) == FAILURE
)
2725 /* Free equivalence sets and lists. Recursively is the easiest way to
2729 gfc_free_equiv (gfc_equiv
*eq
)
2734 gfc_free_equiv (eq
->eq
);
2735 gfc_free_equiv (eq
->next
);
2736 gfc_free_expr (eq
->expr
);
2741 /* Match an EQUIVALENCE statement. */
2744 gfc_match_equivalence (void)
2746 gfc_equiv
*eq
, *set
, *tail
;
2750 gfc_common_head
*common_head
= NULL
;
2758 eq
= gfc_get_equiv ();
2762 eq
->next
= gfc_current_ns
->equiv
;
2763 gfc_current_ns
->equiv
= eq
;
2765 if (gfc_match_char ('(') != MATCH_YES
)
2769 common_flag
= FALSE
;
2774 m
= gfc_match_equiv_variable (&set
->expr
);
2775 if (m
== MATCH_ERROR
)
2780 /* count the number of objects. */
2783 if (gfc_match_char ('%') == MATCH_YES
)
2785 gfc_error ("Derived type component %C is not a "
2786 "permitted EQUIVALENCE member");
2790 for (ref
= set
->expr
->ref
; ref
; ref
= ref
->next
)
2791 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2793 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
2794 "be an array section");
2798 sym
= set
->expr
->symtree
->n
.sym
;
2800 if (gfc_add_in_equivalence (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2803 if (sym
->attr
.in_common
)
2806 common_head
= sym
->common_head
;
2809 if (gfc_match_char (')') == MATCH_YES
)
2812 if (gfc_match_char (',') != MATCH_YES
)
2815 set
->eq
= gfc_get_equiv ();
2821 gfc_error ("EQUIVALENCE at %C requires two or more objects");
2825 /* If one of the members of an equivalence is in common, then
2826 mark them all as being in common. Before doing this, check
2827 that members of the equivalence group are not in different
2830 for (set
= eq
; set
; set
= set
->eq
)
2832 sym
= set
->expr
->symtree
->n
.sym
;
2833 if (sym
->common_head
&& sym
->common_head
!= common_head
)
2835 gfc_error ("Attempt to indirectly overlap COMMON "
2836 "blocks %s and %s by EQUIVALENCE at %C",
2837 sym
->common_head
->name
, common_head
->name
);
2840 sym
->attr
.in_common
= 1;
2841 sym
->common_head
= common_head
;
2844 if (gfc_match_eos () == MATCH_YES
)
2846 if (gfc_match_char (',') != MATCH_YES
)
2853 gfc_syntax_error (ST_EQUIVALENCE
);
2859 gfc_free_equiv (gfc_current_ns
->equiv
);
2860 gfc_current_ns
->equiv
= eq
;
2866 /* Check that a statement function is not recursive. This is done by looking
2867 for the statement function symbol(sym) by looking recursively through its
2868 expression(e). If a reference to sym is found, true is returned.
2869 12.5.4 requires that any variable of function that is implicitly typed
2870 shall have that type confirmed by any subsequent type declaration. The
2871 implicit typing is conveniently done here. */
2874 recursive_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
)
2876 gfc_actual_arglist
*arg
;
2883 switch (e
->expr_type
)
2886 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
2888 if (sym
->name
== arg
->name
|| recursive_stmt_fcn (arg
->expr
, sym
))
2892 if (e
->symtree
== NULL
)
2895 /* Check the name before testing for nested recursion! */
2896 if (sym
->name
== e
->symtree
->n
.sym
->name
)
2899 /* Catch recursion via other statement functions. */
2900 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
2901 && e
->symtree
->n
.sym
->value
2902 && recursive_stmt_fcn (e
->symtree
->n
.sym
->value
, sym
))
2905 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
2906 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
2911 if (e
->symtree
&& sym
->name
== e
->symtree
->n
.sym
->name
)
2914 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
2915 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
2919 if (recursive_stmt_fcn (e
->value
.op
.op1
, sym
)
2920 || recursive_stmt_fcn (e
->value
.op
.op2
, sym
))
2928 /* Component references do not need to be checked. */
2931 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2936 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2938 if (recursive_stmt_fcn (ref
->u
.ar
.start
[i
], sym
)
2939 || recursive_stmt_fcn (ref
->u
.ar
.end
[i
], sym
)
2940 || recursive_stmt_fcn (ref
->u
.ar
.stride
[i
], sym
))
2946 if (recursive_stmt_fcn (ref
->u
.ss
.start
, sym
)
2947 || recursive_stmt_fcn (ref
->u
.ss
.end
, sym
))
2961 /* Match a statement function declaration. It is so easy to match
2962 non-statement function statements with a MATCH_ERROR as opposed to
2963 MATCH_NO that we suppress error message in most cases. */
2966 gfc_match_st_function (void)
2968 gfc_error_buf old_error
;
2973 m
= gfc_match_symbol (&sym
, 0);
2977 gfc_push_error (&old_error
);
2979 if (gfc_add_procedure (&sym
->attr
, PROC_ST_FUNCTION
,
2980 sym
->name
, NULL
) == FAILURE
)
2983 if (gfc_match_formal_arglist (sym
, 1, 0) != MATCH_YES
)
2986 m
= gfc_match (" = %e%t", &expr
);
2990 gfc_free_error (&old_error
);
2991 if (m
== MATCH_ERROR
)
2994 if (recursive_stmt_fcn (expr
, sym
))
2996 gfc_error ("Statement function at %L is recursive", &expr
->where
);
3005 gfc_pop_error (&old_error
);
3010 /***************** SELECT CASE subroutines ******************/
3012 /* Free a single case structure. */
3015 free_case (gfc_case
*p
)
3017 if (p
->low
== p
->high
)
3019 gfc_free_expr (p
->low
);
3020 gfc_free_expr (p
->high
);
3025 /* Free a list of case structures. */
3028 gfc_free_case_list (gfc_case
*p
)
3040 /* Match a single case selector. */
3043 match_case_selector (gfc_case
**cp
)
3048 c
= gfc_get_case ();
3049 c
->where
= gfc_current_locus
;
3051 if (gfc_match_char (':') == MATCH_YES
)
3053 m
= gfc_match_init_expr (&c
->high
);
3056 if (m
== MATCH_ERROR
)
3061 m
= gfc_match_init_expr (&c
->low
);
3062 if (m
== MATCH_ERROR
)
3067 /* If we're not looking at a ':' now, make a range out of a single
3068 target. Else get the upper bound for the case range. */
3069 if (gfc_match_char (':') != MATCH_YES
)
3073 m
= gfc_match_init_expr (&c
->high
);
3074 if (m
== MATCH_ERROR
)
3076 /* MATCH_NO is fine. It's OK if nothing is there! */
3084 gfc_error ("Expected initialization expression in CASE at %C");
3092 /* Match the end of a case statement. */
3095 match_case_eos (void)
3097 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3100 if (gfc_match_eos () == MATCH_YES
)
3103 /* If the case construct doesn't have a case-construct-name, we
3104 should have matched the EOS. */
3105 if (!gfc_current_block ())
3107 gfc_error ("Expected the name of the SELECT CASE construct at %C");
3111 gfc_gobble_whitespace ();
3113 m
= gfc_match_name (name
);
3117 if (strcmp (name
, gfc_current_block ()->name
) != 0)
3119 gfc_error ("Expected case name of '%s' at %C",
3120 gfc_current_block ()->name
);
3124 return gfc_match_eos ();
3128 /* Match a SELECT statement. */
3131 gfc_match_select (void)
3136 m
= gfc_match_label ();
3137 if (m
== MATCH_ERROR
)
3140 m
= gfc_match (" select case ( %e )%t", &expr
);
3144 new_st
.op
= EXEC_SELECT
;
3151 /* Match a CASE statement. */
3154 gfc_match_case (void)
3156 gfc_case
*c
, *head
, *tail
;
3161 if (gfc_current_state () != COMP_SELECT
)
3163 gfc_error ("Unexpected CASE statement at %C");
3167 if (gfc_match ("% default") == MATCH_YES
)
3169 m
= match_case_eos ();
3172 if (m
== MATCH_ERROR
)
3175 new_st
.op
= EXEC_SELECT
;
3176 c
= gfc_get_case ();
3177 c
->where
= gfc_current_locus
;
3178 new_st
.ext
.case_list
= c
;
3182 if (gfc_match_char ('(') != MATCH_YES
)
3187 if (match_case_selector (&c
) == MATCH_ERROR
)
3197 if (gfc_match_char (')') == MATCH_YES
)
3199 if (gfc_match_char (',') != MATCH_YES
)
3203 m
= match_case_eos ();
3206 if (m
== MATCH_ERROR
)
3209 new_st
.op
= EXEC_SELECT
;
3210 new_st
.ext
.case_list
= head
;
3215 gfc_error ("Syntax error in CASE-specification at %C");
3218 gfc_free_case_list (head
); /* new_st is cleaned up in parse.c. */
3222 /********************* WHERE subroutines ********************/
3224 /* Match the rest of a simple WHERE statement that follows an IF statement.
3228 match_simple_where (void)
3234 m
= gfc_match (" ( %e )", &expr
);
3238 m
= gfc_match_assignment ();
3241 if (m
== MATCH_ERROR
)
3244 if (gfc_match_eos () != MATCH_YES
)
3247 c
= gfc_get_code ();
3251 c
->next
= gfc_get_code ();
3254 gfc_clear_new_st ();
3256 new_st
.op
= EXEC_WHERE
;
3262 gfc_syntax_error (ST_WHERE
);
3265 gfc_free_expr (expr
);
3270 /* Match a WHERE statement. */
3273 gfc_match_where (gfc_statement
*st
)
3279 m0
= gfc_match_label ();
3280 if (m0
== MATCH_ERROR
)
3283 m
= gfc_match (" where ( %e )", &expr
);
3287 if (gfc_match_eos () == MATCH_YES
)
3289 *st
= ST_WHERE_BLOCK
;
3290 new_st
.op
= EXEC_WHERE
;
3295 m
= gfc_match_assignment ();
3297 gfc_syntax_error (ST_WHERE
);
3301 gfc_free_expr (expr
);
3305 /* We've got a simple WHERE statement. */
3307 c
= gfc_get_code ();
3311 c
->next
= gfc_get_code ();
3314 gfc_clear_new_st ();
3316 new_st
.op
= EXEC_WHERE
;
3323 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
3324 new_st if successful. */
3327 gfc_match_elsewhere (void)
3329 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3333 if (gfc_current_state () != COMP_WHERE
)
3335 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
3341 if (gfc_match_char ('(') == MATCH_YES
)
3343 m
= gfc_match_expr (&expr
);
3346 if (m
== MATCH_ERROR
)
3349 if (gfc_match_char (')') != MATCH_YES
)
3353 if (gfc_match_eos () != MATCH_YES
)
3355 /* Only makes sense if we have a where-construct-name. */
3356 if (!gfc_current_block ())
3361 /* Better be a name at this point. */
3362 m
= gfc_match_name (name
);
3365 if (m
== MATCH_ERROR
)
3368 if (gfc_match_eos () != MATCH_YES
)
3371 if (strcmp (name
, gfc_current_block ()->name
) != 0)
3373 gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
3374 name
, gfc_current_block ()->name
);
3379 new_st
.op
= EXEC_WHERE
;
3384 gfc_syntax_error (ST_ELSEWHERE
);
3387 gfc_free_expr (expr
);
3392 /******************** FORALL subroutines ********************/
3394 /* Free a list of FORALL iterators. */
3397 gfc_free_forall_iterator (gfc_forall_iterator
*iter
)
3399 gfc_forall_iterator
*next
;
3404 gfc_free_expr (iter
->var
);
3405 gfc_free_expr (iter
->start
);
3406 gfc_free_expr (iter
->end
);
3407 gfc_free_expr (iter
->stride
);
3414 /* Match an iterator as part of a FORALL statement. The format is:
3416 <var> = <start>:<end>[:<stride>]
3418 On MATCH_NO, the caller tests for the possibility that there is a
3419 scalar mask expression. */
3422 match_forall_iterator (gfc_forall_iterator
**result
)
3424 gfc_forall_iterator
*iter
;
3428 where
= gfc_current_locus
;
3429 iter
= gfc_getmem (sizeof (gfc_forall_iterator
));
3431 m
= gfc_match_expr (&iter
->var
);
3435 if (gfc_match_char ('=') != MATCH_YES
3436 || iter
->var
->expr_type
!= EXPR_VARIABLE
)
3442 m
= gfc_match_expr (&iter
->start
);
3446 if (gfc_match_char (':') != MATCH_YES
)
3449 m
= gfc_match_expr (&iter
->end
);
3452 if (m
== MATCH_ERROR
)
3455 if (gfc_match_char (':') == MATCH_NO
)
3456 iter
->stride
= gfc_int_expr (1);
3459 m
= gfc_match_expr (&iter
->stride
);
3462 if (m
== MATCH_ERROR
)
3466 /* Mark the iteration variable's symbol as used as a FORALL index. */
3467 iter
->var
->symtree
->n
.sym
->forall_index
= true;
3473 gfc_error ("Syntax error in FORALL iterator at %C");
3478 gfc_current_locus
= where
;
3479 gfc_free_forall_iterator (iter
);
3484 /* Match the header of a FORALL statement. */
3487 match_forall_header (gfc_forall_iterator
**phead
, gfc_expr
**mask
)
3489 gfc_forall_iterator
*head
, *tail
, *new;
3493 gfc_gobble_whitespace ();
3498 if (gfc_match_char ('(') != MATCH_YES
)
3501 m
= match_forall_iterator (&new);
3502 if (m
== MATCH_ERROR
)
3511 if (gfc_match_char (',') != MATCH_YES
)
3514 m
= match_forall_iterator (&new);
3515 if (m
== MATCH_ERROR
)
3525 /* Have to have a mask expression. */
3527 m
= gfc_match_expr (&msk
);
3530 if (m
== MATCH_ERROR
)
3536 if (gfc_match_char (')') == MATCH_NO
)
3544 gfc_syntax_error (ST_FORALL
);
3547 gfc_free_expr (msk
);
3548 gfc_free_forall_iterator (head
);
3553 /* Match the rest of a simple FORALL statement that follows an
3557 match_simple_forall (void)
3559 gfc_forall_iterator
*head
;
3568 m
= match_forall_header (&head
, &mask
);
3575 m
= gfc_match_assignment ();
3577 if (m
== MATCH_ERROR
)
3581 m
= gfc_match_pointer_assignment ();
3582 if (m
== MATCH_ERROR
)
3588 c
= gfc_get_code ();
3590 c
->loc
= gfc_current_locus
;
3592 if (gfc_match_eos () != MATCH_YES
)
3595 gfc_clear_new_st ();
3596 new_st
.op
= EXEC_FORALL
;
3598 new_st
.ext
.forall_iterator
= head
;
3599 new_st
.block
= gfc_get_code ();
3601 new_st
.block
->op
= EXEC_FORALL
;
3602 new_st
.block
->next
= c
;
3607 gfc_syntax_error (ST_FORALL
);
3610 gfc_free_forall_iterator (head
);
3611 gfc_free_expr (mask
);
3617 /* Match a FORALL statement. */
3620 gfc_match_forall (gfc_statement
*st
)
3622 gfc_forall_iterator
*head
;
3631 m0
= gfc_match_label ();
3632 if (m0
== MATCH_ERROR
)
3635 m
= gfc_match (" forall");
3639 m
= match_forall_header (&head
, &mask
);
3640 if (m
== MATCH_ERROR
)
3645 if (gfc_match_eos () == MATCH_YES
)
3647 *st
= ST_FORALL_BLOCK
;
3648 new_st
.op
= EXEC_FORALL
;
3650 new_st
.ext
.forall_iterator
= head
;
3654 m
= gfc_match_assignment ();
3655 if (m
== MATCH_ERROR
)
3659 m
= gfc_match_pointer_assignment ();
3660 if (m
== MATCH_ERROR
)
3666 c
= gfc_get_code ();
3668 c
->loc
= gfc_current_locus
;
3670 gfc_clear_new_st ();
3671 new_st
.op
= EXEC_FORALL
;
3673 new_st
.ext
.forall_iterator
= head
;
3674 new_st
.block
= gfc_get_code ();
3675 new_st
.block
->op
= EXEC_FORALL
;
3676 new_st
.block
->next
= c
;
3682 gfc_syntax_error (ST_FORALL
);
3685 gfc_free_forall_iterator (head
);
3686 gfc_free_expr (mask
);
3687 gfc_free_statements (c
);