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
;
2255 old_blank_common
= gfc_current_ns
->blank_common
.head
;
2256 if (old_blank_common
)
2258 while (old_blank_common
->common_next
)
2259 old_blank_common
= old_blank_common
->common_next
;
2266 m
= match_common_name (name
);
2267 if (m
== MATCH_ERROR
)
2270 gsym
= gfc_get_gsymbol (name
);
2271 if (gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= GSYM_COMMON
)
2273 gfc_error ("Symbol '%s' at %C is already an external symbol that is not COMMON",
2278 if (gsym
->type
== GSYM_UNKNOWN
)
2280 gsym
->type
= GSYM_COMMON
;
2281 gsym
->where
= gfc_current_locus
;
2287 if (name
[0] == '\0')
2289 t
= &gfc_current_ns
->blank_common
;
2290 if (t
->head
== NULL
)
2291 t
->where
= gfc_current_locus
;
2296 t
= gfc_get_common (name
, 0);
2305 while (tail
->common_next
)
2306 tail
= tail
->common_next
;
2309 /* Grab the list of symbols. */
2312 m
= gfc_match_symbol (&sym
, 0);
2313 if (m
== MATCH_ERROR
)
2318 if (sym
->attr
.in_common
)
2320 gfc_error ("Symbol '%s' at %C is already in a COMMON block",
2325 if (gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2328 if (sym
->value
!= NULL
2329 && (name
[0] == '\0' || !sym
->attr
.data
))
2331 if (name
[0] == '\0')
2332 gfc_error ("Previously initialized symbol '%s' in "
2333 "blank COMMON block at %C", sym
->name
);
2335 gfc_error ("Previously initialized symbol '%s' in "
2336 "COMMON block '%s' at %C", sym
->name
, name
);
2340 if (gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2343 /* Derived type names must have the SEQUENCE attribute. */
2344 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.derived
->attr
.sequence
)
2347 ("Derived type variable in COMMON at %C does not have the "
2348 "SEQUENCE attribute");
2353 tail
->common_next
= sym
;
2359 /* Deal with an optional array specification after the
2361 m
= gfc_match_array_spec (&as
);
2362 if (m
== MATCH_ERROR
)
2367 if (as
->type
!= AS_EXPLICIT
)
2370 ("Array specification for symbol '%s' in COMMON at %C "
2371 "must be explicit", sym
->name
);
2375 if (gfc_add_dimension (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2378 if (sym
->attr
.pointer
)
2381 ("Symbol '%s' in COMMON at %C cannot be a POINTER array",
2391 sym
->common_head
= t
;
2393 /* Check to see if the symbol is already in an equivalence group.
2394 If it is, set the other members as being in common. */
2395 if (sym
->attr
.in_equivalence
)
2397 for (e1
= gfc_current_ns
->equiv
; e1
; e1
= e1
->next
)
2399 for (e2
= e1
; e2
; e2
= e2
->eq
)
2400 if (e2
->expr
->symtree
->n
.sym
== sym
)
2407 for (e2
= e1
; e2
; e2
= e2
->eq
)
2409 other
= e2
->expr
->symtree
->n
.sym
;
2410 if (other
->common_head
2411 && other
->common_head
!= sym
->common_head
)
2413 gfc_error ("Symbol '%s', in COMMON block '%s' at "
2414 "%C is being indirectly equivalenced to "
2415 "another COMMON block '%s'",
2417 sym
->common_head
->name
,
2418 other
->common_head
->name
);
2421 other
->attr
.in_common
= 1;
2422 other
->common_head
= t
;
2428 gfc_gobble_whitespace ();
2429 if (gfc_match_eos () == MATCH_YES
)
2431 if (gfc_peek_char () == '/')
2433 if (gfc_match_char (',') != MATCH_YES
)
2435 gfc_gobble_whitespace ();
2436 if (gfc_peek_char () == '/')
2445 gfc_syntax_error (ST_COMMON
);
2448 if (old_blank_common
)
2449 old_blank_common
->common_next
= NULL
;
2451 gfc_current_ns
->blank_common
.head
= NULL
;
2452 gfc_free_array_spec (as
);
2457 /* Match a BLOCK DATA program unit. */
2460 gfc_match_block_data (void)
2462 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2466 if (gfc_match_eos () == MATCH_YES
)
2468 gfc_new_block
= NULL
;
2472 m
= gfc_match ("% %n%t", name
);
2476 if (gfc_get_symbol (name
, NULL
, &sym
))
2479 if (gfc_add_flavor (&sym
->attr
, FL_BLOCK_DATA
, sym
->name
, NULL
) == FAILURE
)
2482 gfc_new_block
= sym
;
2488 /* Free a namelist structure. */
2491 gfc_free_namelist (gfc_namelist
* name
)
2495 for (; name
; name
= n
)
2503 /* Match a NAMELIST statement. */
2506 gfc_match_namelist (void)
2508 gfc_symbol
*group_name
, *sym
;
2512 m
= gfc_match (" / %s /", &group_name
);
2515 if (m
== MATCH_ERROR
)
2520 if (group_name
->ts
.type
!= BT_UNKNOWN
)
2523 ("Namelist group name '%s' at %C already has a basic type "
2524 "of %s", group_name
->name
, gfc_typename (&group_name
->ts
));
2528 if (group_name
->attr
.flavor
== FL_NAMELIST
2529 && group_name
->attr
.use_assoc
2530 && gfc_notify_std (GFC_STD_GNU
, "Namelist group name '%s' "
2531 "at %C already is USE associated and can"
2532 "not be respecified.", group_name
->name
)
2536 if (group_name
->attr
.flavor
!= FL_NAMELIST
2537 && gfc_add_flavor (&group_name
->attr
, FL_NAMELIST
,
2538 group_name
->name
, NULL
) == FAILURE
)
2543 m
= gfc_match_symbol (&sym
, 1);
2546 if (m
== MATCH_ERROR
)
2549 if (sym
->attr
.in_namelist
== 0
2550 && gfc_add_in_namelist (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2553 /* Use gfc_error_check here, rather than goto error, so that this
2554 these are the only errors for the next two lines. */
2555 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
)
2557 gfc_error ("Assumed size array '%s' in namelist '%s'at "
2558 "%C is not allowed.", sym
->name
, group_name
->name
);
2562 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SHAPE
2563 && gfc_notify_std (GFC_STD_GNU
, "Assumed shape array '%s' in "
2564 "namelist '%s' at %C is an extension.",
2565 sym
->name
, group_name
->name
) == FAILURE
)
2568 nl
= gfc_get_namelist ();
2571 if (group_name
->namelist
== NULL
)
2572 group_name
->namelist
= group_name
->namelist_tail
= nl
;
2575 group_name
->namelist_tail
->next
= nl
;
2576 group_name
->namelist_tail
= nl
;
2579 if (gfc_match_eos () == MATCH_YES
)
2582 m
= gfc_match_char (',');
2584 if (gfc_match_char ('/') == MATCH_YES
)
2586 m2
= gfc_match (" %s /", &group_name
);
2587 if (m2
== MATCH_YES
)
2589 if (m2
== MATCH_ERROR
)
2603 gfc_syntax_error (ST_NAMELIST
);
2610 /* Match a MODULE statement. */
2613 gfc_match_module (void)
2617 m
= gfc_match (" %s%t", &gfc_new_block
);
2621 if (gfc_add_flavor (&gfc_new_block
->attr
, FL_MODULE
,
2622 gfc_new_block
->name
, NULL
) == FAILURE
)
2629 /* Free equivalence sets and lists. Recursively is the easiest way to
2633 gfc_free_equiv (gfc_equiv
* eq
)
2639 gfc_free_equiv (eq
->eq
);
2640 gfc_free_equiv (eq
->next
);
2642 gfc_free_expr (eq
->expr
);
2647 /* Match an EQUIVALENCE statement. */
2650 gfc_match_equivalence (void)
2652 gfc_equiv
*eq
, *set
, *tail
;
2656 gfc_common_head
*common_head
= NULL
;
2664 eq
= gfc_get_equiv ();
2668 eq
->next
= gfc_current_ns
->equiv
;
2669 gfc_current_ns
->equiv
= eq
;
2671 if (gfc_match_char ('(') != MATCH_YES
)
2675 common_flag
= FALSE
;
2680 m
= gfc_match_equiv_variable (&set
->expr
);
2681 if (m
== MATCH_ERROR
)
2686 /* count the number of objects. */
2689 if (gfc_match_char ('%') == MATCH_YES
)
2691 gfc_error ("Derived type component %C is not a "
2692 "permitted EQUIVALENCE member");
2696 for (ref
= set
->expr
->ref
; ref
; ref
= ref
->next
)
2697 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2700 ("Array reference in EQUIVALENCE at %C cannot be an "
2705 sym
= set
->expr
->symtree
->n
.sym
;
2707 if (gfc_add_in_equivalence (&sym
->attr
, sym
->name
, NULL
)
2711 if (sym
->attr
.in_common
)
2714 common_head
= sym
->common_head
;
2717 if (gfc_match_char (')') == MATCH_YES
)
2720 if (gfc_match_char (',') != MATCH_YES
)
2723 set
->eq
= gfc_get_equiv ();
2729 gfc_error ("EQUIVALENCE at %C requires two or more objects");
2733 /* If one of the members of an equivalence is in common, then
2734 mark them all as being in common. Before doing this, check
2735 that members of the equivalence group are not in different
2738 for (set
= eq
; set
; set
= set
->eq
)
2740 sym
= set
->expr
->symtree
->n
.sym
;
2741 if (sym
->common_head
&& sym
->common_head
!= common_head
)
2743 gfc_error ("Attempt to indirectly overlap COMMON "
2744 "blocks %s and %s by EQUIVALENCE at %C",
2745 sym
->common_head
->name
,
2749 sym
->attr
.in_common
= 1;
2750 sym
->common_head
= common_head
;
2753 if (gfc_match_eos () == MATCH_YES
)
2755 if (gfc_match_char (',') != MATCH_YES
)
2762 gfc_syntax_error (ST_EQUIVALENCE
);
2768 gfc_free_equiv (gfc_current_ns
->equiv
);
2769 gfc_current_ns
->equiv
= eq
;
2774 /* Check that a statement function is not recursive. This is done by looking
2775 for the statement function symbol(sym) by looking recursively through its
2776 expression(e). If a reference to sym is found, true is returned. */
2778 recursive_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
)
2780 gfc_actual_arglist
*arg
;
2787 switch (e
->expr_type
)
2790 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
2792 if (sym
->name
== arg
->name
2793 || recursive_stmt_fcn (arg
->expr
, sym
))
2797 if (e
->symtree
== NULL
)
2800 /* Check the name before testing for nested recursion! */
2801 if (sym
->name
== e
->symtree
->n
.sym
->name
)
2804 /* Catch recursion via other statement functions. */
2805 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
2806 && e
->symtree
->n
.sym
->value
2807 && recursive_stmt_fcn (e
->symtree
->n
.sym
->value
, sym
))
2813 if (e
->symtree
&& sym
->name
== e
->symtree
->n
.sym
->name
)
2818 if (recursive_stmt_fcn (e
->value
.op
.op1
, sym
)
2819 || recursive_stmt_fcn (e
->value
.op
.op2
, sym
))
2827 /* Component references do not need to be checked. */
2830 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2835 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2837 if (recursive_stmt_fcn (ref
->u
.ar
.start
[i
], sym
)
2838 || recursive_stmt_fcn (ref
->u
.ar
.end
[i
], sym
)
2839 || recursive_stmt_fcn (ref
->u
.ar
.stride
[i
], sym
))
2845 if (recursive_stmt_fcn (ref
->u
.ss
.start
, sym
)
2846 || recursive_stmt_fcn (ref
->u
.ss
.end
, sym
))
2860 /* Match a statement function declaration. It is so easy to match
2861 non-statement function statements with a MATCH_ERROR as opposed to
2862 MATCH_NO that we suppress error message in most cases. */
2865 gfc_match_st_function (void)
2867 gfc_error_buf old_error
;
2872 m
= gfc_match_symbol (&sym
, 0);
2876 gfc_push_error (&old_error
);
2878 if (gfc_add_procedure (&sym
->attr
, PROC_ST_FUNCTION
,
2879 sym
->name
, NULL
) == FAILURE
)
2882 if (gfc_match_formal_arglist (sym
, 1, 0) != MATCH_YES
)
2885 m
= gfc_match (" = %e%t", &expr
);
2889 gfc_free_error (&old_error
);
2890 if (m
== MATCH_ERROR
)
2893 if (recursive_stmt_fcn (expr
, sym
))
2895 gfc_error ("Statement function at %L is recursive",
2905 gfc_pop_error (&old_error
);
2910 /***************** SELECT CASE subroutines ******************/
2912 /* Free a single case structure. */
2915 free_case (gfc_case
* p
)
2917 if (p
->low
== p
->high
)
2919 gfc_free_expr (p
->low
);
2920 gfc_free_expr (p
->high
);
2925 /* Free a list of case structures. */
2928 gfc_free_case_list (gfc_case
* p
)
2940 /* Match a single case selector. */
2943 match_case_selector (gfc_case
** cp
)
2948 c
= gfc_get_case ();
2949 c
->where
= gfc_current_locus
;
2951 if (gfc_match_char (':') == MATCH_YES
)
2953 m
= gfc_match_init_expr (&c
->high
);
2956 if (m
== MATCH_ERROR
)
2962 m
= gfc_match_init_expr (&c
->low
);
2963 if (m
== MATCH_ERROR
)
2968 /* If we're not looking at a ':' now, make a range out of a single
2969 target. Else get the upper bound for the case range. */
2970 if (gfc_match_char (':') != MATCH_YES
)
2974 m
= gfc_match_init_expr (&c
->high
);
2975 if (m
== MATCH_ERROR
)
2977 /* MATCH_NO is fine. It's OK if nothing is there! */
2985 gfc_error ("Expected initialization expression in CASE at %C");
2993 /* Match the end of a case statement. */
2996 match_case_eos (void)
2998 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3001 if (gfc_match_eos () == MATCH_YES
)
3004 gfc_gobble_whitespace ();
3006 m
= gfc_match_name (name
);
3010 if (strcmp (name
, gfc_current_block ()->name
) != 0)
3012 gfc_error ("Expected case name of '%s' at %C",
3013 gfc_current_block ()->name
);
3017 return gfc_match_eos ();
3021 /* Match a SELECT statement. */
3024 gfc_match_select (void)
3029 m
= gfc_match_label ();
3030 if (m
== MATCH_ERROR
)
3033 m
= gfc_match (" select case ( %e )%t", &expr
);
3037 new_st
.op
= EXEC_SELECT
;
3044 /* Match a CASE statement. */
3047 gfc_match_case (void)
3049 gfc_case
*c
, *head
, *tail
;
3054 if (gfc_current_state () != COMP_SELECT
)
3056 gfc_error ("Unexpected CASE statement at %C");
3060 if (gfc_match ("% default") == MATCH_YES
)
3062 m
= match_case_eos ();
3065 if (m
== MATCH_ERROR
)
3068 new_st
.op
= EXEC_SELECT
;
3069 c
= gfc_get_case ();
3070 c
->where
= gfc_current_locus
;
3071 new_st
.ext
.case_list
= c
;
3075 if (gfc_match_char ('(') != MATCH_YES
)
3080 if (match_case_selector (&c
) == MATCH_ERROR
)
3090 if (gfc_match_char (')') == MATCH_YES
)
3092 if (gfc_match_char (',') != MATCH_YES
)
3096 m
= match_case_eos ();
3099 if (m
== MATCH_ERROR
)
3102 new_st
.op
= EXEC_SELECT
;
3103 new_st
.ext
.case_list
= head
;
3108 gfc_error ("Syntax error in CASE-specification at %C");
3111 gfc_free_case_list (head
); /* new_st is cleaned up in parse.c. */
3115 /********************* WHERE subroutines ********************/
3117 /* Match the rest of a simple WHERE statement that follows an IF statement.
3121 match_simple_where (void)
3127 m
= gfc_match (" ( %e )", &expr
);
3131 m
= gfc_match_assignment ();
3134 if (m
== MATCH_ERROR
)
3137 if (gfc_match_eos () != MATCH_YES
)
3140 c
= gfc_get_code ();
3144 c
->next
= gfc_get_code ();
3147 gfc_clear_new_st ();
3149 new_st
.op
= EXEC_WHERE
;
3155 gfc_syntax_error (ST_WHERE
);
3158 gfc_free_expr (expr
);
3162 /* Match a WHERE statement. */
3165 gfc_match_where (gfc_statement
* st
)
3171 m0
= gfc_match_label ();
3172 if (m0
== MATCH_ERROR
)
3175 m
= gfc_match (" where ( %e )", &expr
);
3179 if (gfc_match_eos () == MATCH_YES
)
3181 *st
= ST_WHERE_BLOCK
;
3183 new_st
.op
= EXEC_WHERE
;
3188 m
= gfc_match_assignment ();
3190 gfc_syntax_error (ST_WHERE
);
3194 gfc_free_expr (expr
);
3198 /* We've got a simple WHERE statement. */
3200 c
= gfc_get_code ();
3204 c
->next
= gfc_get_code ();
3207 gfc_clear_new_st ();
3209 new_st
.op
= EXEC_WHERE
;
3216 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
3217 new_st if successful. */
3220 gfc_match_elsewhere (void)
3222 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3226 if (gfc_current_state () != COMP_WHERE
)
3228 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
3234 if (gfc_match_char ('(') == MATCH_YES
)
3236 m
= gfc_match_expr (&expr
);
3239 if (m
== MATCH_ERROR
)
3242 if (gfc_match_char (')') != MATCH_YES
)
3246 if (gfc_match_eos () != MATCH_YES
)
3247 { /* Better be a name at this point */
3248 m
= gfc_match_name (name
);
3251 if (m
== MATCH_ERROR
)
3254 if (gfc_match_eos () != MATCH_YES
)
3257 if (strcmp (name
, gfc_current_block ()->name
) != 0)
3259 gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
3260 name
, gfc_current_block ()->name
);
3265 new_st
.op
= EXEC_WHERE
;
3270 gfc_syntax_error (ST_ELSEWHERE
);
3273 gfc_free_expr (expr
);
3278 /******************** FORALL subroutines ********************/
3280 /* Free a list of FORALL iterators. */
3283 gfc_free_forall_iterator (gfc_forall_iterator
* iter
)
3285 gfc_forall_iterator
*next
;
3291 gfc_free_expr (iter
->var
);
3292 gfc_free_expr (iter
->start
);
3293 gfc_free_expr (iter
->end
);
3294 gfc_free_expr (iter
->stride
);
3302 /* Match an iterator as part of a FORALL statement. The format is:
3304 <var> = <start>:<end>[:<stride>][, <scalar mask>] */
3307 match_forall_iterator (gfc_forall_iterator
** result
)
3309 gfc_forall_iterator
*iter
;
3313 where
= gfc_current_locus
;
3314 iter
= gfc_getmem (sizeof (gfc_forall_iterator
));
3316 m
= gfc_match_variable (&iter
->var
, 0);
3320 if (gfc_match_char ('=') != MATCH_YES
)
3326 m
= gfc_match_expr (&iter
->start
);
3330 if (gfc_match_char (':') != MATCH_YES
)
3333 m
= gfc_match_expr (&iter
->end
);
3336 if (m
== MATCH_ERROR
)
3339 if (gfc_match_char (':') == MATCH_NO
)
3340 iter
->stride
= gfc_int_expr (1);
3343 m
= gfc_match_expr (&iter
->stride
);
3346 if (m
== MATCH_ERROR
)
3354 gfc_error ("Syntax error in FORALL iterator at %C");
3358 gfc_current_locus
= where
;
3359 gfc_free_forall_iterator (iter
);
3364 /* Match the header of a FORALL statement. */
3367 match_forall_header (gfc_forall_iterator
** phead
, gfc_expr
** mask
)
3369 gfc_forall_iterator
*head
, *tail
, *new;
3372 gfc_gobble_whitespace ();
3377 if (gfc_match_char ('(') != MATCH_YES
)
3380 m
= match_forall_iterator (&new);
3381 if (m
== MATCH_ERROR
)
3390 if (gfc_match_char (',') != MATCH_YES
)
3393 m
= match_forall_iterator (&new);
3394 if (m
== MATCH_ERROR
)
3403 /* Have to have a mask expression */
3405 m
= gfc_match_expr (mask
);
3408 if (m
== MATCH_ERROR
)
3414 if (gfc_match_char (')') == MATCH_NO
)
3421 gfc_syntax_error (ST_FORALL
);
3424 gfc_free_expr (*mask
);
3425 gfc_free_forall_iterator (head
);
3430 /* Match the rest of a simple FORALL statement that follows an IF statement.
3434 match_simple_forall (void)
3436 gfc_forall_iterator
*head
;
3445 m
= match_forall_header (&head
, &mask
);
3452 m
= gfc_match_assignment ();
3454 if (m
== MATCH_ERROR
)
3458 m
= gfc_match_pointer_assignment ();
3459 if (m
== MATCH_ERROR
)
3465 c
= gfc_get_code ();
3467 c
->loc
= gfc_current_locus
;
3469 if (gfc_match_eos () != MATCH_YES
)
3472 gfc_clear_new_st ();
3473 new_st
.op
= EXEC_FORALL
;
3475 new_st
.ext
.forall_iterator
= head
;
3476 new_st
.block
= gfc_get_code ();
3478 new_st
.block
->op
= EXEC_FORALL
;
3479 new_st
.block
->next
= c
;
3484 gfc_syntax_error (ST_FORALL
);
3487 gfc_free_forall_iterator (head
);
3488 gfc_free_expr (mask
);
3494 /* Match a FORALL statement. */
3497 gfc_match_forall (gfc_statement
* st
)
3499 gfc_forall_iterator
*head
;
3508 m0
= gfc_match_label ();
3509 if (m0
== MATCH_ERROR
)
3512 m
= gfc_match (" forall");
3516 m
= match_forall_header (&head
, &mask
);
3517 if (m
== MATCH_ERROR
)
3522 if (gfc_match_eos () == MATCH_YES
)
3524 *st
= ST_FORALL_BLOCK
;
3526 new_st
.op
= EXEC_FORALL
;
3528 new_st
.ext
.forall_iterator
= head
;
3533 m
= gfc_match_assignment ();
3534 if (m
== MATCH_ERROR
)
3538 m
= gfc_match_pointer_assignment ();
3539 if (m
== MATCH_ERROR
)
3545 c
= gfc_get_code ();
3548 if (gfc_match_eos () != MATCH_YES
)
3551 gfc_clear_new_st ();
3552 new_st
.op
= EXEC_FORALL
;
3554 new_st
.ext
.forall_iterator
= head
;
3555 new_st
.block
= gfc_get_code ();
3557 new_st
.block
->op
= EXEC_FORALL
;
3558 new_st
.block
->next
= c
;
3564 gfc_syntax_error (ST_FORALL
);
3567 gfc_free_forall_iterator (head
);
3568 gfc_free_expr (mask
);
3569 gfc_free_statements (c
);