2 Copyright (C) 2000, 2001, 2002, 2003, 2004 Free Software Foundation,
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, 59 Temple Place - Suite 330, Boston, MA
32 /* Current statement label. Zero means no statement label. Because
33 new_st can get wiped during statement matching, we have to keep it
36 gfc_st_label
*gfc_statement_label
;
38 static locus label_locus
;
41 gfc_state_data
*gfc_state_stack
;
43 /* TODO: Re-order functions to kill these forward decls. */
44 static void check_statement_label (gfc_statement
);
45 static void undo_new_statement (void);
46 static void reject_statement (void);
48 /* A sort of half-matching function. We try to match the word on the
49 input with the passed string. If this succeeds, we call the
50 keyword-dependent matching function that will match the rest of the
51 statement. For single keywords, the matching subroutine is
55 match_word (const char *str
, match (*subr
) (void), locus
* old_locus
)
70 gfc_current_locus
= *old_locus
;
78 /* Figure out what the next statement is, (mostly) regardless of
81 #define match(keyword, subr, st) \
82 if (match_word(keyword, subr, &old_locus) == MATCH_YES) \
85 undo_new_statement ();
88 decode_statement (void)
99 gfc_clear_error (); /* Clear any pending errors. */
100 gfc_clear_warning (); /* Clear any pending warnings. */
102 if (gfc_match_eos () == MATCH_YES
)
105 old_locus
= gfc_current_locus
;
107 /* Try matching a data declaration or function declaration. The
108 input "REALFUNCTIONA(N)" can mean several things in different
109 contexts, so it (and its relatives) get special treatment. */
111 if (gfc_current_state () == COMP_NONE
112 || gfc_current_state () == COMP_INTERFACE
113 || gfc_current_state () == COMP_CONTAINS
)
115 m
= gfc_match_function_decl ();
118 else if (m
== MATCH_ERROR
)
122 gfc_current_locus
= old_locus
;
125 /* Match statements whose error messages are meant to be overwritten
126 by something better. */
128 match (NULL
, gfc_match_assignment
, ST_ASSIGNMENT
);
129 match (NULL
, gfc_match_pointer_assignment
, ST_POINTER_ASSIGNMENT
);
130 match (NULL
, gfc_match_st_function
, ST_STATEMENT_FUNCTION
);
132 match (NULL
, gfc_match_data_decl
, ST_DATA_DECL
);
134 /* Try to match a subroutine statement, which has the same optional
135 prefixes that functions can have. */
137 if (gfc_match_subroutine () == MATCH_YES
)
138 return ST_SUBROUTINE
;
140 gfc_current_locus
= old_locus
;
142 /* Check for the IF, DO, SELECT, WHERE and FORALL statements, which
143 might begin with a block label. The match functions for these
144 statements are unusual in that their keyword is not seen before
145 the matcher is called. */
147 if (gfc_match_if (&st
) == MATCH_YES
)
150 gfc_current_locus
= old_locus
;
152 if (gfc_match_where (&st
) == MATCH_YES
)
155 gfc_current_locus
= old_locus
;
157 if (gfc_match_forall (&st
) == MATCH_YES
)
160 gfc_current_locus
= old_locus
;
162 match (NULL
, gfc_match_do
, ST_DO
);
163 match (NULL
, gfc_match_select
, ST_SELECT_CASE
);
165 /* General statement matching: Instead of testing every possible
166 statement, we eliminate most possibilities by peeking at the
169 c
= gfc_peek_char ();
174 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
);
175 match ("allocatable", gfc_match_allocatable
, ST_ATTR_DECL
);
176 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
);
180 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
);
181 match ("block data", gfc_match_block_data
, ST_BLOCK_DATA
);
185 match ("call", gfc_match_call
, ST_CALL
);
186 match ("close", gfc_match_close
, ST_CLOSE
);
187 match ("continue", gfc_match_continue
, ST_CONTINUE
);
188 match ("cycle", gfc_match_cycle
, ST_CYCLE
);
189 match ("case", gfc_match_case
, ST_CASE
);
190 match ("common", gfc_match_common
, ST_COMMON
);
191 match ("contains", gfc_match_eos
, ST_CONTAINS
);
195 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
);
196 match ("data", gfc_match_data
, ST_DATA
);
197 match ("dimension", gfc_match_dimension
, ST_ATTR_DECL
);
201 match ("end file", gfc_match_endfile
, ST_END_FILE
);
202 match ("exit", gfc_match_exit
, ST_EXIT
);
203 match ("else", gfc_match_else
, ST_ELSE
);
204 match ("else where", gfc_match_elsewhere
, ST_ELSEWHERE
);
205 match ("else if", gfc_match_elseif
, ST_ELSEIF
);
207 if (gfc_match_end (&st
) == MATCH_YES
)
210 match ("entry% ", gfc_match_entry
, ST_ENTRY
);
211 match ("equivalence", gfc_match_equivalence
, ST_EQUIVALENCE
);
212 match ("external", gfc_match_external
, ST_ATTR_DECL
);
216 match ("format", gfc_match_format
, ST_FORMAT
);
220 match ("go to", gfc_match_goto
, ST_GOTO
);
224 match ("inquire", gfc_match_inquire
, ST_INQUIRE
);
225 match ("implicit", gfc_match_implicit
, ST_IMPLICIT
);
226 match ("implicit% none", gfc_match_implicit_none
, ST_IMPLICIT_NONE
);
227 match ("interface", gfc_match_interface
, ST_INTERFACE
);
228 match ("intent", gfc_match_intent
, ST_ATTR_DECL
);
229 match ("intrinsic", gfc_match_intrinsic
, ST_ATTR_DECL
);
233 match ("module% procedure% ", gfc_match_modproc
, ST_MODULE_PROC
);
234 match ("module", gfc_match_module
, ST_MODULE
);
238 match ("nullify", gfc_match_nullify
, ST_NULLIFY
);
239 match ("namelist", gfc_match_namelist
, ST_NAMELIST
);
243 match ("open", gfc_match_open
, ST_OPEN
);
244 match ("optional", gfc_match_optional
, ST_ATTR_DECL
);
248 match ("print", gfc_match_print
, ST_WRITE
);
249 match ("parameter", gfc_match_parameter
, ST_PARAMETER
);
250 match ("pause", gfc_match_pause
, ST_PAUSE
);
251 match ("pointer", gfc_match_pointer
, ST_ATTR_DECL
);
252 if (gfc_match_private (&st
) == MATCH_YES
)
254 match ("program", gfc_match_program
, ST_PROGRAM
);
255 if (gfc_match_public (&st
) == MATCH_YES
)
260 match ("read", gfc_match_read
, ST_READ
);
261 match ("return", gfc_match_return
, ST_RETURN
);
262 match ("rewind", gfc_match_rewind
, ST_REWIND
);
266 match ("sequence", gfc_match_eos
, ST_SEQUENCE
);
267 match ("stop", gfc_match_stop
, ST_STOP
);
268 match ("save", gfc_match_save
, ST_ATTR_DECL
);
272 match ("target", gfc_match_target
, ST_ATTR_DECL
);
273 match ("type", gfc_match_derived_decl
, ST_DERIVED_DECL
);
277 match ("use% ", gfc_match_use
, ST_USE
);
281 match ("write", gfc_match_write
, ST_WRITE
);
285 /* All else has failed, so give up. See if any of the matchers has
286 stored an error message of some sort. */
288 if (gfc_error_check () == 0)
289 gfc_error_now ("Unclassifiable statement at %C");
293 gfc_error_recovery ();
301 /* Get the next statement in free form source. */
309 gfc_gobble_whitespace ();
311 c
= gfc_peek_char ();
315 /* Found a statement label? */
316 m
= gfc_match_st_label (&gfc_statement_label
, 0);
318 d
= gfc_peek_char ();
319 if (m
!= MATCH_YES
|| !gfc_is_whitespace (d
))
323 /* Skip the bad statement label. */
324 gfc_warning_now ("Ignoring bad statement label at %C");
325 c
= gfc_next_char ();
331 label_locus
= gfc_current_locus
;
333 if (gfc_statement_label
->value
== 0)
335 gfc_warning_now ("Ignoring statement label of zero at %C");
336 gfc_free_st_label (gfc_statement_label
);
337 gfc_statement_label
= NULL
;
340 gfc_gobble_whitespace ();
342 if (gfc_match_eos () == MATCH_YES
)
345 ("Ignoring statement label in empty statement at %C");
346 gfc_free_st_label (gfc_statement_label
);
347 gfc_statement_label
= NULL
;
353 return decode_statement ();
357 /* Get the next statement in fixed-form source. */
362 int label
, digit_flag
, i
;
367 return decode_statement ();
369 /* Skip past the current label field, parsing a statement label if
370 one is there. This is a weird number parser, since the number is
371 contained within five columns and can have any kind of embedded
372 spaces. We also check for characters that make the rest of the
378 for (i
= 0; i
< 5; i
++)
380 c
= gfc_next_char_literal (0);
397 label
= label
* 10 + c
- '0';
398 label_locus
= gfc_current_locus
;
402 /* Comments have already been skipped by the time we get
403 here so don't bother checking for them. */
406 gfc_buffer_error (0);
407 gfc_error ("Non-numeric character in statement label at %C");
415 gfc_warning_now ("Zero is not a valid statement label at %C");
418 /* We've found a valid statement label. */
419 gfc_statement_label
= gfc_get_st_label (label
);
423 /* Since this line starts a statement, it cannot be a continuation
424 of a previous statement. If we see something here besides a
425 space or zero, it must be a bad continuation line. */
427 c
= gfc_next_char_literal (0);
431 if (c
!= ' ' && c
!= '0')
433 gfc_buffer_error (0);
434 gfc_error ("Bad continuation line at %C");
438 /* Now that we've taken care of the statement label columns, we have
439 to make sure that the first nonblank character is not a '!'. If
440 it is, the rest of the line is a comment. */
444 loc
= gfc_current_locus
;
445 c
= gfc_next_char_literal (0);
447 while (gfc_is_whitespace (c
));
451 gfc_current_locus
= loc
;
453 if (gfc_match_eos () == MATCH_YES
)
456 /* At this point, we've got a nonblank statement to parse. */
457 return decode_statement ();
461 gfc_warning ("Statement label in blank line will be " "ignored at %C");
467 /* Return the next non-ST_NONE statement to the caller. We also worry
468 about including files and the ends of include files at this stage. */
471 next_statement (void)
475 gfc_new_block
= NULL
;
479 gfc_statement_label
= NULL
;
480 gfc_buffer_error (1);
485 gfc_skip_comments ();
494 (gfc_current_form
== FORM_FIXED
) ? next_fixed () : next_free ();
500 gfc_buffer_error (0);
503 check_statement_label (st
);
509 /****************************** Parser ***********************************/
511 /* The parser subroutines are of type 'try' that fail if the file ends
514 /* Macros that expand to case-labels for various classes of
515 statements. Start with executable statements that directly do
518 #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
519 case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
520 case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
521 case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
522 case ST_PAUSE: case ST_STOP: case ST_WRITE: case ST_ASSIGNMENT: \
523 case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
524 case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: case ST_LABEL_ASSIGNMENT
526 /* Statements that mark other executable statements. */
528 #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: case ST_IF_BLOCK: \
529 case ST_WHERE_BLOCK: case ST_SELECT_CASE
531 /* Declaration statements */
533 #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
534 case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
535 case ST_TYPE: case ST_INTERFACE
537 /* Block end statements. Errors associated with interchanging these
538 are detected in gfc_match_end(). */
540 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
541 case ST_END_PROGRAM: case ST_END_SUBROUTINE
544 /* Push a new state onto the stack. */
547 push_state (gfc_state_data
* p
, gfc_compile_state new_state
, gfc_symbol
* sym
)
550 p
->state
= new_state
;
551 p
->previous
= gfc_state_stack
;
553 p
->head
= p
->tail
= NULL
;
554 p
->do_variable
= NULL
;
560 /* Pop the current state. */
566 gfc_state_stack
= gfc_state_stack
->previous
;
570 /* Try to find the given state in the state stack. */
573 gfc_find_state (gfc_compile_state state
)
577 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
578 if (p
->state
== state
)
581 return (p
== NULL
) ? FAILURE
: SUCCESS
;
585 /* Starts a new level in the statement list. */
588 new_level (gfc_code
* q
)
592 p
= q
->block
= gfc_get_code ();
594 gfc_state_stack
->head
= gfc_state_stack
->tail
= p
;
600 /* Add the current new_st code structure and adds it to the current
601 program unit. As a side-effect, it zeroes the new_st. */
611 p
->loc
= gfc_current_locus
;
613 if (gfc_state_stack
->head
== NULL
)
614 gfc_state_stack
->head
= p
;
616 gfc_state_stack
->tail
->next
= p
;
618 while (p
->next
!= NULL
)
621 gfc_state_stack
->tail
= p
;
629 /* Frees everything associated with the current statement. */
632 undo_new_statement (void)
634 gfc_free_statements (new_st
.block
);
635 gfc_free_statements (new_st
.next
);
636 gfc_free_statement (&new_st
);
641 /* If the current statement has a statement label, make sure that it
642 is allowed to, or should have one. */
645 check_statement_label (gfc_statement st
)
649 if (gfc_statement_label
== NULL
)
652 gfc_error ("FORMAT statement at %L does not have a statement label",
660 case ST_END_FUNCTION
:
661 case ST_END_SUBROUTINE
:
667 type
= ST_LABEL_TARGET
;
671 type
= ST_LABEL_FORMAT
;
674 /* Statement labels are not restricted from appearing on a
675 particular line. However, there are plenty of situations
676 where the resulting label can't be referenced. */
679 type
= ST_LABEL_BAD_TARGET
;
683 gfc_define_st_label (gfc_statement_label
, type
, &label_locus
);
685 new_st
.here
= gfc_statement_label
;
689 /* Figures out what the enclosing program unit is. This will be a
690 function, subroutine, program, block data or module. */
693 gfc_enclosing_unit (gfc_compile_state
* result
)
697 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
698 if (p
->state
== COMP_FUNCTION
|| p
->state
== COMP_SUBROUTINE
699 || p
->state
== COMP_MODULE
|| p
->state
== COMP_BLOCK_DATA
700 || p
->state
== COMP_PROGRAM
)
709 *result
= COMP_PROGRAM
;
714 /* Translate a statement enum to a string. */
717 gfc_ascii_statement (gfc_statement st
)
723 case ST_ARITHMETIC_IF
:
730 p
= "attribute declaration";
760 p
= "data declaration";
768 case ST_DERIVED_DECL
:
769 p
= "Derived type declaration";
783 case ST_END_BLOCK_DATA
:
784 p
= "END BLOCK DATA";
795 case ST_END_FUNCTION
:
801 case ST_END_INTERFACE
:
813 case ST_END_SUBROUTINE
:
814 p
= "END SUBROUTINE";
831 case ST_FORALL_BLOCK
: /* Fall through */
850 case ST_IMPLICIT_NONE
:
853 case ST_IMPLIED_ENDDO
:
854 p
= "implied END DO";
878 p
= "MODULE PROCEDURE";
913 case ST_WHERE_BLOCK
: /* Fall through */
923 case ST_POINTER_ASSIGNMENT
:
924 p
= "pointer assignment";
935 case ST_STATEMENT_FUNCTION
:
936 p
= "STATEMENT FUNCTION";
938 case ST_LABEL_ASSIGNMENT
:
939 p
= "LABEL ASSIGNMENT";
942 gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
949 /* Return the name of a compile state. */
952 gfc_state_name (gfc_compile_state state
)
964 case COMP_SUBROUTINE
:
970 case COMP_BLOCK_DATA
:
977 p
= "a DERIVED TYPE block";
980 p
= "an IF-THEN block";
986 p
= "a SELECT block";
989 p
= "a FORALL block";
995 p
= "a contained subprogram";
999 gfc_internal_error ("gfc_state_name(): Bad state");
1006 /* Do whatever is necessary to accept the last statement. */
1009 accept_statement (gfc_statement st
)
1018 case ST_IMPLICIT_NONE
:
1019 gfc_set_implicit_none ();
1028 gfc_current_ns
->proc_name
= gfc_new_block
;
1031 /* If the statement is the end of a block, lay down a special code
1032 that allows a branch to the end of the block from within the
1038 if (gfc_statement_label
!= NULL
)
1040 new_st
.op
= EXEC_NOP
;
1046 /* The end-of-program unit statements do not get the special
1047 marker and require a statement of some sort if they are a
1050 case ST_END_PROGRAM
:
1051 case ST_END_FUNCTION
:
1052 case ST_END_SUBROUTINE
:
1053 if (gfc_statement_label
!= NULL
)
1055 new_st
.op
= EXEC_RETURN
;
1063 gfc_symbol
*block_data
= NULL
;
1064 symbol_attribute attr
;
1066 gfc_get_symbol ("_BLOCK_DATA__", gfc_current_ns
, &block_data
);
1067 gfc_clear_attr (&attr
);
1068 attr
.flavor
= FL_PROCEDURE
;
1069 attr
.proc
= PROC_UNKNOWN
;
1070 attr
.subroutine
= 1;
1071 attr
.access
= ACCESS_PUBLIC
;
1072 block_data
->attr
= attr
;
1073 gfc_current_ns
->proc_name
= block_data
;
1074 gfc_commit_symbols ();
1088 gfc_commit_symbols ();
1089 gfc_warning_check ();
1090 gfc_clear_new_st ();
1094 /* Undo anything tentative that has been built for the current
1098 reject_statement (void)
1101 gfc_undo_symbols ();
1102 gfc_clear_warning ();
1103 undo_new_statement ();
1107 /* Generic complaint about an out of order statement. We also do
1108 whatever is necessary to clean up. */
1111 unexpected_statement (gfc_statement st
)
1114 gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st
));
1116 reject_statement ();
1120 /* Given the next statement seen by the matcher, make sure that it is
1121 in proper order with the last. This subroutine is initialized by
1122 calling it with an argument of ST_NONE. If there is a problem, we
1123 issue an error and return FAILURE. Otherwise we return SUCCESS.
1125 Individual parsers need to verify that the statements seen are
1126 valid before calling here, ie ENTRY statements are not allowed in
1127 INTERFACE blocks. The following diagram is taken from the standard:
1129 +---------------------------------------+
1130 | program subroutine function module |
1131 +---------------------------------------+
1133 |---------------------------------------+
1135 | +-----------+------------------+
1136 | | parameter | implicit |
1137 | +-----------+------------------+
1138 | format | | derived type |
1139 | entry | parameter | interface |
1140 | | data | specification |
1141 | | | statement func |
1142 | +-----------+------------------+
1143 | | data | executable |
1144 +--------+-----------+------------------+
1146 +---------------------------------------+
1147 | internal module/subprogram |
1148 +---------------------------------------+
1150 +---------------------------------------+
1157 { ORDER_START
, ORDER_USE
, ORDER_IMPLICIT_NONE
, ORDER_IMPLICIT
,
1158 ORDER_SPEC
, ORDER_EXEC
1161 gfc_statement last_statement
;
1167 verify_st_order (st_state
* p
, gfc_statement st
)
1173 p
->state
= ORDER_START
;
1177 if (p
->state
> ORDER_USE
)
1179 p
->state
= ORDER_USE
;
1182 case ST_IMPLICIT_NONE
:
1183 if (p
->state
> ORDER_IMPLICIT_NONE
)
1186 /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
1187 statement disqualifies a USE but not an IMPLICIT NONE.
1188 Duplicate IMPLICIT NONEs are caught when the implicit types
1191 p
->state
= ORDER_IMPLICIT_NONE
;
1195 if (p
->state
> ORDER_IMPLICIT
)
1197 p
->state
= ORDER_IMPLICIT
;
1202 if (p
->state
< ORDER_IMPLICIT_NONE
)
1203 p
->state
= ORDER_IMPLICIT_NONE
;
1207 if (p
->state
>= ORDER_EXEC
)
1209 if (p
->state
< ORDER_IMPLICIT
)
1210 p
->state
= ORDER_IMPLICIT
;
1214 if (p
->state
< ORDER_SPEC
)
1215 p
->state
= ORDER_SPEC
;
1220 case ST_DERIVED_DECL
:
1222 if (p
->state
>= ORDER_EXEC
)
1224 if (p
->state
< ORDER_SPEC
)
1225 p
->state
= ORDER_SPEC
;
1230 if (p
->state
< ORDER_EXEC
)
1231 p
->state
= ORDER_EXEC
;
1236 ("Unexpected %s statement in verify_st_order() at %C",
1237 gfc_ascii_statement (st
));
1240 /* All is well, record the statement in case we need it next time. */
1241 p
->where
= gfc_current_locus
;
1242 p
->last_statement
= st
;
1246 gfc_error ("%s statement at %C cannot follow %s statement at %L",
1247 gfc_ascii_statement (st
),
1248 gfc_ascii_statement (p
->last_statement
), &p
->where
);
1254 /* Handle an unexpected end of file. This is a show-stopper... */
1256 static void unexpected_eof (void) ATTRIBUTE_NORETURN
;
1259 unexpected_eof (void)
1263 gfc_error ("Unexpected end of file in '%s'", gfc_source_file
);
1265 /* Memory cleanup. Move to "second to last". */
1266 for (p
= gfc_state_stack
; p
&& p
->previous
&& p
->previous
->previous
;
1269 gfc_current_ns
->code
= (p
&& p
->previous
) ? p
->head
: NULL
;
1276 /* Parse a derived type. */
1279 parse_derived (void)
1281 int compiling_type
, seen_private
, seen_sequence
, seen_component
, error_flag
;
1288 accept_statement (ST_DERIVED_DECL
);
1289 push_state (&s
, COMP_DERIVED
, gfc_new_block
);
1291 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
1298 while (compiling_type
)
1300 st
= next_statement ();
1307 accept_statement (st
);
1314 if (!seen_component
)
1316 gfc_error ("Derived type definition at %C has no components");
1320 accept_statement (ST_END_TYPE
);
1324 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
1327 ("PRIVATE statement in TYPE at %C must be inside a MODULE");
1334 gfc_error ("PRIVATE statement at %C must precede "
1335 "structure components");
1342 gfc_error ("Duplicate PRIVATE statement at %C");
1346 s
.sym
->component_access
= ACCESS_PRIVATE
;
1347 accept_statement (ST_PRIVATE
);
1354 gfc_error ("SEQUENCE statement at %C must precede "
1355 "structure components");
1360 if (gfc_current_block ()->attr
.sequence
)
1361 gfc_warning ("SEQUENCE attribute at %C already specified in "
1366 gfc_error ("Duplicate SEQUENCE statement at %C");
1371 gfc_add_sequence (&gfc_current_block ()->attr
, NULL
);
1375 unexpected_statement (st
);
1380 /* Sanity checks on the structure. If the structure has the
1381 SEQUENCE attribute, then all component structures must also have
1383 if (error_flag
== 0 && gfc_current_block ()->attr
.sequence
)
1384 for (c
= gfc_current_block ()->components
; c
; c
= c
->next
)
1386 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.derived
->attr
.sequence
== 0)
1389 ("Component %s of SEQUENCE type declared at %C does not "
1390 "have the SEQUENCE attribute", c
->ts
.derived
->name
);
1399 /* Parse an interface. We must be able to deal with the possibility
1400 of recursive interfaces. The parse_spec() subroutine is mutually
1401 recursive with parse_interface(). */
1403 static gfc_statement
parse_spec (gfc_statement
);
1406 parse_interface (void)
1408 gfc_compile_state new_state
, current_state
;
1409 gfc_symbol
*prog_unit
, *sym
;
1410 gfc_interface_info save
;
1411 gfc_state_data s1
, s2
;
1414 accept_statement (ST_INTERFACE
);
1416 current_interface
.ns
= gfc_current_ns
;
1417 save
= current_interface
;
1419 sym
= (current_interface
.type
== INTERFACE_GENERIC
1420 || current_interface
.type
== INTERFACE_USER_OP
) ? gfc_new_block
: NULL
;
1422 push_state (&s1
, COMP_INTERFACE
, sym
);
1423 current_state
= COMP_NONE
;
1426 gfc_current_ns
= gfc_get_namespace (current_interface
.ns
);
1428 st
= next_statement ();
1435 new_state
= COMP_SUBROUTINE
;
1436 gfc_add_explicit_interface (gfc_new_block
, IFSRC_IFBODY
,
1437 gfc_new_block
->formal
, NULL
);
1441 new_state
= COMP_FUNCTION
;
1442 gfc_add_explicit_interface (gfc_new_block
, IFSRC_IFBODY
,
1443 gfc_new_block
->formal
, NULL
);
1446 case ST_MODULE_PROC
: /* The module procedure matcher makes
1447 sure the context is correct. */
1448 accept_statement (st
);
1449 gfc_free_namespace (gfc_current_ns
);
1452 case ST_END_INTERFACE
:
1453 gfc_free_namespace (gfc_current_ns
);
1454 gfc_current_ns
= current_interface
.ns
;
1458 gfc_error ("Unexpected %s statement in INTERFACE block at %C",
1459 gfc_ascii_statement (st
));
1460 reject_statement ();
1461 gfc_free_namespace (gfc_current_ns
);
1466 /* Make sure that a generic interface has only subroutines or
1467 functions and that the generic name has the right attribute. */
1468 if (current_interface
.type
== INTERFACE_GENERIC
)
1470 if (current_state
== COMP_NONE
)
1472 if (new_state
== COMP_FUNCTION
)
1473 gfc_add_function (&sym
->attr
, NULL
);
1474 if (new_state
== COMP_SUBROUTINE
)
1475 gfc_add_subroutine (&sym
->attr
, NULL
);
1477 current_state
= new_state
;
1481 if (new_state
!= current_state
)
1483 if (new_state
== COMP_SUBROUTINE
)
1485 ("SUBROUTINE at %C does not belong in a generic function "
1488 if (new_state
== COMP_FUNCTION
)
1490 ("FUNCTION at %C does not belong in a generic subroutine "
1496 push_state (&s2
, new_state
, gfc_new_block
);
1497 accept_statement (st
);
1498 prog_unit
= gfc_new_block
;
1499 prog_unit
->formal_ns
= gfc_current_ns
;
1502 /* Read data declaration statements. */
1503 st
= parse_spec (ST_NONE
);
1505 if (st
!= ST_END_SUBROUTINE
&& st
!= ST_END_FUNCTION
)
1507 gfc_error ("Unexpected %s statement at %C in INTERFACE body",
1508 gfc_ascii_statement (st
));
1509 reject_statement ();
1513 current_interface
= save
;
1514 gfc_add_interface (prog_unit
);
1524 /* Parse a set of specification statements. Returns the statement
1525 that doesn't fit. */
1527 static gfc_statement
1528 parse_spec (gfc_statement st
)
1532 verify_st_order (&ss
, ST_NONE
);
1534 st
= next_statement ();
1544 case ST_DATA
: /* Not allowed in interfaces */
1545 if (gfc_current_state () == COMP_INTERFACE
)
1551 case ST_IMPLICIT_NONE
:
1556 case ST_DERIVED_DECL
:
1558 if (verify_st_order (&ss
, st
) == FAILURE
)
1560 reject_statement ();
1561 st
= next_statement ();
1571 case ST_DERIVED_DECL
:
1577 if (gfc_current_state () != COMP_MODULE
)
1579 gfc_error ("%s statement must appear in a MODULE",
1580 gfc_ascii_statement (st
));
1584 if (gfc_current_ns
->default_access
!= ACCESS_UNKNOWN
)
1586 gfc_error ("%s statement at %C follows another accessibility "
1587 "specification", gfc_ascii_statement (st
));
1591 gfc_current_ns
->default_access
= (st
== ST_PUBLIC
)
1592 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
1600 accept_statement (st
);
1601 st
= next_statement ();
1612 /* Parse a WHERE block, (not a simple WHERE statement). */
1615 parse_where_block (void)
1617 int seen_empty_else
;
1622 accept_statement (ST_WHERE_BLOCK
);
1623 top
= gfc_state_stack
->tail
;
1625 push_state (&s
, COMP_WHERE
, gfc_new_block
);
1627 d
= add_statement ();
1628 d
->expr
= top
->expr
;
1634 seen_empty_else
= 0;
1638 st
= next_statement ();
1644 case ST_WHERE_BLOCK
:
1645 parse_where_block ();
1650 accept_statement (st
);
1654 if (seen_empty_else
)
1657 ("ELSEWHERE statement at %C follows previous unmasked "
1662 if (new_st
.expr
== NULL
)
1663 seen_empty_else
= 1;
1665 d
= new_level (gfc_state_stack
->head
);
1667 d
->expr
= new_st
.expr
;
1669 accept_statement (st
);
1674 accept_statement (st
);
1678 gfc_error ("Unexpected %s statement in WHERE block at %C",
1679 gfc_ascii_statement (st
));
1680 reject_statement ();
1685 while (st
!= ST_END_WHERE
);
1691 /* Parse a FORALL block (not a simple FORALL statement). */
1694 parse_forall_block (void)
1700 accept_statement (ST_FORALL_BLOCK
);
1701 top
= gfc_state_stack
->tail
;
1703 push_state (&s
, COMP_FORALL
, gfc_new_block
);
1705 d
= add_statement ();
1706 d
->op
= EXEC_FORALL
;
1711 st
= next_statement ();
1716 case ST_POINTER_ASSIGNMENT
:
1719 accept_statement (st
);
1722 case ST_WHERE_BLOCK
:
1723 parse_where_block ();
1726 case ST_FORALL_BLOCK
:
1727 parse_forall_block ();
1731 accept_statement (st
);
1738 gfc_error ("Unexpected %s statement in FORALL block at %C",
1739 gfc_ascii_statement (st
));
1741 reject_statement ();
1745 while (st
!= ST_END_FORALL
);
1751 static gfc_statement
parse_executable (gfc_statement
);
1753 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
1756 parse_if_block (void)
1765 accept_statement (ST_IF_BLOCK
);
1767 top
= gfc_state_stack
->tail
;
1768 push_state (&s
, COMP_IF
, gfc_new_block
);
1770 new_st
.op
= EXEC_IF
;
1771 d
= add_statement ();
1773 d
->expr
= top
->expr
;
1779 st
= parse_executable (ST_NONE
);
1790 ("ELSE IF statement at %C cannot follow ELSE statement at %L",
1793 reject_statement ();
1797 d
= new_level (gfc_state_stack
->head
);
1799 d
->expr
= new_st
.expr
;
1801 accept_statement (st
);
1808 gfc_error ("Duplicate ELSE statements at %L and %C",
1810 reject_statement ();
1815 else_locus
= gfc_current_locus
;
1817 d
= new_level (gfc_state_stack
->head
);
1820 accept_statement (st
);
1828 unexpected_statement (st
);
1832 while (st
!= ST_ENDIF
);
1835 accept_statement (st
);
1839 /* Parse a SELECT block. */
1842 parse_select_block (void)
1848 accept_statement (ST_SELECT_CASE
);
1850 cp
= gfc_state_stack
->tail
;
1851 push_state (&s
, COMP_SELECT
, gfc_new_block
);
1853 /* Make sure that the next statement is a CASE or END SELECT. */
1856 st
= next_statement ();
1859 if (st
== ST_END_SELECT
)
1861 /* Empty SELECT CASE is OK. */
1862 accept_statement (st
);
1870 ("Expected a CASE or END SELECT statement following SELECT CASE "
1873 reject_statement ();
1876 /* At this point, we're got a nonempty select block. */
1877 cp
= new_level (cp
);
1880 accept_statement (st
);
1884 st
= parse_executable (ST_NONE
);
1891 cp
= new_level (gfc_state_stack
->head
);
1893 gfc_clear_new_st ();
1895 accept_statement (st
);
1901 /* Can't have an executable statement because of
1902 parse_executable(). */
1904 unexpected_statement (st
);
1908 while (st
!= ST_END_SELECT
);
1911 accept_statement (st
);
1915 /* Given a symbol, make sure it is not an iteration variable for a DO
1916 statement. This subroutine is called when the symbol is seen in a
1917 context that causes it to become redefined. If the symbol is an
1918 iterator, we generate an error message and return nonzero. */
1921 gfc_check_do_variable (gfc_symtree
*st
)
1925 for (s
=gfc_state_stack
; s
; s
= s
->previous
)
1926 if (s
->do_variable
== st
)
1928 gfc_error_now("Variable '%s' at %C cannot be redefined inside "
1929 "loop beginning at %L", st
->name
, &s
->head
->loc
);
1937 /* Checks to see if the current statement label closes an enddo.
1938 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
1939 an error) if it incorrectly closes an ENDDO. */
1942 check_do_closure (void)
1946 if (gfc_statement_label
== NULL
)
1949 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1950 if (p
->state
== COMP_DO
)
1954 return 0; /* No loops to close */
1956 if (p
->ext
.end_do_label
== gfc_statement_label
)
1959 if (p
== gfc_state_stack
)
1963 ("End of nonblock DO statement at %C is within another block");
1967 /* At this point, the label doesn't terminate the innermost loop.
1968 Make sure it doesn't terminate another one. */
1969 for (; p
; p
= p
->previous
)
1970 if (p
->state
== COMP_DO
&& p
->ext
.end_do_label
== gfc_statement_label
)
1972 gfc_error ("End of nonblock DO statement at %C is interwoven "
1973 "with another DO loop");
1981 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
1982 handled inside of parse_executable(), because they aren't really
1986 parse_do_block (void)
1993 s
.ext
.end_do_label
= new_st
.label
;
1995 if (new_st
.ext
.iterator
!= NULL
)
1996 stree
= new_st
.ext
.iterator
->var
->symtree
;
2000 accept_statement (ST_DO
);
2002 top
= gfc_state_stack
->tail
;
2003 push_state (&s
, COMP_DO
, gfc_new_block
);
2005 s
.do_variable
= stree
;
2007 top
->block
= new_level (top
);
2008 top
->block
->op
= EXEC_DO
;
2011 st
= parse_executable (ST_NONE
);
2019 if (s
.ext
.end_do_label
!= NULL
2020 && s
.ext
.end_do_label
!= gfc_statement_label
)
2022 ("Statement label in ENDDO at %C doesn't match DO label");
2025 case ST_IMPLIED_ENDDO
:
2029 unexpected_statement (st
);
2034 accept_statement (st
);
2038 /* Accept a series of executable statements. We return the first
2039 statement that doesn't fit to the caller. Any block statements are
2040 passed on to the correct handler, which usually passes the buck
2043 static gfc_statement
2044 parse_executable (gfc_statement st
)
2049 st
= next_statement ();
2051 for (;; st
= next_statement ())
2054 close_flag
= check_do_closure ();
2059 case ST_END_PROGRAM
:
2062 case ST_END_FUNCTION
:
2066 case ST_END_SUBROUTINE
:
2071 case ST_SELECT_CASE
:
2073 ("%s statement at %C cannot terminate a non-block DO loop",
2074 gfc_ascii_statement (st
));
2090 accept_statement (st
);
2091 if (close_flag
== 1)
2092 return ST_IMPLIED_ENDDO
;
2099 case ST_SELECT_CASE
:
2100 parse_select_block ();
2105 if (check_do_closure () == 1)
2106 return ST_IMPLIED_ENDDO
;
2109 case ST_WHERE_BLOCK
:
2110 parse_where_block ();
2113 case ST_FORALL_BLOCK
:
2114 parse_forall_block ();
2128 /* Parse a series of contained program units. */
2130 static void parse_progunit (gfc_statement
);
2133 /* Fix the symbols for sibling functions. These are incorrectly added to
2134 the child namespace as the parser didn't know about this procedure. */
2137 gfc_fixup_sibling_symbols (gfc_symbol
* sym
, gfc_namespace
* siblings
)
2141 gfc_symbol
*old_sym
;
2143 for (ns
= siblings
; ns
; ns
= ns
->sibling
)
2145 gfc_find_sym_tree (sym
->name
, ns
, 0, &st
);
2149 old_sym
= st
->n
.sym
;
2150 if ((old_sym
->attr
.flavor
== FL_PROCEDURE
2151 || old_sym
->ts
.type
== BT_UNKNOWN
)
2152 && old_sym
->ns
== ns
2153 && ! old_sym
->attr
.contained
)
2155 /* Replace it with the symbol from the parent namespace. */
2159 /* Free the old (local) symbol. */
2161 if (old_sym
->refs
== 0)
2162 gfc_free_symbol (old_sym
);
2165 /* Do the same for any contined procedures. */
2166 gfc_fixup_sibling_symbols (sym
, ns
->contained
);
2171 parse_contained (int module
)
2173 gfc_namespace
*ns
, *parent_ns
;
2174 gfc_state_data s1
, s2
;
2178 push_state (&s1
, COMP_CONTAINS
, NULL
);
2179 parent_ns
= gfc_current_ns
;
2183 gfc_current_ns
= gfc_get_namespace (parent_ns
);
2185 gfc_current_ns
->sibling
= parent_ns
->contained
;
2186 parent_ns
->contained
= gfc_current_ns
;
2188 st
= next_statement ();
2197 accept_statement (st
);
2200 (st
== ST_FUNCTION
) ? COMP_FUNCTION
: COMP_SUBROUTINE
,
2203 /* For internal procedures, create/update the symbol in the
2204 * parent namespace */
2208 if (gfc_get_symbol (gfc_new_block
->name
, parent_ns
, &sym
))
2210 ("Contained procedure '%s' at %C is already ambiguous",
2211 gfc_new_block
->name
);
2214 if (gfc_add_procedure (&sym
->attr
, PROC_INTERNAL
,
2215 &gfc_new_block
->declared_at
) ==
2218 if (st
== ST_FUNCTION
)
2219 gfc_add_function (&sym
->attr
,
2220 &gfc_new_block
->declared_at
);
2222 gfc_add_subroutine (&sym
->attr
,
2223 &gfc_new_block
->declared_at
);
2227 gfc_commit_symbols ();
2230 sym
= gfc_new_block
;
2232 /* Mark this as a contained function, so it isn't replaced
2233 by other module functions. */
2234 sym
->attr
.contained
= 1;
2235 sym
->attr
.referenced
= 1;
2237 /* Fix up any sibling functions that refer to this one. */
2238 gfc_fixup_sibling_symbols (sym
, gfc_current_ns
);
2240 parse_progunit (ST_NONE
);
2242 gfc_current_ns
->code
= s2
.head
;
2243 gfc_current_ns
= parent_ns
;
2248 /* These statements are associated with the end of the host
2250 case ST_END_FUNCTION
:
2252 case ST_END_PROGRAM
:
2253 case ST_END_SUBROUTINE
:
2254 accept_statement (st
);
2258 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
2259 gfc_ascii_statement (st
));
2260 reject_statement ();
2264 while (st
!= ST_END_FUNCTION
&& st
!= ST_END_SUBROUTINE
2265 && st
!= ST_END_MODULE
&& st
!= ST_END_PROGRAM
);
2267 /* The first namespace in the list is guaranteed to not have
2268 anything (worthwhile) in it. */
2270 gfc_current_ns
= parent_ns
;
2272 ns
= gfc_current_ns
->contained
;
2273 gfc_current_ns
->contained
= ns
->sibling
;
2274 gfc_free_namespace (ns
);
2280 /* Parse a PROGRAM, SUBROUTINE or FUNCTION unit. */
2283 parse_progunit (gfc_statement st
)
2288 st
= parse_spec (st
);
2298 accept_statement (st
);
2308 st
= parse_executable (st
);
2319 accept_statement (st
);
2326 unexpected_statement (st
);
2327 reject_statement ();
2328 st
= next_statement ();
2334 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
2335 if (p
->state
== COMP_CONTAINS
)
2338 if (gfc_find_state (COMP_MODULE
) == SUCCESS
)
2343 gfc_error ("CONTAINS statement at %C is already in a contained "
2345 st
= next_statement ();
2349 parse_contained (0);
2352 gfc_current_ns
->code
= gfc_state_stack
->head
;
2356 /* Come here to complain about a global symbol already in use as
2360 global_used (gfc_gsymbol
*sym
, locus
*where
)
2365 where
= &gfc_current_locus
;
2375 case GSYM_SUBROUTINE
:
2376 name
= "SUBROUTINE";
2381 case GSYM_BLOCK_DATA
:
2382 name
= "BLOCK DATA";
2388 gfc_internal_error ("gfc_gsymbol_type(): Bad type");
2392 gfc_error("Global name '%s' at %L is already being used as a %s at %L",
2393 gfc_new_block
->name
, where
, name
, &sym
->where
);
2397 /* Parse a block data program unit. */
2400 parse_block_data (void)
2403 static locus blank_locus
;
2404 static int blank_block
=0;
2407 if (gfc_new_block
== NULL
)
2410 gfc_error ("Blank BLOCK DATA at %C conflicts with "
2411 "prior BLOCK DATA at %L", &blank_locus
);
2415 blank_locus
= gfc_current_locus
;
2420 s
= gfc_get_gsymbol (gfc_new_block
->name
);
2421 if (s
->type
!= GSYM_UNKNOWN
)
2422 global_used(s
, NULL
);
2425 s
->type
= GSYM_BLOCK_DATA
;
2426 s
->where
= gfc_current_locus
;
2430 st
= parse_spec (ST_NONE
);
2432 while (st
!= ST_END_BLOCK_DATA
)
2434 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
2435 gfc_ascii_statement (st
));
2436 reject_statement ();
2437 st
= next_statement ();
2442 /* Parse a module subprogram. */
2450 s
= gfc_get_gsymbol (gfc_new_block
->name
);
2451 if (s
->type
!= GSYM_UNKNOWN
)
2452 global_used(s
, NULL
);
2455 s
->type
= GSYM_MODULE
;
2456 s
->where
= gfc_current_locus
;
2459 st
= parse_spec (ST_NONE
);
2468 parse_contained (1);
2472 accept_statement (st
);
2476 gfc_error ("Unexpected %s statement in MODULE at %C",
2477 gfc_ascii_statement (st
));
2479 reject_statement ();
2480 st
= next_statement ();
2486 /* Add a procedure name to the global symbol table. */
2489 add_global_procedure (int sub
)
2493 s
= gfc_get_gsymbol(gfc_new_block
->name
);
2495 if (s
->type
!= GSYM_UNKNOWN
)
2496 global_used(s
, NULL
);
2499 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2500 s
->where
= gfc_current_locus
;
2505 /* Add a program to the global symbol table. */
2508 add_global_program (void)
2512 if (gfc_new_block
== NULL
)
2514 s
= gfc_get_gsymbol (gfc_new_block
->name
);
2516 if (s
->type
!= GSYM_UNKNOWN
)
2517 global_used(s
, NULL
);
2520 s
->type
= GSYM_PROGRAM
;
2521 s
->where
= gfc_current_locus
;
2526 /* Top level parser. */
2529 gfc_parse_file (void)
2531 int seen_program
, errors_before
, errors
;
2532 gfc_state_data top
, s
;
2536 top
.state
= COMP_NONE
;
2538 top
.previous
= NULL
;
2539 top
.head
= top
.tail
= NULL
;
2540 top
.do_variable
= NULL
;
2542 gfc_state_stack
= &top
;
2544 gfc_clear_new_st ();
2546 gfc_statement_label
= NULL
;
2549 return FAILURE
; /* Come here on unexpected EOF */
2555 st
= next_statement ();
2564 goto duplicate_main
;
2566 prog_locus
= gfc_current_locus
;
2568 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
2569 accept_statement (st
);
2570 add_global_program ();
2571 parse_progunit (ST_NONE
);
2575 add_global_procedure (1);
2576 push_state (&s
, COMP_SUBROUTINE
, gfc_new_block
);
2577 accept_statement (st
);
2578 parse_progunit (ST_NONE
);
2582 add_global_procedure (0);
2583 push_state (&s
, COMP_FUNCTION
, gfc_new_block
);
2584 accept_statement (st
);
2585 parse_progunit (ST_NONE
);
2589 push_state (&s
, COMP_BLOCK_DATA
, gfc_new_block
);
2590 accept_statement (st
);
2591 parse_block_data ();
2595 push_state (&s
, COMP_MODULE
, gfc_new_block
);
2596 accept_statement (st
);
2598 gfc_get_errors (NULL
, &errors_before
);
2602 /* Anything else starts a nameless main program block. */
2605 goto duplicate_main
;
2607 prog_locus
= gfc_current_locus
;
2609 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
2610 parse_progunit (st
);
2614 gfc_current_ns
->code
= s
.head
;
2616 gfc_resolve (gfc_current_ns
);
2618 /* Dump the parse tree if requested. */
2619 if (gfc_option
.verbose
)
2620 gfc_show_namespace (gfc_current_ns
);
2622 gfc_get_errors (NULL
, &errors
);
2623 if (s
.state
== COMP_MODULE
)
2625 gfc_dump_module (s
.sym
->name
, errors_before
== errors
);
2626 if (errors
== 0 && ! gfc_option
.flag_no_backend
)
2627 gfc_generate_module_code (gfc_current_ns
);
2631 if (errors
== 0 && ! gfc_option
.flag_no_backend
)
2632 gfc_generate_code (gfc_current_ns
);
2643 /* If we see a duplicate main program, shut down. If the second
2644 instance is an implied main program, ie data decls or executable
2645 statements, we're in for lots of errors. */
2646 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus
);
2647 reject_statement ();