2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 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
31 /* Current statement label. Zero means no statement label. Because
32 new_st can get wiped during statement matching, we have to keep it
35 gfc_st_label
*gfc_statement_label
;
37 static locus label_locus
;
38 static jmp_buf eof_buf
;
40 gfc_state_data
*gfc_state_stack
;
42 /* TODO: Re-order functions to kill these forward decls. */
43 static void check_statement_label (gfc_statement
);
44 static void undo_new_statement (void);
45 static void reject_statement (void);
47 /* A sort of half-matching function. We try to match the word on the
48 input with the passed string. If this succeeds, we call the
49 keyword-dependent matching function that will match the rest of the
50 statement. For single keywords, the matching subroutine is
54 match_word (const char *str
, match (*subr
) (void), locus
* old_locus
)
69 gfc_current_locus
= *old_locus
;
77 /* Figure out what the next statement is, (mostly) regardless of
80 #define match(keyword, subr, st) \
81 if (match_word(keyword, subr, &old_locus) == MATCH_YES) \
84 undo_new_statement ();
87 decode_statement (void)
98 gfc_clear_error (); /* Clear any pending errors. */
99 gfc_clear_warning (); /* Clear any pending warnings. */
101 if (gfc_match_eos () == MATCH_YES
)
104 old_locus
= gfc_current_locus
;
106 /* Try matching a data declaration or function declaration. The
107 input "REALFUNCTIONA(N)" can mean several things in different
108 contexts, so it (and its relatives) get special treatment. */
110 if (gfc_current_state () == COMP_NONE
111 || gfc_current_state () == COMP_INTERFACE
112 || gfc_current_state () == COMP_CONTAINS
)
114 m
= gfc_match_function_decl ();
117 else if (m
== MATCH_ERROR
)
121 gfc_current_locus
= old_locus
;
124 /* Match statements whose error messages are meant to be overwritten
125 by something better. */
127 match (NULL
, gfc_match_assignment
, ST_ASSIGNMENT
);
128 match (NULL
, gfc_match_pointer_assignment
, ST_POINTER_ASSIGNMENT
);
129 match (NULL
, gfc_match_st_function
, ST_STATEMENT_FUNCTION
);
131 match (NULL
, gfc_match_data_decl
, ST_DATA_DECL
);
133 /* Try to match a subroutine statement, which has the same optional
134 prefixes that functions can have. */
136 if (gfc_match_subroutine () == MATCH_YES
)
137 return ST_SUBROUTINE
;
139 gfc_current_locus
= old_locus
;
141 /* Check for the IF, DO, SELECT, WHERE and FORALL statements, which
142 might begin with a block label. The match functions for these
143 statements are unusual in that their keyword is not seen before
144 the matcher is called. */
146 if (gfc_match_if (&st
) == MATCH_YES
)
149 gfc_current_locus
= old_locus
;
151 if (gfc_match_where (&st
) == MATCH_YES
)
154 gfc_current_locus
= old_locus
;
156 if (gfc_match_forall (&st
) == MATCH_YES
)
159 gfc_current_locus
= old_locus
;
161 match (NULL
, gfc_match_do
, ST_DO
);
162 match (NULL
, gfc_match_select
, ST_SELECT_CASE
);
164 /* General statement matching: Instead of testing every possible
165 statement, we eliminate most possibilities by peeking at the
168 c
= gfc_peek_char ();
173 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
);
174 match ("allocatable", gfc_match_allocatable
, ST_ATTR_DECL
);
175 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
);
179 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
);
180 match ("block data", gfc_match_block_data
, ST_BLOCK_DATA
);
184 match ("call", gfc_match_call
, ST_CALL
);
185 match ("close", gfc_match_close
, ST_CLOSE
);
186 match ("continue", gfc_match_continue
, ST_CONTINUE
);
187 match ("cycle", gfc_match_cycle
, ST_CYCLE
);
188 match ("case", gfc_match_case
, ST_CASE
);
189 match ("common", gfc_match_common
, ST_COMMON
);
190 match ("contains", gfc_match_eos
, ST_CONTAINS
);
194 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
);
195 match ("data", gfc_match_data
, ST_DATA
);
196 match ("dimension", gfc_match_dimension
, ST_ATTR_DECL
);
200 match ("end file", gfc_match_endfile
, ST_END_FILE
);
201 match ("exit", gfc_match_exit
, ST_EXIT
);
202 match ("else", gfc_match_else
, ST_ELSE
);
203 match ("else where", gfc_match_elsewhere
, ST_ELSEWHERE
);
204 match ("else if", gfc_match_elseif
, ST_ELSEIF
);
206 if (gfc_match_end (&st
) == MATCH_YES
)
209 match ("entry% ", gfc_match_entry
, ST_ENTRY
);
210 match ("equivalence", gfc_match_equivalence
, ST_EQUIVALENCE
);
211 match ("external", gfc_match_external
, ST_ATTR_DECL
);
215 match ("format", gfc_match_format
, ST_FORMAT
);
219 match ("go to", gfc_match_goto
, ST_GOTO
);
223 match ("inquire", gfc_match_inquire
, ST_INQUIRE
);
224 match ("implicit", gfc_match_implicit
, ST_IMPLICIT
);
225 match ("implicit% none", gfc_match_implicit_none
, ST_IMPLICIT_NONE
);
226 match ("interface", gfc_match_interface
, ST_INTERFACE
);
227 match ("intent", gfc_match_intent
, ST_ATTR_DECL
);
228 match ("intrinsic", gfc_match_intrinsic
, ST_ATTR_DECL
);
232 match ("module% procedure% ", gfc_match_modproc
, ST_MODULE_PROC
);
233 match ("module", gfc_match_module
, ST_MODULE
);
237 match ("nullify", gfc_match_nullify
, ST_NULLIFY
);
238 match ("namelist", gfc_match_namelist
, ST_NAMELIST
);
242 match ("open", gfc_match_open
, ST_OPEN
);
243 match ("optional", gfc_match_optional
, ST_ATTR_DECL
);
247 match ("print", gfc_match_print
, ST_WRITE
);
248 match ("parameter", gfc_match_parameter
, ST_PARAMETER
);
249 match ("pause", gfc_match_pause
, ST_PAUSE
);
250 match ("pointer", gfc_match_pointer
, ST_ATTR_DECL
);
251 if (gfc_match_private (&st
) == MATCH_YES
)
253 match ("program", gfc_match_program
, ST_PROGRAM
);
254 if (gfc_match_public (&st
) == MATCH_YES
)
259 match ("read", gfc_match_read
, ST_READ
);
260 match ("return", gfc_match_return
, ST_RETURN
);
261 match ("rewind", gfc_match_rewind
, ST_REWIND
);
265 match ("sequence", gfc_match_eos
, ST_SEQUENCE
);
266 match ("stop", gfc_match_stop
, ST_STOP
);
267 match ("save", gfc_match_save
, ST_ATTR_DECL
);
271 match ("target", gfc_match_target
, ST_ATTR_DECL
);
272 match ("type", gfc_match_derived_decl
, ST_DERIVED_DECL
);
276 match ("use% ", gfc_match_use
, ST_USE
);
280 match ("write", gfc_match_write
, ST_WRITE
);
284 /* All else has failed, so give up. See if any of the matchers has
285 stored an error message of some sort. */
287 if (gfc_error_check () == 0)
288 gfc_error_now ("Unclassifiable statement at %C");
292 gfc_error_recovery ();
300 /* Get the next statement in free form source. */
308 gfc_gobble_whitespace ();
310 c
= gfc_peek_char ();
314 /* Found a statement label? */
315 m
= gfc_match_st_label (&gfc_statement_label
, 0);
317 d
= gfc_peek_char ();
318 if (m
!= MATCH_YES
|| !gfc_is_whitespace (d
))
322 /* Skip the bad statement label. */
323 gfc_warning_now ("Ignoring bad statement label at %C");
324 c
= gfc_next_char ();
330 label_locus
= gfc_current_locus
;
332 if (gfc_statement_label
->value
== 0)
334 gfc_warning_now ("Ignoring statement label of zero at %C");
335 gfc_free_st_label (gfc_statement_label
);
336 gfc_statement_label
= NULL
;
339 gfc_gobble_whitespace ();
341 if (gfc_match_eos () == MATCH_YES
)
344 ("Ignoring statement label in empty statement at %C");
345 gfc_free_st_label (gfc_statement_label
);
346 gfc_statement_label
= NULL
;
352 return decode_statement ();
356 /* Get the next statement in fixed-form source. */
361 int label
, digit_flag
, i
;
366 return decode_statement ();
368 /* Skip past the current label field, parsing a statement label if
369 one is there. This is a weird number parser, since the number is
370 contained within five columns and can have any kind of embedded
371 spaces. We also check for characters that make the rest of the
377 for (i
= 0; i
< 5; i
++)
379 c
= gfc_next_char_literal (0);
396 label
= label
* 10 + c
- '0';
397 label_locus
= gfc_current_locus
;
401 /* Comments have already been skipped by the time we get
402 here so don't bother checking for them. */
405 gfc_buffer_error (0);
406 gfc_error ("Non-numeric character in statement label at %C");
414 gfc_warning_now ("Zero is not a valid statement label at %C");
417 /* We've found a valid statement label. */
418 gfc_statement_label
= gfc_get_st_label (label
);
422 /* Since this line starts a statement, it cannot be a continuation
423 of a previous statement. If we see something here besides a
424 space or zero, it must be a bad continuation line. */
426 c
= gfc_next_char_literal (0);
430 if (c
!= ' ' && c
!= '0')
432 gfc_buffer_error (0);
433 gfc_error ("Bad continuation line at %C");
437 /* Now that we've taken care of the statement label columns, we have
438 to make sure that the first nonblank character is not a '!'. If
439 it is, the rest of the line is a comment. */
443 loc
= gfc_current_locus
;
444 c
= gfc_next_char_literal (0);
446 while (gfc_is_whitespace (c
));
450 gfc_current_locus
= loc
;
452 if (gfc_match_eos () == MATCH_YES
)
455 /* At this point, we've got a nonblank statement to parse. */
456 return decode_statement ();
460 gfc_warning ("Statement label in blank line will be " "ignored at %C");
466 /* Return the next non-ST_NONE statement to the caller. We also worry
467 about including files and the ends of include files at this stage. */
470 next_statement (void)
474 gfc_new_block
= NULL
;
478 gfc_statement_label
= NULL
;
479 gfc_buffer_error (1);
484 gfc_skip_comments ();
493 (gfc_current_form
== FORM_FIXED
) ? next_fixed () : next_free ();
499 gfc_buffer_error (0);
502 check_statement_label (st
);
508 /****************************** Parser ***********************************/
510 /* The parser subroutines are of type 'try' that fail if the file ends
513 /* Macros that expand to case-labels for various classes of
514 statements. Start with executable statements that directly do
517 #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
518 case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
519 case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
520 case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
521 case ST_PAUSE: case ST_STOP: case ST_WRITE: case ST_ASSIGNMENT: \
522 case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
523 case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: case ST_LABEL_ASSIGNMENT
525 /* Statements that mark other executable statements. */
527 #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: case ST_IF_BLOCK: \
528 case ST_WHERE_BLOCK: case ST_SELECT_CASE
530 /* Declaration statements */
532 #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
533 case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
534 case ST_TYPE: case ST_INTERFACE
536 /* Block end statements. Errors associated with interchanging these
537 are detected in gfc_match_end(). */
539 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
540 case ST_END_PROGRAM: case ST_END_SUBROUTINE
543 /* Push a new state onto the stack. */
546 push_state (gfc_state_data
* p
, gfc_compile_state new_state
, gfc_symbol
* sym
)
549 p
->state
= new_state
;
550 p
->previous
= gfc_state_stack
;
552 p
->head
= p
->tail
= NULL
;
553 p
->do_variable
= NULL
;
559 /* Pop the current state. */
565 gfc_state_stack
= gfc_state_stack
->previous
;
569 /* Try to find the given state in the state stack. */
572 gfc_find_state (gfc_compile_state state
)
576 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
577 if (p
->state
== state
)
580 return (p
== NULL
) ? FAILURE
: SUCCESS
;
584 /* Starts a new level in the statement list. */
587 new_level (gfc_code
* q
)
591 p
= q
->block
= gfc_get_code ();
593 gfc_state_stack
->head
= gfc_state_stack
->tail
= p
;
599 /* Add the current new_st code structure and adds it to the current
600 program unit. As a side-effect, it zeroes the new_st. */
610 p
->loc
= gfc_current_locus
;
612 if (gfc_state_stack
->head
== NULL
)
613 gfc_state_stack
->head
= p
;
615 gfc_state_stack
->tail
->next
= p
;
617 while (p
->next
!= NULL
)
620 gfc_state_stack
->tail
= p
;
628 /* Frees everything associated with the current statement. */
631 undo_new_statement (void)
633 gfc_free_statements (new_st
.block
);
634 gfc_free_statements (new_st
.next
);
635 gfc_free_statement (&new_st
);
640 /* If the current statement has a statement label, make sure that it
641 is allowed to, or should have one. */
644 check_statement_label (gfc_statement st
)
648 if (gfc_statement_label
== NULL
)
651 gfc_error ("FORMAT statement at %L does not have a statement label",
659 case ST_END_FUNCTION
:
660 case ST_END_SUBROUTINE
:
666 type
= ST_LABEL_TARGET
;
670 type
= ST_LABEL_FORMAT
;
673 /* Statement labels are not restricted from appearing on a
674 particular line. However, there are plenty of situations
675 where the resulting label can't be referenced. */
678 type
= ST_LABEL_BAD_TARGET
;
682 gfc_define_st_label (gfc_statement_label
, type
, &label_locus
);
684 new_st
.here
= gfc_statement_label
;
688 /* Figures out what the enclosing program unit is. This will be a
689 function, subroutine, program, block data or module. */
692 gfc_enclosing_unit (gfc_compile_state
* result
)
696 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
697 if (p
->state
== COMP_FUNCTION
|| p
->state
== COMP_SUBROUTINE
698 || p
->state
== COMP_MODULE
|| p
->state
== COMP_BLOCK_DATA
699 || p
->state
== COMP_PROGRAM
)
708 *result
= COMP_PROGRAM
;
713 /* Translate a statement enum to a string. */
716 gfc_ascii_statement (gfc_statement st
)
722 case ST_ARITHMETIC_IF
:
729 p
= "attribute declaration";
759 p
= "data declaration";
767 case ST_DERIVED_DECL
:
768 p
= "Derived type declaration";
782 case ST_END_BLOCK_DATA
:
783 p
= "END BLOCK DATA";
794 case ST_END_FUNCTION
:
800 case ST_END_INTERFACE
:
812 case ST_END_SUBROUTINE
:
813 p
= "END SUBROUTINE";
830 case ST_FORALL_BLOCK
: /* Fall through */
849 case ST_IMPLICIT_NONE
:
852 case ST_IMPLIED_ENDDO
:
853 p
= "implied END DO";
877 p
= "MODULE PROCEDURE";
912 case ST_WHERE_BLOCK
: /* Fall through */
922 case ST_POINTER_ASSIGNMENT
:
923 p
= "pointer assignment";
934 case ST_STATEMENT_FUNCTION
:
935 p
= "STATEMENT FUNCTION";
937 case ST_LABEL_ASSIGNMENT
:
938 p
= "LABEL ASSIGNMENT";
941 gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
948 /* Return the name of a compile state. */
951 gfc_state_name (gfc_compile_state state
)
963 case COMP_SUBROUTINE
:
969 case COMP_BLOCK_DATA
:
976 p
= "a DERIVED TYPE block";
979 p
= "an IF-THEN block";
985 p
= "a SELECT block";
988 p
= "a FORALL block";
994 p
= "a contained subprogram";
998 gfc_internal_error ("gfc_state_name(): Bad state");
1005 /* Do whatever is necessary to accept the last statement. */
1008 accept_statement (gfc_statement st
)
1017 case ST_IMPLICIT_NONE
:
1018 gfc_set_implicit_none ();
1027 gfc_current_ns
->proc_name
= gfc_new_block
;
1030 /* If the statement is the end of a block, lay down a special code
1031 that allows a branch to the end of the block from within the
1036 if (gfc_statement_label
!= NULL
)
1038 new_st
.op
= EXEC_NOP
;
1044 /* The end-of-program unit statements do not get the special
1045 marker and require a statement of some sort if they are a
1048 case ST_END_PROGRAM
:
1049 case ST_END_FUNCTION
:
1050 case ST_END_SUBROUTINE
:
1051 if (gfc_statement_label
!= NULL
)
1053 new_st
.op
= EXEC_RETURN
;
1069 gfc_commit_symbols ();
1070 gfc_warning_check ();
1071 gfc_clear_new_st ();
1075 /* Undo anything tentative that has been built for the current
1079 reject_statement (void)
1082 gfc_undo_symbols ();
1083 gfc_clear_warning ();
1084 undo_new_statement ();
1088 /* Generic complaint about an out of order statement. We also do
1089 whatever is necessary to clean up. */
1092 unexpected_statement (gfc_statement st
)
1095 gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st
));
1097 reject_statement ();
1101 /* Given the next statement seen by the matcher, make sure that it is
1102 in proper order with the last. This subroutine is initialized by
1103 calling it with an argument of ST_NONE. If there is a problem, we
1104 issue an error and return FAILURE. Otherwise we return SUCCESS.
1106 Individual parsers need to verify that the statements seen are
1107 valid before calling here, ie ENTRY statements are not allowed in
1108 INTERFACE blocks. The following diagram is taken from the standard:
1110 +---------------------------------------+
1111 | program subroutine function module |
1112 +---------------------------------------+
1114 |---------------------------------------+
1116 | +-----------+------------------+
1117 | | parameter | implicit |
1118 | +-----------+------------------+
1119 | format | | derived type |
1120 | entry | parameter | interface |
1121 | | data | specification |
1122 | | | statement func |
1123 | +-----------+------------------+
1124 | | data | executable |
1125 +--------+-----------+------------------+
1127 +---------------------------------------+
1128 | internal module/subprogram |
1129 +---------------------------------------+
1131 +---------------------------------------+
1138 { ORDER_START
, ORDER_USE
, ORDER_IMPLICIT_NONE
, ORDER_IMPLICIT
,
1139 ORDER_SPEC
, ORDER_EXEC
1142 gfc_statement last_statement
;
1148 verify_st_order (st_state
* p
, gfc_statement st
)
1154 p
->state
= ORDER_START
;
1158 if (p
->state
> ORDER_USE
)
1160 p
->state
= ORDER_USE
;
1163 case ST_IMPLICIT_NONE
:
1164 if (p
->state
> ORDER_IMPLICIT_NONE
)
1167 /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
1168 statement disqualifies a USE but not an IMPLICIT NONE.
1169 Duplicate IMPLICIT NONEs are caught when the implicit types
1172 p
->state
= ORDER_IMPLICIT_NONE
;
1176 if (p
->state
> ORDER_IMPLICIT
)
1178 p
->state
= ORDER_IMPLICIT
;
1183 if (p
->state
< ORDER_IMPLICIT_NONE
)
1184 p
->state
= ORDER_IMPLICIT_NONE
;
1188 if (p
->state
>= ORDER_EXEC
)
1190 if (p
->state
< ORDER_IMPLICIT
)
1191 p
->state
= ORDER_IMPLICIT
;
1195 if (p
->state
< ORDER_SPEC
)
1196 p
->state
= ORDER_SPEC
;
1201 case ST_DERIVED_DECL
:
1203 if (p
->state
>= ORDER_EXEC
)
1205 if (p
->state
< ORDER_SPEC
)
1206 p
->state
= ORDER_SPEC
;
1211 if (p
->state
< ORDER_EXEC
)
1212 p
->state
= ORDER_EXEC
;
1217 ("Unexpected %s statement in verify_st_order() at %C",
1218 gfc_ascii_statement (st
));
1221 /* All is well, record the statement in case we need it next time. */
1222 p
->where
= gfc_current_locus
;
1223 p
->last_statement
= st
;
1227 gfc_error ("%s statement at %C cannot follow %s statement at %L",
1228 gfc_ascii_statement (st
),
1229 gfc_ascii_statement (p
->last_statement
), &p
->where
);
1235 /* Handle an unexpected end of file. This is a show-stopper... */
1237 static void unexpected_eof (void) ATTRIBUTE_NORETURN
;
1240 unexpected_eof (void)
1244 gfc_error ("Unexpected end of file in '%s'", gfc_source_file
);
1246 /* Memory cleanup. Move to "second to last". */
1247 for (p
= gfc_state_stack
; p
&& p
->previous
&& p
->previous
->previous
;
1250 gfc_current_ns
->code
= (p
&& p
->previous
) ? p
->head
: NULL
;
1253 longjmp (eof_buf
, 1);
1257 /* Parse a derived type. */
1260 parse_derived (void)
1262 int compiling_type
, seen_private
, seen_sequence
, seen_component
, error_flag
;
1269 accept_statement (ST_DERIVED_DECL
);
1270 push_state (&s
, COMP_DERIVED
, gfc_new_block
);
1272 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
1279 while (compiling_type
)
1281 st
= next_statement ();
1288 accept_statement (st
);
1295 if (!seen_component
)
1297 gfc_error ("Derived type definition at %C has no components");
1301 accept_statement (ST_END_TYPE
);
1305 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
1308 ("PRIVATE statement in TYPE at %C must be inside a MODULE");
1315 gfc_error ("PRIVATE statement at %C must precede "
1316 "structure components");
1323 gfc_error ("Duplicate PRIVATE statement at %C");
1327 s
.sym
->component_access
= ACCESS_PRIVATE
;
1328 accept_statement (ST_PRIVATE
);
1335 gfc_error ("SEQUENCE statement at %C must precede "
1336 "structure components");
1341 if (gfc_current_block ()->attr
.sequence
)
1342 gfc_warning ("SEQUENCE attribute at %C already specified in "
1347 gfc_error ("Duplicate SEQUENCE statement at %C");
1352 gfc_add_sequence (&gfc_current_block ()->attr
, NULL
);
1356 unexpected_statement (st
);
1361 /* Sanity checks on the structure. If the structure has the
1362 SEQUENCE attribute, then all component structures must also have
1364 if (error_flag
== 0 && gfc_current_block ()->attr
.sequence
)
1365 for (c
= gfc_current_block ()->components
; c
; c
= c
->next
)
1367 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.derived
->attr
.sequence
== 0)
1370 ("Component %s of SEQUENCE type declared at %C does not "
1371 "have the SEQUENCE attribute", c
->ts
.derived
->name
);
1380 /* Parse an interface. We must be able to deal with the possibility
1381 of recursive interfaces. The parse_spec() subroutine is mutually
1382 recursive with parse_interface(). */
1384 static gfc_statement
parse_spec (gfc_statement
);
1387 parse_interface (void)
1389 gfc_compile_state new_state
, current_state
;
1390 gfc_symbol
*prog_unit
, *sym
;
1391 gfc_interface_info save
;
1392 gfc_state_data s1
, s2
;
1395 accept_statement (ST_INTERFACE
);
1397 current_interface
.ns
= gfc_current_ns
;
1398 save
= current_interface
;
1400 sym
= (current_interface
.type
== INTERFACE_GENERIC
1401 || current_interface
.type
== INTERFACE_USER_OP
) ? gfc_new_block
: NULL
;
1403 push_state (&s1
, COMP_INTERFACE
, sym
);
1404 current_state
= COMP_NONE
;
1407 gfc_current_ns
= gfc_get_namespace (current_interface
.ns
);
1409 st
= next_statement ();
1416 new_state
= COMP_SUBROUTINE
;
1417 gfc_add_explicit_interface (gfc_new_block
, IFSRC_IFBODY
,
1418 gfc_new_block
->formal
, NULL
);
1422 new_state
= COMP_FUNCTION
;
1423 gfc_add_explicit_interface (gfc_new_block
, IFSRC_IFBODY
,
1424 gfc_new_block
->formal
, NULL
);
1427 case ST_MODULE_PROC
: /* The module procedure matcher makes
1428 sure the context is correct. */
1429 accept_statement (st
);
1430 gfc_free_namespace (gfc_current_ns
);
1433 case ST_END_INTERFACE
:
1434 gfc_free_namespace (gfc_current_ns
);
1435 gfc_current_ns
= current_interface
.ns
;
1439 gfc_error ("Unexpected %s statement in INTERFACE block at %C",
1440 gfc_ascii_statement (st
));
1441 reject_statement ();
1442 gfc_free_namespace (gfc_current_ns
);
1447 /* Make sure that a generic interface has only subroutines or
1448 functions and that the generic name has the right attribute. */
1449 if (current_interface
.type
== INTERFACE_GENERIC
)
1451 if (current_state
== COMP_NONE
)
1453 if (new_state
== COMP_FUNCTION
)
1454 gfc_add_function (&sym
->attr
, NULL
);
1455 if (new_state
== COMP_SUBROUTINE
)
1456 gfc_add_subroutine (&sym
->attr
, NULL
);
1458 current_state
= new_state
;
1462 if (new_state
!= current_state
)
1464 if (new_state
== COMP_SUBROUTINE
)
1466 ("SUBROUTINE at %C does not belong in a generic function "
1469 if (new_state
== COMP_FUNCTION
)
1471 ("FUNCTION at %C does not belong in a generic subroutine "
1477 push_state (&s2
, new_state
, gfc_new_block
);
1478 accept_statement (st
);
1479 prog_unit
= gfc_new_block
;
1480 prog_unit
->formal_ns
= gfc_current_ns
;
1483 /* Read data declaration statements. */
1484 st
= parse_spec (ST_NONE
);
1486 if (st
!= ST_END_SUBROUTINE
&& st
!= ST_END_FUNCTION
)
1488 gfc_error ("Unexpected %s statement at %C in INTERFACE body",
1489 gfc_ascii_statement (st
));
1490 reject_statement ();
1494 current_interface
= save
;
1495 gfc_add_interface (prog_unit
);
1505 /* Parse a set of specification statements. Returns the statement
1506 that doesn't fit. */
1508 static gfc_statement
1509 parse_spec (gfc_statement st
)
1513 verify_st_order (&ss
, ST_NONE
);
1515 st
= next_statement ();
1525 case ST_DATA
: /* Not allowed in interfaces */
1526 if (gfc_current_state () == COMP_INTERFACE
)
1532 case ST_IMPLICIT_NONE
:
1537 case ST_DERIVED_DECL
:
1539 if (verify_st_order (&ss
, st
) == FAILURE
)
1541 reject_statement ();
1542 st
= next_statement ();
1552 case ST_DERIVED_DECL
:
1558 if (gfc_current_state () != COMP_MODULE
)
1560 gfc_error ("%s statement must appear in a MODULE",
1561 gfc_ascii_statement (st
));
1565 if (gfc_current_ns
->default_access
!= ACCESS_UNKNOWN
)
1567 gfc_error ("%s statement at %C follows another accessibility "
1568 "specification", gfc_ascii_statement (st
));
1572 gfc_current_ns
->default_access
= (st
== ST_PUBLIC
)
1573 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
1581 accept_statement (st
);
1582 st
= next_statement ();
1593 /* Parse a WHERE block, (not a simple WHERE statement). */
1596 parse_where_block (void)
1598 int seen_empty_else
;
1603 accept_statement (ST_WHERE_BLOCK
);
1604 top
= gfc_state_stack
->tail
;
1606 push_state (&s
, COMP_WHERE
, gfc_new_block
);
1608 d
= add_statement ();
1609 d
->expr
= top
->expr
;
1615 seen_empty_else
= 0;
1619 st
= next_statement ();
1625 case ST_WHERE_BLOCK
:
1626 parse_where_block ();
1631 accept_statement (st
);
1635 if (seen_empty_else
)
1638 ("ELSEWHERE statement at %C follows previous unmasked "
1643 if (new_st
.expr
== NULL
)
1644 seen_empty_else
= 1;
1646 d
= new_level (gfc_state_stack
->head
);
1648 d
->expr
= new_st
.expr
;
1650 accept_statement (st
);
1655 accept_statement (st
);
1659 gfc_error ("Unexpected %s statement in WHERE block at %C",
1660 gfc_ascii_statement (st
));
1661 reject_statement ();
1666 while (st
!= ST_END_WHERE
);
1672 /* Parse a FORALL block (not a simple FORALL statement). */
1675 parse_forall_block (void)
1681 accept_statement (ST_FORALL_BLOCK
);
1682 top
= gfc_state_stack
->tail
;
1684 push_state (&s
, COMP_FORALL
, gfc_new_block
);
1686 d
= add_statement ();
1687 d
->op
= EXEC_FORALL
;
1692 st
= next_statement ();
1697 case ST_POINTER_ASSIGNMENT
:
1700 accept_statement (st
);
1703 case ST_WHERE_BLOCK
:
1704 parse_where_block ();
1707 case ST_FORALL_BLOCK
:
1708 parse_forall_block ();
1712 accept_statement (st
);
1719 gfc_error ("Unexpected %s statement in FORALL block at %C",
1720 gfc_ascii_statement (st
));
1722 reject_statement ();
1726 while (st
!= ST_END_FORALL
);
1732 static gfc_statement
parse_executable (gfc_statement
);
1734 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
1737 parse_if_block (void)
1746 accept_statement (ST_IF_BLOCK
);
1748 top
= gfc_state_stack
->tail
;
1749 push_state (&s
, COMP_IF
, gfc_new_block
);
1751 new_st
.op
= EXEC_IF
;
1752 d
= add_statement ();
1754 d
->expr
= top
->expr
;
1760 st
= parse_executable (ST_NONE
);
1771 ("ELSE IF statement at %C cannot follow ELSE statement at %L",
1774 reject_statement ();
1778 d
= new_level (gfc_state_stack
->head
);
1780 d
->expr
= new_st
.expr
;
1782 accept_statement (st
);
1789 gfc_error ("Duplicate ELSE statements at %L and %C",
1791 reject_statement ();
1796 else_locus
= gfc_current_locus
;
1798 d
= new_level (gfc_state_stack
->head
);
1801 accept_statement (st
);
1809 unexpected_statement (st
);
1813 while (st
!= ST_ENDIF
);
1816 accept_statement (st
);
1820 /* Parse a SELECT block. */
1823 parse_select_block (void)
1829 accept_statement (ST_SELECT_CASE
);
1831 cp
= gfc_state_stack
->tail
;
1832 push_state (&s
, COMP_SELECT
, gfc_new_block
);
1834 /* Make sure that the next statement is a CASE or END SELECT. */
1837 st
= next_statement ();
1840 if (st
== ST_END_SELECT
)
1842 /* Empty SELECT CASE is OK. */
1843 accept_statement (st
);
1851 ("Expected a CASE or END SELECT statement following SELECT CASE "
1854 reject_statement ();
1857 /* At this point, we're got a nonempty select block. */
1858 cp
= new_level (cp
);
1861 accept_statement (st
);
1865 st
= parse_executable (ST_NONE
);
1872 cp
= new_level (gfc_state_stack
->head
);
1874 gfc_clear_new_st ();
1876 accept_statement (st
);
1882 /* Can't have an executable statement because of
1883 parse_executable(). */
1885 unexpected_statement (st
);
1889 while (st
!= ST_END_SELECT
);
1892 accept_statement (st
);
1896 /* Given a symbol, make sure it is not an iteration variable for a DO
1897 statement. This subroutine is called when the symbol is seen in a
1898 context that causes it to become redefined. If the symbol is an
1899 iterator, we generate an error message and return nonzero. */
1902 gfc_check_do_variable (gfc_symtree
*st
)
1906 for (s
=gfc_state_stack
; s
; s
= s
->previous
)
1907 if (s
->do_variable
== st
)
1909 gfc_error_now("Variable '%s' at %C cannot be redefined inside "
1910 "loop beginning at %L", st
->name
, &s
->head
->loc
);
1918 /* Checks to see if the current statement label closes an enddo.
1919 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
1920 an error) if it incorrectly closes an ENDDO. */
1923 check_do_closure (void)
1927 if (gfc_statement_label
== NULL
)
1930 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1931 if (p
->state
== COMP_DO
)
1935 return 0; /* No loops to close */
1937 if (p
->ext
.end_do_label
== gfc_statement_label
)
1940 if (p
== gfc_state_stack
)
1944 ("End of nonblock DO statement at %C is within another block");
1948 /* At this point, the label doesn't terminate the innermost loop.
1949 Make sure it doesn't terminate another one. */
1950 for (; p
; p
= p
->previous
)
1951 if (p
->state
== COMP_DO
&& p
->ext
.end_do_label
== gfc_statement_label
)
1953 gfc_error ("End of nonblock DO statement at %C is interwoven "
1954 "with another DO loop");
1962 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
1963 handled inside of parse_executable(), because they aren't really
1967 parse_do_block (void)
1974 s
.ext
.end_do_label
= new_st
.label
;
1976 if (new_st
.ext
.iterator
!= NULL
)
1977 stree
= new_st
.ext
.iterator
->var
->symtree
;
1981 accept_statement (ST_DO
);
1983 top
= gfc_state_stack
->tail
;
1984 push_state (&s
, COMP_DO
, gfc_new_block
);
1986 s
.do_variable
= stree
;
1988 top
->block
= new_level (top
);
1989 top
->block
->op
= EXEC_DO
;
1992 st
= parse_executable (ST_NONE
);
2000 if (s
.ext
.end_do_label
!= NULL
2001 && s
.ext
.end_do_label
!= gfc_statement_label
)
2003 ("Statement label in ENDDO at %C doesn't match DO label");
2005 if (gfc_statement_label
!= NULL
)
2007 new_st
.op
= EXEC_NOP
;
2012 case ST_IMPLIED_ENDDO
:
2016 unexpected_statement (st
);
2021 accept_statement (st
);
2025 /* Accept a series of executable statements. We return the first
2026 statement that doesn't fit to the caller. Any block statements are
2027 passed on to the correct handler, which usually passes the buck
2030 static gfc_statement
2031 parse_executable (gfc_statement st
)
2036 st
= next_statement ();
2038 for (;; st
= next_statement ())
2041 close_flag
= check_do_closure ();
2046 case ST_END_PROGRAM
:
2049 case ST_END_FUNCTION
:
2053 case ST_END_SUBROUTINE
:
2058 case ST_SELECT_CASE
:
2060 ("%s statement at %C cannot terminate a non-block DO loop",
2061 gfc_ascii_statement (st
));
2077 accept_statement (st
);
2078 if (close_flag
== 1)
2079 return ST_IMPLIED_ENDDO
;
2086 case ST_SELECT_CASE
:
2087 parse_select_block ();
2092 if (check_do_closure () == 1)
2093 return ST_IMPLIED_ENDDO
;
2096 case ST_WHERE_BLOCK
:
2097 parse_where_block ();
2100 case ST_FORALL_BLOCK
:
2101 parse_forall_block ();
2115 /* Parse a series of contained program units. */
2117 static void parse_progunit (gfc_statement
);
2120 /* Fix the symbols for sibling functions. These are incorrectly added to
2121 the child namespace as the parser didn't know about this procedure. */
2124 gfc_fixup_sibling_symbols (gfc_symbol
* sym
, gfc_namespace
* siblings
)
2128 gfc_symbol
*old_sym
;
2130 sym
->attr
.referenced
= 1;
2131 for (ns
= siblings
; ns
; ns
= ns
->sibling
)
2133 gfc_find_sym_tree (sym
->name
, ns
, 0, &st
);
2137 old_sym
= st
->n
.sym
;
2138 if ((old_sym
->attr
.flavor
== FL_PROCEDURE
2139 || old_sym
->ts
.type
== BT_UNKNOWN
)
2140 && old_sym
->ns
== ns
2141 && ! old_sym
->attr
.contained
)
2143 /* Replace it with the symbol from the parent namespace. */
2147 /* Free the old (local) symbol. */
2149 if (old_sym
->refs
== 0)
2150 gfc_free_symbol (old_sym
);
2153 /* Do the same for any contined procedures. */
2154 gfc_fixup_sibling_symbols (sym
, ns
->contained
);
2159 parse_contained (int module
)
2161 gfc_namespace
*ns
, *parent_ns
;
2162 gfc_state_data s1
, s2
;
2167 push_state (&s1
, COMP_CONTAINS
, NULL
);
2168 parent_ns
= gfc_current_ns
;
2172 gfc_current_ns
= gfc_get_namespace (parent_ns
);
2174 gfc_current_ns
->sibling
= parent_ns
->contained
;
2175 parent_ns
->contained
= gfc_current_ns
;
2177 st
= next_statement ();
2186 accept_statement (st
);
2189 (st
== ST_FUNCTION
) ? COMP_FUNCTION
: COMP_SUBROUTINE
,
2192 /* For internal procedures, create/update the symbol in the
2193 parent namespace. */
2197 if (gfc_get_symbol (gfc_new_block
->name
, parent_ns
, &sym
))
2199 ("Contained procedure '%s' at %C is already ambiguous",
2200 gfc_new_block
->name
);
2203 if (gfc_add_procedure (&sym
->attr
, PROC_INTERNAL
,
2204 &gfc_new_block
->declared_at
) ==
2207 if (st
== ST_FUNCTION
)
2208 gfc_add_function (&sym
->attr
,
2209 &gfc_new_block
->declared_at
);
2211 gfc_add_subroutine (&sym
->attr
,
2212 &gfc_new_block
->declared_at
);
2216 gfc_commit_symbols ();
2219 sym
= gfc_new_block
;
2221 /* Mark this as a contained function, so it isn't replaced
2222 by other module functions. */
2223 sym
->attr
.contained
= 1;
2224 sym
->attr
.referenced
= 1;
2226 parse_progunit (ST_NONE
);
2228 /* Fix up any sibling functions that refer to this one. */
2229 gfc_fixup_sibling_symbols (sym
, gfc_current_ns
);
2230 /* Or refer to any of its alternate entry points. */
2231 for (el
= gfc_current_ns
->entries
; el
; el
= el
->next
)
2232 gfc_fixup_sibling_symbols (el
->sym
, gfc_current_ns
);
2234 gfc_current_ns
->code
= s2
.head
;
2235 gfc_current_ns
= parent_ns
;
2240 /* These statements are associated with the end of the host
2242 case ST_END_FUNCTION
:
2244 case ST_END_PROGRAM
:
2245 case ST_END_SUBROUTINE
:
2246 accept_statement (st
);
2250 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
2251 gfc_ascii_statement (st
));
2252 reject_statement ();
2256 while (st
!= ST_END_FUNCTION
&& st
!= ST_END_SUBROUTINE
2257 && st
!= ST_END_MODULE
&& st
!= ST_END_PROGRAM
);
2259 /* The first namespace in the list is guaranteed to not have
2260 anything (worthwhile) in it. */
2262 gfc_current_ns
= parent_ns
;
2264 ns
= gfc_current_ns
->contained
;
2265 gfc_current_ns
->contained
= ns
->sibling
;
2266 gfc_free_namespace (ns
);
2272 /* Parse a PROGRAM, SUBROUTINE or FUNCTION unit. */
2275 parse_progunit (gfc_statement st
)
2280 st
= parse_spec (st
);
2290 accept_statement (st
);
2300 st
= parse_executable (st
);
2311 accept_statement (st
);
2318 unexpected_statement (st
);
2319 reject_statement ();
2320 st
= next_statement ();
2326 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
2327 if (p
->state
== COMP_CONTAINS
)
2330 if (gfc_find_state (COMP_MODULE
) == SUCCESS
)
2335 gfc_error ("CONTAINS statement at %C is already in a contained "
2337 st
= next_statement ();
2341 parse_contained (0);
2344 gfc_current_ns
->code
= gfc_state_stack
->head
;
2348 /* Come here to complain about a global symbol already in use as
2352 global_used (gfc_gsymbol
*sym
, locus
*where
)
2357 where
= &gfc_current_locus
;
2367 case GSYM_SUBROUTINE
:
2368 name
= "SUBROUTINE";
2373 case GSYM_BLOCK_DATA
:
2374 name
= "BLOCK DATA";
2380 gfc_internal_error ("gfc_gsymbol_type(): Bad type");
2384 gfc_error("Global name '%s' at %L is already being used as a %s at %L",
2385 gfc_new_block
->name
, where
, name
, &sym
->where
);
2389 /* Parse a block data program unit. */
2392 parse_block_data (void)
2395 static locus blank_locus
;
2396 static int blank_block
=0;
2399 gfc_current_ns
->proc_name
= gfc_new_block
;
2400 gfc_current_ns
->is_block_data
= 1;
2402 if (gfc_new_block
== NULL
)
2405 gfc_error ("Blank BLOCK DATA at %C conflicts with "
2406 "prior BLOCK DATA at %L", &blank_locus
);
2410 blank_locus
= gfc_current_locus
;
2415 s
= gfc_get_gsymbol (gfc_new_block
->name
);
2416 if (s
->type
!= GSYM_UNKNOWN
)
2417 global_used(s
, NULL
);
2420 s
->type
= GSYM_BLOCK_DATA
;
2421 s
->where
= gfc_current_locus
;
2425 st
= parse_spec (ST_NONE
);
2427 while (st
!= ST_END_BLOCK_DATA
)
2429 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
2430 gfc_ascii_statement (st
));
2431 reject_statement ();
2432 st
= next_statement ();
2437 /* Parse a module subprogram. */
2445 s
= gfc_get_gsymbol (gfc_new_block
->name
);
2446 if (s
->type
!= GSYM_UNKNOWN
)
2447 global_used(s
, NULL
);
2450 s
->type
= GSYM_MODULE
;
2451 s
->where
= gfc_current_locus
;
2454 st
= parse_spec (ST_NONE
);
2463 parse_contained (1);
2467 accept_statement (st
);
2471 gfc_error ("Unexpected %s statement in MODULE at %C",
2472 gfc_ascii_statement (st
));
2474 reject_statement ();
2475 st
= next_statement ();
2481 /* Add a procedure name to the global symbol table. */
2484 add_global_procedure (int sub
)
2488 s
= gfc_get_gsymbol(gfc_new_block
->name
);
2490 if (s
->type
!= GSYM_UNKNOWN
)
2491 global_used(s
, NULL
);
2494 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2495 s
->where
= gfc_current_locus
;
2500 /* Add a program to the global symbol table. */
2503 add_global_program (void)
2507 if (gfc_new_block
== NULL
)
2509 s
= gfc_get_gsymbol (gfc_new_block
->name
);
2511 if (s
->type
!= GSYM_UNKNOWN
)
2512 global_used(s
, NULL
);
2515 s
->type
= GSYM_PROGRAM
;
2516 s
->where
= gfc_current_locus
;
2521 /* Top level parser. */
2524 gfc_parse_file (void)
2526 int seen_program
, errors_before
, errors
;
2527 gfc_state_data top
, s
;
2531 top
.state
= COMP_NONE
;
2533 top
.previous
= NULL
;
2534 top
.head
= top
.tail
= NULL
;
2535 top
.do_variable
= NULL
;
2537 gfc_state_stack
= &top
;
2539 gfc_clear_new_st ();
2541 gfc_statement_label
= NULL
;
2543 if (setjmp (eof_buf
))
2544 return FAILURE
; /* Come here on unexpected EOF */
2550 st
= next_statement ();
2559 goto duplicate_main
;
2561 prog_locus
= gfc_current_locus
;
2563 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
2564 accept_statement (st
);
2565 add_global_program ();
2566 parse_progunit (ST_NONE
);
2570 add_global_procedure (1);
2571 push_state (&s
, COMP_SUBROUTINE
, gfc_new_block
);
2572 accept_statement (st
);
2573 parse_progunit (ST_NONE
);
2577 add_global_procedure (0);
2578 push_state (&s
, COMP_FUNCTION
, gfc_new_block
);
2579 accept_statement (st
);
2580 parse_progunit (ST_NONE
);
2584 push_state (&s
, COMP_BLOCK_DATA
, gfc_new_block
);
2585 accept_statement (st
);
2586 parse_block_data ();
2590 push_state (&s
, COMP_MODULE
, gfc_new_block
);
2591 accept_statement (st
);
2593 gfc_get_errors (NULL
, &errors_before
);
2597 /* Anything else starts a nameless main program block. */
2600 goto duplicate_main
;
2602 prog_locus
= gfc_current_locus
;
2604 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
2605 parse_progunit (st
);
2609 gfc_current_ns
->code
= s
.head
;
2611 gfc_resolve (gfc_current_ns
);
2613 /* Dump the parse tree if requested. */
2614 if (gfc_option
.verbose
)
2615 gfc_show_namespace (gfc_current_ns
);
2617 gfc_get_errors (NULL
, &errors
);
2618 if (s
.state
== COMP_MODULE
)
2620 gfc_dump_module (s
.sym
->name
, errors_before
== errors
);
2621 if (errors
== 0 && ! gfc_option
.flag_no_backend
)
2622 gfc_generate_module_code (gfc_current_ns
);
2626 if (errors
== 0 && ! gfc_option
.flag_no_backend
)
2627 gfc_generate_code (gfc_current_ns
);
2638 /* If we see a duplicate main program, shut down. If the second
2639 instance is an implied main program, ie data decls or executable
2640 statements, we're in for lots of errors. */
2641 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus
);
2642 reject_statement ();