]>
Commit | Line | Data |
---|---|---|
6de9cd9a | 1 | /* Main parser. |
835aac92 | 2 | Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 |
edf1eac2 | 3 | Free Software Foundation, Inc. |
6de9cd9a DN |
4 | Contributed by Andy Vaught |
5 | ||
9fc4d79b | 6 | This file is part of GCC. |
6de9cd9a | 7 | |
9fc4d79b TS |
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 | |
d234d788 | 10 | Software Foundation; either version 3, or (at your option) any later |
9fc4d79b | 11 | version. |
6de9cd9a | 12 | |
9fc4d79b TS |
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 | |
16 | for more details. | |
6de9cd9a DN |
17 | |
18 | You should have received a copy of the GNU General Public License | |
d234d788 NC |
19 | along with GCC; see the file COPYING3. If not see |
20 | <http://www.gnu.org/licenses/>. */ | |
6de9cd9a | 21 | |
6de9cd9a | 22 | #include "config.h" |
d22e4895 | 23 | #include "system.h" |
6de9cd9a | 24 | #include <setjmp.h> |
6de9cd9a DN |
25 | #include "gfortran.h" |
26 | #include "match.h" | |
27 | #include "parse.h" | |
9e8a6720 | 28 | #include "debug.h" |
6de9cd9a | 29 | |
edf1eac2 SK |
30 | /* Current statement label. Zero means no statement label. Because new_st |
31 | can get wiped during statement matching, we have to keep it separate. */ | |
6de9cd9a DN |
32 | |
33 | gfc_st_label *gfc_statement_label; | |
34 | ||
35 | static locus label_locus; | |
f13ab1ee | 36 | static jmp_buf eof_buf; |
6de9cd9a DN |
37 | |
38 | gfc_state_data *gfc_state_stack; | |
39 | ||
40 | /* TODO: Re-order functions to kill these forward decls. */ | |
41 | static void check_statement_label (gfc_statement); | |
42 | static void undo_new_statement (void); | |
43 | static void reject_statement (void); | |
44 | ||
66e4ab31 | 45 | |
6de9cd9a DN |
46 | /* A sort of half-matching function. We try to match the word on the |
47 | input with the passed string. If this succeeds, we call the | |
48 | keyword-dependent matching function that will match the rest of the | |
49 | statement. For single keywords, the matching subroutine is | |
50 | gfc_match_eos(). */ | |
51 | ||
52 | static match | |
edf1eac2 | 53 | match_word (const char *str, match (*subr) (void), locus *old_locus) |
6de9cd9a DN |
54 | { |
55 | match m; | |
56 | ||
57 | if (str != NULL) | |
58 | { | |
59 | m = gfc_match (str); | |
60 | if (m != MATCH_YES) | |
61 | return m; | |
62 | } | |
63 | ||
64 | m = (*subr) (); | |
65 | ||
66 | if (m != MATCH_YES) | |
67 | { | |
63645982 | 68 | gfc_current_locus = *old_locus; |
6de9cd9a DN |
69 | reject_statement (); |
70 | } | |
71 | ||
72 | return m; | |
73 | } | |
74 | ||
75 | ||
76 | /* Figure out what the next statement is, (mostly) regardless of | |
2b22401b TS |
77 | proper ordering. The do...while(0) is there to prevent if/else |
78 | ambiguity. */ | |
6de9cd9a DN |
79 | |
80 | #define match(keyword, subr, st) \ | |
edf1eac2 | 81 | do { \ |
2b22401b | 82 | if (match_word(keyword, subr, &old_locus) == MATCH_YES) \ |
edf1eac2 | 83 | return st; \ |
2b22401b | 84 | else \ |
edf1eac2 | 85 | undo_new_statement (); \ |
2b22401b | 86 | } while (0); |
6de9cd9a | 87 | |
1c8bcdf7 PT |
88 | |
89 | /* This is a specialist version of decode_statement that is used | |
90 | for the specification statements in a function, whose | |
91 | characteristics are deferred into the specification statements. | |
92 | eg.: INTEGER (king = mykind) foo () | |
93 | USE mymodule, ONLY mykind..... | |
94 | The KIND parameter needs a return after USE or IMPORT, whereas | |
95 | derived type declarations can occur anywhere, up the executable | |
96 | block. ST_GET_FCN_CHARACTERISTICS is returned when we have run | |
97 | out of the correct kind of specification statements. */ | |
98 | static gfc_statement | |
99 | decode_specification_statement (void) | |
100 | { | |
101 | gfc_statement st; | |
102 | locus old_locus; | |
8fc541d3 | 103 | char c; |
1c8bcdf7 PT |
104 | |
105 | if (gfc_match_eos () == MATCH_YES) | |
106 | return ST_NONE; | |
107 | ||
108 | old_locus = gfc_current_locus; | |
109 | ||
110 | match ("import", gfc_match_import, ST_IMPORT); | |
111 | match ("use", gfc_match_use, ST_USE); | |
112 | ||
a99d95a2 | 113 | if (gfc_current_block ()->ts.type != BT_DERIVED) |
1c8bcdf7 PT |
114 | goto end_of_block; |
115 | ||
116 | match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION); | |
117 | match (NULL, gfc_match_data_decl, ST_DATA_DECL); | |
118 | match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR); | |
119 | ||
120 | /* General statement matching: Instead of testing every possible | |
121 | statement, we eliminate most possibilities by peeking at the | |
122 | first character. */ | |
123 | ||
8fc541d3 | 124 | c = gfc_peek_ascii_char (); |
1c8bcdf7 PT |
125 | |
126 | switch (c) | |
127 | { | |
128 | case 'a': | |
129 | match ("abstract% interface", gfc_match_abstract_interface, | |
130 | ST_INTERFACE); | |
131 | break; | |
132 | ||
133 | case 'b': | |
134 | match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL); | |
135 | break; | |
136 | ||
137 | case 'c': | |
138 | break; | |
139 | ||
140 | case 'd': | |
141 | match ("data", gfc_match_data, ST_DATA); | |
142 | match ("dimension", gfc_match_dimension, ST_ATTR_DECL); | |
143 | break; | |
144 | ||
145 | case 'e': | |
146 | match ("enum , bind ( c )", gfc_match_enum, ST_ENUM); | |
147 | match ("entry% ", gfc_match_entry, ST_ENTRY); | |
148 | match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE); | |
149 | match ("external", gfc_match_external, ST_ATTR_DECL); | |
150 | break; | |
151 | ||
152 | case 'f': | |
153 | match ("format", gfc_match_format, ST_FORMAT); | |
154 | break; | |
155 | ||
156 | case 'g': | |
157 | break; | |
158 | ||
159 | case 'i': | |
160 | match ("implicit", gfc_match_implicit, ST_IMPLICIT); | |
161 | match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE); | |
162 | match ("interface", gfc_match_interface, ST_INTERFACE); | |
163 | match ("intent", gfc_match_intent, ST_ATTR_DECL); | |
164 | match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL); | |
165 | break; | |
166 | ||
167 | case 'm': | |
168 | break; | |
169 | ||
170 | case 'n': | |
171 | match ("namelist", gfc_match_namelist, ST_NAMELIST); | |
172 | break; | |
173 | ||
174 | case 'o': | |
175 | match ("optional", gfc_match_optional, ST_ATTR_DECL); | |
176 | break; | |
177 | ||
178 | case 'p': | |
179 | match ("parameter", gfc_match_parameter, ST_PARAMETER); | |
180 | match ("pointer", gfc_match_pointer, ST_ATTR_DECL); | |
181 | if (gfc_match_private (&st) == MATCH_YES) | |
182 | return st; | |
183 | match ("procedure", gfc_match_procedure, ST_PROCEDURE); | |
184 | if (gfc_match_public (&st) == MATCH_YES) | |
185 | return st; | |
186 | match ("protected", gfc_match_protected, ST_ATTR_DECL); | |
187 | break; | |
188 | ||
189 | case 'r': | |
190 | break; | |
191 | ||
192 | case 's': | |
193 | match ("save", gfc_match_save, ST_ATTR_DECL); | |
194 | break; | |
195 | ||
196 | case 't': | |
197 | match ("target", gfc_match_target, ST_ATTR_DECL); | |
198 | match ("type", gfc_match_derived_decl, ST_DERIVED_DECL); | |
199 | break; | |
200 | ||
201 | case 'u': | |
202 | break; | |
203 | ||
204 | case 'v': | |
205 | match ("value", gfc_match_value, ST_ATTR_DECL); | |
206 | match ("volatile", gfc_match_volatile, ST_ATTR_DECL); | |
207 | break; | |
208 | ||
209 | case 'w': | |
210 | break; | |
211 | } | |
212 | ||
213 | /* This is not a specification statement. See if any of the matchers | |
214 | has stored an error message of some sort. */ | |
215 | ||
216 | end_of_block: | |
217 | gfc_clear_error (); | |
218 | gfc_buffer_error (0); | |
219 | gfc_current_locus = old_locus; | |
220 | ||
221 | return ST_GET_FCN_CHARACTERISTICS; | |
222 | } | |
223 | ||
224 | ||
225 | /* This is the primary 'decode_statement'. */ | |
6de9cd9a DN |
226 | static gfc_statement |
227 | decode_statement (void) | |
228 | { | |
229 | gfc_statement st; | |
230 | locus old_locus; | |
231 | match m; | |
8fc541d3 | 232 | char c; |
6de9cd9a DN |
233 | |
234 | #ifdef GFC_DEBUG | |
235 | gfc_symbol_state (); | |
236 | #endif | |
237 | ||
238 | gfc_clear_error (); /* Clear any pending errors. */ | |
239 | gfc_clear_warning (); /* Clear any pending warnings. */ | |
240 | ||
1c8bcdf7 PT |
241 | gfc_matching_function = false; |
242 | ||
6de9cd9a DN |
243 | if (gfc_match_eos () == MATCH_YES) |
244 | return ST_NONE; | |
245 | ||
1c8bcdf7 PT |
246 | if (gfc_current_state () == COMP_FUNCTION |
247 | && gfc_current_block ()->result->ts.kind == -1) | |
248 | return decode_specification_statement (); | |
249 | ||
63645982 | 250 | old_locus = gfc_current_locus; |
6de9cd9a DN |
251 | |
252 | /* Try matching a data declaration or function declaration. The | |
253 | input "REALFUNCTIONA(N)" can mean several things in different | |
254 | contexts, so it (and its relatives) get special treatment. */ | |
255 | ||
256 | if (gfc_current_state () == COMP_NONE | |
257 | || gfc_current_state () == COMP_INTERFACE | |
258 | || gfc_current_state () == COMP_CONTAINS) | |
259 | { | |
1c8bcdf7 | 260 | gfc_matching_function = true; |
6de9cd9a DN |
261 | m = gfc_match_function_decl (); |
262 | if (m == MATCH_YES) | |
263 | return ST_FUNCTION; | |
264 | else if (m == MATCH_ERROR) | |
265 | reject_statement (); | |
de893677 JD |
266 | else |
267 | gfc_undo_symbols (); | |
63645982 | 268 | gfc_current_locus = old_locus; |
6de9cd9a | 269 | } |
1c8bcdf7 PT |
270 | gfc_matching_function = false; |
271 | ||
6de9cd9a DN |
272 | |
273 | /* Match statements whose error messages are meant to be overwritten | |
274 | by something better. */ | |
275 | ||
276 | match (NULL, gfc_match_assignment, ST_ASSIGNMENT); | |
277 | match (NULL, gfc_match_pointer_assignment, ST_POINTER_ASSIGNMENT); | |
278 | match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION); | |
279 | ||
280 | match (NULL, gfc_match_data_decl, ST_DATA_DECL); | |
25d8f0a2 | 281 | match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR); |
6de9cd9a DN |
282 | |
283 | /* Try to match a subroutine statement, which has the same optional | |
284 | prefixes that functions can have. */ | |
285 | ||
286 | if (gfc_match_subroutine () == MATCH_YES) | |
287 | return ST_SUBROUTINE; | |
288 | gfc_undo_symbols (); | |
63645982 | 289 | gfc_current_locus = old_locus; |
6de9cd9a DN |
290 | |
291 | /* Check for the IF, DO, SELECT, WHERE and FORALL statements, which | |
292 | might begin with a block label. The match functions for these | |
293 | statements are unusual in that their keyword is not seen before | |
294 | the matcher is called. */ | |
295 | ||
296 | if (gfc_match_if (&st) == MATCH_YES) | |
297 | return st; | |
298 | gfc_undo_symbols (); | |
63645982 | 299 | gfc_current_locus = old_locus; |
6de9cd9a DN |
300 | |
301 | if (gfc_match_where (&st) == MATCH_YES) | |
302 | return st; | |
303 | gfc_undo_symbols (); | |
63645982 | 304 | gfc_current_locus = old_locus; |
6de9cd9a DN |
305 | |
306 | if (gfc_match_forall (&st) == MATCH_YES) | |
307 | return st; | |
308 | gfc_undo_symbols (); | |
63645982 | 309 | gfc_current_locus = old_locus; |
6de9cd9a DN |
310 | |
311 | match (NULL, gfc_match_do, ST_DO); | |
312 | match (NULL, gfc_match_select, ST_SELECT_CASE); | |
313 | ||
314 | /* General statement matching: Instead of testing every possible | |
315 | statement, we eliminate most possibilities by peeking at the | |
316 | first character. */ | |
317 | ||
8fc541d3 | 318 | c = gfc_peek_ascii_char (); |
6de9cd9a DN |
319 | |
320 | switch (c) | |
321 | { | |
322 | case 'a': | |
e9c06563 TB |
323 | match ("abstract% interface", gfc_match_abstract_interface, |
324 | ST_INTERFACE); | |
6de9cd9a DN |
325 | match ("allocate", gfc_match_allocate, ST_ALLOCATE); |
326 | match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL); | |
327 | match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT); | |
328 | break; | |
329 | ||
330 | case 'b': | |
331 | match ("backspace", gfc_match_backspace, ST_BACKSPACE); | |
24727d92 | 332 | match ("block data", gfc_match_block_data, ST_BLOCK_DATA); |
a8b3b0b6 | 333 | match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL); |
6de9cd9a DN |
334 | break; |
335 | ||
336 | case 'c': | |
337 | match ("call", gfc_match_call, ST_CALL); | |
338 | match ("close", gfc_match_close, ST_CLOSE); | |
339 | match ("continue", gfc_match_continue, ST_CONTINUE); | |
340 | match ("cycle", gfc_match_cycle, ST_CYCLE); | |
341 | match ("case", gfc_match_case, ST_CASE); | |
342 | match ("common", gfc_match_common, ST_COMMON); | |
343 | match ("contains", gfc_match_eos, ST_CONTAINS); | |
344 | break; | |
345 | ||
346 | case 'd': | |
347 | match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE); | |
348 | match ("data", gfc_match_data, ST_DATA); | |
349 | match ("dimension", gfc_match_dimension, ST_ATTR_DECL); | |
350 | break; | |
351 | ||
352 | case 'e': | |
353 | match ("end file", gfc_match_endfile, ST_END_FILE); | |
354 | match ("exit", gfc_match_exit, ST_EXIT); | |
355 | match ("else", gfc_match_else, ST_ELSE); | |
356 | match ("else where", gfc_match_elsewhere, ST_ELSEWHERE); | |
357 | match ("else if", gfc_match_elseif, ST_ELSEIF); | |
25d8f0a2 | 358 | match ("enum , bind ( c )", gfc_match_enum, ST_ENUM); |
6de9cd9a DN |
359 | |
360 | if (gfc_match_end (&st) == MATCH_YES) | |
361 | return st; | |
362 | ||
0ff0dfbf | 363 | match ("entry% ", gfc_match_entry, ST_ENTRY); |
6de9cd9a DN |
364 | match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE); |
365 | match ("external", gfc_match_external, ST_ATTR_DECL); | |
366 | break; | |
367 | ||
368 | case 'f': | |
6403ec5f | 369 | match ("flush", gfc_match_flush, ST_FLUSH); |
6de9cd9a DN |
370 | match ("format", gfc_match_format, ST_FORMAT); |
371 | break; | |
372 | ||
373 | case 'g': | |
374 | match ("go to", gfc_match_goto, ST_GOTO); | |
375 | break; | |
376 | ||
377 | case 'i': | |
378 | match ("inquire", gfc_match_inquire, ST_INQUIRE); | |
379 | match ("implicit", gfc_match_implicit, ST_IMPLICIT); | |
380 | match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE); | |
8998be20 | 381 | match ("import", gfc_match_import, ST_IMPORT); |
6de9cd9a DN |
382 | match ("interface", gfc_match_interface, ST_INTERFACE); |
383 | match ("intent", gfc_match_intent, ST_ATTR_DECL); | |
384 | match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL); | |
385 | break; | |
386 | ||
387 | case 'm': | |
0ff0dfbf | 388 | match ("module% procedure% ", gfc_match_modproc, ST_MODULE_PROC); |
6de9cd9a DN |
389 | match ("module", gfc_match_module, ST_MODULE); |
390 | break; | |
391 | ||
392 | case 'n': | |
393 | match ("nullify", gfc_match_nullify, ST_NULLIFY); | |
394 | match ("namelist", gfc_match_namelist, ST_NAMELIST); | |
395 | break; | |
396 | ||
397 | case 'o': | |
398 | match ("open", gfc_match_open, ST_OPEN); | |
399 | match ("optional", gfc_match_optional, ST_ATTR_DECL); | |
400 | break; | |
401 | ||
402 | case 'p': | |
403 | match ("print", gfc_match_print, ST_WRITE); | |
404 | match ("parameter", gfc_match_parameter, ST_PARAMETER); | |
405 | match ("pause", gfc_match_pause, ST_PAUSE); | |
406 | match ("pointer", gfc_match_pointer, ST_ATTR_DECL); | |
407 | if (gfc_match_private (&st) == MATCH_YES) | |
408 | return st; | |
69773742 | 409 | match ("procedure", gfc_match_procedure, ST_PROCEDURE); |
6de9cd9a DN |
410 | match ("program", gfc_match_program, ST_PROGRAM); |
411 | if (gfc_match_public (&st) == MATCH_YES) | |
412 | return st; | |
ee7e677f | 413 | match ("protected", gfc_match_protected, ST_ATTR_DECL); |
6de9cd9a DN |
414 | break; |
415 | ||
416 | case 'r': | |
417 | match ("read", gfc_match_read, ST_READ); | |
418 | match ("return", gfc_match_return, ST_RETURN); | |
419 | match ("rewind", gfc_match_rewind, ST_REWIND); | |
420 | break; | |
421 | ||
422 | case 's': | |
423 | match ("sequence", gfc_match_eos, ST_SEQUENCE); | |
424 | match ("stop", gfc_match_stop, ST_STOP); | |
425 | match ("save", gfc_match_save, ST_ATTR_DECL); | |
426 | break; | |
427 | ||
428 | case 't': | |
429 | match ("target", gfc_match_target, ST_ATTR_DECL); | |
430 | match ("type", gfc_match_derived_decl, ST_DERIVED_DECL); | |
431 | break; | |
432 | ||
433 | case 'u': | |
31198773 | 434 | match ("use", gfc_match_use, ST_USE); |
6de9cd9a DN |
435 | break; |
436 | ||
775e6c3a | 437 | case 'v': |
06469efd | 438 | match ("value", gfc_match_value, ST_ATTR_DECL); |
775e6c3a TB |
439 | match ("volatile", gfc_match_volatile, ST_ATTR_DECL); |
440 | break; | |
441 | ||
6de9cd9a | 442 | case 'w': |
6f0f0b2e | 443 | match ("wait", gfc_match_wait, ST_WAIT); |
6de9cd9a DN |
444 | match ("write", gfc_match_write, ST_WRITE); |
445 | break; | |
446 | } | |
447 | ||
448 | /* All else has failed, so give up. See if any of the matchers has | |
449 | stored an error message of some sort. */ | |
450 | ||
451 | if (gfc_error_check () == 0) | |
452 | gfc_error_now ("Unclassifiable statement at %C"); | |
453 | ||
454 | reject_statement (); | |
455 | ||
456 | gfc_error_recovery (); | |
457 | ||
458 | return ST_NONE; | |
459 | } | |
460 | ||
6c7a4dfd JJ |
461 | static gfc_statement |
462 | decode_omp_directive (void) | |
463 | { | |
464 | locus old_locus; | |
8fc541d3 | 465 | char c; |
6c7a4dfd JJ |
466 | |
467 | #ifdef GFC_DEBUG | |
468 | gfc_symbol_state (); | |
469 | #endif | |
470 | ||
471 | gfc_clear_error (); /* Clear any pending errors. */ | |
472 | gfc_clear_warning (); /* Clear any pending warnings. */ | |
473 | ||
474 | if (gfc_pure (NULL)) | |
475 | { | |
edf1eac2 SK |
476 | gfc_error_now ("OpenMP directives at %C may not appear in PURE " |
477 | "or ELEMENTAL procedures"); | |
6c7a4dfd JJ |
478 | gfc_error_recovery (); |
479 | return ST_NONE; | |
480 | } | |
481 | ||
482 | old_locus = gfc_current_locus; | |
483 | ||
484 | /* General OpenMP directive matching: Instead of testing every possible | |
485 | statement, we eliminate most possibilities by peeking at the | |
486 | first character. */ | |
487 | ||
8fc541d3 | 488 | c = gfc_peek_ascii_char (); |
6c7a4dfd JJ |
489 | |
490 | switch (c) | |
491 | { | |
492 | case 'a': | |
493 | match ("atomic", gfc_match_omp_atomic, ST_OMP_ATOMIC); | |
494 | break; | |
495 | case 'b': | |
496 | match ("barrier", gfc_match_omp_barrier, ST_OMP_BARRIER); | |
497 | break; | |
498 | case 'c': | |
499 | match ("critical", gfc_match_omp_critical, ST_OMP_CRITICAL); | |
500 | break; | |
501 | case 'd': | |
502 | match ("do", gfc_match_omp_do, ST_OMP_DO); | |
503 | break; | |
504 | case 'e': | |
505 | match ("end critical", gfc_match_omp_critical, ST_OMP_END_CRITICAL); | |
506 | match ("end do", gfc_match_omp_end_nowait, ST_OMP_END_DO); | |
507 | match ("end master", gfc_match_omp_eos, ST_OMP_END_MASTER); | |
508 | match ("end ordered", gfc_match_omp_eos, ST_OMP_END_ORDERED); | |
509 | match ("end parallel do", gfc_match_omp_eos, ST_OMP_END_PARALLEL_DO); | |
510 | match ("end parallel sections", gfc_match_omp_eos, | |
511 | ST_OMP_END_PARALLEL_SECTIONS); | |
512 | match ("end parallel workshare", gfc_match_omp_eos, | |
513 | ST_OMP_END_PARALLEL_WORKSHARE); | |
514 | match ("end parallel", gfc_match_omp_eos, ST_OMP_END_PARALLEL); | |
515 | match ("end sections", gfc_match_omp_end_nowait, ST_OMP_END_SECTIONS); | |
516 | match ("end single", gfc_match_omp_end_single, ST_OMP_END_SINGLE); | |
517 | match ("end workshare", gfc_match_omp_end_nowait, | |
518 | ST_OMP_END_WORKSHARE); | |
519 | break; | |
520 | case 'f': | |
521 | match ("flush", gfc_match_omp_flush, ST_OMP_FLUSH); | |
522 | break; | |
523 | case 'm': | |
524 | match ("master", gfc_match_omp_master, ST_OMP_MASTER); | |
525 | break; | |
526 | case 'o': | |
527 | match ("ordered", gfc_match_omp_ordered, ST_OMP_ORDERED); | |
528 | break; | |
529 | case 'p': | |
530 | match ("parallel do", gfc_match_omp_parallel_do, ST_OMP_PARALLEL_DO); | |
531 | match ("parallel sections", gfc_match_omp_parallel_sections, | |
532 | ST_OMP_PARALLEL_SECTIONS); | |
533 | match ("parallel workshare", gfc_match_omp_parallel_workshare, | |
534 | ST_OMP_PARALLEL_WORKSHARE); | |
535 | match ("parallel", gfc_match_omp_parallel, ST_OMP_PARALLEL); | |
536 | break; | |
537 | case 's': | |
538 | match ("sections", gfc_match_omp_sections, ST_OMP_SECTIONS); | |
539 | match ("section", gfc_match_omp_eos, ST_OMP_SECTION); | |
540 | match ("single", gfc_match_omp_single, ST_OMP_SINGLE); | |
541 | break; | |
542 | case 't': | |
543 | match ("threadprivate", gfc_match_omp_threadprivate, | |
544 | ST_OMP_THREADPRIVATE); | |
545 | case 'w': | |
546 | match ("workshare", gfc_match_omp_workshare, ST_OMP_WORKSHARE); | |
547 | break; | |
548 | } | |
549 | ||
550 | /* All else has failed, so give up. See if any of the matchers has | |
551 | stored an error message of some sort. */ | |
552 | ||
553 | if (gfc_error_check () == 0) | |
554 | gfc_error_now ("Unclassifiable OpenMP directive at %C"); | |
555 | ||
556 | reject_statement (); | |
557 | ||
558 | gfc_error_recovery (); | |
559 | ||
560 | return ST_NONE; | |
561 | } | |
562 | ||
6de9cd9a DN |
563 | #undef match |
564 | ||
565 | ||
566 | /* Get the next statement in free form source. */ | |
567 | ||
568 | static gfc_statement | |
569 | next_free (void) | |
570 | { | |
571 | match m; | |
8fc541d3 FXC |
572 | int i, cnt, at_bol; |
573 | char c; | |
6de9cd9a | 574 | |
31c5eee1 | 575 | at_bol = gfc_at_bol (); |
6de9cd9a DN |
576 | gfc_gobble_whitespace (); |
577 | ||
8fc541d3 | 578 | c = gfc_peek_ascii_char (); |
6de9cd9a DN |
579 | |
580 | if (ISDIGIT (c)) | |
581 | { | |
8fc541d3 FXC |
582 | char d; |
583 | ||
6de9cd9a | 584 | /* Found a statement label? */ |
a34a91f0 | 585 | m = gfc_match_st_label (&gfc_statement_label); |
6de9cd9a | 586 | |
8fc541d3 | 587 | d = gfc_peek_ascii_char (); |
6de9cd9a DN |
588 | if (m != MATCH_YES || !gfc_is_whitespace (d)) |
589 | { | |
8fc541d3 | 590 | gfc_match_small_literal_int (&i, &cnt); |
8a8f7eca | 591 | |
edf1eac2 | 592 | if (cnt > 5) |
8a8f7eca | 593 | gfc_error_now ("Too many digits in statement label at %C"); |
9b3e4c45 | 594 | |
8fc541d3 | 595 | if (i == 0) |
9b3e4c45 | 596 | gfc_error_now ("Zero is not a valid statement label at %C"); |
a34a91f0 | 597 | |
6de9cd9a | 598 | do |
8fc541d3 | 599 | c = gfc_next_ascii_char (); |
a34a91f0 | 600 | while (ISDIGIT(c)); |
99f1e970 SK |
601 | |
602 | if (!gfc_is_whitespace (c)) | |
603 | gfc_error_now ("Non-numeric character in statement label at %C"); | |
604 | ||
e983d070 | 605 | return ST_NONE; |
6de9cd9a DN |
606 | } |
607 | else | |
608 | { | |
63645982 | 609 | label_locus = gfc_current_locus; |
6de9cd9a | 610 | |
6de9cd9a DN |
611 | gfc_gobble_whitespace (); |
612 | ||
8fc541d3 | 613 | if (at_bol && gfc_peek_ascii_char () == ';') |
31c5eee1 | 614 | { |
edf1eac2 SK |
615 | gfc_error_now ("Semicolon at %C needs to be preceded by " |
616 | "statement"); | |
8fc541d3 | 617 | gfc_next_ascii_char (); /* Eat up the semicolon. */ |
31c5eee1 TS |
618 | return ST_NONE; |
619 | } | |
620 | ||
6de9cd9a DN |
621 | if (gfc_match_eos () == MATCH_YES) |
622 | { | |
edf1eac2 SK |
623 | gfc_warning_now ("Ignoring statement label in empty statement " |
624 | "at %C"); | |
6de9cd9a DN |
625 | gfc_free_st_label (gfc_statement_label); |
626 | gfc_statement_label = NULL; | |
627 | return ST_NONE; | |
628 | } | |
629 | } | |
630 | } | |
6c7a4dfd JJ |
631 | else if (c == '!') |
632 | { | |
633 | /* Comments have already been skipped by the time we get here, | |
634 | except for OpenMP directives. */ | |
635 | if (gfc_option.flag_openmp) | |
636 | { | |
637 | int i; | |
638 | ||
8fc541d3 FXC |
639 | c = gfc_next_ascii_char (); |
640 | for (i = 0; i < 5; i++, c = gfc_next_ascii_char ()) | |
6c7a4dfd JJ |
641 | gcc_assert (c == "!$omp"[i]); |
642 | ||
643 | gcc_assert (c == ' '); | |
7efeea5e | 644 | gfc_gobble_whitespace (); |
6c7a4dfd JJ |
645 | return decode_omp_directive (); |
646 | } | |
647 | } | |
6de9cd9a | 648 | |
31c5eee1 TS |
649 | if (at_bol && c == ';') |
650 | { | |
651 | gfc_error_now ("Semicolon at %C needs to be preceded by statement"); | |
8fc541d3 | 652 | gfc_next_ascii_char (); /* Eat up the semicolon. */ |
31c5eee1 TS |
653 | return ST_NONE; |
654 | } | |
655 | ||
6de9cd9a DN |
656 | return decode_statement (); |
657 | } | |
658 | ||
659 | ||
660 | /* Get the next statement in fixed-form source. */ | |
661 | ||
662 | static gfc_statement | |
663 | next_fixed (void) | |
664 | { | |
665 | int label, digit_flag, i; | |
666 | locus loc; | |
8fc541d3 | 667 | gfc_char_t c; |
6de9cd9a DN |
668 | |
669 | if (!gfc_at_bol ()) | |
670 | return decode_statement (); | |
671 | ||
672 | /* Skip past the current label field, parsing a statement label if | |
673 | one is there. This is a weird number parser, since the number is | |
674 | contained within five columns and can have any kind of embedded | |
675 | spaces. We also check for characters that make the rest of the | |
676 | line a comment. */ | |
677 | ||
678 | label = 0; | |
679 | digit_flag = 0; | |
680 | ||
681 | for (i = 0; i < 5; i++) | |
682 | { | |
683 | c = gfc_next_char_literal (0); | |
684 | ||
685 | switch (c) | |
686 | { | |
687 | case ' ': | |
688 | break; | |
689 | ||
690 | case '0': | |
691 | case '1': | |
692 | case '2': | |
693 | case '3': | |
694 | case '4': | |
695 | case '5': | |
696 | case '6': | |
697 | case '7': | |
698 | case '8': | |
699 | case '9': | |
8fc541d3 | 700 | label = label * 10 + ((unsigned char) c - '0'); |
63645982 | 701 | label_locus = gfc_current_locus; |
6de9cd9a DN |
702 | digit_flag = 1; |
703 | break; | |
704 | ||
6c7a4dfd JJ |
705 | /* Comments have already been skipped by the time we get |
706 | here, except for OpenMP directives. */ | |
707 | case '*': | |
708 | if (gfc_option.flag_openmp) | |
709 | { | |
710 | for (i = 0; i < 5; i++, c = gfc_next_char_literal (0)) | |
8fc541d3 | 711 | gcc_assert ((char) gfc_wide_tolower (c) == "*$omp"[i]); |
6c7a4dfd JJ |
712 | |
713 | if (c != ' ' && c != '0') | |
714 | { | |
715 | gfc_buffer_error (0); | |
716 | gfc_error ("Bad continuation line at %C"); | |
717 | return ST_NONE; | |
718 | } | |
719 | ||
720 | return decode_omp_directive (); | |
721 | } | |
722 | /* FALLTHROUGH */ | |
723 | ||
724 | /* Comments have already been skipped by the time we get | |
f7b529fa | 725 | here so don't bother checking for them. */ |
6de9cd9a DN |
726 | |
727 | default: | |
728 | gfc_buffer_error (0); | |
729 | gfc_error ("Non-numeric character in statement label at %C"); | |
730 | return ST_NONE; | |
731 | } | |
732 | } | |
733 | ||
734 | if (digit_flag) | |
735 | { | |
736 | if (label == 0) | |
737 | gfc_warning_now ("Zero is not a valid statement label at %C"); | |
738 | else | |
739 | { | |
740 | /* We've found a valid statement label. */ | |
741 | gfc_statement_label = gfc_get_st_label (label); | |
742 | } | |
743 | } | |
744 | ||
745 | /* Since this line starts a statement, it cannot be a continuation | |
5b5afddf TS |
746 | of a previous statement. If we see something here besides a |
747 | space or zero, it must be a bad continuation line. */ | |
6de9cd9a | 748 | |
5b5afddf TS |
749 | c = gfc_next_char_literal (0); |
750 | if (c == '\n') | |
6de9cd9a DN |
751 | goto blank_line; |
752 | ||
31c5eee1 | 753 | if (c != ' ' && c != '0') |
5b5afddf TS |
754 | { |
755 | gfc_buffer_error (0); | |
756 | gfc_error ("Bad continuation line at %C"); | |
757 | return ST_NONE; | |
758 | } | |
759 | ||
6de9cd9a DN |
760 | /* Now that we've taken care of the statement label columns, we have |
761 | to make sure that the first nonblank character is not a '!'. If | |
762 | it is, the rest of the line is a comment. */ | |
763 | ||
764 | do | |
765 | { | |
63645982 | 766 | loc = gfc_current_locus; |
6de9cd9a DN |
767 | c = gfc_next_char_literal (0); |
768 | } | |
769 | while (gfc_is_whitespace (c)); | |
770 | ||
771 | if (c == '!') | |
772 | goto blank_line; | |
63645982 | 773 | gfc_current_locus = loc; |
6de9cd9a | 774 | |
31c5eee1 TS |
775 | if (c == ';') |
776 | { | |
777 | gfc_error_now ("Semicolon at %C needs to be preceded by statement"); | |
778 | return ST_NONE; | |
779 | } | |
780 | ||
6de9cd9a DN |
781 | if (gfc_match_eos () == MATCH_YES) |
782 | goto blank_line; | |
783 | ||
784 | /* At this point, we've got a nonblank statement to parse. */ | |
785 | return decode_statement (); | |
786 | ||
787 | blank_line: | |
788 | if (digit_flag) | |
9b3e4c45 | 789 | gfc_warning ("Ignoring statement label in empty statement at %C"); |
6de9cd9a DN |
790 | gfc_advance_line (); |
791 | return ST_NONE; | |
792 | } | |
793 | ||
794 | ||
795 | /* Return the next non-ST_NONE statement to the caller. We also worry | |
796 | about including files and the ends of include files at this stage. */ | |
797 | ||
798 | static gfc_statement | |
799 | next_statement (void) | |
800 | { | |
801 | gfc_statement st; | |
ae18bd76 | 802 | locus old_locus; |
6de9cd9a DN |
803 | gfc_new_block = NULL; |
804 | ||
805 | for (;;) | |
806 | { | |
807 | gfc_statement_label = NULL; | |
808 | gfc_buffer_error (1); | |
809 | ||
810 | if (gfc_at_eol ()) | |
ba1defa5 | 811 | { |
b16cc039 | 812 | if ((gfc_option.warn_line_truncation || gfc_current_form == FORM_FREE) |
31909d9f | 813 | && gfc_current_locus.lb |
ba1defa5 RG |
814 | && gfc_current_locus.lb->truncated) |
815 | gfc_warning_now ("Line truncated at %C"); | |
816 | ||
817 | gfc_advance_line (); | |
818 | } | |
6de9cd9a DN |
819 | |
820 | gfc_skip_comments (); | |
821 | ||
6de9cd9a DN |
822 | if (gfc_at_end ()) |
823 | { | |
824 | st = ST_NONE; | |
825 | break; | |
826 | } | |
827 | ||
9e8a6720 FXC |
828 | if (gfc_define_undef_line ()) |
829 | continue; | |
830 | ||
ae18bd76 PT |
831 | old_locus = gfc_current_locus; |
832 | ||
edf1eac2 | 833 | st = (gfc_current_form == FORM_FIXED) ? next_fixed () : next_free (); |
d4fa05b9 | 834 | |
6de9cd9a DN |
835 | if (st != ST_NONE) |
836 | break; | |
837 | } | |
838 | ||
839 | gfc_buffer_error (0); | |
840 | ||
ae18bd76 PT |
841 | if (st == ST_GET_FCN_CHARACTERISTICS && gfc_statement_label != NULL) |
842 | { | |
843 | gfc_free_st_label (gfc_statement_label); | |
844 | gfc_statement_label = NULL; | |
845 | gfc_current_locus = old_locus; | |
846 | } | |
847 | ||
6de9cd9a DN |
848 | if (st != ST_NONE) |
849 | check_statement_label (st); | |
850 | ||
851 | return st; | |
852 | } | |
853 | ||
854 | ||
855 | /****************************** Parser ***********************************/ | |
856 | ||
857 | /* The parser subroutines are of type 'try' that fail if the file ends | |
858 | unexpectedly. */ | |
859 | ||
860 | /* Macros that expand to case-labels for various classes of | |
861 | statements. Start with executable statements that directly do | |
862 | things. */ | |
863 | ||
864 | #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \ | |
865 | case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \ | |
866 | case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \ | |
867 | case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \ | |
6f0f0b2e | 868 | case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \ |
6de9cd9a | 869 | case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \ |
6f0f0b2e | 870 | case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \ |
6c7a4dfd JJ |
871 | case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \ |
872 | case ST_OMP_BARRIER | |
6de9cd9a DN |
873 | |
874 | /* Statements that mark other executable statements. */ | |
875 | ||
876 | #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: case ST_IF_BLOCK: \ | |
6c7a4dfd JJ |
877 | case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_OMP_PARALLEL: \ |
878 | case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \ | |
879 | case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \ | |
880 | case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \ | |
881 | case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE | |
6de9cd9a DN |
882 | |
883 | /* Declaration statements */ | |
884 | ||
885 | #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \ | |
886 | case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \ | |
69773742 JW |
887 | case ST_TYPE: case ST_INTERFACE: case ST_OMP_THREADPRIVATE: \ |
888 | case ST_PROCEDURE | |
6de9cd9a DN |
889 | |
890 | /* Block end statements. Errors associated with interchanging these | |
891 | are detected in gfc_match_end(). */ | |
892 | ||
893 | #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \ | |
edf1eac2 | 894 | case ST_END_PROGRAM: case ST_END_SUBROUTINE |
6de9cd9a DN |
895 | |
896 | ||
897 | /* Push a new state onto the stack. */ | |
898 | ||
899 | static void | |
edf1eac2 | 900 | push_state (gfc_state_data *p, gfc_compile_state new_state, gfc_symbol *sym) |
6de9cd9a | 901 | { |
6de9cd9a DN |
902 | p->state = new_state; |
903 | p->previous = gfc_state_stack; | |
904 | p->sym = sym; | |
905 | p->head = p->tail = NULL; | |
c9583ed2 | 906 | p->do_variable = NULL; |
6de9cd9a DN |
907 | gfc_state_stack = p; |
908 | } | |
909 | ||
910 | ||
911 | /* Pop the current state. */ | |
6de9cd9a DN |
912 | static void |
913 | pop_state (void) | |
914 | { | |
6de9cd9a DN |
915 | gfc_state_stack = gfc_state_stack->previous; |
916 | } | |
917 | ||
918 | ||
919 | /* Try to find the given state in the state stack. */ | |
920 | ||
921 | try | |
922 | gfc_find_state (gfc_compile_state state) | |
923 | { | |
924 | gfc_state_data *p; | |
925 | ||
926 | for (p = gfc_state_stack; p; p = p->previous) | |
927 | if (p->state == state) | |
928 | break; | |
929 | ||
930 | return (p == NULL) ? FAILURE : SUCCESS; | |
931 | } | |
932 | ||
933 | ||
934 | /* Starts a new level in the statement list. */ | |
935 | ||
936 | static gfc_code * | |
edf1eac2 | 937 | new_level (gfc_code *q) |
6de9cd9a DN |
938 | { |
939 | gfc_code *p; | |
940 | ||
941 | p = q->block = gfc_get_code (); | |
942 | ||
943 | gfc_state_stack->head = gfc_state_stack->tail = p; | |
944 | ||
945 | return p; | |
946 | } | |
947 | ||
948 | ||
949 | /* Add the current new_st code structure and adds it to the current | |
950 | program unit. As a side-effect, it zeroes the new_st. */ | |
951 | ||
952 | static gfc_code * | |
953 | add_statement (void) | |
954 | { | |
955 | gfc_code *p; | |
956 | ||
957 | p = gfc_get_code (); | |
958 | *p = new_st; | |
959 | ||
63645982 | 960 | p->loc = gfc_current_locus; |
6de9cd9a DN |
961 | |
962 | if (gfc_state_stack->head == NULL) | |
963 | gfc_state_stack->head = p; | |
964 | else | |
965 | gfc_state_stack->tail->next = p; | |
966 | ||
967 | while (p->next != NULL) | |
968 | p = p->next; | |
969 | ||
970 | gfc_state_stack->tail = p; | |
971 | ||
972 | gfc_clear_new_st (); | |
973 | ||
974 | return p; | |
975 | } | |
976 | ||
977 | ||
978 | /* Frees everything associated with the current statement. */ | |
979 | ||
980 | static void | |
981 | undo_new_statement (void) | |
982 | { | |
983 | gfc_free_statements (new_st.block); | |
984 | gfc_free_statements (new_st.next); | |
985 | gfc_free_statement (&new_st); | |
986 | gfc_clear_new_st (); | |
987 | } | |
988 | ||
989 | ||
990 | /* If the current statement has a statement label, make sure that it | |
991 | is allowed to, or should have one. */ | |
992 | ||
993 | static void | |
994 | check_statement_label (gfc_statement st) | |
995 | { | |
996 | gfc_sl_type type; | |
997 | ||
998 | if (gfc_statement_label == NULL) | |
999 | { | |
1000 | if (st == ST_FORMAT) | |
1001 | gfc_error ("FORMAT statement at %L does not have a statement label", | |
1002 | &new_st.loc); | |
1003 | return; | |
1004 | } | |
1005 | ||
1006 | switch (st) | |
1007 | { | |
1008 | case ST_END_PROGRAM: | |
1009 | case ST_END_FUNCTION: | |
1010 | case ST_END_SUBROUTINE: | |
1011 | case ST_ENDDO: | |
1012 | case ST_ENDIF: | |
1013 | case ST_END_SELECT: | |
1014 | case_executable: | |
1015 | case_exec_markers: | |
1016 | type = ST_LABEL_TARGET; | |
1017 | break; | |
1018 | ||
1019 | case ST_FORMAT: | |
1020 | type = ST_LABEL_FORMAT; | |
1021 | break; | |
1022 | ||
1023 | /* Statement labels are not restricted from appearing on a | |
edf1eac2 SK |
1024 | particular line. However, there are plenty of situations |
1025 | where the resulting label can't be referenced. */ | |
6de9cd9a DN |
1026 | |
1027 | default: | |
1028 | type = ST_LABEL_BAD_TARGET; | |
1029 | break; | |
1030 | } | |
1031 | ||
1032 | gfc_define_st_label (gfc_statement_label, type, &label_locus); | |
1033 | ||
1034 | new_st.here = gfc_statement_label; | |
1035 | } | |
1036 | ||
1037 | ||
1038 | /* Figures out what the enclosing program unit is. This will be a | |
1039 | function, subroutine, program, block data or module. */ | |
1040 | ||
1041 | gfc_state_data * | |
1042 | gfc_enclosing_unit (gfc_compile_state * result) | |
1043 | { | |
1044 | gfc_state_data *p; | |
1045 | ||
1046 | for (p = gfc_state_stack; p; p = p->previous) | |
1047 | if (p->state == COMP_FUNCTION || p->state == COMP_SUBROUTINE | |
1048 | || p->state == COMP_MODULE || p->state == COMP_BLOCK_DATA | |
1049 | || p->state == COMP_PROGRAM) | |
1050 | { | |
1051 | ||
1052 | if (result != NULL) | |
1053 | *result = p->state; | |
1054 | return p; | |
1055 | } | |
1056 | ||
1057 | if (result != NULL) | |
1058 | *result = COMP_PROGRAM; | |
1059 | return NULL; | |
1060 | } | |
1061 | ||
1062 | ||
1063 | /* Translate a statement enum to a string. */ | |
1064 | ||
1065 | const char * | |
1066 | gfc_ascii_statement (gfc_statement st) | |
1067 | { | |
1068 | const char *p; | |
1069 | ||
1070 | switch (st) | |
1071 | { | |
1072 | case ST_ARITHMETIC_IF: | |
31043f6c | 1073 | p = _("arithmetic IF"); |
6de9cd9a DN |
1074 | break; |
1075 | case ST_ALLOCATE: | |
1076 | p = "ALLOCATE"; | |
1077 | break; | |
1078 | case ST_ATTR_DECL: | |
31043f6c | 1079 | p = _("attribute declaration"); |
6de9cd9a DN |
1080 | break; |
1081 | case ST_BACKSPACE: | |
1082 | p = "BACKSPACE"; | |
1083 | break; | |
1084 | case ST_BLOCK_DATA: | |
1085 | p = "BLOCK DATA"; | |
1086 | break; | |
1087 | case ST_CALL: | |
1088 | p = "CALL"; | |
1089 | break; | |
1090 | case ST_CASE: | |
1091 | p = "CASE"; | |
1092 | break; | |
1093 | case ST_CLOSE: | |
1094 | p = "CLOSE"; | |
1095 | break; | |
1096 | case ST_COMMON: | |
1097 | p = "COMMON"; | |
1098 | break; | |
1099 | case ST_CONTINUE: | |
1100 | p = "CONTINUE"; | |
1101 | break; | |
1102 | case ST_CONTAINS: | |
1103 | p = "CONTAINS"; | |
1104 | break; | |
1105 | case ST_CYCLE: | |
1106 | p = "CYCLE"; | |
1107 | break; | |
1108 | case ST_DATA_DECL: | |
31043f6c | 1109 | p = _("data declaration"); |
6de9cd9a DN |
1110 | break; |
1111 | case ST_DATA: | |
1112 | p = "DATA"; | |
1113 | break; | |
1114 | case ST_DEALLOCATE: | |
1115 | p = "DEALLOCATE"; | |
1116 | break; | |
1117 | case ST_DERIVED_DECL: | |
31043f6c | 1118 | p = _("derived type declaration"); |
6de9cd9a DN |
1119 | break; |
1120 | case ST_DO: | |
1121 | p = "DO"; | |
1122 | break; | |
1123 | case ST_ELSE: | |
1124 | p = "ELSE"; | |
1125 | break; | |
1126 | case ST_ELSEIF: | |
1127 | p = "ELSE IF"; | |
1128 | break; | |
1129 | case ST_ELSEWHERE: | |
1130 | p = "ELSEWHERE"; | |
1131 | break; | |
1132 | case ST_END_BLOCK_DATA: | |
1133 | p = "END BLOCK DATA"; | |
1134 | break; | |
1135 | case ST_ENDDO: | |
1136 | p = "END DO"; | |
1137 | break; | |
1138 | case ST_END_FILE: | |
1139 | p = "END FILE"; | |
1140 | break; | |
1141 | case ST_END_FORALL: | |
1142 | p = "END FORALL"; | |
1143 | break; | |
1144 | case ST_END_FUNCTION: | |
1145 | p = "END FUNCTION"; | |
1146 | break; | |
1147 | case ST_ENDIF: | |
1148 | p = "END IF"; | |
1149 | break; | |
1150 | case ST_END_INTERFACE: | |
1151 | p = "END INTERFACE"; | |
1152 | break; | |
1153 | case ST_END_MODULE: | |
1154 | p = "END MODULE"; | |
1155 | break; | |
1156 | case ST_END_PROGRAM: | |
1157 | p = "END PROGRAM"; | |
1158 | break; | |
1159 | case ST_END_SELECT: | |
1160 | p = "END SELECT"; | |
1161 | break; | |
1162 | case ST_END_SUBROUTINE: | |
1163 | p = "END SUBROUTINE"; | |
1164 | break; | |
1165 | case ST_END_WHERE: | |
1166 | p = "END WHERE"; | |
1167 | break; | |
1168 | case ST_END_TYPE: | |
1169 | p = "END TYPE"; | |
1170 | break; | |
1171 | case ST_ENTRY: | |
1172 | p = "ENTRY"; | |
1173 | break; | |
1174 | case ST_EQUIVALENCE: | |
1175 | p = "EQUIVALENCE"; | |
1176 | break; | |
1177 | case ST_EXIT: | |
1178 | p = "EXIT"; | |
1179 | break; | |
6403ec5f JB |
1180 | case ST_FLUSH: |
1181 | p = "FLUSH"; | |
1182 | break; | |
6de9cd9a DN |
1183 | case ST_FORALL_BLOCK: /* Fall through */ |
1184 | case ST_FORALL: | |
1185 | p = "FORALL"; | |
1186 | break; | |
1187 | case ST_FORMAT: | |
1188 | p = "FORMAT"; | |
1189 | break; | |
1190 | case ST_FUNCTION: | |
1191 | p = "FUNCTION"; | |
1192 | break; | |
1193 | case ST_GOTO: | |
1194 | p = "GOTO"; | |
1195 | break; | |
1196 | case ST_IF_BLOCK: | |
31043f6c | 1197 | p = _("block IF"); |
6de9cd9a DN |
1198 | break; |
1199 | case ST_IMPLICIT: | |
1200 | p = "IMPLICIT"; | |
1201 | break; | |
1202 | case ST_IMPLICIT_NONE: | |
1203 | p = "IMPLICIT NONE"; | |
1204 | break; | |
1205 | case ST_IMPLIED_ENDDO: | |
31043f6c | 1206 | p = _("implied END DO"); |
6de9cd9a | 1207 | break; |
8998be20 TB |
1208 | case ST_IMPORT: |
1209 | p = "IMPORT"; | |
1210 | break; | |
6de9cd9a DN |
1211 | case ST_INQUIRE: |
1212 | p = "INQUIRE"; | |
1213 | break; | |
1214 | case ST_INTERFACE: | |
1215 | p = "INTERFACE"; | |
1216 | break; | |
1217 | case ST_PARAMETER: | |
1218 | p = "PARAMETER"; | |
1219 | break; | |
1220 | case ST_PRIVATE: | |
1221 | p = "PRIVATE"; | |
1222 | break; | |
1223 | case ST_PUBLIC: | |
1224 | p = "PUBLIC"; | |
1225 | break; | |
1226 | case ST_MODULE: | |
1227 | p = "MODULE"; | |
1228 | break; | |
1229 | case ST_PAUSE: | |
1230 | p = "PAUSE"; | |
1231 | break; | |
1232 | case ST_MODULE_PROC: | |
1233 | p = "MODULE PROCEDURE"; | |
1234 | break; | |
1235 | case ST_NAMELIST: | |
1236 | p = "NAMELIST"; | |
1237 | break; | |
1238 | case ST_NULLIFY: | |
1239 | p = "NULLIFY"; | |
1240 | break; | |
1241 | case ST_OPEN: | |
1242 | p = "OPEN"; | |
1243 | break; | |
1244 | case ST_PROGRAM: | |
1245 | p = "PROGRAM"; | |
1246 | break; | |
69773742 JW |
1247 | case ST_PROCEDURE: |
1248 | p = "PROCEDURE"; | |
1249 | break; | |
6de9cd9a DN |
1250 | case ST_READ: |
1251 | p = "READ"; | |
1252 | break; | |
1253 | case ST_RETURN: | |
1254 | p = "RETURN"; | |
1255 | break; | |
1256 | case ST_REWIND: | |
1257 | p = "REWIND"; | |
1258 | break; | |
1259 | case ST_STOP: | |
1260 | p = "STOP"; | |
1261 | break; | |
1262 | case ST_SUBROUTINE: | |
1263 | p = "SUBROUTINE"; | |
1264 | break; | |
1265 | case ST_TYPE: | |
1266 | p = "TYPE"; | |
1267 | break; | |
1268 | case ST_USE: | |
1269 | p = "USE"; | |
1270 | break; | |
1271 | case ST_WHERE_BLOCK: /* Fall through */ | |
1272 | case ST_WHERE: | |
1273 | p = "WHERE"; | |
1274 | break; | |
6f0f0b2e JD |
1275 | case ST_WAIT: |
1276 | p = "WAIT"; | |
1277 | break; | |
6de9cd9a DN |
1278 | case ST_WRITE: |
1279 | p = "WRITE"; | |
1280 | break; | |
1281 | case ST_ASSIGNMENT: | |
31043f6c | 1282 | p = _("assignment"); |
6de9cd9a DN |
1283 | break; |
1284 | case ST_POINTER_ASSIGNMENT: | |
31043f6c | 1285 | p = _("pointer assignment"); |
6de9cd9a DN |
1286 | break; |
1287 | case ST_SELECT_CASE: | |
1288 | p = "SELECT CASE"; | |
1289 | break; | |
1290 | case ST_SEQUENCE: | |
1291 | p = "SEQUENCE"; | |
1292 | break; | |
1293 | case ST_SIMPLE_IF: | |
31043f6c | 1294 | p = _("simple IF"); |
6de9cd9a DN |
1295 | break; |
1296 | case ST_STATEMENT_FUNCTION: | |
1297 | p = "STATEMENT FUNCTION"; | |
1298 | break; | |
1299 | case ST_LABEL_ASSIGNMENT: | |
1300 | p = "LABEL ASSIGNMENT"; | |
1301 | break; | |
25d8f0a2 TS |
1302 | case ST_ENUM: |
1303 | p = "ENUM DEFINITION"; | |
1304 | break; | |
1305 | case ST_ENUMERATOR: | |
1306 | p = "ENUMERATOR DEFINITION"; | |
1307 | break; | |
1308 | case ST_END_ENUM: | |
1309 | p = "END ENUM"; | |
1310 | break; | |
6c7a4dfd JJ |
1311 | case ST_OMP_ATOMIC: |
1312 | p = "!$OMP ATOMIC"; | |
1313 | break; | |
1314 | case ST_OMP_BARRIER: | |
1315 | p = "!$OMP BARRIER"; | |
1316 | break; | |
1317 | case ST_OMP_CRITICAL: | |
1318 | p = "!$OMP CRITICAL"; | |
1319 | break; | |
1320 | case ST_OMP_DO: | |
1321 | p = "!$OMP DO"; | |
1322 | break; | |
1323 | case ST_OMP_END_CRITICAL: | |
1324 | p = "!$OMP END CRITICAL"; | |
1325 | break; | |
1326 | case ST_OMP_END_DO: | |
1327 | p = "!$OMP END DO"; | |
1328 | break; | |
1329 | case ST_OMP_END_MASTER: | |
1330 | p = "!$OMP END MASTER"; | |
1331 | break; | |
1332 | case ST_OMP_END_ORDERED: | |
1333 | p = "!$OMP END ORDERED"; | |
1334 | break; | |
1335 | case ST_OMP_END_PARALLEL: | |
1336 | p = "!$OMP END PARALLEL"; | |
1337 | break; | |
1338 | case ST_OMP_END_PARALLEL_DO: | |
1339 | p = "!$OMP END PARALLEL DO"; | |
1340 | break; | |
1341 | case ST_OMP_END_PARALLEL_SECTIONS: | |
1342 | p = "!$OMP END PARALLEL SECTIONS"; | |
1343 | break; | |
1344 | case ST_OMP_END_PARALLEL_WORKSHARE: | |
1345 | p = "!$OMP END PARALLEL WORKSHARE"; | |
1346 | break; | |
1347 | case ST_OMP_END_SECTIONS: | |
1348 | p = "!$OMP END SECTIONS"; | |
1349 | break; | |
1350 | case ST_OMP_END_SINGLE: | |
1351 | p = "!$OMP END SINGLE"; | |
1352 | break; | |
1353 | case ST_OMP_END_WORKSHARE: | |
1354 | p = "!$OMP END WORKSHARE"; | |
1355 | break; | |
1356 | case ST_OMP_FLUSH: | |
1357 | p = "!$OMP FLUSH"; | |
1358 | break; | |
1359 | case ST_OMP_MASTER: | |
1360 | p = "!$OMP MASTER"; | |
1361 | break; | |
1362 | case ST_OMP_ORDERED: | |
1363 | p = "!$OMP ORDERED"; | |
1364 | break; | |
1365 | case ST_OMP_PARALLEL: | |
1366 | p = "!$OMP PARALLEL"; | |
1367 | break; | |
1368 | case ST_OMP_PARALLEL_DO: | |
1369 | p = "!$OMP PARALLEL DO"; | |
1370 | break; | |
1371 | case ST_OMP_PARALLEL_SECTIONS: | |
1372 | p = "!$OMP PARALLEL SECTIONS"; | |
1373 | break; | |
1374 | case ST_OMP_PARALLEL_WORKSHARE: | |
1375 | p = "!$OMP PARALLEL WORKSHARE"; | |
1376 | break; | |
1377 | case ST_OMP_SECTIONS: | |
1378 | p = "!$OMP SECTIONS"; | |
1379 | break; | |
1380 | case ST_OMP_SECTION: | |
1381 | p = "!$OMP SECTION"; | |
1382 | break; | |
1383 | case ST_OMP_SINGLE: | |
1384 | p = "!$OMP SINGLE"; | |
1385 | break; | |
1386 | case ST_OMP_THREADPRIVATE: | |
1387 | p = "!$OMP THREADPRIVATE"; | |
1388 | break; | |
1389 | case ST_OMP_WORKSHARE: | |
1390 | p = "!$OMP WORKSHARE"; | |
1391 | break; | |
6de9cd9a DN |
1392 | default: |
1393 | gfc_internal_error ("gfc_ascii_statement(): Bad statement code"); | |
1394 | } | |
1395 | ||
1396 | return p; | |
1397 | } | |
1398 | ||
1399 | ||
6a869706 EE |
1400 | /* Create a symbol for the main program and assign it to ns->proc_name. */ |
1401 | ||
1402 | static void | |
ecf24057 | 1403 | main_program_symbol (gfc_namespace *ns, const char *name) |
6a869706 EE |
1404 | { |
1405 | gfc_symbol *main_program; | |
1406 | symbol_attribute attr; | |
1407 | ||
ecf24057 | 1408 | gfc_get_symbol (name, ns, &main_program); |
6a869706 | 1409 | gfc_clear_attr (&attr); |
ecf24057 | 1410 | attr.flavor = FL_PROGRAM; |
6a869706 EE |
1411 | attr.proc = PROC_UNKNOWN; |
1412 | attr.subroutine = 1; | |
1413 | attr.access = ACCESS_PUBLIC; | |
1414 | attr.is_main_program = 1; | |
1415 | main_program->attr = attr; | |
1416 | main_program->declared_at = gfc_current_locus; | |
1417 | ns->proc_name = main_program; | |
1418 | gfc_commit_symbols (); | |
1419 | } | |
1420 | ||
1421 | ||
6de9cd9a DN |
1422 | /* Do whatever is necessary to accept the last statement. */ |
1423 | ||
1424 | static void | |
1425 | accept_statement (gfc_statement st) | |
1426 | { | |
6de9cd9a DN |
1427 | switch (st) |
1428 | { | |
1429 | case ST_USE: | |
1430 | gfc_use_module (); | |
1431 | break; | |
1432 | ||
1433 | case ST_IMPLICIT_NONE: | |
1434 | gfc_set_implicit_none (); | |
1435 | break; | |
1436 | ||
1437 | case ST_IMPLICIT: | |
6de9cd9a DN |
1438 | break; |
1439 | ||
1440 | case ST_FUNCTION: | |
1441 | case ST_SUBROUTINE: | |
1442 | case ST_MODULE: | |
1443 | gfc_current_ns->proc_name = gfc_new_block; | |
1444 | break; | |
1445 | ||
1446 | /* If the statement is the end of a block, lay down a special code | |
edf1eac2 SK |
1447 | that allows a branch to the end of the block from within the |
1448 | construct. */ | |
6de9cd9a DN |
1449 | |
1450 | case ST_ENDIF: | |
6de9cd9a DN |
1451 | case ST_END_SELECT: |
1452 | if (gfc_statement_label != NULL) | |
1453 | { | |
1454 | new_st.op = EXEC_NOP; | |
1455 | add_statement (); | |
1456 | } | |
1457 | ||
1458 | break; | |
1459 | ||
1460 | /* The end-of-program unit statements do not get the special | |
edf1eac2 SK |
1461 | marker and require a statement of some sort if they are a |
1462 | branch target. */ | |
6de9cd9a DN |
1463 | |
1464 | case ST_END_PROGRAM: | |
1465 | case ST_END_FUNCTION: | |
1466 | case ST_END_SUBROUTINE: | |
1467 | if (gfc_statement_label != NULL) | |
1468 | { | |
1469 | new_st.op = EXEC_RETURN; | |
1470 | add_statement (); | |
1471 | } | |
1472 | ||
1473 | break; | |
1474 | ||
3d79abbd | 1475 | case ST_ENTRY: |
6de9cd9a DN |
1476 | case_executable: |
1477 | case_exec_markers: | |
1478 | add_statement (); | |
1479 | break; | |
1480 | ||
1481 | default: | |
1482 | break; | |
1483 | } | |
1484 | ||
1485 | gfc_commit_symbols (); | |
1486 | gfc_warning_check (); | |
1487 | gfc_clear_new_st (); | |
1488 | } | |
1489 | ||
1490 | ||
1491 | /* Undo anything tentative that has been built for the current | |
1492 | statement. */ | |
1493 | ||
1494 | static void | |
1495 | reject_statement (void) | |
1496 | { | |
8e785b78 | 1497 | gfc_new_block = NULL; |
6de9cd9a DN |
1498 | gfc_undo_symbols (); |
1499 | gfc_clear_warning (); | |
1500 | undo_new_statement (); | |
1501 | } | |
1502 | ||
1503 | ||
1504 | /* Generic complaint about an out of order statement. We also do | |
1505 | whatever is necessary to clean up. */ | |
1506 | ||
1507 | static void | |
1508 | unexpected_statement (gfc_statement st) | |
1509 | { | |
6de9cd9a DN |
1510 | gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st)); |
1511 | ||
1512 | reject_statement (); | |
1513 | } | |
1514 | ||
1515 | ||
1516 | /* Given the next statement seen by the matcher, make sure that it is | |
1517 | in proper order with the last. This subroutine is initialized by | |
1518 | calling it with an argument of ST_NONE. If there is a problem, we | |
1519 | issue an error and return FAILURE. Otherwise we return SUCCESS. | |
1520 | ||
1521 | Individual parsers need to verify that the statements seen are | |
1522 | valid before calling here, ie ENTRY statements are not allowed in | |
1523 | INTERFACE blocks. The following diagram is taken from the standard: | |
1524 | ||
edf1eac2 SK |
1525 | +---------------------------------------+ |
1526 | | program subroutine function module | | |
1527 | +---------------------------------------+ | |
1528 | | use | | |
1529 | +---------------------------------------+ | |
1530 | | import | | |
1531 | +---------------------------------------+ | |
1532 | | | implicit none | | |
1533 | | +-----------+------------------+ | |
1534 | | | parameter | implicit | | |
1535 | | +-----------+------------------+ | |
1536 | | format | | derived type | | |
1537 | | entry | parameter | interface | | |
1538 | | | data | specification | | |
1539 | | | | statement func | | |
1540 | | +-----------+------------------+ | |
1541 | | | data | executable | | |
1542 | +--------+-----------+------------------+ | |
1543 | | contains | | |
1544 | +---------------------------------------+ | |
1545 | | internal module/subprogram | | |
1546 | +---------------------------------------+ | |
1547 | | end | | |
1548 | +---------------------------------------+ | |
6de9cd9a DN |
1549 | |
1550 | */ | |
1551 | ||
1552 | typedef struct | |
1553 | { | |
1554 | enum | |
8998be20 TB |
1555 | { ORDER_START, ORDER_USE, ORDER_IMPORT, ORDER_IMPLICIT_NONE, |
1556 | ORDER_IMPLICIT, ORDER_SPEC, ORDER_EXEC | |
6de9cd9a DN |
1557 | } |
1558 | state; | |
1559 | gfc_statement last_statement; | |
1560 | locus where; | |
1561 | } | |
1562 | st_state; | |
1563 | ||
1564 | static try | |
edf1eac2 | 1565 | verify_st_order (st_state *p, gfc_statement st) |
6de9cd9a DN |
1566 | { |
1567 | ||
1568 | switch (st) | |
1569 | { | |
1570 | case ST_NONE: | |
1571 | p->state = ORDER_START; | |
1572 | break; | |
1573 | ||
1574 | case ST_USE: | |
1575 | if (p->state > ORDER_USE) | |
1576 | goto order; | |
1577 | p->state = ORDER_USE; | |
1578 | break; | |
1579 | ||
8998be20 TB |
1580 | case ST_IMPORT: |
1581 | if (p->state > ORDER_IMPORT) | |
1582 | goto order; | |
1583 | p->state = ORDER_IMPORT; | |
1584 | break; | |
1585 | ||
6de9cd9a DN |
1586 | case ST_IMPLICIT_NONE: |
1587 | if (p->state > ORDER_IMPLICIT_NONE) | |
1588 | goto order; | |
1589 | ||
edf1eac2 SK |
1590 | /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY |
1591 | statement disqualifies a USE but not an IMPLICIT NONE. | |
1592 | Duplicate IMPLICIT NONEs are caught when the implicit types | |
1593 | are set. */ | |
6de9cd9a DN |
1594 | |
1595 | p->state = ORDER_IMPLICIT_NONE; | |
1596 | break; | |
1597 | ||
1598 | case ST_IMPLICIT: | |
1599 | if (p->state > ORDER_IMPLICIT) | |
1600 | goto order; | |
1601 | p->state = ORDER_IMPLICIT; | |
1602 | break; | |
1603 | ||
1604 | case ST_FORMAT: | |
1605 | case ST_ENTRY: | |
1606 | if (p->state < ORDER_IMPLICIT_NONE) | |
1607 | p->state = ORDER_IMPLICIT_NONE; | |
1608 | break; | |
1609 | ||
1610 | case ST_PARAMETER: | |
1611 | if (p->state >= ORDER_EXEC) | |
1612 | goto order; | |
1613 | if (p->state < ORDER_IMPLICIT) | |
1614 | p->state = ORDER_IMPLICIT; | |
1615 | break; | |
1616 | ||
1617 | case ST_DATA: | |
1618 | if (p->state < ORDER_SPEC) | |
1619 | p->state = ORDER_SPEC; | |
1620 | break; | |
1621 | ||
1622 | case ST_PUBLIC: | |
1623 | case ST_PRIVATE: | |
1624 | case ST_DERIVED_DECL: | |
1625 | case_decl: | |
1626 | if (p->state >= ORDER_EXEC) | |
1627 | goto order; | |
1628 | if (p->state < ORDER_SPEC) | |
1629 | p->state = ORDER_SPEC; | |
1630 | break; | |
1631 | ||
1632 | case_executable: | |
1633 | case_exec_markers: | |
1634 | if (p->state < ORDER_EXEC) | |
1635 | p->state = ORDER_EXEC; | |
1636 | break; | |
1637 | ||
1638 | default: | |
edf1eac2 SK |
1639 | gfc_internal_error ("Unexpected %s statement in verify_st_order() at %C", |
1640 | gfc_ascii_statement (st)); | |
6de9cd9a DN |
1641 | } |
1642 | ||
1643 | /* All is well, record the statement in case we need it next time. */ | |
63645982 | 1644 | p->where = gfc_current_locus; |
6de9cd9a DN |
1645 | p->last_statement = st; |
1646 | return SUCCESS; | |
1647 | ||
1648 | order: | |
1649 | gfc_error ("%s statement at %C cannot follow %s statement at %L", | |
1650 | gfc_ascii_statement (st), | |
1651 | gfc_ascii_statement (p->last_statement), &p->where); | |
1652 | ||
1653 | return FAILURE; | |
1654 | } | |
1655 | ||
1656 | ||
1657 | /* Handle an unexpected end of file. This is a show-stopper... */ | |
1658 | ||
1659 | static void unexpected_eof (void) ATTRIBUTE_NORETURN; | |
1660 | ||
1661 | static void | |
1662 | unexpected_eof (void) | |
1663 | { | |
1664 | gfc_state_data *p; | |
1665 | ||
d4fa05b9 | 1666 | gfc_error ("Unexpected end of file in '%s'", gfc_source_file); |
6de9cd9a DN |
1667 | |
1668 | /* Memory cleanup. Move to "second to last". */ | |
1669 | for (p = gfc_state_stack; p && p->previous && p->previous->previous; | |
1670 | p = p->previous); | |
1671 | ||
1672 | gfc_current_ns->code = (p && p->previous) ? p->head : NULL; | |
1673 | gfc_done_2 (); | |
1674 | ||
f13ab1ee | 1675 | longjmp (eof_buf, 1); |
6de9cd9a DN |
1676 | } |
1677 | ||
1678 | ||
1679 | /* Parse a derived type. */ | |
1680 | ||
1681 | static void | |
1682 | parse_derived (void) | |
1683 | { | |
1684 | int compiling_type, seen_private, seen_sequence, seen_component, error_flag; | |
1685 | gfc_statement st; | |
6de9cd9a | 1686 | gfc_state_data s; |
a8b3b0b6 | 1687 | gfc_symbol *derived_sym = NULL; |
5046aff5 PT |
1688 | gfc_symbol *sym; |
1689 | gfc_component *c; | |
6de9cd9a DN |
1690 | |
1691 | error_flag = 0; | |
1692 | ||
1693 | accept_statement (ST_DERIVED_DECL); | |
1694 | push_state (&s, COMP_DERIVED, gfc_new_block); | |
1695 | ||
1696 | gfc_new_block->component_access = ACCESS_PUBLIC; | |
1697 | seen_private = 0; | |
1698 | seen_sequence = 0; | |
1699 | seen_component = 0; | |
1700 | ||
1701 | compiling_type = 1; | |
1702 | ||
1703 | while (compiling_type) | |
1704 | { | |
1705 | st = next_statement (); | |
1706 | switch (st) | |
1707 | { | |
1708 | case ST_NONE: | |
1709 | unexpected_eof (); | |
1710 | ||
1711 | case ST_DATA_DECL: | |
69773742 | 1712 | case ST_PROCEDURE: |
6de9cd9a DN |
1713 | accept_statement (st); |
1714 | seen_component = 1; | |
1715 | break; | |
1716 | ||
1717 | case ST_END_TYPE: | |
1718 | compiling_type = 0; | |
1719 | ||
c5b9117e TB |
1720 | if (!seen_component |
1721 | && (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Derived type " | |
1722 | "definition at %C without components") | |
1723 | == FAILURE)) | |
1724 | error_flag = 1; | |
6de9cd9a DN |
1725 | |
1726 | accept_statement (ST_END_TYPE); | |
1727 | break; | |
1728 | ||
1729 | case ST_PRIVATE: | |
1730 | if (gfc_find_state (COMP_MODULE) == FAILURE) | |
1731 | { | |
edf1eac2 SK |
1732 | gfc_error ("PRIVATE statement in TYPE at %C must be inside " |
1733 | "a MODULE"); | |
6de9cd9a DN |
1734 | error_flag = 1; |
1735 | break; | |
1736 | } | |
1737 | ||
1738 | if (seen_component) | |
1739 | { | |
1740 | gfc_error ("PRIVATE statement at %C must precede " | |
1741 | "structure components"); | |
1742 | error_flag = 1; | |
1743 | break; | |
1744 | } | |
1745 | ||
1746 | if (seen_private) | |
1747 | { | |
1748 | gfc_error ("Duplicate PRIVATE statement at %C"); | |
1749 | error_flag = 1; | |
1750 | } | |
1751 | ||
1752 | s.sym->component_access = ACCESS_PRIVATE; | |
1753 | accept_statement (ST_PRIVATE); | |
1754 | seen_private = 1; | |
1755 | break; | |
1756 | ||
1757 | case ST_SEQUENCE: | |
1758 | if (seen_component) | |
1759 | { | |
1760 | gfc_error ("SEQUENCE statement at %C must precede " | |
1761 | "structure components"); | |
1762 | error_flag = 1; | |
1763 | break; | |
1764 | } | |
1765 | ||
1766 | if (gfc_current_block ()->attr.sequence) | |
1767 | gfc_warning ("SEQUENCE attribute at %C already specified in " | |
1768 | "TYPE statement"); | |
1769 | ||
1770 | if (seen_sequence) | |
1771 | { | |
1772 | gfc_error ("Duplicate SEQUENCE statement at %C"); | |
1773 | error_flag = 1; | |
1774 | } | |
1775 | ||
1776 | seen_sequence = 1; | |
231b2fcc TS |
1777 | gfc_add_sequence (&gfc_current_block ()->attr, |
1778 | gfc_current_block ()->name, NULL); | |
6de9cd9a DN |
1779 | break; |
1780 | ||
1781 | default: | |
1782 | unexpected_statement (st); | |
1783 | break; | |
1784 | } | |
1785 | } | |
1786 | ||
a8b3b0b6 CR |
1787 | /* need to verify that all fields of the derived type are |
1788 | * interoperable with C if the type is declared to be bind(c) | |
1789 | */ | |
1790 | derived_sym = gfc_current_block(); | |
1791 | ||
5046aff5 PT |
1792 | sym = gfc_current_block (); |
1793 | for (c = sym->components; c; c = c->next) | |
1794 | { | |
5cca320d | 1795 | /* Look for allocatable components. */ |
edf1eac2 SK |
1796 | if (c->allocatable |
1797 | || (c->ts.type == BT_DERIVED && c->ts.derived->attr.alloc_comp)) | |
5046aff5 PT |
1798 | { |
1799 | sym->attr.alloc_comp = 1; | |
1800 | break; | |
1801 | } | |
5cca320d DF |
1802 | |
1803 | /* Look for pointer components. */ | |
1804 | if (c->pointer | |
1805 | || (c->ts.type == BT_DERIVED && c->ts.derived->attr.pointer_comp)) | |
1806 | { | |
1807 | sym->attr.pointer_comp = 1; | |
1808 | break; | |
1809 | } | |
1810 | ||
1811 | /* Look for private components. */ | |
1812 | if (sym->component_access == ACCESS_PRIVATE | |
1813 | || c->access == ACCESS_PRIVATE | |
1814 | || (c->ts.type == BT_DERIVED && c->ts.derived->attr.private_comp)) | |
1815 | { | |
1816 | sym->attr.private_comp = 1; | |
1817 | break; | |
1818 | } | |
1819 | } | |
5046aff5 | 1820 | |
9fa6b0af FXC |
1821 | if (!seen_component) |
1822 | sym->attr.zero_comp = 1; | |
1823 | ||
6de9cd9a DN |
1824 | pop_state (); |
1825 | } | |
1826 | ||
1827 | ||
25d8f0a2 TS |
1828 | /* Parse an ENUM. */ |
1829 | ||
1830 | static void | |
1831 | parse_enum (void) | |
1832 | { | |
1833 | int error_flag; | |
1834 | gfc_statement st; | |
1835 | int compiling_enum; | |
1836 | gfc_state_data s; | |
1837 | int seen_enumerator = 0; | |
1838 | ||
1839 | error_flag = 0; | |
1840 | ||
1841 | push_state (&s, COMP_ENUM, gfc_new_block); | |
1842 | ||
1843 | compiling_enum = 1; | |
1844 | ||
1845 | while (compiling_enum) | |
1846 | { | |
1847 | st = next_statement (); | |
1848 | switch (st) | |
edf1eac2 SK |
1849 | { |
1850 | case ST_NONE: | |
1851 | unexpected_eof (); | |
1852 | break; | |
25d8f0a2 | 1853 | |
edf1eac2 | 1854 | case ST_ENUMERATOR: |
25d8f0a2 | 1855 | seen_enumerator = 1; |
edf1eac2 SK |
1856 | accept_statement (st); |
1857 | break; | |
25d8f0a2 | 1858 | |
edf1eac2 SK |
1859 | case ST_END_ENUM: |
1860 | compiling_enum = 0; | |
25d8f0a2 | 1861 | if (!seen_enumerator) |
edf1eac2 SK |
1862 | { |
1863 | gfc_error ("ENUM declaration at %C has no ENUMERATORS"); | |
25d8f0a2 | 1864 | error_flag = 1; |
edf1eac2 SK |
1865 | } |
1866 | accept_statement (st); | |
1867 | break; | |
1868 | ||
1869 | default: | |
1870 | gfc_free_enum_history (); | |
1871 | unexpected_statement (st); | |
1872 | break; | |
1873 | } | |
25d8f0a2 TS |
1874 | } |
1875 | pop_state (); | |
1876 | } | |
1877 | ||
edf1eac2 | 1878 | |
6de9cd9a DN |
1879 | /* Parse an interface. We must be able to deal with the possibility |
1880 | of recursive interfaces. The parse_spec() subroutine is mutually | |
1881 | recursive with parse_interface(). */ | |
1882 | ||
1883 | static gfc_statement parse_spec (gfc_statement); | |
1884 | ||
1885 | static void | |
1886 | parse_interface (void) | |
1887 | { | |
1888 | gfc_compile_state new_state, current_state; | |
1889 | gfc_symbol *prog_unit, *sym; | |
1890 | gfc_interface_info save; | |
1891 | gfc_state_data s1, s2; | |
1892 | gfc_statement st; | |
536afc35 | 1893 | locus proc_locus; |
6de9cd9a DN |
1894 | |
1895 | accept_statement (ST_INTERFACE); | |
1896 | ||
1897 | current_interface.ns = gfc_current_ns; | |
1898 | save = current_interface; | |
1899 | ||
1900 | sym = (current_interface.type == INTERFACE_GENERIC | |
edf1eac2 SK |
1901 | || current_interface.type == INTERFACE_USER_OP) |
1902 | ? gfc_new_block : NULL; | |
6de9cd9a DN |
1903 | |
1904 | push_state (&s1, COMP_INTERFACE, sym); | |
6de9cd9a DN |
1905 | current_state = COMP_NONE; |
1906 | ||
1907 | loop: | |
0366dfe9 | 1908 | gfc_current_ns = gfc_get_namespace (current_interface.ns, 0); |
6de9cd9a DN |
1909 | |
1910 | st = next_statement (); | |
1911 | switch (st) | |
1912 | { | |
1913 | case ST_NONE: | |
1914 | unexpected_eof (); | |
1915 | ||
1916 | case ST_SUBROUTINE: | |
1917 | new_state = COMP_SUBROUTINE; | |
1918 | gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY, | |
1919 | gfc_new_block->formal, NULL); | |
1920 | break; | |
1921 | ||
1922 | case ST_FUNCTION: | |
1923 | new_state = COMP_FUNCTION; | |
1924 | gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY, | |
1925 | gfc_new_block->formal, NULL); | |
1926 | break; | |
1927 | ||
69773742 | 1928 | case ST_PROCEDURE: |
6de9cd9a DN |
1929 | case ST_MODULE_PROC: /* The module procedure matcher makes |
1930 | sure the context is correct. */ | |
6de9cd9a DN |
1931 | accept_statement (st); |
1932 | gfc_free_namespace (gfc_current_ns); | |
1933 | goto loop; | |
1934 | ||
1935 | case ST_END_INTERFACE: | |
1936 | gfc_free_namespace (gfc_current_ns); | |
1937 | gfc_current_ns = current_interface.ns; | |
1938 | goto done; | |
1939 | ||
1940 | default: | |
1941 | gfc_error ("Unexpected %s statement in INTERFACE block at %C", | |
1942 | gfc_ascii_statement (st)); | |
1943 | reject_statement (); | |
1944 | gfc_free_namespace (gfc_current_ns); | |
1945 | goto loop; | |
1946 | } | |
1947 | ||
1948 | ||
1949 | /* Make sure that a generic interface has only subroutines or | |
1950 | functions and that the generic name has the right attribute. */ | |
1951 | if (current_interface.type == INTERFACE_GENERIC) | |
1952 | { | |
1953 | if (current_state == COMP_NONE) | |
1954 | { | |
1955 | if (new_state == COMP_FUNCTION) | |
231b2fcc TS |
1956 | gfc_add_function (&sym->attr, sym->name, NULL); |
1957 | else if (new_state == COMP_SUBROUTINE) | |
1958 | gfc_add_subroutine (&sym->attr, sym->name, NULL); | |
6de9cd9a DN |
1959 | |
1960 | current_state = new_state; | |
1961 | } | |
1962 | else | |
1963 | { | |
1964 | if (new_state != current_state) | |
1965 | { | |
1966 | if (new_state == COMP_SUBROUTINE) | |
edf1eac2 SK |
1967 | gfc_error ("SUBROUTINE at %C does not belong in a " |
1968 | "generic function interface"); | |
6de9cd9a DN |
1969 | |
1970 | if (new_state == COMP_FUNCTION) | |
edf1eac2 SK |
1971 | gfc_error ("FUNCTION at %C does not belong in a " |
1972 | "generic subroutine interface"); | |
6de9cd9a DN |
1973 | } |
1974 | } | |
1975 | } | |
1976 | ||
9e1d712c TB |
1977 | if (current_interface.type == INTERFACE_ABSTRACT) |
1978 | { | |
1979 | gfc_new_block->attr.abstract = 1; | |
e9c06563 TB |
1980 | if (gfc_is_intrinsic_typename (gfc_new_block->name)) |
1981 | gfc_error ("Name '%s' of ABSTRACT INTERFACE at %C " | |
1982 | "cannot be the same as an intrinsic type", | |
1983 | gfc_new_block->name); | |
9e1d712c TB |
1984 | } |
1985 | ||
6de9cd9a DN |
1986 | push_state (&s2, new_state, gfc_new_block); |
1987 | accept_statement (st); | |
1988 | prog_unit = gfc_new_block; | |
1989 | prog_unit->formal_ns = gfc_current_ns; | |
536afc35 | 1990 | proc_locus = gfc_current_locus; |
6de9cd9a DN |
1991 | |
1992 | decl: | |
1993 | /* Read data declaration statements. */ | |
1994 | st = parse_spec (ST_NONE); | |
1995 | ||
f68abf4a PT |
1996 | /* Since the interface block does not permit an IMPLICIT statement, |
1997 | the default type for the function or the result must be taken | |
1998 | from the formal namespace. */ | |
1999 | if (new_state == COMP_FUNCTION) | |
2000 | { | |
2001 | if (prog_unit->result == prog_unit | |
2002 | && prog_unit->ts.type == BT_UNKNOWN) | |
2003 | gfc_set_default_type (prog_unit, 1, prog_unit->formal_ns); | |
2004 | else if (prog_unit->result != prog_unit | |
2005 | && prog_unit->result->ts.type == BT_UNKNOWN) | |
2006 | gfc_set_default_type (prog_unit->result, 1, | |
2007 | prog_unit->formal_ns); | |
2008 | } | |
2009 | ||
6de9cd9a DN |
2010 | if (st != ST_END_SUBROUTINE && st != ST_END_FUNCTION) |
2011 | { | |
2012 | gfc_error ("Unexpected %s statement at %C in INTERFACE body", | |
2013 | gfc_ascii_statement (st)); | |
2014 | reject_statement (); | |
2015 | goto decl; | |
2016 | } | |
2017 | ||
6de9cd9a DN |
2018 | current_interface = save; |
2019 | gfc_add_interface (prog_unit); | |
6de9cd9a | 2020 | pop_state (); |
536afc35 PT |
2021 | |
2022 | if (current_interface.ns | |
2023 | && current_interface.ns->proc_name | |
2024 | && strcmp (current_interface.ns->proc_name->name, | |
2025 | prog_unit->name) == 0) | |
2026 | gfc_error ("INTERFACE procedure '%s' at %L has the same name as the " | |
2027 | "enclosing procedure", prog_unit->name, &proc_locus); | |
2028 | ||
6de9cd9a DN |
2029 | goto loop; |
2030 | ||
2031 | done: | |
6de9cd9a DN |
2032 | pop_state (); |
2033 | } | |
2034 | ||
2035 | ||
1c8bcdf7 PT |
2036 | /* Associate function characteristics by going back to the function |
2037 | declaration and rematching the prefix. */ | |
e2d29968 | 2038 | |
1c8bcdf7 | 2039 | static match |
e2d29968 PT |
2040 | match_deferred_characteristics (gfc_typespec * ts) |
2041 | { | |
2042 | locus loc; | |
1c8bcdf7 PT |
2043 | match m = MATCH_ERROR; |
2044 | char name[GFC_MAX_SYMBOL_LEN + 1]; | |
e2d29968 PT |
2045 | |
2046 | loc = gfc_current_locus; | |
2047 | ||
1c8bcdf7 PT |
2048 | gfc_current_locus = gfc_current_block ()->declared_at; |
2049 | ||
2050 | gfc_clear_error (); | |
2051 | gfc_buffer_error (1); | |
2052 | m = gfc_match_prefix (ts); | |
2053 | gfc_buffer_error (0); | |
2054 | ||
2055 | if (ts->type == BT_DERIVED) | |
e2d29968 | 2056 | { |
1c8bcdf7 PT |
2057 | ts->kind = 0; |
2058 | ||
2059 | if (!ts->derived || !ts->derived->components) | |
2060 | m = MATCH_ERROR; | |
e2d29968 | 2061 | } |
1c8bcdf7 PT |
2062 | |
2063 | /* Only permit one go at the characteristic association. */ | |
2064 | if (ts->kind == -1) | |
2065 | ts->kind = 0; | |
2066 | ||
2067 | /* Set the function locus correctly. If we have not found the | |
2068 | function name, there is an error. */ | |
2069 | gfc_match ("function% %n", name); | |
2070 | if (m == MATCH_YES && strcmp (name, gfc_current_block ()->name) == 0) | |
e2d29968 | 2071 | { |
1c8bcdf7 PT |
2072 | gfc_current_block ()->declared_at = gfc_current_locus; |
2073 | gfc_commit_symbols (); | |
e2d29968 | 2074 | } |
1c8bcdf7 PT |
2075 | else |
2076 | gfc_error_check (); | |
e2d29968 | 2077 | |
e2d29968 PT |
2078 | gfc_current_locus =loc; |
2079 | return m; | |
2080 | } | |
2081 | ||
2082 | ||
6de9cd9a DN |
2083 | /* Parse a set of specification statements. Returns the statement |
2084 | that doesn't fit. */ | |
2085 | ||
2086 | static gfc_statement | |
2087 | parse_spec (gfc_statement st) | |
2088 | { | |
2089 | st_state ss; | |
1c8bcdf7 PT |
2090 | bool bad_characteristic = false; |
2091 | gfc_typespec *ts; | |
6de9cd9a DN |
2092 | |
2093 | verify_st_order (&ss, ST_NONE); | |
2094 | if (st == ST_NONE) | |
2095 | st = next_statement (); | |
2096 | ||
2097 | loop: | |
2098 | switch (st) | |
2099 | { | |
2100 | case ST_NONE: | |
2101 | unexpected_eof (); | |
2102 | ||
2103 | case ST_FORMAT: | |
2104 | case ST_ENTRY: | |
2105 | case ST_DATA: /* Not allowed in interfaces */ | |
2106 | if (gfc_current_state () == COMP_INTERFACE) | |
2107 | break; | |
2108 | ||
2109 | /* Fall through */ | |
2110 | ||
2111 | case ST_USE: | |
8998be20 | 2112 | case ST_IMPORT: |
6de9cd9a DN |
2113 | case ST_IMPLICIT_NONE: |
2114 | case ST_IMPLICIT: | |
2115 | case ST_PARAMETER: | |
2116 | case ST_PUBLIC: | |
2117 | case ST_PRIVATE: | |
2118 | case ST_DERIVED_DECL: | |
2119 | case_decl: | |
2120 | if (verify_st_order (&ss, st) == FAILURE) | |
2121 | { | |
2122 | reject_statement (); | |
2123 | st = next_statement (); | |
2124 | goto loop; | |
2125 | } | |
2126 | ||
2127 | switch (st) | |
2128 | { | |
2129 | case ST_INTERFACE: | |
2130 | parse_interface (); | |
2131 | break; | |
2132 | ||
2133 | case ST_DERIVED_DECL: | |
2134 | parse_derived (); | |
2135 | break; | |
2136 | ||
2137 | case ST_PUBLIC: | |
2138 | case ST_PRIVATE: | |
2139 | if (gfc_current_state () != COMP_MODULE) | |
2140 | { | |
2141 | gfc_error ("%s statement must appear in a MODULE", | |
2142 | gfc_ascii_statement (st)); | |
2143 | break; | |
2144 | } | |
2145 | ||
2146 | if (gfc_current_ns->default_access != ACCESS_UNKNOWN) | |
2147 | { | |
2148 | gfc_error ("%s statement at %C follows another accessibility " | |
2149 | "specification", gfc_ascii_statement (st)); | |
2150 | break; | |
2151 | } | |
2152 | ||
2153 | gfc_current_ns->default_access = (st == ST_PUBLIC) | |
2154 | ? ACCESS_PUBLIC : ACCESS_PRIVATE; | |
2155 | ||
2156 | break; | |
2157 | ||
dec9e22d DF |
2158 | case ST_STATEMENT_FUNCTION: |
2159 | if (gfc_current_state () == COMP_MODULE) | |
2160 | { | |
2161 | unexpected_statement (st); | |
2162 | break; | |
2163 | } | |
2164 | ||
6de9cd9a DN |
2165 | default: |
2166 | break; | |
2167 | } | |
2168 | ||
2169 | accept_statement (st); | |
25d8f0a2 TS |
2170 | st = next_statement (); |
2171 | goto loop; | |
2172 | ||
2173 | case ST_ENUM: | |
2174 | accept_statement (st); | |
2175 | parse_enum(); | |
6de9cd9a DN |
2176 | st = next_statement (); |
2177 | goto loop; | |
2178 | ||
1c8bcdf7 PT |
2179 | case ST_GET_FCN_CHARACTERISTICS: |
2180 | /* This statement triggers the association of a function's result | |
2181 | characteristics. */ | |
2182 | ts = &gfc_current_block ()->result->ts; | |
2183 | if (match_deferred_characteristics (ts) != MATCH_YES) | |
2184 | bad_characteristic = true; | |
2185 | ||
2186 | st = next_statement (); | |
2187 | goto loop; | |
2188 | ||
6de9cd9a DN |
2189 | default: |
2190 | break; | |
2191 | } | |
2192 | ||
1c8bcdf7 PT |
2193 | /* If match_deferred_characteristics failed, then there is an error. */ |
2194 | if (bad_characteristic) | |
e2d29968 | 2195 | { |
1c8bcdf7 PT |
2196 | ts = &gfc_current_block ()->result->ts; |
2197 | if (ts->type != BT_DERIVED) | |
e2d29968 | 2198 | gfc_error ("Bad kind expression for function '%s' at %L", |
1c8bcdf7 PT |
2199 | gfc_current_block ()->name, |
2200 | &gfc_current_block ()->declared_at); | |
e2d29968 PT |
2201 | else |
2202 | gfc_error ("The type for function '%s' at %L is not accessible", | |
1c8bcdf7 PT |
2203 | gfc_current_block ()->name, |
2204 | &gfc_current_block ()->declared_at); | |
2205 | ||
2206 | gfc_current_block ()->ts.kind = 0; | |
2207 | /* Keep the derived type; if it's bad, it will be discovered later. */ | |
2ddd2871 | 2208 | if (!(ts->type == BT_DERIVED && ts->derived)) |
1c8bcdf7 | 2209 | ts->type = BT_UNKNOWN; |
e2d29968 PT |
2210 | } |
2211 | ||
6de9cd9a DN |
2212 | return st; |
2213 | } | |
2214 | ||
2215 | ||
2216 | /* Parse a WHERE block, (not a simple WHERE statement). */ | |
2217 | ||
2218 | static void | |
2219 | parse_where_block (void) | |
2220 | { | |
2221 | int seen_empty_else; | |
2222 | gfc_code *top, *d; | |
2223 | gfc_state_data s; | |
2224 | gfc_statement st; | |
2225 | ||
2226 | accept_statement (ST_WHERE_BLOCK); | |
2227 | top = gfc_state_stack->tail; | |
2228 | ||
2229 | push_state (&s, COMP_WHERE, gfc_new_block); | |
2230 | ||
2231 | d = add_statement (); | |
2232 | d->expr = top->expr; | |
2233 | d->op = EXEC_WHERE; | |
2234 | ||
2235 | top->expr = NULL; | |
2236 | top->block = d; | |
2237 | ||
2238 | seen_empty_else = 0; | |
2239 | ||
2240 | do | |
2241 | { | |
2242 | st = next_statement (); | |
2243 | switch (st) | |
2244 | { | |
2245 | case ST_NONE: | |
2246 | unexpected_eof (); | |
2247 | ||
2248 | case ST_WHERE_BLOCK: | |
2249 | parse_where_block (); | |
edf1eac2 | 2250 | break; |
6de9cd9a DN |
2251 | |
2252 | case ST_ASSIGNMENT: | |
2253 | case ST_WHERE: | |
2254 | accept_statement (st); | |
2255 | break; | |
2256 | ||
2257 | case ST_ELSEWHERE: | |
2258 | if (seen_empty_else) | |
2259 | { | |
edf1eac2 SK |
2260 | gfc_error ("ELSEWHERE statement at %C follows previous " |
2261 | "unmasked ELSEWHERE"); | |
6de9cd9a DN |
2262 | break; |
2263 | } | |
2264 | ||
2265 | if (new_st.expr == NULL) | |
2266 | seen_empty_else = 1; | |
2267 | ||
2268 | d = new_level (gfc_state_stack->head); | |
2269 | d->op = EXEC_WHERE; | |
2270 | d->expr = new_st.expr; | |
2271 | ||
2272 | accept_statement (st); | |
2273 | ||
2274 | break; | |
2275 | ||
2276 | case ST_END_WHERE: | |
2277 | accept_statement (st); | |
2278 | break; | |
2279 | ||
2280 | default: | |
2281 | gfc_error ("Unexpected %s statement in WHERE block at %C", | |
2282 | gfc_ascii_statement (st)); | |
2283 | reject_statement (); | |
2284 | break; | |
2285 | } | |
6de9cd9a DN |
2286 | } |
2287 | while (st != ST_END_WHERE); | |
2288 | ||
2289 | pop_state (); | |
2290 | } | |
2291 | ||
2292 | ||
2293 | /* Parse a FORALL block (not a simple FORALL statement). */ | |
2294 | ||
2295 | static void | |
2296 | parse_forall_block (void) | |
2297 | { | |
2298 | gfc_code *top, *d; | |
2299 | gfc_state_data s; | |
2300 | gfc_statement st; | |
2301 | ||
2302 | accept_statement (ST_FORALL_BLOCK); | |
2303 | top = gfc_state_stack->tail; | |
2304 | ||
2305 | push_state (&s, COMP_FORALL, gfc_new_block); | |
2306 | ||
2307 | d = add_statement (); | |
2308 | d->op = EXEC_FORALL; | |
2309 | top->block = d; | |
2310 | ||
2311 | do | |
2312 | { | |
2313 | st = next_statement (); | |
2314 | switch (st) | |
2315 | { | |
2316 | ||
2317 | case ST_ASSIGNMENT: | |
2318 | case ST_POINTER_ASSIGNMENT: | |
2319 | case ST_WHERE: | |
2320 | case ST_FORALL: | |
2321 | accept_statement (st); | |
2322 | break; | |
2323 | ||
2324 | case ST_WHERE_BLOCK: | |
2325 | parse_where_block (); | |
2326 | break; | |
2327 | ||
2328 | case ST_FORALL_BLOCK: | |
2329 | parse_forall_block (); | |
2330 | break; | |
2331 | ||
2332 | case ST_END_FORALL: | |
2333 | accept_statement (st); | |
2334 | break; | |
2335 | ||
2336 | case ST_NONE: | |
2337 | unexpected_eof (); | |
2338 | ||
2339 | default: | |
2340 | gfc_error ("Unexpected %s statement in FORALL block at %C", | |
2341 | gfc_ascii_statement (st)); | |
2342 | ||
2343 | reject_statement (); | |
2344 | break; | |
2345 | } | |
2346 | } | |
2347 | while (st != ST_END_FORALL); | |
2348 | ||
2349 | pop_state (); | |
2350 | } | |
2351 | ||
2352 | ||
2353 | static gfc_statement parse_executable (gfc_statement); | |
2354 | ||
2355 | /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */ | |
2356 | ||
2357 | static void | |
2358 | parse_if_block (void) | |
2359 | { | |
2360 | gfc_code *top, *d; | |
2361 | gfc_statement st; | |
2362 | locus else_locus; | |
2363 | gfc_state_data s; | |
2364 | int seen_else; | |
2365 | ||
2366 | seen_else = 0; | |
2367 | accept_statement (ST_IF_BLOCK); | |
2368 | ||
2369 | top = gfc_state_stack->tail; | |
2370 | push_state (&s, COMP_IF, gfc_new_block); | |
2371 | ||
2372 | new_st.op = EXEC_IF; | |
2373 | d = add_statement (); | |
2374 | ||
2375 | d->expr = top->expr; | |
2376 | top->expr = NULL; | |
2377 | top->block = d; | |
2378 | ||
2379 | do | |
2380 | { | |
2381 | st = parse_executable (ST_NONE); | |
2382 | ||
2383 | switch (st) | |
2384 | { | |
2385 | case ST_NONE: | |
2386 | unexpected_eof (); | |
2387 | ||
2388 | case ST_ELSEIF: | |
2389 | if (seen_else) | |
2390 | { | |
edf1eac2 SK |
2391 | gfc_error ("ELSE IF statement at %C cannot follow ELSE " |
2392 | "statement at %L", &else_locus); | |
6de9cd9a DN |
2393 | |
2394 | reject_statement (); | |
2395 | break; | |
2396 | } | |
2397 | ||
2398 | d = new_level (gfc_state_stack->head); | |
2399 | d->op = EXEC_IF; | |
2400 | d->expr = new_st.expr; | |
2401 | ||
2402 | accept_statement (st); | |
2403 | ||
2404 | break; | |
2405 | ||
2406 | case ST_ELSE: | |
2407 | if (seen_else) | |
2408 | { | |
2409 | gfc_error ("Duplicate ELSE statements at %L and %C", | |
2410 | &else_locus); | |
2411 | reject_statement (); | |
2412 | break; | |
2413 | } | |
2414 | ||
2415 | seen_else = 1; | |
63645982 | 2416 | else_locus = gfc_current_locus; |
6de9cd9a DN |
2417 | |
2418 | d = new_level (gfc_state_stack->head); | |
2419 | d->op = EXEC_IF; | |
2420 | ||
2421 | accept_statement (st); | |
2422 | ||
2423 | break; | |
2424 | ||
2425 | case ST_ENDIF: | |
2426 | break; | |
2427 | ||
2428 | default: | |
2429 | unexpected_statement (st); | |
2430 | break; | |
2431 | } | |
2432 | } | |
2433 | while (st != ST_ENDIF); | |
2434 | ||
2435 | pop_state (); | |
2436 | accept_statement (st); | |
2437 | } | |
2438 | ||
2439 | ||
2440 | /* Parse a SELECT block. */ | |
2441 | ||
2442 | static void | |
2443 | parse_select_block (void) | |
2444 | { | |
2445 | gfc_statement st; | |
2446 | gfc_code *cp; | |
2447 | gfc_state_data s; | |
2448 | ||
2449 | accept_statement (ST_SELECT_CASE); | |
2450 | ||
2451 | cp = gfc_state_stack->tail; | |
2452 | push_state (&s, COMP_SELECT, gfc_new_block); | |
2453 | ||
2454 | /* Make sure that the next statement is a CASE or END SELECT. */ | |
2455 | for (;;) | |
2456 | { | |
2457 | st = next_statement (); | |
2458 | if (st == ST_NONE) | |
2459 | unexpected_eof (); | |
2460 | if (st == ST_END_SELECT) | |
2461 | { | |
2462 | /* Empty SELECT CASE is OK. */ | |
2463 | accept_statement (st); | |
2464 | pop_state (); | |
2465 | return; | |
2466 | } | |
2467 | if (st == ST_CASE) | |
2468 | break; | |
2469 | ||
edf1eac2 SK |
2470 | gfc_error ("Expected a CASE or END SELECT statement following SELECT " |
2471 | "CASE at %C"); | |
6de9cd9a DN |
2472 | |
2473 | reject_statement (); | |
2474 | } | |
2475 | ||
2476 | /* At this point, we're got a nonempty select block. */ | |
2477 | cp = new_level (cp); | |
2478 | *cp = new_st; | |
2479 | ||
2480 | accept_statement (st); | |
2481 | ||
2482 | do | |
2483 | { | |
2484 | st = parse_executable (ST_NONE); | |
2485 | switch (st) | |
2486 | { | |
2487 | case ST_NONE: | |
2488 | unexpected_eof (); | |
2489 | ||
2490 | case ST_CASE: | |
2491 | cp = new_level (gfc_state_stack->head); | |
2492 | *cp = new_st; | |
2493 | gfc_clear_new_st (); | |
2494 | ||
2495 | accept_statement (st); | |
2496 | /* Fall through */ | |
2497 | ||
2498 | case ST_END_SELECT: | |
2499 | break; | |
2500 | ||
edf1eac2 SK |
2501 | /* Can't have an executable statement because of |
2502 | parse_executable(). */ | |
6de9cd9a DN |
2503 | default: |
2504 | unexpected_statement (st); | |
2505 | break; | |
2506 | } | |
2507 | } | |
2508 | while (st != ST_END_SELECT); | |
2509 | ||
2510 | pop_state (); | |
2511 | accept_statement (st); | |
2512 | } | |
2513 | ||
2514 | ||
c9583ed2 TS |
2515 | /* Given a symbol, make sure it is not an iteration variable for a DO |
2516 | statement. This subroutine is called when the symbol is seen in a | |
2517 | context that causes it to become redefined. If the symbol is an | |
2518 | iterator, we generate an error message and return nonzero. */ | |
2519 | ||
2520 | int | |
2521 | gfc_check_do_variable (gfc_symtree *st) | |
2522 | { | |
2523 | gfc_state_data *s; | |
2524 | ||
2525 | for (s=gfc_state_stack; s; s = s->previous) | |
2526 | if (s->do_variable == st) | |
2527 | { | |
2528 | gfc_error_now("Variable '%s' at %C cannot be redefined inside " | |
b38b6477 | 2529 | "loop beginning at %L", st->name, &s->head->loc); |
c9583ed2 TS |
2530 | return 1; |
2531 | } | |
2532 | ||
2533 | return 0; | |
2534 | } | |
2535 | ||
2536 | ||
6de9cd9a DN |
2537 | /* Checks to see if the current statement label closes an enddo. |
2538 | Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues | |
2539 | an error) if it incorrectly closes an ENDDO. */ | |
2540 | ||
2541 | static int | |
2542 | check_do_closure (void) | |
2543 | { | |
2544 | gfc_state_data *p; | |
2545 | ||
2546 | if (gfc_statement_label == NULL) | |
2547 | return 0; | |
2548 | ||
2549 | for (p = gfc_state_stack; p; p = p->previous) | |
2550 | if (p->state == COMP_DO) | |
2551 | break; | |
2552 | ||
2553 | if (p == NULL) | |
2554 | return 0; /* No loops to close */ | |
2555 | ||
2556 | if (p->ext.end_do_label == gfc_statement_label) | |
2557 | { | |
2558 | ||
2559 | if (p == gfc_state_stack) | |
2560 | return 1; | |
2561 | ||
edf1eac2 | 2562 | gfc_error ("End of nonblock DO statement at %C is within another block"); |
6de9cd9a DN |
2563 | return 2; |
2564 | } | |
2565 | ||
2566 | /* At this point, the label doesn't terminate the innermost loop. | |
2567 | Make sure it doesn't terminate another one. */ | |
2568 | for (; p; p = p->previous) | |
2569 | if (p->state == COMP_DO && p->ext.end_do_label == gfc_statement_label) | |
2570 | { | |
2571 | gfc_error ("End of nonblock DO statement at %C is interwoven " | |
2572 | "with another DO loop"); | |
2573 | return 2; | |
2574 | } | |
2575 | ||
2576 | return 0; | |
2577 | } | |
2578 | ||
2579 | ||
2580 | /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are | |
2581 | handled inside of parse_executable(), because they aren't really | |
2582 | loop statements. */ | |
2583 | ||
2584 | static void | |
2585 | parse_do_block (void) | |
2586 | { | |
2587 | gfc_statement st; | |
2588 | gfc_code *top; | |
2589 | gfc_state_data s; | |
c9583ed2 | 2590 | gfc_symtree *stree; |
6de9cd9a DN |
2591 | |
2592 | s.ext.end_do_label = new_st.label; | |
2593 | ||
c9583ed2 TS |
2594 | if (new_st.ext.iterator != NULL) |
2595 | stree = new_st.ext.iterator->var->symtree; | |
2596 | else | |
2597 | stree = NULL; | |
2598 | ||
6de9cd9a DN |
2599 | accept_statement (ST_DO); |
2600 | ||
2601 | top = gfc_state_stack->tail; | |
2602 | push_state (&s, COMP_DO, gfc_new_block); | |
2603 | ||
c9583ed2 TS |
2604 | s.do_variable = stree; |
2605 | ||
6de9cd9a DN |
2606 | top->block = new_level (top); |
2607 | top->block->op = EXEC_DO; | |
2608 | ||
2609 | loop: | |
2610 | st = parse_executable (ST_NONE); | |
2611 | ||
2612 | switch (st) | |
2613 | { | |
2614 | case ST_NONE: | |
2615 | unexpected_eof (); | |
2616 | ||
2617 | case ST_ENDDO: | |
2618 | if (s.ext.end_do_label != NULL | |
2619 | && s.ext.end_do_label != gfc_statement_label) | |
edf1eac2 SK |
2620 | gfc_error_now ("Statement label in ENDDO at %C doesn't match " |
2621 | "DO label"); | |
73a014b5 TS |
2622 | |
2623 | if (gfc_statement_label != NULL) | |
2624 | { | |
2625 | new_st.op = EXEC_NOP; | |
2626 | add_statement (); | |
2627 | } | |
2628 | break; | |
6de9cd9a DN |
2629 | |
2630 | case ST_IMPLIED_ENDDO: | |
6690a9e0 PT |
2631 | /* If the do-stmt of this DO construct has a do-construct-name, |
2632 | the corresponding end-do must be an end-do-stmt (with a matching | |
2633 | name, but in that case we must have seen ST_ENDDO first). | |
2634 | We only complain about this in pedantic mode. */ | |
2635 | if (gfc_current_block () != NULL) | |
edf1eac2 SK |
2636 | gfc_error_now ("named block DO at %L requires matching ENDDO name", |
2637 | &gfc_current_block()->declared_at); | |
6690a9e0 | 2638 | |
6de9cd9a DN |
2639 | break; |
2640 | ||
2641 | default: | |
2642 | unexpected_statement (st); | |
2643 | goto loop; | |
2644 | } | |
2645 | ||
2646 | pop_state (); | |
2647 | accept_statement (st); | |
2648 | } | |
2649 | ||
2650 | ||
6c7a4dfd JJ |
2651 | /* Parse the statements of OpenMP do/parallel do. */ |
2652 | ||
2653 | static gfc_statement | |
2654 | parse_omp_do (gfc_statement omp_st) | |
2655 | { | |
2656 | gfc_statement st; | |
2657 | gfc_code *cp, *np; | |
2658 | gfc_state_data s; | |
2659 | ||
2660 | accept_statement (omp_st); | |
2661 | ||
2662 | cp = gfc_state_stack->tail; | |
2663 | push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL); | |
2664 | np = new_level (cp); | |
2665 | np->op = cp->op; | |
2666 | np->block = NULL; | |
2667 | ||
2668 | for (;;) | |
2669 | { | |
2670 | st = next_statement (); | |
2671 | if (st == ST_NONE) | |
2672 | unexpected_eof (); | |
2673 | else if (st == ST_DO) | |
2674 | break; | |
2675 | else | |
2676 | unexpected_statement (st); | |
2677 | } | |
2678 | ||
2679 | parse_do_block (); | |
2680 | if (gfc_statement_label != NULL | |
2681 | && gfc_state_stack->previous != NULL | |
2682 | && gfc_state_stack->previous->state == COMP_DO | |
2683 | && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label) | |
2684 | { | |
2685 | /* In | |
edf1eac2 SK |
2686 | DO 100 I=1,10 |
2687 | !$OMP DO | |
2688 | DO J=1,10 | |
2689 | ... | |
2690 | 100 CONTINUE | |
2691 | there should be no !$OMP END DO. */ | |
6c7a4dfd JJ |
2692 | pop_state (); |
2693 | return ST_IMPLIED_ENDDO; | |
2694 | } | |
2695 | ||
2696 | check_do_closure (); | |
2697 | pop_state (); | |
2698 | ||
2699 | st = next_statement (); | |
2700 | if (st == (omp_st == ST_OMP_DO ? ST_OMP_END_DO : ST_OMP_END_PARALLEL_DO)) | |
2701 | { | |
2702 | if (new_st.op == EXEC_OMP_END_NOWAIT) | |
2703 | cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool; | |
2704 | else | |
2705 | gcc_assert (new_st.op == EXEC_NOP); | |
2706 | gfc_clear_new_st (); | |
6b9ac6fc JJ |
2707 | gfc_commit_symbols (); |
2708 | gfc_warning_check (); | |
6c7a4dfd JJ |
2709 | st = next_statement (); |
2710 | } | |
2711 | return st; | |
2712 | } | |
2713 | ||
2714 | ||
2715 | /* Parse the statements of OpenMP atomic directive. */ | |
2716 | ||
2717 | static void | |
2718 | parse_omp_atomic (void) | |
2719 | { | |
2720 | gfc_statement st; | |
2721 | gfc_code *cp, *np; | |
2722 | gfc_state_data s; | |
2723 | ||
2724 | accept_statement (ST_OMP_ATOMIC); | |
2725 | ||
2726 | cp = gfc_state_stack->tail; | |
2727 | push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL); | |
2728 | np = new_level (cp); | |
2729 | np->op = cp->op; | |
2730 | np->block = NULL; | |
2731 | ||
2732 | for (;;) | |
2733 | { | |
2734 | st = next_statement (); | |
2735 | if (st == ST_NONE) | |
2736 | unexpected_eof (); | |
2737 | else if (st == ST_ASSIGNMENT) | |
2738 | break; | |
2739 | else | |
2740 | unexpected_statement (st); | |
2741 | } | |
2742 | ||
2743 | accept_statement (st); | |
2744 | ||
2745 | pop_state (); | |
2746 | } | |
2747 | ||
2748 | ||
2749 | /* Parse the statements of an OpenMP structured block. */ | |
2750 | ||
2751 | static void | |
2752 | parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only) | |
2753 | { | |
2754 | gfc_statement st, omp_end_st; | |
2755 | gfc_code *cp, *np; | |
2756 | gfc_state_data s; | |
2757 | ||
2758 | accept_statement (omp_st); | |
2759 | ||
2760 | cp = gfc_state_stack->tail; | |
2761 | push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL); | |
2762 | np = new_level (cp); | |
2763 | np->op = cp->op; | |
2764 | np->block = NULL; | |
2765 | ||
2766 | switch (omp_st) | |
2767 | { | |
2768 | case ST_OMP_PARALLEL: | |
2769 | omp_end_st = ST_OMP_END_PARALLEL; | |
2770 | break; | |
2771 | case ST_OMP_PARALLEL_SECTIONS: | |
2772 | omp_end_st = ST_OMP_END_PARALLEL_SECTIONS; | |
2773 | break; | |
2774 | case ST_OMP_SECTIONS: | |
2775 | omp_end_st = ST_OMP_END_SECTIONS; | |
2776 | break; | |
2777 | case ST_OMP_ORDERED: | |
2778 | omp_end_st = ST_OMP_END_ORDERED; | |
2779 | break; | |
2780 | case ST_OMP_CRITICAL: | |
2781 | omp_end_st = ST_OMP_END_CRITICAL; | |
2782 | break; | |
2783 | case ST_OMP_MASTER: | |
2784 | omp_end_st = ST_OMP_END_MASTER; | |
2785 | break; | |
2786 | case ST_OMP_SINGLE: | |
2787 | omp_end_st = ST_OMP_END_SINGLE; | |
2788 | break; | |
2789 | case ST_OMP_WORKSHARE: | |
2790 | omp_end_st = ST_OMP_END_WORKSHARE; | |
2791 | break; | |
2792 | case ST_OMP_PARALLEL_WORKSHARE: | |
2793 | omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE; | |
2794 | break; | |
2795 | default: | |
2796 | gcc_unreachable (); | |
2797 | } | |
2798 | ||
2799 | do | |
2800 | { | |
2801 | if (workshare_stmts_only) | |
2802 | { | |
2803 | /* Inside of !$omp workshare, only | |
2804 | scalar assignments | |
2805 | array assignments | |
2806 | where statements and constructs | |
2807 | forall statements and constructs | |
2808 | !$omp atomic | |
2809 | !$omp critical | |
2810 | !$omp parallel | |
2811 | are allowed. For !$omp critical these | |
2812 | restrictions apply recursively. */ | |
2813 | bool cycle = true; | |
2814 | ||
2815 | st = next_statement (); | |
2816 | for (;;) | |
2817 | { | |
2818 | switch (st) | |
2819 | { | |
2820 | case ST_NONE: | |
2821 | unexpected_eof (); | |
2822 | ||
2823 | case ST_ASSIGNMENT: | |
2824 | case ST_WHERE: | |
2825 | case ST_FORALL: | |
2826 | accept_statement (st); | |
2827 | break; | |
2828 | ||
2829 | case ST_WHERE_BLOCK: | |
2830 | parse_where_block (); | |
2831 | break; | |
2832 | ||
2833 | case ST_FORALL_BLOCK: | |
2834 | parse_forall_block (); | |
2835 | break; | |
2836 | ||
2837 | case ST_OMP_PARALLEL: | |
2838 | case ST_OMP_PARALLEL_SECTIONS: | |
2839 | parse_omp_structured_block (st, false); | |
2840 | break; | |
2841 | ||
2842 | case ST_OMP_PARALLEL_WORKSHARE: | |
2843 | case ST_OMP_CRITICAL: | |
2844 | parse_omp_structured_block (st, true); | |
2845 | break; | |
2846 | ||
2847 | case ST_OMP_PARALLEL_DO: | |
2848 | st = parse_omp_do (st); | |
2849 | continue; | |
2850 | ||
2851 | case ST_OMP_ATOMIC: | |
2852 | parse_omp_atomic (); | |
2853 | break; | |
2854 | ||
2855 | default: | |
2856 | cycle = false; | |
2857 | break; | |
2858 | } | |
2859 | ||
2860 | if (!cycle) | |
2861 | break; | |
2862 | ||
2863 | st = next_statement (); | |
2864 | } | |
2865 | } | |
2866 | else | |
2867 | st = parse_executable (ST_NONE); | |
2868 | if (st == ST_NONE) | |
2869 | unexpected_eof (); | |
2870 | else if (st == ST_OMP_SECTION | |
2871 | && (omp_st == ST_OMP_SECTIONS | |
2872 | || omp_st == ST_OMP_PARALLEL_SECTIONS)) | |
2873 | { | |
2874 | np = new_level (np); | |
2875 | np->op = cp->op; | |
2876 | np->block = NULL; | |
2877 | } | |
2878 | else if (st != omp_end_st) | |
2879 | unexpected_statement (st); | |
2880 | } | |
2881 | while (st != omp_end_st); | |
2882 | ||
2883 | switch (new_st.op) | |
2884 | { | |
2885 | case EXEC_OMP_END_NOWAIT: | |
2886 | cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool; | |
2887 | break; | |
2888 | case EXEC_OMP_CRITICAL: | |
2889 | if (((cp->ext.omp_name == NULL) ^ (new_st.ext.omp_name == NULL)) | |
2890 | || (new_st.ext.omp_name != NULL | |
2891 | && strcmp (cp->ext.omp_name, new_st.ext.omp_name) != 0)) | |
edf1eac2 SK |
2892 | gfc_error ("Name after !$omp critical and !$omp end critical does " |
2893 | "not match at %C"); | |
b1d5455a | 2894 | gfc_free (CONST_CAST (char *, new_st.ext.omp_name)); |
6c7a4dfd JJ |
2895 | break; |
2896 | case EXEC_OMP_END_SINGLE: | |
2897 | cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] | |
2898 | = new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]; | |
2899 | new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] = NULL; | |
2900 | gfc_free_omp_clauses (new_st.ext.omp_clauses); | |
2901 | break; | |
2902 | case EXEC_NOP: | |
2903 | break; | |
2904 | default: | |
2905 | gcc_unreachable (); | |
2906 | } | |
2907 | ||
2908 | gfc_clear_new_st (); | |
6b9ac6fc JJ |
2909 | gfc_commit_symbols (); |
2910 | gfc_warning_check (); | |
6c7a4dfd JJ |
2911 | pop_state (); |
2912 | } | |
2913 | ||
2914 | ||
6de9cd9a DN |
2915 | /* Accept a series of executable statements. We return the first |
2916 | statement that doesn't fit to the caller. Any block statements are | |
2917 | passed on to the correct handler, which usually passes the buck | |
2918 | right back here. */ | |
2919 | ||
2920 | static gfc_statement | |
2921 | parse_executable (gfc_statement st) | |
2922 | { | |
2923 | int close_flag; | |
2924 | ||
2925 | if (st == ST_NONE) | |
2926 | st = next_statement (); | |
2927 | ||
6c7a4dfd | 2928 | for (;;) |
6de9cd9a | 2929 | { |
6de9cd9a DN |
2930 | close_flag = check_do_closure (); |
2931 | if (close_flag) | |
2932 | switch (st) | |
2933 | { | |
2934 | case ST_GOTO: | |
2935 | case ST_END_PROGRAM: | |
2936 | case ST_RETURN: | |
2937 | case ST_EXIT: | |
2938 | case ST_END_FUNCTION: | |
2939 | case ST_CYCLE: | |
2940 | case ST_PAUSE: | |
2941 | case ST_STOP: | |
2942 | case ST_END_SUBROUTINE: | |
2943 | ||
2944 | case ST_DO: | |
2945 | case ST_FORALL: | |
2946 | case ST_WHERE: | |
2947 | case ST_SELECT_CASE: | |
edf1eac2 SK |
2948 | gfc_error ("%s statement at %C cannot terminate a non-block " |
2949 | "DO loop", gfc_ascii_statement (st)); | |
6de9cd9a DN |
2950 | break; |
2951 | ||
2952 | default: | |
2953 | break; | |
2954 | } | |
2955 | ||
2956 | switch (st) | |
2957 | { | |
2958 | case ST_NONE: | |
2959 | unexpected_eof (); | |
2960 | ||
2961 | case ST_FORMAT: | |
2962 | case ST_DATA: | |
2963 | case ST_ENTRY: | |
2964 | case_executable: | |
2965 | accept_statement (st); | |
2966 | if (close_flag == 1) | |
2967 | return ST_IMPLIED_ENDDO; | |
6c7a4dfd | 2968 | break; |
6de9cd9a DN |
2969 | |
2970 | case ST_IF_BLOCK: | |
2971 | parse_if_block (); | |
6c7a4dfd | 2972 | break; |
6de9cd9a DN |
2973 | |
2974 | case ST_SELECT_CASE: | |
2975 | parse_select_block (); | |
6c7a4dfd | 2976 | break; |
6de9cd9a DN |
2977 | |
2978 | case ST_DO: | |
2979 | parse_do_block (); | |
2980 | if (check_do_closure () == 1) | |
2981 | return ST_IMPLIED_ENDDO; | |
6c7a4dfd | 2982 | break; |
6de9cd9a DN |
2983 | |
2984 | case ST_WHERE_BLOCK: | |
2985 | parse_where_block (); | |
6c7a4dfd | 2986 | break; |
6de9cd9a DN |
2987 | |
2988 | case ST_FORALL_BLOCK: | |
2989 | parse_forall_block (); | |
6c7a4dfd JJ |
2990 | break; |
2991 | ||
2992 | case ST_OMP_PARALLEL: | |
2993 | case ST_OMP_PARALLEL_SECTIONS: | |
2994 | case ST_OMP_SECTIONS: | |
2995 | case ST_OMP_ORDERED: | |
2996 | case ST_OMP_CRITICAL: | |
2997 | case ST_OMP_MASTER: | |
2998 | case ST_OMP_SINGLE: | |
2999 | parse_omp_structured_block (st, false); | |
3000 | break; | |
3001 | ||
3002 | case ST_OMP_WORKSHARE: | |
3003 | case ST_OMP_PARALLEL_WORKSHARE: | |
3004 | parse_omp_structured_block (st, true); | |
3005 | break; | |
3006 | ||
3007 | case ST_OMP_DO: | |
3008 | case ST_OMP_PARALLEL_DO: | |
3009 | st = parse_omp_do (st); | |
3010 | if (st == ST_IMPLIED_ENDDO) | |
3011 | return st; | |
6de9cd9a DN |
3012 | continue; |
3013 | ||
6c7a4dfd JJ |
3014 | case ST_OMP_ATOMIC: |
3015 | parse_omp_atomic (); | |
6de9cd9a | 3016 | break; |
6c7a4dfd JJ |
3017 | |
3018 | default: | |
3019 | return st; | |
6de9cd9a DN |
3020 | } |
3021 | ||
6c7a4dfd | 3022 | st = next_statement (); |
6de9cd9a | 3023 | } |
6de9cd9a DN |
3024 | } |
3025 | ||
3026 | ||
3027 | /* Parse a series of contained program units. */ | |
3028 | ||
3029 | static void parse_progunit (gfc_statement); | |
3030 | ||
3031 | ||
3032 | /* Fix the symbols for sibling functions. These are incorrectly added to | |
3033 | the child namespace as the parser didn't know about this procedure. */ | |
3034 | ||
3035 | static void | |
edf1eac2 | 3036 | gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings) |
6de9cd9a DN |
3037 | { |
3038 | gfc_namespace *ns; | |
3039 | gfc_symtree *st; | |
3040 | gfc_symbol *old_sym; | |
3041 | ||
3d79abbd | 3042 | sym->attr.referenced = 1; |
6de9cd9a DN |
3043 | for (ns = siblings; ns; ns = ns->sibling) |
3044 | { | |
3045 | gfc_find_sym_tree (sym->name, ns, 0, &st); | |
8c086c9c PT |
3046 | |
3047 | if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns)) | |
3048 | continue; | |
6de9cd9a DN |
3049 | |
3050 | old_sym = st->n.sym; | |
182393f4 PT |
3051 | if (old_sym->ns == ns |
3052 | && !old_sym->attr.contained | |
3053 | ||
3054 | /* By 14.6.1.3, host association should be excluded | |
3055 | for the following. */ | |
3056 | && !(old_sym->attr.external | |
3057 | || (old_sym->ts.type != BT_UNKNOWN | |
3058 | && !old_sym->attr.implicit_type) | |
3059 | || old_sym->attr.flavor == FL_PARAMETER | |
3060 | || old_sym->attr.in_common | |
3061 | || old_sym->attr.in_equivalence | |
3062 | || old_sym->attr.data | |
3063 | || old_sym->attr.dummy | |
3064 | || old_sym->attr.result | |
3065 | || old_sym->attr.dimension | |
3066 | || old_sym->attr.allocatable | |
3067 | || old_sym->attr.intrinsic | |
3068 | || old_sym->attr.generic | |
3069 | || old_sym->attr.flavor == FL_NAMELIST | |
3070 | || old_sym->attr.proc == PROC_ST_FUNCTION)) | |
edf1eac2 SK |
3071 | { |
3072 | /* Replace it with the symbol from the parent namespace. */ | |
3073 | st->n.sym = sym; | |
3074 | sym->refs++; | |
3075 | ||
3076 | /* Free the old (local) symbol. */ | |
3077 | old_sym->refs--; | |
3078 | if (old_sym->refs == 0) | |
3079 | gfc_free_symbol (old_sym); | |
3080 | } | |
6de9cd9a | 3081 | |
aa9c57ec | 3082 | /* Do the same for any contained procedures. */ |
6de9cd9a DN |
3083 | gfc_fixup_sibling_symbols (sym, ns->contained); |
3084 | } | |
3085 | } | |
3086 | ||
3087 | static void | |
3088 | parse_contained (int module) | |
3089 | { | |
de893677 | 3090 | gfc_namespace *ns, *parent_ns, *tmp; |
6de9cd9a DN |
3091 | gfc_state_data s1, s2; |
3092 | gfc_statement st; | |
3093 | gfc_symbol *sym; | |
3d79abbd | 3094 | gfc_entry_list *el; |
8c894ae2 | 3095 | int contains_statements = 0; |
de893677 | 3096 | int seen_error = 0; |
6de9cd9a DN |
3097 | |
3098 | push_state (&s1, COMP_CONTAINS, NULL); | |
3099 | parent_ns = gfc_current_ns; | |
3100 | ||
3101 | do | |
3102 | { | |
0366dfe9 | 3103 | gfc_current_ns = gfc_get_namespace (parent_ns, 1); |
6de9cd9a DN |
3104 | |
3105 | gfc_current_ns->sibling = parent_ns->contained; | |
3106 | parent_ns->contained = gfc_current_ns; | |
3107 | ||
de893677 JD |
3108 | next: |
3109 | /* Process the next available statement. We come here if we got an error | |
3110 | and rejected the last statement. */ | |
6de9cd9a DN |
3111 | st = next_statement (); |
3112 | ||
3113 | switch (st) | |
3114 | { | |
3115 | case ST_NONE: | |
3116 | unexpected_eof (); | |
3117 | ||
3118 | case ST_FUNCTION: | |
3119 | case ST_SUBROUTINE: | |
ab25c2d9 | 3120 | contains_statements = 1; |
6de9cd9a DN |
3121 | accept_statement (st); |
3122 | ||
3123 | push_state (&s2, | |
3124 | (st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE, | |
3125 | gfc_new_block); | |
3126 | ||
3127 | /* For internal procedures, create/update the symbol in the | |
4f613946 | 3128 | parent namespace. */ |
6de9cd9a DN |
3129 | |
3130 | if (!module) | |
3131 | { | |
3132 | if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym)) | |
edf1eac2 SK |
3133 | gfc_error ("Contained procedure '%s' at %C is already " |
3134 | "ambiguous", gfc_new_block->name); | |
6de9cd9a DN |
3135 | else |
3136 | { | |
231b2fcc | 3137 | if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, sym->name, |
6de9cd9a DN |
3138 | &gfc_new_block->declared_at) == |
3139 | SUCCESS) | |
3140 | { | |
3141 | if (st == ST_FUNCTION) | |
231b2fcc | 3142 | gfc_add_function (&sym->attr, sym->name, |
6de9cd9a DN |
3143 | &gfc_new_block->declared_at); |
3144 | else | |
231b2fcc | 3145 | gfc_add_subroutine (&sym->attr, sym->name, |
6de9cd9a DN |
3146 | &gfc_new_block->declared_at); |
3147 | } | |
3148 | } | |
3149 | ||
3150 | gfc_commit_symbols (); | |
3151 | } | |
edf1eac2 SK |
3152 | else |
3153 | sym = gfc_new_block; | |
6de9cd9a | 3154 | |
edf1eac2 SK |
3155 | /* Mark this as a contained function, so it isn't replaced |
3156 | by other module functions. */ | |
3157 | sym->attr.contained = 1; | |
682e69e1 | 3158 | sym->attr.referenced = 1; |
6de9cd9a | 3159 | |
3d79abbd PB |
3160 | parse_progunit (ST_NONE); |
3161 | ||
edf1eac2 SK |
3162 | /* Fix up any sibling functions that refer to this one. */ |
3163 | gfc_fixup_sibling_symbols (sym, gfc_current_ns); | |
3d79abbd PB |
3164 | /* Or refer to any of its alternate entry points. */ |
3165 | for (el = gfc_current_ns->entries; el; el = el->next) | |
3166 | gfc_fixup_sibling_symbols (el->sym, gfc_current_ns); | |
6de9cd9a DN |
3167 | |
3168 | gfc_current_ns->code = s2.head; | |
3169 | gfc_current_ns = parent_ns; | |
3170 | ||
3171 | pop_state (); | |
3172 | break; | |
3173 | ||
edf1eac2 | 3174 | /* These statements are associated with the end of the host unit. */ |
6de9cd9a DN |
3175 | case ST_END_FUNCTION: |
3176 | case ST_END_MODULE: | |
3177 | case ST_END_PROGRAM: | |
3178 | case ST_END_SUBROUTINE: | |
3179 | accept_statement (st); | |
3180 | break; | |
3181 | ||
3182 | default: | |
3183 | gfc_error ("Unexpected %s statement in CONTAINS section at %C", | |
3184 | gfc_ascii_statement (st)); | |
3185 | reject_statement (); | |
de893677 JD |
3186 | seen_error = 1; |
3187 | goto next; | |
6de9cd9a DN |
3188 | break; |
3189 | } | |
3190 | } | |
3191 | while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE | |
3192 | && st != ST_END_MODULE && st != ST_END_PROGRAM); | |
3193 | ||
3194 | /* The first namespace in the list is guaranteed to not have | |
3195 | anything (worthwhile) in it. */ | |
de893677 | 3196 | tmp = gfc_current_ns; |
6de9cd9a | 3197 | gfc_current_ns = parent_ns; |
de893677 JD |
3198 | if (seen_error && tmp->refs > 1) |
3199 | gfc_free_namespace (tmp); | |
6de9cd9a DN |
3200 | |
3201 | ns = gfc_current_ns->contained; | |
3202 | gfc_current_ns->contained = ns->sibling; | |
3203 | gfc_free_namespace (ns); | |
3204 | ||
3205 | pop_state (); | |
8c894ae2 | 3206 | if (!contains_statements) |
f489fba1 | 3207 | gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CONTAINS statement without " |
edf1eac2 | 3208 | "FUNCTION or SUBROUTINE statement at %C"); |
6de9cd9a DN |
3209 | } |
3210 | ||
3211 | ||
3212 | /* Parse a PROGRAM, SUBROUTINE or FUNCTION unit. */ | |
3213 | ||
3214 | static void | |
3215 | parse_progunit (gfc_statement st) | |
3216 | { | |
3217 | gfc_state_data *p; | |
3218 | int n; | |
3219 | ||
3220 | st = parse_spec (st); | |
3221 | switch (st) | |
3222 | { | |
3223 | case ST_NONE: | |
3224 | unexpected_eof (); | |
3225 | ||
3226 | case ST_CONTAINS: | |
3227 | goto contains; | |
3228 | ||
3229 | case_end: | |
3230 | accept_statement (st); | |
3231 | goto done; | |
3232 | ||
3233 | default: | |
3234 | break; | |
3235 | } | |
3236 | ||
e9bd9f7d PT |
3237 | if (gfc_current_state () == COMP_FUNCTION) |
3238 | gfc_check_function_type (gfc_current_ns); | |
3239 | ||
6de9cd9a DN |
3240 | loop: |
3241 | for (;;) | |
3242 | { | |
3243 | st = parse_executable (st); | |
3244 | ||
3245 | switch (st) | |
3246 | { | |
3247 | case ST_NONE: | |
3248 | unexpected_eof (); | |
3249 | ||
3250 | case ST_CONTAINS: | |
3251 | goto contains; | |
3252 | ||
3253 | case_end: | |
3254 | accept_statement (st); | |
3255 | goto done; | |
3256 | ||
3257 | default: | |
3258 | break; | |
3259 | } | |
3260 | ||
3261 | unexpected_statement (st); | |
3262 | reject_statement (); | |
3263 | st = next_statement (); | |
3264 | } | |
3265 | ||
3266 | contains: | |
3267 | n = 0; | |
3268 | ||
3269 | for (p = gfc_state_stack; p; p = p->previous) | |
3270 | if (p->state == COMP_CONTAINS) | |
3271 | n++; | |
3272 | ||
3273 | if (gfc_find_state (COMP_MODULE) == SUCCESS) | |
3274 | n--; | |
3275 | ||
3276 | if (n > 0) | |
3277 | { | |
3278 | gfc_error ("CONTAINS statement at %C is already in a contained " | |
3279 | "program unit"); | |
3280 | st = next_statement (); | |
3281 | goto loop; | |
3282 | } | |
3283 | ||
3284 | parse_contained (0); | |
3285 | ||
3286 | done: | |
3287 | gfc_current_ns->code = gfc_state_stack->head; | |
3288 | } | |
3289 | ||
3290 | ||
c9543002 TS |
3291 | /* Come here to complain about a global symbol already in use as |
3292 | something else. */ | |
3293 | ||
68ea355b | 3294 | void |
ca39e6f2 | 3295 | gfc_global_used (gfc_gsymbol *sym, locus *where) |
c9543002 TS |
3296 | { |
3297 | const char *name; | |
3298 | ||
3299 | if (where == NULL) | |
3300 | where = &gfc_current_locus; | |
3301 | ||
3302 | switch(sym->type) | |
3303 | { | |
3304 | case GSYM_PROGRAM: | |
3305 | name = "PROGRAM"; | |
3306 | break; | |
3307 | case GSYM_FUNCTION: | |
3308 | name = "FUNCTION"; | |
3309 | break; | |
3310 | case GSYM_SUBROUTINE: | |
3311 | name = "SUBROUTINE"; | |
3312 | break; | |
3313 | case GSYM_COMMON: | |
3314 | name = "COMMON"; | |
3315 | break; | |
3316 | case GSYM_BLOCK_DATA: | |
3317 | name = "BLOCK DATA"; | |
3318 | break; | |
3319 | case GSYM_MODULE: | |
3320 | name = "MODULE"; | |
3321 | break; | |
3322 | default: | |
3323 | gfc_internal_error ("gfc_gsymbol_type(): Bad type"); | |
3324 | name = NULL; | |
3325 | } | |
3326 | ||
3327 | gfc_error("Global name '%s' at %L is already being used as a %s at %L", | |
68ea355b | 3328 | sym->name, where, name, &sym->where); |
c9543002 TS |
3329 | } |
3330 | ||
3331 | ||
6de9cd9a DN |
3332 | /* Parse a block data program unit. */ |
3333 | ||
3334 | static void | |
3335 | parse_block_data (void) | |
3336 | { | |
3337 | gfc_statement st; | |
c9543002 TS |
3338 | static locus blank_locus; |
3339 | static int blank_block=0; | |
3340 | gfc_gsymbol *s; | |
3341 | ||
0de4325e TS |
3342 | gfc_current_ns->proc_name = gfc_new_block; |
3343 | gfc_current_ns->is_block_data = 1; | |
3344 | ||
c9543002 TS |
3345 | if (gfc_new_block == NULL) |
3346 | { | |
3347 | if (blank_block) | |
3348 | gfc_error ("Blank BLOCK DATA at %C conflicts with " | |
edf1eac2 | 3349 | "prior BLOCK DATA at %L", &blank_locus); |
c9543002 TS |
3350 | else |
3351 | { | |
edf1eac2 SK |
3352 | blank_block = 1; |
3353 | blank_locus = gfc_current_locus; | |
c9543002 TS |
3354 | } |
3355 | } | |
3356 | else | |
3357 | { | |
3358 | s = gfc_get_gsymbol (gfc_new_block->name); | |
edf1eac2 SK |
3359 | if (s->defined |
3360 | || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA)) | |
ca39e6f2 | 3361 | gfc_global_used(s, NULL); |
c9543002 TS |
3362 | else |
3363 | { | |
edf1eac2 SK |
3364 | s->type = GSYM_BLOCK_DATA; |
3365 | s->where = gfc_current_locus; | |
68ea355b | 3366 | s->defined = 1; |
c9543002 TS |
3367 | } |
3368 | } | |
6de9cd9a DN |
3369 | |
3370 | st = parse_spec (ST_NONE); | |
3371 | ||
3372 | while (st != ST_END_BLOCK_DATA) | |
3373 | { | |
3374 | gfc_error ("Unexpected %s statement in BLOCK DATA at %C", | |
3375 | gfc_ascii_statement (st)); | |
3376 | reject_statement (); | |
3377 | st = next_statement (); | |
3378 | } | |
3379 | } | |
3380 | ||
3381 | ||
3382 | /* Parse a module subprogram. */ | |
3383 | ||
3384 | static void | |
3385 | parse_module (void) | |
3386 | { | |
3387 | gfc_statement st; | |
c9543002 TS |
3388 | gfc_gsymbol *s; |
3389 | ||
3390 | s = gfc_get_gsymbol (gfc_new_block->name); | |
68ea355b | 3391 | if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE)) |
ca39e6f2 | 3392 | gfc_global_used(s, NULL); |
c9543002 TS |
3393 | else |
3394 | { | |
3395 | s->type = GSYM_MODULE; | |
3396 | s->where = gfc_current_locus; | |
68ea355b | 3397 | s->defined = 1; |
c9543002 | 3398 | } |
6de9cd9a DN |
3399 | |
3400 | st = parse_spec (ST_NONE); | |
3401 | ||
3402 | loop: | |
3403 | switch (st) | |
3404 | { | |
3405 | case ST_NONE: | |
3406 | unexpected_eof (); | |
3407 | ||
3408 | case ST_CONTAINS: | |
3409 | parse_contained (1); | |
3410 | break; | |
3411 | ||
3412 | case ST_END_MODULE: | |
3413 | accept_statement (st); | |
3414 | break; | |
3415 | ||
3416 | default: | |
3417 | gfc_error ("Unexpected %s statement in MODULE at %C", | |
3418 | gfc_ascii_statement (st)); | |
3419 | ||
3420 | reject_statement (); | |
3421 | st = next_statement (); | |
3422 | goto loop; | |
3423 | } | |
3424 | } | |
3425 | ||
3426 | ||
c9543002 TS |
3427 | /* Add a procedure name to the global symbol table. */ |
3428 | ||
3429 | static void | |
3430 | add_global_procedure (int sub) | |
3431 | { | |
3432 | gfc_gsymbol *s; | |
3433 | ||
3434 | s = gfc_get_gsymbol(gfc_new_block->name); | |
3435 | ||
68ea355b | 3436 | if (s->defined |
edf1eac2 SK |
3437 | || (s->type != GSYM_UNKNOWN |
3438 | && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION))) | |
ca39e6f2 | 3439 | gfc_global_used(s, NULL); |
c9543002 TS |
3440 | else |
3441 | { | |
3442 | s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION; | |
3443 | s->where = gfc_current_locus; | |
68ea355b | 3444 | s->defined = 1; |
c9543002 TS |
3445 | } |
3446 | } | |
3447 | ||
3448 | ||
3449 | /* Add a program to the global symbol table. */ | |
3450 | ||
3451 | static void | |
3452 | add_global_program (void) | |
3453 | { | |
3454 | gfc_gsymbol *s; | |
3455 | ||
3456 | if (gfc_new_block == NULL) | |
3457 | return; | |
3458 | s = gfc_get_gsymbol (gfc_new_block->name); | |
3459 | ||
68ea355b | 3460 | if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM)) |
ca39e6f2 | 3461 | gfc_global_used(s, NULL); |
c9543002 TS |
3462 | else |
3463 | { | |
3464 | s->type = GSYM_PROGRAM; | |
3465 | s->where = gfc_current_locus; | |
68ea355b | 3466 | s->defined = 1; |
c9543002 TS |
3467 | } |
3468 | } | |
3469 | ||
3470 | ||
6de9cd9a DN |
3471 | /* Top level parser. */ |
3472 | ||
3473 | try | |
3474 | gfc_parse_file (void) | |
3475 | { | |
3476 | int seen_program, errors_before, errors; | |
3477 | gfc_state_data top, s; | |
3478 | gfc_statement st; | |
3479 | locus prog_locus; | |
3480 | ||
60332588 | 3481 | gfc_start_source_files (); |
9e8a6720 | 3482 | |
6de9cd9a DN |
3483 | top.state = COMP_NONE; |
3484 | top.sym = NULL; | |
3485 | top.previous = NULL; | |
3486 | top.head = top.tail = NULL; | |
c9583ed2 | 3487 | top.do_variable = NULL; |
6de9cd9a DN |
3488 | |
3489 | gfc_state_stack = ⊤ | |
3490 | ||
3491 | gfc_clear_new_st (); | |
3492 | ||
3493 | gfc_statement_label = NULL; | |
3494 | ||
f13ab1ee | 3495 | if (setjmp (eof_buf)) |
6de9cd9a DN |
3496 | return FAILURE; /* Come here on unexpected EOF */ |
3497 | ||
3498 | seen_program = 0; | |
3499 | ||
c82cdb5d RG |
3500 | /* Exit early for empty files. */ |
3501 | if (gfc_at_eof ()) | |
3502 | goto done; | |
3503 | ||
6de9cd9a DN |
3504 | loop: |
3505 | gfc_init_2 (); | |
3506 | st = next_statement (); | |
3507 | switch (st) | |
3508 | { | |
3509 | case ST_NONE: | |
3510 | gfc_done_2 (); | |
3511 | goto done; | |
3512 | ||
3513 | case ST_PROGRAM: | |
3514 | if (seen_program) | |
3515 | goto duplicate_main; | |
3516 | seen_program = 1; | |
63645982 | 3517 | prog_locus = gfc_current_locus; |
6de9cd9a DN |
3518 | |
3519 | push_state (&s, COMP_PROGRAM, gfc_new_block); | |
ecf24057 | 3520 | main_program_symbol(gfc_current_ns, gfc_new_block->name); |
6de9cd9a | 3521 | accept_statement (st); |
c9543002 | 3522 | add_global_program (); |
6de9cd9a DN |
3523 | parse_progunit (ST_NONE); |
3524 | break; | |
3525 | ||
3526 | case ST_SUBROUTINE: | |
c9543002 | 3527 | add_global_procedure (1); |
6de9cd9a DN |
3528 | push_state (&s, COMP_SUBROUTINE, gfc_new_block); |
3529 | accept_statement (st); | |
3530 | parse_progunit (ST_NONE); | |
3531 | break; | |
3532 | ||
3533 | case ST_FUNCTION: | |
c9543002 | 3534 | add_global_procedure (0); |
6de9cd9a DN |
3535 | push_state (&s, COMP_FUNCTION, gfc_new_block); |
3536 | accept_statement (st); | |
3537 | parse_progunit (ST_NONE); | |
3538 | break; | |
3539 | ||
3540 | case ST_BLOCK_DATA: | |
3541 | push_state (&s, COMP_BLOCK_DATA, gfc_new_block); | |
3542 | accept_statement (st); | |
3543 | parse_block_data (); | |
3544 | break; | |
3545 | ||
3546 | case ST_MODULE: | |
3547 | push_state (&s, COMP_MODULE, gfc_new_block); | |
3548 | accept_statement (st); | |
3549 | ||
3550 | gfc_get_errors (NULL, &errors_before); | |
3551 | parse_module (); | |
3552 | break; | |
3553 | ||
3554 | /* Anything else starts a nameless main program block. */ | |
3555 | default: | |
3556 | if (seen_program) | |
3557 | goto duplicate_main; | |
3558 | seen_program = 1; | |
63645982 | 3559 | prog_locus = gfc_current_locus; |
6de9cd9a DN |
3560 | |
3561 | push_state (&s, COMP_PROGRAM, gfc_new_block); | |
ecf24057 | 3562 | main_program_symbol (gfc_current_ns, "MAIN__"); |
6de9cd9a DN |
3563 | parse_progunit (st); |
3564 | break; | |
3565 | } | |
3566 | ||
3567 | gfc_current_ns->code = s.head; | |
3568 | ||
3569 | gfc_resolve (gfc_current_ns); | |
3570 | ||
3571 | /* Dump the parse tree if requested. */ | |
daf5afd4 FXC |
3572 | if (gfc_option.dump_parse_tree) |
3573 | gfc_dump_parse_tree (gfc_current_ns, stdout); | |
6de9cd9a DN |
3574 | |
3575 | gfc_get_errors (NULL, &errors); | |
3576 | if (s.state == COMP_MODULE) | |
3577 | { | |
3578 | gfc_dump_module (s.sym->name, errors_before == errors); | |
4887aa71 | 3579 | if (errors == 0) |
6de9cd9a DN |
3580 | gfc_generate_module_code (gfc_current_ns); |
3581 | } | |
3582 | else | |
3583 | { | |
4887aa71 | 3584 | if (errors == 0) |
6de9cd9a DN |
3585 | gfc_generate_code (gfc_current_ns); |
3586 | } | |
3587 | ||
3588 | pop_state (); | |
3589 | gfc_done_2 (); | |
3590 | goto loop; | |
3591 | ||
3592 | done: | |
60332588 | 3593 | gfc_end_source_files (); |
6de9cd9a DN |
3594 | return SUCCESS; |
3595 | ||
3596 | duplicate_main: | |
3597 | /* If we see a duplicate main program, shut down. If the second | |
3598 | instance is an implied main program, ie data decls or executable | |
3599 | statements, we're in for lots of errors. */ | |
3600 | gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus); | |
3601 | reject_statement (); | |
3602 | gfc_done_2 (); | |
3603 | return SUCCESS; | |
3604 | } |