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);
483 if (gfc_option
.warn_line_truncation
484 && gfc_current_locus
.lb
->truncated
)
485 gfc_warning_now ("Line truncated at %C");
490 gfc_skip_comments ();
499 (gfc_current_form
== FORM_FIXED
) ? next_fixed () : next_free ();
505 gfc_buffer_error (0);
508 check_statement_label (st
);
514 /****************************** Parser ***********************************/
516 /* The parser subroutines are of type 'try' that fail if the file ends
519 /* Macros that expand to case-labels for various classes of
520 statements. Start with executable statements that directly do
523 #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
524 case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
525 case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
526 case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
527 case ST_PAUSE: case ST_STOP: case ST_WRITE: case ST_ASSIGNMENT: \
528 case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
529 case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: case ST_LABEL_ASSIGNMENT
531 /* Statements that mark other executable statements. */
533 #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: case ST_IF_BLOCK: \
534 case ST_WHERE_BLOCK: case ST_SELECT_CASE
536 /* Declaration statements */
538 #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
539 case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
540 case ST_TYPE: case ST_INTERFACE
542 /* Block end statements. Errors associated with interchanging these
543 are detected in gfc_match_end(). */
545 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
546 case ST_END_PROGRAM: case ST_END_SUBROUTINE
549 /* Push a new state onto the stack. */
552 push_state (gfc_state_data
* p
, gfc_compile_state new_state
, gfc_symbol
* sym
)
555 p
->state
= new_state
;
556 p
->previous
= gfc_state_stack
;
558 p
->head
= p
->tail
= NULL
;
559 p
->do_variable
= NULL
;
565 /* Pop the current state. */
571 gfc_state_stack
= gfc_state_stack
->previous
;
575 /* Try to find the given state in the state stack. */
578 gfc_find_state (gfc_compile_state state
)
582 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
583 if (p
->state
== state
)
586 return (p
== NULL
) ? FAILURE
: SUCCESS
;
590 /* Starts a new level in the statement list. */
593 new_level (gfc_code
* q
)
597 p
= q
->block
= gfc_get_code ();
599 gfc_state_stack
->head
= gfc_state_stack
->tail
= p
;
605 /* Add the current new_st code structure and adds it to the current
606 program unit. As a side-effect, it zeroes the new_st. */
616 p
->loc
= gfc_current_locus
;
618 if (gfc_state_stack
->head
== NULL
)
619 gfc_state_stack
->head
= p
;
621 gfc_state_stack
->tail
->next
= p
;
623 while (p
->next
!= NULL
)
626 gfc_state_stack
->tail
= p
;
634 /* Frees everything associated with the current statement. */
637 undo_new_statement (void)
639 gfc_free_statements (new_st
.block
);
640 gfc_free_statements (new_st
.next
);
641 gfc_free_statement (&new_st
);
646 /* If the current statement has a statement label, make sure that it
647 is allowed to, or should have one. */
650 check_statement_label (gfc_statement st
)
654 if (gfc_statement_label
== NULL
)
657 gfc_error ("FORMAT statement at %L does not have a statement label",
665 case ST_END_FUNCTION
:
666 case ST_END_SUBROUTINE
:
672 type
= ST_LABEL_TARGET
;
676 type
= ST_LABEL_FORMAT
;
679 /* Statement labels are not restricted from appearing on a
680 particular line. However, there are plenty of situations
681 where the resulting label can't be referenced. */
684 type
= ST_LABEL_BAD_TARGET
;
688 gfc_define_st_label (gfc_statement_label
, type
, &label_locus
);
690 new_st
.here
= gfc_statement_label
;
694 /* Figures out what the enclosing program unit is. This will be a
695 function, subroutine, program, block data or module. */
698 gfc_enclosing_unit (gfc_compile_state
* result
)
702 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
703 if (p
->state
== COMP_FUNCTION
|| p
->state
== COMP_SUBROUTINE
704 || p
->state
== COMP_MODULE
|| p
->state
== COMP_BLOCK_DATA
705 || p
->state
== COMP_PROGRAM
)
714 *result
= COMP_PROGRAM
;
719 /* Translate a statement enum to a string. */
722 gfc_ascii_statement (gfc_statement st
)
728 case ST_ARITHMETIC_IF
:
735 p
= "attribute declaration";
765 p
= "data declaration";
773 case ST_DERIVED_DECL
:
774 p
= "Derived type declaration";
788 case ST_END_BLOCK_DATA
:
789 p
= "END BLOCK DATA";
800 case ST_END_FUNCTION
:
806 case ST_END_INTERFACE
:
818 case ST_END_SUBROUTINE
:
819 p
= "END SUBROUTINE";
836 case ST_FORALL_BLOCK
: /* Fall through */
855 case ST_IMPLICIT_NONE
:
858 case ST_IMPLIED_ENDDO
:
859 p
= "implied END DO";
883 p
= "MODULE PROCEDURE";
918 case ST_WHERE_BLOCK
: /* Fall through */
928 case ST_POINTER_ASSIGNMENT
:
929 p
= "pointer assignment";
940 case ST_STATEMENT_FUNCTION
:
941 p
= "STATEMENT FUNCTION";
943 case ST_LABEL_ASSIGNMENT
:
944 p
= "LABEL ASSIGNMENT";
947 gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
954 /* Return the name of a compile state. */
957 gfc_state_name (gfc_compile_state state
)
969 case COMP_SUBROUTINE
:
975 case COMP_BLOCK_DATA
:
982 p
= "a DERIVED TYPE block";
985 p
= "an IF-THEN block";
991 p
= "a SELECT block";
994 p
= "a FORALL block";
1000 p
= "a contained subprogram";
1004 gfc_internal_error ("gfc_state_name(): Bad state");
1011 /* Do whatever is necessary to accept the last statement. */
1014 accept_statement (gfc_statement st
)
1023 case ST_IMPLICIT_NONE
:
1024 gfc_set_implicit_none ();
1033 gfc_current_ns
->proc_name
= gfc_new_block
;
1036 /* If the statement is the end of a block, lay down a special code
1037 that allows a branch to the end of the block from within the
1042 if (gfc_statement_label
!= NULL
)
1044 new_st
.op
= EXEC_NOP
;
1050 /* The end-of-program unit statements do not get the special
1051 marker and require a statement of some sort if they are a
1054 case ST_END_PROGRAM
:
1055 case ST_END_FUNCTION
:
1056 case ST_END_SUBROUTINE
:
1057 if (gfc_statement_label
!= NULL
)
1059 new_st
.op
= EXEC_RETURN
;
1075 gfc_commit_symbols ();
1076 gfc_warning_check ();
1077 gfc_clear_new_st ();
1081 /* Undo anything tentative that has been built for the current
1085 reject_statement (void)
1088 gfc_undo_symbols ();
1089 gfc_clear_warning ();
1090 undo_new_statement ();
1094 /* Generic complaint about an out of order statement. We also do
1095 whatever is necessary to clean up. */
1098 unexpected_statement (gfc_statement st
)
1101 gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st
));
1103 reject_statement ();
1107 /* Given the next statement seen by the matcher, make sure that it is
1108 in proper order with the last. This subroutine is initialized by
1109 calling it with an argument of ST_NONE. If there is a problem, we
1110 issue an error and return FAILURE. Otherwise we return SUCCESS.
1112 Individual parsers need to verify that the statements seen are
1113 valid before calling here, ie ENTRY statements are not allowed in
1114 INTERFACE blocks. The following diagram is taken from the standard:
1116 +---------------------------------------+
1117 | program subroutine function module |
1118 +---------------------------------------+
1120 |---------------------------------------+
1122 | +-----------+------------------+
1123 | | parameter | implicit |
1124 | +-----------+------------------+
1125 | format | | derived type |
1126 | entry | parameter | interface |
1127 | | data | specification |
1128 | | | statement func |
1129 | +-----------+------------------+
1130 | | data | executable |
1131 +--------+-----------+------------------+
1133 +---------------------------------------+
1134 | internal module/subprogram |
1135 +---------------------------------------+
1137 +---------------------------------------+
1144 { ORDER_START
, ORDER_USE
, ORDER_IMPLICIT_NONE
, ORDER_IMPLICIT
,
1145 ORDER_SPEC
, ORDER_EXEC
1148 gfc_statement last_statement
;
1154 verify_st_order (st_state
* p
, gfc_statement st
)
1160 p
->state
= ORDER_START
;
1164 if (p
->state
> ORDER_USE
)
1166 p
->state
= ORDER_USE
;
1169 case ST_IMPLICIT_NONE
:
1170 if (p
->state
> ORDER_IMPLICIT_NONE
)
1173 /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
1174 statement disqualifies a USE but not an IMPLICIT NONE.
1175 Duplicate IMPLICIT NONEs are caught when the implicit types
1178 p
->state
= ORDER_IMPLICIT_NONE
;
1182 if (p
->state
> ORDER_IMPLICIT
)
1184 p
->state
= ORDER_IMPLICIT
;
1189 if (p
->state
< ORDER_IMPLICIT_NONE
)
1190 p
->state
= ORDER_IMPLICIT_NONE
;
1194 if (p
->state
>= ORDER_EXEC
)
1196 if (p
->state
< ORDER_IMPLICIT
)
1197 p
->state
= ORDER_IMPLICIT
;
1201 if (p
->state
< ORDER_SPEC
)
1202 p
->state
= ORDER_SPEC
;
1207 case ST_DERIVED_DECL
:
1209 if (p
->state
>= ORDER_EXEC
)
1211 if (p
->state
< ORDER_SPEC
)
1212 p
->state
= ORDER_SPEC
;
1217 if (p
->state
< ORDER_EXEC
)
1218 p
->state
= ORDER_EXEC
;
1223 ("Unexpected %s statement in verify_st_order() at %C",
1224 gfc_ascii_statement (st
));
1227 /* All is well, record the statement in case we need it next time. */
1228 p
->where
= gfc_current_locus
;
1229 p
->last_statement
= st
;
1233 gfc_error ("%s statement at %C cannot follow %s statement at %L",
1234 gfc_ascii_statement (st
),
1235 gfc_ascii_statement (p
->last_statement
), &p
->where
);
1241 /* Handle an unexpected end of file. This is a show-stopper... */
1243 static void unexpected_eof (void) ATTRIBUTE_NORETURN
;
1246 unexpected_eof (void)
1250 gfc_error ("Unexpected end of file in '%s'", gfc_source_file
);
1252 /* Memory cleanup. Move to "second to last". */
1253 for (p
= gfc_state_stack
; p
&& p
->previous
&& p
->previous
->previous
;
1256 gfc_current_ns
->code
= (p
&& p
->previous
) ? p
->head
: NULL
;
1259 longjmp (eof_buf
, 1);
1263 /* Parse a derived type. */
1266 parse_derived (void)
1268 int compiling_type
, seen_private
, seen_sequence
, seen_component
, error_flag
;
1275 accept_statement (ST_DERIVED_DECL
);
1276 push_state (&s
, COMP_DERIVED
, gfc_new_block
);
1278 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
1285 while (compiling_type
)
1287 st
= next_statement ();
1294 accept_statement (st
);
1301 if (!seen_component
)
1303 gfc_error ("Derived type definition at %C has no components");
1307 accept_statement (ST_END_TYPE
);
1311 if (gfc_find_state (COMP_MODULE
) == FAILURE
)
1314 ("PRIVATE statement in TYPE at %C must be inside a MODULE");
1321 gfc_error ("PRIVATE statement at %C must precede "
1322 "structure components");
1329 gfc_error ("Duplicate PRIVATE statement at %C");
1333 s
.sym
->component_access
= ACCESS_PRIVATE
;
1334 accept_statement (ST_PRIVATE
);
1341 gfc_error ("SEQUENCE statement at %C must precede "
1342 "structure components");
1347 if (gfc_current_block ()->attr
.sequence
)
1348 gfc_warning ("SEQUENCE attribute at %C already specified in "
1353 gfc_error ("Duplicate SEQUENCE statement at %C");
1358 gfc_add_sequence (&gfc_current_block ()->attr
,
1359 gfc_current_block ()->name
, NULL
);
1363 unexpected_statement (st
);
1368 /* Sanity checks on the structure. If the structure has the
1369 SEQUENCE attribute, then all component structures must also have
1371 if (error_flag
== 0 && gfc_current_block ()->attr
.sequence
)
1372 for (c
= gfc_current_block ()->components
; c
; c
= c
->next
)
1374 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.derived
->attr
.sequence
== 0)
1377 ("Component %s of SEQUENCE type declared at %C does not "
1378 "have the SEQUENCE attribute", c
->ts
.derived
->name
);
1387 /* Parse an interface. We must be able to deal with the possibility
1388 of recursive interfaces. The parse_spec() subroutine is mutually
1389 recursive with parse_interface(). */
1391 static gfc_statement
parse_spec (gfc_statement
);
1394 parse_interface (void)
1396 gfc_compile_state new_state
, current_state
;
1397 gfc_symbol
*prog_unit
, *sym
;
1398 gfc_interface_info save
;
1399 gfc_state_data s1
, s2
;
1402 accept_statement (ST_INTERFACE
);
1404 current_interface
.ns
= gfc_current_ns
;
1405 save
= current_interface
;
1407 sym
= (current_interface
.type
== INTERFACE_GENERIC
1408 || current_interface
.type
== INTERFACE_USER_OP
) ? gfc_new_block
: NULL
;
1410 push_state (&s1
, COMP_INTERFACE
, sym
);
1411 current_state
= COMP_NONE
;
1414 gfc_current_ns
= gfc_get_namespace (current_interface
.ns
, 0);
1416 st
= next_statement ();
1423 new_state
= COMP_SUBROUTINE
;
1424 gfc_add_explicit_interface (gfc_new_block
, IFSRC_IFBODY
,
1425 gfc_new_block
->formal
, NULL
);
1429 new_state
= COMP_FUNCTION
;
1430 gfc_add_explicit_interface (gfc_new_block
, IFSRC_IFBODY
,
1431 gfc_new_block
->formal
, NULL
);
1434 case ST_MODULE_PROC
: /* The module procedure matcher makes
1435 sure the context is correct. */
1436 accept_statement (st
);
1437 gfc_free_namespace (gfc_current_ns
);
1440 case ST_END_INTERFACE
:
1441 gfc_free_namespace (gfc_current_ns
);
1442 gfc_current_ns
= current_interface
.ns
;
1446 gfc_error ("Unexpected %s statement in INTERFACE block at %C",
1447 gfc_ascii_statement (st
));
1448 reject_statement ();
1449 gfc_free_namespace (gfc_current_ns
);
1454 /* Make sure that a generic interface has only subroutines or
1455 functions and that the generic name has the right attribute. */
1456 if (current_interface
.type
== INTERFACE_GENERIC
)
1458 if (current_state
== COMP_NONE
)
1460 if (new_state
== COMP_FUNCTION
)
1461 gfc_add_function (&sym
->attr
, sym
->name
, NULL
);
1462 else if (new_state
== COMP_SUBROUTINE
)
1463 gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
);
1465 current_state
= new_state
;
1469 if (new_state
!= current_state
)
1471 if (new_state
== COMP_SUBROUTINE
)
1473 ("SUBROUTINE at %C does not belong in a generic function "
1476 if (new_state
== COMP_FUNCTION
)
1478 ("FUNCTION at %C does not belong in a generic subroutine "
1484 push_state (&s2
, new_state
, gfc_new_block
);
1485 accept_statement (st
);
1486 prog_unit
= gfc_new_block
;
1487 prog_unit
->formal_ns
= gfc_current_ns
;
1490 /* Read data declaration statements. */
1491 st
= parse_spec (ST_NONE
);
1493 if (st
!= ST_END_SUBROUTINE
&& st
!= ST_END_FUNCTION
)
1495 gfc_error ("Unexpected %s statement at %C in INTERFACE body",
1496 gfc_ascii_statement (st
));
1497 reject_statement ();
1501 current_interface
= save
;
1502 gfc_add_interface (prog_unit
);
1512 /* Parse a set of specification statements. Returns the statement
1513 that doesn't fit. */
1515 static gfc_statement
1516 parse_spec (gfc_statement st
)
1520 verify_st_order (&ss
, ST_NONE
);
1522 st
= next_statement ();
1532 case ST_DATA
: /* Not allowed in interfaces */
1533 if (gfc_current_state () == COMP_INTERFACE
)
1539 case ST_IMPLICIT_NONE
:
1544 case ST_DERIVED_DECL
:
1546 if (verify_st_order (&ss
, st
) == FAILURE
)
1548 reject_statement ();
1549 st
= next_statement ();
1559 case ST_DERIVED_DECL
:
1565 if (gfc_current_state () != COMP_MODULE
)
1567 gfc_error ("%s statement must appear in a MODULE",
1568 gfc_ascii_statement (st
));
1572 if (gfc_current_ns
->default_access
!= ACCESS_UNKNOWN
)
1574 gfc_error ("%s statement at %C follows another accessibility "
1575 "specification", gfc_ascii_statement (st
));
1579 gfc_current_ns
->default_access
= (st
== ST_PUBLIC
)
1580 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
1588 accept_statement (st
);
1589 st
= next_statement ();
1600 /* Parse a WHERE block, (not a simple WHERE statement). */
1603 parse_where_block (void)
1605 int seen_empty_else
;
1610 accept_statement (ST_WHERE_BLOCK
);
1611 top
= gfc_state_stack
->tail
;
1613 push_state (&s
, COMP_WHERE
, gfc_new_block
);
1615 d
= add_statement ();
1616 d
->expr
= top
->expr
;
1622 seen_empty_else
= 0;
1626 st
= next_statement ();
1632 case ST_WHERE_BLOCK
:
1633 parse_where_block ();
1638 accept_statement (st
);
1642 if (seen_empty_else
)
1645 ("ELSEWHERE statement at %C follows previous unmasked "
1650 if (new_st
.expr
== NULL
)
1651 seen_empty_else
= 1;
1653 d
= new_level (gfc_state_stack
->head
);
1655 d
->expr
= new_st
.expr
;
1657 accept_statement (st
);
1662 accept_statement (st
);
1666 gfc_error ("Unexpected %s statement in WHERE block at %C",
1667 gfc_ascii_statement (st
));
1668 reject_statement ();
1673 while (st
!= ST_END_WHERE
);
1679 /* Parse a FORALL block (not a simple FORALL statement). */
1682 parse_forall_block (void)
1688 accept_statement (ST_FORALL_BLOCK
);
1689 top
= gfc_state_stack
->tail
;
1691 push_state (&s
, COMP_FORALL
, gfc_new_block
);
1693 d
= add_statement ();
1694 d
->op
= EXEC_FORALL
;
1699 st
= next_statement ();
1704 case ST_POINTER_ASSIGNMENT
:
1707 accept_statement (st
);
1710 case ST_WHERE_BLOCK
:
1711 parse_where_block ();
1714 case ST_FORALL_BLOCK
:
1715 parse_forall_block ();
1719 accept_statement (st
);
1726 gfc_error ("Unexpected %s statement in FORALL block at %C",
1727 gfc_ascii_statement (st
));
1729 reject_statement ();
1733 while (st
!= ST_END_FORALL
);
1739 static gfc_statement
parse_executable (gfc_statement
);
1741 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
1744 parse_if_block (void)
1753 accept_statement (ST_IF_BLOCK
);
1755 top
= gfc_state_stack
->tail
;
1756 push_state (&s
, COMP_IF
, gfc_new_block
);
1758 new_st
.op
= EXEC_IF
;
1759 d
= add_statement ();
1761 d
->expr
= top
->expr
;
1767 st
= parse_executable (ST_NONE
);
1778 ("ELSE IF statement at %C cannot follow ELSE statement at %L",
1781 reject_statement ();
1785 d
= new_level (gfc_state_stack
->head
);
1787 d
->expr
= new_st
.expr
;
1789 accept_statement (st
);
1796 gfc_error ("Duplicate ELSE statements at %L and %C",
1798 reject_statement ();
1803 else_locus
= gfc_current_locus
;
1805 d
= new_level (gfc_state_stack
->head
);
1808 accept_statement (st
);
1816 unexpected_statement (st
);
1820 while (st
!= ST_ENDIF
);
1823 accept_statement (st
);
1827 /* Parse a SELECT block. */
1830 parse_select_block (void)
1836 accept_statement (ST_SELECT_CASE
);
1838 cp
= gfc_state_stack
->tail
;
1839 push_state (&s
, COMP_SELECT
, gfc_new_block
);
1841 /* Make sure that the next statement is a CASE or END SELECT. */
1844 st
= next_statement ();
1847 if (st
== ST_END_SELECT
)
1849 /* Empty SELECT CASE is OK. */
1850 accept_statement (st
);
1858 ("Expected a CASE or END SELECT statement following SELECT CASE "
1861 reject_statement ();
1864 /* At this point, we're got a nonempty select block. */
1865 cp
= new_level (cp
);
1868 accept_statement (st
);
1872 st
= parse_executable (ST_NONE
);
1879 cp
= new_level (gfc_state_stack
->head
);
1881 gfc_clear_new_st ();
1883 accept_statement (st
);
1889 /* Can't have an executable statement because of
1890 parse_executable(). */
1892 unexpected_statement (st
);
1896 while (st
!= ST_END_SELECT
);
1899 accept_statement (st
);
1903 /* Given a symbol, make sure it is not an iteration variable for a DO
1904 statement. This subroutine is called when the symbol is seen in a
1905 context that causes it to become redefined. If the symbol is an
1906 iterator, we generate an error message and return nonzero. */
1909 gfc_check_do_variable (gfc_symtree
*st
)
1913 for (s
=gfc_state_stack
; s
; s
= s
->previous
)
1914 if (s
->do_variable
== st
)
1916 gfc_error_now("Variable '%s' at %C cannot be redefined inside "
1917 "loop beginning at %L", st
->name
, &s
->head
->loc
);
1925 /* Checks to see if the current statement label closes an enddo.
1926 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
1927 an error) if it incorrectly closes an ENDDO. */
1930 check_do_closure (void)
1934 if (gfc_statement_label
== NULL
)
1937 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1938 if (p
->state
== COMP_DO
)
1942 return 0; /* No loops to close */
1944 if (p
->ext
.end_do_label
== gfc_statement_label
)
1947 if (p
== gfc_state_stack
)
1951 ("End of nonblock DO statement at %C is within another block");
1955 /* At this point, the label doesn't terminate the innermost loop.
1956 Make sure it doesn't terminate another one. */
1957 for (; p
; p
= p
->previous
)
1958 if (p
->state
== COMP_DO
&& p
->ext
.end_do_label
== gfc_statement_label
)
1960 gfc_error ("End of nonblock DO statement at %C is interwoven "
1961 "with another DO loop");
1969 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
1970 handled inside of parse_executable(), because they aren't really
1974 parse_do_block (void)
1981 s
.ext
.end_do_label
= new_st
.label
;
1983 if (new_st
.ext
.iterator
!= NULL
)
1984 stree
= new_st
.ext
.iterator
->var
->symtree
;
1988 accept_statement (ST_DO
);
1990 top
= gfc_state_stack
->tail
;
1991 push_state (&s
, COMP_DO
, gfc_new_block
);
1993 s
.do_variable
= stree
;
1995 top
->block
= new_level (top
);
1996 top
->block
->op
= EXEC_DO
;
1999 st
= parse_executable (ST_NONE
);
2007 if (s
.ext
.end_do_label
!= NULL
2008 && s
.ext
.end_do_label
!= gfc_statement_label
)
2010 ("Statement label in ENDDO at %C doesn't match DO label");
2012 if (gfc_statement_label
!= NULL
)
2014 new_st
.op
= EXEC_NOP
;
2019 case ST_IMPLIED_ENDDO
:
2023 unexpected_statement (st
);
2028 accept_statement (st
);
2032 /* Accept a series of executable statements. We return the first
2033 statement that doesn't fit to the caller. Any block statements are
2034 passed on to the correct handler, which usually passes the buck
2037 static gfc_statement
2038 parse_executable (gfc_statement st
)
2043 st
= next_statement ();
2045 for (;; st
= next_statement ())
2048 close_flag
= check_do_closure ();
2053 case ST_END_PROGRAM
:
2056 case ST_END_FUNCTION
:
2060 case ST_END_SUBROUTINE
:
2065 case ST_SELECT_CASE
:
2067 ("%s statement at %C cannot terminate a non-block DO loop",
2068 gfc_ascii_statement (st
));
2084 accept_statement (st
);
2085 if (close_flag
== 1)
2086 return ST_IMPLIED_ENDDO
;
2093 case ST_SELECT_CASE
:
2094 parse_select_block ();
2099 if (check_do_closure () == 1)
2100 return ST_IMPLIED_ENDDO
;
2103 case ST_WHERE_BLOCK
:
2104 parse_where_block ();
2107 case ST_FORALL_BLOCK
:
2108 parse_forall_block ();
2122 /* Parse a series of contained program units. */
2124 static void parse_progunit (gfc_statement
);
2127 /* Fix the symbols for sibling functions. These are incorrectly added to
2128 the child namespace as the parser didn't know about this procedure. */
2131 gfc_fixup_sibling_symbols (gfc_symbol
* sym
, gfc_namespace
* siblings
)
2135 gfc_symbol
*old_sym
;
2137 sym
->attr
.referenced
= 1;
2138 for (ns
= siblings
; ns
; ns
= ns
->sibling
)
2140 gfc_find_sym_tree (sym
->name
, ns
, 0, &st
);
2144 old_sym
= st
->n
.sym
;
2145 if ((old_sym
->attr
.flavor
== FL_PROCEDURE
2146 || old_sym
->ts
.type
== BT_UNKNOWN
)
2147 && old_sym
->ns
== ns
2148 && ! old_sym
->attr
.contained
)
2150 /* Replace it with the symbol from the parent namespace. */
2154 /* Free the old (local) symbol. */
2156 if (old_sym
->refs
== 0)
2157 gfc_free_symbol (old_sym
);
2160 /* Do the same for any contained procedures. */
2161 gfc_fixup_sibling_symbols (sym
, ns
->contained
);
2166 parse_contained (int module
)
2168 gfc_namespace
*ns
, *parent_ns
;
2169 gfc_state_data s1
, s2
;
2174 push_state (&s1
, COMP_CONTAINS
, NULL
);
2175 parent_ns
= gfc_current_ns
;
2179 gfc_current_ns
= gfc_get_namespace (parent_ns
, 1);
2181 gfc_current_ns
->sibling
= parent_ns
->contained
;
2182 parent_ns
->contained
= gfc_current_ns
;
2184 st
= next_statement ();
2193 accept_statement (st
);
2196 (st
== ST_FUNCTION
) ? COMP_FUNCTION
: COMP_SUBROUTINE
,
2199 /* For internal procedures, create/update the symbol in the
2200 parent namespace. */
2204 if (gfc_get_symbol (gfc_new_block
->name
, parent_ns
, &sym
))
2206 ("Contained procedure '%s' at %C is already ambiguous",
2207 gfc_new_block
->name
);
2210 if (gfc_add_procedure (&sym
->attr
, PROC_INTERNAL
, sym
->name
,
2211 &gfc_new_block
->declared_at
) ==
2214 if (st
== ST_FUNCTION
)
2215 gfc_add_function (&sym
->attr
, sym
->name
,
2216 &gfc_new_block
->declared_at
);
2218 gfc_add_subroutine (&sym
->attr
, sym
->name
,
2219 &gfc_new_block
->declared_at
);
2223 gfc_commit_symbols ();
2226 sym
= gfc_new_block
;
2228 /* Mark this as a contained function, so it isn't replaced
2229 by other module functions. */
2230 sym
->attr
.contained
= 1;
2231 sym
->attr
.referenced
= 1;
2233 parse_progunit (ST_NONE
);
2235 /* Fix up any sibling functions that refer to this one. */
2236 gfc_fixup_sibling_symbols (sym
, gfc_current_ns
);
2237 /* Or refer to any of its alternate entry points. */
2238 for (el
= gfc_current_ns
->entries
; el
; el
= el
->next
)
2239 gfc_fixup_sibling_symbols (el
->sym
, gfc_current_ns
);
2241 gfc_current_ns
->code
= s2
.head
;
2242 gfc_current_ns
= parent_ns
;
2247 /* These statements are associated with the end of the host
2249 case ST_END_FUNCTION
:
2251 case ST_END_PROGRAM
:
2252 case ST_END_SUBROUTINE
:
2253 accept_statement (st
);
2257 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
2258 gfc_ascii_statement (st
));
2259 reject_statement ();
2263 while (st
!= ST_END_FUNCTION
&& st
!= ST_END_SUBROUTINE
2264 && st
!= ST_END_MODULE
&& st
!= ST_END_PROGRAM
);
2266 /* The first namespace in the list is guaranteed to not have
2267 anything (worthwhile) in it. */
2269 gfc_current_ns
= parent_ns
;
2271 ns
= gfc_current_ns
->contained
;
2272 gfc_current_ns
->contained
= ns
->sibling
;
2273 gfc_free_namespace (ns
);
2279 /* Parse a PROGRAM, SUBROUTINE or FUNCTION unit. */
2282 parse_progunit (gfc_statement st
)
2287 st
= parse_spec (st
);
2297 accept_statement (st
);
2307 st
= parse_executable (st
);
2318 accept_statement (st
);
2325 unexpected_statement (st
);
2326 reject_statement ();
2327 st
= next_statement ();
2333 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
2334 if (p
->state
== COMP_CONTAINS
)
2337 if (gfc_find_state (COMP_MODULE
) == SUCCESS
)
2342 gfc_error ("CONTAINS statement at %C is already in a contained "
2344 st
= next_statement ();
2348 parse_contained (0);
2351 gfc_current_ns
->code
= gfc_state_stack
->head
;
2355 /* Come here to complain about a global symbol already in use as
2359 global_used (gfc_gsymbol
*sym
, locus
*where
)
2364 where
= &gfc_current_locus
;
2374 case GSYM_SUBROUTINE
:
2375 name
= "SUBROUTINE";
2380 case GSYM_BLOCK_DATA
:
2381 name
= "BLOCK DATA";
2387 gfc_internal_error ("gfc_gsymbol_type(): Bad type");
2391 gfc_error("Global name '%s' at %L is already being used as a %s at %L",
2392 gfc_new_block
->name
, where
, name
, &sym
->where
);
2396 /* Parse a block data program unit. */
2399 parse_block_data (void)
2402 static locus blank_locus
;
2403 static int blank_block
=0;
2406 gfc_current_ns
->proc_name
= gfc_new_block
;
2407 gfc_current_ns
->is_block_data
= 1;
2409 if (gfc_new_block
== NULL
)
2412 gfc_error ("Blank BLOCK DATA at %C conflicts with "
2413 "prior BLOCK DATA at %L", &blank_locus
);
2417 blank_locus
= gfc_current_locus
;
2422 s
= gfc_get_gsymbol (gfc_new_block
->name
);
2423 if (s
->type
!= GSYM_UNKNOWN
)
2424 global_used(s
, NULL
);
2427 s
->type
= GSYM_BLOCK_DATA
;
2428 s
->where
= gfc_current_locus
;
2432 st
= parse_spec (ST_NONE
);
2434 while (st
!= ST_END_BLOCK_DATA
)
2436 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
2437 gfc_ascii_statement (st
));
2438 reject_statement ();
2439 st
= next_statement ();
2444 /* Parse a module subprogram. */
2452 s
= gfc_get_gsymbol (gfc_new_block
->name
);
2453 if (s
->type
!= GSYM_UNKNOWN
)
2454 global_used(s
, NULL
);
2457 s
->type
= GSYM_MODULE
;
2458 s
->where
= gfc_current_locus
;
2461 st
= parse_spec (ST_NONE
);
2470 parse_contained (1);
2474 accept_statement (st
);
2478 gfc_error ("Unexpected %s statement in MODULE at %C",
2479 gfc_ascii_statement (st
));
2481 reject_statement ();
2482 st
= next_statement ();
2488 /* Add a procedure name to the global symbol table. */
2491 add_global_procedure (int sub
)
2495 s
= gfc_get_gsymbol(gfc_new_block
->name
);
2497 if (s
->type
!= GSYM_UNKNOWN
)
2498 global_used(s
, NULL
);
2501 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
2502 s
->where
= gfc_current_locus
;
2507 /* Add a program to the global symbol table. */
2510 add_global_program (void)
2514 if (gfc_new_block
== NULL
)
2516 s
= gfc_get_gsymbol (gfc_new_block
->name
);
2518 if (s
->type
!= GSYM_UNKNOWN
)
2519 global_used(s
, NULL
);
2522 s
->type
= GSYM_PROGRAM
;
2523 s
->where
= gfc_current_locus
;
2528 /* Top level parser. */
2531 gfc_parse_file (void)
2533 int seen_program
, errors_before
, errors
;
2534 gfc_state_data top
, s
;
2538 top
.state
= COMP_NONE
;
2540 top
.previous
= NULL
;
2541 top
.head
= top
.tail
= NULL
;
2542 top
.do_variable
= NULL
;
2544 gfc_state_stack
= &top
;
2546 gfc_clear_new_st ();
2548 gfc_statement_label
= NULL
;
2550 if (setjmp (eof_buf
))
2551 return FAILURE
; /* Come here on unexpected EOF */
2557 st
= next_statement ();
2566 goto duplicate_main
;
2568 prog_locus
= gfc_current_locus
;
2570 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
2571 accept_statement (st
);
2572 add_global_program ();
2573 parse_progunit (ST_NONE
);
2577 add_global_procedure (1);
2578 push_state (&s
, COMP_SUBROUTINE
, gfc_new_block
);
2579 accept_statement (st
);
2580 parse_progunit (ST_NONE
);
2584 add_global_procedure (0);
2585 push_state (&s
, COMP_FUNCTION
, gfc_new_block
);
2586 accept_statement (st
);
2587 parse_progunit (ST_NONE
);
2591 push_state (&s
, COMP_BLOCK_DATA
, gfc_new_block
);
2592 accept_statement (st
);
2593 parse_block_data ();
2597 push_state (&s
, COMP_MODULE
, gfc_new_block
);
2598 accept_statement (st
);
2600 gfc_get_errors (NULL
, &errors_before
);
2604 /* Anything else starts a nameless main program block. */
2607 goto duplicate_main
;
2609 prog_locus
= gfc_current_locus
;
2611 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
2612 parse_progunit (st
);
2616 gfc_current_ns
->code
= s
.head
;
2618 gfc_resolve (gfc_current_ns
);
2620 /* Dump the parse tree if requested. */
2621 if (gfc_option
.verbose
)
2622 gfc_show_namespace (gfc_current_ns
);
2624 gfc_get_errors (NULL
, &errors
);
2625 if (s
.state
== COMP_MODULE
)
2627 gfc_dump_module (s
.sym
->name
, errors_before
== errors
);
2628 if (errors
== 0 && ! gfc_option
.flag_no_backend
)
2629 gfc_generate_module_code (gfc_current_ns
);
2633 if (errors
== 0 && ! gfc_option
.flag_no_backend
)
2634 gfc_generate_code (gfc_current_ns
);
2645 /* If we see a duplicate main program, shut down. If the second
2646 instance is an implied main program, ie data decls or executable
2647 statements, we're in for lots of errors. */
2648 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus
);
2649 reject_statement ();