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/] [dump-parse-tree.c] - Blame information for rev 328

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

Line No. Rev Author Line
1 285 jeremybenn
/* Parse tree dumper
2
   Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009
3
   Free Software Foundation, Inc.
4
   Contributed by Steven Bosscher
5
 
6
This file is part of GCC.
7
 
8
GCC is free software; you can redistribute it and/or modify it under
9
the terms of the GNU General Public License as published by the Free
10
Software Foundation; either version 3, or (at your option) any later
11
version.
12
 
13
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14
WARRANTY; without even the implied warranty of MERCHANTABILITY or
15
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
16
for more details.
17
 
18
You should have received a copy of the GNU General Public License
19
along with GCC; see the file COPYING3.  If not see
20
<http://www.gnu.org/licenses/>.  */
21
 
22
 
23
/* Actually this is just a collection of routines that used to be
24
   scattered around the sources.  Now that they are all in a single
25
   file, almost all of them can be static, and the other files don't
26
   have this mess in them.
27
 
28
   As a nice side-effect, this file can act as documentation of the
29
   gfc_code and gfc_expr structures and all their friends and
30
   relatives.
31
 
32
   TODO: Dump DATA.  */
33
 
34
#include "config.h"
35
#include "gfortran.h"
36
 
37
/* Keep track of indentation for symbol tree dumps.  */
38
static int show_level = 0;
39
 
40
/* The file handle we're dumping to is kept in a static variable.  This
41
   is not too cool, but it avoids a lot of passing it around.  */
42
static FILE *dumpfile;
43
 
44
/* Forward declaration of some of the functions.  */
45
static void show_expr (gfc_expr *p);
46
static void show_code_node (int, gfc_code *);
47
static void show_namespace (gfc_namespace *ns);
48
 
49
 
50
/* Do indentation for a specific level.  */
51
 
52
static inline void
53
code_indent (int level, gfc_st_label *label)
54
{
55
  int i;
56
 
57
  if (label != NULL)
58
    fprintf (dumpfile, "%-5d ", label->value);
59
  else
60
    fputs ("      ", dumpfile);
61
 
62
  for (i = 0; i < 2 * level; i++)
63
    fputc (' ', dumpfile);
64
}
65
 
66
 
67
/* Simple indentation at the current level.  This one
68
   is used to show symbols.  */
69
 
70
static inline void
71
show_indent (void)
72
{
73
  fputc ('\n', dumpfile);
74
  code_indent (show_level, NULL);
75
}
76
 
77
 
78
/* Show type-specific information.  */
79
 
80
static void
81
show_typespec (gfc_typespec *ts)
82
{
83
  fprintf (dumpfile, "(%s ", gfc_basic_typename (ts->type));
84
 
85
  switch (ts->type)
86
    {
87
    case BT_DERIVED:
88
      fprintf (dumpfile, "%s", ts->u.derived->name);
89
      break;
90
 
91
    case BT_CHARACTER:
92
      show_expr (ts->u.cl->length);
93
      break;
94
 
95
    default:
96
      fprintf (dumpfile, "%d", ts->kind);
97
      break;
98
    }
99
 
100
  fputc (')', dumpfile);
101
}
102
 
103
 
104
/* Show an actual argument list.  */
105
 
106
static void
107
show_actual_arglist (gfc_actual_arglist *a)
108
{
109
  fputc ('(', dumpfile);
110
 
111
  for (; a; a = a->next)
112
    {
113
      fputc ('(', dumpfile);
114
      if (a->name != NULL)
115
        fprintf (dumpfile, "%s = ", a->name);
116
      if (a->expr != NULL)
117
        show_expr (a->expr);
118
      else
119
        fputs ("(arg not-present)", dumpfile);
120
 
121
      fputc (')', dumpfile);
122
      if (a->next != NULL)
123
        fputc (' ', dumpfile);
124
    }
125
 
126
  fputc (')', dumpfile);
127
}
128
 
129
 
130
/* Show a gfc_array_spec array specification structure.  */
131
 
132
static void
133
show_array_spec (gfc_array_spec *as)
134
{
135
  const char *c;
136
  int i;
137
 
138
  if (as == NULL)
139
    {
140
      fputs ("()", dumpfile);
141
      return;
142
    }
143
 
144
  fprintf (dumpfile, "(%d", as->rank);
145
 
146
  if (as->rank != 0)
147
    {
148
      switch (as->type)
149
      {
150
        case AS_EXPLICIT:      c = "AS_EXPLICIT";      break;
151
        case AS_DEFERRED:      c = "AS_DEFERRED";      break;
152
        case AS_ASSUMED_SIZE:  c = "AS_ASSUMED_SIZE";  break;
153
        case AS_ASSUMED_SHAPE: c = "AS_ASSUMED_SHAPE"; break;
154
        default:
155
          gfc_internal_error ("show_array_spec(): Unhandled array shape "
156
                              "type.");
157
      }
158
      fprintf (dumpfile, " %s ", c);
159
 
160
      for (i = 0; i < as->rank; i++)
161
        {
162
          show_expr (as->lower[i]);
163
          fputc (' ', dumpfile);
164
          show_expr (as->upper[i]);
165
          fputc (' ', dumpfile);
166
        }
167
    }
168
 
169
  fputc (')', dumpfile);
170
}
171
 
172
 
173
/* Show a gfc_array_ref array reference structure.  */
174
 
175
static void
176
show_array_ref (gfc_array_ref * ar)
177
{
178
  int i;
179
 
180
  fputc ('(', dumpfile);
181
 
182
  switch (ar->type)
183
    {
184
    case AR_FULL:
185
      fputs ("FULL", dumpfile);
186
      break;
187
 
188
    case AR_SECTION:
189
      for (i = 0; i < ar->dimen; i++)
190
        {
191
          /* There are two types of array sections: either the
192
             elements are identified by an integer array ('vector'),
193
             or by an index range. In the former case we only have to
194
             print the start expression which contains the vector, in
195
             the latter case we have to print any of lower and upper
196
             bound and the stride, if they're present.  */
197
 
198
          if (ar->start[i] != NULL)
199
            show_expr (ar->start[i]);
200
 
201
          if (ar->dimen_type[i] == DIMEN_RANGE)
202
            {
203
              fputc (':', dumpfile);
204
 
205
              if (ar->end[i] != NULL)
206
                show_expr (ar->end[i]);
207
 
208
              if (ar->stride[i] != NULL)
209
                {
210
                  fputc (':', dumpfile);
211
                  show_expr (ar->stride[i]);
212
                }
213
            }
214
 
215
          if (i != ar->dimen - 1)
216
            fputs (" , ", dumpfile);
217
        }
218
      break;
219
 
220
    case AR_ELEMENT:
221
      for (i = 0; i < ar->dimen; i++)
222
        {
223
          show_expr (ar->start[i]);
224
          if (i != ar->dimen - 1)
225
            fputs (" , ", dumpfile);
226
        }
227
      break;
228
 
229
    case AR_UNKNOWN:
230
      fputs ("UNKNOWN", dumpfile);
231
      break;
232
 
233
    default:
234
      gfc_internal_error ("show_array_ref(): Unknown array reference");
235
    }
236
 
237
  fputc (')', dumpfile);
238
}
239
 
240
 
241
/* Show a list of gfc_ref structures.  */
242
 
243
static void
244
show_ref (gfc_ref *p)
245
{
246
  for (; p; p = p->next)
247
    switch (p->type)
248
      {
249
      case REF_ARRAY:
250
        show_array_ref (&p->u.ar);
251
        break;
252
 
253
      case REF_COMPONENT:
254
        fprintf (dumpfile, " %% %s", p->u.c.component->name);
255
        break;
256
 
257
      case REF_SUBSTRING:
258
        fputc ('(', dumpfile);
259
        show_expr (p->u.ss.start);
260
        fputc (':', dumpfile);
261
        show_expr (p->u.ss.end);
262
        fputc (')', dumpfile);
263
        break;
264
 
265
      default:
266
        gfc_internal_error ("show_ref(): Bad component code");
267
      }
268
}
269
 
270
 
271
/* Display a constructor.  Works recursively for array constructors.  */
272
 
273
static void
274
show_constructor (gfc_constructor *c)
275
{
276
  for (; c; c = c->next)
277
    {
278
      if (c->iterator == NULL)
279
        show_expr (c->expr);
280
      else
281
        {
282
          fputc ('(', dumpfile);
283
          show_expr (c->expr);
284
 
285
          fputc (' ', dumpfile);
286
          show_expr (c->iterator->var);
287
          fputc ('=', dumpfile);
288
          show_expr (c->iterator->start);
289
          fputc (',', dumpfile);
290
          show_expr (c->iterator->end);
291
          fputc (',', dumpfile);
292
          show_expr (c->iterator->step);
293
 
294
          fputc (')', dumpfile);
295
        }
296
 
297
      if (c->next != NULL)
298
        fputs (" , ", dumpfile);
299
    }
300
}
301
 
302
 
303
static void
304
show_char_const (const gfc_char_t *c, int length)
305
{
306
  int i;
307
 
308
  fputc ('\'', dumpfile);
309
  for (i = 0; i < length; i++)
310
    {
311
      if (c[i] == '\'')
312
        fputs ("''", dumpfile);
313
      else
314
        fputs (gfc_print_wide_char (c[i]), dumpfile);
315
    }
316
  fputc ('\'', dumpfile);
317
}
318
 
319
 
320
/* Show a component-call expression.  */
321
 
322
static void
323
show_compcall (gfc_expr* p)
324
{
325
  gcc_assert (p->expr_type == EXPR_COMPCALL);
326
 
327
  fprintf (dumpfile, "%s", p->symtree->n.sym->name);
328
  show_ref (p->ref);
329
  fprintf (dumpfile, "%s", p->value.compcall.name);
330
 
331
  show_actual_arglist (p->value.compcall.actual);
332
}
333
 
334
 
335
/* Show an expression.  */
336
 
337
static void
338
show_expr (gfc_expr *p)
339
{
340
  const char *c;
341
  int i;
342
 
343
  if (p == NULL)
344
    {
345
      fputs ("()", dumpfile);
346
      return;
347
    }
348
 
349
  switch (p->expr_type)
350
    {
351
    case EXPR_SUBSTRING:
352
      show_char_const (p->value.character.string, p->value.character.length);
353
      show_ref (p->ref);
354
      break;
355
 
356
    case EXPR_STRUCTURE:
357
      fprintf (dumpfile, "%s(", p->ts.u.derived->name);
358
      show_constructor (p->value.constructor);
359
      fputc (')', dumpfile);
360
      break;
361
 
362
    case EXPR_ARRAY:
363
      fputs ("(/ ", dumpfile);
364
      show_constructor (p->value.constructor);
365
      fputs (" /)", dumpfile);
366
 
367
      show_ref (p->ref);
368
      break;
369
 
370
    case EXPR_NULL:
371
      fputs ("NULL()", dumpfile);
372
      break;
373
 
374
    case EXPR_CONSTANT:
375
      switch (p->ts.type)
376
        {
377
        case BT_INTEGER:
378
          mpz_out_str (stdout, 10, p->value.integer);
379
 
380
          if (p->ts.kind != gfc_default_integer_kind)
381
            fprintf (dumpfile, "_%d", p->ts.kind);
382
          break;
383
 
384
        case BT_LOGICAL:
385
          if (p->value.logical)
386
            fputs (".true.", dumpfile);
387
          else
388
            fputs (".false.", dumpfile);
389
          break;
390
 
391
        case BT_REAL:
392
          mpfr_out_str (stdout, 10, 0, p->value.real, GFC_RND_MODE);
393
          if (p->ts.kind != gfc_default_real_kind)
394
            fprintf (dumpfile, "_%d", p->ts.kind);
395
          break;
396
 
397
        case BT_CHARACTER:
398
          show_char_const (p->value.character.string,
399
                           p->value.character.length);
400
          break;
401
 
402
        case BT_COMPLEX:
403
          fputs ("(complex ", dumpfile);
404
 
405
          mpfr_out_str (stdout, 10, 0, mpc_realref (p->value.complex),
406
                        GFC_RND_MODE);
407
          if (p->ts.kind != gfc_default_complex_kind)
408
            fprintf (dumpfile, "_%d", p->ts.kind);
409
 
410
          fputc (' ', dumpfile);
411
 
412
          mpfr_out_str (stdout, 10, 0, mpc_imagref (p->value.complex),
413
                        GFC_RND_MODE);
414
          if (p->ts.kind != gfc_default_complex_kind)
415
            fprintf (dumpfile, "_%d", p->ts.kind);
416
 
417
          fputc (')', dumpfile);
418
          break;
419
 
420
        case BT_HOLLERITH:
421
          fprintf (dumpfile, "%dH", p->representation.length);
422
          c = p->representation.string;
423
          for (i = 0; i < p->representation.length; i++, c++)
424
            {
425
              fputc (*c, dumpfile);
426
            }
427
          break;
428
 
429
        default:
430
          fputs ("???", dumpfile);
431
          break;
432
        }
433
 
434
      if (p->representation.string)
435
        {
436
          fputs (" {", dumpfile);
437
          c = p->representation.string;
438
          for (i = 0; i < p->representation.length; i++, c++)
439
            {
440
              fprintf (dumpfile, "%.2x", (unsigned int) *c);
441
              if (i < p->representation.length - 1)
442
                fputc (',', dumpfile);
443
            }
444
          fputc ('}', dumpfile);
445
        }
446
 
447
      break;
448
 
449
    case EXPR_VARIABLE:
450
      if (p->symtree->n.sym->ns && p->symtree->n.sym->ns->proc_name)
451
        fprintf (dumpfile, "%s:", p->symtree->n.sym->ns->proc_name->name);
452
      fprintf (dumpfile, "%s", p->symtree->n.sym->name);
453
      show_ref (p->ref);
454
      break;
455
 
456
    case EXPR_OP:
457
      fputc ('(', dumpfile);
458
      switch (p->value.op.op)
459
        {
460
        case INTRINSIC_UPLUS:
461
          fputs ("U+ ", dumpfile);
462
          break;
463
        case INTRINSIC_UMINUS:
464
          fputs ("U- ", dumpfile);
465
          break;
466
        case INTRINSIC_PLUS:
467
          fputs ("+ ", dumpfile);
468
          break;
469
        case INTRINSIC_MINUS:
470
          fputs ("- ", dumpfile);
471
          break;
472
        case INTRINSIC_TIMES:
473
          fputs ("* ", dumpfile);
474
          break;
475
        case INTRINSIC_DIVIDE:
476
          fputs ("/ ", dumpfile);
477
          break;
478
        case INTRINSIC_POWER:
479
          fputs ("** ", dumpfile);
480
          break;
481
        case INTRINSIC_CONCAT:
482
          fputs ("// ", dumpfile);
483
          break;
484
        case INTRINSIC_AND:
485
          fputs ("AND ", dumpfile);
486
          break;
487
        case INTRINSIC_OR:
488
          fputs ("OR ", dumpfile);
489
          break;
490
        case INTRINSIC_EQV:
491
          fputs ("EQV ", dumpfile);
492
          break;
493
        case INTRINSIC_NEQV:
494
          fputs ("NEQV ", dumpfile);
495
          break;
496
        case INTRINSIC_EQ:
497
        case INTRINSIC_EQ_OS:
498
          fputs ("= ", dumpfile);
499
          break;
500
        case INTRINSIC_NE:
501
        case INTRINSIC_NE_OS:
502
          fputs ("/= ", dumpfile);
503
          break;
504
        case INTRINSIC_GT:
505
        case INTRINSIC_GT_OS:
506
          fputs ("> ", dumpfile);
507
          break;
508
        case INTRINSIC_GE:
509
        case INTRINSIC_GE_OS:
510
          fputs (">= ", dumpfile);
511
          break;
512
        case INTRINSIC_LT:
513
        case INTRINSIC_LT_OS:
514
          fputs ("< ", dumpfile);
515
          break;
516
        case INTRINSIC_LE:
517
        case INTRINSIC_LE_OS:
518
          fputs ("<= ", dumpfile);
519
          break;
520
        case INTRINSIC_NOT:
521
          fputs ("NOT ", dumpfile);
522
          break;
523
        case INTRINSIC_PARENTHESES:
524
          fputs ("parens", dumpfile);
525
          break;
526
 
527
        default:
528
          gfc_internal_error
529
            ("show_expr(): Bad intrinsic in expression!");
530
        }
531
 
532
      show_expr (p->value.op.op1);
533
 
534
      if (p->value.op.op2)
535
        {
536
          fputc (' ', dumpfile);
537
          show_expr (p->value.op.op2);
538
        }
539
 
540
      fputc (')', dumpfile);
541
      break;
542
 
543
    case EXPR_FUNCTION:
544
      if (p->value.function.name == NULL)
545
        {
546
          fprintf (dumpfile, "%s", p->symtree->n.sym->name);
547
          if (gfc_is_proc_ptr_comp (p, NULL))
548
            show_ref (p->ref);
549
          fputc ('[', dumpfile);
550
          show_actual_arglist (p->value.function.actual);
551
          fputc (']', dumpfile);
552
        }
553
      else
554
        {
555
          fprintf (dumpfile, "%s", p->value.function.name);
556
          if (gfc_is_proc_ptr_comp (p, NULL))
557
            show_ref (p->ref);
558
          fputc ('[', dumpfile);
559
          fputc ('[', dumpfile);
560
          show_actual_arglist (p->value.function.actual);
561
          fputc (']', dumpfile);
562
          fputc (']', dumpfile);
563
        }
564
 
565
      break;
566
 
567
    case EXPR_COMPCALL:
568
      show_compcall (p);
569
      break;
570
 
571
    default:
572
      gfc_internal_error ("show_expr(): Don't know how to show expr");
573
    }
574
}
575
 
576
/* Show symbol attributes.  The flavor and intent are followed by
577
   whatever single bit attributes are present.  */
578
 
579
static void
580
show_attr (symbol_attribute *attr)
581
{
582
 
583
  fprintf (dumpfile, "(%s %s %s %s %s",
584
           gfc_code2string (flavors, attr->flavor),
585
           gfc_intent_string (attr->intent),
586
           gfc_code2string (access_types, attr->access),
587
           gfc_code2string (procedures, attr->proc),
588
           gfc_code2string (save_status, attr->save));
589
 
590
  if (attr->allocatable)
591
    fputs (" ALLOCATABLE", dumpfile);
592
  if (attr->asynchronous)
593
    fputs (" ASYNCHRONOUS", dumpfile);
594
  if (attr->dimension)
595
    fputs (" DIMENSION", dumpfile);
596
  if (attr->external)
597
    fputs (" EXTERNAL", dumpfile);
598
  if (attr->intrinsic)
599
    fputs (" INTRINSIC", dumpfile);
600
  if (attr->optional)
601
    fputs (" OPTIONAL", dumpfile);
602
  if (attr->pointer)
603
    fputs (" POINTER", dumpfile);
604
  if (attr->is_protected)
605
    fputs (" PROTECTED", dumpfile);
606
  if (attr->value)
607
    fputs (" VALUE", dumpfile);
608
  if (attr->volatile_)
609
    fputs (" VOLATILE", dumpfile);
610
  if (attr->threadprivate)
611
    fputs (" THREADPRIVATE", dumpfile);
612
  if (attr->target)
613
    fputs (" TARGET", dumpfile);
614
  if (attr->dummy)
615
    fputs (" DUMMY", dumpfile);
616
  if (attr->result)
617
    fputs (" RESULT", dumpfile);
618
  if (attr->entry)
619
    fputs (" ENTRY", dumpfile);
620
  if (attr->is_bind_c)
621
    fputs (" BIND(C)", dumpfile);
622
 
623
  if (attr->data)
624
    fputs (" DATA", dumpfile);
625
  if (attr->use_assoc)
626
    fputs (" USE-ASSOC", dumpfile);
627
  if (attr->in_namelist)
628
    fputs (" IN-NAMELIST", dumpfile);
629
  if (attr->in_common)
630
    fputs (" IN-COMMON", dumpfile);
631
 
632
  if (attr->abstract)
633
    fputs (" ABSTRACT", dumpfile);
634
  if (attr->function)
635
    fputs (" FUNCTION", dumpfile);
636
  if (attr->subroutine)
637
    fputs (" SUBROUTINE", dumpfile);
638
  if (attr->implicit_type)
639
    fputs (" IMPLICIT-TYPE", dumpfile);
640
 
641
  if (attr->sequence)
642
    fputs (" SEQUENCE", dumpfile);
643
  if (attr->elemental)
644
    fputs (" ELEMENTAL", dumpfile);
645
  if (attr->pure)
646
    fputs (" PURE", dumpfile);
647
  if (attr->recursive)
648
    fputs (" RECURSIVE", dumpfile);
649
 
650
  fputc (')', dumpfile);
651
}
652
 
653
 
654
/* Show components of a derived type.  */
655
 
656
static void
657
show_components (gfc_symbol *sym)
658
{
659
  gfc_component *c;
660
 
661
  for (c = sym->components; c; c = c->next)
662
    {
663
      fprintf (dumpfile, "(%s ", c->name);
664
      show_typespec (&c->ts);
665
      if (c->attr.pointer)
666
        fputs (" POINTER", dumpfile);
667
      if (c->attr.proc_pointer)
668
        fputs (" PPC", dumpfile);
669
      if (c->attr.dimension)
670
        fputs (" DIMENSION", dumpfile);
671
      fputc (' ', dumpfile);
672
      show_array_spec (c->as);
673
      if (c->attr.access)
674
        fprintf (dumpfile, " %s", gfc_code2string (access_types, c->attr.access));
675
      fputc (')', dumpfile);
676
      if (c->next != NULL)
677
        fputc (' ', dumpfile);
678
    }
679
}
680
 
681
 
682
/* Show the f2k_derived namespace with procedure bindings.  */
683
 
684
static void
685
show_typebound_proc (gfc_typebound_proc* tb, const char* name)
686
{
687
  show_indent ();
688
 
689
  if (tb->is_generic)
690
    fputs ("GENERIC", dumpfile);
691
  else
692
    {
693
      fputs ("PROCEDURE, ", dumpfile);
694
      if (tb->nopass)
695
        fputs ("NOPASS", dumpfile);
696
      else
697
        {
698
          if (tb->pass_arg)
699
            fprintf (dumpfile, "PASS(%s)", tb->pass_arg);
700
          else
701
            fputs ("PASS", dumpfile);
702
        }
703
      if (tb->non_overridable)
704
        fputs (", NON_OVERRIDABLE", dumpfile);
705
    }
706
 
707
  if (tb->access == ACCESS_PUBLIC)
708
    fputs (", PUBLIC", dumpfile);
709
  else
710
    fputs (", PRIVATE", dumpfile);
711
 
712
  fprintf (dumpfile, " :: %s => ", name);
713
 
714
  if (tb->is_generic)
715
    {
716
      gfc_tbp_generic* g;
717
      for (g = tb->u.generic; g; g = g->next)
718
        {
719
          fputs (g->specific_st->name, dumpfile);
720
          if (g->next)
721
            fputs (", ", dumpfile);
722
        }
723
    }
724
  else
725
    fputs (tb->u.specific->n.sym->name, dumpfile);
726
}
727
 
728
static void
729
show_typebound_symtree (gfc_symtree* st)
730
{
731
  gcc_assert (st->n.tb);
732
  show_typebound_proc (st->n.tb, st->name);
733
}
734
 
735
static void
736
show_f2k_derived (gfc_namespace* f2k)
737
{
738
  gfc_finalizer* f;
739
  int op;
740
 
741
  show_indent ();
742
  fputs ("Procedure bindings:", dumpfile);
743
  ++show_level;
744
 
745
  /* Finalizer bindings.  */
746
  for (f = f2k->finalizers; f; f = f->next)
747
    {
748
      show_indent ();
749
      fprintf (dumpfile, "FINAL %s", f->proc_sym->name);
750
    }
751
 
752
  /* Type-bound procedures.  */
753
  gfc_traverse_symtree (f2k->tb_sym_root, &show_typebound_symtree);
754
 
755
  --show_level;
756
 
757
  show_indent ();
758
  fputs ("Operator bindings:", dumpfile);
759
  ++show_level;
760
 
761
  /* User-defined operators.  */
762
  gfc_traverse_symtree (f2k->tb_uop_root, &show_typebound_symtree);
763
 
764
  /* Intrinsic operators.  */
765
  for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; ++op)
766
    if (f2k->tb_op[op])
767
      show_typebound_proc (f2k->tb_op[op],
768
                           gfc_op2string ((gfc_intrinsic_op) op));
769
 
770
  --show_level;
771
}
772
 
773
 
774
/* Show a symbol.  If a symbol is an ENTRY, SUBROUTINE or FUNCTION, we
775
   show the interface.  Information needed to reconstruct the list of
776
   specific interfaces associated with a generic symbol is done within
777
   that symbol.  */
778
 
779
static void
780
show_symbol (gfc_symbol *sym)
781
{
782
  gfc_formal_arglist *formal;
783
  gfc_interface *intr;
784
 
785
  if (sym == NULL)
786
    return;
787
 
788
  show_indent ();
789
 
790
  fprintf (dumpfile, "symbol %s ", sym->name);
791
  show_typespec (&sym->ts);
792
  show_attr (&sym->attr);
793
 
794
  if (sym->value)
795
    {
796
      show_indent ();
797
      fputs ("value: ", dumpfile);
798
      show_expr (sym->value);
799
    }
800
 
801
  if (sym->as)
802
    {
803
      show_indent ();
804
      fputs ("Array spec:", dumpfile);
805
      show_array_spec (sym->as);
806
    }
807
 
808
  if (sym->generic)
809
    {
810
      show_indent ();
811
      fputs ("Generic interfaces:", dumpfile);
812
      for (intr = sym->generic; intr; intr = intr->next)
813
        fprintf (dumpfile, " %s", intr->sym->name);
814
    }
815
 
816
  if (sym->result)
817
    {
818
      show_indent ();
819
      fprintf (dumpfile, "result: %s", sym->result->name);
820
    }
821
 
822
  if (sym->components)
823
    {
824
      show_indent ();
825
      fputs ("components: ", dumpfile);
826
      show_components (sym);
827
    }
828
 
829
  if (sym->f2k_derived)
830
    {
831
      show_indent ();
832
      if (sym->hash_value)
833
        fprintf (dumpfile, "hash: %d", sym->hash_value);
834
      show_f2k_derived (sym->f2k_derived);
835
    }
836
 
837
  if (sym->formal)
838
    {
839
      show_indent ();
840
      fputs ("Formal arglist:", dumpfile);
841
 
842
      for (formal = sym->formal; formal; formal = formal->next)
843
        {
844
          if (formal->sym != NULL)
845
            fprintf (dumpfile, " %s", formal->sym->name);
846
          else
847
            fputs (" [Alt Return]", dumpfile);
848
        }
849
    }
850
 
851
  if (sym->formal_ns && (sym->formal_ns->proc_name != sym))
852
    {
853
      show_indent ();
854
      fputs ("Formal namespace", dumpfile);
855
      show_namespace (sym->formal_ns);
856
    }
857
 
858
  fputc ('\n', dumpfile);
859
}
860
 
861
 
862
/* Show a user-defined operator.  Just prints an operator
863
   and the name of the associated subroutine, really.  */
864
 
865
static void
866
show_uop (gfc_user_op *uop)
867
{
868
  gfc_interface *intr;
869
 
870
  show_indent ();
871
  fprintf (dumpfile, "%s:", uop->name);
872
 
873
  for (intr = uop->op; intr; intr = intr->next)
874
    fprintf (dumpfile, " %s", intr->sym->name);
875
}
876
 
877
 
878
/* Workhorse function for traversing the user operator symtree.  */
879
 
880
static void
881
traverse_uop (gfc_symtree *st, void (*func) (gfc_user_op *))
882
{
883
  if (st == NULL)
884
    return;
885
 
886
  (*func) (st->n.uop);
887
 
888
  traverse_uop (st->left, func);
889
  traverse_uop (st->right, func);
890
}
891
 
892
 
893
/* Traverse the tree of user operator nodes.  */
894
 
895
void
896
gfc_traverse_user_op (gfc_namespace *ns, void (*func) (gfc_user_op *))
897
{
898
  traverse_uop (ns->uop_root, func);
899
}
900
 
901
 
902
/* Function to display a common block.  */
903
 
904
static void
905
show_common (gfc_symtree *st)
906
{
907
  gfc_symbol *s;
908
 
909
  show_indent ();
910
  fprintf (dumpfile, "common: /%s/ ", st->name);
911
 
912
  s = st->n.common->head;
913
  while (s)
914
    {
915
      fprintf (dumpfile, "%s", s->name);
916
      s = s->common_next;
917
      if (s)
918
        fputs (", ", dumpfile);
919
    }
920
  fputc ('\n', dumpfile);
921
}
922
 
923
 
924
/* Worker function to display the symbol tree.  */
925
 
926
static void
927
show_symtree (gfc_symtree *st)
928
{
929
  show_indent ();
930
  fprintf (dumpfile, "symtree: %s  Ambig %d", st->name, st->ambiguous);
931
 
932
  if (st->n.sym->ns != gfc_current_ns)
933
    fprintf (dumpfile, " from namespace %s", st->n.sym->ns->proc_name->name);
934
  else
935
    show_symbol (st->n.sym);
936
}
937
 
938
 
939
/******************* Show gfc_code structures **************/
940
 
941
 
942
/* Show a list of code structures.  Mutually recursive with
943
   show_code_node().  */
944
 
945
static void
946
show_code (int level, gfc_code *c)
947
{
948
  for (; c; c = c->next)
949
    show_code_node (level, c);
950
}
951
 
952
static void
953
show_namelist (gfc_namelist *n)
954
{
955
  for (; n->next; n = n->next)
956
    fprintf (dumpfile, "%s,", n->sym->name);
957
  fprintf (dumpfile, "%s", n->sym->name);
958
}
959
 
960
/* Show a single OpenMP directive node and everything underneath it
961
   if necessary.  */
962
 
963
static void
964
show_omp_node (int level, gfc_code *c)
965
{
966
  gfc_omp_clauses *omp_clauses = NULL;
967
  const char *name = NULL;
968
 
969
  switch (c->op)
970
    {
971
    case EXEC_OMP_ATOMIC: name = "ATOMIC"; break;
972
    case EXEC_OMP_BARRIER: name = "BARRIER"; break;
973
    case EXEC_OMP_CRITICAL: name = "CRITICAL"; break;
974
    case EXEC_OMP_FLUSH: name = "FLUSH"; break;
975
    case EXEC_OMP_DO: name = "DO"; break;
976
    case EXEC_OMP_MASTER: name = "MASTER"; break;
977
    case EXEC_OMP_ORDERED: name = "ORDERED"; break;
978
    case EXEC_OMP_PARALLEL: name = "PARALLEL"; break;
979
    case EXEC_OMP_PARALLEL_DO: name = "PARALLEL DO"; break;
980
    case EXEC_OMP_PARALLEL_SECTIONS: name = "PARALLEL SECTIONS"; break;
981
    case EXEC_OMP_PARALLEL_WORKSHARE: name = "PARALLEL WORKSHARE"; break;
982
    case EXEC_OMP_SECTIONS: name = "SECTIONS"; break;
983
    case EXEC_OMP_SINGLE: name = "SINGLE"; break;
984
    case EXEC_OMP_TASK: name = "TASK"; break;
985
    case EXEC_OMP_TASKWAIT: name = "TASKWAIT"; break;
986
    case EXEC_OMP_WORKSHARE: name = "WORKSHARE"; break;
987
    default:
988
      gcc_unreachable ();
989
    }
990
  fprintf (dumpfile, "!$OMP %s", name);
991
  switch (c->op)
992
    {
993
    case EXEC_OMP_DO:
994
    case EXEC_OMP_PARALLEL:
995
    case EXEC_OMP_PARALLEL_DO:
996
    case EXEC_OMP_PARALLEL_SECTIONS:
997
    case EXEC_OMP_SECTIONS:
998
    case EXEC_OMP_SINGLE:
999
    case EXEC_OMP_WORKSHARE:
1000
    case EXEC_OMP_PARALLEL_WORKSHARE:
1001
    case EXEC_OMP_TASK:
1002
      omp_clauses = c->ext.omp_clauses;
1003
      break;
1004
    case EXEC_OMP_CRITICAL:
1005
      if (c->ext.omp_name)
1006
        fprintf (dumpfile, " (%s)", c->ext.omp_name);
1007
      break;
1008
    case EXEC_OMP_FLUSH:
1009
      if (c->ext.omp_namelist)
1010
        {
1011
          fputs (" (", dumpfile);
1012
          show_namelist (c->ext.omp_namelist);
1013
          fputc (')', dumpfile);
1014
        }
1015
      return;
1016
    case EXEC_OMP_BARRIER:
1017
    case EXEC_OMP_TASKWAIT:
1018
      return;
1019
    default:
1020
      break;
1021
    }
1022
  if (omp_clauses)
1023
    {
1024
      int list_type;
1025
 
1026
      if (omp_clauses->if_expr)
1027
        {
1028
          fputs (" IF(", dumpfile);
1029
          show_expr (omp_clauses->if_expr);
1030
          fputc (')', dumpfile);
1031
        }
1032
      if (omp_clauses->num_threads)
1033
        {
1034
          fputs (" NUM_THREADS(", dumpfile);
1035
          show_expr (omp_clauses->num_threads);
1036
          fputc (')', dumpfile);
1037
        }
1038
      if (omp_clauses->sched_kind != OMP_SCHED_NONE)
1039
        {
1040
          const char *type;
1041
          switch (omp_clauses->sched_kind)
1042
            {
1043
            case OMP_SCHED_STATIC: type = "STATIC"; break;
1044
            case OMP_SCHED_DYNAMIC: type = "DYNAMIC"; break;
1045
            case OMP_SCHED_GUIDED: type = "GUIDED"; break;
1046
            case OMP_SCHED_RUNTIME: type = "RUNTIME"; break;
1047
            case OMP_SCHED_AUTO: type = "AUTO"; break;
1048
            default:
1049
              gcc_unreachable ();
1050
            }
1051
          fprintf (dumpfile, " SCHEDULE (%s", type);
1052
          if (omp_clauses->chunk_size)
1053
            {
1054
              fputc (',', dumpfile);
1055
              show_expr (omp_clauses->chunk_size);
1056
            }
1057
          fputc (')', dumpfile);
1058
        }
1059
      if (omp_clauses->default_sharing != OMP_DEFAULT_UNKNOWN)
1060
        {
1061
          const char *type;
1062
          switch (omp_clauses->default_sharing)
1063
            {
1064
            case OMP_DEFAULT_NONE: type = "NONE"; break;
1065
            case OMP_DEFAULT_PRIVATE: type = "PRIVATE"; break;
1066
            case OMP_DEFAULT_SHARED: type = "SHARED"; break;
1067
            case OMP_DEFAULT_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
1068
            default:
1069
              gcc_unreachable ();
1070
            }
1071
          fprintf (dumpfile, " DEFAULT(%s)", type);
1072
        }
1073
      if (omp_clauses->ordered)
1074
        fputs (" ORDERED", dumpfile);
1075
      if (omp_clauses->untied)
1076
        fputs (" UNTIED", dumpfile);
1077
      if (omp_clauses->collapse)
1078
        fprintf (dumpfile, " COLLAPSE(%d)", omp_clauses->collapse);
1079
      for (list_type = 0; list_type < OMP_LIST_NUM; list_type++)
1080
        if (omp_clauses->lists[list_type] != NULL
1081
            && list_type != OMP_LIST_COPYPRIVATE)
1082
          {
1083
            const char *type;
1084
            if (list_type >= OMP_LIST_REDUCTION_FIRST)
1085
              {
1086
                switch (list_type)
1087
                  {
1088
                  case OMP_LIST_PLUS: type = "+"; break;
1089
                  case OMP_LIST_MULT: type = "*"; break;
1090
                  case OMP_LIST_SUB: type = "-"; break;
1091
                  case OMP_LIST_AND: type = ".AND."; break;
1092
                  case OMP_LIST_OR: type = ".OR."; break;
1093
                  case OMP_LIST_EQV: type = ".EQV."; break;
1094
                  case OMP_LIST_NEQV: type = ".NEQV."; break;
1095
                  case OMP_LIST_MAX: type = "MAX"; break;
1096
                  case OMP_LIST_MIN: type = "MIN"; break;
1097
                  case OMP_LIST_IAND: type = "IAND"; break;
1098
                  case OMP_LIST_IOR: type = "IOR"; break;
1099
                  case OMP_LIST_IEOR: type = "IEOR"; break;
1100
                  default:
1101
                    gcc_unreachable ();
1102
                  }
1103
                fprintf (dumpfile, " REDUCTION(%s:", type);
1104
              }
1105
            else
1106
              {
1107
                switch (list_type)
1108
                  {
1109
                  case OMP_LIST_PRIVATE: type = "PRIVATE"; break;
1110
                  case OMP_LIST_FIRSTPRIVATE: type = "FIRSTPRIVATE"; break;
1111
                  case OMP_LIST_LASTPRIVATE: type = "LASTPRIVATE"; break;
1112
                  case OMP_LIST_SHARED: type = "SHARED"; break;
1113
                  case OMP_LIST_COPYIN: type = "COPYIN"; break;
1114
                  default:
1115
                    gcc_unreachable ();
1116
                  }
1117
                fprintf (dumpfile, " %s(", type);
1118
              }
1119
            show_namelist (omp_clauses->lists[list_type]);
1120
            fputc (')', dumpfile);
1121
          }
1122
    }
1123
  fputc ('\n', dumpfile);
1124
  if (c->op == EXEC_OMP_SECTIONS || c->op == EXEC_OMP_PARALLEL_SECTIONS)
1125
    {
1126
      gfc_code *d = c->block;
1127
      while (d != NULL)
1128
        {
1129
          show_code (level + 1, d->next);
1130
          if (d->block == NULL)
1131
            break;
1132
          code_indent (level, 0);
1133
          fputs ("!$OMP SECTION\n", dumpfile);
1134
          d = d->block;
1135
        }
1136
    }
1137
  else
1138
    show_code (level + 1, c->block->next);
1139
  if (c->op == EXEC_OMP_ATOMIC)
1140
    return;
1141
  code_indent (level, 0);
1142
  fprintf (dumpfile, "!$OMP END %s", name);
1143
  if (omp_clauses != NULL)
1144
    {
1145
      if (omp_clauses->lists[OMP_LIST_COPYPRIVATE])
1146
        {
1147
          fputs (" COPYPRIVATE(", dumpfile);
1148
          show_namelist (omp_clauses->lists[OMP_LIST_COPYPRIVATE]);
1149
          fputc (')', dumpfile);
1150
        }
1151
      else if (omp_clauses->nowait)
1152
        fputs (" NOWAIT", dumpfile);
1153
    }
1154
  else if (c->op == EXEC_OMP_CRITICAL && c->ext.omp_name)
1155
    fprintf (dumpfile, " (%s)", c->ext.omp_name);
1156
}
1157
 
1158
 
1159
/* Show a single code node and everything underneath it if necessary.  */
1160
 
1161
static void
1162
show_code_node (int level, gfc_code *c)
1163
{
1164
  gfc_forall_iterator *fa;
1165
  gfc_open *open;
1166
  gfc_case *cp;
1167
  gfc_alloc *a;
1168
  gfc_code *d;
1169
  gfc_close *close;
1170
  gfc_filepos *fp;
1171
  gfc_inquire *i;
1172
  gfc_dt *dt;
1173
 
1174
  code_indent (level, c->here);
1175
 
1176
  switch (c->op)
1177
    {
1178
    case EXEC_END_PROCEDURE:
1179
      break;
1180
 
1181
    case EXEC_NOP:
1182
      fputs ("NOP", dumpfile);
1183
      break;
1184
 
1185
    case EXEC_CONTINUE:
1186
      fputs ("CONTINUE", dumpfile);
1187
      break;
1188
 
1189
    case EXEC_ENTRY:
1190
      fprintf (dumpfile, "ENTRY %s", c->ext.entry->sym->name);
1191
      break;
1192
 
1193
    case EXEC_INIT_ASSIGN:
1194
    case EXEC_ASSIGN:
1195
      fputs ("ASSIGN ", dumpfile);
1196
      show_expr (c->expr1);
1197
      fputc (' ', dumpfile);
1198
      show_expr (c->expr2);
1199
      break;
1200
 
1201
    case EXEC_LABEL_ASSIGN:
1202
      fputs ("LABEL ASSIGN ", dumpfile);
1203
      show_expr (c->expr1);
1204
      fprintf (dumpfile, " %d", c->label1->value);
1205
      break;
1206
 
1207
    case EXEC_POINTER_ASSIGN:
1208
      fputs ("POINTER ASSIGN ", dumpfile);
1209
      show_expr (c->expr1);
1210
      fputc (' ', dumpfile);
1211
      show_expr (c->expr2);
1212
      break;
1213
 
1214
    case EXEC_GOTO:
1215
      fputs ("GOTO ", dumpfile);
1216
      if (c->label1)
1217
        fprintf (dumpfile, "%d", c->label1->value);
1218
      else
1219
        {
1220
          show_expr (c->expr1);
1221
          d = c->block;
1222
          if (d != NULL)
1223
            {
1224
              fputs (", (", dumpfile);
1225
              for (; d; d = d ->block)
1226
                {
1227
                  code_indent (level, d->label1);
1228
                  if (d->block != NULL)
1229
                    fputc (',', dumpfile);
1230
                  else
1231
                    fputc (')', dumpfile);
1232
                }
1233
            }
1234
        }
1235
      break;
1236
 
1237
    case EXEC_CALL:
1238
    case EXEC_ASSIGN_CALL:
1239
      if (c->resolved_sym)
1240
        fprintf (dumpfile, "CALL %s ", c->resolved_sym->name);
1241
      else if (c->symtree)
1242
        fprintf (dumpfile, "CALL %s ", c->symtree->name);
1243
      else
1244
        fputs ("CALL ?? ", dumpfile);
1245
 
1246
      show_actual_arglist (c->ext.actual);
1247
      break;
1248
 
1249
    case EXEC_COMPCALL:
1250
      fputs ("CALL ", dumpfile);
1251
      show_compcall (c->expr1);
1252
      break;
1253
 
1254
    case EXEC_CALL_PPC:
1255
      fputs ("CALL ", dumpfile);
1256
      show_expr (c->expr1);
1257
      show_actual_arglist (c->ext.actual);
1258
      break;
1259
 
1260
    case EXEC_RETURN:
1261
      fputs ("RETURN ", dumpfile);
1262
      if (c->expr1)
1263
        show_expr (c->expr1);
1264
      break;
1265
 
1266
    case EXEC_PAUSE:
1267
      fputs ("PAUSE ", dumpfile);
1268
 
1269
      if (c->expr1 != NULL)
1270
        show_expr (c->expr1);
1271
      else
1272
        fprintf (dumpfile, "%d", c->ext.stop_code);
1273
 
1274
      break;
1275
 
1276
    case EXEC_STOP:
1277
      fputs ("STOP ", dumpfile);
1278
 
1279
      if (c->expr1 != NULL)
1280
        show_expr (c->expr1);
1281
      else
1282
        fprintf (dumpfile, "%d", c->ext.stop_code);
1283
 
1284
      break;
1285
 
1286
    case EXEC_ARITHMETIC_IF:
1287
      fputs ("IF ", dumpfile);
1288
      show_expr (c->expr1);
1289
      fprintf (dumpfile, " %d, %d, %d",
1290
                  c->label1->value, c->label2->value, c->label3->value);
1291
      break;
1292
 
1293
    case EXEC_IF:
1294
      d = c->block;
1295
      fputs ("IF ", dumpfile);
1296
      show_expr (d->expr1);
1297
      fputc ('\n', dumpfile);
1298
      show_code (level + 1, d->next);
1299
 
1300
      d = d->block;
1301
      for (; d; d = d->block)
1302
        {
1303
          code_indent (level, 0);
1304
 
1305
          if (d->expr1 == NULL)
1306
            fputs ("ELSE\n", dumpfile);
1307
          else
1308
            {
1309
              fputs ("ELSE IF ", dumpfile);
1310
              show_expr (d->expr1);
1311
              fputc ('\n', dumpfile);
1312
            }
1313
 
1314
          show_code (level + 1, d->next);
1315
        }
1316
 
1317
      code_indent (level, c->label1);
1318
 
1319
      fputs ("ENDIF", dumpfile);
1320
      break;
1321
 
1322
    case EXEC_SELECT:
1323
      d = c->block;
1324
      fputs ("SELECT CASE ", dumpfile);
1325
      show_expr (c->expr1);
1326
      fputc ('\n', dumpfile);
1327
 
1328
      for (; d; d = d->block)
1329
        {
1330
          code_indent (level, 0);
1331
 
1332
          fputs ("CASE ", dumpfile);
1333
          for (cp = d->ext.case_list; cp; cp = cp->next)
1334
            {
1335
              fputc ('(', dumpfile);
1336
              show_expr (cp->low);
1337
              fputc (' ', dumpfile);
1338
              show_expr (cp->high);
1339
              fputc (')', dumpfile);
1340
              fputc (' ', dumpfile);
1341
            }
1342
          fputc ('\n', dumpfile);
1343
 
1344
          show_code (level + 1, d->next);
1345
        }
1346
 
1347
      code_indent (level, c->label1);
1348
      fputs ("END SELECT", dumpfile);
1349
      break;
1350
 
1351
    case EXEC_WHERE:
1352
      fputs ("WHERE ", dumpfile);
1353
 
1354
      d = c->block;
1355
      show_expr (d->expr1);
1356
      fputc ('\n', dumpfile);
1357
 
1358
      show_code (level + 1, d->next);
1359
 
1360
      for (d = d->block; d; d = d->block)
1361
        {
1362
          code_indent (level, 0);
1363
          fputs ("ELSE WHERE ", dumpfile);
1364
          show_expr (d->expr1);
1365
          fputc ('\n', dumpfile);
1366
          show_code (level + 1, d->next);
1367
        }
1368
 
1369
      code_indent (level, 0);
1370
      fputs ("END WHERE", dumpfile);
1371
      break;
1372
 
1373
 
1374
    case EXEC_FORALL:
1375
      fputs ("FORALL ", dumpfile);
1376
      for (fa = c->ext.forall_iterator; fa; fa = fa->next)
1377
        {
1378
          show_expr (fa->var);
1379
          fputc (' ', dumpfile);
1380
          show_expr (fa->start);
1381
          fputc (':', dumpfile);
1382
          show_expr (fa->end);
1383
          fputc (':', dumpfile);
1384
          show_expr (fa->stride);
1385
 
1386
          if (fa->next != NULL)
1387
            fputc (',', dumpfile);
1388
        }
1389
 
1390
      if (c->expr1 != NULL)
1391
        {
1392
          fputc (',', dumpfile);
1393
          show_expr (c->expr1);
1394
        }
1395
      fputc ('\n', dumpfile);
1396
 
1397
      show_code (level + 1, c->block->next);
1398
 
1399
      code_indent (level, 0);
1400
      fputs ("END FORALL", dumpfile);
1401
      break;
1402
 
1403
    case EXEC_DO:
1404
      fputs ("DO ", dumpfile);
1405
 
1406
      show_expr (c->ext.iterator->var);
1407
      fputc ('=', dumpfile);
1408
      show_expr (c->ext.iterator->start);
1409
      fputc (' ', dumpfile);
1410
      show_expr (c->ext.iterator->end);
1411
      fputc (' ', dumpfile);
1412
      show_expr (c->ext.iterator->step);
1413
      fputc ('\n', dumpfile);
1414
 
1415
      show_code (level + 1, c->block->next);
1416
 
1417
      code_indent (level, 0);
1418
      fputs ("END DO", dumpfile);
1419
      break;
1420
 
1421
    case EXEC_DO_WHILE:
1422
      fputs ("DO WHILE ", dumpfile);
1423
      show_expr (c->expr1);
1424
      fputc ('\n', dumpfile);
1425
 
1426
      show_code (level + 1, c->block->next);
1427
 
1428
      code_indent (level, c->label1);
1429
      fputs ("END DO", dumpfile);
1430
      break;
1431
 
1432
    case EXEC_CYCLE:
1433
      fputs ("CYCLE", dumpfile);
1434
      if (c->symtree)
1435
        fprintf (dumpfile, " %s", c->symtree->n.sym->name);
1436
      break;
1437
 
1438
    case EXEC_EXIT:
1439
      fputs ("EXIT", dumpfile);
1440
      if (c->symtree)
1441
        fprintf (dumpfile, " %s", c->symtree->n.sym->name);
1442
      break;
1443
 
1444
    case EXEC_ALLOCATE:
1445
      fputs ("ALLOCATE ", dumpfile);
1446
      if (c->expr1)
1447
        {
1448
          fputs (" STAT=", dumpfile);
1449
          show_expr (c->expr1);
1450
        }
1451
 
1452
      if (c->expr2)
1453
        {
1454
          fputs (" ERRMSG=", dumpfile);
1455
          show_expr (c->expr2);
1456
        }
1457
 
1458
      for (a = c->ext.alloc.list; a; a = a->next)
1459
        {
1460
          fputc (' ', dumpfile);
1461
          show_expr (a->expr);
1462
        }
1463
 
1464
      break;
1465
 
1466
    case EXEC_DEALLOCATE:
1467
      fputs ("DEALLOCATE ", dumpfile);
1468
      if (c->expr1)
1469
        {
1470
          fputs (" STAT=", dumpfile);
1471
          show_expr (c->expr1);
1472
        }
1473
 
1474
      if (c->expr2)
1475
        {
1476
          fputs (" ERRMSG=", dumpfile);
1477
          show_expr (c->expr2);
1478
        }
1479
 
1480
      for (a = c->ext.alloc.list; a; a = a->next)
1481
        {
1482
          fputc (' ', dumpfile);
1483
          show_expr (a->expr);
1484
        }
1485
 
1486
      break;
1487
 
1488
    case EXEC_OPEN:
1489
      fputs ("OPEN", dumpfile);
1490
      open = c->ext.open;
1491
 
1492
      if (open->unit)
1493
        {
1494
          fputs (" UNIT=", dumpfile);
1495
          show_expr (open->unit);
1496
        }
1497
      if (open->iomsg)
1498
        {
1499
          fputs (" IOMSG=", dumpfile);
1500
          show_expr (open->iomsg);
1501
        }
1502
      if (open->iostat)
1503
        {
1504
          fputs (" IOSTAT=", dumpfile);
1505
          show_expr (open->iostat);
1506
        }
1507
      if (open->file)
1508
        {
1509
          fputs (" FILE=", dumpfile);
1510
          show_expr (open->file);
1511
        }
1512
      if (open->status)
1513
        {
1514
          fputs (" STATUS=", dumpfile);
1515
          show_expr (open->status);
1516
        }
1517
      if (open->access)
1518
        {
1519
          fputs (" ACCESS=", dumpfile);
1520
          show_expr (open->access);
1521
        }
1522
      if (open->form)
1523
        {
1524
          fputs (" FORM=", dumpfile);
1525
          show_expr (open->form);
1526
        }
1527
      if (open->recl)
1528
        {
1529
          fputs (" RECL=", dumpfile);
1530
          show_expr (open->recl);
1531
        }
1532
      if (open->blank)
1533
        {
1534
          fputs (" BLANK=", dumpfile);
1535
          show_expr (open->blank);
1536
        }
1537
      if (open->position)
1538
        {
1539
          fputs (" POSITION=", dumpfile);
1540
          show_expr (open->position);
1541
        }
1542
      if (open->action)
1543
        {
1544
          fputs (" ACTION=", dumpfile);
1545
          show_expr (open->action);
1546
        }
1547
      if (open->delim)
1548
        {
1549
          fputs (" DELIM=", dumpfile);
1550
          show_expr (open->delim);
1551
        }
1552
      if (open->pad)
1553
        {
1554
          fputs (" PAD=", dumpfile);
1555
          show_expr (open->pad);
1556
        }
1557
      if (open->decimal)
1558
        {
1559
          fputs (" DECIMAL=", dumpfile);
1560
          show_expr (open->decimal);
1561
        }
1562
      if (open->encoding)
1563
        {
1564
          fputs (" ENCODING=", dumpfile);
1565
          show_expr (open->encoding);
1566
        }
1567
      if (open->round)
1568
        {
1569
          fputs (" ROUND=", dumpfile);
1570
          show_expr (open->round);
1571
        }
1572
      if (open->sign)
1573
        {
1574
          fputs (" SIGN=", dumpfile);
1575
          show_expr (open->sign);
1576
        }
1577
      if (open->convert)
1578
        {
1579
          fputs (" CONVERT=", dumpfile);
1580
          show_expr (open->convert);
1581
        }
1582
      if (open->asynchronous)
1583
        {
1584
          fputs (" ASYNCHRONOUS=", dumpfile);
1585
          show_expr (open->asynchronous);
1586
        }
1587
      if (open->err != NULL)
1588
        fprintf (dumpfile, " ERR=%d", open->err->value);
1589
 
1590
      break;
1591
 
1592
    case EXEC_CLOSE:
1593
      fputs ("CLOSE", dumpfile);
1594
      close = c->ext.close;
1595
 
1596
      if (close->unit)
1597
        {
1598
          fputs (" UNIT=", dumpfile);
1599
          show_expr (close->unit);
1600
        }
1601
      if (close->iomsg)
1602
        {
1603
          fputs (" IOMSG=", dumpfile);
1604
          show_expr (close->iomsg);
1605
        }
1606
      if (close->iostat)
1607
        {
1608
          fputs (" IOSTAT=", dumpfile);
1609
          show_expr (close->iostat);
1610
        }
1611
      if (close->status)
1612
        {
1613
          fputs (" STATUS=", dumpfile);
1614
          show_expr (close->status);
1615
        }
1616
      if (close->err != NULL)
1617
        fprintf (dumpfile, " ERR=%d", close->err->value);
1618
      break;
1619
 
1620
    case EXEC_BACKSPACE:
1621
      fputs ("BACKSPACE", dumpfile);
1622
      goto show_filepos;
1623
 
1624
    case EXEC_ENDFILE:
1625
      fputs ("ENDFILE", dumpfile);
1626
      goto show_filepos;
1627
 
1628
    case EXEC_REWIND:
1629
      fputs ("REWIND", dumpfile);
1630
      goto show_filepos;
1631
 
1632
    case EXEC_FLUSH:
1633
      fputs ("FLUSH", dumpfile);
1634
 
1635
    show_filepos:
1636
      fp = c->ext.filepos;
1637
 
1638
      if (fp->unit)
1639
        {
1640
          fputs (" UNIT=", dumpfile);
1641
          show_expr (fp->unit);
1642
        }
1643
      if (fp->iomsg)
1644
        {
1645
          fputs (" IOMSG=", dumpfile);
1646
          show_expr (fp->iomsg);
1647
        }
1648
      if (fp->iostat)
1649
        {
1650
          fputs (" IOSTAT=", dumpfile);
1651
          show_expr (fp->iostat);
1652
        }
1653
      if (fp->err != NULL)
1654
        fprintf (dumpfile, " ERR=%d", fp->err->value);
1655
      break;
1656
 
1657
    case EXEC_INQUIRE:
1658
      fputs ("INQUIRE", dumpfile);
1659
      i = c->ext.inquire;
1660
 
1661
      if (i->unit)
1662
        {
1663
          fputs (" UNIT=", dumpfile);
1664
          show_expr (i->unit);
1665
        }
1666
      if (i->file)
1667
        {
1668
          fputs (" FILE=", dumpfile);
1669
          show_expr (i->file);
1670
        }
1671
 
1672
      if (i->iomsg)
1673
        {
1674
          fputs (" IOMSG=", dumpfile);
1675
          show_expr (i->iomsg);
1676
        }
1677
      if (i->iostat)
1678
        {
1679
          fputs (" IOSTAT=", dumpfile);
1680
          show_expr (i->iostat);
1681
        }
1682
      if (i->exist)
1683
        {
1684
          fputs (" EXIST=", dumpfile);
1685
          show_expr (i->exist);
1686
        }
1687
      if (i->opened)
1688
        {
1689
          fputs (" OPENED=", dumpfile);
1690
          show_expr (i->opened);
1691
        }
1692
      if (i->number)
1693
        {
1694
          fputs (" NUMBER=", dumpfile);
1695
          show_expr (i->number);
1696
        }
1697
      if (i->named)
1698
        {
1699
          fputs (" NAMED=", dumpfile);
1700
          show_expr (i->named);
1701
        }
1702
      if (i->name)
1703
        {
1704
          fputs (" NAME=", dumpfile);
1705
          show_expr (i->name);
1706
        }
1707
      if (i->access)
1708
        {
1709
          fputs (" ACCESS=", dumpfile);
1710
          show_expr (i->access);
1711
        }
1712
      if (i->sequential)
1713
        {
1714
          fputs (" SEQUENTIAL=", dumpfile);
1715
          show_expr (i->sequential);
1716
        }
1717
 
1718
      if (i->direct)
1719
        {
1720
          fputs (" DIRECT=", dumpfile);
1721
          show_expr (i->direct);
1722
        }
1723
      if (i->form)
1724
        {
1725
          fputs (" FORM=", dumpfile);
1726
          show_expr (i->form);
1727
        }
1728
      if (i->formatted)
1729
        {
1730
          fputs (" FORMATTED", dumpfile);
1731
          show_expr (i->formatted);
1732
        }
1733
      if (i->unformatted)
1734
        {
1735
          fputs (" UNFORMATTED=", dumpfile);
1736
          show_expr (i->unformatted);
1737
        }
1738
      if (i->recl)
1739
        {
1740
          fputs (" RECL=", dumpfile);
1741
          show_expr (i->recl);
1742
        }
1743
      if (i->nextrec)
1744
        {
1745
          fputs (" NEXTREC=", dumpfile);
1746
          show_expr (i->nextrec);
1747
        }
1748
      if (i->blank)
1749
        {
1750
          fputs (" BLANK=", dumpfile);
1751
          show_expr (i->blank);
1752
        }
1753
      if (i->position)
1754
        {
1755
          fputs (" POSITION=", dumpfile);
1756
          show_expr (i->position);
1757
        }
1758
      if (i->action)
1759
        {
1760
          fputs (" ACTION=", dumpfile);
1761
          show_expr (i->action);
1762
        }
1763
      if (i->read)
1764
        {
1765
          fputs (" READ=", dumpfile);
1766
          show_expr (i->read);
1767
        }
1768
      if (i->write)
1769
        {
1770
          fputs (" WRITE=", dumpfile);
1771
          show_expr (i->write);
1772
        }
1773
      if (i->readwrite)
1774
        {
1775
          fputs (" READWRITE=", dumpfile);
1776
          show_expr (i->readwrite);
1777
        }
1778
      if (i->delim)
1779
        {
1780
          fputs (" DELIM=", dumpfile);
1781
          show_expr (i->delim);
1782
        }
1783
      if (i->pad)
1784
        {
1785
          fputs (" PAD=", dumpfile);
1786
          show_expr (i->pad);
1787
        }
1788
      if (i->convert)
1789
        {
1790
          fputs (" CONVERT=", dumpfile);
1791
          show_expr (i->convert);
1792
        }
1793
      if (i->asynchronous)
1794
        {
1795
          fputs (" ASYNCHRONOUS=", dumpfile);
1796
          show_expr (i->asynchronous);
1797
        }
1798
      if (i->decimal)
1799
        {
1800
          fputs (" DECIMAL=", dumpfile);
1801
          show_expr (i->decimal);
1802
        }
1803
      if (i->encoding)
1804
        {
1805
          fputs (" ENCODING=", dumpfile);
1806
          show_expr (i->encoding);
1807
        }
1808
      if (i->pending)
1809
        {
1810
          fputs (" PENDING=", dumpfile);
1811
          show_expr (i->pending);
1812
        }
1813
      if (i->round)
1814
        {
1815
          fputs (" ROUND=", dumpfile);
1816
          show_expr (i->round);
1817
        }
1818
      if (i->sign)
1819
        {
1820
          fputs (" SIGN=", dumpfile);
1821
          show_expr (i->sign);
1822
        }
1823
      if (i->size)
1824
        {
1825
          fputs (" SIZE=", dumpfile);
1826
          show_expr (i->size);
1827
        }
1828
      if (i->id)
1829
        {
1830
          fputs (" ID=", dumpfile);
1831
          show_expr (i->id);
1832
        }
1833
 
1834
      if (i->err != NULL)
1835
        fprintf (dumpfile, " ERR=%d", i->err->value);
1836
      break;
1837
 
1838
    case EXEC_IOLENGTH:
1839
      fputs ("IOLENGTH ", dumpfile);
1840
      show_expr (c->expr1);
1841
      goto show_dt_code;
1842
      break;
1843
 
1844
    case EXEC_READ:
1845
      fputs ("READ", dumpfile);
1846
      goto show_dt;
1847
 
1848
    case EXEC_WRITE:
1849
      fputs ("WRITE", dumpfile);
1850
 
1851
    show_dt:
1852
      dt = c->ext.dt;
1853
      if (dt->io_unit)
1854
        {
1855
          fputs (" UNIT=", dumpfile);
1856
          show_expr (dt->io_unit);
1857
        }
1858
 
1859
      if (dt->format_expr)
1860
        {
1861
          fputs (" FMT=", dumpfile);
1862
          show_expr (dt->format_expr);
1863
        }
1864
 
1865
      if (dt->format_label != NULL)
1866
        fprintf (dumpfile, " FMT=%d", dt->format_label->value);
1867
      if (dt->namelist)
1868
        fprintf (dumpfile, " NML=%s", dt->namelist->name);
1869
 
1870
      if (dt->iomsg)
1871
        {
1872
          fputs (" IOMSG=", dumpfile);
1873
          show_expr (dt->iomsg);
1874
        }
1875
      if (dt->iostat)
1876
        {
1877
          fputs (" IOSTAT=", dumpfile);
1878
          show_expr (dt->iostat);
1879
        }
1880
      if (dt->size)
1881
        {
1882
          fputs (" SIZE=", dumpfile);
1883
          show_expr (dt->size);
1884
        }
1885
      if (dt->rec)
1886
        {
1887
          fputs (" REC=", dumpfile);
1888
          show_expr (dt->rec);
1889
        }
1890
      if (dt->advance)
1891
        {
1892
          fputs (" ADVANCE=", dumpfile);
1893
          show_expr (dt->advance);
1894
        }
1895
      if (dt->id)
1896
        {
1897
          fputs (" ID=", dumpfile);
1898
          show_expr (dt->id);
1899
        }
1900
      if (dt->pos)
1901
        {
1902
          fputs (" POS=", dumpfile);
1903
          show_expr (dt->pos);
1904
        }
1905
      if (dt->asynchronous)
1906
        {
1907
          fputs (" ASYNCHRONOUS=", dumpfile);
1908
          show_expr (dt->asynchronous);
1909
        }
1910
      if (dt->blank)
1911
        {
1912
          fputs (" BLANK=", dumpfile);
1913
          show_expr (dt->blank);
1914
        }
1915
      if (dt->decimal)
1916
        {
1917
          fputs (" DECIMAL=", dumpfile);
1918
          show_expr (dt->decimal);
1919
        }
1920
      if (dt->delim)
1921
        {
1922
          fputs (" DELIM=", dumpfile);
1923
          show_expr (dt->delim);
1924
        }
1925
      if (dt->pad)
1926
        {
1927
          fputs (" PAD=", dumpfile);
1928
          show_expr (dt->pad);
1929
        }
1930
      if (dt->round)
1931
        {
1932
          fputs (" ROUND=", dumpfile);
1933
          show_expr (dt->round);
1934
        }
1935
      if (dt->sign)
1936
        {
1937
          fputs (" SIGN=", dumpfile);
1938
          show_expr (dt->sign);
1939
        }
1940
 
1941
    show_dt_code:
1942
      fputc ('\n', dumpfile);
1943
      for (c = c->block->next; c; c = c->next)
1944
        show_code_node (level + (c->next != NULL), c);
1945
      return;
1946
 
1947
    case EXEC_TRANSFER:
1948
      fputs ("TRANSFER ", dumpfile);
1949
      show_expr (c->expr1);
1950
      break;
1951
 
1952
    case EXEC_DT_END:
1953
      fputs ("DT_END", dumpfile);
1954
      dt = c->ext.dt;
1955
 
1956
      if (dt->err != NULL)
1957
        fprintf (dumpfile, " ERR=%d", dt->err->value);
1958
      if (dt->end != NULL)
1959
        fprintf (dumpfile, " END=%d", dt->end->value);
1960
      if (dt->eor != NULL)
1961
        fprintf (dumpfile, " EOR=%d", dt->eor->value);
1962
      break;
1963
 
1964
    case EXEC_OMP_ATOMIC:
1965
    case EXEC_OMP_BARRIER:
1966
    case EXEC_OMP_CRITICAL:
1967
    case EXEC_OMP_FLUSH:
1968
    case EXEC_OMP_DO:
1969
    case EXEC_OMP_MASTER:
1970
    case EXEC_OMP_ORDERED:
1971
    case EXEC_OMP_PARALLEL:
1972
    case EXEC_OMP_PARALLEL_DO:
1973
    case EXEC_OMP_PARALLEL_SECTIONS:
1974
    case EXEC_OMP_PARALLEL_WORKSHARE:
1975
    case EXEC_OMP_SECTIONS:
1976
    case EXEC_OMP_SINGLE:
1977
    case EXEC_OMP_TASK:
1978
    case EXEC_OMP_TASKWAIT:
1979
    case EXEC_OMP_WORKSHARE:
1980
      show_omp_node (level, c);
1981
      break;
1982
 
1983
    default:
1984
      gfc_internal_error ("show_code_node(): Bad statement code");
1985
    }
1986
 
1987
  fputc ('\n', dumpfile);
1988
}
1989
 
1990
 
1991
/* Show an equivalence chain.  */
1992
 
1993
static void
1994
show_equiv (gfc_equiv *eq)
1995
{
1996
  show_indent ();
1997
  fputs ("Equivalence: ", dumpfile);
1998
  while (eq)
1999
    {
2000
      show_expr (eq->expr);
2001
      eq = eq->eq;
2002
      if (eq)
2003
        fputs (", ", dumpfile);
2004
    }
2005
}
2006
 
2007
 
2008
/* Show a freakin' whole namespace.  */
2009
 
2010
static void
2011
show_namespace (gfc_namespace *ns)
2012
{
2013
  gfc_interface *intr;
2014
  gfc_namespace *save;
2015
  int op;
2016
  gfc_equiv *eq;
2017
  int i;
2018
 
2019
  save = gfc_current_ns;
2020
  show_level++;
2021
 
2022
  show_indent ();
2023
  fputs ("Namespace:", dumpfile);
2024
 
2025
  if (ns != NULL)
2026
    {
2027
      i = 0;
2028
      do
2029
        {
2030
          int l = i;
2031
          while (i < GFC_LETTERS - 1
2032
                 && gfc_compare_types(&ns->default_type[i+1],
2033
                                      &ns->default_type[l]))
2034
            i++;
2035
 
2036
          if (i > l)
2037
            fprintf (dumpfile, " %c-%c: ", l+'A', i+'A');
2038
          else
2039
            fprintf (dumpfile, " %c: ", l+'A');
2040
 
2041
          show_typespec(&ns->default_type[l]);
2042
          i++;
2043
      } while (i < GFC_LETTERS);
2044
 
2045
      if (ns->proc_name != NULL)
2046
        {
2047
          show_indent ();
2048
          fprintf (dumpfile, "procedure name = %s", ns->proc_name->name);
2049
        }
2050
 
2051
      gfc_current_ns = ns;
2052
      gfc_traverse_symtree (ns->common_root, show_common);
2053
 
2054
      gfc_traverse_symtree (ns->sym_root, show_symtree);
2055
 
2056
      for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; op++)
2057
        {
2058
          /* User operator interfaces */
2059
          intr = ns->op[op];
2060
          if (intr == NULL)
2061
            continue;
2062
 
2063
          show_indent ();
2064
          fprintf (dumpfile, "Operator interfaces for %s:",
2065
                   gfc_op2string ((gfc_intrinsic_op) op));
2066
 
2067
          for (; intr; intr = intr->next)
2068
            fprintf (dumpfile, " %s", intr->sym->name);
2069
        }
2070
 
2071
      if (ns->uop_root != NULL)
2072
        {
2073
          show_indent ();
2074
          fputs ("User operators:\n", dumpfile);
2075
          gfc_traverse_user_op (ns, show_uop);
2076
        }
2077
    }
2078
 
2079
  for (eq = ns->equiv; eq; eq = eq->next)
2080
    show_equiv (eq);
2081
 
2082
  fputc ('\n', dumpfile);
2083
  fputc ('\n', dumpfile);
2084
 
2085
  show_code (0, ns->code);
2086
 
2087
  for (ns = ns->contained; ns; ns = ns->sibling)
2088
    {
2089
      show_indent ();
2090
      fputs ("CONTAINS\n", dumpfile);
2091
      show_namespace (ns);
2092
    }
2093
 
2094
  show_level--;
2095
  fputc ('\n', dumpfile);
2096
  gfc_current_ns = save;
2097
}
2098
 
2099
 
2100
/* Main function for dumping a parse tree.  */
2101
 
2102
void
2103
gfc_dump_parse_tree (gfc_namespace *ns, FILE *file)
2104
{
2105
  dumpfile = file;
2106
  show_namespace (ns);
2107
}

powered by: WebSVN 2.1.0

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