2 Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 2, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING. If not, write to the Free
19 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
;
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
;
558 /* Pop the current state. */
564 gfc_state_stack
= gfc_state_stack
->previous
;
568 /* Try to find the given state in the state stack. */
571 gfc_find_state (gfc_compile_state state
)
575 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
576 if (p
->state
== state
)
579 return (p
== NULL
) ? FAILURE
: SUCCESS
;
583 /* Starts a new level in the statement list. */
586 new_level (gfc_code
* q
)
590 p
= q
->block
= gfc_get_code ();
592 gfc_state_stack
->head
= gfc_state_stack
->tail
= p
;
598 /* Add the current new_st code structure and adds it to the current
599 program unit. As a side-effect, it zeroes the new_st. */
609 p
->loc
= gfc_current_locus
;
611 if (gfc_state_stack
->head
== NULL
)
612 gfc_state_stack
->head
= p
;
614 gfc_state_stack
->tail
->next
= p
;
616 while (p
->next
!= NULL
)
619 gfc_state_stack
->tail
= p
;
627 /* Frees everything associated with the current statement. */
630 undo_new_statement (void)
632 gfc_free_statements (new_st
.block
);
633 gfc_free_statements (new_st
.next
);
634 gfc_free_statement (&new_st
);
639 /* If the current statement has a statement label, make sure that it
640 is allowed to, or should have one. */
643 check_statement_label (gfc_statement st
)
647 if (gfc_statement_label
== NULL
)
650 gfc_error ("FORMAT statement at %L does not have a statement label",
658 case ST_END_FUNCTION
:
659 case ST_END_SUBROUTINE
:
665 type
= ST_LABEL_TARGET
;
669 type
= ST_LABEL_FORMAT
;
672 /* Statement labels are not restricted from appearing on a
673 particular line. However, there are plenty of situations
674 where the resulting label can't be referenced. */
677 type
= ST_LABEL_BAD_TARGET
;
681 gfc_define_st_label (gfc_statement_label
, type
, &label_locus
);
683 new_st
.here
= gfc_statement_label
;
687 /* Figures out what the enclosing program unit is. This will be a
688 function, subroutine, program, block data or module. */
691 gfc_enclosing_unit (gfc_compile_state
* result
)
695 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
696 if (p
->state
== COMP_FUNCTION
|| p
->state
== COMP_SUBROUTINE
697 || p
->state
== COMP_MODULE
|| p
->state
== COMP_BLOCK_DATA
698 || p
->state
== COMP_PROGRAM
)
707 *result
= COMP_PROGRAM
;
712 /* Translate a statement enum to a string. */
715 gfc_ascii_statement (gfc_statement st
)
721 case ST_ARITHMETIC_IF
:
728 p
= "attribute declaration";
758 p
= "data declaration";
766 case ST_DERIVED_DECL
:
767 p
= "Derived type declaration";
781 case ST_END_BLOCK_DATA
:
782 p
= "END BLOCK DATA";
793 case ST_END_FUNCTION
:
799 case ST_END_INTERFACE
:
811 case ST_END_SUBROUTINE
:
812 p
= "END SUBROUTINE";
829 case ST_FORALL_BLOCK
: /* Fall through */
848 case ST_IMPLICIT_NONE
:
851 case ST_IMPLIED_ENDDO
:
852 p
= "implied END DO";
876 p
= "MODULE PROCEDURE";
911 case ST_WHERE_BLOCK
: /* Fall through */
921 case ST_POINTER_ASSIGNMENT
:
922 p
= "pointer assignment";
933 case ST_STATEMENT_FUNCTION
:
934 p
= "STATEMENT FUNCTION";
936 case ST_LABEL_ASSIGNMENT
:
937 p
= "LABEL ASSIGNMENT";
940 gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
947 /* Return the name of a compile state. */
950 gfc_state_name (gfc_compile_state state
)
962 case COMP_SUBROUTINE
:
968 case COMP_BLOCK_DATA
:
975 p
= "a DERIVED TYPE block";
978 p
= "an IF-THEN block";
984 p
= "a SELECT block";
987 p
= "a FORALL block";
993 p
= "a contained subprogram";
997 gfc_internal_error ("gfc_state_name(): Bad state");
1004 /* Do whatever is necessary to accept the last statement. */
1007 accept_statement (gfc_statement st
)
1016 case ST_IMPLICIT_NONE
:
1017 gfc_set_implicit_none ();
1021 gfc_set_implicit ();
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
1037 if (gfc_statement_label
!= NULL
)
1039 new_st
.op
= EXEC_NOP
;
1045 /* The end-of-program unit statements do not get the special
1046 marker and require a statement of some sort if they are a
1049 case ST_END_PROGRAM
:
1050 case ST_END_FUNCTION
:
1051 case ST_END_SUBROUTINE
:
1052 if (gfc_statement_label
!= NULL
)
1054 new_st
.op
= EXEC_RETURN
;
1062 gfc_symbol
*block_data
= NULL
;
1063 symbol_attribute attr
;
1065 gfc_get_symbol ("_BLOCK_DATA__", gfc_current_ns
, &block_data
);
1066 gfc_clear_attr (&attr
);
1067 attr
.flavor
= FL_PROCEDURE
;
1068 attr
.proc
= PROC_UNKNOWN
;
1069 attr
.subroutine
= 1;
1070 attr
.access
= ACCESS_PUBLIC
;
1071 block_data
->attr
= attr
;
1072 gfc_current_ns
->proc_name
= block_data
;
1073 gfc_commit_symbols ();
1087 gfc_commit_symbols ();
1088 gfc_warning_check ();
1089 gfc_clear_new_st ();
1093 /* Undo anything tentative that has been built for the current
1097 reject_statement (void)
1100 gfc_undo_symbols ();
1101 gfc_clear_warning ();
1102 undo_new_statement ();
1106 /* Generic complaint about an out of order statement. We also do
1107 whatever is necessary to clean up. */
1110 unexpected_statement (gfc_statement st
)
1113 gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st
));
1115 reject_statement ();
1119 /* Given the next statement seen by the matcher, make sure that it is
1120 in proper order with the last. This subroutine is initialized by
1121 calling it with an argument of ST_NONE. If there is a problem, we
1122 issue an error and return FAILURE. Otherwise we return SUCCESS.
1124 Individual parsers need to verify that the statements seen are
1125 valid before calling here, ie ENTRY statements are not allowed in
1126 INTERFACE blocks. The following diagram is taken from the standard:
1128 +---------------------------------------+
1129 | program subroutine function module |
1130 +---------------------------------------+
1132 |---------------------------------------+
1134 | +-----------+------------------+
1135 | | parameter | implicit |
1136 | +-----------+------------------+
1137 | format | | derived type |
1138 | entry | parameter | interface |
1139 | | data | specification |
1140 | | | statement func |
1141 | +-----------+------------------+
1142 | | data | executable |
1143 +--------+-----------+------------------+
1145 +---------------------------------------+
1146 | internal module/subprogram |
1147 +---------------------------------------+
1149 +---------------------------------------+
1156 { ORDER_START
, ORDER_USE
, ORDER_IMPLICIT_NONE
, ORDER_IMPLICIT
,
1157 ORDER_SPEC
, ORDER_EXEC
1160 gfc_statement last_statement
;
1166 verify_st_order (st_state
* p
, gfc_statement st
)
1172 p
->state
= ORDER_START
;
1176 if (p
->state
> ORDER_USE
)
1178 p
->state
= ORDER_USE
;
1181 case ST_IMPLICIT_NONE
:
1182 if (p
->state
> ORDER_IMPLICIT_NONE
)
1185 /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
1186 statement disqualifies a USE but not an IMPLICIT NONE.
1187 Duplicate IMPLICIT NONEs are caught when the implicit types
1190 p
->state
= ORDER_IMPLICIT_NONE
;
1194 if (p
->state
> ORDER_IMPLICIT
)
1196 p
->state
= ORDER_IMPLICIT
;
1201 if (p
->state
< ORDER_IMPLICIT_NONE
)
1202 p
->state
= ORDER_IMPLICIT_NONE
;
1206 if (p
->state
>= ORDER_EXEC
)
1208 if (p
->state
< ORDER_IMPLICIT
)
1209 p
->state
= ORDER_IMPLICIT
;
1213 if (p
->state
< ORDER_SPEC
)
1214 p
->state
= ORDER_SPEC
;
1219 case ST_DERIVED_DECL
:
1221 if (p
->state
>= ORDER_EXEC
)
1223 if (p
->state
< ORDER_SPEC
)
1224 p
->state
= ORDER_SPEC
;
1229 if (p
->state
< ORDER_EXEC
)
1230 p
->state
= ORDER_EXEC
;
1235 ("Unexpected %s statement in verify_st_order() at %C",
1236 gfc_ascii_statement (st
));
1239 /* All is well, record the statement in case we need it next time. */
1240 p
->where
= gfc_current_locus
;
1241 p
->last_statement
= st
;
1245 gfc_error ("%s statement at %C cannot follow %s statement at %L",
1246 gfc_ascii_statement (st
),
1247 gfc_ascii_statement (p
->last_statement
), &p
->where
);
1253 /* Handle an unexpected end of file. This is a show-stopper... */
1255 static void unexpected_eof (void) ATTRIBUTE_NORETURN
;
1258 unexpected_eof (void)
1262 gfc_error ("Unexpected end of file in '%s'", gfc_source_file
);
1264 /* Memory cleanup. Move to "second to last". */
1265 for (p
= gfc_state_stack
; p
&& p
->previous
&& p
->previous
->previous
;
1268 gfc_current_ns
->code
= (p
&& p
->previous
) ? p
->head
: NULL
;
1275 /* Parse a derived type. */
1278 parse_derived (void)
1280 int compiling_type
, seen_private
, seen_sequence
, seen_component
, error_flag
;
1287 accept_statement (ST_DERIVED_DECL
);
1288 push_state (&s
, COMP_DERIVED
, gfc_new_block
);
1290 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
1297 while (compiling_type
)
1299 st
= next_statement ();
1306 accept_statement (st
);
1313 if (!seen_component
)
1315 gfc_error ("Derived type definition at %C has no components");
1319 accept_statement (ST_END_TYPE
);
1323 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
1326 ("PRIVATE statement in TYPE at %C must be inside a MODULE");
1333 gfc_error ("PRIVATE statement at %C must precede "
1334 "structure components");
1341 gfc_error ("Duplicate PRIVATE statement at %C");
1345 s
.sym
->component_access
= ACCESS_PRIVATE
;
1346 accept_statement (ST_PRIVATE
);
1353 gfc_error ("SEQUENCE statement at %C must precede "
1354 "structure components");
1359 if (gfc_current_block ()->attr
.sequence
)
1360 gfc_warning ("SEQUENCE attribute at %C already specified in "
1365 gfc_error ("Duplicate SEQUENCE statement at %C");
1370 gfc_add_sequence (&gfc_current_block ()->attr
, NULL
);
1374 unexpected_statement (st
);
1379 /* Sanity checks on the structure. If the structure has the
1380 SEQUENCE attribute, then all component structures must also have
1382 if (error_flag
== 0 && gfc_current_block ()->attr
.sequence
)
1383 for (c
= gfc_current_block ()->components
; c
; c
= c
->next
)
1385 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.derived
->attr
.sequence
== 0)
1388 ("Component %s of SEQUENCE type declared at %C does not "
1389 "have the SEQUENCE attribute", c
->ts
.derived
->name
);
1398 /* Parse an interface. We must be able to deal with the possibility
1399 of recursive interfaces. The parse_spec() subroutine is mutually
1400 recursive with parse_interface(). */
1402 static gfc_statement
parse_spec (gfc_statement
);
1405 parse_interface (void)
1407 gfc_compile_state new_state
, current_state
;
1408 gfc_symbol
*prog_unit
, *sym
;
1409 gfc_interface_info save
;
1410 gfc_state_data s1
, s2
;
1413 accept_statement (ST_INTERFACE
);
1415 current_interface
.ns
= gfc_current_ns
;
1416 save
= current_interface
;
1418 sym
= (current_interface
.type
== INTERFACE_GENERIC
1419 || current_interface
.type
== INTERFACE_USER_OP
) ? gfc_new_block
: NULL
;
1421 push_state (&s1
, COMP_INTERFACE
, sym
);
1422 current_state
= COMP_NONE
;
1425 gfc_current_ns
= gfc_get_namespace (current_interface
.ns
);
1427 st
= next_statement ();
1434 new_state
= COMP_SUBROUTINE
;
1435 gfc_add_explicit_interface (gfc_new_block
, IFSRC_IFBODY
,
1436 gfc_new_block
->formal
, NULL
);
1440 new_state
= COMP_FUNCTION
;
1441 gfc_add_explicit_interface (gfc_new_block
, IFSRC_IFBODY
,
1442 gfc_new_block
->formal
, NULL
);
1445 case ST_MODULE_PROC
: /* The module procedure matcher makes
1446 sure the context is correct. */
1447 accept_statement (st
);
1448 gfc_free_namespace (gfc_current_ns
);
1451 case ST_END_INTERFACE
:
1452 gfc_free_namespace (gfc_current_ns
);
1453 gfc_current_ns
= current_interface
.ns
;
1457 gfc_error ("Unexpected %s statement in INTERFACE block at %C",
1458 gfc_ascii_statement (st
));
1459 reject_statement ();
1460 gfc_free_namespace (gfc_current_ns
);
1465 /* Make sure that a generic interface has only subroutines or
1466 functions and that the generic name has the right attribute. */
1467 if (current_interface
.type
== INTERFACE_GENERIC
)
1469 if (current_state
== COMP_NONE
)
1471 if (new_state
== COMP_FUNCTION
)
1472 gfc_add_function (&sym
->attr
, NULL
);
1473 if (new_state
== COMP_SUBROUTINE
)
1474 gfc_add_subroutine (&sym
->attr
, NULL
);
1476 current_state
= new_state
;
1480 if (new_state
!= current_state
)
1482 if (new_state
== COMP_SUBROUTINE
)
1484 ("SUBROUTINE at %C does not belong in a generic function "
1487 if (new_state
== COMP_FUNCTION
)
1489 ("FUNCTION at %C does not belong in a generic subroutine "
1495 push_state (&s2
, new_state
, gfc_new_block
);
1496 accept_statement (st
);
1497 prog_unit
= gfc_new_block
;
1498 prog_unit
->formal_ns
= gfc_current_ns
;
1501 /* Read data declaration statements. */
1502 st
= parse_spec (ST_NONE
);
1504 if (st
!= ST_END_SUBROUTINE
&& st
!= ST_END_FUNCTION
)
1506 gfc_error ("Unexpected %s statement at %C in INTERFACE body",
1507 gfc_ascii_statement (st
));
1508 reject_statement ();
1512 current_interface
= save
;
1513 gfc_add_interface (prog_unit
);
1523 /* Parse a set of specification statements. Returns the statement
1524 that doesn't fit. */
1526 static gfc_statement
1527 parse_spec (gfc_statement st
)
1531 verify_st_order (&ss
, ST_NONE
);
1533 st
= next_statement ();
1543 case ST_DATA
: /* Not allowed in interfaces */
1544 if (gfc_current_state () == COMP_INTERFACE
)
1550 case ST_IMPLICIT_NONE
:
1555 case ST_DERIVED_DECL
:
1557 if (verify_st_order (&ss
, st
) == FAILURE
)
1559 reject_statement ();
1560 st
= next_statement ();
1570 case ST_DERIVED_DECL
:
1576 if (gfc_current_state () != COMP_MODULE
)
1578 gfc_error ("%s statement must appear in a MODULE",
1579 gfc_ascii_statement (st
));
1583 if (gfc_current_ns
->default_access
!= ACCESS_UNKNOWN
)
1585 gfc_error ("%s statement at %C follows another accessibility "
1586 "specification", gfc_ascii_statement (st
));
1590 gfc_current_ns
->default_access
= (st
== ST_PUBLIC
)
1591 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
1599 accept_statement (st
);
1600 st
= next_statement ();
1611 /* Parse a WHERE block, (not a simple WHERE statement). */
1614 parse_where_block (void)
1616 int seen_empty_else
;
1621 accept_statement (ST_WHERE_BLOCK
);
1622 top
= gfc_state_stack
->tail
;
1624 push_state (&s
, COMP_WHERE
, gfc_new_block
);
1626 d
= add_statement ();
1627 d
->expr
= top
->expr
;
1633 seen_empty_else
= 0;
1637 st
= next_statement ();
1643 case ST_WHERE_BLOCK
:
1644 parse_where_block ();
1649 accept_statement (st
);
1653 if (seen_empty_else
)
1656 ("ELSEWHERE statement at %C follows previous unmasked "
1661 if (new_st
.expr
== NULL
)
1662 seen_empty_else
= 1;
1664 d
= new_level (gfc_state_stack
->head
);
1666 d
->expr
= new_st
.expr
;
1668 accept_statement (st
);
1673 accept_statement (st
);
1677 gfc_error ("Unexpected %s statement in WHERE block at %C",
1678 gfc_ascii_statement (st
));
1679 reject_statement ();
1684 while (st
!= ST_END_WHERE
);
1690 /* Parse a FORALL block (not a simple FORALL statement). */
1693 parse_forall_block (void)
1699 accept_statement (ST_FORALL_BLOCK
);
1700 top
= gfc_state_stack
->tail
;
1702 push_state (&s
, COMP_FORALL
, gfc_new_block
);
1704 d
= add_statement ();
1705 d
->op
= EXEC_FORALL
;
1710 st
= next_statement ();
1715 case ST_POINTER_ASSIGNMENT
:
1718 accept_statement (st
);
1721 case ST_WHERE_BLOCK
:
1722 parse_where_block ();
1725 case ST_FORALL_BLOCK
:
1726 parse_forall_block ();
1730 accept_statement (st
);
1737 gfc_error ("Unexpected %s statement in FORALL block at %C",
1738 gfc_ascii_statement (st
));
1740 reject_statement ();
1744 while (st
!= ST_END_FORALL
);
1750 static gfc_statement
parse_executable (gfc_statement
);
1752 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
1755 parse_if_block (void)
1764 accept_statement (ST_IF_BLOCK
);
1766 top
= gfc_state_stack
->tail
;
1767 push_state (&s
, COMP_IF
, gfc_new_block
);
1769 new_st
.op
= EXEC_IF
;
1770 d
= add_statement ();
1772 d
->expr
= top
->expr
;
1778 st
= parse_executable (ST_NONE
);
1789 ("ELSE IF statement at %C cannot follow ELSE statement at %L",
1792 reject_statement ();
1796 d
= new_level (gfc_state_stack
->head
);
1798 d
->expr
= new_st
.expr
;
1800 accept_statement (st
);
1807 gfc_error ("Duplicate ELSE statements at %L and %C",
1809 reject_statement ();
1814 else_locus
= gfc_current_locus
;
1816 d
= new_level (gfc_state_stack
->head
);
1819 accept_statement (st
);
1827 unexpected_statement (st
);
1831 while (st
!= ST_ENDIF
);
1834 accept_statement (st
);
1838 /* Parse a SELECT block. */
1841 parse_select_block (void)
1847 accept_statement (ST_SELECT_CASE
);
1849 cp
= gfc_state_stack
->tail
;
1850 push_state (&s
, COMP_SELECT
, gfc_new_block
);
1852 /* Make sure that the next statement is a CASE or END SELECT. */
1855 st
= next_statement ();
1858 if (st
== ST_END_SELECT
)
1860 /* Empty SELECT CASE is OK. */
1861 accept_statement (st
);
1869 ("Expected a CASE or END SELECT statement following SELECT CASE "
1872 reject_statement ();
1875 /* At this point, we're got a nonempty select block. */
1876 cp
= new_level (cp
);
1879 accept_statement (st
);
1883 st
= parse_executable (ST_NONE
);
1890 cp
= new_level (gfc_state_stack
->head
);
1892 gfc_clear_new_st ();
1894 accept_statement (st
);
1900 /* Can't have an executable statement because of
1901 parse_executable(). */
1903 unexpected_statement (st
);
1907 while (st
!= ST_END_SELECT
);
1910 accept_statement (st
);
1914 /* Checks to see if the current statement label closes an enddo.
1915 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
1916 an error) if it incorrectly closes an ENDDO. */
1919 check_do_closure (void)
1923 if (gfc_statement_label
== NULL
)
1926 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1927 if (p
->state
== COMP_DO
)
1931 return 0; /* No loops to close */
1933 if (p
->ext
.end_do_label
== gfc_statement_label
)
1936 if (p
== gfc_state_stack
)
1940 ("End of nonblock DO statement at %C is within another block");
1944 /* At this point, the label doesn't terminate the innermost loop.
1945 Make sure it doesn't terminate another one. */
1946 for (; p
; p
= p
->previous
)
1947 if (p
->state
== COMP_DO
&& p
->ext
.end_do_label
== gfc_statement_label
)
1949 gfc_error ("End of nonblock DO statement at %C is interwoven "
1950 "with another DO loop");
1958 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
1959 handled inside of parse_executable(), because they aren't really
1963 parse_do_block (void)
1969 s
.ext
.end_do_label
= new_st
.label
;
1971 accept_statement (ST_DO
);
1973 top
= gfc_state_stack
->tail
;
1974 push_state (&s
, COMP_DO
, gfc_new_block
);
1976 top
->block
= new_level (top
);
1977 top
->block
->op
= EXEC_DO
;
1980 st
= parse_executable (ST_NONE
);
1988 if (s
.ext
.end_do_label
!= NULL
1989 && s
.ext
.end_do_label
!= gfc_statement_label
)
1991 ("Statement label in ENDDO at %C doesn't match DO label");
1994 case ST_IMPLIED_ENDDO
:
1998 unexpected_statement (st
);
2003 accept_statement (st
);
2007 /* Accept a series of executable statements. We return the first
2008 statement that doesn't fit to the caller. Any block statements are
2009 passed on to the correct handler, which usually passes the buck
2012 static gfc_statement
2013 parse_executable (gfc_statement st
)
2018 st
= next_statement ();
2020 for (;; st
= next_statement ())
2023 close_flag
= check_do_closure ();
2028 case ST_END_PROGRAM
:
2031 case ST_END_FUNCTION
:
2035 case ST_END_SUBROUTINE
:
2040 case ST_SELECT_CASE
:
2042 ("%s statement at %C cannot terminate a non-block DO loop",
2043 gfc_ascii_statement (st
));
2059 accept_statement (st
);
2060 if (close_flag
== 1)
2061 return ST_IMPLIED_ENDDO
;
2068 case ST_SELECT_CASE
:
2069 parse_select_block ();
2074 if (check_do_closure () == 1)
2075 return ST_IMPLIED_ENDDO
;
2078 case ST_WHERE_BLOCK
:
2079 parse_where_block ();
2082 case ST_FORALL_BLOCK
:
2083 parse_forall_block ();
2097 /* Parse a series of contained program units. */
2099 static void parse_progunit (gfc_statement
);
2102 /* Fix the symbols for sibling functions. These are incorrectly added to
2103 the child namespace as the parser didn't know about this procedure. */
2106 gfc_fixup_sibling_symbols (gfc_symbol
* sym
, gfc_namespace
* siblings
)
2110 gfc_symbol
*old_sym
;
2112 for (ns
= siblings
; ns
; ns
= ns
->sibling
)
2114 gfc_find_sym_tree (sym
->name
, ns
, 0, &st
);
2118 old_sym
= st
->n
.sym
;
2119 if (old_sym
->attr
.flavor
== FL_PROCEDURE
&& old_sym
->ns
== ns
2120 && ! old_sym
->attr
.contained
)
2122 /* Replace it with the symbol from the parent namespace. */
2126 /* Free the old (local) symbol. */
2128 if (old_sym
->refs
== 0)
2129 gfc_free_symbol (old_sym
);
2132 /* Do the same for any contined procedures. */
2133 gfc_fixup_sibling_symbols (sym
, ns
->contained
);
2138 parse_contained (int module
)
2140 gfc_namespace
*ns
, *parent_ns
;
2141 gfc_state_data s1
, s2
;
2145 push_state (&s1
, COMP_CONTAINS
, NULL
);
2146 parent_ns
= gfc_current_ns
;
2150 gfc_current_ns
= gfc_get_namespace (parent_ns
);
2152 gfc_current_ns
->sibling
= parent_ns
->contained
;
2153 parent_ns
->contained
= gfc_current_ns
;
2155 st
= next_statement ();
2164 accept_statement (st
);
2167 (st
== ST_FUNCTION
) ? COMP_FUNCTION
: COMP_SUBROUTINE
,
2170 /* For internal procedures, create/update the symbol in the
2171 * parent namespace */
2175 if (gfc_get_symbol (gfc_new_block
->name
, parent_ns
, &sym
))
2177 ("Contained procedure '%s' at %C is already ambiguous",
2178 gfc_new_block
->name
);
2181 if (gfc_add_procedure (&sym
->attr
, PROC_INTERNAL
,
2182 &gfc_new_block
->declared_at
) ==
2185 if (st
== ST_FUNCTION
)
2186 gfc_add_function (&sym
->attr
,
2187 &gfc_new_block
->declared_at
);
2189 gfc_add_subroutine (&sym
->attr
,
2190 &gfc_new_block
->declared_at
);
2194 gfc_commit_symbols ();
2197 sym
= gfc_new_block
;
2199 /* Mark this as a contained function, so it isn't replaced
2200 by other module functions. */
2201 sym
->attr
.contained
= 1;
2203 /* Fix up any sibling functions that refer to this one. */
2204 gfc_fixup_sibling_symbols (sym
, gfc_current_ns
);
2206 parse_progunit (ST_NONE
);
2208 gfc_current_ns
->code
= s2
.head
;
2209 gfc_current_ns
= parent_ns
;
2214 /* These statements are associated with the end of the host
2216 case ST_END_FUNCTION
:
2218 case ST_END_PROGRAM
:
2219 case ST_END_SUBROUTINE
:
2220 accept_statement (st
);
2224 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
2225 gfc_ascii_statement (st
));
2226 reject_statement ();
2230 while (st
!= ST_END_FUNCTION
&& st
!= ST_END_SUBROUTINE
2231 && st
!= ST_END_MODULE
&& st
!= ST_END_PROGRAM
);
2233 /* The first namespace in the list is guaranteed to not have
2234 anything (worthwhile) in it. */
2236 gfc_current_ns
= parent_ns
;
2238 ns
= gfc_current_ns
->contained
;
2239 gfc_current_ns
->contained
= ns
->sibling
;
2240 gfc_free_namespace (ns
);
2246 /* Parse a PROGRAM, SUBROUTINE or FUNCTION unit. */
2249 parse_progunit (gfc_statement st
)
2254 st
= parse_spec (st
);
2264 accept_statement (st
);
2274 st
= parse_executable (st
);
2285 accept_statement (st
);
2292 unexpected_statement (st
);
2293 reject_statement ();
2294 st
= next_statement ();
2300 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
2301 if (p
->state
== COMP_CONTAINS
)
2304 if (gfc_find_state (COMP_MODULE
) == SUCCESS
)
2309 gfc_error ("CONTAINS statement at %C is already in a contained "
2311 st
= next_statement ();
2315 parse_contained (0);
2318 gfc_current_ns
->code
= gfc_state_stack
->head
;
2322 /* Parse a block data program unit. */
2325 parse_block_data (void)
2329 st
= parse_spec (ST_NONE
);
2331 while (st
!= ST_END_BLOCK_DATA
)
2333 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
2334 gfc_ascii_statement (st
));
2335 reject_statement ();
2336 st
= next_statement ();
2341 /* Parse a module subprogram. */
2348 st
= parse_spec (ST_NONE
);
2357 parse_contained (1);
2361 accept_statement (st
);
2365 gfc_error ("Unexpected %s statement in MODULE at %C",
2366 gfc_ascii_statement (st
));
2368 reject_statement ();
2369 st
= next_statement ();
2375 /* Top level parser. */
2378 gfc_parse_file (void)
2380 int seen_program
, errors_before
, errors
;
2381 gfc_state_data top
, s
;
2385 top
.state
= COMP_NONE
;
2387 top
.previous
= NULL
;
2388 top
.head
= top
.tail
= NULL
;
2390 gfc_state_stack
= &top
;
2392 gfc_clear_new_st ();
2394 gfc_statement_label
= NULL
;
2397 return FAILURE
; /* Come here on unexpected EOF */
2403 st
= next_statement ();
2412 goto duplicate_main
;
2414 prog_locus
= gfc_current_locus
;
2416 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
2417 accept_statement (st
);
2418 parse_progunit (ST_NONE
);
2422 push_state (&s
, COMP_SUBROUTINE
, gfc_new_block
);
2423 accept_statement (st
);
2424 parse_progunit (ST_NONE
);
2428 push_state (&s
, COMP_FUNCTION
, gfc_new_block
);
2429 accept_statement (st
);
2430 parse_progunit (ST_NONE
);
2434 push_state (&s
, COMP_BLOCK_DATA
, gfc_new_block
);
2435 accept_statement (st
);
2436 parse_block_data ();
2440 push_state (&s
, COMP_MODULE
, gfc_new_block
);
2441 accept_statement (st
);
2443 gfc_get_errors (NULL
, &errors_before
);
2447 /* Anything else starts a nameless main program block. */
2450 goto duplicate_main
;
2452 prog_locus
= gfc_current_locus
;
2454 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
2455 parse_progunit (st
);
2459 gfc_current_ns
->code
= s
.head
;
2461 gfc_resolve (gfc_current_ns
);
2463 /* Dump the parse tree if requested. */
2464 if (gfc_option
.verbose
)
2465 gfc_show_namespace (gfc_current_ns
);
2467 gfc_get_errors (NULL
, &errors
);
2468 if (s
.state
== COMP_MODULE
)
2470 gfc_dump_module (s
.sym
->name
, errors_before
== errors
);
2471 if (errors
== 0 && ! gfc_option
.flag_no_backend
)
2472 gfc_generate_module_code (gfc_current_ns
);
2476 if (errors
== 0 && ! gfc_option
.flag_no_backend
)
2477 gfc_generate_code (gfc_current_ns
);
2488 /* If we see a duplicate main program, shut down. If the second
2489 instance is an implied main program, ie data decls or executable
2490 statements, we're in for lots of errors. */
2491 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus
);
2492 reject_statement ();