1 /* Matching subroutines in all sizes, shapes and colors.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software
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
31 /* For matching and debugging purposes. Order matters here! The
32 unary operators /must/ precede the binary plus and minus, or
33 the expression parser breaks. */
35 mstring intrinsic_operators
[] = {
36 minit ("+", INTRINSIC_UPLUS
),
37 minit ("-", INTRINSIC_UMINUS
),
38 minit ("+", INTRINSIC_PLUS
),
39 minit ("-", INTRINSIC_MINUS
),
40 minit ("**", INTRINSIC_POWER
),
41 minit ("//", INTRINSIC_CONCAT
),
42 minit ("*", INTRINSIC_TIMES
),
43 minit ("/", INTRINSIC_DIVIDE
),
44 minit (".and.", INTRINSIC_AND
),
45 minit (".or.", INTRINSIC_OR
),
46 minit (".eqv.", INTRINSIC_EQV
),
47 minit (".neqv.", INTRINSIC_NEQV
),
48 minit (".eq.", INTRINSIC_EQ
),
49 minit ("==", INTRINSIC_EQ
),
50 minit (".ne.", INTRINSIC_NE
),
51 minit ("/=", INTRINSIC_NE
),
52 minit (".ge.", INTRINSIC_GE
),
53 minit (">=", INTRINSIC_GE
),
54 minit (".le.", INTRINSIC_LE
),
55 minit ("<=", INTRINSIC_LE
),
56 minit (".lt.", INTRINSIC_LT
),
57 minit ("<", INTRINSIC_LT
),
58 minit (".gt.", INTRINSIC_GT
),
59 minit (">", INTRINSIC_GT
),
60 minit (".not.", INTRINSIC_NOT
),
61 minit ("parens", INTRINSIC_PARENTHESES
),
62 minit (NULL
, INTRINSIC_NONE
)
66 /******************** Generic matching subroutines ************************/
68 /* In free form, match at least one space. Always matches in fixed
72 gfc_match_space (void)
77 if (gfc_current_form
== FORM_FIXED
)
80 old_loc
= gfc_current_locus
;
83 if (!gfc_is_whitespace (c
))
85 gfc_current_locus
= old_loc
;
89 gfc_gobble_whitespace ();
95 /* Match an end of statement. End of statement is optional
96 whitespace, followed by a ';' or '\n' or comment '!'. If a
97 semicolon is found, we continue to eat whitespace and semicolons. */
109 old_loc
= gfc_current_locus
;
110 gfc_gobble_whitespace ();
112 c
= gfc_next_char ();
118 c
= gfc_next_char ();
135 gfc_current_locus
= old_loc
;
136 return (flag
) ? MATCH_YES
: MATCH_NO
;
140 /* Match a literal integer on the input, setting the value on
141 MATCH_YES. Literal ints occur in kind-parameters as well as
142 old-style character length specifications. If cnt is non-NULL it
143 will be set to the number of digits. */
146 gfc_match_small_literal_int (int *value
, int *cnt
)
152 old_loc
= gfc_current_locus
;
154 gfc_gobble_whitespace ();
155 c
= gfc_next_char ();
161 gfc_current_locus
= old_loc
;
170 old_loc
= gfc_current_locus
;
171 c
= gfc_next_char ();
176 i
= 10 * i
+ c
- '0';
181 gfc_error ("Integer too large at %C");
186 gfc_current_locus
= old_loc
;
195 /* Match a small, constant integer expression, like in a kind
196 statement. On MATCH_YES, 'value' is set. */
199 gfc_match_small_int (int *value
)
206 m
= gfc_match_expr (&expr
);
210 p
= gfc_extract_int (expr
, &i
);
211 gfc_free_expr (expr
);
224 /* Matches a statement label. Uses gfc_match_small_literal_int() to
225 do most of the work. */
228 gfc_match_st_label (gfc_st_label
** label
)
234 old_loc
= gfc_current_locus
;
236 m
= gfc_match_small_literal_int (&i
, &cnt
);
242 gfc_error ("Too many digits in statement label at %C");
248 gfc_error ("Statement label at %C is zero");
252 *label
= gfc_get_st_label (i
);
257 gfc_current_locus
= old_loc
;
262 /* Match and validate a label associated with a named IF, DO or SELECT
263 statement. If the symbol does not have the label attribute, we add
264 it. We also make sure the symbol does not refer to another
265 (active) block. A matched label is pointed to by gfc_new_block. */
268 gfc_match_label (void)
270 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
273 gfc_new_block
= NULL
;
275 m
= gfc_match (" %n :", name
);
279 if (gfc_get_symbol (name
, NULL
, &gfc_new_block
))
281 gfc_error ("Label name '%s' at %C is ambiguous", name
);
285 if (gfc_new_block
->attr
.flavor
== FL_LABEL
)
287 gfc_error ("Duplicate construct label '%s' at %C", name
);
291 if (gfc_add_flavor (&gfc_new_block
->attr
, FL_LABEL
,
292 gfc_new_block
->name
, NULL
) == FAILURE
)
299 /* Try and match the input against an array of possibilities. If one
300 potential matching string is a substring of another, the longest
301 match takes precedence. Spaces in the target strings are optional
302 spaces that do not necessarily have to be found in the input
303 stream. In fixed mode, spaces never appear. If whitespace is
304 matched, it matches unlimited whitespace in the input. For this
305 reason, the 'mp' member of the mstring structure is used to track
306 the progress of each potential match.
308 If there is no match we return the tag associated with the
309 terminating NULL mstring structure and leave the locus pointer
310 where it started. If there is a match we return the tag member of
311 the matched mstring and leave the locus pointer after the matched
314 A '%' character is a mandatory space. */
317 gfc_match_strings (mstring
* a
)
319 mstring
*p
, *best_match
;
320 int no_match
, c
, possibles
;
325 for (p
= a
; p
->string
!= NULL
; p
++)
334 match_loc
= gfc_current_locus
;
336 gfc_gobble_whitespace ();
338 while (possibles
> 0)
340 c
= gfc_next_char ();
342 /* Apply the next character to the current possibilities. */
343 for (p
= a
; p
->string
!= NULL
; p
++)
350 /* Space matches 1+ whitespace(s). */
351 if ((gfc_current_form
== FORM_FREE
)
352 && gfc_is_whitespace (c
))
370 match_loc
= gfc_current_locus
;
378 gfc_current_locus
= match_loc
;
380 return (best_match
== NULL
) ? no_match
: best_match
->tag
;
384 /* See if the current input looks like a name of some sort. Modifies
385 the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long. */
388 gfc_match_name (char *buffer
)
393 old_loc
= gfc_current_locus
;
394 gfc_gobble_whitespace ();
396 c
= gfc_next_char ();
399 gfc_current_locus
= old_loc
;
409 if (i
> gfc_option
.max_identifier_length
)
411 gfc_error ("Name at %C is too long");
415 old_loc
= gfc_current_locus
;
416 c
= gfc_next_char ();
420 || (gfc_option
.flag_dollar_ok
&& c
== '$'));
423 gfc_current_locus
= old_loc
;
429 /* Match a symbol on the input. Modifies the pointer to the symbol
430 pointer if successful. */
433 gfc_match_sym_tree (gfc_symtree
** matched_symbol
, int host_assoc
)
435 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
438 m
= gfc_match_name (buffer
);
443 return (gfc_get_ha_sym_tree (buffer
, matched_symbol
))
444 ? MATCH_ERROR
: MATCH_YES
;
446 if (gfc_get_sym_tree (buffer
, NULL
, matched_symbol
))
454 gfc_match_symbol (gfc_symbol
** matched_symbol
, int host_assoc
)
459 m
= gfc_match_sym_tree (&st
, host_assoc
);
464 *matched_symbol
= st
->n
.sym
;
466 *matched_symbol
= NULL
;
469 *matched_symbol
= NULL
;
473 /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
474 we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
478 gfc_match_intrinsic_op (gfc_intrinsic_op
* result
)
482 op
= (gfc_intrinsic_op
) gfc_match_strings (intrinsic_operators
);
484 if (op
== INTRINSIC_NONE
)
492 /* Match a loop control phrase:
494 <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
496 If the final integer expression is not present, a constant unity
497 expression is returned. We don't return MATCH_ERROR until after
498 the equals sign is seen. */
501 gfc_match_iterator (gfc_iterator
* iter
, int init_flag
)
503 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
504 gfc_expr
*var
, *e1
, *e2
, *e3
;
508 /* Match the start of an iterator without affecting the symbol
511 start
= gfc_current_locus
;
512 m
= gfc_match (" %n =", name
);
513 gfc_current_locus
= start
;
518 m
= gfc_match_variable (&var
, 0);
522 gfc_match_char ('=');
526 if (var
->ref
!= NULL
)
528 gfc_error ("Loop variable at %C cannot be a sub-component");
532 if (var
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
534 gfc_error ("Loop variable '%s' at %C cannot be INTENT(IN)",
535 var
->symtree
->n
.sym
->name
);
539 if (var
->symtree
->n
.sym
->attr
.pointer
)
541 gfc_error ("Loop variable at %C cannot have the POINTER attribute");
545 m
= init_flag
? gfc_match_init_expr (&e1
) : gfc_match_expr (&e1
);
548 if (m
== MATCH_ERROR
)
551 if (gfc_match_char (',') != MATCH_YES
)
554 m
= init_flag
? gfc_match_init_expr (&e2
) : gfc_match_expr (&e2
);
557 if (m
== MATCH_ERROR
)
560 if (gfc_match_char (',') != MATCH_YES
)
562 e3
= gfc_int_expr (1);
566 m
= init_flag
? gfc_match_init_expr (&e3
) : gfc_match_expr (&e3
);
567 if (m
== MATCH_ERROR
)
571 gfc_error ("Expected a step value in iterator at %C");
583 gfc_error ("Syntax error in iterator at %C");
594 /* Tries to match the next non-whitespace character on the input.
595 This subroutine does not return MATCH_ERROR. */
598 gfc_match_char (char c
)
602 where
= gfc_current_locus
;
603 gfc_gobble_whitespace ();
605 if (gfc_next_char () == c
)
608 gfc_current_locus
= where
;
613 /* General purpose matching subroutine. The target string is a
614 scanf-like format string in which spaces correspond to arbitrary
615 whitespace (including no whitespace), characters correspond to
616 themselves. The %-codes are:
618 %% Literal percent sign
619 %e Expression, pointer to a pointer is set
620 %s Symbol, pointer to the symbol is set
621 %n Name, character buffer is set to name
622 %t Matches end of statement.
623 %o Matches an intrinsic operator, returned as an INTRINSIC enum.
624 %l Matches a statement label
625 %v Matches a variable expression (an lvalue)
626 % Matches a required space (in free form) and optional spaces. */
629 gfc_match (const char *target
, ...)
631 gfc_st_label
**label
;
640 old_loc
= gfc_current_locus
;
641 va_start (argp
, target
);
651 gfc_gobble_whitespace ();
662 vp
= va_arg (argp
, void **);
663 n
= gfc_match_expr ((gfc_expr
**) vp
);
674 vp
= va_arg (argp
, void **);
675 n
= gfc_match_variable ((gfc_expr
**) vp
, 0);
686 vp
= va_arg (argp
, void **);
687 n
= gfc_match_symbol ((gfc_symbol
**) vp
, 0);
698 np
= va_arg (argp
, char *);
699 n
= gfc_match_name (np
);
710 label
= va_arg (argp
, gfc_st_label
**);
711 n
= gfc_match_st_label (label
);
722 ip
= va_arg (argp
, int *);
723 n
= gfc_match_intrinsic_op ((gfc_intrinsic_op
*) ip
);
734 if (gfc_match_eos () != MATCH_YES
)
742 if (gfc_match_space () == MATCH_YES
)
748 break; /* Fall through to character matcher */
751 gfc_internal_error ("gfc_match(): Bad match code %c", c
);
755 if (c
== gfc_next_char ())
765 /* Clean up after a failed match. */
766 gfc_current_locus
= old_loc
;
767 va_start (argp
, target
);
770 for (; matches
> 0; matches
--)
780 /* Matches that don't have to be undone */
785 (void)va_arg (argp
, void **);
790 vp
= va_arg (argp
, void **);
804 /*********************** Statement level matching **********************/
806 /* Matches the start of a program unit, which is the program keyword
807 followed by an obligatory symbol. */
810 gfc_match_program (void)
815 m
= gfc_match ("% %s%t", &sym
);
819 gfc_error ("Invalid form of PROGRAM statement at %C");
823 if (m
== MATCH_ERROR
)
826 if (gfc_add_flavor (&sym
->attr
, FL_PROGRAM
, sym
->name
, NULL
) == FAILURE
)
835 /* Match a simple assignment statement. */
838 gfc_match_assignment (void)
840 gfc_expr
*lvalue
, *rvalue
;
844 old_loc
= gfc_current_locus
;
846 lvalue
= rvalue
= NULL
;
847 m
= gfc_match (" %v =", &lvalue
);
851 if (lvalue
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
853 gfc_error ("Cannot assign to a PARAMETER variable at %C");
858 m
= gfc_match (" %e%t", &rvalue
);
862 gfc_set_sym_referenced (lvalue
->symtree
->n
.sym
);
864 new_st
.op
= EXEC_ASSIGN
;
865 new_st
.expr
= lvalue
;
866 new_st
.expr2
= rvalue
;
868 gfc_check_do_variable (lvalue
->symtree
);
873 gfc_current_locus
= old_loc
;
874 gfc_free_expr (lvalue
);
875 gfc_free_expr (rvalue
);
880 /* Match a pointer assignment statement. */
883 gfc_match_pointer_assignment (void)
885 gfc_expr
*lvalue
, *rvalue
;
889 old_loc
= gfc_current_locus
;
891 lvalue
= rvalue
= NULL
;
893 m
= gfc_match (" %v =>", &lvalue
);
900 m
= gfc_match (" %e%t", &rvalue
);
904 new_st
.op
= EXEC_POINTER_ASSIGN
;
905 new_st
.expr
= lvalue
;
906 new_st
.expr2
= rvalue
;
911 gfc_current_locus
= old_loc
;
912 gfc_free_expr (lvalue
);
913 gfc_free_expr (rvalue
);
918 /* We try to match an easy arithmetic IF statement. This only happens
919 when just after having encountered a simple IF statement. This code
920 is really duplicate with parts of the gfc_match_if code, but this is
923 match_arithmetic_if (void)
925 gfc_st_label
*l1
, *l2
, *l3
;
929 m
= gfc_match (" ( %e ) %l , %l , %l%t", &expr
, &l1
, &l2
, &l3
);
933 if (gfc_reference_st_label (l1
, ST_LABEL_TARGET
) == FAILURE
934 || gfc_reference_st_label (l2
, ST_LABEL_TARGET
) == FAILURE
935 || gfc_reference_st_label (l3
, ST_LABEL_TARGET
) == FAILURE
)
937 gfc_free_expr (expr
);
941 if (gfc_notify_std (GFC_STD_F95_DEL
,
942 "Obsolete: arithmetic IF statement at %C") == FAILURE
)
945 new_st
.op
= EXEC_ARITHMETIC_IF
;
955 /* The IF statement is a bit of a pain. First of all, there are three
956 forms of it, the simple IF, the IF that starts a block and the
959 There is a problem with the simple IF and that is the fact that we
960 only have a single level of undo information on symbols. What this
961 means is for a simple IF, we must re-match the whole IF statement
962 multiple times in order to guarantee that the symbol table ends up
963 in the proper state. */
965 static match
match_simple_forall (void);
966 static match
match_simple_where (void);
969 gfc_match_if (gfc_statement
* if_type
)
972 gfc_st_label
*l1
, *l2
, *l3
;
977 n
= gfc_match_label ();
978 if (n
== MATCH_ERROR
)
981 old_loc
= gfc_current_locus
;
983 m
= gfc_match (" if ( %e", &expr
);
987 if (gfc_match_char (')') != MATCH_YES
)
989 gfc_error ("Syntax error in IF-expression at %C");
990 gfc_free_expr (expr
);
994 m
= gfc_match (" %l , %l , %l%t", &l1
, &l2
, &l3
);
1001 ("Block label not appropriate for arithmetic IF statement "
1004 gfc_free_expr (expr
);
1008 if (gfc_reference_st_label (l1
, ST_LABEL_TARGET
) == FAILURE
1009 || gfc_reference_st_label (l2
, ST_LABEL_TARGET
) == FAILURE
1010 || gfc_reference_st_label (l3
, ST_LABEL_TARGET
) == FAILURE
)
1013 gfc_free_expr (expr
);
1017 if (gfc_notify_std (GFC_STD_F95_DEL
,
1018 "Obsolete: arithmetic IF statement at %C")
1022 new_st
.op
= EXEC_ARITHMETIC_IF
;
1028 *if_type
= ST_ARITHMETIC_IF
;
1032 if (gfc_match (" then%t") == MATCH_YES
)
1034 new_st
.op
= EXEC_IF
;
1037 *if_type
= ST_IF_BLOCK
;
1043 gfc_error ("Block label is not appropriate IF statement at %C");
1045 gfc_free_expr (expr
);
1049 /* At this point the only thing left is a simple IF statement. At
1050 this point, n has to be MATCH_NO, so we don't have to worry about
1051 re-matching a block label. From what we've got so far, try
1052 matching an assignment. */
1054 *if_type
= ST_SIMPLE_IF
;
1056 m
= gfc_match_assignment ();
1060 gfc_free_expr (expr
);
1061 gfc_undo_symbols ();
1062 gfc_current_locus
= old_loc
;
1064 /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_NO, continue to
1065 call the various matchers. For MATCH_ERROR, a mangled assignment
1067 if (m
== MATCH_ERROR
)
1070 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match */
1072 m
= gfc_match_pointer_assignment ();
1076 gfc_free_expr (expr
);
1077 gfc_undo_symbols ();
1078 gfc_current_locus
= old_loc
;
1080 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match */
1082 /* Look at the next keyword to see which matcher to call. Matching
1083 the keyword doesn't affect the symbol table, so we don't have to
1084 restore between tries. */
1086 #define match(string, subr, statement) \
1087 if (gfc_match(string) == MATCH_YES) { m = subr(); goto got_match; }
1091 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
)
1092 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
)
1093 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
)
1094 match ("call", gfc_match_call
, ST_CALL
)
1095 match ("close", gfc_match_close
, ST_CLOSE
)
1096 match ("continue", gfc_match_continue
, ST_CONTINUE
)
1097 match ("cycle", gfc_match_cycle
, ST_CYCLE
)
1098 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
)
1099 match ("end file", gfc_match_endfile
, ST_END_FILE
)
1100 match ("exit", gfc_match_exit
, ST_EXIT
)
1101 match ("flush", gfc_match_flush
, ST_FLUSH
)
1102 match ("forall", match_simple_forall
, ST_FORALL
)
1103 match ("go to", gfc_match_goto
, ST_GOTO
)
1104 match ("if", match_arithmetic_if
, ST_ARITHMETIC_IF
)
1105 match ("inquire", gfc_match_inquire
, ST_INQUIRE
)
1106 match ("nullify", gfc_match_nullify
, ST_NULLIFY
)
1107 match ("open", gfc_match_open
, ST_OPEN
)
1108 match ("pause", gfc_match_pause
, ST_NONE
)
1109 match ("print", gfc_match_print
, ST_WRITE
)
1110 match ("read", gfc_match_read
, ST_READ
)
1111 match ("return", gfc_match_return
, ST_RETURN
)
1112 match ("rewind", gfc_match_rewind
, ST_REWIND
)
1113 match ("stop", gfc_match_stop
, ST_STOP
)
1114 match ("where", match_simple_where
, ST_WHERE
)
1115 match ("write", gfc_match_write
, ST_WRITE
)
1117 /* All else has failed, so give up. See if any of the matchers has
1118 stored an error message of some sort. */
1119 if (gfc_error_check () == 0)
1120 gfc_error ("Unclassifiable statement in IF-clause at %C");
1122 gfc_free_expr (expr
);
1127 gfc_error ("Syntax error in IF-clause at %C");
1130 gfc_free_expr (expr
);
1134 /* At this point, we've matched the single IF and the action clause
1135 is in new_st. Rearrange things so that the IF statement appears
1138 p
= gfc_get_code ();
1139 p
->next
= gfc_get_code ();
1141 p
->next
->loc
= gfc_current_locus
;
1146 gfc_clear_new_st ();
1148 new_st
.op
= EXEC_IF
;
1157 /* Match an ELSE statement. */
1160 gfc_match_else (void)
1162 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1164 if (gfc_match_eos () == MATCH_YES
)
1167 if (gfc_match_name (name
) != MATCH_YES
1168 || gfc_current_block () == NULL
1169 || gfc_match_eos () != MATCH_YES
)
1171 gfc_error ("Unexpected junk after ELSE statement at %C");
1175 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1177 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1178 name
, gfc_current_block ()->name
);
1186 /* Match an ELSE IF statement. */
1189 gfc_match_elseif (void)
1191 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1195 m
= gfc_match (" ( %e ) then", &expr
);
1199 if (gfc_match_eos () == MATCH_YES
)
1202 if (gfc_match_name (name
) != MATCH_YES
1203 || gfc_current_block () == NULL
1204 || gfc_match_eos () != MATCH_YES
)
1206 gfc_error ("Unexpected junk after ELSE IF statement at %C");
1210 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1212 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1213 name
, gfc_current_block ()->name
);
1218 new_st
.op
= EXEC_IF
;
1223 gfc_free_expr (expr
);
1228 /* Free a gfc_iterator structure. */
1231 gfc_free_iterator (gfc_iterator
* iter
, int flag
)
1237 gfc_free_expr (iter
->var
);
1238 gfc_free_expr (iter
->start
);
1239 gfc_free_expr (iter
->end
);
1240 gfc_free_expr (iter
->step
);
1247 /* Match a DO statement. */
1252 gfc_iterator iter
, *ip
;
1254 gfc_st_label
*label
;
1257 old_loc
= gfc_current_locus
;
1260 iter
.var
= iter
.start
= iter
.end
= iter
.step
= NULL
;
1262 m
= gfc_match_label ();
1263 if (m
== MATCH_ERROR
)
1266 if (gfc_match (" do") != MATCH_YES
)
1269 m
= gfc_match_st_label (&label
);
1270 if (m
== MATCH_ERROR
)
1273 /* Match an infinite DO, make it like a DO WHILE(.TRUE.) */
1275 if (gfc_match_eos () == MATCH_YES
)
1277 iter
.end
= gfc_logical_expr (1, NULL
);
1278 new_st
.op
= EXEC_DO_WHILE
;
1282 /* match an optional comma, if no comma is found a space is obligatory. */
1283 if (gfc_match_char(',') != MATCH_YES
1284 && gfc_match ("% ") != MATCH_YES
)
1287 /* See if we have a DO WHILE. */
1288 if (gfc_match (" while ( %e )%t", &iter
.end
) == MATCH_YES
)
1290 new_st
.op
= EXEC_DO_WHILE
;
1294 /* The abortive DO WHILE may have done something to the symbol
1295 table, so we start over: */
1296 gfc_undo_symbols ();
1297 gfc_current_locus
= old_loc
;
1299 gfc_match_label (); /* This won't error */
1300 gfc_match (" do "); /* This will work */
1302 gfc_match_st_label (&label
); /* Can't error out */
1303 gfc_match_char (','); /* Optional comma */
1305 m
= gfc_match_iterator (&iter
, 0);
1308 if (m
== MATCH_ERROR
)
1311 gfc_check_do_variable (iter
.var
->symtree
);
1313 if (gfc_match_eos () != MATCH_YES
)
1315 gfc_syntax_error (ST_DO
);
1319 new_st
.op
= EXEC_DO
;
1323 && gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
1326 new_st
.label
= label
;
1328 if (new_st
.op
== EXEC_DO_WHILE
)
1329 new_st
.expr
= iter
.end
;
1332 new_st
.ext
.iterator
= ip
= gfc_get_iterator ();
1339 gfc_free_iterator (&iter
, 0);
1345 /* Match an EXIT or CYCLE statement. */
1348 match_exit_cycle (gfc_statement st
, gfc_exec_op op
)
1350 gfc_state_data
*p
, *o
;
1354 if (gfc_match_eos () == MATCH_YES
)
1358 m
= gfc_match ("% %s%t", &sym
);
1359 if (m
== MATCH_ERROR
)
1363 gfc_syntax_error (st
);
1367 if (sym
->attr
.flavor
!= FL_LABEL
)
1369 gfc_error ("Name '%s' in %s statement at %C is not a loop name",
1370 sym
->name
, gfc_ascii_statement (st
));
1375 /* Find the loop mentioned specified by the label (or lack of a
1377 for (o
= NULL
, p
= gfc_state_stack
; p
; p
= p
->previous
)
1378 if (p
->state
== COMP_DO
&& (sym
== NULL
|| sym
== p
->sym
))
1380 else if (o
== NULL
&& p
->state
== COMP_OMP_STRUCTURED_BLOCK
)
1386 gfc_error ("%s statement at %C is not within a loop",
1387 gfc_ascii_statement (st
));
1389 gfc_error ("%s statement at %C is not within loop '%s'",
1390 gfc_ascii_statement (st
), sym
->name
);
1397 gfc_error ("%s statement at %C leaving OpenMP structured block",
1398 gfc_ascii_statement (st
));
1401 else if (st
== ST_EXIT
1402 && p
->previous
!= NULL
1403 && p
->previous
->state
== COMP_OMP_STRUCTURED_BLOCK
1404 && (p
->previous
->head
->op
== EXEC_OMP_DO
1405 || p
->previous
->head
->op
== EXEC_OMP_PARALLEL_DO
))
1407 gcc_assert (p
->previous
->head
->next
!= NULL
);
1408 gcc_assert (p
->previous
->head
->next
->op
== EXEC_DO
1409 || p
->previous
->head
->next
->op
== EXEC_DO_WHILE
);
1410 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
1414 /* Save the first statement in the loop - needed by the backend. */
1415 new_st
.ext
.whichloop
= p
->head
;
1418 /* new_st.sym = sym;*/
1424 /* Match the EXIT statement. */
1427 gfc_match_exit (void)
1430 return match_exit_cycle (ST_EXIT
, EXEC_EXIT
);
1434 /* Match the CYCLE statement. */
1437 gfc_match_cycle (void)
1440 return match_exit_cycle (ST_CYCLE
, EXEC_CYCLE
);
1444 /* Match a number or character constant after a STOP or PAUSE statement. */
1447 gfc_match_stopcode (gfc_statement st
)
1457 if (gfc_match_eos () != MATCH_YES
)
1459 m
= gfc_match_small_literal_int (&stop_code
, &cnt
);
1460 if (m
== MATCH_ERROR
)
1463 if (m
== MATCH_YES
&& cnt
> 5)
1465 gfc_error ("Too many digits in STOP code at %C");
1471 /* Try a character constant. */
1472 m
= gfc_match_expr (&e
);
1473 if (m
== MATCH_ERROR
)
1477 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1481 if (gfc_match_eos () != MATCH_YES
)
1485 if (gfc_pure (NULL
))
1487 gfc_error ("%s statement not allowed in PURE procedure at %C",
1488 gfc_ascii_statement (st
));
1492 new_st
.op
= st
== ST_STOP
? EXEC_STOP
: EXEC_PAUSE
;
1494 new_st
.ext
.stop_code
= stop_code
;
1499 gfc_syntax_error (st
);
1507 /* Match the (deprecated) PAUSE statement. */
1510 gfc_match_pause (void)
1514 m
= gfc_match_stopcode (ST_PAUSE
);
1517 if (gfc_notify_std (GFC_STD_F95_DEL
,
1518 "Obsolete: PAUSE statement at %C")
1526 /* Match the STOP statement. */
1529 gfc_match_stop (void)
1531 return gfc_match_stopcode (ST_STOP
);
1535 /* Match a CONTINUE statement. */
1538 gfc_match_continue (void)
1541 if (gfc_match_eos () != MATCH_YES
)
1543 gfc_syntax_error (ST_CONTINUE
);
1547 new_st
.op
= EXEC_CONTINUE
;
1552 /* Match the (deprecated) ASSIGN statement. */
1555 gfc_match_assign (void)
1558 gfc_st_label
*label
;
1560 if (gfc_match (" %l", &label
) == MATCH_YES
)
1562 if (gfc_reference_st_label (label
, ST_LABEL_UNKNOWN
) == FAILURE
)
1564 if (gfc_match (" to %v%t", &expr
) == MATCH_YES
)
1566 if (gfc_notify_std (GFC_STD_F95_DEL
,
1567 "Obsolete: ASSIGN statement at %C")
1571 expr
->symtree
->n
.sym
->attr
.assign
= 1;
1573 new_st
.op
= EXEC_LABEL_ASSIGN
;
1574 new_st
.label
= label
;
1583 /* Match the GO TO statement. As a computed GOTO statement is
1584 matched, it is transformed into an equivalent SELECT block. No
1585 tree is necessary, and the resulting jumps-to-jumps are
1586 specifically optimized away by the back end. */
1589 gfc_match_goto (void)
1591 gfc_code
*head
, *tail
;
1594 gfc_st_label
*label
;
1598 if (gfc_match (" %l%t", &label
) == MATCH_YES
)
1600 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
1603 new_st
.op
= EXEC_GOTO
;
1604 new_st
.label
= label
;
1608 /* The assigned GO TO statement. */
1610 if (gfc_match_variable (&expr
, 0) == MATCH_YES
)
1612 if (gfc_notify_std (GFC_STD_F95_DEL
,
1613 "Obsolete: Assigned GOTO statement at %C")
1617 new_st
.op
= EXEC_GOTO
;
1620 if (gfc_match_eos () == MATCH_YES
)
1623 /* Match label list. */
1624 gfc_match_char (',');
1625 if (gfc_match_char ('(') != MATCH_YES
)
1627 gfc_syntax_error (ST_GOTO
);
1634 m
= gfc_match_st_label (&label
);
1638 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
1642 head
= tail
= gfc_get_code ();
1645 tail
->block
= gfc_get_code ();
1649 tail
->label
= label
;
1650 tail
->op
= EXEC_GOTO
;
1652 while (gfc_match_char (',') == MATCH_YES
);
1654 if (gfc_match (")%t") != MATCH_YES
)
1660 "Statement label list in GOTO at %C cannot be empty");
1663 new_st
.block
= head
;
1668 /* Last chance is a computed GO TO statement. */
1669 if (gfc_match_char ('(') != MATCH_YES
)
1671 gfc_syntax_error (ST_GOTO
);
1680 m
= gfc_match_st_label (&label
);
1684 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
1688 head
= tail
= gfc_get_code ();
1691 tail
->block
= gfc_get_code ();
1695 cp
= gfc_get_case ();
1696 cp
->low
= cp
->high
= gfc_int_expr (i
++);
1698 tail
->op
= EXEC_SELECT
;
1699 tail
->ext
.case_list
= cp
;
1701 tail
->next
= gfc_get_code ();
1702 tail
->next
->op
= EXEC_GOTO
;
1703 tail
->next
->label
= label
;
1705 while (gfc_match_char (',') == MATCH_YES
);
1707 if (gfc_match_char (')') != MATCH_YES
)
1712 gfc_error ("Statement label list in GOTO at %C cannot be empty");
1716 /* Get the rest of the statement. */
1717 gfc_match_char (',');
1719 if (gfc_match (" %e%t", &expr
) != MATCH_YES
)
1722 /* At this point, a computed GOTO has been fully matched and an
1723 equivalent SELECT statement constructed. */
1725 new_st
.op
= EXEC_SELECT
;
1728 /* Hack: For a "real" SELECT, the expression is in expr. We put
1729 it in expr2 so we can distinguish then and produce the correct
1731 new_st
.expr2
= expr
;
1732 new_st
.block
= head
;
1736 gfc_syntax_error (ST_GOTO
);
1738 gfc_free_statements (head
);
1743 /* Frees a list of gfc_alloc structures. */
1746 gfc_free_alloc_list (gfc_alloc
* p
)
1753 gfc_free_expr (p
->expr
);
1759 /* Match an ALLOCATE statement. */
1762 gfc_match_allocate (void)
1764 gfc_alloc
*head
, *tail
;
1771 if (gfc_match_char ('(') != MATCH_YES
)
1777 head
= tail
= gfc_get_alloc ();
1780 tail
->next
= gfc_get_alloc ();
1784 m
= gfc_match_variable (&tail
->expr
, 0);
1787 if (m
== MATCH_ERROR
)
1790 if (gfc_check_do_variable (tail
->expr
->symtree
))
1794 && gfc_impure_variable (tail
->expr
->symtree
->n
.sym
))
1796 gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a "
1801 if (gfc_match_char (',') != MATCH_YES
)
1804 m
= gfc_match (" stat = %v", &stat
);
1805 if (m
== MATCH_ERROR
)
1813 if (stat
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
1816 ("STAT variable '%s' of ALLOCATE statement at %C cannot be "
1817 "INTENT(IN)", stat
->symtree
->n
.sym
->name
);
1821 if (gfc_pure (NULL
) && gfc_impure_variable (stat
->symtree
->n
.sym
))
1824 ("Illegal STAT variable in ALLOCATE statement at %C for a PURE "
1829 if (stat
->symtree
->n
.sym
->attr
.flavor
!= FL_VARIABLE
)
1831 gfc_error("STAT expression at %C must be a variable");
1835 gfc_check_do_variable(stat
->symtree
);
1838 if (gfc_match (" )%t") != MATCH_YES
)
1841 new_st
.op
= EXEC_ALLOCATE
;
1843 new_st
.ext
.alloc_list
= head
;
1848 gfc_syntax_error (ST_ALLOCATE
);
1851 gfc_free_expr (stat
);
1852 gfc_free_alloc_list (head
);
1857 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
1858 a set of pointer assignments to intrinsic NULL(). */
1861 gfc_match_nullify (void)
1869 if (gfc_match_char ('(') != MATCH_YES
)
1874 m
= gfc_match_variable (&p
, 0);
1875 if (m
== MATCH_ERROR
)
1880 if (gfc_check_do_variable(p
->symtree
))
1883 if (gfc_pure (NULL
) && gfc_impure_variable (p
->symtree
->n
.sym
))
1886 ("Illegal variable in NULLIFY at %C for a PURE procedure");
1890 /* build ' => NULL() ' */
1891 e
= gfc_get_expr ();
1892 e
->where
= gfc_current_locus
;
1893 e
->expr_type
= EXPR_NULL
;
1894 e
->ts
.type
= BT_UNKNOWN
;
1901 tail
->next
= gfc_get_code ();
1905 tail
->op
= EXEC_POINTER_ASSIGN
;
1909 if (gfc_match (" )%t") == MATCH_YES
)
1911 if (gfc_match_char (',') != MATCH_YES
)
1918 gfc_syntax_error (ST_NULLIFY
);
1921 gfc_free_statements (new_st
.next
);
1926 /* Match a DEALLOCATE statement. */
1929 gfc_match_deallocate (void)
1931 gfc_alloc
*head
, *tail
;
1938 if (gfc_match_char ('(') != MATCH_YES
)
1944 head
= tail
= gfc_get_alloc ();
1947 tail
->next
= gfc_get_alloc ();
1951 m
= gfc_match_variable (&tail
->expr
, 0);
1952 if (m
== MATCH_ERROR
)
1957 if (gfc_check_do_variable (tail
->expr
->symtree
))
1961 && gfc_impure_variable (tail
->expr
->symtree
->n
.sym
))
1964 ("Illegal deallocate-expression in DEALLOCATE at %C for a PURE "
1969 if (gfc_match_char (',') != MATCH_YES
)
1972 m
= gfc_match (" stat = %v", &stat
);
1973 if (m
== MATCH_ERROR
)
1981 if (stat
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
1983 gfc_error ("STAT variable '%s' of DEALLOCATE statement at %C "
1984 "cannot be INTENT(IN)", stat
->symtree
->n
.sym
->name
);
1988 if (gfc_pure(NULL
) && gfc_impure_variable (stat
->symtree
->n
.sym
))
1990 gfc_error ("Illegal STAT variable in DEALLOCATE statement at %C "
1991 "for a PURE procedure");
1995 if (stat
->symtree
->n
.sym
->attr
.flavor
!= FL_VARIABLE
)
1997 gfc_error("STAT expression at %C must be a variable");
2001 gfc_check_do_variable(stat
->symtree
);
2004 if (gfc_match (" )%t") != MATCH_YES
)
2007 new_st
.op
= EXEC_DEALLOCATE
;
2009 new_st
.ext
.alloc_list
= head
;
2014 gfc_syntax_error (ST_DEALLOCATE
);
2017 gfc_free_expr (stat
);
2018 gfc_free_alloc_list (head
);
2023 /* Match a RETURN statement. */
2026 gfc_match_return (void)
2030 gfc_compile_state s
;
2034 if (gfc_match_eos () == MATCH_YES
)
2037 if (gfc_find_state (COMP_SUBROUTINE
) == FAILURE
)
2039 gfc_error ("Alternate RETURN statement at %C is only allowed within "
2044 if (gfc_current_form
== FORM_FREE
)
2046 /* The following are valid, so we can't require a blank after the
2050 c
= gfc_peek_char ();
2051 if (ISALPHA (c
) || ISDIGIT (c
))
2055 m
= gfc_match (" %e%t", &e
);
2058 if (m
== MATCH_ERROR
)
2061 gfc_syntax_error (ST_RETURN
);
2068 gfc_enclosing_unit (&s
);
2069 if (s
== COMP_PROGRAM
2070 && gfc_notify_std (GFC_STD_GNU
, "Extension: RETURN statement in "
2071 "main program at %C") == FAILURE
)
2074 new_st
.op
= EXEC_RETURN
;
2081 /* Match a CALL statement. The tricky part here are possible
2082 alternate return specifiers. We handle these by having all
2083 "subroutines" actually return an integer via a register that gives
2084 the return number. If the call specifies alternate returns, we
2085 generate code for a SELECT statement whose case clauses contain
2086 GOTOs to the various labels. */
2089 gfc_match_call (void)
2091 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2092 gfc_actual_arglist
*a
, *arglist
;
2102 m
= gfc_match ("% %n", name
);
2108 if (gfc_get_ha_sym_tree (name
, &st
))
2112 gfc_set_sym_referenced (sym
);
2114 if (!sym
->attr
.generic
2115 && !sym
->attr
.subroutine
2116 && gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2119 if (gfc_match_eos () != MATCH_YES
)
2121 m
= gfc_match_actual_arglist (1, &arglist
);
2124 if (m
== MATCH_ERROR
)
2127 if (gfc_match_eos () != MATCH_YES
)
2131 /* If any alternate return labels were found, construct a SELECT
2132 statement that will jump to the right place. */
2135 for (a
= arglist
; a
; a
= a
->next
)
2136 if (a
->expr
== NULL
)
2141 gfc_symtree
*select_st
;
2142 gfc_symbol
*select_sym
;
2143 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2145 new_st
.next
= c
= gfc_get_code ();
2146 c
->op
= EXEC_SELECT
;
2147 sprintf (name
, "_result_%s",sym
->name
);
2148 gfc_get_ha_sym_tree (name
, &select_st
); /* Can't fail */
2150 select_sym
= select_st
->n
.sym
;
2151 select_sym
->ts
.type
= BT_INTEGER
;
2152 select_sym
->ts
.kind
= gfc_default_integer_kind
;
2153 gfc_set_sym_referenced (select_sym
);
2154 c
->expr
= gfc_get_expr ();
2155 c
->expr
->expr_type
= EXPR_VARIABLE
;
2156 c
->expr
->symtree
= select_st
;
2157 c
->expr
->ts
= select_sym
->ts
;
2158 c
->expr
->where
= gfc_current_locus
;
2161 for (a
= arglist
; a
; a
= a
->next
)
2163 if (a
->expr
!= NULL
)
2166 if (gfc_reference_st_label (a
->label
, ST_LABEL_TARGET
) == FAILURE
)
2171 c
->block
= gfc_get_code ();
2173 c
->op
= EXEC_SELECT
;
2175 new_case
= gfc_get_case ();
2176 new_case
->high
= new_case
->low
= gfc_int_expr (i
);
2177 c
->ext
.case_list
= new_case
;
2179 c
->next
= gfc_get_code ();
2180 c
->next
->op
= EXEC_GOTO
;
2181 c
->next
->label
= a
->label
;
2185 new_st
.op
= EXEC_CALL
;
2186 new_st
.symtree
= st
;
2187 new_st
.ext
.actual
= arglist
;
2192 gfc_syntax_error (ST_CALL
);
2195 gfc_free_actual_arglist (arglist
);
2200 /* Given a name, return a pointer to the common head structure,
2201 creating it if it does not exist. If FROM_MODULE is nonzero, we
2202 mangle the name so that it doesn't interfere with commons defined
2203 in the using namespace.
2204 TODO: Add to global symbol tree. */
2207 gfc_get_common (const char *name
, int from_module
)
2210 static int serial
= 0;
2211 char mangled_name
[GFC_MAX_SYMBOL_LEN
+1];
2215 /* A use associated common block is only needed to correctly layout
2216 the variables it contains. */
2217 snprintf(mangled_name
, GFC_MAX_SYMBOL_LEN
, "_%d_%s", serial
++, name
);
2218 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, mangled_name
);
2222 st
= gfc_find_symtree (gfc_current_ns
->common_root
, name
);
2225 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, name
);
2228 if (st
->n
.common
== NULL
)
2230 st
->n
.common
= gfc_get_common_head ();
2231 st
->n
.common
->where
= gfc_current_locus
;
2232 strcpy (st
->n
.common
->name
, name
);
2235 return st
->n
.common
;
2239 /* Match a common block name. */
2242 match_common_name (char *name
)
2246 if (gfc_match_char ('/') == MATCH_NO
)
2252 if (gfc_match_char ('/') == MATCH_YES
)
2258 m
= gfc_match_name (name
);
2260 if (m
== MATCH_ERROR
)
2262 if (m
== MATCH_YES
&& gfc_match_char ('/') == MATCH_YES
)
2265 gfc_error ("Syntax error in common block name at %C");
2270 /* Match a COMMON statement. */
2273 gfc_match_common (void)
2275 gfc_symbol
*sym
, **head
, *tail
, *other
, *old_blank_common
;
2276 char name
[GFC_MAX_SYMBOL_LEN
+1];
2279 gfc_equiv
* e1
, * e2
;
2283 old_blank_common
= gfc_current_ns
->blank_common
.head
;
2284 if (old_blank_common
)
2286 while (old_blank_common
->common_next
)
2287 old_blank_common
= old_blank_common
->common_next
;
2294 m
= match_common_name (name
);
2295 if (m
== MATCH_ERROR
)
2298 gsym
= gfc_get_gsymbol (name
);
2299 if (gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= GSYM_COMMON
)
2301 gfc_error ("Symbol '%s' at %C is already an external symbol that is not COMMON",
2306 if (gsym
->type
== GSYM_UNKNOWN
)
2308 gsym
->type
= GSYM_COMMON
;
2309 gsym
->where
= gfc_current_locus
;
2315 if (name
[0] == '\0')
2317 t
= &gfc_current_ns
->blank_common
;
2318 if (t
->head
== NULL
)
2319 t
->where
= gfc_current_locus
;
2324 t
= gfc_get_common (name
, 0);
2333 while (tail
->common_next
)
2334 tail
= tail
->common_next
;
2337 /* Grab the list of symbols. */
2340 m
= gfc_match_symbol (&sym
, 0);
2341 if (m
== MATCH_ERROR
)
2346 if (sym
->attr
.in_common
)
2348 gfc_error ("Symbol '%s' at %C is already in a COMMON block",
2353 if (gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2356 if (sym
->value
!= NULL
2357 && (name
[0] == '\0' || !sym
->attr
.data
))
2359 if (name
[0] == '\0')
2360 gfc_error ("Previously initialized symbol '%s' in "
2361 "blank COMMON block at %C", sym
->name
);
2363 gfc_error ("Previously initialized symbol '%s' in "
2364 "COMMON block '%s' at %C", sym
->name
, name
);
2368 if (gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2371 /* Derived type names must have the SEQUENCE attribute. */
2372 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.derived
->attr
.sequence
)
2375 ("Derived type variable in COMMON at %C does not have the "
2376 "SEQUENCE attribute");
2381 tail
->common_next
= sym
;
2387 /* Deal with an optional array specification after the
2389 m
= gfc_match_array_spec (&as
);
2390 if (m
== MATCH_ERROR
)
2395 if (as
->type
!= AS_EXPLICIT
)
2398 ("Array specification for symbol '%s' in COMMON at %C "
2399 "must be explicit", sym
->name
);
2403 if (gfc_add_dimension (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2406 if (sym
->attr
.pointer
)
2409 ("Symbol '%s' in COMMON at %C cannot be a POINTER array",
2419 sym
->common_head
= t
;
2421 /* Check to see if the symbol is already in an equivalence group.
2422 If it is, set the other members as being in common. */
2423 if (sym
->attr
.in_equivalence
)
2425 for (e1
= gfc_current_ns
->equiv
; e1
; e1
= e1
->next
)
2427 for (e2
= e1
; e2
; e2
= e2
->eq
)
2428 if (e2
->expr
->symtree
->n
.sym
== sym
)
2435 for (e2
= e1
; e2
; e2
= e2
->eq
)
2437 other
= e2
->expr
->symtree
->n
.sym
;
2438 if (other
->common_head
2439 && other
->common_head
!= sym
->common_head
)
2441 gfc_error ("Symbol '%s', in COMMON block '%s' at "
2442 "%C is being indirectly equivalenced to "
2443 "another COMMON block '%s'",
2445 sym
->common_head
->name
,
2446 other
->common_head
->name
);
2449 other
->attr
.in_common
= 1;
2450 other
->common_head
= t
;
2456 gfc_gobble_whitespace ();
2457 if (gfc_match_eos () == MATCH_YES
)
2459 if (gfc_peek_char () == '/')
2461 if (gfc_match_char (',') != MATCH_YES
)
2463 gfc_gobble_whitespace ();
2464 if (gfc_peek_char () == '/')
2473 gfc_syntax_error (ST_COMMON
);
2476 if (old_blank_common
)
2477 old_blank_common
->common_next
= NULL
;
2479 gfc_current_ns
->blank_common
.head
= NULL
;
2480 gfc_free_array_spec (as
);
2485 /* Match a BLOCK DATA program unit. */
2488 gfc_match_block_data (void)
2490 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2494 if (gfc_match_eos () == MATCH_YES
)
2496 gfc_new_block
= NULL
;
2500 m
= gfc_match ("% %n%t", name
);
2504 if (gfc_get_symbol (name
, NULL
, &sym
))
2507 if (gfc_add_flavor (&sym
->attr
, FL_BLOCK_DATA
, sym
->name
, NULL
) == FAILURE
)
2510 gfc_new_block
= sym
;
2516 /* Free a namelist structure. */
2519 gfc_free_namelist (gfc_namelist
* name
)
2523 for (; name
; name
= n
)
2531 /* Match a NAMELIST statement. */
2534 gfc_match_namelist (void)
2536 gfc_symbol
*group_name
, *sym
;
2540 m
= gfc_match (" / %s /", &group_name
);
2543 if (m
== MATCH_ERROR
)
2548 if (group_name
->ts
.type
!= BT_UNKNOWN
)
2551 ("Namelist group name '%s' at %C already has a basic type "
2552 "of %s", group_name
->name
, gfc_typename (&group_name
->ts
));
2556 if (group_name
->attr
.flavor
== FL_NAMELIST
2557 && group_name
->attr
.use_assoc
2558 && gfc_notify_std (GFC_STD_GNU
, "Namelist group name '%s' "
2559 "at %C already is USE associated and can"
2560 "not be respecified.", group_name
->name
)
2564 if (group_name
->attr
.flavor
!= FL_NAMELIST
2565 && gfc_add_flavor (&group_name
->attr
, FL_NAMELIST
,
2566 group_name
->name
, NULL
) == FAILURE
)
2571 m
= gfc_match_symbol (&sym
, 1);
2574 if (m
== MATCH_ERROR
)
2577 if (sym
->attr
.in_namelist
== 0
2578 && gfc_add_in_namelist (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2581 /* Use gfc_error_check here, rather than goto error, so that this
2582 these are the only errors for the next two lines. */
2583 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
)
2585 gfc_error ("Assumed size array '%s' in namelist '%s'at "
2586 "%C is not allowed.", sym
->name
, group_name
->name
);
2590 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SHAPE
2591 && gfc_notify_std (GFC_STD_GNU
, "Assumed shape array '%s' in "
2592 "namelist '%s' at %C is an extension.",
2593 sym
->name
, group_name
->name
) == FAILURE
)
2596 nl
= gfc_get_namelist ();
2600 if (group_name
->namelist
== NULL
)
2601 group_name
->namelist
= group_name
->namelist_tail
= nl
;
2604 group_name
->namelist_tail
->next
= nl
;
2605 group_name
->namelist_tail
= nl
;
2608 if (gfc_match_eos () == MATCH_YES
)
2611 m
= gfc_match_char (',');
2613 if (gfc_match_char ('/') == MATCH_YES
)
2615 m2
= gfc_match (" %s /", &group_name
);
2616 if (m2
== MATCH_YES
)
2618 if (m2
== MATCH_ERROR
)
2632 gfc_syntax_error (ST_NAMELIST
);
2639 /* Match a MODULE statement. */
2642 gfc_match_module (void)
2646 m
= gfc_match (" %s%t", &gfc_new_block
);
2650 if (gfc_add_flavor (&gfc_new_block
->attr
, FL_MODULE
,
2651 gfc_new_block
->name
, NULL
) == FAILURE
)
2658 /* Free equivalence sets and lists. Recursively is the easiest way to
2662 gfc_free_equiv (gfc_equiv
* eq
)
2668 gfc_free_equiv (eq
->eq
);
2669 gfc_free_equiv (eq
->next
);
2671 gfc_free_expr (eq
->expr
);
2676 /* Match an EQUIVALENCE statement. */
2679 gfc_match_equivalence (void)
2681 gfc_equiv
*eq
, *set
, *tail
;
2685 gfc_common_head
*common_head
= NULL
;
2693 eq
= gfc_get_equiv ();
2697 eq
->next
= gfc_current_ns
->equiv
;
2698 gfc_current_ns
->equiv
= eq
;
2700 if (gfc_match_char ('(') != MATCH_YES
)
2704 common_flag
= FALSE
;
2709 m
= gfc_match_equiv_variable (&set
->expr
);
2710 if (m
== MATCH_ERROR
)
2715 /* count the number of objects. */
2718 if (gfc_match_char ('%') == MATCH_YES
)
2720 gfc_error ("Derived type component %C is not a "
2721 "permitted EQUIVALENCE member");
2725 for (ref
= set
->expr
->ref
; ref
; ref
= ref
->next
)
2726 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2729 ("Array reference in EQUIVALENCE at %C cannot be an "
2734 sym
= set
->expr
->symtree
->n
.sym
;
2736 if (gfc_add_in_equivalence (&sym
->attr
, sym
->name
, NULL
)
2740 if (sym
->attr
.in_common
)
2743 common_head
= sym
->common_head
;
2746 if (gfc_match_char (')') == MATCH_YES
)
2749 if (gfc_match_char (',') != MATCH_YES
)
2752 set
->eq
= gfc_get_equiv ();
2758 gfc_error ("EQUIVALENCE at %C requires two or more objects");
2762 /* If one of the members of an equivalence is in common, then
2763 mark them all as being in common. Before doing this, check
2764 that members of the equivalence group are not in different
2767 for (set
= eq
; set
; set
= set
->eq
)
2769 sym
= set
->expr
->symtree
->n
.sym
;
2770 if (sym
->common_head
&& sym
->common_head
!= common_head
)
2772 gfc_error ("Attempt to indirectly overlap COMMON "
2773 "blocks %s and %s by EQUIVALENCE at %C",
2774 sym
->common_head
->name
,
2778 sym
->attr
.in_common
= 1;
2779 sym
->common_head
= common_head
;
2782 if (gfc_match_eos () == MATCH_YES
)
2784 if (gfc_match_char (',') != MATCH_YES
)
2791 gfc_syntax_error (ST_EQUIVALENCE
);
2797 gfc_free_equiv (gfc_current_ns
->equiv
);
2798 gfc_current_ns
->equiv
= eq
;
2803 /* Check that a statement function is not recursive. This is done by looking
2804 for the statement function symbol(sym) by looking recursively through its
2805 expression(e). If a reference to sym is found, true is returned.
2806 12.5.4 requires that any variable of function that is implicitly typed
2807 shall have that type confirmed by any subsequent type declaration. The
2808 implicit typing is conveniently done here. */
2811 recursive_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
)
2813 gfc_actual_arglist
*arg
;
2820 switch (e
->expr_type
)
2823 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
2825 if (sym
->name
== arg
->name
2826 || recursive_stmt_fcn (arg
->expr
, sym
))
2830 if (e
->symtree
== NULL
)
2833 /* Check the name before testing for nested recursion! */
2834 if (sym
->name
== e
->symtree
->n
.sym
->name
)
2837 /* Catch recursion via other statement functions. */
2838 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
2839 && e
->symtree
->n
.sym
->value
2840 && recursive_stmt_fcn (e
->symtree
->n
.sym
->value
, sym
))
2843 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
2844 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
2849 if (e
->symtree
&& sym
->name
== e
->symtree
->n
.sym
->name
)
2852 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
2853 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
2857 if (recursive_stmt_fcn (e
->value
.op
.op1
, sym
)
2858 || recursive_stmt_fcn (e
->value
.op
.op2
, sym
))
2866 /* Component references do not need to be checked. */
2869 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2874 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2876 if (recursive_stmt_fcn (ref
->u
.ar
.start
[i
], sym
)
2877 || recursive_stmt_fcn (ref
->u
.ar
.end
[i
], sym
)
2878 || recursive_stmt_fcn (ref
->u
.ar
.stride
[i
], sym
))
2884 if (recursive_stmt_fcn (ref
->u
.ss
.start
, sym
)
2885 || recursive_stmt_fcn (ref
->u
.ss
.end
, sym
))
2899 /* Match a statement function declaration. It is so easy to match
2900 non-statement function statements with a MATCH_ERROR as opposed to
2901 MATCH_NO that we suppress error message in most cases. */
2904 gfc_match_st_function (void)
2906 gfc_error_buf old_error
;
2911 m
= gfc_match_symbol (&sym
, 0);
2915 gfc_push_error (&old_error
);
2917 if (gfc_add_procedure (&sym
->attr
, PROC_ST_FUNCTION
,
2918 sym
->name
, NULL
) == FAILURE
)
2921 if (gfc_match_formal_arglist (sym
, 1, 0) != MATCH_YES
)
2924 m
= gfc_match (" = %e%t", &expr
);
2928 gfc_free_error (&old_error
);
2929 if (m
== MATCH_ERROR
)
2932 if (recursive_stmt_fcn (expr
, sym
))
2934 gfc_error ("Statement function at %L is recursive",
2944 gfc_pop_error (&old_error
);
2949 /***************** SELECT CASE subroutines ******************/
2951 /* Free a single case structure. */
2954 free_case (gfc_case
* p
)
2956 if (p
->low
== p
->high
)
2958 gfc_free_expr (p
->low
);
2959 gfc_free_expr (p
->high
);
2964 /* Free a list of case structures. */
2967 gfc_free_case_list (gfc_case
* p
)
2979 /* Match a single case selector. */
2982 match_case_selector (gfc_case
** cp
)
2987 c
= gfc_get_case ();
2988 c
->where
= gfc_current_locus
;
2990 if (gfc_match_char (':') == MATCH_YES
)
2992 m
= gfc_match_init_expr (&c
->high
);
2995 if (m
== MATCH_ERROR
)
3001 m
= gfc_match_init_expr (&c
->low
);
3002 if (m
== MATCH_ERROR
)
3007 /* If we're not looking at a ':' now, make a range out of a single
3008 target. Else get the upper bound for the case range. */
3009 if (gfc_match_char (':') != MATCH_YES
)
3013 m
= gfc_match_init_expr (&c
->high
);
3014 if (m
== MATCH_ERROR
)
3016 /* MATCH_NO is fine. It's OK if nothing is there! */
3024 gfc_error ("Expected initialization expression in CASE at %C");
3032 /* Match the end of a case statement. */
3035 match_case_eos (void)
3037 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3040 if (gfc_match_eos () == MATCH_YES
)
3043 /* If the case construct doesn't have a case-construct-name, we
3044 should have matched the EOS. */
3045 if (!gfc_current_block ())
3048 gfc_gobble_whitespace ();
3050 m
= gfc_match_name (name
);
3054 if (strcmp (name
, gfc_current_block ()->name
) != 0)
3056 gfc_error ("Expected case name of '%s' at %C",
3057 gfc_current_block ()->name
);
3061 return gfc_match_eos ();
3065 /* Match a SELECT statement. */
3068 gfc_match_select (void)
3073 m
= gfc_match_label ();
3074 if (m
== MATCH_ERROR
)
3077 m
= gfc_match (" select case ( %e )%t", &expr
);
3081 new_st
.op
= EXEC_SELECT
;
3088 /* Match a CASE statement. */
3091 gfc_match_case (void)
3093 gfc_case
*c
, *head
, *tail
;
3098 if (gfc_current_state () != COMP_SELECT
)
3100 gfc_error ("Unexpected CASE statement at %C");
3104 if (gfc_match ("% default") == MATCH_YES
)
3106 m
= match_case_eos ();
3109 if (m
== MATCH_ERROR
)
3112 new_st
.op
= EXEC_SELECT
;
3113 c
= gfc_get_case ();
3114 c
->where
= gfc_current_locus
;
3115 new_st
.ext
.case_list
= c
;
3119 if (gfc_match_char ('(') != MATCH_YES
)
3124 if (match_case_selector (&c
) == MATCH_ERROR
)
3134 if (gfc_match_char (')') == MATCH_YES
)
3136 if (gfc_match_char (',') != MATCH_YES
)
3140 m
= match_case_eos ();
3143 if (m
== MATCH_ERROR
)
3146 new_st
.op
= EXEC_SELECT
;
3147 new_st
.ext
.case_list
= head
;
3152 gfc_error ("Syntax error in CASE-specification at %C");
3155 gfc_free_case_list (head
); /* new_st is cleaned up in parse.c. */
3159 /********************* WHERE subroutines ********************/
3161 /* Match the rest of a simple WHERE statement that follows an IF statement.
3165 match_simple_where (void)
3171 m
= gfc_match (" ( %e )", &expr
);
3175 m
= gfc_match_assignment ();
3178 if (m
== MATCH_ERROR
)
3181 if (gfc_match_eos () != MATCH_YES
)
3184 c
= gfc_get_code ();
3188 c
->next
= gfc_get_code ();
3191 gfc_clear_new_st ();
3193 new_st
.op
= EXEC_WHERE
;
3199 gfc_syntax_error (ST_WHERE
);
3202 gfc_free_expr (expr
);
3206 /* Match a WHERE statement. */
3209 gfc_match_where (gfc_statement
* st
)
3215 m0
= gfc_match_label ();
3216 if (m0
== MATCH_ERROR
)
3219 m
= gfc_match (" where ( %e )", &expr
);
3223 if (gfc_match_eos () == MATCH_YES
)
3225 *st
= ST_WHERE_BLOCK
;
3227 new_st
.op
= EXEC_WHERE
;
3232 m
= gfc_match_assignment ();
3234 gfc_syntax_error (ST_WHERE
);
3238 gfc_free_expr (expr
);
3242 /* We've got a simple WHERE statement. */
3244 c
= gfc_get_code ();
3248 c
->next
= gfc_get_code ();
3251 gfc_clear_new_st ();
3253 new_st
.op
= EXEC_WHERE
;
3260 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
3261 new_st if successful. */
3264 gfc_match_elsewhere (void)
3266 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3270 if (gfc_current_state () != COMP_WHERE
)
3272 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
3278 if (gfc_match_char ('(') == MATCH_YES
)
3280 m
= gfc_match_expr (&expr
);
3283 if (m
== MATCH_ERROR
)
3286 if (gfc_match_char (')') != MATCH_YES
)
3290 if (gfc_match_eos () != MATCH_YES
)
3291 { /* Better be a name at this point */
3292 m
= gfc_match_name (name
);
3295 if (m
== MATCH_ERROR
)
3298 if (gfc_match_eos () != MATCH_YES
)
3301 if (strcmp (name
, gfc_current_block ()->name
) != 0)
3303 gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
3304 name
, gfc_current_block ()->name
);
3309 new_st
.op
= EXEC_WHERE
;
3314 gfc_syntax_error (ST_ELSEWHERE
);
3317 gfc_free_expr (expr
);
3322 /******************** FORALL subroutines ********************/
3324 /* Free a list of FORALL iterators. */
3327 gfc_free_forall_iterator (gfc_forall_iterator
* iter
)
3329 gfc_forall_iterator
*next
;
3335 gfc_free_expr (iter
->var
);
3336 gfc_free_expr (iter
->start
);
3337 gfc_free_expr (iter
->end
);
3338 gfc_free_expr (iter
->stride
);
3346 /* Match an iterator as part of a FORALL statement. The format is:
3348 <var> = <start>:<end>[:<stride>][, <scalar mask>] */
3351 match_forall_iterator (gfc_forall_iterator
** result
)
3353 gfc_forall_iterator
*iter
;
3357 where
= gfc_current_locus
;
3358 iter
= gfc_getmem (sizeof (gfc_forall_iterator
));
3360 m
= gfc_match_variable (&iter
->var
, 0);
3364 if (gfc_match_char ('=') != MATCH_YES
)
3370 m
= gfc_match_expr (&iter
->start
);
3374 if (gfc_match_char (':') != MATCH_YES
)
3377 m
= gfc_match_expr (&iter
->end
);
3380 if (m
== MATCH_ERROR
)
3383 if (gfc_match_char (':') == MATCH_NO
)
3384 iter
->stride
= gfc_int_expr (1);
3387 m
= gfc_match_expr (&iter
->stride
);
3390 if (m
== MATCH_ERROR
)
3394 /* Mark the iteration variable's symbol as used as a FORALL index. */
3395 iter
->var
->symtree
->n
.sym
->forall_index
= true;
3401 gfc_error ("Syntax error in FORALL iterator at %C");
3405 /* Make sure that potential internal function references in the
3406 mask do not get messed up. */
3408 && iter
->var
->expr_type
== EXPR_VARIABLE
3409 && iter
->var
->symtree
->n
.sym
->refs
== 1)
3410 iter
->var
->symtree
->n
.sym
->attr
.flavor
= FL_UNKNOWN
;
3412 gfc_current_locus
= where
;
3413 gfc_free_forall_iterator (iter
);
3418 /* Match the header of a FORALL statement. */
3421 match_forall_header (gfc_forall_iterator
** phead
, gfc_expr
** mask
)
3423 gfc_forall_iterator
*head
, *tail
, *new;
3427 gfc_gobble_whitespace ();
3432 if (gfc_match_char ('(') != MATCH_YES
)
3435 m
= match_forall_iterator (&new);
3436 if (m
== MATCH_ERROR
)
3445 if (gfc_match_char (',') != MATCH_YES
)
3448 m
= match_forall_iterator (&new);
3449 if (m
== MATCH_ERROR
)
3459 /* Have to have a mask expression */
3461 m
= gfc_match_expr (&msk
);
3464 if (m
== MATCH_ERROR
)
3470 if (gfc_match_char (')') == MATCH_NO
)
3478 gfc_syntax_error (ST_FORALL
);
3481 gfc_free_expr (msk
);
3482 gfc_free_forall_iterator (head
);
3487 /* Match the rest of a simple FORALL statement that follows an IF statement.
3491 match_simple_forall (void)
3493 gfc_forall_iterator
*head
;
3502 m
= match_forall_header (&head
, &mask
);
3509 m
= gfc_match_assignment ();
3511 if (m
== MATCH_ERROR
)
3515 m
= gfc_match_pointer_assignment ();
3516 if (m
== MATCH_ERROR
)
3522 c
= gfc_get_code ();
3524 c
->loc
= gfc_current_locus
;
3526 if (gfc_match_eos () != MATCH_YES
)
3529 gfc_clear_new_st ();
3530 new_st
.op
= EXEC_FORALL
;
3532 new_st
.ext
.forall_iterator
= head
;
3533 new_st
.block
= gfc_get_code ();
3535 new_st
.block
->op
= EXEC_FORALL
;
3536 new_st
.block
->next
= c
;
3541 gfc_syntax_error (ST_FORALL
);
3544 gfc_free_forall_iterator (head
);
3545 gfc_free_expr (mask
);
3551 /* Match a FORALL statement. */
3554 gfc_match_forall (gfc_statement
* st
)
3556 gfc_forall_iterator
*head
;
3565 m0
= gfc_match_label ();
3566 if (m0
== MATCH_ERROR
)
3569 m
= gfc_match (" forall");
3573 m
= match_forall_header (&head
, &mask
);
3574 if (m
== MATCH_ERROR
)
3579 if (gfc_match_eos () == MATCH_YES
)
3581 *st
= ST_FORALL_BLOCK
;
3583 new_st
.op
= EXEC_FORALL
;
3585 new_st
.ext
.forall_iterator
= head
;
3590 m
= gfc_match_assignment ();
3591 if (m
== MATCH_ERROR
)
3595 m
= gfc_match_pointer_assignment ();
3596 if (m
== MATCH_ERROR
)
3602 c
= gfc_get_code ();
3604 c
->loc
= gfc_current_locus
;
3606 gfc_clear_new_st ();
3607 new_st
.op
= EXEC_FORALL
;
3609 new_st
.ext
.forall_iterator
= head
;
3610 new_st
.block
= gfc_get_code ();
3612 new_st
.block
->op
= EXEC_FORALL
;
3613 new_st
.block
->next
= c
;
3619 gfc_syntax_error (ST_FORALL
);
3622 gfc_free_forall_iterator (head
);
3623 gfc_free_expr (mask
);
3624 gfc_free_statements (c
);