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 if (gfc_error_flag_test() == 0)
400 gfc_error ("Invalid character in name at %C");
401 gfc_current_locus
= old_loc
;
411 if (i
> gfc_option
.max_identifier_length
)
413 gfc_error ("Name at %C is too long");
417 old_loc
= gfc_current_locus
;
418 c
= gfc_next_char ();
422 || (gfc_option
.flag_dollar_ok
&& c
== '$'));
425 gfc_current_locus
= old_loc
;
431 /* Match a symbol on the input. Modifies the pointer to the symbol
432 pointer if successful. */
435 gfc_match_sym_tree (gfc_symtree
** matched_symbol
, int host_assoc
)
437 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
440 m
= gfc_match_name (buffer
);
445 return (gfc_get_ha_sym_tree (buffer
, matched_symbol
))
446 ? MATCH_ERROR
: MATCH_YES
;
448 if (gfc_get_sym_tree (buffer
, NULL
, matched_symbol
))
456 gfc_match_symbol (gfc_symbol
** matched_symbol
, int host_assoc
)
461 m
= gfc_match_sym_tree (&st
, host_assoc
);
466 *matched_symbol
= st
->n
.sym
;
468 *matched_symbol
= NULL
;
471 *matched_symbol
= NULL
;
475 /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
476 we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
480 gfc_match_intrinsic_op (gfc_intrinsic_op
* result
)
484 op
= (gfc_intrinsic_op
) gfc_match_strings (intrinsic_operators
);
486 if (op
== INTRINSIC_NONE
)
494 /* Match a loop control phrase:
496 <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
498 If the final integer expression is not present, a constant unity
499 expression is returned. We don't return MATCH_ERROR until after
500 the equals sign is seen. */
503 gfc_match_iterator (gfc_iterator
* iter
, int init_flag
)
505 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
506 gfc_expr
*var
, *e1
, *e2
, *e3
;
510 /* Match the start of an iterator without affecting the symbol
513 start
= gfc_current_locus
;
514 m
= gfc_match (" %n =", name
);
515 gfc_current_locus
= start
;
520 m
= gfc_match_variable (&var
, 0);
524 gfc_match_char ('=');
528 if (var
->ref
!= NULL
)
530 gfc_error ("Loop variable at %C cannot be a sub-component");
534 if (var
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
536 gfc_error ("Loop variable '%s' at %C cannot be INTENT(IN)",
537 var
->symtree
->n
.sym
->name
);
541 if (var
->symtree
->n
.sym
->attr
.pointer
)
543 gfc_error ("Loop variable at %C cannot have the POINTER attribute");
547 m
= init_flag
? gfc_match_init_expr (&e1
) : gfc_match_expr (&e1
);
550 if (m
== MATCH_ERROR
)
553 if (gfc_match_char (',') != MATCH_YES
)
556 m
= init_flag
? gfc_match_init_expr (&e2
) : gfc_match_expr (&e2
);
559 if (m
== MATCH_ERROR
)
562 if (gfc_match_char (',') != MATCH_YES
)
564 e3
= gfc_int_expr (1);
568 m
= init_flag
? gfc_match_init_expr (&e3
) : gfc_match_expr (&e3
);
569 if (m
== MATCH_ERROR
)
573 gfc_error ("Expected a step value in iterator at %C");
585 gfc_error ("Syntax error in iterator at %C");
596 /* Tries to match the next non-whitespace character on the input.
597 This subroutine does not return MATCH_ERROR. */
600 gfc_match_char (char c
)
604 where
= gfc_current_locus
;
605 gfc_gobble_whitespace ();
607 if (gfc_next_char () == c
)
610 gfc_current_locus
= where
;
615 /* General purpose matching subroutine. The target string is a
616 scanf-like format string in which spaces correspond to arbitrary
617 whitespace (including no whitespace), characters correspond to
618 themselves. The %-codes are:
620 %% Literal percent sign
621 %e Expression, pointer to a pointer is set
622 %s Symbol, pointer to the symbol is set
623 %n Name, character buffer is set to name
624 %t Matches end of statement.
625 %o Matches an intrinsic operator, returned as an INTRINSIC enum.
626 %l Matches a statement label
627 %v Matches a variable expression (an lvalue)
628 % Matches a required space (in free form) and optional spaces. */
631 gfc_match (const char *target
, ...)
633 gfc_st_label
**label
;
642 old_loc
= gfc_current_locus
;
643 va_start (argp
, target
);
653 gfc_gobble_whitespace ();
664 vp
= va_arg (argp
, void **);
665 n
= gfc_match_expr ((gfc_expr
**) vp
);
676 vp
= va_arg (argp
, void **);
677 n
= gfc_match_variable ((gfc_expr
**) vp
, 0);
688 vp
= va_arg (argp
, void **);
689 n
= gfc_match_symbol ((gfc_symbol
**) vp
, 0);
700 np
= va_arg (argp
, char *);
701 n
= gfc_match_name (np
);
712 label
= va_arg (argp
, gfc_st_label
**);
713 n
= gfc_match_st_label (label
);
724 ip
= va_arg (argp
, int *);
725 n
= gfc_match_intrinsic_op ((gfc_intrinsic_op
*) ip
);
736 if (gfc_match_eos () != MATCH_YES
)
744 if (gfc_match_space () == MATCH_YES
)
750 break; /* Fall through to character matcher */
753 gfc_internal_error ("gfc_match(): Bad match code %c", c
);
757 if (c
== gfc_next_char ())
767 /* Clean up after a failed match. */
768 gfc_current_locus
= old_loc
;
769 va_start (argp
, target
);
772 for (; matches
> 0; matches
--)
782 /* Matches that don't have to be undone */
787 (void)va_arg (argp
, void **);
792 vp
= va_arg (argp
, void **);
806 /*********************** Statement level matching **********************/
808 /* Matches the start of a program unit, which is the program keyword
809 followed by an obligatory symbol. */
812 gfc_match_program (void)
817 m
= gfc_match ("% %s%t", &sym
);
821 gfc_error ("Invalid form of PROGRAM statement at %C");
825 if (m
== MATCH_ERROR
)
828 if (gfc_add_flavor (&sym
->attr
, FL_PROGRAM
, sym
->name
, NULL
) == FAILURE
)
837 /* Match a simple assignment statement. */
840 gfc_match_assignment (void)
842 gfc_expr
*lvalue
, *rvalue
;
846 old_loc
= gfc_current_locus
;
849 m
= gfc_match (" %v =", &lvalue
);
852 gfc_current_locus
= old_loc
;
853 gfc_free_expr (lvalue
);
857 if (lvalue
->symtree
->n
.sym
->attr
.protected
858 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
)
860 gfc_current_locus
= old_loc
;
861 gfc_free_expr (lvalue
);
862 gfc_error ("Setting value of PROTECTED variable at %C");
867 m
= gfc_match (" %e%t", &rvalue
);
870 gfc_current_locus
= old_loc
;
871 gfc_free_expr (lvalue
);
872 gfc_free_expr (rvalue
);
876 gfc_set_sym_referenced (lvalue
->symtree
->n
.sym
);
878 new_st
.op
= EXEC_ASSIGN
;
879 new_st
.expr
= lvalue
;
880 new_st
.expr2
= rvalue
;
882 gfc_check_do_variable (lvalue
->symtree
);
888 /* Match a pointer assignment statement. */
891 gfc_match_pointer_assignment (void)
893 gfc_expr
*lvalue
, *rvalue
;
897 old_loc
= gfc_current_locus
;
899 lvalue
= rvalue
= NULL
;
901 m
= gfc_match (" %v =>", &lvalue
);
908 m
= gfc_match (" %e%t", &rvalue
);
912 if (lvalue
->symtree
->n
.sym
->attr
.protected
913 && lvalue
->symtree
->n
.sym
->attr
.use_assoc
)
915 gfc_error ("Assigning to a PROTECTED pointer at %C");
921 new_st
.op
= EXEC_POINTER_ASSIGN
;
922 new_st
.expr
= lvalue
;
923 new_st
.expr2
= rvalue
;
928 gfc_current_locus
= old_loc
;
929 gfc_free_expr (lvalue
);
930 gfc_free_expr (rvalue
);
935 /* We try to match an easy arithmetic IF statement. This only happens
936 when just after having encountered a simple IF statement. This code
937 is really duplicate with parts of the gfc_match_if code, but this is
940 match_arithmetic_if (void)
942 gfc_st_label
*l1
, *l2
, *l3
;
946 m
= gfc_match (" ( %e ) %l , %l , %l%t", &expr
, &l1
, &l2
, &l3
);
950 if (gfc_reference_st_label (l1
, ST_LABEL_TARGET
) == FAILURE
951 || gfc_reference_st_label (l2
, ST_LABEL_TARGET
) == FAILURE
952 || gfc_reference_st_label (l3
, ST_LABEL_TARGET
) == FAILURE
)
954 gfc_free_expr (expr
);
958 if (gfc_notify_std (GFC_STD_F95_DEL
,
959 "Obsolete: arithmetic IF statement at %C") == FAILURE
)
962 new_st
.op
= EXEC_ARITHMETIC_IF
;
972 /* The IF statement is a bit of a pain. First of all, there are three
973 forms of it, the simple IF, the IF that starts a block and the
976 There is a problem with the simple IF and that is the fact that we
977 only have a single level of undo information on symbols. What this
978 means is for a simple IF, we must re-match the whole IF statement
979 multiple times in order to guarantee that the symbol table ends up
980 in the proper state. */
982 static match
match_simple_forall (void);
983 static match
match_simple_where (void);
986 gfc_match_if (gfc_statement
* if_type
)
989 gfc_st_label
*l1
, *l2
, *l3
;
994 n
= gfc_match_label ();
995 if (n
== MATCH_ERROR
)
998 old_loc
= gfc_current_locus
;
1000 m
= gfc_match (" if ( %e", &expr
);
1004 if (gfc_match_char (')') != MATCH_YES
)
1006 gfc_error ("Syntax error in IF-expression at %C");
1007 gfc_free_expr (expr
);
1011 m
= gfc_match (" %l , %l , %l%t", &l1
, &l2
, &l3
);
1018 ("Block label not appropriate for arithmetic IF statement "
1021 gfc_free_expr (expr
);
1025 if (gfc_reference_st_label (l1
, ST_LABEL_TARGET
) == FAILURE
1026 || gfc_reference_st_label (l2
, ST_LABEL_TARGET
) == FAILURE
1027 || gfc_reference_st_label (l3
, ST_LABEL_TARGET
) == FAILURE
)
1030 gfc_free_expr (expr
);
1034 if (gfc_notify_std (GFC_STD_F95_DEL
,
1035 "Obsolete: arithmetic IF statement at %C")
1039 new_st
.op
= EXEC_ARITHMETIC_IF
;
1045 *if_type
= ST_ARITHMETIC_IF
;
1049 if (gfc_match (" then%t") == MATCH_YES
)
1051 new_st
.op
= EXEC_IF
;
1054 *if_type
= ST_IF_BLOCK
;
1060 gfc_error ("Block label is not appropriate IF statement at %C");
1062 gfc_free_expr (expr
);
1066 /* At this point the only thing left is a simple IF statement. At
1067 this point, n has to be MATCH_NO, so we don't have to worry about
1068 re-matching a block label. From what we've got so far, try
1069 matching an assignment. */
1071 *if_type
= ST_SIMPLE_IF
;
1073 m
= gfc_match_assignment ();
1077 gfc_free_expr (expr
);
1078 gfc_undo_symbols ();
1079 gfc_current_locus
= old_loc
;
1081 /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled
1082 assignment was found. For MATCH_NO, continue to call the various
1084 if (m
== MATCH_ERROR
)
1087 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match */
1089 m
= gfc_match_pointer_assignment ();
1093 gfc_free_expr (expr
);
1094 gfc_undo_symbols ();
1095 gfc_current_locus
= old_loc
;
1097 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match */
1099 /* Look at the next keyword to see which matcher to call. Matching
1100 the keyword doesn't affect the symbol table, so we don't have to
1101 restore between tries. */
1103 #define match(string, subr, statement) \
1104 if (gfc_match(string) == MATCH_YES) { m = subr(); goto got_match; }
1108 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
)
1109 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
)
1110 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
)
1111 match ("call", gfc_match_call
, ST_CALL
)
1112 match ("close", gfc_match_close
, ST_CLOSE
)
1113 match ("continue", gfc_match_continue
, ST_CONTINUE
)
1114 match ("cycle", gfc_match_cycle
, ST_CYCLE
)
1115 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
)
1116 match ("end file", gfc_match_endfile
, ST_END_FILE
)
1117 match ("exit", gfc_match_exit
, ST_EXIT
)
1118 match ("flush", gfc_match_flush
, ST_FLUSH
)
1119 match ("forall", match_simple_forall
, ST_FORALL
)
1120 match ("go to", gfc_match_goto
, ST_GOTO
)
1121 match ("if", match_arithmetic_if
, ST_ARITHMETIC_IF
)
1122 match ("inquire", gfc_match_inquire
, ST_INQUIRE
)
1123 match ("nullify", gfc_match_nullify
, ST_NULLIFY
)
1124 match ("open", gfc_match_open
, ST_OPEN
)
1125 match ("pause", gfc_match_pause
, ST_NONE
)
1126 match ("print", gfc_match_print
, ST_WRITE
)
1127 match ("read", gfc_match_read
, ST_READ
)
1128 match ("return", gfc_match_return
, ST_RETURN
)
1129 match ("rewind", gfc_match_rewind
, ST_REWIND
)
1130 match ("stop", gfc_match_stop
, ST_STOP
)
1131 match ("where", match_simple_where
, ST_WHERE
)
1132 match ("write", gfc_match_write
, ST_WRITE
)
1134 /* The gfc_match_assignment() above may have returned a MATCH_NO
1135 where the assignment was to a named constant. Check that
1136 special case here. */
1137 m
= gfc_match_assignment ();
1140 gfc_error ("Cannot assign to a named constant at %C");
1141 gfc_free_expr (expr
);
1142 gfc_undo_symbols ();
1143 gfc_current_locus
= old_loc
;
1147 /* All else has failed, so give up. See if any of the matchers has
1148 stored an error message of some sort. */
1149 if (gfc_error_check () == 0)
1150 gfc_error ("Unclassifiable statement in IF-clause at %C");
1152 gfc_free_expr (expr
);
1157 gfc_error ("Syntax error in IF-clause at %C");
1160 gfc_free_expr (expr
);
1164 /* At this point, we've matched the single IF and the action clause
1165 is in new_st. Rearrange things so that the IF statement appears
1168 p
= gfc_get_code ();
1169 p
->next
= gfc_get_code ();
1171 p
->next
->loc
= gfc_current_locus
;
1176 gfc_clear_new_st ();
1178 new_st
.op
= EXEC_IF
;
1187 /* Match an ELSE statement. */
1190 gfc_match_else (void)
1192 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1194 if (gfc_match_eos () == MATCH_YES
)
1197 if (gfc_match_name (name
) != MATCH_YES
1198 || gfc_current_block () == NULL
1199 || gfc_match_eos () != MATCH_YES
)
1201 gfc_error ("Unexpected junk after ELSE statement at %C");
1205 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1207 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1208 name
, gfc_current_block ()->name
);
1216 /* Match an ELSE IF statement. */
1219 gfc_match_elseif (void)
1221 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1225 m
= gfc_match (" ( %e ) then", &expr
);
1229 if (gfc_match_eos () == MATCH_YES
)
1232 if (gfc_match_name (name
) != MATCH_YES
1233 || gfc_current_block () == NULL
1234 || gfc_match_eos () != MATCH_YES
)
1236 gfc_error ("Unexpected junk after ELSE IF statement at %C");
1240 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1242 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1243 name
, gfc_current_block ()->name
);
1248 new_st
.op
= EXEC_IF
;
1253 gfc_free_expr (expr
);
1258 /* Free a gfc_iterator structure. */
1261 gfc_free_iterator (gfc_iterator
* iter
, int flag
)
1267 gfc_free_expr (iter
->var
);
1268 gfc_free_expr (iter
->start
);
1269 gfc_free_expr (iter
->end
);
1270 gfc_free_expr (iter
->step
);
1277 /* Match a DO statement. */
1282 gfc_iterator iter
, *ip
;
1284 gfc_st_label
*label
;
1287 old_loc
= gfc_current_locus
;
1290 iter
.var
= iter
.start
= iter
.end
= iter
.step
= NULL
;
1292 m
= gfc_match_label ();
1293 if (m
== MATCH_ERROR
)
1296 if (gfc_match (" do") != MATCH_YES
)
1299 m
= gfc_match_st_label (&label
);
1300 if (m
== MATCH_ERROR
)
1303 /* Match an infinite DO, make it like a DO WHILE(.TRUE.) */
1305 if (gfc_match_eos () == MATCH_YES
)
1307 iter
.end
= gfc_logical_expr (1, NULL
);
1308 new_st
.op
= EXEC_DO_WHILE
;
1312 /* match an optional comma, if no comma is found a space is obligatory. */
1313 if (gfc_match_char(',') != MATCH_YES
1314 && gfc_match ("% ") != MATCH_YES
)
1317 /* See if we have a DO WHILE. */
1318 if (gfc_match (" while ( %e )%t", &iter
.end
) == MATCH_YES
)
1320 new_st
.op
= EXEC_DO_WHILE
;
1324 /* The abortive DO WHILE may have done something to the symbol
1325 table, so we start over: */
1326 gfc_undo_symbols ();
1327 gfc_current_locus
= old_loc
;
1329 gfc_match_label (); /* This won't error */
1330 gfc_match (" do "); /* This will work */
1332 gfc_match_st_label (&label
); /* Can't error out */
1333 gfc_match_char (','); /* Optional comma */
1335 m
= gfc_match_iterator (&iter
, 0);
1338 if (m
== MATCH_ERROR
)
1341 gfc_check_do_variable (iter
.var
->symtree
);
1343 if (gfc_match_eos () != MATCH_YES
)
1345 gfc_syntax_error (ST_DO
);
1349 new_st
.op
= EXEC_DO
;
1353 && gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
1356 new_st
.label
= label
;
1358 if (new_st
.op
== EXEC_DO_WHILE
)
1359 new_st
.expr
= iter
.end
;
1362 new_st
.ext
.iterator
= ip
= gfc_get_iterator ();
1369 gfc_free_iterator (&iter
, 0);
1375 /* Match an EXIT or CYCLE statement. */
1378 match_exit_cycle (gfc_statement st
, gfc_exec_op op
)
1380 gfc_state_data
*p
, *o
;
1384 if (gfc_match_eos () == MATCH_YES
)
1388 m
= gfc_match ("% %s%t", &sym
);
1389 if (m
== MATCH_ERROR
)
1393 gfc_syntax_error (st
);
1397 if (sym
->attr
.flavor
!= FL_LABEL
)
1399 gfc_error ("Name '%s' in %s statement at %C is not a loop name",
1400 sym
->name
, gfc_ascii_statement (st
));
1405 /* Find the loop mentioned specified by the label (or lack of a
1407 for (o
= NULL
, p
= gfc_state_stack
; p
; p
= p
->previous
)
1408 if (p
->state
== COMP_DO
&& (sym
== NULL
|| sym
== p
->sym
))
1410 else if (o
== NULL
&& p
->state
== COMP_OMP_STRUCTURED_BLOCK
)
1416 gfc_error ("%s statement at %C is not within a loop",
1417 gfc_ascii_statement (st
));
1419 gfc_error ("%s statement at %C is not within loop '%s'",
1420 gfc_ascii_statement (st
), sym
->name
);
1427 gfc_error ("%s statement at %C leaving OpenMP structured block",
1428 gfc_ascii_statement (st
));
1431 else if (st
== ST_EXIT
1432 && p
->previous
!= NULL
1433 && p
->previous
->state
== COMP_OMP_STRUCTURED_BLOCK
1434 && (p
->previous
->head
->op
== EXEC_OMP_DO
1435 || p
->previous
->head
->op
== EXEC_OMP_PARALLEL_DO
))
1437 gcc_assert (p
->previous
->head
->next
!= NULL
);
1438 gcc_assert (p
->previous
->head
->next
->op
== EXEC_DO
1439 || p
->previous
->head
->next
->op
== EXEC_DO_WHILE
);
1440 gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
1444 /* Save the first statement in the loop - needed by the backend. */
1445 new_st
.ext
.whichloop
= p
->head
;
1448 /* new_st.sym = sym;*/
1454 /* Match the EXIT statement. */
1457 gfc_match_exit (void)
1460 return match_exit_cycle (ST_EXIT
, EXEC_EXIT
);
1464 /* Match the CYCLE statement. */
1467 gfc_match_cycle (void)
1470 return match_exit_cycle (ST_CYCLE
, EXEC_CYCLE
);
1474 /* Match a number or character constant after a STOP or PAUSE statement. */
1477 gfc_match_stopcode (gfc_statement st
)
1487 if (gfc_match_eos () != MATCH_YES
)
1489 m
= gfc_match_small_literal_int (&stop_code
, &cnt
);
1490 if (m
== MATCH_ERROR
)
1493 if (m
== MATCH_YES
&& cnt
> 5)
1495 gfc_error ("Too many digits in STOP code at %C");
1501 /* Try a character constant. */
1502 m
= gfc_match_expr (&e
);
1503 if (m
== MATCH_ERROR
)
1507 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1511 if (gfc_match_eos () != MATCH_YES
)
1515 if (gfc_pure (NULL
))
1517 gfc_error ("%s statement not allowed in PURE procedure at %C",
1518 gfc_ascii_statement (st
));
1522 new_st
.op
= st
== ST_STOP
? EXEC_STOP
: EXEC_PAUSE
;
1524 new_st
.ext
.stop_code
= stop_code
;
1529 gfc_syntax_error (st
);
1537 /* Match the (deprecated) PAUSE statement. */
1540 gfc_match_pause (void)
1544 m
= gfc_match_stopcode (ST_PAUSE
);
1547 if (gfc_notify_std (GFC_STD_F95_DEL
,
1548 "Obsolete: PAUSE statement at %C")
1556 /* Match the STOP statement. */
1559 gfc_match_stop (void)
1561 return gfc_match_stopcode (ST_STOP
);
1565 /* Match a CONTINUE statement. */
1568 gfc_match_continue (void)
1571 if (gfc_match_eos () != MATCH_YES
)
1573 gfc_syntax_error (ST_CONTINUE
);
1577 new_st
.op
= EXEC_CONTINUE
;
1582 /* Match the (deprecated) ASSIGN statement. */
1585 gfc_match_assign (void)
1588 gfc_st_label
*label
;
1590 if (gfc_match (" %l", &label
) == MATCH_YES
)
1592 if (gfc_reference_st_label (label
, ST_LABEL_UNKNOWN
) == FAILURE
)
1594 if (gfc_match (" to %v%t", &expr
) == MATCH_YES
)
1596 if (gfc_notify_std (GFC_STD_F95_DEL
,
1597 "Obsolete: ASSIGN statement at %C")
1601 expr
->symtree
->n
.sym
->attr
.assign
= 1;
1603 new_st
.op
= EXEC_LABEL_ASSIGN
;
1604 new_st
.label
= label
;
1613 /* Match the GO TO statement. As a computed GOTO statement is
1614 matched, it is transformed into an equivalent SELECT block. No
1615 tree is necessary, and the resulting jumps-to-jumps are
1616 specifically optimized away by the back end. */
1619 gfc_match_goto (void)
1621 gfc_code
*head
, *tail
;
1624 gfc_st_label
*label
;
1628 if (gfc_match (" %l%t", &label
) == MATCH_YES
)
1630 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
1633 new_st
.op
= EXEC_GOTO
;
1634 new_st
.label
= label
;
1638 /* The assigned GO TO statement. */
1640 if (gfc_match_variable (&expr
, 0) == MATCH_YES
)
1642 if (gfc_notify_std (GFC_STD_F95_DEL
,
1643 "Obsolete: Assigned GOTO statement at %C")
1647 new_st
.op
= EXEC_GOTO
;
1650 if (gfc_match_eos () == MATCH_YES
)
1653 /* Match label list. */
1654 gfc_match_char (',');
1655 if (gfc_match_char ('(') != MATCH_YES
)
1657 gfc_syntax_error (ST_GOTO
);
1664 m
= gfc_match_st_label (&label
);
1668 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
1672 head
= tail
= gfc_get_code ();
1675 tail
->block
= gfc_get_code ();
1679 tail
->label
= label
;
1680 tail
->op
= EXEC_GOTO
;
1682 while (gfc_match_char (',') == MATCH_YES
);
1684 if (gfc_match (")%t") != MATCH_YES
)
1690 "Statement label list in GOTO at %C cannot be empty");
1693 new_st
.block
= head
;
1698 /* Last chance is a computed GO TO statement. */
1699 if (gfc_match_char ('(') != MATCH_YES
)
1701 gfc_syntax_error (ST_GOTO
);
1710 m
= gfc_match_st_label (&label
);
1714 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
1718 head
= tail
= gfc_get_code ();
1721 tail
->block
= gfc_get_code ();
1725 cp
= gfc_get_case ();
1726 cp
->low
= cp
->high
= gfc_int_expr (i
++);
1728 tail
->op
= EXEC_SELECT
;
1729 tail
->ext
.case_list
= cp
;
1731 tail
->next
= gfc_get_code ();
1732 tail
->next
->op
= EXEC_GOTO
;
1733 tail
->next
->label
= label
;
1735 while (gfc_match_char (',') == MATCH_YES
);
1737 if (gfc_match_char (')') != MATCH_YES
)
1742 gfc_error ("Statement label list in GOTO at %C cannot be empty");
1746 /* Get the rest of the statement. */
1747 gfc_match_char (',');
1749 if (gfc_match (" %e%t", &expr
) != MATCH_YES
)
1752 /* At this point, a computed GOTO has been fully matched and an
1753 equivalent SELECT statement constructed. */
1755 new_st
.op
= EXEC_SELECT
;
1758 /* Hack: For a "real" SELECT, the expression is in expr. We put
1759 it in expr2 so we can distinguish then and produce the correct
1761 new_st
.expr2
= expr
;
1762 new_st
.block
= head
;
1766 gfc_syntax_error (ST_GOTO
);
1768 gfc_free_statements (head
);
1773 /* Frees a list of gfc_alloc structures. */
1776 gfc_free_alloc_list (gfc_alloc
* p
)
1783 gfc_free_expr (p
->expr
);
1789 /* Match an ALLOCATE statement. */
1792 gfc_match_allocate (void)
1794 gfc_alloc
*head
, *tail
;
1801 if (gfc_match_char ('(') != MATCH_YES
)
1807 head
= tail
= gfc_get_alloc ();
1810 tail
->next
= gfc_get_alloc ();
1814 m
= gfc_match_variable (&tail
->expr
, 0);
1817 if (m
== MATCH_ERROR
)
1820 if (gfc_check_do_variable (tail
->expr
->symtree
))
1824 && gfc_impure_variable (tail
->expr
->symtree
->n
.sym
))
1826 gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a "
1831 if (tail
->expr
->ts
.type
== BT_DERIVED
)
1832 tail
->expr
->ts
.derived
= gfc_use_derived (tail
->expr
->ts
.derived
);
1834 if (gfc_match_char (',') != MATCH_YES
)
1837 m
= gfc_match (" stat = %v", &stat
);
1838 if (m
== MATCH_ERROR
)
1846 if (stat
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
1849 ("STAT variable '%s' of ALLOCATE statement at %C cannot be "
1850 "INTENT(IN)", stat
->symtree
->n
.sym
->name
);
1854 if (gfc_pure (NULL
) && gfc_impure_variable (stat
->symtree
->n
.sym
))
1857 ("Illegal STAT variable in ALLOCATE statement at %C for a PURE "
1862 if (stat
->symtree
->n
.sym
->attr
.flavor
!= FL_VARIABLE
)
1864 gfc_error("STAT expression at %C must be a variable");
1868 gfc_check_do_variable(stat
->symtree
);
1871 if (gfc_match (" )%t") != MATCH_YES
)
1874 new_st
.op
= EXEC_ALLOCATE
;
1876 new_st
.ext
.alloc_list
= head
;
1881 gfc_syntax_error (ST_ALLOCATE
);
1884 gfc_free_expr (stat
);
1885 gfc_free_alloc_list (head
);
1890 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
1891 a set of pointer assignments to intrinsic NULL(). */
1894 gfc_match_nullify (void)
1902 if (gfc_match_char ('(') != MATCH_YES
)
1907 m
= gfc_match_variable (&p
, 0);
1908 if (m
== MATCH_ERROR
)
1913 if (gfc_check_do_variable(p
->symtree
))
1916 if (gfc_pure (NULL
) && gfc_impure_variable (p
->symtree
->n
.sym
))
1919 ("Illegal variable in NULLIFY at %C for a PURE procedure");
1923 /* build ' => NULL() ' */
1924 e
= gfc_get_expr ();
1925 e
->where
= gfc_current_locus
;
1926 e
->expr_type
= EXPR_NULL
;
1927 e
->ts
.type
= BT_UNKNOWN
;
1934 tail
->next
= gfc_get_code ();
1938 tail
->op
= EXEC_POINTER_ASSIGN
;
1942 if (gfc_match (" )%t") == MATCH_YES
)
1944 if (gfc_match_char (',') != MATCH_YES
)
1951 gfc_syntax_error (ST_NULLIFY
);
1954 gfc_free_statements (new_st
.next
);
1959 /* Match a DEALLOCATE statement. */
1962 gfc_match_deallocate (void)
1964 gfc_alloc
*head
, *tail
;
1971 if (gfc_match_char ('(') != MATCH_YES
)
1977 head
= tail
= gfc_get_alloc ();
1980 tail
->next
= gfc_get_alloc ();
1984 m
= gfc_match_variable (&tail
->expr
, 0);
1985 if (m
== MATCH_ERROR
)
1990 if (gfc_check_do_variable (tail
->expr
->symtree
))
1994 && gfc_impure_variable (tail
->expr
->symtree
->n
.sym
))
1997 ("Illegal deallocate-expression in DEALLOCATE at %C for a PURE "
2002 if (gfc_match_char (',') != MATCH_YES
)
2005 m
= gfc_match (" stat = %v", &stat
);
2006 if (m
== MATCH_ERROR
)
2014 if (stat
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
2016 gfc_error ("STAT variable '%s' of DEALLOCATE statement at %C "
2017 "cannot be INTENT(IN)", stat
->symtree
->n
.sym
->name
);
2021 if (gfc_pure(NULL
) && gfc_impure_variable (stat
->symtree
->n
.sym
))
2023 gfc_error ("Illegal STAT variable in DEALLOCATE statement at %C "
2024 "for a PURE procedure");
2028 if (stat
->symtree
->n
.sym
->attr
.flavor
!= FL_VARIABLE
)
2030 gfc_error("STAT expression at %C must be a variable");
2034 gfc_check_do_variable(stat
->symtree
);
2037 if (gfc_match (" )%t") != MATCH_YES
)
2040 new_st
.op
= EXEC_DEALLOCATE
;
2042 new_st
.ext
.alloc_list
= head
;
2047 gfc_syntax_error (ST_DEALLOCATE
);
2050 gfc_free_expr (stat
);
2051 gfc_free_alloc_list (head
);
2056 /* Match a RETURN statement. */
2059 gfc_match_return (void)
2063 gfc_compile_state s
;
2067 if (gfc_match_eos () == MATCH_YES
)
2070 if (gfc_find_state (COMP_SUBROUTINE
) == FAILURE
)
2072 gfc_error ("Alternate RETURN statement at %C is only allowed within "
2077 if (gfc_current_form
== FORM_FREE
)
2079 /* The following are valid, so we can't require a blank after the
2083 c
= gfc_peek_char ();
2084 if (ISALPHA (c
) || ISDIGIT (c
))
2088 m
= gfc_match (" %e%t", &e
);
2091 if (m
== MATCH_ERROR
)
2094 gfc_syntax_error (ST_RETURN
);
2101 gfc_enclosing_unit (&s
);
2102 if (s
== COMP_PROGRAM
2103 && gfc_notify_std (GFC_STD_GNU
, "Extension: RETURN statement in "
2104 "main program at %C") == FAILURE
)
2107 new_st
.op
= EXEC_RETURN
;
2114 /* Match a CALL statement. The tricky part here are possible
2115 alternate return specifiers. We handle these by having all
2116 "subroutines" actually return an integer via a register that gives
2117 the return number. If the call specifies alternate returns, we
2118 generate code for a SELECT statement whose case clauses contain
2119 GOTOs to the various labels. */
2122 gfc_match_call (void)
2124 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2125 gfc_actual_arglist
*a
, *arglist
;
2135 m
= gfc_match ("% %n", name
);
2141 if (gfc_get_ha_sym_tree (name
, &st
))
2145 gfc_set_sym_referenced (sym
);
2147 if (!sym
->attr
.generic
2148 && !sym
->attr
.subroutine
2149 && gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2152 if (gfc_match_eos () != MATCH_YES
)
2154 m
= gfc_match_actual_arglist (1, &arglist
);
2157 if (m
== MATCH_ERROR
)
2160 if (gfc_match_eos () != MATCH_YES
)
2164 /* If any alternate return labels were found, construct a SELECT
2165 statement that will jump to the right place. */
2168 for (a
= arglist
; a
; a
= a
->next
)
2169 if (a
->expr
== NULL
)
2174 gfc_symtree
*select_st
;
2175 gfc_symbol
*select_sym
;
2176 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2178 new_st
.next
= c
= gfc_get_code ();
2179 c
->op
= EXEC_SELECT
;
2180 sprintf (name
, "_result_%s",sym
->name
);
2181 gfc_get_ha_sym_tree (name
, &select_st
); /* Can't fail */
2183 select_sym
= select_st
->n
.sym
;
2184 select_sym
->ts
.type
= BT_INTEGER
;
2185 select_sym
->ts
.kind
= gfc_default_integer_kind
;
2186 gfc_set_sym_referenced (select_sym
);
2187 c
->expr
= gfc_get_expr ();
2188 c
->expr
->expr_type
= EXPR_VARIABLE
;
2189 c
->expr
->symtree
= select_st
;
2190 c
->expr
->ts
= select_sym
->ts
;
2191 c
->expr
->where
= gfc_current_locus
;
2194 for (a
= arglist
; a
; a
= a
->next
)
2196 if (a
->expr
!= NULL
)
2199 if (gfc_reference_st_label (a
->label
, ST_LABEL_TARGET
) == FAILURE
)
2204 c
->block
= gfc_get_code ();
2206 c
->op
= EXEC_SELECT
;
2208 new_case
= gfc_get_case ();
2209 new_case
->high
= new_case
->low
= gfc_int_expr (i
);
2210 c
->ext
.case_list
= new_case
;
2212 c
->next
= gfc_get_code ();
2213 c
->next
->op
= EXEC_GOTO
;
2214 c
->next
->label
= a
->label
;
2218 new_st
.op
= EXEC_CALL
;
2219 new_st
.symtree
= st
;
2220 new_st
.ext
.actual
= arglist
;
2225 gfc_syntax_error (ST_CALL
);
2228 gfc_free_actual_arglist (arglist
);
2233 /* Given a name, return a pointer to the common head structure,
2234 creating it if it does not exist. If FROM_MODULE is nonzero, we
2235 mangle the name so that it doesn't interfere with commons defined
2236 in the using namespace.
2237 TODO: Add to global symbol tree. */
2240 gfc_get_common (const char *name
, int from_module
)
2243 static int serial
= 0;
2244 char mangled_name
[GFC_MAX_SYMBOL_LEN
+1];
2248 /* A use associated common block is only needed to correctly layout
2249 the variables it contains. */
2250 snprintf(mangled_name
, GFC_MAX_SYMBOL_LEN
, "_%d_%s", serial
++, name
);
2251 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, mangled_name
);
2255 st
= gfc_find_symtree (gfc_current_ns
->common_root
, name
);
2258 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, name
);
2261 if (st
->n
.common
== NULL
)
2263 st
->n
.common
= gfc_get_common_head ();
2264 st
->n
.common
->where
= gfc_current_locus
;
2265 strcpy (st
->n
.common
->name
, name
);
2268 return st
->n
.common
;
2272 /* Match a common block name. */
2275 match_common_name (char *name
)
2279 if (gfc_match_char ('/') == MATCH_NO
)
2285 if (gfc_match_char ('/') == MATCH_YES
)
2291 m
= gfc_match_name (name
);
2293 if (m
== MATCH_ERROR
)
2295 if (m
== MATCH_YES
&& gfc_match_char ('/') == MATCH_YES
)
2298 gfc_error ("Syntax error in common block name at %C");
2303 /* Match a COMMON statement. */
2306 gfc_match_common (void)
2308 gfc_symbol
*sym
, **head
, *tail
, *other
, *old_blank_common
;
2309 char name
[GFC_MAX_SYMBOL_LEN
+1];
2312 gfc_equiv
* e1
, * e2
;
2316 old_blank_common
= gfc_current_ns
->blank_common
.head
;
2317 if (old_blank_common
)
2319 while (old_blank_common
->common_next
)
2320 old_blank_common
= old_blank_common
->common_next
;
2327 m
= match_common_name (name
);
2328 if (m
== MATCH_ERROR
)
2331 gsym
= gfc_get_gsymbol (name
);
2332 if (gsym
->type
!= GSYM_UNKNOWN
&& gsym
->type
!= GSYM_COMMON
)
2334 gfc_error ("Symbol '%s' at %C is already an external symbol that is not COMMON",
2339 if (gsym
->type
== GSYM_UNKNOWN
)
2341 gsym
->type
= GSYM_COMMON
;
2342 gsym
->where
= gfc_current_locus
;
2348 if (name
[0] == '\0')
2350 if (gfc_current_ns
->is_block_data
)
2352 gfc_warning ("BLOCK DATA unit cannot contain blank COMMON at %C");
2354 t
= &gfc_current_ns
->blank_common
;
2355 if (t
->head
== NULL
)
2356 t
->where
= gfc_current_locus
;
2360 t
= gfc_get_common (name
, 0);
2369 while (tail
->common_next
)
2370 tail
= tail
->common_next
;
2373 /* Grab the list of symbols. */
2376 m
= gfc_match_symbol (&sym
, 0);
2377 if (m
== MATCH_ERROR
)
2382 if (sym
->attr
.in_common
)
2384 gfc_error ("Symbol '%s' at %C is already in a COMMON block",
2389 if (gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2392 if (sym
->value
!= NULL
2393 && (name
[0] == '\0' || !sym
->attr
.data
))
2395 if (name
[0] == '\0')
2396 gfc_error ("Previously initialized symbol '%s' in "
2397 "blank COMMON block at %C", sym
->name
);
2399 gfc_error ("Previously initialized symbol '%s' in "
2400 "COMMON block '%s' at %C", sym
->name
, name
);
2404 if (gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2407 /* Derived type names must have the SEQUENCE attribute. */
2408 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.derived
->attr
.sequence
)
2411 ("Derived type variable in COMMON at %C does not have the "
2412 "SEQUENCE attribute");
2417 tail
->common_next
= sym
;
2423 /* Deal with an optional array specification after the
2425 m
= gfc_match_array_spec (&as
);
2426 if (m
== MATCH_ERROR
)
2431 if (as
->type
!= AS_EXPLICIT
)
2434 ("Array specification for symbol '%s' in COMMON at %C "
2435 "must be explicit", sym
->name
);
2439 if (gfc_add_dimension (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2442 if (sym
->attr
.pointer
)
2445 ("Symbol '%s' in COMMON at %C cannot be a POINTER array",
2455 sym
->common_head
= t
;
2457 /* Check to see if the symbol is already in an equivalence group.
2458 If it is, set the other members as being in common. */
2459 if (sym
->attr
.in_equivalence
)
2461 for (e1
= gfc_current_ns
->equiv
; e1
; e1
= e1
->next
)
2463 for (e2
= e1
; e2
; e2
= e2
->eq
)
2464 if (e2
->expr
->symtree
->n
.sym
== sym
)
2471 for (e2
= e1
; e2
; e2
= e2
->eq
)
2473 other
= e2
->expr
->symtree
->n
.sym
;
2474 if (other
->common_head
2475 && other
->common_head
!= sym
->common_head
)
2477 gfc_error ("Symbol '%s', in COMMON block '%s' at "
2478 "%C is being indirectly equivalenced to "
2479 "another COMMON block '%s'",
2481 sym
->common_head
->name
,
2482 other
->common_head
->name
);
2485 other
->attr
.in_common
= 1;
2486 other
->common_head
= t
;
2492 gfc_gobble_whitespace ();
2493 if (gfc_match_eos () == MATCH_YES
)
2495 if (gfc_peek_char () == '/')
2497 if (gfc_match_char (',') != MATCH_YES
)
2499 gfc_gobble_whitespace ();
2500 if (gfc_peek_char () == '/')
2509 gfc_syntax_error (ST_COMMON
);
2512 if (old_blank_common
)
2513 old_blank_common
->common_next
= NULL
;
2515 gfc_current_ns
->blank_common
.head
= NULL
;
2516 gfc_free_array_spec (as
);
2521 /* Match a BLOCK DATA program unit. */
2524 gfc_match_block_data (void)
2526 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2530 if (gfc_match_eos () == MATCH_YES
)
2532 gfc_new_block
= NULL
;
2536 m
= gfc_match ("% %n%t", name
);
2540 if (gfc_get_symbol (name
, NULL
, &sym
))
2543 if (gfc_add_flavor (&sym
->attr
, FL_BLOCK_DATA
, sym
->name
, NULL
) == FAILURE
)
2546 gfc_new_block
= sym
;
2552 /* Free a namelist structure. */
2555 gfc_free_namelist (gfc_namelist
* name
)
2559 for (; name
; name
= n
)
2567 /* Match a NAMELIST statement. */
2570 gfc_match_namelist (void)
2572 gfc_symbol
*group_name
, *sym
;
2576 m
= gfc_match (" / %s /", &group_name
);
2579 if (m
== MATCH_ERROR
)
2584 if (group_name
->ts
.type
!= BT_UNKNOWN
)
2587 ("Namelist group name '%s' at %C already has a basic type "
2588 "of %s", group_name
->name
, gfc_typename (&group_name
->ts
));
2592 if (group_name
->attr
.flavor
== FL_NAMELIST
2593 && group_name
->attr
.use_assoc
2594 && gfc_notify_std (GFC_STD_GNU
, "Namelist group name '%s' "
2595 "at %C already is USE associated and can"
2596 "not be respecified.", group_name
->name
)
2600 if (group_name
->attr
.flavor
!= FL_NAMELIST
2601 && gfc_add_flavor (&group_name
->attr
, FL_NAMELIST
,
2602 group_name
->name
, NULL
) == FAILURE
)
2607 m
= gfc_match_symbol (&sym
, 1);
2610 if (m
== MATCH_ERROR
)
2613 if (sym
->attr
.in_namelist
== 0
2614 && gfc_add_in_namelist (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2617 /* Use gfc_error_check here, rather than goto error, so that this
2618 these are the only errors for the next two lines. */
2619 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SIZE
)
2621 gfc_error ("Assumed size array '%s' in namelist '%s' at "
2622 "%C is not allowed", sym
->name
, group_name
->name
);
2626 if (sym
->as
&& sym
->as
->type
== AS_ASSUMED_SHAPE
2627 && gfc_notify_std (GFC_STD_GNU
, "Assumed shape array '%s' in "
2628 "namelist '%s' at %C is an extension.",
2629 sym
->name
, group_name
->name
) == FAILURE
)
2632 nl
= gfc_get_namelist ();
2636 if (group_name
->namelist
== NULL
)
2637 group_name
->namelist
= group_name
->namelist_tail
= nl
;
2640 group_name
->namelist_tail
->next
= nl
;
2641 group_name
->namelist_tail
= nl
;
2644 if (gfc_match_eos () == MATCH_YES
)
2647 m
= gfc_match_char (',');
2649 if (gfc_match_char ('/') == MATCH_YES
)
2651 m2
= gfc_match (" %s /", &group_name
);
2652 if (m2
== MATCH_YES
)
2654 if (m2
== MATCH_ERROR
)
2668 gfc_syntax_error (ST_NAMELIST
);
2675 /* Match a MODULE statement. */
2678 gfc_match_module (void)
2682 m
= gfc_match (" %s%t", &gfc_new_block
);
2686 if (gfc_add_flavor (&gfc_new_block
->attr
, FL_MODULE
,
2687 gfc_new_block
->name
, NULL
) == FAILURE
)
2694 /* Free equivalence sets and lists. Recursively is the easiest way to
2698 gfc_free_equiv (gfc_equiv
* eq
)
2704 gfc_free_equiv (eq
->eq
);
2705 gfc_free_equiv (eq
->next
);
2707 gfc_free_expr (eq
->expr
);
2712 /* Match an EQUIVALENCE statement. */
2715 gfc_match_equivalence (void)
2717 gfc_equiv
*eq
, *set
, *tail
;
2721 gfc_common_head
*common_head
= NULL
;
2729 eq
= gfc_get_equiv ();
2733 eq
->next
= gfc_current_ns
->equiv
;
2734 gfc_current_ns
->equiv
= eq
;
2736 if (gfc_match_char ('(') != MATCH_YES
)
2740 common_flag
= FALSE
;
2745 m
= gfc_match_equiv_variable (&set
->expr
);
2746 if (m
== MATCH_ERROR
)
2751 /* count the number of objects. */
2754 if (gfc_match_char ('%') == MATCH_YES
)
2756 gfc_error ("Derived type component %C is not a "
2757 "permitted EQUIVALENCE member");
2761 for (ref
= set
->expr
->ref
; ref
; ref
= ref
->next
)
2762 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2765 ("Array reference in EQUIVALENCE at %C cannot be an "
2770 sym
= set
->expr
->symtree
->n
.sym
;
2772 if (gfc_add_in_equivalence (&sym
->attr
, sym
->name
, NULL
)
2776 if (sym
->attr
.in_common
)
2779 common_head
= sym
->common_head
;
2782 if (gfc_match_char (')') == MATCH_YES
)
2785 if (gfc_match_char (',') != MATCH_YES
)
2788 set
->eq
= gfc_get_equiv ();
2794 gfc_error ("EQUIVALENCE at %C requires two or more objects");
2798 /* If one of the members of an equivalence is in common, then
2799 mark them all as being in common. Before doing this, check
2800 that members of the equivalence group are not in different
2803 for (set
= eq
; set
; set
= set
->eq
)
2805 sym
= set
->expr
->symtree
->n
.sym
;
2806 if (sym
->common_head
&& sym
->common_head
!= common_head
)
2808 gfc_error ("Attempt to indirectly overlap COMMON "
2809 "blocks %s and %s by EQUIVALENCE at %C",
2810 sym
->common_head
->name
,
2814 sym
->attr
.in_common
= 1;
2815 sym
->common_head
= common_head
;
2818 if (gfc_match_eos () == MATCH_YES
)
2820 if (gfc_match_char (',') != MATCH_YES
)
2827 gfc_syntax_error (ST_EQUIVALENCE
);
2833 gfc_free_equiv (gfc_current_ns
->equiv
);
2834 gfc_current_ns
->equiv
= eq
;
2839 /* Check that a statement function is not recursive. This is done by looking
2840 for the statement function symbol(sym) by looking recursively through its
2841 expression(e). If a reference to sym is found, true is returned.
2842 12.5.4 requires that any variable of function that is implicitly typed
2843 shall have that type confirmed by any subsequent type declaration. The
2844 implicit typing is conveniently done here. */
2847 recursive_stmt_fcn (gfc_expr
*e
, gfc_symbol
*sym
)
2849 gfc_actual_arglist
*arg
;
2856 switch (e
->expr_type
)
2859 for (arg
= e
->value
.function
.actual
; arg
; arg
= arg
->next
)
2861 if (sym
->name
== arg
->name
2862 || recursive_stmt_fcn (arg
->expr
, sym
))
2866 if (e
->symtree
== NULL
)
2869 /* Check the name before testing for nested recursion! */
2870 if (sym
->name
== e
->symtree
->n
.sym
->name
)
2873 /* Catch recursion via other statement functions. */
2874 if (e
->symtree
->n
.sym
->attr
.proc
== PROC_ST_FUNCTION
2875 && e
->symtree
->n
.sym
->value
2876 && recursive_stmt_fcn (e
->symtree
->n
.sym
->value
, sym
))
2879 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
2880 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
2885 if (e
->symtree
&& sym
->name
== e
->symtree
->n
.sym
->name
)
2888 if (e
->symtree
->n
.sym
->ts
.type
== BT_UNKNOWN
)
2889 gfc_set_default_type (e
->symtree
->n
.sym
, 0, NULL
);
2893 if (recursive_stmt_fcn (e
->value
.op
.op1
, sym
)
2894 || recursive_stmt_fcn (e
->value
.op
.op2
, sym
))
2902 /* Component references do not need to be checked. */
2905 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
2910 for (i
= 0; i
< ref
->u
.ar
.dimen
; i
++)
2912 if (recursive_stmt_fcn (ref
->u
.ar
.start
[i
], sym
)
2913 || recursive_stmt_fcn (ref
->u
.ar
.end
[i
], sym
)
2914 || recursive_stmt_fcn (ref
->u
.ar
.stride
[i
], sym
))
2920 if (recursive_stmt_fcn (ref
->u
.ss
.start
, sym
)
2921 || recursive_stmt_fcn (ref
->u
.ss
.end
, sym
))
2935 /* Match a statement function declaration. It is so easy to match
2936 non-statement function statements with a MATCH_ERROR as opposed to
2937 MATCH_NO that we suppress error message in most cases. */
2940 gfc_match_st_function (void)
2942 gfc_error_buf old_error
;
2947 m
= gfc_match_symbol (&sym
, 0);
2951 gfc_push_error (&old_error
);
2953 if (gfc_add_procedure (&sym
->attr
, PROC_ST_FUNCTION
,
2954 sym
->name
, NULL
) == FAILURE
)
2957 if (gfc_match_formal_arglist (sym
, 1, 0) != MATCH_YES
)
2960 m
= gfc_match (" = %e%t", &expr
);
2964 gfc_free_error (&old_error
);
2965 if (m
== MATCH_ERROR
)
2968 if (recursive_stmt_fcn (expr
, sym
))
2970 gfc_error ("Statement function at %L is recursive",
2980 gfc_pop_error (&old_error
);
2985 /***************** SELECT CASE subroutines ******************/
2987 /* Free a single case structure. */
2990 free_case (gfc_case
* p
)
2992 if (p
->low
== p
->high
)
2994 gfc_free_expr (p
->low
);
2995 gfc_free_expr (p
->high
);
3000 /* Free a list of case structures. */
3003 gfc_free_case_list (gfc_case
* p
)
3015 /* Match a single case selector. */
3018 match_case_selector (gfc_case
** cp
)
3023 c
= gfc_get_case ();
3024 c
->where
= gfc_current_locus
;
3026 if (gfc_match_char (':') == MATCH_YES
)
3028 m
= gfc_match_init_expr (&c
->high
);
3031 if (m
== MATCH_ERROR
)
3037 m
= gfc_match_init_expr (&c
->low
);
3038 if (m
== MATCH_ERROR
)
3043 /* If we're not looking at a ':' now, make a range out of a single
3044 target. Else get the upper bound for the case range. */
3045 if (gfc_match_char (':') != MATCH_YES
)
3049 m
= gfc_match_init_expr (&c
->high
);
3050 if (m
== MATCH_ERROR
)
3052 /* MATCH_NO is fine. It's OK if nothing is there! */
3060 gfc_error ("Expected initialization expression in CASE at %C");
3068 /* Match the end of a case statement. */
3071 match_case_eos (void)
3073 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3076 if (gfc_match_eos () == MATCH_YES
)
3079 /* If the case construct doesn't have a case-construct-name, we
3080 should have matched the EOS. */
3081 if (!gfc_current_block ())
3083 gfc_error ("Expected the name of the select case construct at %C");
3087 gfc_gobble_whitespace ();
3089 m
= gfc_match_name (name
);
3093 if (strcmp (name
, gfc_current_block ()->name
) != 0)
3095 gfc_error ("Expected case name of '%s' at %C",
3096 gfc_current_block ()->name
);
3100 return gfc_match_eos ();
3104 /* Match a SELECT statement. */
3107 gfc_match_select (void)
3112 m
= gfc_match_label ();
3113 if (m
== MATCH_ERROR
)
3116 m
= gfc_match (" select case ( %e )%t", &expr
);
3120 new_st
.op
= EXEC_SELECT
;
3127 /* Match a CASE statement. */
3130 gfc_match_case (void)
3132 gfc_case
*c
, *head
, *tail
;
3137 if (gfc_current_state () != COMP_SELECT
)
3139 gfc_error ("Unexpected CASE statement at %C");
3143 if (gfc_match ("% default") == MATCH_YES
)
3145 m
= match_case_eos ();
3148 if (m
== MATCH_ERROR
)
3151 new_st
.op
= EXEC_SELECT
;
3152 c
= gfc_get_case ();
3153 c
->where
= gfc_current_locus
;
3154 new_st
.ext
.case_list
= c
;
3158 if (gfc_match_char ('(') != MATCH_YES
)
3163 if (match_case_selector (&c
) == MATCH_ERROR
)
3173 if (gfc_match_char (')') == MATCH_YES
)
3175 if (gfc_match_char (',') != MATCH_YES
)
3179 m
= match_case_eos ();
3182 if (m
== MATCH_ERROR
)
3185 new_st
.op
= EXEC_SELECT
;
3186 new_st
.ext
.case_list
= head
;
3191 gfc_error ("Syntax error in CASE-specification at %C");
3194 gfc_free_case_list (head
); /* new_st is cleaned up in parse.c. */
3198 /********************* WHERE subroutines ********************/
3200 /* Match the rest of a simple WHERE statement that follows an IF statement.
3204 match_simple_where (void)
3210 m
= gfc_match (" ( %e )", &expr
);
3214 m
= gfc_match_assignment ();
3217 if (m
== MATCH_ERROR
)
3220 if (gfc_match_eos () != MATCH_YES
)
3223 c
= gfc_get_code ();
3227 c
->next
= gfc_get_code ();
3230 gfc_clear_new_st ();
3232 new_st
.op
= EXEC_WHERE
;
3238 gfc_syntax_error (ST_WHERE
);
3241 gfc_free_expr (expr
);
3245 /* Match a WHERE statement. */
3248 gfc_match_where (gfc_statement
* st
)
3254 m0
= gfc_match_label ();
3255 if (m0
== MATCH_ERROR
)
3258 m
= gfc_match (" where ( %e )", &expr
);
3262 if (gfc_match_eos () == MATCH_YES
)
3264 *st
= ST_WHERE_BLOCK
;
3266 new_st
.op
= EXEC_WHERE
;
3271 m
= gfc_match_assignment ();
3273 gfc_syntax_error (ST_WHERE
);
3277 gfc_free_expr (expr
);
3281 /* We've got a simple WHERE statement. */
3283 c
= gfc_get_code ();
3287 c
->next
= gfc_get_code ();
3290 gfc_clear_new_st ();
3292 new_st
.op
= EXEC_WHERE
;
3299 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
3300 new_st if successful. */
3303 gfc_match_elsewhere (void)
3305 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3309 if (gfc_current_state () != COMP_WHERE
)
3311 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
3317 if (gfc_match_char ('(') == MATCH_YES
)
3319 m
= gfc_match_expr (&expr
);
3322 if (m
== MATCH_ERROR
)
3325 if (gfc_match_char (')') != MATCH_YES
)
3329 if (gfc_match_eos () != MATCH_YES
)
3330 { /* Better be a name at this point */
3331 m
= gfc_match_name (name
);
3334 if (m
== MATCH_ERROR
)
3337 if (gfc_match_eos () != MATCH_YES
)
3340 if (strcmp (name
, gfc_current_block ()->name
) != 0)
3342 gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
3343 name
, gfc_current_block ()->name
);
3348 new_st
.op
= EXEC_WHERE
;
3353 gfc_syntax_error (ST_ELSEWHERE
);
3356 gfc_free_expr (expr
);
3361 /******************** FORALL subroutines ********************/
3363 /* Free a list of FORALL iterators. */
3366 gfc_free_forall_iterator (gfc_forall_iterator
* iter
)
3368 gfc_forall_iterator
*next
;
3374 gfc_free_expr (iter
->var
);
3375 gfc_free_expr (iter
->start
);
3376 gfc_free_expr (iter
->end
);
3377 gfc_free_expr (iter
->stride
);
3385 /* Match an iterator as part of a FORALL statement. The format is:
3387 <var> = <start>:<end>[:<stride>][, <scalar mask>] */
3390 match_forall_iterator (gfc_forall_iterator
** result
)
3392 gfc_forall_iterator
*iter
;
3396 where
= gfc_current_locus
;
3397 iter
= gfc_getmem (sizeof (gfc_forall_iterator
));
3399 m
= gfc_match_variable (&iter
->var
, 0);
3403 if (gfc_match_char ('=') != MATCH_YES
)
3409 m
= gfc_match_expr (&iter
->start
);
3413 if (gfc_match_char (':') != MATCH_YES
)
3416 m
= gfc_match_expr (&iter
->end
);
3419 if (m
== MATCH_ERROR
)
3422 if (gfc_match_char (':') == MATCH_NO
)
3423 iter
->stride
= gfc_int_expr (1);
3426 m
= gfc_match_expr (&iter
->stride
);
3429 if (m
== MATCH_ERROR
)
3433 /* Mark the iteration variable's symbol as used as a FORALL index. */
3434 iter
->var
->symtree
->n
.sym
->forall_index
= true;
3440 gfc_error ("Syntax error in FORALL iterator at %C");
3444 /* Make sure that potential internal function references in the
3445 mask do not get messed up. */
3447 && iter
->var
->expr_type
== EXPR_VARIABLE
3448 && iter
->var
->symtree
->n
.sym
->refs
== 1)
3449 iter
->var
->symtree
->n
.sym
->attr
.flavor
= FL_UNKNOWN
;
3451 gfc_current_locus
= where
;
3452 gfc_free_forall_iterator (iter
);
3457 /* Match the header of a FORALL statement. */
3460 match_forall_header (gfc_forall_iterator
** phead
, gfc_expr
** mask
)
3462 gfc_forall_iterator
*head
, *tail
, *new;
3466 gfc_gobble_whitespace ();
3471 if (gfc_match_char ('(') != MATCH_YES
)
3474 m
= match_forall_iterator (&new);
3475 if (m
== MATCH_ERROR
)
3484 if (gfc_match_char (',') != MATCH_YES
)
3487 m
= match_forall_iterator (&new);
3488 if (m
== MATCH_ERROR
)
3498 /* Have to have a mask expression */
3500 m
= gfc_match_expr (&msk
);
3503 if (m
== MATCH_ERROR
)
3509 if (gfc_match_char (')') == MATCH_NO
)
3517 gfc_syntax_error (ST_FORALL
);
3520 gfc_free_expr (msk
);
3521 gfc_free_forall_iterator (head
);
3526 /* Match the rest of a simple FORALL statement that follows an IF statement.
3530 match_simple_forall (void)
3532 gfc_forall_iterator
*head
;
3541 m
= match_forall_header (&head
, &mask
);
3548 m
= gfc_match_assignment ();
3550 if (m
== MATCH_ERROR
)
3554 m
= gfc_match_pointer_assignment ();
3555 if (m
== MATCH_ERROR
)
3561 c
= gfc_get_code ();
3563 c
->loc
= gfc_current_locus
;
3565 if (gfc_match_eos () != MATCH_YES
)
3568 gfc_clear_new_st ();
3569 new_st
.op
= EXEC_FORALL
;
3571 new_st
.ext
.forall_iterator
= head
;
3572 new_st
.block
= gfc_get_code ();
3574 new_st
.block
->op
= EXEC_FORALL
;
3575 new_st
.block
->next
= c
;
3580 gfc_syntax_error (ST_FORALL
);
3583 gfc_free_forall_iterator (head
);
3584 gfc_free_expr (mask
);
3590 /* Match a FORALL statement. */
3593 gfc_match_forall (gfc_statement
* st
)
3595 gfc_forall_iterator
*head
;
3604 m0
= gfc_match_label ();
3605 if (m0
== MATCH_ERROR
)
3608 m
= gfc_match (" forall");
3612 m
= match_forall_header (&head
, &mask
);
3613 if (m
== MATCH_ERROR
)
3618 if (gfc_match_eos () == MATCH_YES
)
3620 *st
= ST_FORALL_BLOCK
;
3622 new_st
.op
= EXEC_FORALL
;
3624 new_st
.ext
.forall_iterator
= head
;
3629 m
= gfc_match_assignment ();
3630 if (m
== MATCH_ERROR
)
3634 m
= gfc_match_pointer_assignment ();
3635 if (m
== MATCH_ERROR
)
3641 c
= gfc_get_code ();
3643 c
->loc
= gfc_current_locus
;
3645 gfc_clear_new_st ();
3646 new_st
.op
= EXEC_FORALL
;
3648 new_st
.ext
.forall_iterator
= head
;
3649 new_st
.block
= gfc_get_code ();
3651 new_st
.block
->op
= EXEC_FORALL
;
3652 new_st
.block
->next
= c
;
3658 gfc_syntax_error (ST_FORALL
);
3661 gfc_free_forall_iterator (head
);
3662 gfc_free_expr (mask
);
3663 gfc_free_statements (c
);