OpenCores
URL https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [fortran/] [parse.c] - Blame information for rev 329

Go to most recent revision | Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.