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 (NULL
, INTRINSIC_NONE
)
65 /******************** Generic matching subroutines ************************/
67 /* In free form, match at least one space. Always matches in fixed
71 gfc_match_space (void)
76 if (gfc_current_form
== FORM_FIXED
)
79 old_loc
= gfc_current_locus
;
82 if (!gfc_is_whitespace (c
))
84 gfc_current_locus
= old_loc
;
88 gfc_gobble_whitespace ();
94 /* Match an end of statement. End of statement is optional
95 whitespace, followed by a ';' or '\n' or comment '!'. If a
96 semicolon is found, we continue to eat whitespace and semicolons. */
108 old_loc
= gfc_current_locus
;
109 gfc_gobble_whitespace ();
111 c
= gfc_next_char ();
117 c
= gfc_next_char ();
134 gfc_current_locus
= old_loc
;
135 return (flag
) ? MATCH_YES
: MATCH_NO
;
139 /* Match a literal integer on the input, setting the value on
140 MATCH_YES. Literal ints occur in kind-parameters as well as
141 old-style character length specifications. If cnt is non-NULL it
142 will be set to the number of digits. */
145 gfc_match_small_literal_int (int *value
, int *cnt
)
151 old_loc
= gfc_current_locus
;
153 gfc_gobble_whitespace ();
154 c
= gfc_next_char ();
160 gfc_current_locus
= old_loc
;
169 old_loc
= gfc_current_locus
;
170 c
= gfc_next_char ();
175 i
= 10 * i
+ c
- '0';
180 gfc_error ("Integer too large at %C");
185 gfc_current_locus
= old_loc
;
194 /* Match a small, constant integer expression, like in a kind
195 statement. On MATCH_YES, 'value' is set. */
198 gfc_match_small_int (int *value
)
205 m
= gfc_match_expr (&expr
);
209 p
= gfc_extract_int (expr
, &i
);
210 gfc_free_expr (expr
);
223 /* Matches a statement label. Uses gfc_match_small_literal_int() to
224 do most of the work. */
227 gfc_match_st_label (gfc_st_label
** label
)
233 old_loc
= gfc_current_locus
;
235 m
= gfc_match_small_literal_int (&i
, &cnt
);
241 gfc_error ("Too many digits in statement label at %C");
247 gfc_error ("Statement label at %C is zero");
251 *label
= gfc_get_st_label (i
);
256 gfc_current_locus
= old_loc
;
261 /* Match and validate a label associated with a named IF, DO or SELECT
262 statement. If the symbol does not have the label attribute, we add
263 it. We also make sure the symbol does not refer to another
264 (active) block. A matched label is pointed to by gfc_new_block. */
267 gfc_match_label (void)
269 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
272 gfc_new_block
= NULL
;
274 m
= gfc_match (" %n :", name
);
278 if (gfc_get_symbol (name
, NULL
, &gfc_new_block
))
280 gfc_error ("Label name '%s' at %C is ambiguous", name
);
284 if (gfc_new_block
->attr
.flavor
== FL_LABEL
)
286 gfc_error ("Duplicate construct label '%s' at %C", name
);
290 if (gfc_add_flavor (&gfc_new_block
->attr
, FL_LABEL
,
291 gfc_new_block
->name
, NULL
) == FAILURE
)
298 /* Try and match the input against an array of possibilities. If one
299 potential matching string is a substring of another, the longest
300 match takes precedence. Spaces in the target strings are optional
301 spaces that do not necessarily have to be found in the input
302 stream. In fixed mode, spaces never appear. If whitespace is
303 matched, it matches unlimited whitespace in the input. For this
304 reason, the 'mp' member of the mstring structure is used to track
305 the progress of each potential match.
307 If there is no match we return the tag associated with the
308 terminating NULL mstring structure and leave the locus pointer
309 where it started. If there is a match we return the tag member of
310 the matched mstring and leave the locus pointer after the matched
313 A '%' character is a mandatory space. */
316 gfc_match_strings (mstring
* a
)
318 mstring
*p
, *best_match
;
319 int no_match
, c
, possibles
;
324 for (p
= a
; p
->string
!= NULL
; p
++)
333 match_loc
= gfc_current_locus
;
335 gfc_gobble_whitespace ();
337 while (possibles
> 0)
339 c
= gfc_next_char ();
341 /* Apply the next character to the current possibilities. */
342 for (p
= a
; p
->string
!= NULL
; p
++)
349 /* Space matches 1+ whitespace(s). */
350 if ((gfc_current_form
== FORM_FREE
)
351 && gfc_is_whitespace (c
))
369 match_loc
= gfc_current_locus
;
377 gfc_current_locus
= match_loc
;
379 return (best_match
== NULL
) ? no_match
: best_match
->tag
;
383 /* See if the current input looks like a name of some sort. Modifies
384 the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long. */
387 gfc_match_name (char *buffer
)
392 old_loc
= gfc_current_locus
;
393 gfc_gobble_whitespace ();
395 c
= gfc_next_char ();
398 gfc_current_locus
= old_loc
;
408 if (i
> gfc_option
.max_identifier_length
)
410 gfc_error ("Name at %C is too long");
414 old_loc
= gfc_current_locus
;
415 c
= gfc_next_char ();
419 || (gfc_option
.flag_dollar_ok
&& c
== '$'));
422 gfc_current_locus
= old_loc
;
428 /* Match a symbol on the input. Modifies the pointer to the symbol
429 pointer if successful. */
432 gfc_match_sym_tree (gfc_symtree
** matched_symbol
, int host_assoc
)
434 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
437 m
= gfc_match_name (buffer
);
442 return (gfc_get_ha_sym_tree (buffer
, matched_symbol
))
443 ? MATCH_ERROR
: MATCH_YES
;
445 if (gfc_get_sym_tree (buffer
, NULL
, matched_symbol
))
453 gfc_match_symbol (gfc_symbol
** matched_symbol
, int host_assoc
)
458 m
= gfc_match_sym_tree (&st
, host_assoc
);
463 *matched_symbol
= st
->n
.sym
;
465 *matched_symbol
= NULL
;
468 *matched_symbol
= NULL
;
472 /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
473 we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
477 gfc_match_intrinsic_op (gfc_intrinsic_op
* result
)
481 op
= (gfc_intrinsic_op
) gfc_match_strings (intrinsic_operators
);
483 if (op
== INTRINSIC_NONE
)
491 /* Match a loop control phrase:
493 <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
495 If the final integer expression is not present, a constant unity
496 expression is returned. We don't return MATCH_ERROR until after
497 the equals sign is seen. */
500 gfc_match_iterator (gfc_iterator
* iter
, int init_flag
)
502 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
503 gfc_expr
*var
, *e1
, *e2
, *e3
;
507 /* Match the start of an iterator without affecting the symbol
510 start
= gfc_current_locus
;
511 m
= gfc_match (" %n =", name
);
512 gfc_current_locus
= start
;
517 m
= gfc_match_variable (&var
, 0);
521 gfc_match_char ('=');
525 if (var
->ref
!= NULL
)
527 gfc_error ("Loop variable at %C cannot be a sub-component");
531 if (var
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
533 gfc_error ("Loop variable '%s' at %C cannot be INTENT(IN)",
534 var
->symtree
->n
.sym
->name
);
538 if (var
->symtree
->n
.sym
->attr
.pointer
)
540 gfc_error ("Loop variable at %C cannot have the POINTER attribute");
544 m
= init_flag
? gfc_match_init_expr (&e1
) : gfc_match_expr (&e1
);
547 if (m
== MATCH_ERROR
)
550 if (gfc_match_char (',') != MATCH_YES
)
553 m
= init_flag
? gfc_match_init_expr (&e2
) : gfc_match_expr (&e2
);
556 if (m
== MATCH_ERROR
)
559 if (gfc_match_char (',') != MATCH_YES
)
561 e3
= gfc_int_expr (1);
565 m
= init_flag
? gfc_match_init_expr (&e3
) : gfc_match_expr (&e3
);
566 if (m
== MATCH_ERROR
)
570 gfc_error ("Expected a step value in iterator at %C");
582 gfc_error ("Syntax error in iterator at %C");
593 /* Tries to match the next non-whitespace character on the input.
594 This subroutine does not return MATCH_ERROR. */
597 gfc_match_char (char c
)
601 where
= gfc_current_locus
;
602 gfc_gobble_whitespace ();
604 if (gfc_next_char () == c
)
607 gfc_current_locus
= where
;
612 /* General purpose matching subroutine. The target string is a
613 scanf-like format string in which spaces correspond to arbitrary
614 whitespace (including no whitespace), characters correspond to
615 themselves. The %-codes are:
617 %% Literal percent sign
618 %e Expression, pointer to a pointer is set
619 %s Symbol, pointer to the symbol is set
620 %n Name, character buffer is set to name
621 %t Matches end of statement.
622 %o Matches an intrinsic operator, returned as an INTRINSIC enum.
623 %l Matches a statement label
624 %v Matches a variable expression (an lvalue)
625 % Matches a required space (in free form) and optional spaces. */
628 gfc_match (const char *target
, ...)
630 gfc_st_label
**label
;
639 old_loc
= gfc_current_locus
;
640 va_start (argp
, target
);
650 gfc_gobble_whitespace ();
661 vp
= va_arg (argp
, void **);
662 n
= gfc_match_expr ((gfc_expr
**) vp
);
673 vp
= va_arg (argp
, void **);
674 n
= gfc_match_variable ((gfc_expr
**) vp
, 0);
685 vp
= va_arg (argp
, void **);
686 n
= gfc_match_symbol ((gfc_symbol
**) vp
, 0);
697 np
= va_arg (argp
, char *);
698 n
= gfc_match_name (np
);
709 label
= va_arg (argp
, gfc_st_label
**);
710 n
= gfc_match_st_label (label
);
721 ip
= va_arg (argp
, int *);
722 n
= gfc_match_intrinsic_op ((gfc_intrinsic_op
*) ip
);
733 if (gfc_match_eos () != MATCH_YES
)
741 if (gfc_match_space () == MATCH_YES
)
747 break; /* Fall through to character matcher */
750 gfc_internal_error ("gfc_match(): Bad match code %c", c
);
754 if (c
== gfc_next_char ())
764 /* Clean up after a failed match. */
765 gfc_current_locus
= old_loc
;
766 va_start (argp
, target
);
769 for (; matches
> 0; matches
--)
779 /* Matches that don't have to be undone */
784 (void)va_arg (argp
, void **);
789 vp
= va_arg (argp
, void **);
803 /*********************** Statement level matching **********************/
805 /* Matches the start of a program unit, which is the program keyword
806 followed by an obligatory symbol. */
809 gfc_match_program (void)
814 m
= gfc_match ("% %s%t", &sym
);
818 gfc_error ("Invalid form of PROGRAM statement at %C");
822 if (m
== MATCH_ERROR
)
825 if (gfc_add_flavor (&sym
->attr
, FL_PROGRAM
, sym
->name
, NULL
) == FAILURE
)
834 /* Match a simple assignment statement. */
837 gfc_match_assignment (void)
839 gfc_expr
*lvalue
, *rvalue
;
843 old_loc
= gfc_current_locus
;
845 lvalue
= rvalue
= NULL
;
846 m
= gfc_match (" %v =", &lvalue
);
850 if (lvalue
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
852 gfc_error ("Cannot assign to a PARAMETER variable at %C");
857 m
= gfc_match (" %e%t", &rvalue
);
861 gfc_set_sym_referenced (lvalue
->symtree
->n
.sym
);
863 new_st
.op
= EXEC_ASSIGN
;
864 new_st
.expr
= lvalue
;
865 new_st
.expr2
= rvalue
;
867 gfc_check_do_variable (lvalue
->symtree
);
872 gfc_current_locus
= old_loc
;
873 gfc_free_expr (lvalue
);
874 gfc_free_expr (rvalue
);
879 /* Match a pointer assignment statement. */
882 gfc_match_pointer_assignment (void)
884 gfc_expr
*lvalue
, *rvalue
;
888 old_loc
= gfc_current_locus
;
890 lvalue
= rvalue
= NULL
;
892 m
= gfc_match (" %v =>", &lvalue
);
899 m
= gfc_match (" %e%t", &rvalue
);
903 new_st
.op
= EXEC_POINTER_ASSIGN
;
904 new_st
.expr
= lvalue
;
905 new_st
.expr2
= rvalue
;
910 gfc_current_locus
= old_loc
;
911 gfc_free_expr (lvalue
);
912 gfc_free_expr (rvalue
);
917 /* We try to match an easy arithmetic IF statement. This only happens
918 when just after having encountered a simple IF statement. This code
919 is really duplicate with parts of the gfc_match_if code, but this is
922 match_arithmetic_if (void)
924 gfc_st_label
*l1
, *l2
, *l3
;
928 m
= gfc_match (" ( %e ) %l , %l , %l%t", &expr
, &l1
, &l2
, &l3
);
932 if (gfc_reference_st_label (l1
, ST_LABEL_TARGET
) == FAILURE
933 || gfc_reference_st_label (l2
, ST_LABEL_TARGET
) == FAILURE
934 || gfc_reference_st_label (l3
, ST_LABEL_TARGET
) == FAILURE
)
936 gfc_free_expr (expr
);
940 if (gfc_notify_std (GFC_STD_F95_DEL
,
941 "Obsolete: arithmetic IF statement at %C") == FAILURE
)
944 new_st
.op
= EXEC_ARITHMETIC_IF
;
954 /* The IF statement is a bit of a pain. First of all, there are three
955 forms of it, the simple IF, the IF that starts a block and the
958 There is a problem with the simple IF and that is the fact that we
959 only have a single level of undo information on symbols. What this
960 means is for a simple IF, we must re-match the whole IF statement
961 multiple times in order to guarantee that the symbol table ends up
962 in the proper state. */
964 static match
match_simple_forall (void);
965 static match
match_simple_where (void);
968 gfc_match_if (gfc_statement
* if_type
)
971 gfc_st_label
*l1
, *l2
, *l3
;
976 n
= gfc_match_label ();
977 if (n
== MATCH_ERROR
)
980 old_loc
= gfc_current_locus
;
982 m
= gfc_match (" if ( %e", &expr
);
986 if (gfc_match_char (')') != MATCH_YES
)
988 gfc_error ("Syntax error in IF-expression at %C");
989 gfc_free_expr (expr
);
993 m
= gfc_match (" %l , %l , %l%t", &l1
, &l2
, &l3
);
1000 ("Block label not appropriate for arithmetic IF statement "
1003 gfc_free_expr (expr
);
1007 if (gfc_reference_st_label (l1
, ST_LABEL_TARGET
) == FAILURE
1008 || gfc_reference_st_label (l2
, ST_LABEL_TARGET
) == FAILURE
1009 || gfc_reference_st_label (l3
, ST_LABEL_TARGET
) == FAILURE
)
1012 gfc_free_expr (expr
);
1016 if (gfc_notify_std (GFC_STD_F95_DEL
,
1017 "Obsolete: arithmetic IF statement at %C")
1021 new_st
.op
= EXEC_ARITHMETIC_IF
;
1027 *if_type
= ST_ARITHMETIC_IF
;
1031 if (gfc_match (" then%t") == MATCH_YES
)
1033 new_st
.op
= EXEC_IF
;
1036 *if_type
= ST_IF_BLOCK
;
1042 gfc_error ("Block label is not appropriate IF statement at %C");
1044 gfc_free_expr (expr
);
1048 /* At this point the only thing left is a simple IF statement. At
1049 this point, n has to be MATCH_NO, so we don't have to worry about
1050 re-matching a block label. From what we've got so far, try
1051 matching an assignment. */
1053 *if_type
= ST_SIMPLE_IF
;
1055 m
= gfc_match_assignment ();
1059 gfc_free_expr (expr
);
1060 gfc_undo_symbols ();
1061 gfc_current_locus
= old_loc
;
1063 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match */
1065 m
= gfc_match_pointer_assignment ();
1069 gfc_free_expr (expr
);
1070 gfc_undo_symbols ();
1071 gfc_current_locus
= old_loc
;
1073 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match */
1075 /* Look at the next keyword to see which matcher to call. Matching
1076 the keyword doesn't affect the symbol table, so we don't have to
1077 restore between tries. */
1079 #define match(string, subr, statement) \
1080 if (gfc_match(string) == MATCH_YES) { m = subr(); goto got_match; }
1084 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
)
1085 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
)
1086 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
)
1087 match ("call", gfc_match_call
, ST_CALL
)
1088 match ("close", gfc_match_close
, ST_CLOSE
)
1089 match ("continue", gfc_match_continue
, ST_CONTINUE
)
1090 match ("cycle", gfc_match_cycle
, ST_CYCLE
)
1091 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
)
1092 match ("end file", gfc_match_endfile
, ST_END_FILE
)
1093 match ("exit", gfc_match_exit
, ST_EXIT
)
1094 match ("flush", gfc_match_flush
, ST_FLUSH
)
1095 match ("forall", match_simple_forall
, ST_FORALL
)
1096 match ("go to", gfc_match_goto
, ST_GOTO
)
1097 match ("if", match_arithmetic_if
, ST_ARITHMETIC_IF
)
1098 match ("inquire", gfc_match_inquire
, ST_INQUIRE
)
1099 match ("nullify", gfc_match_nullify
, ST_NULLIFY
)
1100 match ("open", gfc_match_open
, ST_OPEN
)
1101 match ("pause", gfc_match_pause
, ST_NONE
)
1102 match ("print", gfc_match_print
, ST_WRITE
)
1103 match ("read", gfc_match_read
, ST_READ
)
1104 match ("return", gfc_match_return
, ST_RETURN
)
1105 match ("rewind", gfc_match_rewind
, ST_REWIND
)
1106 match ("stop", gfc_match_stop
, ST_STOP
)
1107 match ("where", match_simple_where
, ST_WHERE
)
1108 match ("write", gfc_match_write
, ST_WRITE
)
1110 /* All else has failed, so give up. See if any of the matchers has
1111 stored an error message of some sort. */
1112 if (gfc_error_check () == 0)
1113 gfc_error ("Unclassifiable statement in IF-clause at %C");
1115 gfc_free_expr (expr
);
1120 gfc_error ("Syntax error in IF-clause at %C");
1123 gfc_free_expr (expr
);
1127 /* At this point, we've matched the single IF and the action clause
1128 is in new_st. Rearrange things so that the IF statement appears
1131 p
= gfc_get_code ();
1132 p
->next
= gfc_get_code ();
1134 p
->next
->loc
= gfc_current_locus
;
1139 gfc_clear_new_st ();
1141 new_st
.op
= EXEC_IF
;
1150 /* Match an ELSE statement. */
1153 gfc_match_else (void)
1155 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1157 if (gfc_match_eos () == MATCH_YES
)
1160 if (gfc_match_name (name
) != MATCH_YES
1161 || gfc_current_block () == NULL
1162 || gfc_match_eos () != MATCH_YES
)
1164 gfc_error ("Unexpected junk after ELSE statement at %C");
1168 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1170 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1171 name
, gfc_current_block ()->name
);
1179 /* Match an ELSE IF statement. */
1182 gfc_match_elseif (void)
1184 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1188 m
= gfc_match (" ( %e ) then", &expr
);
1192 if (gfc_match_eos () == MATCH_YES
)
1195 if (gfc_match_name (name
) != MATCH_YES
1196 || gfc_current_block () == NULL
1197 || gfc_match_eos () != MATCH_YES
)
1199 gfc_error ("Unexpected junk after ELSE IF statement at %C");
1203 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1205 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1206 name
, gfc_current_block ()->name
);
1211 new_st
.op
= EXEC_IF
;
1216 gfc_free_expr (expr
);
1221 /* Free a gfc_iterator structure. */
1224 gfc_free_iterator (gfc_iterator
* iter
, int flag
)
1230 gfc_free_expr (iter
->var
);
1231 gfc_free_expr (iter
->start
);
1232 gfc_free_expr (iter
->end
);
1233 gfc_free_expr (iter
->step
);
1240 /* Match a DO statement. */
1245 gfc_iterator iter
, *ip
;
1247 gfc_st_label
*label
;
1250 old_loc
= gfc_current_locus
;
1253 iter
.var
= iter
.start
= iter
.end
= iter
.step
= NULL
;
1255 m
= gfc_match_label ();
1256 if (m
== MATCH_ERROR
)
1259 if (gfc_match (" do") != MATCH_YES
)
1262 m
= gfc_match_st_label (&label
);
1263 if (m
== MATCH_ERROR
)
1266 /* Match an infinite DO, make it like a DO WHILE(.TRUE.) */
1268 if (gfc_match_eos () == MATCH_YES
)
1270 iter
.end
= gfc_logical_expr (1, NULL
);
1271 new_st
.op
= EXEC_DO_WHILE
;
1275 /* match an optional comma, if no comma is found a space is obligatory. */
1276 if (gfc_match_char(',') != MATCH_YES
1277 && gfc_match ("% ") != MATCH_YES
)
1280 /* See if we have a DO WHILE. */
1281 if (gfc_match (" while ( %e )%t", &iter
.end
) == MATCH_YES
)
1283 new_st
.op
= EXEC_DO_WHILE
;
1287 /* The abortive DO WHILE may have done something to the symbol
1288 table, so we start over: */
1289 gfc_undo_symbols ();
1290 gfc_current_locus
= old_loc
;
1292 gfc_match_label (); /* This won't error */
1293 gfc_match (" do "); /* This will work */
1295 gfc_match_st_label (&label
); /* Can't error out */
1296 gfc_match_char (','); /* Optional comma */
1298 m
= gfc_match_iterator (&iter
, 0);
1301 if (m
== MATCH_ERROR
)
1304 gfc_check_do_variable (iter
.var
->symtree
);
1306 if (gfc_match_eos () != MATCH_YES
)
1308 gfc_syntax_error (ST_DO
);
1312 new_st
.op
= EXEC_DO
;
1316 && gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
1319 new_st
.label
= label
;
1321 if (new_st
.op
== EXEC_DO_WHILE
)
1322 new_st
.expr
= iter
.end
;
1325 new_st
.ext
.iterator
= ip
= gfc_get_iterator ();
1332 gfc_free_iterator (&iter
, 0);
1338 /* Match an EXIT or CYCLE statement. */
1341 match_exit_cycle (gfc_statement st
, gfc_exec_op op
)
1347 if (gfc_match_eos () == MATCH_YES
)
1351 m
= gfc_match ("% %s%t", &sym
);
1352 if (m
== MATCH_ERROR
)
1356 gfc_syntax_error (st
);
1360 if (sym
->attr
.flavor
!= FL_LABEL
)
1362 gfc_error ("Name '%s' in %s statement at %C is not a loop name",
1363 sym
->name
, gfc_ascii_statement (st
));
1368 /* Find the loop mentioned specified by the label (or lack of a
1370 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1371 if (p
->state
== COMP_DO
&& (sym
== NULL
|| sym
== p
->sym
))
1377 gfc_error ("%s statement at %C is not within a loop",
1378 gfc_ascii_statement (st
));
1380 gfc_error ("%s statement at %C is not within loop '%s'",
1381 gfc_ascii_statement (st
), sym
->name
);
1386 /* Save the first statement in the loop - needed by the backend. */
1387 new_st
.ext
.whichloop
= p
->head
;
1390 /* new_st.sym = sym;*/
1396 /* Match the EXIT statement. */
1399 gfc_match_exit (void)
1402 return match_exit_cycle (ST_EXIT
, EXEC_EXIT
);
1406 /* Match the CYCLE statement. */
1409 gfc_match_cycle (void)
1412 return match_exit_cycle (ST_CYCLE
, EXEC_CYCLE
);
1416 /* Match a number or character constant after a STOP or PAUSE statement. */
1419 gfc_match_stopcode (gfc_statement st
)
1429 if (gfc_match_eos () != MATCH_YES
)
1431 m
= gfc_match_small_literal_int (&stop_code
, &cnt
);
1432 if (m
== MATCH_ERROR
)
1435 if (m
== MATCH_YES
&& cnt
> 5)
1437 gfc_error ("Too many digits in STOP code at %C");
1443 /* Try a character constant. */
1444 m
= gfc_match_expr (&e
);
1445 if (m
== MATCH_ERROR
)
1449 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1453 if (gfc_match_eos () != MATCH_YES
)
1457 if (gfc_pure (NULL
))
1459 gfc_error ("%s statement not allowed in PURE procedure at %C",
1460 gfc_ascii_statement (st
));
1464 new_st
.op
= st
== ST_STOP
? EXEC_STOP
: EXEC_PAUSE
;
1466 new_st
.ext
.stop_code
= stop_code
;
1471 gfc_syntax_error (st
);
1479 /* Match the (deprecated) PAUSE statement. */
1482 gfc_match_pause (void)
1486 m
= gfc_match_stopcode (ST_PAUSE
);
1489 if (gfc_notify_std (GFC_STD_F95_DEL
,
1490 "Obsolete: PAUSE statement at %C")
1498 /* Match the STOP statement. */
1501 gfc_match_stop (void)
1503 return gfc_match_stopcode (ST_STOP
);
1507 /* Match a CONTINUE statement. */
1510 gfc_match_continue (void)
1513 if (gfc_match_eos () != MATCH_YES
)
1515 gfc_syntax_error (ST_CONTINUE
);
1519 new_st
.op
= EXEC_CONTINUE
;
1524 /* Match the (deprecated) ASSIGN statement. */
1527 gfc_match_assign (void)
1530 gfc_st_label
*label
;
1532 if (gfc_match (" %l", &label
) == MATCH_YES
)
1534 if (gfc_reference_st_label (label
, ST_LABEL_UNKNOWN
) == FAILURE
)
1536 if (gfc_match (" to %v%t", &expr
) == MATCH_YES
)
1538 if (gfc_notify_std (GFC_STD_F95_DEL
,
1539 "Obsolete: ASSIGN statement at %C")
1543 expr
->symtree
->n
.sym
->attr
.assign
= 1;
1545 new_st
.op
= EXEC_LABEL_ASSIGN
;
1546 new_st
.label
= label
;
1555 /* Match the GO TO statement. As a computed GOTO statement is
1556 matched, it is transformed into an equivalent SELECT block. No
1557 tree is necessary, and the resulting jumps-to-jumps are
1558 specifically optimized away by the back end. */
1561 gfc_match_goto (void)
1563 gfc_code
*head
, *tail
;
1566 gfc_st_label
*label
;
1570 if (gfc_match (" %l%t", &label
) == MATCH_YES
)
1572 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
1575 new_st
.op
= EXEC_GOTO
;
1576 new_st
.label
= label
;
1580 /* The assigned GO TO statement. */
1582 if (gfc_match_variable (&expr
, 0) == MATCH_YES
)
1584 if (gfc_notify_std (GFC_STD_F95_DEL
,
1585 "Obsolete: Assigned GOTO statement at %C")
1589 new_st
.op
= EXEC_GOTO
;
1592 if (gfc_match_eos () == MATCH_YES
)
1595 /* Match label list. */
1596 gfc_match_char (',');
1597 if (gfc_match_char ('(') != MATCH_YES
)
1599 gfc_syntax_error (ST_GOTO
);
1606 m
= gfc_match_st_label (&label
);
1610 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
1614 head
= tail
= gfc_get_code ();
1617 tail
->block
= gfc_get_code ();
1621 tail
->label
= label
;
1622 tail
->op
= EXEC_GOTO
;
1624 while (gfc_match_char (',') == MATCH_YES
);
1626 if (gfc_match (")%t") != MATCH_YES
)
1632 "Statement label list in GOTO at %C cannot be empty");
1635 new_st
.block
= head
;
1640 /* Last chance is a computed GO TO statement. */
1641 if (gfc_match_char ('(') != MATCH_YES
)
1643 gfc_syntax_error (ST_GOTO
);
1652 m
= gfc_match_st_label (&label
);
1656 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
1660 head
= tail
= gfc_get_code ();
1663 tail
->block
= gfc_get_code ();
1667 cp
= gfc_get_case ();
1668 cp
->low
= cp
->high
= gfc_int_expr (i
++);
1670 tail
->op
= EXEC_SELECT
;
1671 tail
->ext
.case_list
= cp
;
1673 tail
->next
= gfc_get_code ();
1674 tail
->next
->op
= EXEC_GOTO
;
1675 tail
->next
->label
= label
;
1677 while (gfc_match_char (',') == MATCH_YES
);
1679 if (gfc_match_char (')') != MATCH_YES
)
1684 gfc_error ("Statement label list in GOTO at %C cannot be empty");
1688 /* Get the rest of the statement. */
1689 gfc_match_char (',');
1691 if (gfc_match (" %e%t", &expr
) != MATCH_YES
)
1694 /* At this point, a computed GOTO has been fully matched and an
1695 equivalent SELECT statement constructed. */
1697 new_st
.op
= EXEC_SELECT
;
1700 /* Hack: For a "real" SELECT, the expression is in expr. We put
1701 it in expr2 so we can distinguish then and produce the correct
1703 new_st
.expr2
= expr
;
1704 new_st
.block
= head
;
1708 gfc_syntax_error (ST_GOTO
);
1710 gfc_free_statements (head
);
1715 /* Frees a list of gfc_alloc structures. */
1718 gfc_free_alloc_list (gfc_alloc
* p
)
1725 gfc_free_expr (p
->expr
);
1731 /* Match an ALLOCATE statement. */
1734 gfc_match_allocate (void)
1736 gfc_alloc
*head
, *tail
;
1743 if (gfc_match_char ('(') != MATCH_YES
)
1749 head
= tail
= gfc_get_alloc ();
1752 tail
->next
= gfc_get_alloc ();
1756 m
= gfc_match_variable (&tail
->expr
, 0);
1759 if (m
== MATCH_ERROR
)
1762 if (gfc_check_do_variable (tail
->expr
->symtree
))
1766 && gfc_impure_variable (tail
->expr
->symtree
->n
.sym
))
1768 gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a "
1773 if (gfc_match_char (',') != MATCH_YES
)
1776 m
= gfc_match (" stat = %v", &stat
);
1777 if (m
== MATCH_ERROR
)
1785 if (stat
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
1788 ("STAT variable '%s' of ALLOCATE statement at %C cannot be "
1789 "INTENT(IN)", stat
->symtree
->n
.sym
->name
);
1793 if (gfc_pure (NULL
) && gfc_impure_variable (stat
->symtree
->n
.sym
))
1796 ("Illegal STAT variable in ALLOCATE statement at %C for a PURE "
1801 if (stat
->symtree
->n
.sym
->attr
.flavor
!= FL_VARIABLE
)
1803 gfc_error("STAT expression at %C must be a variable");
1807 gfc_check_do_variable(stat
->symtree
);
1810 if (gfc_match (" )%t") != MATCH_YES
)
1813 new_st
.op
= EXEC_ALLOCATE
;
1815 new_st
.ext
.alloc_list
= head
;
1820 gfc_syntax_error (ST_ALLOCATE
);
1823 gfc_free_expr (stat
);
1824 gfc_free_alloc_list (head
);
1829 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
1830 a set of pointer assignments to intrinsic NULL(). */
1833 gfc_match_nullify (void)
1841 if (gfc_match_char ('(') != MATCH_YES
)
1846 m
= gfc_match_variable (&p
, 0);
1847 if (m
== MATCH_ERROR
)
1852 if (gfc_check_do_variable(p
->symtree
))
1855 if (gfc_pure (NULL
) && gfc_impure_variable (p
->symtree
->n
.sym
))
1858 ("Illegal variable in NULLIFY at %C for a PURE procedure");
1862 /* build ' => NULL() ' */
1863 e
= gfc_get_expr ();
1864 e
->where
= gfc_current_locus
;
1865 e
->expr_type
= EXPR_NULL
;
1866 e
->ts
.type
= BT_UNKNOWN
;
1873 tail
->next
= gfc_get_code ();
1877 tail
->op
= EXEC_POINTER_ASSIGN
;
1881 if (gfc_match (" )%t") == MATCH_YES
)
1883 if (gfc_match_char (',') != MATCH_YES
)
1890 gfc_syntax_error (ST_NULLIFY
);
1893 gfc_free_statements (tail
);
1898 /* Match a DEALLOCATE statement. */
1901 gfc_match_deallocate (void)
1903 gfc_alloc
*head
, *tail
;
1910 if (gfc_match_char ('(') != MATCH_YES
)
1916 head
= tail
= gfc_get_alloc ();
1919 tail
->next
= gfc_get_alloc ();
1923 m
= gfc_match_variable (&tail
->expr
, 0);
1924 if (m
== MATCH_ERROR
)
1929 if (gfc_check_do_variable (tail
->expr
->symtree
))
1933 && gfc_impure_variable (tail
->expr
->symtree
->n
.sym
))
1936 ("Illegal deallocate-expression in DEALLOCATE at %C for a PURE "
1941 if (gfc_match_char (',') != MATCH_YES
)
1944 m
= gfc_match (" stat = %v", &stat
);
1945 if (m
== MATCH_ERROR
)
1953 if (stat
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
1955 gfc_error ("STAT variable '%s' of DEALLOCATE statement at %C "
1956 "cannot be INTENT(IN)", stat
->symtree
->n
.sym
->name
);
1960 if (gfc_pure(NULL
) && gfc_impure_variable (stat
->symtree
->n
.sym
))
1962 gfc_error ("Illegal STAT variable in DEALLOCATE statement at %C "
1963 "for a PURE procedure");
1967 if (stat
->symtree
->n
.sym
->attr
.flavor
!= FL_VARIABLE
)
1969 gfc_error("STAT expression at %C must be a variable");
1973 gfc_check_do_variable(stat
->symtree
);
1976 if (gfc_match (" )%t") != MATCH_YES
)
1979 new_st
.op
= EXEC_DEALLOCATE
;
1981 new_st
.ext
.alloc_list
= head
;
1986 gfc_syntax_error (ST_DEALLOCATE
);
1989 gfc_free_expr (stat
);
1990 gfc_free_alloc_list (head
);
1995 /* Match a RETURN statement. */
1998 gfc_match_return (void)
2002 gfc_compile_state s
;
2006 if (gfc_match_eos () == MATCH_YES
)
2009 if (gfc_find_state (COMP_SUBROUTINE
) == FAILURE
)
2011 gfc_error ("Alternate RETURN statement at %C is only allowed within "
2016 if (gfc_current_form
== FORM_FREE
)
2018 /* The following are valid, so we can't require a blank after the
2022 c
= gfc_peek_char ();
2023 if (ISALPHA (c
) || ISDIGIT (c
))
2027 m
= gfc_match (" %e%t", &e
);
2030 if (m
== MATCH_ERROR
)
2033 gfc_syntax_error (ST_RETURN
);
2040 gfc_enclosing_unit (&s
);
2041 if (s
== COMP_PROGRAM
2042 && gfc_notify_std (GFC_STD_GNU
, "Extension: RETURN statement in "
2043 "main program at %C") == FAILURE
)
2046 new_st
.op
= EXEC_RETURN
;
2053 /* Match a CALL statement. The tricky part here are possible
2054 alternate return specifiers. We handle these by having all
2055 "subroutines" actually return an integer via a register that gives
2056 the return number. If the call specifies alternate returns, we
2057 generate code for a SELECT statement whose case clauses contain
2058 GOTOs to the various labels. */
2061 gfc_match_call (void)
2063 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2064 gfc_actual_arglist
*a
, *arglist
;
2074 m
= gfc_match ("% %n", name
);
2080 if (gfc_get_ha_sym_tree (name
, &st
))
2084 gfc_set_sym_referenced (sym
);
2086 if (!sym
->attr
.generic
2087 && !sym
->attr
.subroutine
2088 && gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2091 if (gfc_match_eos () != MATCH_YES
)
2093 m
= gfc_match_actual_arglist (1, &arglist
);
2096 if (m
== MATCH_ERROR
)
2099 if (gfc_match_eos () != MATCH_YES
)
2103 /* If any alternate return labels were found, construct a SELECT
2104 statement that will jump to the right place. */
2107 for (a
= arglist
; a
; a
= a
->next
)
2108 if (a
->expr
== NULL
)
2113 gfc_symtree
*select_st
;
2114 gfc_symbol
*select_sym
;
2115 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2117 new_st
.next
= c
= gfc_get_code ();
2118 c
->op
= EXEC_SELECT
;
2119 sprintf (name
, "_result_%s",sym
->name
);
2120 gfc_get_ha_sym_tree (name
, &select_st
); /* Can't fail */
2122 select_sym
= select_st
->n
.sym
;
2123 select_sym
->ts
.type
= BT_INTEGER
;
2124 select_sym
->ts
.kind
= gfc_default_integer_kind
;
2125 gfc_set_sym_referenced (select_sym
);
2126 c
->expr
= gfc_get_expr ();
2127 c
->expr
->expr_type
= EXPR_VARIABLE
;
2128 c
->expr
->symtree
= select_st
;
2129 c
->expr
->ts
= select_sym
->ts
;
2130 c
->expr
->where
= gfc_current_locus
;
2133 for (a
= arglist
; a
; a
= a
->next
)
2135 if (a
->expr
!= NULL
)
2138 if (gfc_reference_st_label (a
->label
, ST_LABEL_TARGET
) == FAILURE
)
2143 c
->block
= gfc_get_code ();
2145 c
->op
= EXEC_SELECT
;
2147 new_case
= gfc_get_case ();
2148 new_case
->high
= new_case
->low
= gfc_int_expr (i
);
2149 c
->ext
.case_list
= new_case
;
2151 c
->next
= gfc_get_code ();
2152 c
->next
->op
= EXEC_GOTO
;
2153 c
->next
->label
= a
->label
;
2157 new_st
.op
= EXEC_CALL
;
2158 new_st
.symtree
= st
;
2159 new_st
.ext
.actual
= arglist
;
2164 gfc_syntax_error (ST_CALL
);
2167 gfc_free_actual_arglist (arglist
);
2172 /* Given a name, return a pointer to the common head structure,
2173 creating it if it does not exist. If FROM_MODULE is nonzero, we
2174 mangle the name so that it doesn't interfere with commons defined
2175 in the using namespace.
2176 TODO: Add to global symbol tree. */
2179 gfc_get_common (const char *name
, int from_module
)
2182 static int serial
= 0;
2183 char mangled_name
[GFC_MAX_SYMBOL_LEN
+1];
2187 /* A use associated common block is only needed to correctly layout
2188 the variables it contains. */
2189 snprintf(mangled_name
, GFC_MAX_SYMBOL_LEN
, "_%d_%s", serial
++, name
);
2190 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, mangled_name
);
2194 st
= gfc_find_symtree (gfc_current_ns
->common_root
, name
);
2197 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, name
);
2200 if (st
->n
.common
== NULL
)
2202 st
->n
.common
= gfc_get_common_head ();
2203 st
->n
.common
->where
= gfc_current_locus
;
2204 strcpy (st
->n
.common
->name
, name
);
2207 return st
->n
.common
;
2211 /* Match a common block name. */
2214 match_common_name (char *name
)
2218 if (gfc_match_char ('/') == MATCH_NO
)
2224 if (gfc_match_char ('/') == MATCH_YES
)
2230 m
= gfc_match_name (name
);
2232 if (m
== MATCH_ERROR
)
2234 if (m
== MATCH_YES
&& gfc_match_char ('/') == MATCH_YES
)
2237 gfc_error ("Syntax error in common block name at %C");
2242 /* Match a COMMON statement. */
2245 gfc_match_common (void)
2247 gfc_symbol
*sym
, **head
, *tail
, *other
, *old_blank_common
;
2248 char name
[GFC_MAX_SYMBOL_LEN
+1];
2251 gfc_equiv
* e1
, * e2
;
2254 old_blank_common
= gfc_current_ns
->blank_common
.head
;
2255 if (old_blank_common
)
2257 while (old_blank_common
->common_next
)
2258 old_blank_common
= old_blank_common
->common_next
;
2265 m
= match_common_name (name
);
2266 if (m
== MATCH_ERROR
)
2269 if (name
[0] == '\0')
2271 t
= &gfc_current_ns
->blank_common
;
2272 if (t
->head
== NULL
)
2273 t
->where
= gfc_current_locus
;
2278 t
= gfc_get_common (name
, 0);
2287 while (tail
->common_next
)
2288 tail
= tail
->common_next
;
2291 /* Grab the list of symbols. */
2294 m
= gfc_match_symbol (&sym
, 0);
2295 if (m
== MATCH_ERROR
)
2300 if (sym
->attr
.in_common
)
2302 gfc_error ("Symbol '%s' at %C is already in a COMMON block",
2307 if (gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2310 if (sym
->value
!= NULL
2311 && (name
[0] == '\0' || !sym
->attr
.data
))
2313 if (name
[0] == '\0')
2314 gfc_error ("Previously initialized symbol '%s' in "
2315 "blank COMMON block at %C", sym
->name
);
2317 gfc_error ("Previously initialized symbol '%s' in "
2318 "COMMON block '%s' at %C", sym
->name
, name
);
2322 if (gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2325 /* Derived type names must have the SEQUENCE attribute. */
2326 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.derived
->attr
.sequence
)
2329 ("Derived type variable in COMMON at %C does not have the "
2330 "SEQUENCE attribute");
2335 tail
->common_next
= sym
;
2341 /* Deal with an optional array specification after the
2343 m
= gfc_match_array_spec (&as
);
2344 if (m
== MATCH_ERROR
)
2349 if (as
->type
!= AS_EXPLICIT
)
2352 ("Array specification for symbol '%s' in COMMON at %C "
2353 "must be explicit", sym
->name
);
2357 if (gfc_add_dimension (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2360 if (sym
->attr
.pointer
)
2363 ("Symbol '%s' in COMMON at %C cannot be a POINTER array",
2373 sym
->common_head
= t
;
2375 /* Check to see if the symbol is already in an equivalence group.
2376 If it is, set the other members as being in common. */
2377 if (sym
->attr
.in_equivalence
)
2379 for (e1
= gfc_current_ns
->equiv
; e1
; e1
= e1
->next
)
2381 for (e2
= e1
; e2
; e2
= e2
->eq
)
2382 if (e2
->expr
->symtree
->n
.sym
== sym
)
2389 for (e2
= e1
; e2
; e2
= e2
->eq
)
2391 other
= e2
->expr
->symtree
->n
.sym
;
2392 if (other
->common_head
2393 && other
->common_head
!= sym
->common_head
)
2395 gfc_error ("Symbol '%s', in COMMON block '%s' at "
2396 "%C is being indirectly equivalenced to "
2397 "another COMMON block '%s'",
2399 sym
->common_head
->name
,
2400 other
->common_head
->name
);
2403 other
->attr
.in_common
= 1;
2404 other
->common_head
= t
;
2410 gfc_gobble_whitespace ();
2411 if (gfc_match_eos () == MATCH_YES
)
2413 if (gfc_peek_char () == '/')
2415 if (gfc_match_char (',') != MATCH_YES
)
2417 gfc_gobble_whitespace ();
2418 if (gfc_peek_char () == '/')
2427 gfc_syntax_error (ST_COMMON
);
2430 if (old_blank_common
)
2431 old_blank_common
->common_next
= NULL
;
2433 gfc_current_ns
->blank_common
.head
= NULL
;
2434 gfc_free_array_spec (as
);
2439 /* Match a BLOCK DATA program unit. */
2442 gfc_match_block_data (void)
2444 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2448 if (gfc_match_eos () == MATCH_YES
)
2450 gfc_new_block
= NULL
;
2454 m
= gfc_match ("% %n%t", name
);
2458 if (gfc_get_symbol (name
, NULL
, &sym
))
2461 if (gfc_add_flavor (&sym
->attr
, FL_BLOCK_DATA
, sym
->name
, NULL
) == FAILURE
)
2464 gfc_new_block
= sym
;
2470 /* Free a namelist structure. */
2473 gfc_free_namelist (gfc_namelist
* name
)
2477 for (; name
; name
= n
)
2485 /* Match a NAMELIST statement. */
2488 gfc_match_namelist (void)
2490 gfc_symbol
*group_name
, *sym
;
2494 m
= gfc_match (" / %s /", &group_name
);
2497 if (m
== MATCH_ERROR
)
2502 if (group_name
->ts
.type
!= BT_UNKNOWN
)
2505 ("Namelist group name '%s' at %C already has a basic type "
2506 "of %s", group_name
->name
, gfc_typename (&group_name
->ts
));
2510 if (group_name
->attr
.flavor
== FL_NAMELIST
2511 && group_name
->attr
.use_assoc
2512 && gfc_notify_std (GFC_STD_GNU
, "Namelist group name '%s' "
2513 "at %C already is USE associated and can"
2514 "not be respecified.", group_name
->name
)
2518 if (group_name
->attr
.flavor
!= FL_NAMELIST
2519 && gfc_add_flavor (&group_name
->attr
, FL_NAMELIST
,
2520 group_name
->name
, NULL
) == FAILURE
)
2525 m
= gfc_match_symbol (&sym
, 1);
2528 if (m
== MATCH_ERROR
)
2531 if (sym
->attr
.in_namelist
== 0
2532 && gfc_add_in_namelist (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2535 /* Use gfc_error_check here, rather than goto error, so that this
2536 these are the only errors for the next two lines. */
2537 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
)
2539 gfc_error ("Assumed size array '%s' in namelist '%s'at "
2540 "%C is not allowed.", sym
->name
, group_name
->name
);
2544 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SHAPE
2545 && gfc_notify_std (GFC_STD_GNU
, "Assumed shape array '%s' in "
2546 "namelist '%s' at %C is an extension.",
2547 sym
->name
, group_name
->name
) == FAILURE
)
2550 nl
= gfc_get_namelist ();
2553 if (group_name
->namelist
== NULL
)
2554 group_name
->namelist
= group_name
->namelist_tail
= nl
;
2557 group_name
->namelist_tail
->next
= nl
;
2558 group_name
->namelist_tail
= nl
;
2561 if (gfc_match_eos () == MATCH_YES
)
2564 m
= gfc_match_char (',');
2566 if (gfc_match_char ('/') == MATCH_YES
)
2568 m2
= gfc_match (" %s /", &group_name
);
2569 if (m2
== MATCH_YES
)
2571 if (m2
== MATCH_ERROR
)
2585 gfc_syntax_error (ST_NAMELIST
);
2592 /* Match a MODULE statement. */
2595 gfc_match_module (void)
2599 m
= gfc_match (" %s%t", &gfc_new_block
);
2603 if (gfc_add_flavor (&gfc_new_block
->attr
, FL_MODULE
,
2604 gfc_new_block
->name
, NULL
) == FAILURE
)
2611 /* Free equivalence sets and lists. Recursively is the easiest way to
2615 gfc_free_equiv (gfc_equiv
* eq
)
2621 gfc_free_equiv (eq
->eq
);
2622 gfc_free_equiv (eq
->next
);
2624 gfc_free_expr (eq
->expr
);
2629 /* Match an EQUIVALENCE statement. */
2632 gfc_match_equivalence (void)
2634 gfc_equiv
*eq
, *set
, *tail
;
2638 gfc_common_head
*common_head
= NULL
;
2646 eq
= gfc_get_equiv ();
2650 eq
->next
= gfc_current_ns
->equiv
;
2651 gfc_current_ns
->equiv
= eq
;
2653 if (gfc_match_char ('(') != MATCH_YES
)
2657 common_flag
= FALSE
;
2662 m
= gfc_match_equiv_variable (&set
->expr
);
2663 if (m
== MATCH_ERROR
)
2668 /* count the number of objects. */
2671 if (gfc_match_char ('%') == MATCH_YES
)
2673 gfc_error ("Derived type component %C is not a "
2674 "permitted EQUIVALENCE member");
2678 for (ref
= set
->expr
->ref
; ref
; ref
= ref
->next
)
2679 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2682 ("Array reference in EQUIVALENCE at %C cannot be an "
2687 sym
= set
->expr
->symtree
->n
.sym
;
2689 if (gfc_add_in_equivalence (&sym
->attr
, sym
->name
, NULL
)
2693 if (sym
->attr
.in_common
)
2696 common_head
= sym
->common_head
;
2699 if (gfc_match_char (')') == MATCH_YES
)
2702 if (gfc_match_char (',') != MATCH_YES
)
2705 set
->eq
= gfc_get_equiv ();
2711 gfc_error ("EQUIVALENCE at %C requires two or more objects");
2715 /* If one of the members of an equivalence is in common, then
2716 mark them all as being in common. Before doing this, check
2717 that members of the equivalence group are not in different
2720 for (set
= eq
; set
; set
= set
->eq
)
2722 sym
= set
->expr
->symtree
->n
.sym
;
2723 if (sym
->common_head
&& sym
->common_head
!= common_head
)
2725 gfc_error ("Attempt to indirectly overlap COMMON "
2726 "blocks %s and %s by EQUIVALENCE at %C",
2727 sym
->common_head
->name
,
2731 sym
->attr
.in_common
= 1;
2732 sym
->common_head
= common_head
;
2735 if (gfc_match_eos () == MATCH_YES
)
2737 if (gfc_match_char (',') != MATCH_YES
)
2744 gfc_syntax_error (ST_EQUIVALENCE
);
2750 gfc_free_equiv (gfc_current_ns
->equiv
);
2751 gfc_current_ns
->equiv
= eq
;
2756 /* Check that a statement function is not recursive. This is done by looking
2757 for the statement function symbol(sym) by looking recursively through its
2758 expression(e). If a reference to sym is found, true is returned. */
2760 recursive_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
)
2762 gfc_actual_arglist
*arg
;
2769 switch (e
->expr_type
)
2772 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
2774 if (sym
->name
== arg
->name
2775 || recursive_stmt_fcn (arg
->expr
, sym
))
2779 if (e
->symtree
== NULL
)
2782 /* Check the name before testing for nested recursion! */
2783 if (sym
->name
== e
->symtree
->n
.sym
->name
)
2786 /* Catch recursion via other statement functions. */
2787 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
2788 && e
->symtree
->n
.sym
->value
2789 && recursive_stmt_fcn (e
->symtree
->n
.sym
->value
, sym
))
2795 if (e
->symtree
&& sym
->name
== e
->symtree
->n
.sym
->name
)
2800 if (recursive_stmt_fcn (e
->value
.op
.op1
, sym
)
2801 || recursive_stmt_fcn (e
->value
.op
.op2
, sym
))
2809 /* Component references do not need to be checked. */
2812 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2817 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2819 if (recursive_stmt_fcn (ref
->u
.ar
.start
[i
], sym
)
2820 || recursive_stmt_fcn (ref
->u
.ar
.end
[i
], sym
)
2821 || recursive_stmt_fcn (ref
->u
.ar
.stride
[i
], sym
))
2827 if (recursive_stmt_fcn (ref
->u
.ss
.start
, sym
)
2828 || recursive_stmt_fcn (ref
->u
.ss
.end
, sym
))
2842 /* Match a statement function declaration. It is so easy to match
2843 non-statement function statements with a MATCH_ERROR as opposed to
2844 MATCH_NO that we suppress error message in most cases. */
2847 gfc_match_st_function (void)
2849 gfc_error_buf old_error
;
2854 m
= gfc_match_symbol (&sym
, 0);
2858 gfc_push_error (&old_error
);
2860 if (gfc_add_procedure (&sym
->attr
, PROC_ST_FUNCTION
,
2861 sym
->name
, NULL
) == FAILURE
)
2864 if (gfc_match_formal_arglist (sym
, 1, 0) != MATCH_YES
)
2867 m
= gfc_match (" = %e%t", &expr
);
2871 gfc_free_error (&old_error
);
2872 if (m
== MATCH_ERROR
)
2875 if (recursive_stmt_fcn (expr
, sym
))
2877 gfc_error ("Statement function at %L is recursive",
2887 gfc_pop_error (&old_error
);
2892 /***************** SELECT CASE subroutines ******************/
2894 /* Free a single case structure. */
2897 free_case (gfc_case
* p
)
2899 if (p
->low
== p
->high
)
2901 gfc_free_expr (p
->low
);
2902 gfc_free_expr (p
->high
);
2907 /* Free a list of case structures. */
2910 gfc_free_case_list (gfc_case
* p
)
2922 /* Match a single case selector. */
2925 match_case_selector (gfc_case
** cp
)
2930 c
= gfc_get_case ();
2931 c
->where
= gfc_current_locus
;
2933 if (gfc_match_char (':') == MATCH_YES
)
2935 m
= gfc_match_init_expr (&c
->high
);
2938 if (m
== MATCH_ERROR
)
2944 m
= gfc_match_init_expr (&c
->low
);
2945 if (m
== MATCH_ERROR
)
2950 /* If we're not looking at a ':' now, make a range out of a single
2951 target. Else get the upper bound for the case range. */
2952 if (gfc_match_char (':') != MATCH_YES
)
2956 m
= gfc_match_init_expr (&c
->high
);
2957 if (m
== MATCH_ERROR
)
2959 /* MATCH_NO is fine. It's OK if nothing is there! */
2967 gfc_error ("Expected initialization expression in CASE at %C");
2975 /* Match the end of a case statement. */
2978 match_case_eos (void)
2980 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2983 if (gfc_match_eos () == MATCH_YES
)
2986 gfc_gobble_whitespace ();
2988 m
= gfc_match_name (name
);
2992 if (strcmp (name
, gfc_current_block ()->name
) != 0)
2994 gfc_error ("Expected case name of '%s' at %C",
2995 gfc_current_block ()->name
);
2999 return gfc_match_eos ();
3003 /* Match a SELECT statement. */
3006 gfc_match_select (void)
3011 m
= gfc_match_label ();
3012 if (m
== MATCH_ERROR
)
3015 m
= gfc_match (" select case ( %e )%t", &expr
);
3019 new_st
.op
= EXEC_SELECT
;
3026 /* Match a CASE statement. */
3029 gfc_match_case (void)
3031 gfc_case
*c
, *head
, *tail
;
3036 if (gfc_current_state () != COMP_SELECT
)
3038 gfc_error ("Unexpected CASE statement at %C");
3042 if (gfc_match ("% default") == MATCH_YES
)
3044 m
= match_case_eos ();
3047 if (m
== MATCH_ERROR
)
3050 new_st
.op
= EXEC_SELECT
;
3051 c
= gfc_get_case ();
3052 c
->where
= gfc_current_locus
;
3053 new_st
.ext
.case_list
= c
;
3057 if (gfc_match_char ('(') != MATCH_YES
)
3062 if (match_case_selector (&c
) == MATCH_ERROR
)
3072 if (gfc_match_char (')') == MATCH_YES
)
3074 if (gfc_match_char (',') != MATCH_YES
)
3078 m
= match_case_eos ();
3081 if (m
== MATCH_ERROR
)
3084 new_st
.op
= EXEC_SELECT
;
3085 new_st
.ext
.case_list
= head
;
3090 gfc_error ("Syntax error in CASE-specification at %C");
3093 gfc_free_case_list (head
); /* new_st is cleaned up in parse.c. */
3097 /********************* WHERE subroutines ********************/
3099 /* Match the rest of a simple WHERE statement that follows an IF statement.
3103 match_simple_where (void)
3109 m
= gfc_match (" ( %e )", &expr
);
3113 m
= gfc_match_assignment ();
3116 if (m
== MATCH_ERROR
)
3119 if (gfc_match_eos () != MATCH_YES
)
3122 c
= gfc_get_code ();
3126 c
->next
= gfc_get_code ();
3129 gfc_clear_new_st ();
3131 new_st
.op
= EXEC_WHERE
;
3137 gfc_syntax_error (ST_WHERE
);
3140 gfc_free_expr (expr
);
3144 /* Match a WHERE statement. */
3147 gfc_match_where (gfc_statement
* st
)
3153 m0
= gfc_match_label ();
3154 if (m0
== MATCH_ERROR
)
3157 m
= gfc_match (" where ( %e )", &expr
);
3161 if (gfc_match_eos () == MATCH_YES
)
3163 *st
= ST_WHERE_BLOCK
;
3165 new_st
.op
= EXEC_WHERE
;
3170 m
= gfc_match_assignment ();
3172 gfc_syntax_error (ST_WHERE
);
3176 gfc_free_expr (expr
);
3180 /* We've got a simple WHERE statement. */
3182 c
= gfc_get_code ();
3186 c
->next
= gfc_get_code ();
3189 gfc_clear_new_st ();
3191 new_st
.op
= EXEC_WHERE
;
3198 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
3199 new_st if successful. */
3202 gfc_match_elsewhere (void)
3204 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3208 if (gfc_current_state () != COMP_WHERE
)
3210 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
3216 if (gfc_match_char ('(') == MATCH_YES
)
3218 m
= gfc_match_expr (&expr
);
3221 if (m
== MATCH_ERROR
)
3224 if (gfc_match_char (')') != MATCH_YES
)
3228 if (gfc_match_eos () != MATCH_YES
)
3229 { /* Better be a name at this point */
3230 m
= gfc_match_name (name
);
3233 if (m
== MATCH_ERROR
)
3236 if (gfc_match_eos () != MATCH_YES
)
3239 if (strcmp (name
, gfc_current_block ()->name
) != 0)
3241 gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
3242 name
, gfc_current_block ()->name
);
3247 new_st
.op
= EXEC_WHERE
;
3252 gfc_syntax_error (ST_ELSEWHERE
);
3255 gfc_free_expr (expr
);
3260 /******************** FORALL subroutines ********************/
3262 /* Free a list of FORALL iterators. */
3265 gfc_free_forall_iterator (gfc_forall_iterator
* iter
)
3267 gfc_forall_iterator
*next
;
3273 gfc_free_expr (iter
->var
);
3274 gfc_free_expr (iter
->start
);
3275 gfc_free_expr (iter
->end
);
3276 gfc_free_expr (iter
->stride
);
3284 /* Match an iterator as part of a FORALL statement. The format is:
3286 <var> = <start>:<end>[:<stride>][, <scalar mask>] */
3289 match_forall_iterator (gfc_forall_iterator
** result
)
3291 gfc_forall_iterator
*iter
;
3295 where
= gfc_current_locus
;
3296 iter
= gfc_getmem (sizeof (gfc_forall_iterator
));
3298 m
= gfc_match_variable (&iter
->var
, 0);
3302 if (gfc_match_char ('=') != MATCH_YES
)
3308 m
= gfc_match_expr (&iter
->start
);
3312 if (gfc_match_char (':') != MATCH_YES
)
3315 m
= gfc_match_expr (&iter
->end
);
3318 if (m
== MATCH_ERROR
)
3321 if (gfc_match_char (':') == MATCH_NO
)
3322 iter
->stride
= gfc_int_expr (1);
3325 m
= gfc_match_expr (&iter
->stride
);
3328 if (m
== MATCH_ERROR
)
3336 gfc_error ("Syntax error in FORALL iterator at %C");
3340 gfc_current_locus
= where
;
3341 gfc_free_forall_iterator (iter
);
3346 /* Match the header of a FORALL statement. */
3349 match_forall_header (gfc_forall_iterator
** phead
, gfc_expr
** mask
)
3351 gfc_forall_iterator
*head
, *tail
, *new;
3354 gfc_gobble_whitespace ();
3359 if (gfc_match_char ('(') != MATCH_YES
)
3362 m
= match_forall_iterator (&new);
3363 if (m
== MATCH_ERROR
)
3372 if (gfc_match_char (',') != MATCH_YES
)
3375 m
= match_forall_iterator (&new);
3376 if (m
== MATCH_ERROR
)
3385 /* Have to have a mask expression */
3387 m
= gfc_match_expr (mask
);
3390 if (m
== MATCH_ERROR
)
3396 if (gfc_match_char (')') == MATCH_NO
)
3403 gfc_syntax_error (ST_FORALL
);
3406 gfc_free_expr (*mask
);
3407 gfc_free_forall_iterator (head
);
3412 /* Match the rest of a simple FORALL statement that follows an IF statement.
3416 match_simple_forall (void)
3418 gfc_forall_iterator
*head
;
3427 m
= match_forall_header (&head
, &mask
);
3434 m
= gfc_match_assignment ();
3436 if (m
== MATCH_ERROR
)
3440 m
= gfc_match_pointer_assignment ();
3441 if (m
== MATCH_ERROR
)
3447 c
= gfc_get_code ();
3449 c
->loc
= gfc_current_locus
;
3451 if (gfc_match_eos () != MATCH_YES
)
3454 gfc_clear_new_st ();
3455 new_st
.op
= EXEC_FORALL
;
3457 new_st
.ext
.forall_iterator
= head
;
3458 new_st
.block
= gfc_get_code ();
3460 new_st
.block
->op
= EXEC_FORALL
;
3461 new_st
.block
->next
= c
;
3466 gfc_syntax_error (ST_FORALL
);
3469 gfc_free_forall_iterator (head
);
3470 gfc_free_expr (mask
);
3476 /* Match a FORALL statement. */
3479 gfc_match_forall (gfc_statement
* st
)
3481 gfc_forall_iterator
*head
;
3490 m0
= gfc_match_label ();
3491 if (m0
== MATCH_ERROR
)
3494 m
= gfc_match (" forall");
3498 m
= match_forall_header (&head
, &mask
);
3499 if (m
== MATCH_ERROR
)
3504 if (gfc_match_eos () == MATCH_YES
)
3506 *st
= ST_FORALL_BLOCK
;
3508 new_st
.op
= EXEC_FORALL
;
3510 new_st
.ext
.forall_iterator
= head
;
3515 m
= gfc_match_assignment ();
3516 if (m
== MATCH_ERROR
)
3520 m
= gfc_match_pointer_assignment ();
3521 if (m
== MATCH_ERROR
)
3527 c
= gfc_get_code ();
3530 if (gfc_match_eos () != MATCH_YES
)
3533 gfc_clear_new_st ();
3534 new_st
.op
= EXEC_FORALL
;
3536 new_st
.ext
.forall_iterator
= head
;
3537 new_st
.block
= gfc_get_code ();
3539 new_st
.block
->op
= EXEC_FORALL
;
3540 new_st
.block
->next
= c
;
3546 gfc_syntax_error (ST_FORALL
);
3549 gfc_free_forall_iterator (head
);
3550 gfc_free_expr (mask
);
3551 gfc_free_statements (c
);