1 /* Matching subroutines in all sizes, shapes and colors.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
31 /* For matching and debugging purposes. Order matters here! The
32 unary operators /must/ precede the binary plus and minus, or
33 the expression parser breaks. */
35 mstring intrinsic_operators
[] = {
36 minit ("+", INTRINSIC_UPLUS
),
37 minit ("-", INTRINSIC_UMINUS
),
38 minit ("+", INTRINSIC_PLUS
),
39 minit ("-", INTRINSIC_MINUS
),
40 minit ("**", INTRINSIC_POWER
),
41 minit ("//", INTRINSIC_CONCAT
),
42 minit ("*", INTRINSIC_TIMES
),
43 minit ("/", INTRINSIC_DIVIDE
),
44 minit (".and.", INTRINSIC_AND
),
45 minit (".or.", INTRINSIC_OR
),
46 minit (".eqv.", INTRINSIC_EQV
),
47 minit (".neqv.", INTRINSIC_NEQV
),
48 minit (".eq.", INTRINSIC_EQ
),
49 minit ("==", INTRINSIC_EQ
),
50 minit (".ne.", INTRINSIC_NE
),
51 minit ("/=", INTRINSIC_NE
),
52 minit (".ge.", INTRINSIC_GE
),
53 minit (">=", INTRINSIC_GE
),
54 minit (".le.", INTRINSIC_LE
),
55 minit ("<=", INTRINSIC_LE
),
56 minit (".lt.", INTRINSIC_LT
),
57 minit ("<", INTRINSIC_LT
),
58 minit (".gt.", INTRINSIC_GT
),
59 minit (">", INTRINSIC_GT
),
60 minit (".not.", INTRINSIC_NOT
),
61 minit ("parens", INTRINSIC_PARENTHESES
),
62 minit (NULL
, INTRINSIC_NONE
)
66 /******************** Generic matching subroutines ************************/
68 /* In free form, match at least one space. Always matches in fixed
72 gfc_match_space (void)
77 if (gfc_current_form
== FORM_FIXED
)
80 old_loc
= gfc_current_locus
;
83 if (!gfc_is_whitespace (c
))
85 gfc_current_locus
= old_loc
;
89 gfc_gobble_whitespace ();
95 /* Match an end of statement. End of statement is optional
96 whitespace, followed by a ';' or '\n' or comment '!'. If a
97 semicolon is found, we continue to eat whitespace and semicolons. */
109 old_loc
= gfc_current_locus
;
110 gfc_gobble_whitespace ();
112 c
= gfc_next_char ();
118 c
= gfc_next_char ();
135 gfc_current_locus
= old_loc
;
136 return (flag
) ? MATCH_YES
: MATCH_NO
;
140 /* Match a literal integer on the input, setting the value on
141 MATCH_YES. Literal ints occur in kind-parameters as well as
142 old-style character length specifications. If cnt is non-NULL it
143 will be set to the number of digits. */
146 gfc_match_small_literal_int (int *value
, int *cnt
)
152 old_loc
= gfc_current_locus
;
154 gfc_gobble_whitespace ();
155 c
= gfc_next_char ();
161 gfc_current_locus
= old_loc
;
170 old_loc
= gfc_current_locus
;
171 c
= gfc_next_char ();
176 i
= 10 * i
+ c
- '0';
181 gfc_error ("Integer too large at %C");
186 gfc_current_locus
= old_loc
;
195 /* Match a small, constant integer expression, like in a kind
196 statement. On MATCH_YES, 'value' is set. */
199 gfc_match_small_int (int *value
)
206 m
= gfc_match_expr (&expr
);
210 p
= gfc_extract_int (expr
, &i
);
211 gfc_free_expr (expr
);
224 /* Matches a statement label. Uses gfc_match_small_literal_int() to
225 do most of the work. */
228 gfc_match_st_label (gfc_st_label
** label
)
234 old_loc
= gfc_current_locus
;
236 m
= gfc_match_small_literal_int (&i
, &cnt
);
242 gfc_error ("Too many digits in statement label at %C");
248 gfc_error ("Statement label at %C is zero");
252 *label
= gfc_get_st_label (i
);
257 gfc_current_locus
= old_loc
;
262 /* Match and validate a label associated with a named IF, DO or SELECT
263 statement. If the symbol does not have the label attribute, we add
264 it. We also make sure the symbol does not refer to another
265 (active) block. A matched label is pointed to by gfc_new_block. */
268 gfc_match_label (void)
270 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
273 gfc_new_block
= NULL
;
275 m
= gfc_match (" %n :", name
);
279 if (gfc_get_symbol (name
, NULL
, &gfc_new_block
))
281 gfc_error ("Label name '%s' at %C is ambiguous", name
);
285 if (gfc_new_block
->attr
.flavor
== FL_LABEL
)
287 gfc_error ("Duplicate construct label '%s' at %C", name
);
291 if (gfc_add_flavor (&gfc_new_block
->attr
, FL_LABEL
,
292 gfc_new_block
->name
, NULL
) == FAILURE
)
299 /* Try and match the input against an array of possibilities. If one
300 potential matching string is a substring of another, the longest
301 match takes precedence. Spaces in the target strings are optional
302 spaces that do not necessarily have to be found in the input
303 stream. In fixed mode, spaces never appear. If whitespace is
304 matched, it matches unlimited whitespace in the input. For this
305 reason, the 'mp' member of the mstring structure is used to track
306 the progress of each potential match.
308 If there is no match we return the tag associated with the
309 terminating NULL mstring structure and leave the locus pointer
310 where it started. If there is a match we return the tag member of
311 the matched mstring and leave the locus pointer after the matched
314 A '%' character is a mandatory space. */
317 gfc_match_strings (mstring
* a
)
319 mstring
*p
, *best_match
;
320 int no_match
, c
, possibles
;
325 for (p
= a
; p
->string
!= NULL
; p
++)
334 match_loc
= gfc_current_locus
;
336 gfc_gobble_whitespace ();
338 while (possibles
> 0)
340 c
= gfc_next_char ();
342 /* Apply the next character to the current possibilities. */
343 for (p
= a
; p
->string
!= NULL
; p
++)
350 /* Space matches 1+ whitespace(s). */
351 if ((gfc_current_form
== FORM_FREE
)
352 && gfc_is_whitespace (c
))
370 match_loc
= gfc_current_locus
;
378 gfc_current_locus
= match_loc
;
380 return (best_match
== NULL
) ? no_match
: best_match
->tag
;
384 /* See if the current input looks like a name of some sort. Modifies
385 the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long. */
388 gfc_match_name (char *buffer
)
393 old_loc
= gfc_current_locus
;
394 gfc_gobble_whitespace ();
396 c
= gfc_next_char ();
399 gfc_current_locus
= old_loc
;
409 if (i
> gfc_option
.max_identifier_length
)
411 gfc_error ("Name at %C is too long");
415 old_loc
= gfc_current_locus
;
416 c
= gfc_next_char ();
420 || (gfc_option
.flag_dollar_ok
&& c
== '$'));
423 gfc_current_locus
= old_loc
;
429 /* Match a symbol on the input. Modifies the pointer to the symbol
430 pointer if successful. */
433 gfc_match_sym_tree (gfc_symtree
** matched_symbol
, int host_assoc
)
435 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
438 m
= gfc_match_name (buffer
);
443 return (gfc_get_ha_sym_tree (buffer
, matched_symbol
))
444 ? MATCH_ERROR
: MATCH_YES
;
446 if (gfc_get_sym_tree (buffer
, NULL
, matched_symbol
))
454 gfc_match_symbol (gfc_symbol
** matched_symbol
, int host_assoc
)
459 m
= gfc_match_sym_tree (&st
, host_assoc
);
464 *matched_symbol
= st
->n
.sym
;
466 *matched_symbol
= NULL
;
469 *matched_symbol
= NULL
;
473 /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
474 we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
478 gfc_match_intrinsic_op (gfc_intrinsic_op
* result
)
482 op
= (gfc_intrinsic_op
) gfc_match_strings (intrinsic_operators
);
484 if (op
== INTRINSIC_NONE
)
492 /* Match a loop control phrase:
494 <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
496 If the final integer expression is not present, a constant unity
497 expression is returned. We don't return MATCH_ERROR until after
498 the equals sign is seen. */
501 gfc_match_iterator (gfc_iterator
* iter
, int init_flag
)
503 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
504 gfc_expr
*var
, *e1
, *e2
, *e3
;
508 /* Match the start of an iterator without affecting the symbol
511 start
= gfc_current_locus
;
512 m
= gfc_match (" %n =", name
);
513 gfc_current_locus
= start
;
518 m
= gfc_match_variable (&var
, 0);
522 gfc_match_char ('=');
526 if (var
->ref
!= NULL
)
528 gfc_error ("Loop variable at %C cannot be a sub-component");
532 if (var
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
534 gfc_error ("Loop variable '%s' at %C cannot be INTENT(IN)",
535 var
->symtree
->n
.sym
->name
);
539 if (var
->symtree
->n
.sym
->attr
.pointer
)
541 gfc_error ("Loop variable at %C cannot have the POINTER attribute");
545 m
= init_flag
? gfc_match_init_expr (&e1
) : gfc_match_expr (&e1
);
548 if (m
== MATCH_ERROR
)
551 if (gfc_match_char (',') != MATCH_YES
)
554 m
= init_flag
? gfc_match_init_expr (&e2
) : gfc_match_expr (&e2
);
557 if (m
== MATCH_ERROR
)
560 if (gfc_match_char (',') != MATCH_YES
)
562 e3
= gfc_int_expr (1);
566 m
= init_flag
? gfc_match_init_expr (&e3
) : gfc_match_expr (&e3
);
567 if (m
== MATCH_ERROR
)
571 gfc_error ("Expected a step value in iterator at %C");
583 gfc_error ("Syntax error in iterator at %C");
594 /* Tries to match the next non-whitespace character on the input.
595 This subroutine does not return MATCH_ERROR. */
598 gfc_match_char (char c
)
602 where
= gfc_current_locus
;
603 gfc_gobble_whitespace ();
605 if (gfc_next_char () == c
)
608 gfc_current_locus
= where
;
613 /* General purpose matching subroutine. The target string is a
614 scanf-like format string in which spaces correspond to arbitrary
615 whitespace (including no whitespace), characters correspond to
616 themselves. The %-codes are:
618 %% Literal percent sign
619 %e Expression, pointer to a pointer is set
620 %s Symbol, pointer to the symbol is set
621 %n Name, character buffer is set to name
622 %t Matches end of statement.
623 %o Matches an intrinsic operator, returned as an INTRINSIC enum.
624 %l Matches a statement label
625 %v Matches a variable expression (an lvalue)
626 % Matches a required space (in free form) and optional spaces. */
629 gfc_match (const char *target
, ...)
631 gfc_st_label
**label
;
640 old_loc
= gfc_current_locus
;
641 va_start (argp
, target
);
651 gfc_gobble_whitespace ();
662 vp
= va_arg (argp
, void **);
663 n
= gfc_match_expr ((gfc_expr
**) vp
);
674 vp
= va_arg (argp
, void **);
675 n
= gfc_match_variable ((gfc_expr
**) vp
, 0);
686 vp
= va_arg (argp
, void **);
687 n
= gfc_match_symbol ((gfc_symbol
**) vp
, 0);
698 np
= va_arg (argp
, char *);
699 n
= gfc_match_name (np
);
710 label
= va_arg (argp
, gfc_st_label
**);
711 n
= gfc_match_st_label (label
);
722 ip
= va_arg (argp
, int *);
723 n
= gfc_match_intrinsic_op ((gfc_intrinsic_op
*) ip
);
734 if (gfc_match_eos () != MATCH_YES
)
742 if (gfc_match_space () == MATCH_YES
)
748 break; /* Fall through to character matcher */
751 gfc_internal_error ("gfc_match(): Bad match code %c", c
);
755 if (c
== gfc_next_char ())
765 /* Clean up after a failed match. */
766 gfc_current_locus
= old_loc
;
767 va_start (argp
, target
);
770 for (; matches
> 0; matches
--)
780 /* Matches that don't have to be undone */
785 (void)va_arg (argp
, void **);
790 vp
= va_arg (argp
, void **);
804 /*********************** Statement level matching **********************/
806 /* Matches the start of a program unit, which is the program keyword
807 followed by an obligatory symbol. */
810 gfc_match_program (void)
815 m
= gfc_match ("% %s%t", &sym
);
819 gfc_error ("Invalid form of PROGRAM statement at %C");
823 if (m
== MATCH_ERROR
)
826 if (gfc_add_flavor (&sym
->attr
, FL_PROGRAM
, sym
->name
, NULL
) == FAILURE
)
835 /* Match a simple assignment statement. */
838 gfc_match_assignment (void)
840 gfc_expr
*lvalue
, *rvalue
;
844 old_loc
= gfc_current_locus
;
847 m
= gfc_match (" %v =", &lvalue
);
850 gfc_current_locus
= old_loc
;
851 gfc_free_expr (lvalue
);
855 if (lvalue
->symtree
->n
.sym
->attr
.protected
856 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
)
858 gfc_current_locus
= old_loc
;
859 gfc_free_expr (lvalue
);
860 gfc_error ("Setting value of PROTECTED variable at %C");
865 m
= gfc_match (" %e%t", &rvalue
);
868 gfc_current_locus
= old_loc
;
869 gfc_free_expr (lvalue
);
870 gfc_free_expr (rvalue
);
874 gfc_set_sym_referenced (lvalue
->symtree
->n
.sym
);
876 new_st
.op
= EXEC_ASSIGN
;
877 new_st
.expr
= lvalue
;
878 new_st
.expr2
= rvalue
;
880 gfc_check_do_variable (lvalue
->symtree
);
886 /* Match a pointer assignment statement. */
889 gfc_match_pointer_assignment (void)
891 gfc_expr
*lvalue
, *rvalue
;
895 old_loc
= gfc_current_locus
;
897 lvalue
= rvalue
= NULL
;
899 m
= gfc_match (" %v =>", &lvalue
);
906 m
= gfc_match (" %e%t", &rvalue
);
910 if (lvalue
->symtree
->n
.sym
->attr
.protected
911 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
)
913 gfc_error ("Assigning to a PROTECTED pointer at %C");
919 new_st
.op
= EXEC_POINTER_ASSIGN
;
920 new_st
.expr
= lvalue
;
921 new_st
.expr2
= rvalue
;
926 gfc_current_locus
= old_loc
;
927 gfc_free_expr (lvalue
);
928 gfc_free_expr (rvalue
);
933 /* We try to match an easy arithmetic IF statement. This only happens
934 when just after having encountered a simple IF statement. This code
935 is really duplicate with parts of the gfc_match_if code, but this is
938 match_arithmetic_if (void)
940 gfc_st_label
*l1
, *l2
, *l3
;
944 m
= gfc_match (" ( %e ) %l , %l , %l%t", &expr
, &l1
, &l2
, &l3
);
948 if (gfc_reference_st_label (l1
, ST_LABEL_TARGET
) == FAILURE
949 || gfc_reference_st_label (l2
, ST_LABEL_TARGET
) == FAILURE
950 || gfc_reference_st_label (l3
, ST_LABEL_TARGET
) == FAILURE
)
952 gfc_free_expr (expr
);
956 if (gfc_notify_std (GFC_STD_F95_DEL
,
957 "Obsolete: arithmetic IF statement at %C") == FAILURE
)
960 new_st
.op
= EXEC_ARITHMETIC_IF
;
970 /* The IF statement is a bit of a pain. First of all, there are three
971 forms of it, the simple IF, the IF that starts a block and the
974 There is a problem with the simple IF and that is the fact that we
975 only have a single level of undo information on symbols. What this
976 means is for a simple IF, we must re-match the whole IF statement
977 multiple times in order to guarantee that the symbol table ends up
978 in the proper state. */
980 static match
match_simple_forall (void);
981 static match
match_simple_where (void);
984 gfc_match_if (gfc_statement
* if_type
)
987 gfc_st_label
*l1
, *l2
, *l3
;
992 n
= gfc_match_label ();
993 if (n
== MATCH_ERROR
)
996 old_loc
= gfc_current_locus
;
998 m
= gfc_match (" if ( %e", &expr
);
1002 if (gfc_match_char (')') != MATCH_YES
)
1004 gfc_error ("Syntax error in IF-expression at %C");
1005 gfc_free_expr (expr
);
1009 m
= gfc_match (" %l , %l , %l%t", &l1
, &l2
, &l3
);
1016 ("Block label not appropriate for arithmetic IF statement "
1019 gfc_free_expr (expr
);
1023 if (gfc_reference_st_label (l1
, ST_LABEL_TARGET
) == FAILURE
1024 || gfc_reference_st_label (l2
, ST_LABEL_TARGET
) == FAILURE
1025 || gfc_reference_st_label (l3
, ST_LABEL_TARGET
) == FAILURE
)
1028 gfc_free_expr (expr
);
1032 if (gfc_notify_std (GFC_STD_F95_DEL
,
1033 "Obsolete: arithmetic IF statement at %C")
1037 new_st
.op
= EXEC_ARITHMETIC_IF
;
1043 *if_type
= ST_ARITHMETIC_IF
;
1047 if (gfc_match (" then%t") == MATCH_YES
)
1049 new_st
.op
= EXEC_IF
;
1052 *if_type
= ST_IF_BLOCK
;
1058 gfc_error ("Block label is not appropriate IF statement at %C");
1060 gfc_free_expr (expr
);
1064 /* At this point the only thing left is a simple IF statement. At
1065 this point, n has to be MATCH_NO, so we don't have to worry about
1066 re-matching a block label. From what we've got so far, try
1067 matching an assignment. */
1069 *if_type
= ST_SIMPLE_IF
;
1071 m
= gfc_match_assignment ();
1075 gfc_free_expr (expr
);
1076 gfc_undo_symbols ();
1077 gfc_current_locus
= old_loc
;
1079 /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled
1080 assignment was found. For MATCH_NO, continue to call the various
1082 if (m
== MATCH_ERROR
)
1085 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match */
1087 m
= gfc_match_pointer_assignment ();
1091 gfc_free_expr (expr
);
1092 gfc_undo_symbols ();
1093 gfc_current_locus
= old_loc
;
1095 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match */
1097 /* Look at the next keyword to see which matcher to call. Matching
1098 the keyword doesn't affect the symbol table, so we don't have to
1099 restore between tries. */
1101 #define match(string, subr, statement) \
1102 if (gfc_match(string) == MATCH_YES) { m = subr(); goto got_match; }
1106 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
)
1107 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
)
1108 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
)
1109 match ("call", gfc_match_call
, ST_CALL
)
1110 match ("close", gfc_match_close
, ST_CLOSE
)
1111 match ("continue", gfc_match_continue
, ST_CONTINUE
)
1112 match ("cycle", gfc_match_cycle
, ST_CYCLE
)
1113 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
)
1114 match ("end file", gfc_match_endfile
, ST_END_FILE
)
1115 match ("exit", gfc_match_exit
, ST_EXIT
)
1116 match ("flush", gfc_match_flush
, ST_FLUSH
)
1117 match ("forall", match_simple_forall
, ST_FORALL
)
1118 match ("go to", gfc_match_goto
, ST_GOTO
)
1119 match ("if", match_arithmetic_if
, ST_ARITHMETIC_IF
)
1120 match ("inquire", gfc_match_inquire
, ST_INQUIRE
)
1121 match ("nullify", gfc_match_nullify
, ST_NULLIFY
)
1122 match ("open", gfc_match_open
, ST_OPEN
)
1123 match ("pause", gfc_match_pause
, ST_NONE
)
1124 match ("print", gfc_match_print
, ST_WRITE
)
1125 match ("read", gfc_match_read
, ST_READ
)
1126 match ("return", gfc_match_return
, ST_RETURN
)
1127 match ("rewind", gfc_match_rewind
, ST_REWIND
)
1128 match ("stop", gfc_match_stop
, ST_STOP
)
1129 match ("where", match_simple_where
, ST_WHERE
)
1130 match ("write", gfc_match_write
, ST_WRITE
)
1132 /* The gfc_match_assignment() above may have returned a MATCH_NO
1133 where the assignment was to a named constant. Check that
1134 special case here. */
1135 m
= gfc_match_assignment ();
1138 gfc_error ("Cannot assign to a named constant at %C");
1139 gfc_free_expr (expr
);
1140 gfc_undo_symbols ();
1141 gfc_current_locus
= old_loc
;
1145 /* All else has failed, so give up. See if any of the matchers has
1146 stored an error message of some sort. */
1147 if (gfc_error_check () == 0)
1148 gfc_error ("Unclassifiable statement in IF-clause at %C");
1150 gfc_free_expr (expr
);
1155 gfc_error ("Syntax error in IF-clause at %C");
1158 gfc_free_expr (expr
);
1162 /* At this point, we've matched the single IF and the action clause
1163 is in new_st. Rearrange things so that the IF statement appears
1166 p
= gfc_get_code ();
1167 p
->next
= gfc_get_code ();
1169 p
->next
->loc
= gfc_current_locus
;
1174 gfc_clear_new_st ();
1176 new_st
.op
= EXEC_IF
;
1185 /* Match an ELSE statement. */
1188 gfc_match_else (void)
1190 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
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 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
);
1214 /* Match an ELSE IF statement. */
1217 gfc_match_elseif (void)
1219 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1223 m
= gfc_match (" ( %e ) then", &expr
);
1227 if (gfc_match_eos () == MATCH_YES
)
1230 if (gfc_match_name (name
) != MATCH_YES
1231 || gfc_current_block () == NULL
1232 || gfc_match_eos () != MATCH_YES
)
1234 gfc_error ("Unexpected junk after ELSE IF statement at %C");
1238 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1240 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1241 name
, gfc_current_block ()->name
);
1246 new_st
.op
= EXEC_IF
;
1251 gfc_free_expr (expr
);
1256 /* Free a gfc_iterator structure. */
1259 gfc_free_iterator (gfc_iterator
* iter
, int flag
)
1265 gfc_free_expr (iter
->var
);
1266 gfc_free_expr (iter
->start
);
1267 gfc_free_expr (iter
->end
);
1268 gfc_free_expr (iter
->step
);
1275 /* Match a DO statement. */
1280 gfc_iterator iter
, *ip
;
1282 gfc_st_label
*label
;
1285 old_loc
= gfc_current_locus
;
1288 iter
.var
= iter
.start
= iter
.end
= iter
.step
= NULL
;
1290 m
= gfc_match_label ();
1291 if (m
== MATCH_ERROR
)
1294 if (gfc_match (" do") != MATCH_YES
)
1297 m
= gfc_match_st_label (&label
);
1298 if (m
== MATCH_ERROR
)
1301 /* Match an infinite DO, make it like a DO WHILE(.TRUE.) */
1303 if (gfc_match_eos () == MATCH_YES
)
1305 iter
.end
= gfc_logical_expr (1, NULL
);
1306 new_st
.op
= EXEC_DO_WHILE
;
1310 /* match an optional comma, if no comma is found a space is obligatory. */
1311 if (gfc_match_char(',') != MATCH_YES
1312 && gfc_match ("% ") != MATCH_YES
)
1315 /* See if we have a DO WHILE. */
1316 if (gfc_match (" while ( %e )%t", &iter
.end
) == MATCH_YES
)
1318 new_st
.op
= EXEC_DO_WHILE
;
1322 /* The abortive DO WHILE may have done something to the symbol
1323 table, so we start over: */
1324 gfc_undo_symbols ();
1325 gfc_current_locus
= old_loc
;
1327 gfc_match_label (); /* This won't error */
1328 gfc_match (" do "); /* This will work */
1330 gfc_match_st_label (&label
); /* Can't error out */
1331 gfc_match_char (','); /* Optional comma */
1333 m
= gfc_match_iterator (&iter
, 0);
1336 if (m
== MATCH_ERROR
)
1339 gfc_check_do_variable (iter
.var
->symtree
);
1341 if (gfc_match_eos () != MATCH_YES
)
1343 gfc_syntax_error (ST_DO
);
1347 new_st
.op
= EXEC_DO
;
1351 && gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
1354 new_st
.label
= label
;
1356 if (new_st
.op
== EXEC_DO_WHILE
)
1357 new_st
.expr
= iter
.end
;
1360 new_st
.ext
.iterator
= ip
= gfc_get_iterator ();
1367 gfc_free_iterator (&iter
, 0);
1373 /* Match an EXIT or CYCLE statement. */
1376 match_exit_cycle (gfc_statement st
, gfc_exec_op op
)
1378 gfc_state_data
*p
, *o
;
1382 if (gfc_match_eos () == MATCH_YES
)
1386 m
= gfc_match ("% %s%t", &sym
);
1387 if (m
== MATCH_ERROR
)
1391 gfc_syntax_error (st
);
1395 if (sym
->attr
.flavor
!= FL_LABEL
)
1397 gfc_error ("Name '%s' in %s statement at %C is not a loop name",
1398 sym
->name
, gfc_ascii_statement (st
));
1403 /* Find the loop mentioned specified by the label (or lack of a
1405 for (o
= NULL
, p
= gfc_state_stack
; p
; p
= p
->previous
)
1406 if (p
->state
== COMP_DO
&& (sym
== NULL
|| sym
== p
->sym
))
1408 else if (o
== NULL
&& p
->state
== COMP_OMP_STRUCTURED_BLOCK
)
1414 gfc_error ("%s statement at %C is not within a loop",
1415 gfc_ascii_statement (st
));
1417 gfc_error ("%s statement at %C is not within loop '%s'",
1418 gfc_ascii_statement (st
), sym
->name
);
1425 gfc_error ("%s statement at %C leaving OpenMP structured block",
1426 gfc_ascii_statement (st
));
1429 else if (st
== ST_EXIT
1430 && p
->previous
!= NULL
1431 && p
->previous
->state
== COMP_OMP_STRUCTURED_BLOCK
1432 && (p
->previous
->head
->op
== EXEC_OMP_DO
1433 || p
->previous
->head
->op
== EXEC_OMP_PARALLEL_DO
))
1435 gcc_assert (p
->previous
->head
->next
!= NULL
);
1436 gcc_assert (p
->previous
->head
->next
->op
== EXEC_DO
1437 || p
->previous
->head
->next
->op
== EXEC_DO_WHILE
);
1438 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
1442 /* Save the first statement in the loop - needed by the backend. */
1443 new_st
.ext
.whichloop
= p
->head
;
1446 /* new_st.sym = sym;*/
1452 /* Match the EXIT statement. */
1455 gfc_match_exit (void)
1458 return match_exit_cycle (ST_EXIT
, EXEC_EXIT
);
1462 /* Match the CYCLE statement. */
1465 gfc_match_cycle (void)
1468 return match_exit_cycle (ST_CYCLE
, EXEC_CYCLE
);
1472 /* Match a number or character constant after a STOP or PAUSE statement. */
1475 gfc_match_stopcode (gfc_statement st
)
1485 if (gfc_match_eos () != MATCH_YES
)
1487 m
= gfc_match_small_literal_int (&stop_code
, &cnt
);
1488 if (m
== MATCH_ERROR
)
1491 if (m
== MATCH_YES
&& cnt
> 5)
1493 gfc_error ("Too many digits in STOP code at %C");
1499 /* Try a character constant. */
1500 m
= gfc_match_expr (&e
);
1501 if (m
== MATCH_ERROR
)
1505 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1509 if (gfc_match_eos () != MATCH_YES
)
1513 if (gfc_pure (NULL
))
1515 gfc_error ("%s statement not allowed in PURE procedure at %C",
1516 gfc_ascii_statement (st
));
1520 new_st
.op
= st
== ST_STOP
? EXEC_STOP
: EXEC_PAUSE
;
1522 new_st
.ext
.stop_code
= stop_code
;
1527 gfc_syntax_error (st
);
1535 /* Match the (deprecated) PAUSE statement. */
1538 gfc_match_pause (void)
1542 m
= gfc_match_stopcode (ST_PAUSE
);
1545 if (gfc_notify_std (GFC_STD_F95_DEL
,
1546 "Obsolete: PAUSE statement at %C")
1554 /* Match the STOP statement. */
1557 gfc_match_stop (void)
1559 return gfc_match_stopcode (ST_STOP
);
1563 /* Match a CONTINUE statement. */
1566 gfc_match_continue (void)
1569 if (gfc_match_eos () != MATCH_YES
)
1571 gfc_syntax_error (ST_CONTINUE
);
1575 new_st
.op
= EXEC_CONTINUE
;
1580 /* Match the (deprecated) ASSIGN statement. */
1583 gfc_match_assign (void)
1586 gfc_st_label
*label
;
1588 if (gfc_match (" %l", &label
) == MATCH_YES
)
1590 if (gfc_reference_st_label (label
, ST_LABEL_UNKNOWN
) == FAILURE
)
1592 if (gfc_match (" to %v%t", &expr
) == MATCH_YES
)
1594 if (gfc_notify_std (GFC_STD_F95_DEL
,
1595 "Obsolete: ASSIGN statement at %C")
1599 expr
->symtree
->n
.sym
->attr
.assign
= 1;
1601 new_st
.op
= EXEC_LABEL_ASSIGN
;
1602 new_st
.label
= label
;
1611 /* Match the GO TO statement. As a computed GOTO statement is
1612 matched, it is transformed into an equivalent SELECT block. No
1613 tree is necessary, and the resulting jumps-to-jumps are
1614 specifically optimized away by the back end. */
1617 gfc_match_goto (void)
1619 gfc_code
*head
, *tail
;
1622 gfc_st_label
*label
;
1626 if (gfc_match (" %l%t", &label
) == MATCH_YES
)
1628 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
1631 new_st
.op
= EXEC_GOTO
;
1632 new_st
.label
= label
;
1636 /* The assigned GO TO statement. */
1638 if (gfc_match_variable (&expr
, 0) == MATCH_YES
)
1640 if (gfc_notify_std (GFC_STD_F95_DEL
,
1641 "Obsolete: Assigned GOTO statement at %C")
1645 new_st
.op
= EXEC_GOTO
;
1648 if (gfc_match_eos () == MATCH_YES
)
1651 /* Match label list. */
1652 gfc_match_char (',');
1653 if (gfc_match_char ('(') != MATCH_YES
)
1655 gfc_syntax_error (ST_GOTO
);
1662 m
= gfc_match_st_label (&label
);
1666 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
1670 head
= tail
= gfc_get_code ();
1673 tail
->block
= gfc_get_code ();
1677 tail
->label
= label
;
1678 tail
->op
= EXEC_GOTO
;
1680 while (gfc_match_char (',') == MATCH_YES
);
1682 if (gfc_match (")%t") != MATCH_YES
)
1688 "Statement label list in GOTO at %C cannot be empty");
1691 new_st
.block
= head
;
1696 /* Last chance is a computed GO TO statement. */
1697 if (gfc_match_char ('(') != MATCH_YES
)
1699 gfc_syntax_error (ST_GOTO
);
1708 m
= gfc_match_st_label (&label
);
1712 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
1716 head
= tail
= gfc_get_code ();
1719 tail
->block
= gfc_get_code ();
1723 cp
= gfc_get_case ();
1724 cp
->low
= cp
->high
= gfc_int_expr (i
++);
1726 tail
->op
= EXEC_SELECT
;
1727 tail
->ext
.case_list
= cp
;
1729 tail
->next
= gfc_get_code ();
1730 tail
->next
->op
= EXEC_GOTO
;
1731 tail
->next
->label
= label
;
1733 while (gfc_match_char (',') == MATCH_YES
);
1735 if (gfc_match_char (')') != MATCH_YES
)
1740 gfc_error ("Statement label list in GOTO at %C cannot be empty");
1744 /* Get the rest of the statement. */
1745 gfc_match_char (',');
1747 if (gfc_match (" %e%t", &expr
) != MATCH_YES
)
1750 /* At this point, a computed GOTO has been fully matched and an
1751 equivalent SELECT statement constructed. */
1753 new_st
.op
= EXEC_SELECT
;
1756 /* Hack: For a "real" SELECT, the expression is in expr. We put
1757 it in expr2 so we can distinguish then and produce the correct
1759 new_st
.expr2
= expr
;
1760 new_st
.block
= head
;
1764 gfc_syntax_error (ST_GOTO
);
1766 gfc_free_statements (head
);
1771 /* Frees a list of gfc_alloc structures. */
1774 gfc_free_alloc_list (gfc_alloc
* p
)
1781 gfc_free_expr (p
->expr
);
1787 /* Match an ALLOCATE statement. */
1790 gfc_match_allocate (void)
1792 gfc_alloc
*head
, *tail
;
1799 if (gfc_match_char ('(') != MATCH_YES
)
1805 head
= tail
= gfc_get_alloc ();
1808 tail
->next
= gfc_get_alloc ();
1812 m
= gfc_match_variable (&tail
->expr
, 0);
1815 if (m
== MATCH_ERROR
)
1818 if (gfc_check_do_variable (tail
->expr
->symtree
))
1822 && gfc_impure_variable (tail
->expr
->symtree
->n
.sym
))
1824 gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a "
1829 if (tail
->expr
->ts
.type
== BT_DERIVED
)
1830 tail
->expr
->ts
.derived
= gfc_use_derived (tail
->expr
->ts
.derived
);
1832 if (gfc_match_char (',') != MATCH_YES
)
1835 m
= gfc_match (" stat = %v", &stat
);
1836 if (m
== MATCH_ERROR
)
1844 if (stat
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
1847 ("STAT variable '%s' of ALLOCATE statement at %C cannot be "
1848 "INTENT(IN)", stat
->symtree
->n
.sym
->name
);
1852 if (gfc_pure (NULL
) && gfc_impure_variable (stat
->symtree
->n
.sym
))
1855 ("Illegal STAT variable in ALLOCATE statement at %C for a PURE "
1860 if (stat
->symtree
->n
.sym
->attr
.flavor
!= FL_VARIABLE
)
1862 gfc_error("STAT expression at %C must be a variable");
1866 gfc_check_do_variable(stat
->symtree
);
1869 if (gfc_match (" )%t") != MATCH_YES
)
1872 new_st
.op
= EXEC_ALLOCATE
;
1874 new_st
.ext
.alloc_list
= head
;
1879 gfc_syntax_error (ST_ALLOCATE
);
1882 gfc_free_expr (stat
);
1883 gfc_free_alloc_list (head
);
1888 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
1889 a set of pointer assignments to intrinsic NULL(). */
1892 gfc_match_nullify (void)
1900 if (gfc_match_char ('(') != MATCH_YES
)
1905 m
= gfc_match_variable (&p
, 0);
1906 if (m
== MATCH_ERROR
)
1911 if (gfc_check_do_variable(p
->symtree
))
1914 if (gfc_pure (NULL
) && gfc_impure_variable (p
->symtree
->n
.sym
))
1917 ("Illegal variable in NULLIFY at %C for a PURE procedure");
1921 /* build ' => NULL() ' */
1922 e
= gfc_get_expr ();
1923 e
->where
= gfc_current_locus
;
1924 e
->expr_type
= EXPR_NULL
;
1925 e
->ts
.type
= BT_UNKNOWN
;
1932 tail
->next
= gfc_get_code ();
1936 tail
->op
= EXEC_POINTER_ASSIGN
;
1940 if (gfc_match (" )%t") == MATCH_YES
)
1942 if (gfc_match_char (',') != MATCH_YES
)
1949 gfc_syntax_error (ST_NULLIFY
);
1952 gfc_free_statements (new_st
.next
);
1957 /* Match a DEALLOCATE statement. */
1960 gfc_match_deallocate (void)
1962 gfc_alloc
*head
, *tail
;
1969 if (gfc_match_char ('(') != MATCH_YES
)
1975 head
= tail
= gfc_get_alloc ();
1978 tail
->next
= gfc_get_alloc ();
1982 m
= gfc_match_variable (&tail
->expr
, 0);
1983 if (m
== MATCH_ERROR
)
1988 if (gfc_check_do_variable (tail
->expr
->symtree
))
1992 && gfc_impure_variable (tail
->expr
->symtree
->n
.sym
))
1995 ("Illegal deallocate-expression in DEALLOCATE at %C for a PURE "
2000 if (gfc_match_char (',') != MATCH_YES
)
2003 m
= gfc_match (" stat = %v", &stat
);
2004 if (m
== MATCH_ERROR
)
2012 if (stat
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
2014 gfc_error ("STAT variable '%s' of DEALLOCATE statement at %C "
2015 "cannot be INTENT(IN)", stat
->symtree
->n
.sym
->name
);
2019 if (gfc_pure(NULL
) && gfc_impure_variable (stat
->symtree
->n
.sym
))
2021 gfc_error ("Illegal STAT variable in DEALLOCATE statement at %C "
2022 "for a PURE procedure");
2026 if (stat
->symtree
->n
.sym
->attr
.flavor
!= FL_VARIABLE
)
2028 gfc_error("STAT expression at %C must be a variable");
2032 gfc_check_do_variable(stat
->symtree
);
2035 if (gfc_match (" )%t") != MATCH_YES
)
2038 new_st
.op
= EXEC_DEALLOCATE
;
2040 new_st
.ext
.alloc_list
= head
;
2045 gfc_syntax_error (ST_DEALLOCATE
);
2048 gfc_free_expr (stat
);
2049 gfc_free_alloc_list (head
);
2054 /* Match a RETURN statement. */
2057 gfc_match_return (void)
2061 gfc_compile_state s
;
2065 if (gfc_match_eos () == MATCH_YES
)
2068 if (gfc_find_state (COMP_SUBROUTINE
) == FAILURE
)
2070 gfc_error ("Alternate RETURN statement at %C is only allowed within "
2075 if (gfc_current_form
== FORM_FREE
)
2077 /* The following are valid, so we can't require a blank after the
2081 c
= gfc_peek_char ();
2082 if (ISALPHA (c
) || ISDIGIT (c
))
2086 m
= gfc_match (" %e%t", &e
);
2089 if (m
== MATCH_ERROR
)
2092 gfc_syntax_error (ST_RETURN
);
2099 gfc_enclosing_unit (&s
);
2100 if (s
== COMP_PROGRAM
2101 && gfc_notify_std (GFC_STD_GNU
, "Extension: RETURN statement in "
2102 "main program at %C") == FAILURE
)
2105 new_st
.op
= EXEC_RETURN
;
2112 /* Match a CALL statement. The tricky part here are possible
2113 alternate return specifiers. We handle these by having all
2114 "subroutines" actually return an integer via a register that gives
2115 the return number. If the call specifies alternate returns, we
2116 generate code for a SELECT statement whose case clauses contain
2117 GOTOs to the various labels. */
2120 gfc_match_call (void)
2122 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2123 gfc_actual_arglist
*a
, *arglist
;
2133 m
= gfc_match ("% %n", name
);
2139 if (gfc_get_ha_sym_tree (name
, &st
))
2143 gfc_set_sym_referenced (sym
);
2145 if (!sym
->attr
.generic
2146 && !sym
->attr
.subroutine
2147 && gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2150 if (gfc_match_eos () != MATCH_YES
)
2152 m
= gfc_match_actual_arglist (1, &arglist
);
2155 if (m
== MATCH_ERROR
)
2158 if (gfc_match_eos () != MATCH_YES
)
2162 /* If any alternate return labels were found, construct a SELECT
2163 statement that will jump to the right place. */
2166 for (a
= arglist
; a
; a
= a
->next
)
2167 if (a
->expr
== NULL
)
2172 gfc_symtree
*select_st
;
2173 gfc_symbol
*select_sym
;
2174 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2176 new_st
.next
= c
= gfc_get_code ();
2177 c
->op
= EXEC_SELECT
;
2178 sprintf (name
, "_result_%s",sym
->name
);
2179 gfc_get_ha_sym_tree (name
, &select_st
); /* Can't fail */
2181 select_sym
= select_st
->n
.sym
;
2182 select_sym
->ts
.type
= BT_INTEGER
;
2183 select_sym
->ts
.kind
= gfc_default_integer_kind
;
2184 gfc_set_sym_referenced (select_sym
);
2185 c
->expr
= gfc_get_expr ();
2186 c
->expr
->expr_type
= EXPR_VARIABLE
;
2187 c
->expr
->symtree
= select_st
;
2188 c
->expr
->ts
= select_sym
->ts
;
2189 c
->expr
->where
= gfc_current_locus
;
2192 for (a
= arglist
; a
; a
= a
->next
)
2194 if (a
->expr
!= NULL
)
2197 if (gfc_reference_st_label (a
->label
, ST_LABEL_TARGET
) == FAILURE
)
2202 c
->block
= gfc_get_code ();
2204 c
->op
= EXEC_SELECT
;
2206 new_case
= gfc_get_case ();
2207 new_case
->high
= new_case
->low
= gfc_int_expr (i
);
2208 c
->ext
.case_list
= new_case
;
2210 c
->next
= gfc_get_code ();
2211 c
->next
->op
= EXEC_GOTO
;
2212 c
->next
->label
= a
->label
;
2216 new_st
.op
= EXEC_CALL
;
2217 new_st
.symtree
= st
;
2218 new_st
.ext
.actual
= arglist
;
2223 gfc_syntax_error (ST_CALL
);
2226 gfc_free_actual_arglist (arglist
);
2231 /* Given a name, return a pointer to the common head structure,
2232 creating it if it does not exist. If FROM_MODULE is nonzero, we
2233 mangle the name so that it doesn't interfere with commons defined
2234 in the using namespace.
2235 TODO: Add to global symbol tree. */
2238 gfc_get_common (const char *name
, int from_module
)
2241 static int serial
= 0;
2242 char mangled_name
[GFC_MAX_SYMBOL_LEN
+1];
2246 /* A use associated common block is only needed to correctly layout
2247 the variables it contains. */
2248 snprintf(mangled_name
, GFC_MAX_SYMBOL_LEN
, "_%d_%s", serial
++, name
);
2249 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, mangled_name
);
2253 st
= gfc_find_symtree (gfc_current_ns
->common_root
, name
);
2256 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, name
);
2259 if (st
->n
.common
== NULL
)
2261 st
->n
.common
= gfc_get_common_head ();
2262 st
->n
.common
->where
= gfc_current_locus
;
2263 strcpy (st
->n
.common
->name
, name
);
2266 return st
->n
.common
;
2270 /* Match a common block name. */
2273 match_common_name (char *name
)
2277 if (gfc_match_char ('/') == MATCH_NO
)
2283 if (gfc_match_char ('/') == MATCH_YES
)
2289 m
= gfc_match_name (name
);
2291 if (m
== MATCH_ERROR
)
2293 if (m
== MATCH_YES
&& gfc_match_char ('/') == MATCH_YES
)
2296 gfc_error ("Syntax error in common block name at %C");
2301 /* Match a COMMON statement. */
2304 gfc_match_common (void)
2306 gfc_symbol
*sym
, **head
, *tail
, *other
, *old_blank_common
;
2307 char name
[GFC_MAX_SYMBOL_LEN
+1];
2310 gfc_equiv
* e1
, * e2
;
2314 old_blank_common
= gfc_current_ns
->blank_common
.head
;
2315 if (old_blank_common
)
2317 while (old_blank_common
->common_next
)
2318 old_blank_common
= old_blank_common
->common_next
;
2325 m
= match_common_name (name
);
2326 if (m
== MATCH_ERROR
)
2329 gsym
= gfc_get_gsymbol (name
);
2330 if (gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= GSYM_COMMON
)
2332 gfc_error ("Symbol '%s' at %C is already an external symbol that is not COMMON",
2337 if (gsym
->type
== GSYM_UNKNOWN
)
2339 gsym
->type
= GSYM_COMMON
;
2340 gsym
->where
= gfc_current_locus
;
2346 if (name
[0] == '\0')
2348 if (gfc_current_ns
->is_block_data
)
2350 gfc_warning ("BLOCK DATA unit cannot contain blank COMMON at %C");
2352 t
= &gfc_current_ns
->blank_common
;
2353 if (t
->head
== NULL
)
2354 t
->where
= gfc_current_locus
;
2358 t
= gfc_get_common (name
, 0);
2367 while (tail
->common_next
)
2368 tail
= tail
->common_next
;
2371 /* Grab the list of symbols. */
2374 m
= gfc_match_symbol (&sym
, 0);
2375 if (m
== MATCH_ERROR
)
2380 if (sym
->attr
.in_common
)
2382 gfc_error ("Symbol '%s' at %C is already in a COMMON block",
2387 if (gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2390 if (sym
->value
!= NULL
2391 && (name
[0] == '\0' || !sym
->attr
.data
))
2393 if (name
[0] == '\0')
2394 gfc_error ("Previously initialized symbol '%s' in "
2395 "blank COMMON block at %C", sym
->name
);
2397 gfc_error ("Previously initialized symbol '%s' in "
2398 "COMMON block '%s' at %C", sym
->name
, name
);
2402 if (gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2405 /* Derived type names must have the SEQUENCE attribute. */
2406 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.derived
->attr
.sequence
)
2409 ("Derived type variable in COMMON at %C does not have the "
2410 "SEQUENCE attribute");
2415 tail
->common_next
= sym
;
2421 /* Deal with an optional array specification after the
2423 m
= gfc_match_array_spec (&as
);
2424 if (m
== MATCH_ERROR
)
2429 if (as
->type
!= AS_EXPLICIT
)
2432 ("Array specification for symbol '%s' in COMMON at %C "
2433 "must be explicit", sym
->name
);
2437 if (gfc_add_dimension (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2440 if (sym
->attr
.pointer
)
2443 ("Symbol '%s' in COMMON at %C cannot be a POINTER array",
2453 sym
->common_head
= t
;
2455 /* Check to see if the symbol is already in an equivalence group.
2456 If it is, set the other members as being in common. */
2457 if (sym
->attr
.in_equivalence
)
2459 for (e1
= gfc_current_ns
->equiv
; e1
; e1
= e1
->next
)
2461 for (e2
= e1
; e2
; e2
= e2
->eq
)
2462 if (e2
->expr
->symtree
->n
.sym
== sym
)
2469 for (e2
= e1
; e2
; e2
= e2
->eq
)
2471 other
= e2
->expr
->symtree
->n
.sym
;
2472 if (other
->common_head
2473 && other
->common_head
!= sym
->common_head
)
2475 gfc_error ("Symbol '%s', in COMMON block '%s' at "
2476 "%C is being indirectly equivalenced to "
2477 "another COMMON block '%s'",
2479 sym
->common_head
->name
,
2480 other
->common_head
->name
);
2483 other
->attr
.in_common
= 1;
2484 other
->common_head
= t
;
2490 gfc_gobble_whitespace ();
2491 if (gfc_match_eos () == MATCH_YES
)
2493 if (gfc_peek_char () == '/')
2495 if (gfc_match_char (',') != MATCH_YES
)
2497 gfc_gobble_whitespace ();
2498 if (gfc_peek_char () == '/')
2507 gfc_syntax_error (ST_COMMON
);
2510 if (old_blank_common
)
2511 old_blank_common
->common_next
= NULL
;
2513 gfc_current_ns
->blank_common
.head
= NULL
;
2514 gfc_free_array_spec (as
);
2519 /* Match a BLOCK DATA program unit. */
2522 gfc_match_block_data (void)
2524 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2528 if (gfc_match_eos () == MATCH_YES
)
2530 gfc_new_block
= NULL
;
2534 m
= gfc_match ("% %n%t", name
);
2538 if (gfc_get_symbol (name
, NULL
, &sym
))
2541 if (gfc_add_flavor (&sym
->attr
, FL_BLOCK_DATA
, sym
->name
, NULL
) == FAILURE
)
2544 gfc_new_block
= sym
;
2550 /* Free a namelist structure. */
2553 gfc_free_namelist (gfc_namelist
* name
)
2557 for (; name
; name
= n
)
2565 /* Match a NAMELIST statement. */
2568 gfc_match_namelist (void)
2570 gfc_symbol
*group_name
, *sym
;
2574 m
= gfc_match (" / %s /", &group_name
);
2577 if (m
== MATCH_ERROR
)
2582 if (group_name
->ts
.type
!= BT_UNKNOWN
)
2585 ("Namelist group name '%s' at %C already has a basic type "
2586 "of %s", group_name
->name
, gfc_typename (&group_name
->ts
));
2590 if (group_name
->attr
.flavor
== FL_NAMELIST
2591 && group_name
->attr
.use_assoc
2592 && gfc_notify_std (GFC_STD_GNU
, "Namelist group name '%s' "
2593 "at %C already is USE associated and can"
2594 "not be respecified.", group_name
->name
)
2598 if (group_name
->attr
.flavor
!= FL_NAMELIST
2599 && gfc_add_flavor (&group_name
->attr
, FL_NAMELIST
,
2600 group_name
->name
, NULL
) == FAILURE
)
2605 m
= gfc_match_symbol (&sym
, 1);
2608 if (m
== MATCH_ERROR
)
2611 if (sym
->attr
.in_namelist
== 0
2612 && gfc_add_in_namelist (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2615 /* Use gfc_error_check here, rather than goto error, so that this
2616 these are the only errors for the next two lines. */
2617 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
)
2619 gfc_error ("Assumed size array '%s' in namelist '%s' at "
2620 "%C is not allowed", sym
->name
, group_name
->name
);
2624 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SHAPE
2625 && gfc_notify_std (GFC_STD_GNU
, "Assumed shape array '%s' in "
2626 "namelist '%s' at %C is an extension.",
2627 sym
->name
, group_name
->name
) == FAILURE
)
2630 nl
= gfc_get_namelist ();
2634 if (group_name
->namelist
== NULL
)
2635 group_name
->namelist
= group_name
->namelist_tail
= nl
;
2638 group_name
->namelist_tail
->next
= nl
;
2639 group_name
->namelist_tail
= nl
;
2642 if (gfc_match_eos () == MATCH_YES
)
2645 m
= gfc_match_char (',');
2647 if (gfc_match_char ('/') == MATCH_YES
)
2649 m2
= gfc_match (" %s /", &group_name
);
2650 if (m2
== MATCH_YES
)
2652 if (m2
== MATCH_ERROR
)
2666 gfc_syntax_error (ST_NAMELIST
);
2673 /* Match a MODULE statement. */
2676 gfc_match_module (void)
2680 m
= gfc_match (" %s%t", &gfc_new_block
);
2684 if (gfc_add_flavor (&gfc_new_block
->attr
, FL_MODULE
,
2685 gfc_new_block
->name
, NULL
) == FAILURE
)
2692 /* Free equivalence sets and lists. Recursively is the easiest way to
2696 gfc_free_equiv (gfc_equiv
* eq
)
2702 gfc_free_equiv (eq
->eq
);
2703 gfc_free_equiv (eq
->next
);
2705 gfc_free_expr (eq
->expr
);
2710 /* Match an EQUIVALENCE statement. */
2713 gfc_match_equivalence (void)
2715 gfc_equiv
*eq
, *set
, *tail
;
2719 gfc_common_head
*common_head
= NULL
;
2727 eq
= gfc_get_equiv ();
2731 eq
->next
= gfc_current_ns
->equiv
;
2732 gfc_current_ns
->equiv
= eq
;
2734 if (gfc_match_char ('(') != MATCH_YES
)
2738 common_flag
= FALSE
;
2743 m
= gfc_match_equiv_variable (&set
->expr
);
2744 if (m
== MATCH_ERROR
)
2749 /* count the number of objects. */
2752 if (gfc_match_char ('%') == MATCH_YES
)
2754 gfc_error ("Derived type component %C is not a "
2755 "permitted EQUIVALENCE member");
2759 for (ref
= set
->expr
->ref
; ref
; ref
= ref
->next
)
2760 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2763 ("Array reference in EQUIVALENCE at %C cannot be an "
2768 sym
= set
->expr
->symtree
->n
.sym
;
2770 if (gfc_add_in_equivalence (&sym
->attr
, sym
->name
, NULL
)
2774 if (sym
->attr
.in_common
)
2777 common_head
= sym
->common_head
;
2780 if (gfc_match_char (')') == MATCH_YES
)
2783 if (gfc_match_char (',') != MATCH_YES
)
2786 set
->eq
= gfc_get_equiv ();
2792 gfc_error ("EQUIVALENCE at %C requires two or more objects");
2796 /* If one of the members of an equivalence is in common, then
2797 mark them all as being in common. Before doing this, check
2798 that members of the equivalence group are not in different
2801 for (set
= eq
; set
; set
= set
->eq
)
2803 sym
= set
->expr
->symtree
->n
.sym
;
2804 if (sym
->common_head
&& sym
->common_head
!= common_head
)
2806 gfc_error ("Attempt to indirectly overlap COMMON "
2807 "blocks %s and %s by EQUIVALENCE at %C",
2808 sym
->common_head
->name
,
2812 sym
->attr
.in_common
= 1;
2813 sym
->common_head
= common_head
;
2816 if (gfc_match_eos () == MATCH_YES
)
2818 if (gfc_match_char (',') != MATCH_YES
)
2825 gfc_syntax_error (ST_EQUIVALENCE
);
2831 gfc_free_equiv (gfc_current_ns
->equiv
);
2832 gfc_current_ns
->equiv
= eq
;
2837 /* Check that a statement function is not recursive. This is done by looking
2838 for the statement function symbol(sym) by looking recursively through its
2839 expression(e). If a reference to sym is found, true is returned.
2840 12.5.4 requires that any variable of function that is implicitly typed
2841 shall have that type confirmed by any subsequent type declaration. The
2842 implicit typing is conveniently done here. */
2845 recursive_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
)
2847 gfc_actual_arglist
*arg
;
2854 switch (e
->expr_type
)
2857 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
2859 if (sym
->name
== arg
->name
2860 || recursive_stmt_fcn (arg
->expr
, sym
))
2864 if (e
->symtree
== NULL
)
2867 /* Check the name before testing for nested recursion! */
2868 if (sym
->name
== e
->symtree
->n
.sym
->name
)
2871 /* Catch recursion via other statement functions. */
2872 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
2873 && e
->symtree
->n
.sym
->value
2874 && recursive_stmt_fcn (e
->symtree
->n
.sym
->value
, sym
))
2877 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
2878 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
2883 if (e
->symtree
&& sym
->name
== e
->symtree
->n
.sym
->name
)
2886 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
2887 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
2891 if (recursive_stmt_fcn (e
->value
.op
.op1
, sym
)
2892 || recursive_stmt_fcn (e
->value
.op
.op2
, sym
))
2900 /* Component references do not need to be checked. */
2903 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2908 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2910 if (recursive_stmt_fcn (ref
->u
.ar
.start
[i
], sym
)
2911 || recursive_stmt_fcn (ref
->u
.ar
.end
[i
], sym
)
2912 || recursive_stmt_fcn (ref
->u
.ar
.stride
[i
], sym
))
2918 if (recursive_stmt_fcn (ref
->u
.ss
.start
, sym
)
2919 || recursive_stmt_fcn (ref
->u
.ss
.end
, sym
))
2933 /* Match a statement function declaration. It is so easy to match
2934 non-statement function statements with a MATCH_ERROR as opposed to
2935 MATCH_NO that we suppress error message in most cases. */
2938 gfc_match_st_function (void)
2940 gfc_error_buf old_error
;
2945 m
= gfc_match_symbol (&sym
, 0);
2949 gfc_push_error (&old_error
);
2951 if (gfc_add_procedure (&sym
->attr
, PROC_ST_FUNCTION
,
2952 sym
->name
, NULL
) == FAILURE
)
2955 if (gfc_match_formal_arglist (sym
, 1, 0) != MATCH_YES
)
2958 m
= gfc_match (" = %e%t", &expr
);
2962 gfc_free_error (&old_error
);
2963 if (m
== MATCH_ERROR
)
2966 if (recursive_stmt_fcn (expr
, sym
))
2968 gfc_error ("Statement function at %L is recursive",
2978 gfc_pop_error (&old_error
);
2983 /***************** SELECT CASE subroutines ******************/
2985 /* Free a single case structure. */
2988 free_case (gfc_case
* p
)
2990 if (p
->low
== p
->high
)
2992 gfc_free_expr (p
->low
);
2993 gfc_free_expr (p
->high
);
2998 /* Free a list of case structures. */
3001 gfc_free_case_list (gfc_case
* p
)
3013 /* Match a single case selector. */
3016 match_case_selector (gfc_case
** cp
)
3021 c
= gfc_get_case ();
3022 c
->where
= gfc_current_locus
;
3024 if (gfc_match_char (':') == MATCH_YES
)
3026 m
= gfc_match_init_expr (&c
->high
);
3029 if (m
== MATCH_ERROR
)
3035 m
= gfc_match_init_expr (&c
->low
);
3036 if (m
== MATCH_ERROR
)
3041 /* If we're not looking at a ':' now, make a range out of a single
3042 target. Else get the upper bound for the case range. */
3043 if (gfc_match_char (':') != MATCH_YES
)
3047 m
= gfc_match_init_expr (&c
->high
);
3048 if (m
== MATCH_ERROR
)
3050 /* MATCH_NO is fine. It's OK if nothing is there! */
3058 gfc_error ("Expected initialization expression in CASE at %C");
3066 /* Match the end of a case statement. */
3069 match_case_eos (void)
3071 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3074 if (gfc_match_eos () == MATCH_YES
)
3077 /* If the case construct doesn't have a case-construct-name, we
3078 should have matched the EOS. */
3079 if (!gfc_current_block ())
3081 gfc_error ("Expected the name of the select case construct at %C");
3085 gfc_gobble_whitespace ();
3087 m
= gfc_match_name (name
);
3091 if (strcmp (name
, gfc_current_block ()->name
) != 0)
3093 gfc_error ("Expected case name of '%s' at %C",
3094 gfc_current_block ()->name
);
3098 return gfc_match_eos ();
3102 /* Match a SELECT statement. */
3105 gfc_match_select (void)
3110 m
= gfc_match_label ();
3111 if (m
== MATCH_ERROR
)
3114 m
= gfc_match (" select case ( %e )%t", &expr
);
3118 new_st
.op
= EXEC_SELECT
;
3125 /* Match a CASE statement. */
3128 gfc_match_case (void)
3130 gfc_case
*c
, *head
, *tail
;
3135 if (gfc_current_state () != COMP_SELECT
)
3137 gfc_error ("Unexpected CASE statement at %C");
3141 if (gfc_match ("% default") == MATCH_YES
)
3143 m
= match_case_eos ();
3146 if (m
== MATCH_ERROR
)
3149 new_st
.op
= EXEC_SELECT
;
3150 c
= gfc_get_case ();
3151 c
->where
= gfc_current_locus
;
3152 new_st
.ext
.case_list
= c
;
3156 if (gfc_match_char ('(') != MATCH_YES
)
3161 if (match_case_selector (&c
) == MATCH_ERROR
)
3171 if (gfc_match_char (')') == MATCH_YES
)
3173 if (gfc_match_char (',') != MATCH_YES
)
3177 m
= match_case_eos ();
3180 if (m
== MATCH_ERROR
)
3183 new_st
.op
= EXEC_SELECT
;
3184 new_st
.ext
.case_list
= head
;
3189 gfc_error ("Syntax error in CASE-specification at %C");
3192 gfc_free_case_list (head
); /* new_st is cleaned up in parse.c. */
3196 /********************* WHERE subroutines ********************/
3198 /* Match the rest of a simple WHERE statement that follows an IF statement.
3202 match_simple_where (void)
3208 m
= gfc_match (" ( %e )", &expr
);
3212 m
= gfc_match_assignment ();
3215 if (m
== MATCH_ERROR
)
3218 if (gfc_match_eos () != MATCH_YES
)
3221 c
= gfc_get_code ();
3225 c
->next
= gfc_get_code ();
3228 gfc_clear_new_st ();
3230 new_st
.op
= EXEC_WHERE
;
3236 gfc_syntax_error (ST_WHERE
);
3239 gfc_free_expr (expr
);
3243 /* Match a WHERE statement. */
3246 gfc_match_where (gfc_statement
* st
)
3252 m0
= gfc_match_label ();
3253 if (m0
== MATCH_ERROR
)
3256 m
= gfc_match (" where ( %e )", &expr
);
3260 if (gfc_match_eos () == MATCH_YES
)
3262 *st
= ST_WHERE_BLOCK
;
3264 new_st
.op
= EXEC_WHERE
;
3269 m
= gfc_match_assignment ();
3271 gfc_syntax_error (ST_WHERE
);
3275 gfc_free_expr (expr
);
3279 /* We've got a simple WHERE statement. */
3281 c
= gfc_get_code ();
3285 c
->next
= gfc_get_code ();
3288 gfc_clear_new_st ();
3290 new_st
.op
= EXEC_WHERE
;
3297 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
3298 new_st if successful. */
3301 gfc_match_elsewhere (void)
3303 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3307 if (gfc_current_state () != COMP_WHERE
)
3309 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
3315 if (gfc_match_char ('(') == MATCH_YES
)
3317 m
= gfc_match_expr (&expr
);
3320 if (m
== MATCH_ERROR
)
3323 if (gfc_match_char (')') != MATCH_YES
)
3327 if (gfc_match_eos () != MATCH_YES
)
3328 { /* Better be a name at this point */
3329 m
= gfc_match_name (name
);
3332 if (m
== MATCH_ERROR
)
3335 if (gfc_match_eos () != MATCH_YES
)
3338 if (strcmp (name
, gfc_current_block ()->name
) != 0)
3340 gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
3341 name
, gfc_current_block ()->name
);
3346 new_st
.op
= EXEC_WHERE
;
3351 gfc_syntax_error (ST_ELSEWHERE
);
3354 gfc_free_expr (expr
);
3359 /******************** FORALL subroutines ********************/
3361 /* Free a list of FORALL iterators. */
3364 gfc_free_forall_iterator (gfc_forall_iterator
* iter
)
3366 gfc_forall_iterator
*next
;
3372 gfc_free_expr (iter
->var
);
3373 gfc_free_expr (iter
->start
);
3374 gfc_free_expr (iter
->end
);
3375 gfc_free_expr (iter
->stride
);
3383 /* Match an iterator as part of a FORALL statement. The format is:
3385 <var> = <start>:<end>[:<stride>][, <scalar mask>] */
3388 match_forall_iterator (gfc_forall_iterator
** result
)
3390 gfc_forall_iterator
*iter
;
3394 where
= gfc_current_locus
;
3395 iter
= gfc_getmem (sizeof (gfc_forall_iterator
));
3397 m
= gfc_match_variable (&iter
->var
, 0);
3401 if (gfc_match_char ('=') != MATCH_YES
)
3407 m
= gfc_match_expr (&iter
->start
);
3411 if (gfc_match_char (':') != MATCH_YES
)
3414 m
= gfc_match_expr (&iter
->end
);
3417 if (m
== MATCH_ERROR
)
3420 if (gfc_match_char (':') == MATCH_NO
)
3421 iter
->stride
= gfc_int_expr (1);
3424 m
= gfc_match_expr (&iter
->stride
);
3427 if (m
== MATCH_ERROR
)
3431 /* Mark the iteration variable's symbol as used as a FORALL index. */
3432 iter
->var
->symtree
->n
.sym
->forall_index
= true;
3438 gfc_error ("Syntax error in FORALL iterator at %C");
3442 /* Make sure that potential internal function references in the
3443 mask do not get messed up. */
3445 && iter
->var
->expr_type
== EXPR_VARIABLE
3446 && iter
->var
->symtree
->n
.sym
->refs
== 1)
3447 iter
->var
->symtree
->n
.sym
->attr
.flavor
= FL_UNKNOWN
;
3449 gfc_current_locus
= where
;
3450 gfc_free_forall_iterator (iter
);
3455 /* Match the header of a FORALL statement. */
3458 match_forall_header (gfc_forall_iterator
** phead
, gfc_expr
** mask
)
3460 gfc_forall_iterator
*head
, *tail
, *new;
3464 gfc_gobble_whitespace ();
3469 if (gfc_match_char ('(') != MATCH_YES
)
3472 m
= match_forall_iterator (&new);
3473 if (m
== MATCH_ERROR
)
3482 if (gfc_match_char (',') != MATCH_YES
)
3485 m
= match_forall_iterator (&new);
3486 if (m
== MATCH_ERROR
)
3496 /* Have to have a mask expression */
3498 m
= gfc_match_expr (&msk
);
3501 if (m
== MATCH_ERROR
)
3507 if (gfc_match_char (')') == MATCH_NO
)
3515 gfc_syntax_error (ST_FORALL
);
3518 gfc_free_expr (msk
);
3519 gfc_free_forall_iterator (head
);
3524 /* Match the rest of a simple FORALL statement that follows an IF statement.
3528 match_simple_forall (void)
3530 gfc_forall_iterator
*head
;
3539 m
= match_forall_header (&head
, &mask
);
3546 m
= gfc_match_assignment ();
3548 if (m
== MATCH_ERROR
)
3552 m
= gfc_match_pointer_assignment ();
3553 if (m
== MATCH_ERROR
)
3559 c
= gfc_get_code ();
3561 c
->loc
= gfc_current_locus
;
3563 if (gfc_match_eos () != MATCH_YES
)
3566 gfc_clear_new_st ();
3567 new_st
.op
= EXEC_FORALL
;
3569 new_st
.ext
.forall_iterator
= head
;
3570 new_st
.block
= gfc_get_code ();
3572 new_st
.block
->op
= EXEC_FORALL
;
3573 new_st
.block
->next
= c
;
3578 gfc_syntax_error (ST_FORALL
);
3581 gfc_free_forall_iterator (head
);
3582 gfc_free_expr (mask
);
3588 /* Match a FORALL statement. */
3591 gfc_match_forall (gfc_statement
* st
)
3593 gfc_forall_iterator
*head
;
3602 m0
= gfc_match_label ();
3603 if (m0
== MATCH_ERROR
)
3606 m
= gfc_match (" forall");
3610 m
= match_forall_header (&head
, &mask
);
3611 if (m
== MATCH_ERROR
)
3616 if (gfc_match_eos () == MATCH_YES
)
3618 *st
= ST_FORALL_BLOCK
;
3620 new_st
.op
= EXEC_FORALL
;
3622 new_st
.ext
.forall_iterator
= head
;
3627 m
= gfc_match_assignment ();
3628 if (m
== MATCH_ERROR
)
3632 m
= gfc_match_pointer_assignment ();
3633 if (m
== MATCH_ERROR
)
3639 c
= gfc_get_code ();
3641 c
->loc
= gfc_current_locus
;
3643 gfc_clear_new_st ();
3644 new_st
.op
= EXEC_FORALL
;
3646 new_st
.ext
.forall_iterator
= head
;
3647 new_st
.block
= gfc_get_code ();
3649 new_st
.block
->op
= EXEC_FORALL
;
3650 new_st
.block
->next
= c
;
3656 gfc_syntax_error (ST_FORALL
);
3659 gfc_free_forall_iterator (head
);
3660 gfc_free_expr (mask
);
3661 gfc_free_statements (c
);