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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [fortran/] [symbol.c] - Blame information for rev 378

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

Line No. Rev Author Line
1 285 jeremybenn
/* Maintain binary trees of symbols.
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
 
24
#include "config.h"
25
#include "system.h"
26
#include "flags.h"
27
#include "gfortran.h"
28
#include "parse.h"
29
#include "match.h"
30
 
31
 
32
/* Strings for all symbol attributes.  We use these for dumping the
33
   parse tree, in error messages, and also when reading and writing
34
   modules.  */
35
 
36
const mstring flavors[] =
37
{
38
  minit ("UNKNOWN-FL", FL_UNKNOWN), minit ("PROGRAM", FL_PROGRAM),
39
  minit ("BLOCK-DATA", FL_BLOCK_DATA), minit ("MODULE", FL_MODULE),
40
  minit ("VARIABLE", FL_VARIABLE), minit ("PARAMETER", FL_PARAMETER),
41
  minit ("LABEL", FL_LABEL), minit ("PROCEDURE", FL_PROCEDURE),
42
  minit ("DERIVED", FL_DERIVED), minit ("NAMELIST", FL_NAMELIST),
43
  minit (NULL, -1)
44
};
45
 
46
const mstring procedures[] =
47
{
48
    minit ("UNKNOWN-PROC", PROC_UNKNOWN),
49
    minit ("MODULE-PROC", PROC_MODULE),
50
    minit ("INTERNAL-PROC", PROC_INTERNAL),
51
    minit ("DUMMY-PROC", PROC_DUMMY),
52
    minit ("INTRINSIC-PROC", PROC_INTRINSIC),
53
    minit ("EXTERNAL-PROC", PROC_EXTERNAL),
54
    minit ("STATEMENT-PROC", PROC_ST_FUNCTION),
55
    minit (NULL, -1)
56
};
57
 
58
const mstring intents[] =
59
{
60
    minit ("UNKNOWN-INTENT", INTENT_UNKNOWN),
61
    minit ("IN", INTENT_IN),
62
    minit ("OUT", INTENT_OUT),
63
    minit ("INOUT", INTENT_INOUT),
64
    minit (NULL, -1)
65
};
66
 
67
const mstring access_types[] =
68
{
69
    minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN),
70
    minit ("PUBLIC", ACCESS_PUBLIC),
71
    minit ("PRIVATE", ACCESS_PRIVATE),
72
    minit (NULL, -1)
73
};
74
 
75
const mstring ifsrc_types[] =
76
{
77
    minit ("UNKNOWN", IFSRC_UNKNOWN),
78
    minit ("DECL", IFSRC_DECL),
79
    minit ("BODY", IFSRC_IFBODY)
80
};
81
 
82
const mstring save_status[] =
83
{
84
    minit ("UNKNOWN", SAVE_NONE),
85
    minit ("EXPLICIT-SAVE", SAVE_EXPLICIT),
86
    minit ("IMPLICIT-SAVE", SAVE_IMPLICIT),
87
};
88
 
89
/* This is to make sure the backend generates setup code in the correct
90
   order.  */
91
 
92
static int next_dummy_order = 1;
93
 
94
 
95
gfc_namespace *gfc_current_ns;
96
gfc_namespace *gfc_global_ns_list;
97
 
98
gfc_gsymbol *gfc_gsym_root = NULL;
99
 
100
static gfc_symbol *changed_syms = NULL;
101
 
102
gfc_dt_list *gfc_derived_types;
103
 
104
 
105
/* List of tentative typebound-procedures.  */
106
 
107
typedef struct tentative_tbp
108
{
109
  gfc_typebound_proc *proc;
110
  struct tentative_tbp *next;
111
}
112
tentative_tbp;
113
 
114
static tentative_tbp *tentative_tbp_list = NULL;
115
 
116
 
117
/*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
118
 
119
/* The following static variable indicates whether a particular element has
120
   been explicitly set or not.  */
121
 
122
static int new_flag[GFC_LETTERS];
123
 
124
 
125
/* Handle a correctly parsed IMPLICIT NONE.  */
126
 
127
void
128
gfc_set_implicit_none (void)
129
{
130
  int i;
131
 
132
  if (gfc_current_ns->seen_implicit_none)
133
    {
134
      gfc_error ("Duplicate IMPLICIT NONE statement at %C");
135
      return;
136
    }
137
 
138
  gfc_current_ns->seen_implicit_none = 1;
139
 
140
  for (i = 0; i < GFC_LETTERS; i++)
141
    {
142
      gfc_clear_ts (&gfc_current_ns->default_type[i]);
143
      gfc_current_ns->set_flag[i] = 1;
144
    }
145
}
146
 
147
 
148
/* Reset the implicit range flags.  */
149
 
150
void
151
gfc_clear_new_implicit (void)
152
{
153
  int i;
154
 
155
  for (i = 0; i < GFC_LETTERS; i++)
156
    new_flag[i] = 0;
157
}
158
 
159
 
160
/* Prepare for a new implicit range.  Sets flags in new_flag[].  */
161
 
162
gfc_try
163
gfc_add_new_implicit_range (int c1, int c2)
164
{
165
  int i;
166
 
167
  c1 -= 'a';
168
  c2 -= 'a';
169
 
170
  for (i = c1; i <= c2; i++)
171
    {
172
      if (new_flag[i])
173
        {
174
          gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
175
                     i + 'A');
176
          return FAILURE;
177
        }
178
 
179
      new_flag[i] = 1;
180
    }
181
 
182
  return SUCCESS;
183
}
184
 
185
 
186
/* Add a matched implicit range for gfc_set_implicit().  Check if merging
187
   the new implicit types back into the existing types will work.  */
188
 
189
gfc_try
190
gfc_merge_new_implicit (gfc_typespec *ts)
191
{
192
  int i;
193
 
194
  if (gfc_current_ns->seen_implicit_none)
195
    {
196
      gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
197
      return FAILURE;
198
    }
199
 
200
  for (i = 0; i < GFC_LETTERS; i++)
201
    {
202
      if (new_flag[i])
203
        {
204
          if (gfc_current_ns->set_flag[i])
205
            {
206
              gfc_error ("Letter %c already has an IMPLICIT type at %C",
207
                         i + 'A');
208
              return FAILURE;
209
            }
210
 
211
          gfc_current_ns->default_type[i] = *ts;
212
          gfc_current_ns->implicit_loc[i] = gfc_current_locus;
213
          gfc_current_ns->set_flag[i] = 1;
214
        }
215
    }
216
  return SUCCESS;
217
}
218
 
219
 
220
/* Given a symbol, return a pointer to the typespec for its default type.  */
221
 
222
gfc_typespec *
223
gfc_get_default_type (const char *name, gfc_namespace *ns)
224
{
225
  char letter;
226
 
227
  letter = name[0];
228
 
229
  if (gfc_option.flag_allow_leading_underscore && letter == '_')
230
    gfc_internal_error ("Option -fallow-leading-underscore is for use only by "
231
                        "gfortran developers, and should not be used for "
232
                        "implicitly typed variables");
233
 
234
  if (letter < 'a' || letter > 'z')
235
    gfc_internal_error ("gfc_get_default_type(): Bad symbol '%s'", name);
236
 
237
  if (ns == NULL)
238
    ns = gfc_current_ns;
239
 
240
  return &ns->default_type[letter - 'a'];
241
}
242
 
243
 
244
/* Given a pointer to a symbol, set its type according to the first
245
   letter of its name.  Fails if the letter in question has no default
246
   type.  */
247
 
248
gfc_try
249
gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
250
{
251
  gfc_typespec *ts;
252
 
253
  if (sym->ts.type != BT_UNKNOWN)
254
    gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
255
 
256
  ts = gfc_get_default_type (sym->name, ns);
257
 
258
  if (ts->type == BT_UNKNOWN)
259
    {
260
      if (error_flag && !sym->attr.untyped)
261
        {
262
          gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
263
                     sym->name, &sym->declared_at);
264
          sym->attr.untyped = 1; /* Ensure we only give an error once.  */
265
        }
266
 
267
      return FAILURE;
268
    }
269
 
270
  sym->ts = *ts;
271
  sym->attr.implicit_type = 1;
272
 
273
  if (ts->type == BT_CHARACTER && ts->u.cl)
274
    sym->ts.u.cl = gfc_new_charlen (sym->ns, ts->u.cl);
275
 
276
  if (sym->attr.is_bind_c == 1)
277
    {
278
      /* BIND(C) variables should not be implicitly declared.  */
279
      gfc_warning_now ("Implicitly declared BIND(C) variable '%s' at %L may "
280
                       "not be C interoperable", sym->name, &sym->declared_at);
281
      sym->ts.f90_type = sym->ts.type;
282
    }
283
 
284
  if (sym->attr.dummy != 0)
285
    {
286
      if (sym->ns->proc_name != NULL
287
          && (sym->ns->proc_name->attr.subroutine != 0
288
              || sym->ns->proc_name->attr.function != 0)
289
          && sym->ns->proc_name->attr.is_bind_c != 0)
290
        {
291
          /* Dummy args to a BIND(C) routine may not be interoperable if
292
             they are implicitly typed.  */
293
          gfc_warning_now ("Implicitly declared variable '%s' at %L may not "
294
                           "be C interoperable but it is a dummy argument to "
295
                           "the BIND(C) procedure '%s' at %L", sym->name,
296
                           &(sym->declared_at), sym->ns->proc_name->name,
297
                           &(sym->ns->proc_name->declared_at));
298
          sym->ts.f90_type = sym->ts.type;
299
        }
300
    }
301
 
302
  return SUCCESS;
303
}
304
 
305
 
306
/* This function is called from parse.c(parse_progunit) to check the
307
   type of the function is not implicitly typed in the host namespace
308
   and to implicitly type the function result, if necessary.  */
309
 
310
void
311
gfc_check_function_type (gfc_namespace *ns)
312
{
313
  gfc_symbol *proc = ns->proc_name;
314
 
315
  if (!proc->attr.contained || proc->result->attr.implicit_type)
316
    return;
317
 
318
  if (proc->result->ts.type == BT_UNKNOWN && proc->result->ts.interface == NULL)
319
    {
320
      if (gfc_set_default_type (proc->result, 0, gfc_current_ns)
321
                == SUCCESS)
322
        {
323
          if (proc->result != proc)
324
            {
325
              proc->ts = proc->result->ts;
326
              proc->as = gfc_copy_array_spec (proc->result->as);
327
              proc->attr.dimension = proc->result->attr.dimension;
328
              proc->attr.pointer = proc->result->attr.pointer;
329
              proc->attr.allocatable = proc->result->attr.allocatable;
330
            }
331
        }
332
      else if (!proc->result->attr.proc_pointer)
333
        {
334
          gfc_error ("Function result '%s' at %L has no IMPLICIT type",
335
                     proc->result->name, &proc->result->declared_at);
336
          proc->result->attr.untyped = 1;
337
        }
338
    }
339
}
340
 
341
 
342
/******************** Symbol attribute stuff *********************/
343
 
344
/* This is a generic conflict-checker.  We do this to avoid having a
345
   single conflict in two places.  */
346
 
347
#define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
348
#define conf2(a) if (attr->a) { a2 = a; goto conflict; }
349
#define conf_std(a, b, std) if (attr->a && attr->b)\
350
                              {\
351
                                a1 = a;\
352
                                a2 = b;\
353
                                standard = std;\
354
                                goto conflict_std;\
355
                              }
356
 
357
static gfc_try
358
check_conflict (symbol_attribute *attr, const char *name, locus *where)
359
{
360
  static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
361
    *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
362
    *intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC",
363
    *intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)",
364
    *allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL",
365
    *privat = "PRIVATE", *recursive = "RECURSIVE",
366
    *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
367
    *publik = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
368
    *function = "FUNCTION", *subroutine = "SUBROUTINE",
369
    *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
370
    *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
371
    *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
372
    *volatile_ = "VOLATILE", *is_protected = "PROTECTED",
373
    *is_bind_c = "BIND(C)", *procedure = "PROCEDURE",
374
    *asynchronous = "ASYNCHRONOUS";
375
  static const char *threadprivate = "THREADPRIVATE";
376
 
377
  const char *a1, *a2;
378
  int standard;
379
 
380
  if (where == NULL)
381
    where = &gfc_current_locus;
382
 
383
  if (attr->pointer && attr->intent != INTENT_UNKNOWN)
384
    {
385
      a1 = pointer;
386
      a2 = intent;
387
      standard = GFC_STD_F2003;
388
      goto conflict_std;
389
    }
390
 
391
  /* Check for attributes not allowed in a BLOCK DATA.  */
392
  if (gfc_current_state () == COMP_BLOCK_DATA)
393
    {
394
      a1 = NULL;
395
 
396
      if (attr->in_namelist)
397
        a1 = in_namelist;
398
      if (attr->allocatable)
399
        a1 = allocatable;
400
      if (attr->external)
401
        a1 = external;
402
      if (attr->optional)
403
        a1 = optional;
404
      if (attr->access == ACCESS_PRIVATE)
405
        a1 = privat;
406
      if (attr->access == ACCESS_PUBLIC)
407
        a1 = publik;
408
      if (attr->intent != INTENT_UNKNOWN)
409
        a1 = intent;
410
 
411
      if (a1 != NULL)
412
        {
413
          gfc_error
414
            ("%s attribute not allowed in BLOCK DATA program unit at %L",
415
             a1, where);
416
          return FAILURE;
417
        }
418
    }
419
 
420
  if (attr->save == SAVE_EXPLICIT)
421
    {
422
      conf (dummy, save);
423
      conf (in_common, save);
424
      conf (result, save);
425
 
426
      switch (attr->flavor)
427
        {
428
          case FL_PROGRAM:
429
          case FL_BLOCK_DATA:
430
          case FL_MODULE:
431
          case FL_LABEL:
432
          case FL_DERIVED:
433
          case FL_PARAMETER:
434
            a1 = gfc_code2string (flavors, attr->flavor);
435
            a2 = save;
436
            goto conflict;
437
 
438
          case FL_PROCEDURE:
439
            /* Conflicts between SAVE and PROCEDURE will be checked at
440
               resolution stage, see "resolve_fl_procedure".  */
441
          case FL_VARIABLE:
442
          case FL_NAMELIST:
443
          default:
444
            break;
445
        }
446
    }
447
 
448
  conf (dummy, entry);
449
  conf (dummy, intrinsic);
450
  conf (dummy, threadprivate);
451
  conf (pointer, target);
452
  conf (pointer, intrinsic);
453
  conf (pointer, elemental);
454
  conf (allocatable, elemental);
455
 
456
  conf (target, external);
457
  conf (target, intrinsic);
458
 
459
  if (!attr->if_source)
460
    conf (external, dimension);   /* See Fortran 95's R504.  */
461
 
462
  conf (external, intrinsic);
463
  conf (entry, intrinsic);
464
 
465
  if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained)
466
    conf (external, subroutine);
467
 
468
  if (attr->proc_pointer && gfc_notify_std (GFC_STD_F2003,
469
                            "Fortran 2003: Procedure pointer at %C") == FAILURE)
470
    return FAILURE;
471
 
472
  conf (allocatable, pointer);
473
  conf_std (allocatable, dummy, GFC_STD_F2003);
474
  conf_std (allocatable, function, GFC_STD_F2003);
475
  conf_std (allocatable, result, GFC_STD_F2003);
476
  conf (elemental, recursive);
477
 
478
  conf (in_common, dummy);
479
  conf (in_common, allocatable);
480
  conf (in_common, result);
481
 
482
  conf (dummy, result);
483
 
484
  conf (in_equivalence, use_assoc);
485
  conf (in_equivalence, dummy);
486
  conf (in_equivalence, target);
487
  conf (in_equivalence, pointer);
488
  conf (in_equivalence, function);
489
  conf (in_equivalence, result);
490
  conf (in_equivalence, entry);
491
  conf (in_equivalence, allocatable);
492
  conf (in_equivalence, threadprivate);
493
 
494
  conf (in_namelist, pointer);
495
  conf (in_namelist, allocatable);
496
 
497
  conf (entry, result);
498
 
499
  conf (function, subroutine);
500
 
501
  if (!function && !subroutine)
502
    conf (is_bind_c, dummy);
503
 
504
  conf (is_bind_c, cray_pointer);
505
  conf (is_bind_c, cray_pointee);
506
  conf (is_bind_c, allocatable);
507
  conf (is_bind_c, elemental);
508
 
509
  /* Need to also get volatile attr, according to 5.1 of F2003 draft.
510
     Parameter conflict caught below.  Also, value cannot be specified
511
     for a dummy procedure.  */
512
 
513
  /* Cray pointer/pointee conflicts.  */
514
  conf (cray_pointer, cray_pointee);
515
  conf (cray_pointer, dimension);
516
  conf (cray_pointer, pointer);
517
  conf (cray_pointer, target);
518
  conf (cray_pointer, allocatable);
519
  conf (cray_pointer, external);
520
  conf (cray_pointer, intrinsic);
521
  conf (cray_pointer, in_namelist);
522
  conf (cray_pointer, function);
523
  conf (cray_pointer, subroutine);
524
  conf (cray_pointer, entry);
525
 
526
  conf (cray_pointee, allocatable);
527
  conf (cray_pointee, intent);
528
  conf (cray_pointee, optional);
529
  conf (cray_pointee, dummy);
530
  conf (cray_pointee, target);
531
  conf (cray_pointee, intrinsic);
532
  conf (cray_pointee, pointer);
533
  conf (cray_pointee, entry);
534
  conf (cray_pointee, in_common);
535
  conf (cray_pointee, in_equivalence);
536
  conf (cray_pointee, threadprivate);
537
 
538
  conf (data, dummy);
539
  conf (data, function);
540
  conf (data, result);
541
  conf (data, allocatable);
542
  conf (data, use_assoc);
543
 
544
  conf (value, pointer)
545
  conf (value, allocatable)
546
  conf (value, subroutine)
547
  conf (value, function)
548
  conf (value, volatile_)
549
  conf (value, dimension)
550
  conf (value, external)
551
 
552
  if (attr->value
553
      && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT))
554
    {
555
      a1 = value;
556
      a2 = attr->intent == INTENT_OUT ? intent_out : intent_inout;
557
      goto conflict;
558
    }
559
 
560
  conf (is_protected, intrinsic)
561
  conf (is_protected, external)
562
  conf (is_protected, in_common)
563
 
564
  conf (asynchronous, intrinsic)
565
  conf (asynchronous, external)
566
 
567
  conf (volatile_, intrinsic)
568
  conf (volatile_, external)
569
 
570
  if (attr->volatile_ && attr->intent == INTENT_IN)
571
    {
572
      a1 = volatile_;
573
      a2 = intent_in;
574
      goto conflict;
575
    }
576
 
577
  conf (procedure, allocatable)
578
  conf (procedure, dimension)
579
  conf (procedure, intrinsic)
580
  conf (procedure, is_protected)
581
  conf (procedure, target)
582
  conf (procedure, value)
583
  conf (procedure, volatile_)
584
  conf (procedure, asynchronous)
585
  conf (procedure, entry)
586
 
587
  a1 = gfc_code2string (flavors, attr->flavor);
588
 
589
  if (attr->in_namelist
590
      && attr->flavor != FL_VARIABLE
591
      && attr->flavor != FL_PROCEDURE
592
      && attr->flavor != FL_UNKNOWN)
593
    {
594
      a2 = in_namelist;
595
      goto conflict;
596
    }
597
 
598
  switch (attr->flavor)
599
    {
600
    case FL_PROGRAM:
601
    case FL_BLOCK_DATA:
602
    case FL_MODULE:
603
    case FL_LABEL:
604
      conf2 (dimension);
605
      conf2 (dummy);
606
      conf2 (volatile_);
607
      conf2 (asynchronous);
608
      conf2 (pointer);
609
      conf2 (is_protected);
610
      conf2 (target);
611
      conf2 (external);
612
      conf2 (intrinsic);
613
      conf2 (allocatable);
614
      conf2 (result);
615
      conf2 (in_namelist);
616
      conf2 (optional);
617
      conf2 (function);
618
      conf2 (subroutine);
619
      conf2 (threadprivate);
620
 
621
      if (attr->access == ACCESS_PUBLIC || attr->access == ACCESS_PRIVATE)
622
        {
623
          a2 = attr->access == ACCESS_PUBLIC ? publik : privat;
624
          gfc_error ("%s attribute applied to %s %s at %L", a2, a1,
625
            name, where);
626
          return FAILURE;
627
        }
628
 
629
      if (attr->is_bind_c)
630
        {
631
          gfc_error_now ("BIND(C) applied to %s %s at %L", a1, name, where);
632
          return FAILURE;
633
        }
634
 
635
      break;
636
 
637
    case FL_VARIABLE:
638
      break;
639
 
640
    case FL_NAMELIST:
641
      conf2 (result);
642
      break;
643
 
644
    case FL_PROCEDURE:
645
      /* Conflicts with INTENT, SAVE and RESULT will be checked
646
         at resolution stage, see "resolve_fl_procedure".  */
647
 
648
      if (attr->subroutine)
649
        {
650
          a1 = subroutine;
651
          conf2 (target);
652
          conf2 (allocatable);
653
          conf2 (volatile_);
654
          conf2 (asynchronous);
655
          conf2 (in_namelist);
656
          conf2 (dimension);
657
          conf2 (function);
658
          conf2 (threadprivate);
659
        }
660
 
661
      if (!attr->proc_pointer)
662
        conf2 (in_common);
663
 
664
      switch (attr->proc)
665
        {
666
        case PROC_ST_FUNCTION:
667
          conf2 (dummy);
668
          break;
669
 
670
        case PROC_MODULE:
671
          conf2 (dummy);
672
          break;
673
 
674
        case PROC_DUMMY:
675
          conf2 (result);
676
          conf2 (threadprivate);
677
          break;
678
 
679
        default:
680
          break;
681
        }
682
 
683
      break;
684
 
685
    case FL_DERIVED:
686
      conf2 (dummy);
687
      conf2 (pointer);
688
      conf2 (target);
689
      conf2 (external);
690
      conf2 (intrinsic);
691
      conf2 (allocatable);
692
      conf2 (optional);
693
      conf2 (entry);
694
      conf2 (function);
695
      conf2 (subroutine);
696
      conf2 (threadprivate);
697
      conf2 (result);
698
 
699
      if (attr->intent != INTENT_UNKNOWN)
700
        {
701
          a2 = intent;
702
          goto conflict;
703
        }
704
      break;
705
 
706
    case FL_PARAMETER:
707
      conf2 (external);
708
      conf2 (intrinsic);
709
      conf2 (optional);
710
      conf2 (allocatable);
711
      conf2 (function);
712
      conf2 (subroutine);
713
      conf2 (entry);
714
      conf2 (pointer);
715
      conf2 (is_protected);
716
      conf2 (target);
717
      conf2 (dummy);
718
      conf2 (in_common);
719
      conf2 (value);
720
      conf2 (volatile_);
721
      conf2 (asynchronous);
722
      conf2 (threadprivate);
723
      conf2 (value);
724
      conf2 (is_bind_c);
725
      conf2 (result);
726
      break;
727
 
728
    default:
729
      break;
730
    }
731
 
732
  return SUCCESS;
733
 
734
conflict:
735
  if (name == NULL)
736
    gfc_error ("%s attribute conflicts with %s attribute at %L",
737
               a1, a2, where);
738
  else
739
    gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
740
               a1, a2, name, where);
741
 
742
  return FAILURE;
743
 
744
conflict_std:
745
  if (name == NULL)
746
    {
747
      return gfc_notify_std (standard, "Fortran 2003: %s attribute "
748
                             "with %s attribute at %L", a1, a2,
749
                             where);
750
    }
751
  else
752
    {
753
      return gfc_notify_std (standard, "Fortran 2003: %s attribute "
754
                             "with %s attribute in '%s' at %L",
755
                             a1, a2, name, where);
756
    }
757
}
758
 
759
#undef conf
760
#undef conf2
761
#undef conf_std
762
 
763
 
764
/* Mark a symbol as referenced.  */
765
 
766
void
767
gfc_set_sym_referenced (gfc_symbol *sym)
768
{
769
 
770
  if (sym->attr.referenced)
771
    return;
772
 
773
  sym->attr.referenced = 1;
774
 
775
  /* Remember which order dummy variables are accessed in.  */
776
  if (sym->attr.dummy)
777
    sym->dummy_order = next_dummy_order++;
778
}
779
 
780
 
781
/* Common subroutine called by attribute changing subroutines in order
782
   to prevent them from changing a symbol that has been
783
   use-associated.  Returns zero if it is OK to change the symbol,
784
   nonzero if not.  */
785
 
786
static int
787
check_used (symbol_attribute *attr, const char *name, locus *where)
788
{
789
 
790
  if (attr->use_assoc == 0)
791
    return 0;
792
 
793
  if (where == NULL)
794
    where = &gfc_current_locus;
795
 
796
  if (name == NULL)
797
    gfc_error ("Cannot change attributes of USE-associated symbol at %L",
798
               where);
799
  else
800
    gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
801
               name, where);
802
 
803
  return 1;
804
}
805
 
806
 
807
/* Generate an error because of a duplicate attribute.  */
808
 
809
static void
810
duplicate_attr (const char *attr, locus *where)
811
{
812
 
813
  if (where == NULL)
814
    where = &gfc_current_locus;
815
 
816
  gfc_error ("Duplicate %s attribute specified at %L", attr, where);
817
}
818
 
819
 
820
gfc_try
821
gfc_add_ext_attribute (symbol_attribute *attr, ext_attr_id_t ext_attr,
822
                       locus *where ATTRIBUTE_UNUSED)
823
{
824
  attr->ext_attr |= 1 << ext_attr;
825
  return SUCCESS;
826
}
827
 
828
 
829
/* Called from decl.c (attr_decl1) to check attributes, when declared
830
   separately.  */
831
 
832
gfc_try
833
gfc_add_attribute (symbol_attribute *attr, locus *where)
834
{
835
  if (check_used (attr, NULL, where))
836
    return FAILURE;
837
 
838
  return check_conflict (attr, NULL, where);
839
}
840
 
841
 
842
gfc_try
843
gfc_add_allocatable (symbol_attribute *attr, locus *where)
844
{
845
 
846
  if (check_used (attr, NULL, where))
847
    return FAILURE;
848
 
849
  if (attr->allocatable)
850
    {
851
      duplicate_attr ("ALLOCATABLE", where);
852
      return FAILURE;
853
    }
854
 
855
  if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
856
      && gfc_find_state (COMP_INTERFACE) == FAILURE)
857
    {
858
      gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
859
                 where);
860
      return FAILURE;
861
    }
862
 
863
  attr->allocatable = 1;
864
  return check_conflict (attr, NULL, where);
865
}
866
 
867
 
868
gfc_try
869
gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where)
870
{
871
 
872
  if (check_used (attr, name, where))
873
    return FAILURE;
874
 
875
  if (attr->dimension)
876
    {
877
      duplicate_attr ("DIMENSION", where);
878
      return FAILURE;
879
    }
880
 
881
  if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
882
      && gfc_find_state (COMP_INTERFACE) == FAILURE)
883
    {
884
      gfc_error ("DIMENSION specified for '%s' outside its INTERFACE body "
885
                 "at %L", name, where);
886
      return FAILURE;
887
    }
888
 
889
  attr->dimension = 1;
890
  return check_conflict (attr, name, where);
891
}
892
 
893
 
894
gfc_try
895
gfc_add_external (symbol_attribute *attr, locus *where)
896
{
897
 
898
  if (check_used (attr, NULL, where))
899
    return FAILURE;
900
 
901
  if (attr->external)
902
    {
903
      duplicate_attr ("EXTERNAL", where);
904
      return FAILURE;
905
    }
906
 
907
  if (attr->pointer && attr->if_source != IFSRC_IFBODY)
908
    {
909
      attr->pointer = 0;
910
      attr->proc_pointer = 1;
911
    }
912
 
913
  attr->external = 1;
914
 
915
  return check_conflict (attr, NULL, where);
916
}
917
 
918
 
919
gfc_try
920
gfc_add_intrinsic (symbol_attribute *attr, locus *where)
921
{
922
 
923
  if (check_used (attr, NULL, where))
924
    return FAILURE;
925
 
926
  if (attr->intrinsic)
927
    {
928
      duplicate_attr ("INTRINSIC", where);
929
      return FAILURE;
930
    }
931
 
932
  attr->intrinsic = 1;
933
 
934
  return check_conflict (attr, NULL, where);
935
}
936
 
937
 
938
gfc_try
939
gfc_add_optional (symbol_attribute *attr, locus *where)
940
{
941
 
942
  if (check_used (attr, NULL, where))
943
    return FAILURE;
944
 
945
  if (attr->optional)
946
    {
947
      duplicate_attr ("OPTIONAL", where);
948
      return FAILURE;
949
    }
950
 
951
  attr->optional = 1;
952
  return check_conflict (attr, NULL, where);
953
}
954
 
955
 
956
gfc_try
957
gfc_add_pointer (symbol_attribute *attr, locus *where)
958
{
959
 
960
  if (check_used (attr, NULL, where))
961
    return FAILURE;
962
 
963
  if (attr->pointer && !(attr->if_source == IFSRC_IFBODY
964
      && gfc_find_state (COMP_INTERFACE) == FAILURE))
965
    {
966
      duplicate_attr ("POINTER", where);
967
      return FAILURE;
968
    }
969
 
970
  if (attr->procedure || (attr->external && attr->if_source != IFSRC_IFBODY)
971
      || (attr->if_source == IFSRC_IFBODY
972
      && gfc_find_state (COMP_INTERFACE) == FAILURE))
973
    attr->proc_pointer = 1;
974
  else
975
    attr->pointer = 1;
976
 
977
  return check_conflict (attr, NULL, where);
978
}
979
 
980
 
981
gfc_try
982
gfc_add_cray_pointer (symbol_attribute *attr, locus *where)
983
{
984
 
985
  if (check_used (attr, NULL, where))
986
    return FAILURE;
987
 
988
  attr->cray_pointer = 1;
989
  return check_conflict (attr, NULL, where);
990
}
991
 
992
 
993
gfc_try
994
gfc_add_cray_pointee (symbol_attribute *attr, locus *where)
995
{
996
 
997
  if (check_used (attr, NULL, where))
998
    return FAILURE;
999
 
1000
  if (attr->cray_pointee)
1001
    {
1002
      gfc_error ("Cray Pointee at %L appears in multiple pointer()"
1003
                 " statements", where);
1004
      return FAILURE;
1005
    }
1006
 
1007
  attr->cray_pointee = 1;
1008
  return check_conflict (attr, NULL, where);
1009
}
1010
 
1011
 
1012
gfc_try
1013
gfc_add_protected (symbol_attribute *attr, const char *name, locus *where)
1014
{
1015
  if (check_used (attr, name, where))
1016
    return FAILURE;
1017
 
1018
  if (attr->is_protected)
1019
    {
1020
        if (gfc_notify_std (GFC_STD_LEGACY,
1021
                            "Duplicate PROTECTED attribute specified at %L",
1022
                            where)
1023
            == FAILURE)
1024
          return FAILURE;
1025
    }
1026
 
1027
  attr->is_protected = 1;
1028
  return check_conflict (attr, name, where);
1029
}
1030
 
1031
 
1032
gfc_try
1033
gfc_add_result (symbol_attribute *attr, const char *name, locus *where)
1034
{
1035
 
1036
  if (check_used (attr, name, where))
1037
    return FAILURE;
1038
 
1039
  attr->result = 1;
1040
  return check_conflict (attr, name, where);
1041
}
1042
 
1043
 
1044
gfc_try
1045
gfc_add_save (symbol_attribute *attr, const char *name, locus *where)
1046
{
1047
 
1048
  if (check_used (attr, name, where))
1049
    return FAILURE;
1050
 
1051
  if (gfc_pure (NULL))
1052
    {
1053
      gfc_error
1054
        ("SAVE attribute at %L cannot be specified in a PURE procedure",
1055
         where);
1056
      return FAILURE;
1057
    }
1058
 
1059
  if (attr->save == SAVE_EXPLICIT && !attr->vtab)
1060
    {
1061
        if (gfc_notify_std (GFC_STD_LEGACY,
1062
                            "Duplicate SAVE attribute specified at %L",
1063
                            where)
1064
            == FAILURE)
1065
          return FAILURE;
1066
    }
1067
 
1068
  attr->save = SAVE_EXPLICIT;
1069
  return check_conflict (attr, name, where);
1070
}
1071
 
1072
 
1073
gfc_try
1074
gfc_add_value (symbol_attribute *attr, const char *name, locus *where)
1075
{
1076
 
1077
  if (check_used (attr, name, where))
1078
    return FAILURE;
1079
 
1080
  if (attr->value)
1081
    {
1082
        if (gfc_notify_std (GFC_STD_LEGACY,
1083
                            "Duplicate VALUE attribute specified at %L",
1084
                            where)
1085
            == FAILURE)
1086
          return FAILURE;
1087
    }
1088
 
1089
  attr->value = 1;
1090
  return check_conflict (attr, name, where);
1091
}
1092
 
1093
 
1094
gfc_try
1095
gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where)
1096
{
1097
  /* No check_used needed as 11.2.1 of the F2003 standard allows
1098
     that the local identifier made accessible by a use statement can be
1099
     given a VOLATILE attribute.  */
1100
 
1101
  if (attr->volatile_ && attr->volatile_ns == gfc_current_ns)
1102
    if (gfc_notify_std (GFC_STD_LEGACY,
1103
                        "Duplicate VOLATILE attribute specified at %L", where)
1104
        == FAILURE)
1105
      return FAILURE;
1106
 
1107
  attr->volatile_ = 1;
1108
  attr->volatile_ns = gfc_current_ns;
1109
  return check_conflict (attr, name, where);
1110
}
1111
 
1112
 
1113
gfc_try
1114
gfc_add_asynchronous (symbol_attribute *attr, const char *name, locus *where)
1115
{
1116
  /* No check_used needed as 11.2.1 of the F2003 standard allows
1117
     that the local identifier made accessible by a use statement can be
1118
     given a ASYNCHRONOUS attribute.  */
1119
 
1120
  if (attr->asynchronous && attr->asynchronous_ns == gfc_current_ns)
1121
    if (gfc_notify_std (GFC_STD_LEGACY,
1122
                        "Duplicate ASYNCHRONOUS attribute specified at %L",
1123
                        where) == FAILURE)
1124
      return FAILURE;
1125
 
1126
  attr->asynchronous = 1;
1127
  attr->asynchronous_ns = gfc_current_ns;
1128
  return check_conflict (attr, name, where);
1129
}
1130
 
1131
 
1132
gfc_try
1133
gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where)
1134
{
1135
 
1136
  if (check_used (attr, name, where))
1137
    return FAILURE;
1138
 
1139
  if (attr->threadprivate)
1140
    {
1141
      duplicate_attr ("THREADPRIVATE", where);
1142
      return FAILURE;
1143
    }
1144
 
1145
  attr->threadprivate = 1;
1146
  return check_conflict (attr, name, where);
1147
}
1148
 
1149
 
1150
gfc_try
1151
gfc_add_target (symbol_attribute *attr, locus *where)
1152
{
1153
 
1154
  if (check_used (attr, NULL, where))
1155
    return FAILURE;
1156
 
1157
  if (attr->target)
1158
    {
1159
      duplicate_attr ("TARGET", where);
1160
      return FAILURE;
1161
    }
1162
 
1163
  attr->target = 1;
1164
  return check_conflict (attr, NULL, where);
1165
}
1166
 
1167
 
1168
gfc_try
1169
gfc_add_dummy (symbol_attribute *attr, const char *name, locus *where)
1170
{
1171
 
1172
  if (check_used (attr, name, where))
1173
    return FAILURE;
1174
 
1175
  /* Duplicate dummy arguments are allowed due to ENTRY statements.  */
1176
  attr->dummy = 1;
1177
  return check_conflict (attr, name, where);
1178
}
1179
 
1180
 
1181
gfc_try
1182
gfc_add_in_common (symbol_attribute *attr, const char *name, locus *where)
1183
{
1184
 
1185
  if (check_used (attr, name, where))
1186
    return FAILURE;
1187
 
1188
  /* Duplicate attribute already checked for.  */
1189
  attr->in_common = 1;
1190
  return check_conflict (attr, name, where);
1191
}
1192
 
1193
 
1194
gfc_try
1195
gfc_add_in_equivalence (symbol_attribute *attr, const char *name, locus *where)
1196
{
1197
 
1198
  /* Duplicate attribute already checked for.  */
1199
  attr->in_equivalence = 1;
1200
  if (check_conflict (attr, name, where) == FAILURE)
1201
    return FAILURE;
1202
 
1203
  if (attr->flavor == FL_VARIABLE)
1204
    return SUCCESS;
1205
 
1206
  return gfc_add_flavor (attr, FL_VARIABLE, name, where);
1207
}
1208
 
1209
 
1210
gfc_try
1211
gfc_add_data (symbol_attribute *attr, const char *name, locus *where)
1212
{
1213
 
1214
  if (check_used (attr, name, where))
1215
    return FAILURE;
1216
 
1217
  attr->data = 1;
1218
  return check_conflict (attr, name, where);
1219
}
1220
 
1221
 
1222
gfc_try
1223
gfc_add_in_namelist (symbol_attribute *attr, const char *name, locus *where)
1224
{
1225
 
1226
  attr->in_namelist = 1;
1227
  return check_conflict (attr, name, where);
1228
}
1229
 
1230
 
1231
gfc_try
1232
gfc_add_sequence (symbol_attribute *attr, const char *name, locus *where)
1233
{
1234
 
1235
  if (check_used (attr, name, where))
1236
    return FAILURE;
1237
 
1238
  attr->sequence = 1;
1239
  return check_conflict (attr, name, where);
1240
}
1241
 
1242
 
1243
gfc_try
1244
gfc_add_elemental (symbol_attribute *attr, locus *where)
1245
{
1246
 
1247
  if (check_used (attr, NULL, where))
1248
    return FAILURE;
1249
 
1250
  if (attr->elemental)
1251
    {
1252
      duplicate_attr ("ELEMENTAL", where);
1253
      return FAILURE;
1254
    }
1255
 
1256
  attr->elemental = 1;
1257
  return check_conflict (attr, NULL, where);
1258
}
1259
 
1260
 
1261
gfc_try
1262
gfc_add_pure (symbol_attribute *attr, locus *where)
1263
{
1264
 
1265
  if (check_used (attr, NULL, where))
1266
    return FAILURE;
1267
 
1268
  if (attr->pure)
1269
    {
1270
      duplicate_attr ("PURE", where);
1271
      return FAILURE;
1272
    }
1273
 
1274
  attr->pure = 1;
1275
  return check_conflict (attr, NULL, where);
1276
}
1277
 
1278
 
1279
gfc_try
1280
gfc_add_recursive (symbol_attribute *attr, locus *where)
1281
{
1282
 
1283
  if (check_used (attr, NULL, where))
1284
    return FAILURE;
1285
 
1286
  if (attr->recursive)
1287
    {
1288
      duplicate_attr ("RECURSIVE", where);
1289
      return FAILURE;
1290
    }
1291
 
1292
  attr->recursive = 1;
1293
  return check_conflict (attr, NULL, where);
1294
}
1295
 
1296
 
1297
gfc_try
1298
gfc_add_entry (symbol_attribute *attr, const char *name, locus *where)
1299
{
1300
 
1301
  if (check_used (attr, name, where))
1302
    return FAILURE;
1303
 
1304
  if (attr->entry)
1305
    {
1306
      duplicate_attr ("ENTRY", where);
1307
      return FAILURE;
1308
    }
1309
 
1310
  attr->entry = 1;
1311
  return check_conflict (attr, name, where);
1312
}
1313
 
1314
 
1315
gfc_try
1316
gfc_add_function (symbol_attribute *attr, const char *name, locus *where)
1317
{
1318
 
1319
  if (attr->flavor != FL_PROCEDURE
1320
      && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1321
    return FAILURE;
1322
 
1323
  attr->function = 1;
1324
  return check_conflict (attr, name, where);
1325
}
1326
 
1327
 
1328
gfc_try
1329
gfc_add_subroutine (symbol_attribute *attr, const char *name, locus *where)
1330
{
1331
 
1332
  if (attr->flavor != FL_PROCEDURE
1333
      && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1334
    return FAILURE;
1335
 
1336
  attr->subroutine = 1;
1337
  return check_conflict (attr, name, where);
1338
}
1339
 
1340
 
1341
gfc_try
1342
gfc_add_generic (symbol_attribute *attr, const char *name, locus *where)
1343
{
1344
 
1345
  if (attr->flavor != FL_PROCEDURE
1346
      && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1347
    return FAILURE;
1348
 
1349
  attr->generic = 1;
1350
  return check_conflict (attr, name, where);
1351
}
1352
 
1353
 
1354
gfc_try
1355
gfc_add_proc (symbol_attribute *attr, const char *name, locus *where)
1356
{
1357
 
1358
  if (check_used (attr, NULL, where))
1359
    return FAILURE;
1360
 
1361
  if (attr->flavor != FL_PROCEDURE
1362
      && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1363
    return FAILURE;
1364
 
1365
  if (attr->procedure)
1366
    {
1367
      duplicate_attr ("PROCEDURE", where);
1368
      return FAILURE;
1369
    }
1370
 
1371
  attr->procedure = 1;
1372
 
1373
  return check_conflict (attr, NULL, where);
1374
}
1375
 
1376
 
1377
gfc_try
1378
gfc_add_abstract (symbol_attribute* attr, locus* where)
1379
{
1380
  if (attr->abstract)
1381
    {
1382
      duplicate_attr ("ABSTRACT", where);
1383
      return FAILURE;
1384
    }
1385
 
1386
  attr->abstract = 1;
1387
  return SUCCESS;
1388
}
1389
 
1390
 
1391
/* Flavors are special because some flavors are not what Fortran
1392
   considers attributes and can be reaffirmed multiple times.  */
1393
 
1394
gfc_try
1395
gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name,
1396
                locus *where)
1397
{
1398
 
1399
  if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE
1400
       || f == FL_PARAMETER || f == FL_LABEL || f == FL_DERIVED
1401
       || f == FL_NAMELIST) && check_used (attr, name, where))
1402
    return FAILURE;
1403
 
1404
  if (attr->flavor == f && f == FL_VARIABLE)
1405
    return SUCCESS;
1406
 
1407
  if (attr->flavor != FL_UNKNOWN)
1408
    {
1409
      if (where == NULL)
1410
        where = &gfc_current_locus;
1411
 
1412
      if (name)
1413
        gfc_error ("%s attribute of '%s' conflicts with %s attribute at %L",
1414
                   gfc_code2string (flavors, attr->flavor), name,
1415
                   gfc_code2string (flavors, f), where);
1416
      else
1417
        gfc_error ("%s attribute conflicts with %s attribute at %L",
1418
                   gfc_code2string (flavors, attr->flavor),
1419
                   gfc_code2string (flavors, f), where);
1420
 
1421
      return FAILURE;
1422
    }
1423
 
1424
  attr->flavor = f;
1425
 
1426
  return check_conflict (attr, name, where);
1427
}
1428
 
1429
 
1430
gfc_try
1431
gfc_add_procedure (symbol_attribute *attr, procedure_type t,
1432
                   const char *name, locus *where)
1433
{
1434
 
1435
  if (check_used (attr, name, where))
1436
    return FAILURE;
1437
 
1438
  if (attr->flavor != FL_PROCEDURE
1439
      && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1440
    return FAILURE;
1441
 
1442
  if (where == NULL)
1443
    where = &gfc_current_locus;
1444
 
1445
  if (attr->proc != PROC_UNKNOWN)
1446
    {
1447
      gfc_error ("%s procedure at %L is already declared as %s procedure",
1448
                 gfc_code2string (procedures, t), where,
1449
                 gfc_code2string (procedures, attr->proc));
1450
 
1451
      return FAILURE;
1452
    }
1453
 
1454
  attr->proc = t;
1455
 
1456
  /* Statement functions are always scalar and functions.  */
1457
  if (t == PROC_ST_FUNCTION
1458
      && ((!attr->function && gfc_add_function (attr, name, where) == FAILURE)
1459
          || attr->dimension))
1460
    return FAILURE;
1461
 
1462
  return check_conflict (attr, name, where);
1463
}
1464
 
1465
 
1466
gfc_try
1467
gfc_add_intent (symbol_attribute *attr, sym_intent intent, locus *where)
1468
{
1469
 
1470
  if (check_used (attr, NULL, where))
1471
    return FAILURE;
1472
 
1473
  if (attr->intent == INTENT_UNKNOWN)
1474
    {
1475
      attr->intent = intent;
1476
      return check_conflict (attr, NULL, where);
1477
    }
1478
 
1479
  if (where == NULL)
1480
    where = &gfc_current_locus;
1481
 
1482
  gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1483
             gfc_intent_string (attr->intent),
1484
             gfc_intent_string (intent), where);
1485
 
1486
  return FAILURE;
1487
}
1488
 
1489
 
1490
/* No checks for use-association in public and private statements.  */
1491
 
1492
gfc_try
1493
gfc_add_access (symbol_attribute *attr, gfc_access access,
1494
                const char *name, locus *where)
1495
{
1496
 
1497
  if (attr->access == ACCESS_UNKNOWN
1498
        || (attr->use_assoc && attr->access != ACCESS_PRIVATE))
1499
    {
1500
      attr->access = access;
1501
      return check_conflict (attr, name, where);
1502
    }
1503
 
1504
  if (where == NULL)
1505
    where = &gfc_current_locus;
1506
  gfc_error ("ACCESS specification at %L was already specified", where);
1507
 
1508
  return FAILURE;
1509
}
1510
 
1511
 
1512
/* Set the is_bind_c field for the given symbol_attribute.  */
1513
 
1514
gfc_try
1515
gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where,
1516
                   int is_proc_lang_bind_spec)
1517
{
1518
 
1519
  if (is_proc_lang_bind_spec == 0 && attr->flavor == FL_PROCEDURE)
1520
    gfc_error_now ("BIND(C) attribute at %L can only be used for "
1521
                   "variables or common blocks", where);
1522
  else if (attr->is_bind_c)
1523
    gfc_error_now ("Duplicate BIND attribute specified at %L", where);
1524
  else
1525
    attr->is_bind_c = 1;
1526
 
1527
  if (where == NULL)
1528
    where = &gfc_current_locus;
1529
 
1530
  if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BIND(C) at %L", where)
1531
      == FAILURE)
1532
    return FAILURE;
1533
 
1534
  return check_conflict (attr, name, where);
1535
}
1536
 
1537
 
1538
/* Set the extension field for the given symbol_attribute.  */
1539
 
1540
gfc_try
1541
gfc_add_extension (symbol_attribute *attr, locus *where)
1542
{
1543
  if (where == NULL)
1544
    where = &gfc_current_locus;
1545
 
1546
  if (attr->extension)
1547
    gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where);
1548
  else
1549
    attr->extension = 1;
1550
 
1551
  if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: EXTENDS at %L", where)
1552
        == FAILURE)
1553
    return FAILURE;
1554
 
1555
  return SUCCESS;
1556
}
1557
 
1558
 
1559
gfc_try
1560
gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source,
1561
                            gfc_formal_arglist * formal, locus *where)
1562
{
1563
 
1564
  if (check_used (&sym->attr, sym->name, where))
1565
    return FAILURE;
1566
 
1567
  if (where == NULL)
1568
    where = &gfc_current_locus;
1569
 
1570
  if (sym->attr.if_source != IFSRC_UNKNOWN
1571
      && sym->attr.if_source != IFSRC_DECL)
1572
    {
1573
      gfc_error ("Symbol '%s' at %L already has an explicit interface",
1574
                 sym->name, where);
1575
      return FAILURE;
1576
    }
1577
 
1578
  if (source == IFSRC_IFBODY && (sym->attr.dimension || sym->attr.allocatable))
1579
    {
1580
      gfc_error ("'%s' at %L has attributes specified outside its INTERFACE "
1581
                 "body", sym->name, where);
1582
      return FAILURE;
1583
    }
1584
 
1585
  sym->formal = formal;
1586
  sym->attr.if_source = source;
1587
 
1588
  return SUCCESS;
1589
}
1590
 
1591
 
1592
/* Add a type to a symbol.  */
1593
 
1594
gfc_try
1595
gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where)
1596
{
1597
  sym_flavor flavor;
1598
  bt type;
1599
 
1600
  if (where == NULL)
1601
    where = &gfc_current_locus;
1602
 
1603
  if (sym->result)
1604
    type = sym->result->ts.type;
1605
  else
1606
    type = sym->ts.type;
1607
 
1608
  if (sym->attr.result && type == BT_UNKNOWN && sym->ns->proc_name)
1609
    type = sym->ns->proc_name->ts.type;
1610
 
1611
  if (type != BT_UNKNOWN && !(sym->attr.function && sym->attr.implicit_type))
1612
    {
1613
      gfc_error ("Symbol '%s' at %L already has basic type of %s", sym->name,
1614
                 where, gfc_basic_typename (type));
1615
      return FAILURE;
1616
    }
1617
 
1618
  if (sym->attr.procedure && sym->ts.interface)
1619
    {
1620
      gfc_error ("Procedure '%s' at %L may not have basic type of %s",
1621
                 sym->name, where, gfc_basic_typename (ts->type));
1622
      return FAILURE;
1623
    }
1624
 
1625
  flavor = sym->attr.flavor;
1626
 
1627
  if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE
1628
      || flavor == FL_LABEL
1629
      || (flavor == FL_PROCEDURE && sym->attr.subroutine)
1630
      || flavor == FL_DERIVED || flavor == FL_NAMELIST)
1631
    {
1632
      gfc_error ("Symbol '%s' at %L cannot have a type", sym->name, where);
1633
      return FAILURE;
1634
    }
1635
 
1636
  sym->ts = *ts;
1637
  return SUCCESS;
1638
}
1639
 
1640
 
1641
/* Clears all attributes.  */
1642
 
1643
void
1644
gfc_clear_attr (symbol_attribute *attr)
1645
{
1646
  memset (attr, 0, sizeof (symbol_attribute));
1647
}
1648
 
1649
 
1650
/* Check for missing attributes in the new symbol.  Currently does
1651
   nothing, but it's not clear that it is unnecessary yet.  */
1652
 
1653
gfc_try
1654
gfc_missing_attr (symbol_attribute *attr ATTRIBUTE_UNUSED,
1655
                  locus *where ATTRIBUTE_UNUSED)
1656
{
1657
 
1658
  return SUCCESS;
1659
}
1660
 
1661
 
1662
/* Copy an attribute to a symbol attribute, bit by bit.  Some
1663
   attributes have a lot of side-effects but cannot be present given
1664
   where we are called from, so we ignore some bits.  */
1665
 
1666
gfc_try
1667
gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
1668
{
1669
  int is_proc_lang_bind_spec;
1670
 
1671
  /* In line with the other attributes, we only add bits but do not remove
1672
     them; cf. also PR 41034.  */
1673
  dest->ext_attr |= src->ext_attr;
1674
 
1675
  if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE)
1676
    goto fail;
1677
 
1678
  if (src->dimension && gfc_add_dimension (dest, NULL, where) == FAILURE)
1679
    goto fail;
1680
  if (src->optional && gfc_add_optional (dest, where) == FAILURE)
1681
    goto fail;
1682
  if (src->pointer && gfc_add_pointer (dest, where) == FAILURE)
1683
    goto fail;
1684
  if (src->is_protected && gfc_add_protected (dest, NULL, where) == FAILURE)
1685
    goto fail;
1686
  if (src->save && gfc_add_save (dest, NULL, where) == FAILURE)
1687
    goto fail;
1688
  if (src->value && gfc_add_value (dest, NULL, where) == FAILURE)
1689
    goto fail;
1690
  if (src->volatile_ && gfc_add_volatile (dest, NULL, where) == FAILURE)
1691
    goto fail;
1692
  if (src->asynchronous && gfc_add_asynchronous (dest, NULL, where) == FAILURE)
1693
    goto fail;
1694
  if (src->threadprivate
1695
      && gfc_add_threadprivate (dest, NULL, where) == FAILURE)
1696
    goto fail;
1697
  if (src->target && gfc_add_target (dest, where) == FAILURE)
1698
    goto fail;
1699
  if (src->dummy && gfc_add_dummy (dest, NULL, where) == FAILURE)
1700
    goto fail;
1701
  if (src->result && gfc_add_result (dest, NULL, where) == FAILURE)
1702
    goto fail;
1703
  if (src->entry)
1704
    dest->entry = 1;
1705
 
1706
  if (src->in_namelist && gfc_add_in_namelist (dest, NULL, where) == FAILURE)
1707
    goto fail;
1708
 
1709
  if (src->in_common && gfc_add_in_common (dest, NULL, where) == FAILURE)
1710
    goto fail;
1711
 
1712
  if (src->generic && gfc_add_generic (dest, NULL, where) == FAILURE)
1713
    goto fail;
1714
  if (src->function && gfc_add_function (dest, NULL, where) == FAILURE)
1715
    goto fail;
1716
  if (src->subroutine && gfc_add_subroutine (dest, NULL, where) == FAILURE)
1717
    goto fail;
1718
 
1719
  if (src->sequence && gfc_add_sequence (dest, NULL, where) == FAILURE)
1720
    goto fail;
1721
  if (src->elemental && gfc_add_elemental (dest, where) == FAILURE)
1722
    goto fail;
1723
  if (src->pure && gfc_add_pure (dest, where) == FAILURE)
1724
    goto fail;
1725
  if (src->recursive && gfc_add_recursive (dest, where) == FAILURE)
1726
    goto fail;
1727
 
1728
  if (src->flavor != FL_UNKNOWN
1729
      && gfc_add_flavor (dest, src->flavor, NULL, where) == FAILURE)
1730
    goto fail;
1731
 
1732
  if (src->intent != INTENT_UNKNOWN
1733
      && gfc_add_intent (dest, src->intent, where) == FAILURE)
1734
    goto fail;
1735
 
1736
  if (src->access != ACCESS_UNKNOWN
1737
      && gfc_add_access (dest, src->access, NULL, where) == FAILURE)
1738
    goto fail;
1739
 
1740
  if (gfc_missing_attr (dest, where) == FAILURE)
1741
    goto fail;
1742
 
1743
  if (src->cray_pointer && gfc_add_cray_pointer (dest, where) == FAILURE)
1744
    goto fail;
1745
  if (src->cray_pointee && gfc_add_cray_pointee (dest, where) == FAILURE)
1746
    goto fail;
1747
 
1748
  is_proc_lang_bind_spec = (src->flavor == FL_PROCEDURE ? 1 : 0);
1749
  if (src->is_bind_c
1750
      && gfc_add_is_bind_c (dest, NULL, where, is_proc_lang_bind_spec)
1751
         != SUCCESS)
1752
    return FAILURE;
1753
 
1754
  if (src->is_c_interop)
1755
    dest->is_c_interop = 1;
1756
  if (src->is_iso_c)
1757
    dest->is_iso_c = 1;
1758
 
1759
  if (src->external && gfc_add_external (dest, where) == FAILURE)
1760
    goto fail;
1761
  if (src->intrinsic && gfc_add_intrinsic (dest, where) == FAILURE)
1762
    goto fail;
1763
  if (src->proc_pointer)
1764
    dest->proc_pointer = 1;
1765
 
1766
  return SUCCESS;
1767
 
1768
fail:
1769
  return FAILURE;
1770
}
1771
 
1772
 
1773
/************** Component name management ************/
1774
 
1775
/* Component names of a derived type form their own little namespaces
1776
   that are separate from all other spaces.  The space is composed of
1777
   a singly linked list of gfc_component structures whose head is
1778
   located in the parent symbol.  */
1779
 
1780
 
1781
/* Add a component name to a symbol.  The call fails if the name is
1782
   already present.  On success, the component pointer is modified to
1783
   point to the additional component structure.  */
1784
 
1785
gfc_try
1786
gfc_add_component (gfc_symbol *sym, const char *name,
1787
                   gfc_component **component)
1788
{
1789
  gfc_component *p, *tail;
1790
 
1791
  tail = NULL;
1792
 
1793
  for (p = sym->components; p; p = p->next)
1794
    {
1795
      if (strcmp (p->name, name) == 0)
1796
        {
1797
          gfc_error ("Component '%s' at %C already declared at %L",
1798
                     name, &p->loc);
1799
          return FAILURE;
1800
        }
1801
 
1802
      tail = p;
1803
    }
1804
 
1805
  if (sym->attr.extension
1806
        && gfc_find_component (sym->components->ts.u.derived, name, true, true))
1807
    {
1808
      gfc_error ("Component '%s' at %C already in the parent type "
1809
                 "at %L", name, &sym->components->ts.u.derived->declared_at);
1810
      return FAILURE;
1811
    }
1812
 
1813
  /* Allocate a new component.  */
1814
  p = gfc_get_component ();
1815
 
1816
  if (tail == NULL)
1817
    sym->components = p;
1818
  else
1819
    tail->next = p;
1820
 
1821
  p->name = gfc_get_string (name);
1822
  p->loc = gfc_current_locus;
1823
  p->ts.type = BT_UNKNOWN;
1824
 
1825
  *component = p;
1826
  return SUCCESS;
1827
}
1828
 
1829
 
1830
/* Recursive function to switch derived types of all symbol in a
1831
   namespace.  */
1832
 
1833
static void
1834
switch_types (gfc_symtree *st, gfc_symbol *from, gfc_symbol *to)
1835
{
1836
  gfc_symbol *sym;
1837
 
1838
  if (st == NULL)
1839
    return;
1840
 
1841
  sym = st->n.sym;
1842
  if (sym->ts.type == BT_DERIVED && sym->ts.u.derived == from)
1843
    sym->ts.u.derived = to;
1844
 
1845
  switch_types (st->left, from, to);
1846
  switch_types (st->right, from, to);
1847
}
1848
 
1849
 
1850
/* This subroutine is called when a derived type is used in order to
1851
   make the final determination about which version to use.  The
1852
   standard requires that a type be defined before it is 'used', but
1853
   such types can appear in IMPLICIT statements before the actual
1854
   definition.  'Using' in this context means declaring a variable to
1855
   be that type or using the type constructor.
1856
 
1857
   If a type is used and the components haven't been defined, then we
1858
   have to have a derived type in a parent unit.  We find the node in
1859
   the other namespace and point the symtree node in this namespace to
1860
   that node.  Further reference to this name point to the correct
1861
   node.  If we can't find the node in a parent namespace, then we have
1862
   an error.
1863
 
1864
   This subroutine takes a pointer to a symbol node and returns a
1865
   pointer to the translated node or NULL for an error.  Usually there
1866
   is no translation and we return the node we were passed.  */
1867
 
1868
gfc_symbol *
1869
gfc_use_derived (gfc_symbol *sym)
1870
{
1871
  gfc_symbol *s;
1872
  gfc_typespec *t;
1873
  gfc_symtree *st;
1874
  int i;
1875
 
1876
  if (sym->components != NULL || sym->attr.zero_comp)
1877
    return sym;               /* Already defined.  */
1878
 
1879
  if (sym->ns->parent == NULL)
1880
    goto bad;
1881
 
1882
  if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
1883
    {
1884
      gfc_error ("Symbol '%s' at %C is ambiguous", sym->name);
1885
      return NULL;
1886
    }
1887
 
1888
  if (s == NULL || s->attr.flavor != FL_DERIVED)
1889
    goto bad;
1890
 
1891
  /* Get rid of symbol sym, translating all references to s.  */
1892
  for (i = 0; i < GFC_LETTERS; i++)
1893
    {
1894
      t = &sym->ns->default_type[i];
1895
      if (t->u.derived == sym)
1896
        t->u.derived = s;
1897
    }
1898
 
1899
  st = gfc_find_symtree (sym->ns->sym_root, sym->name);
1900
  st->n.sym = s;
1901
 
1902
  s->refs++;
1903
 
1904
  /* Unlink from list of modified symbols.  */
1905
  gfc_commit_symbol (sym);
1906
 
1907
  switch_types (sym->ns->sym_root, sym, s);
1908
 
1909
  /* TODO: Also have to replace sym -> s in other lists like
1910
     namelists, common lists and interface lists.  */
1911
  gfc_free_symbol (sym);
1912
 
1913
  return s;
1914
 
1915
bad:
1916
  gfc_error ("Derived type '%s' at %C is being used before it is defined",
1917
             sym->name);
1918
  return NULL;
1919
}
1920
 
1921
 
1922
/* Given a derived type node and a component name, try to locate the
1923
   component structure.  Returns the NULL pointer if the component is
1924
   not found or the components are private.  If noaccess is set, no access
1925
   checks are done.  */
1926
 
1927
gfc_component *
1928
gfc_find_component (gfc_symbol *sym, const char *name,
1929
                    bool noaccess, bool silent)
1930
{
1931
  gfc_component *p;
1932
 
1933
  if (name == NULL)
1934
    return NULL;
1935
 
1936
  sym = gfc_use_derived (sym);
1937
 
1938
  if (sym == NULL)
1939
    return NULL;
1940
 
1941
  for (p = sym->components; p; p = p->next)
1942
    if (strcmp (p->name, name) == 0)
1943
      break;
1944
 
1945
  if (p == NULL
1946
        && sym->attr.extension
1947
        && sym->components->ts.type == BT_DERIVED)
1948
    {
1949
      p = gfc_find_component (sym->components->ts.u.derived, name,
1950
                              noaccess, silent);
1951
      /* Do not overwrite the error.  */
1952
      if (p == NULL)
1953
        return p;
1954
    }
1955
 
1956
  if (p == NULL && !silent)
1957
    gfc_error ("'%s' at %C is not a member of the '%s' structure",
1958
               name, sym->name);
1959
 
1960
  else if (sym->attr.use_assoc && !noaccess)
1961
    {
1962
      bool is_parent_comp = sym->attr.extension && (p == sym->components);
1963
      if (p->attr.access == ACCESS_PRIVATE ||
1964
          (p->attr.access != ACCESS_PUBLIC
1965
           && sym->component_access == ACCESS_PRIVATE
1966
           && !is_parent_comp))
1967
        {
1968
          if (!silent)
1969
            gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1970
                       name, sym->name);
1971
          return NULL;
1972
        }
1973
    }
1974
 
1975
  return p;
1976
}
1977
 
1978
 
1979
/* Given a symbol, free all of the component structures and everything
1980
   they point to.  */
1981
 
1982
static void
1983
free_components (gfc_component *p)
1984
{
1985
  gfc_component *q;
1986
 
1987
  for (; p; p = q)
1988
    {
1989
      q = p->next;
1990
 
1991
      gfc_free_array_spec (p->as);
1992
      gfc_free_expr (p->initializer);
1993
 
1994
      gfc_free (p);
1995
    }
1996
}
1997
 
1998
 
1999
/******************** Statement label management ********************/
2000
 
2001
/* Comparison function for statement labels, used for managing the
2002
   binary tree.  */
2003
 
2004
static int
2005
compare_st_labels (void *a1, void *b1)
2006
{
2007
  int a = ((gfc_st_label *) a1)->value;
2008
  int b = ((gfc_st_label *) b1)->value;
2009
 
2010
  return (b - a);
2011
}
2012
 
2013
 
2014
/* Free a single gfc_st_label structure, making sure the tree is not
2015
   messed up.  This function is called only when some parse error
2016
   occurs.  */
2017
 
2018
void
2019
gfc_free_st_label (gfc_st_label *label)
2020
{
2021
 
2022
  if (label == NULL)
2023
    return;
2024
 
2025
  gfc_delete_bbt (&gfc_current_ns->st_labels, label, compare_st_labels);
2026
 
2027
  if (label->format != NULL)
2028
    gfc_free_expr (label->format);
2029
 
2030
  gfc_free (label);
2031
}
2032
 
2033
 
2034
/* Free a whole tree of gfc_st_label structures.  */
2035
 
2036
static void
2037
free_st_labels (gfc_st_label *label)
2038
{
2039
 
2040
  if (label == NULL)
2041
    return;
2042
 
2043
  free_st_labels (label->left);
2044
  free_st_labels (label->right);
2045
 
2046
  if (label->format != NULL)
2047
    gfc_free_expr (label->format);
2048
  gfc_free (label);
2049
}
2050
 
2051
 
2052
/* Given a label number, search for and return a pointer to the label
2053
   structure, creating it if it does not exist.  */
2054
 
2055
gfc_st_label *
2056
gfc_get_st_label (int labelno)
2057
{
2058
  gfc_st_label *lp;
2059
  gfc_namespace *ns;
2060
 
2061
  /* Find the namespace of the scoping unit:
2062
     If we're in a BLOCK construct, jump to the parent namespace.  */
2063
  ns = gfc_current_ns;
2064
  while (ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL)
2065
    ns = ns->parent;
2066
 
2067
  /* First see if the label is already in this namespace.  */
2068
  lp = ns->st_labels;
2069
  while (lp)
2070
    {
2071
      if (lp->value == labelno)
2072
        return lp;
2073
 
2074
      if (lp->value < labelno)
2075
        lp = lp->left;
2076
      else
2077
        lp = lp->right;
2078
    }
2079
 
2080
  lp = XCNEW (gfc_st_label);
2081
 
2082
  lp->value = labelno;
2083
  lp->defined = ST_LABEL_UNKNOWN;
2084
  lp->referenced = ST_LABEL_UNKNOWN;
2085
 
2086
  gfc_insert_bbt (&ns->st_labels, lp, compare_st_labels);
2087
 
2088
  return lp;
2089
}
2090
 
2091
 
2092
/* Called when a statement with a statement label is about to be
2093
   accepted.  We add the label to the list of the current namespace,
2094
   making sure it hasn't been defined previously and referenced
2095
   correctly.  */
2096
 
2097
void
2098
gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus)
2099
{
2100
  int labelno;
2101
 
2102
  labelno = lp->value;
2103
 
2104
  if (lp->defined != ST_LABEL_UNKNOWN)
2105
    gfc_error ("Duplicate statement label %d at %L and %L", labelno,
2106
               &lp->where, label_locus);
2107
  else
2108
    {
2109
      lp->where = *label_locus;
2110
 
2111
      switch (type)
2112
        {
2113
        case ST_LABEL_FORMAT:
2114
          if (lp->referenced == ST_LABEL_TARGET)
2115
            gfc_error ("Label %d at %C already referenced as branch target",
2116
                       labelno);
2117
          else
2118
            lp->defined = ST_LABEL_FORMAT;
2119
 
2120
          break;
2121
 
2122
        case ST_LABEL_TARGET:
2123
          if (lp->referenced == ST_LABEL_FORMAT)
2124
            gfc_error ("Label %d at %C already referenced as a format label",
2125
                       labelno);
2126
          else
2127
            lp->defined = ST_LABEL_TARGET;
2128
 
2129
          break;
2130
 
2131
        default:
2132
          lp->defined = ST_LABEL_BAD_TARGET;
2133
          lp->referenced = ST_LABEL_BAD_TARGET;
2134
        }
2135
    }
2136
}
2137
 
2138
 
2139
/* Reference a label.  Given a label and its type, see if that
2140
   reference is consistent with what is known about that label,
2141
   updating the unknown state.  Returns FAILURE if something goes
2142
   wrong.  */
2143
 
2144
gfc_try
2145
gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type)
2146
{
2147
  gfc_sl_type label_type;
2148
  int labelno;
2149
  gfc_try rc;
2150
 
2151
  if (lp == NULL)
2152
    return SUCCESS;
2153
 
2154
  labelno = lp->value;
2155
 
2156
  if (lp->defined != ST_LABEL_UNKNOWN)
2157
    label_type = lp->defined;
2158
  else
2159
    {
2160
      label_type = lp->referenced;
2161
      lp->where = gfc_current_locus;
2162
    }
2163
 
2164
  if (label_type == ST_LABEL_FORMAT && type == ST_LABEL_TARGET)
2165
    {
2166
      gfc_error ("Label %d at %C previously used as a FORMAT label", labelno);
2167
      rc = FAILURE;
2168
      goto done;
2169
    }
2170
 
2171
  if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_BAD_TARGET)
2172
      && type == ST_LABEL_FORMAT)
2173
    {
2174
      gfc_error ("Label %d at %C previously used as branch target", labelno);
2175
      rc = FAILURE;
2176
      goto done;
2177
    }
2178
 
2179
  lp->referenced = type;
2180
  rc = SUCCESS;
2181
 
2182
done:
2183
  return rc;
2184
}
2185
 
2186
 
2187
/*******A helper function for creating new expressions*************/
2188
 
2189
 
2190
gfc_expr *
2191
gfc_lval_expr_from_sym (gfc_symbol *sym)
2192
{
2193
  gfc_expr *lval;
2194
  lval = gfc_get_expr ();
2195
  lval->expr_type = EXPR_VARIABLE;
2196
  lval->where = sym->declared_at;
2197
  lval->ts = sym->ts;
2198
  lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
2199
 
2200
  /* It will always be a full array.  */
2201
  lval->rank = sym->as ? sym->as->rank : 0;
2202
  if (lval->rank)
2203
    {
2204
      lval->ref = gfc_get_ref ();
2205
      lval->ref->type = REF_ARRAY;
2206
      lval->ref->u.ar.type = AR_FULL;
2207
      lval->ref->u.ar.dimen = lval->rank;
2208
      lval->ref->u.ar.where = sym->declared_at;
2209
      lval->ref->u.ar.as = sym->as;
2210
    }
2211
 
2212
  return lval;
2213
}
2214
 
2215
 
2216
/************** Symbol table management subroutines ****************/
2217
 
2218
/* Basic details: Fortran 95 requires a potentially unlimited number
2219
   of distinct namespaces when compiling a program unit.  This case
2220
   occurs during a compilation of internal subprograms because all of
2221
   the internal subprograms must be read before we can start
2222
   generating code for the host.
2223
 
2224
   Given the tricky nature of the Fortran grammar, we must be able to
2225
   undo changes made to a symbol table if the current interpretation
2226
   of a statement is found to be incorrect.  Whenever a symbol is
2227
   looked up, we make a copy of it and link to it.  All of these
2228
   symbols are kept in a singly linked list so that we can commit or
2229
   undo the changes at a later time.
2230
 
2231
   A symtree may point to a symbol node outside of its namespace.  In
2232
   this case, that symbol has been used as a host associated variable
2233
   at some previous time.  */
2234
 
2235
/* Allocate a new namespace structure.  Copies the implicit types from
2236
   PARENT if PARENT_TYPES is set.  */
2237
 
2238
gfc_namespace *
2239
gfc_get_namespace (gfc_namespace *parent, int parent_types)
2240
{
2241
  gfc_namespace *ns;
2242
  gfc_typespec *ts;
2243
  int in;
2244
  int i;
2245
 
2246
  ns = XCNEW (gfc_namespace);
2247
  ns->sym_root = NULL;
2248
  ns->uop_root = NULL;
2249
  ns->tb_sym_root = NULL;
2250
  ns->finalizers = NULL;
2251
  ns->default_access = ACCESS_UNKNOWN;
2252
  ns->parent = parent;
2253
 
2254
  for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
2255
    {
2256
      ns->operator_access[in] = ACCESS_UNKNOWN;
2257
      ns->tb_op[in] = NULL;
2258
    }
2259
 
2260
  /* Initialize default implicit types.  */
2261
  for (i = 'a'; i <= 'z'; i++)
2262
    {
2263
      ns->set_flag[i - 'a'] = 0;
2264
      ts = &ns->default_type[i - 'a'];
2265
 
2266
      if (parent_types && ns->parent != NULL)
2267
        {
2268
          /* Copy parent settings.  */
2269
          *ts = ns->parent->default_type[i - 'a'];
2270
          continue;
2271
        }
2272
 
2273
      if (gfc_option.flag_implicit_none != 0)
2274
        {
2275
          gfc_clear_ts (ts);
2276
          continue;
2277
        }
2278
 
2279
      if ('i' <= i && i <= 'n')
2280
        {
2281
          ts->type = BT_INTEGER;
2282
          ts->kind = gfc_default_integer_kind;
2283
        }
2284
      else
2285
        {
2286
          ts->type = BT_REAL;
2287
          ts->kind = gfc_default_real_kind;
2288
        }
2289
    }
2290
 
2291
  ns->refs = 1;
2292
 
2293
  return ns;
2294
}
2295
 
2296
 
2297
/* Comparison function for symtree nodes.  */
2298
 
2299
static int
2300
compare_symtree (void *_st1, void *_st2)
2301
{
2302
  gfc_symtree *st1, *st2;
2303
 
2304
  st1 = (gfc_symtree *) _st1;
2305
  st2 = (gfc_symtree *) _st2;
2306
 
2307
  return strcmp (st1->name, st2->name);
2308
}
2309
 
2310
 
2311
/* Allocate a new symtree node and associate it with the new symbol.  */
2312
 
2313
gfc_symtree *
2314
gfc_new_symtree (gfc_symtree **root, const char *name)
2315
{
2316
  gfc_symtree *st;
2317
 
2318
  st = XCNEW (gfc_symtree);
2319
  st->name = gfc_get_string (name);
2320
 
2321
  gfc_insert_bbt (root, st, compare_symtree);
2322
  return st;
2323
}
2324
 
2325
 
2326
/* Delete a symbol from the tree.  Does not free the symbol itself!  */
2327
 
2328
void
2329
gfc_delete_symtree (gfc_symtree **root, const char *name)
2330
{
2331
  gfc_symtree st, *st0;
2332
 
2333
  st0 = gfc_find_symtree (*root, name);
2334
 
2335
  st.name = gfc_get_string (name);
2336
  gfc_delete_bbt (root, &st, compare_symtree);
2337
 
2338
  gfc_free (st0);
2339
}
2340
 
2341
 
2342
/* Given a root symtree node and a name, try to find the symbol within
2343
   the namespace.  Returns NULL if the symbol is not found.  */
2344
 
2345
gfc_symtree *
2346
gfc_find_symtree (gfc_symtree *st, const char *name)
2347
{
2348
  int c;
2349
 
2350
  while (st != NULL)
2351
    {
2352
      c = strcmp (name, st->name);
2353
      if (c == 0)
2354
        return st;
2355
 
2356
      st = (c < 0) ? st->left : st->right;
2357
    }
2358
 
2359
  return NULL;
2360
}
2361
 
2362
 
2363
/* Return a symtree node with a name that is guaranteed to be unique
2364
   within the namespace and corresponds to an illegal fortran name.  */
2365
 
2366
gfc_symtree *
2367
gfc_get_unique_symtree (gfc_namespace *ns)
2368
{
2369
  char name[GFC_MAX_SYMBOL_LEN + 1];
2370
  static int serial = 0;
2371
 
2372
  sprintf (name, "@%d", serial++);
2373
  return gfc_new_symtree (&ns->sym_root, name);
2374
}
2375
 
2376
 
2377
/* Given a name find a user operator node, creating it if it doesn't
2378
   exist.  These are much simpler than symbols because they can't be
2379
   ambiguous with one another.  */
2380
 
2381
gfc_user_op *
2382
gfc_get_uop (const char *name)
2383
{
2384
  gfc_user_op *uop;
2385
  gfc_symtree *st;
2386
 
2387
  st = gfc_find_symtree (gfc_current_ns->uop_root, name);
2388
  if (st != NULL)
2389
    return st->n.uop;
2390
 
2391
  st = gfc_new_symtree (&gfc_current_ns->uop_root, name);
2392
 
2393
  uop = st->n.uop = XCNEW (gfc_user_op);
2394
  uop->name = gfc_get_string (name);
2395
  uop->access = ACCESS_UNKNOWN;
2396
  uop->ns = gfc_current_ns;
2397
 
2398
  return uop;
2399
}
2400
 
2401
 
2402
/* Given a name find the user operator node.  Returns NULL if it does
2403
   not exist.  */
2404
 
2405
gfc_user_op *
2406
gfc_find_uop (const char *name, gfc_namespace *ns)
2407
{
2408
  gfc_symtree *st;
2409
 
2410
  if (ns == NULL)
2411
    ns = gfc_current_ns;
2412
 
2413
  st = gfc_find_symtree (ns->uop_root, name);
2414
  return (st == NULL) ? NULL : st->n.uop;
2415
}
2416
 
2417
 
2418
/* Remove a gfc_symbol structure and everything it points to.  */
2419
 
2420
void
2421
gfc_free_symbol (gfc_symbol *sym)
2422
{
2423
 
2424
  if (sym == NULL)
2425
    return;
2426
 
2427
  gfc_free_array_spec (sym->as);
2428
 
2429
  free_components (sym->components);
2430
 
2431
  gfc_free_expr (sym->value);
2432
 
2433
  gfc_free_namelist (sym->namelist);
2434
 
2435
  gfc_free_namespace (sym->formal_ns);
2436
 
2437
  if (!sym->attr.generic_copy)
2438
    gfc_free_interface (sym->generic);
2439
 
2440
  gfc_free_formal_arglist (sym->formal);
2441
 
2442
  gfc_free_namespace (sym->f2k_derived);
2443
 
2444
  gfc_free (sym);
2445
}
2446
 
2447
 
2448
/* Allocate and initialize a new symbol node.  */
2449
 
2450
gfc_symbol *
2451
gfc_new_symbol (const char *name, gfc_namespace *ns)
2452
{
2453
  gfc_symbol *p;
2454
 
2455
  p = XCNEW (gfc_symbol);
2456
 
2457
  gfc_clear_ts (&p->ts);
2458
  gfc_clear_attr (&p->attr);
2459
  p->ns = ns;
2460
 
2461
  p->declared_at = gfc_current_locus;
2462
 
2463
  if (strlen (name) > GFC_MAX_SYMBOL_LEN)
2464
    gfc_internal_error ("new_symbol(): Symbol name too long");
2465
 
2466
  p->name = gfc_get_string (name);
2467
 
2468
  /* Make sure flags for symbol being C bound are clear initially.  */
2469
  p->attr.is_bind_c = 0;
2470
  p->attr.is_iso_c = 0;
2471
  /* Make sure the binding label field has a Nul char to start.  */
2472
  p->binding_label[0] = '\0';
2473
 
2474
  /* Clear the ptrs we may need.  */
2475
  p->common_block = NULL;
2476
  p->f2k_derived = NULL;
2477
 
2478
  return p;
2479
}
2480
 
2481
 
2482
/* Generate an error if a symbol is ambiguous.  */
2483
 
2484
static void
2485
ambiguous_symbol (const char *name, gfc_symtree *st)
2486
{
2487
 
2488
  if (st->n.sym->module)
2489
    gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2490
               "from module '%s'", name, st->n.sym->name, st->n.sym->module);
2491
  else
2492
    gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2493
               "from current program unit", name, st->n.sym->name);
2494
}
2495
 
2496
 
2497
/* If we're in a SELECT TYPE block, check if the variable 'st' matches any
2498
   selector on the stack. If yes, replace it by the corresponding temporary.  */
2499
 
2500
static void
2501
select_type_insert_tmp (gfc_symtree **st)
2502
{
2503
  gfc_select_type_stack *stack = select_type_stack;
2504
  for (; stack; stack = stack->prev)
2505
    if ((*st)->n.sym == stack->selector && stack->tmp)
2506
      *st = stack->tmp;
2507
}
2508
 
2509
 
2510
/* Search for a symtree starting in the current namespace, resorting to
2511
   any parent namespaces if requested by a nonzero parent_flag.
2512
   Returns nonzero if the name is ambiguous.  */
2513
 
2514
int
2515
gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag,
2516
                   gfc_symtree **result)
2517
{
2518
  gfc_symtree *st;
2519
 
2520
  if (ns == NULL)
2521
    ns = gfc_current_ns;
2522
 
2523
  do
2524
    {
2525
      st = gfc_find_symtree (ns->sym_root, name);
2526
      if (st != NULL)
2527
        {
2528
          select_type_insert_tmp (&st);
2529
 
2530
          *result = st;
2531
          /* Ambiguous generic interfaces are permitted, as long
2532
             as the specific interfaces are different.  */
2533
          if (st->ambiguous && !st->n.sym->attr.generic)
2534
            {
2535
              ambiguous_symbol (name, st);
2536
              return 1;
2537
            }
2538
 
2539
          return 0;
2540
        }
2541
 
2542
      if (!parent_flag)
2543
        break;
2544
 
2545
      ns = ns->parent;
2546
    }
2547
  while (ns != NULL);
2548
 
2549
  *result = NULL;
2550
  return 0;
2551
}
2552
 
2553
 
2554
/* Same, but returns the symbol instead.  */
2555
 
2556
int
2557
gfc_find_symbol (const char *name, gfc_namespace *ns, int parent_flag,
2558
                 gfc_symbol **result)
2559
{
2560
  gfc_symtree *st;
2561
  int i;
2562
 
2563
  i = gfc_find_sym_tree (name, ns, parent_flag, &st);
2564
 
2565
  if (st == NULL)
2566
    *result = NULL;
2567
  else
2568
    *result = st->n.sym;
2569
 
2570
  return i;
2571
}
2572
 
2573
 
2574
/* Save symbol with the information necessary to back it out.  */
2575
 
2576
static void
2577
save_symbol_data (gfc_symbol *sym)
2578
{
2579
 
2580
  if (sym->gfc_new || sym->old_symbol != NULL)
2581
    return;
2582
 
2583
  sym->old_symbol = XCNEW (gfc_symbol);
2584
  *(sym->old_symbol) = *sym;
2585
 
2586
  sym->tlink = changed_syms;
2587
  changed_syms = sym;
2588
}
2589
 
2590
 
2591
/* Given a name, find a symbol, or create it if it does not exist yet
2592
   in the current namespace.  If the symbol is found we make sure that
2593
   it's OK.
2594
 
2595
   The integer return code indicates
2596
 
2597
     1   The symbol name was ambiguous
2598
     2   The name meant to be established was already host associated.
2599
 
2600
   So if the return value is nonzero, then an error was issued.  */
2601
 
2602
int
2603
gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result,
2604
                  bool allow_subroutine)
2605
{
2606
  gfc_symtree *st;
2607
  gfc_symbol *p;
2608
 
2609
  /* This doesn't usually happen during resolution.  */
2610
  if (ns == NULL)
2611
    ns = gfc_current_ns;
2612
 
2613
  /* Try to find the symbol in ns.  */
2614
  st = gfc_find_symtree (ns->sym_root, name);
2615
 
2616
  if (st == NULL)
2617
    {
2618
      /* If not there, create a new symbol.  */
2619
      p = gfc_new_symbol (name, ns);
2620
 
2621
      /* Add to the list of tentative symbols.  */
2622
      p->old_symbol = NULL;
2623
      p->tlink = changed_syms;
2624
      p->mark = 1;
2625
      p->gfc_new = 1;
2626
      changed_syms = p;
2627
 
2628
      st = gfc_new_symtree (&ns->sym_root, name);
2629
      st->n.sym = p;
2630
      p->refs++;
2631
 
2632
    }
2633
  else
2634
    {
2635
      /* Make sure the existing symbol is OK.  Ambiguous
2636
         generic interfaces are permitted, as long as the
2637
         specific interfaces are different.  */
2638
      if (st->ambiguous && !st->n.sym->attr.generic)
2639
        {
2640
          ambiguous_symbol (name, st);
2641
          return 1;
2642
        }
2643
 
2644
      p = st->n.sym;
2645
      if (p->ns != ns && (!p->attr.function || ns->proc_name != p)
2646
          && !(allow_subroutine && p->attr.subroutine)
2647
          && !(ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY
2648
          && (ns->has_import_set || p->attr.imported)))
2649
        {
2650
          /* Symbol is from another namespace.  */
2651
          gfc_error ("Symbol '%s' at %C has already been host associated",
2652
                     name);
2653
          return 2;
2654
        }
2655
 
2656
      p->mark = 1;
2657
 
2658
      /* Copy in case this symbol is changed.  */
2659
      save_symbol_data (p);
2660
    }
2661
 
2662
  *result = st;
2663
  return 0;
2664
}
2665
 
2666
 
2667
int
2668
gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result)
2669
{
2670
  gfc_symtree *st;
2671
  int i;
2672
 
2673
  i = gfc_get_sym_tree (name, ns, &st, false);
2674
  if (i != 0)
2675
    return i;
2676
 
2677
  if (st)
2678
    *result = st->n.sym;
2679
  else
2680
    *result = NULL;
2681
  return i;
2682
}
2683
 
2684
 
2685
/* Subroutine that searches for a symbol, creating it if it doesn't
2686
   exist, but tries to host-associate the symbol if possible.  */
2687
 
2688
int
2689
gfc_get_ha_sym_tree (const char *name, gfc_symtree **result)
2690
{
2691
  gfc_symtree *st;
2692
  int i;
2693
 
2694
  i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
2695
 
2696
  if (st != NULL)
2697
    {
2698
      save_symbol_data (st->n.sym);
2699
      *result = st;
2700
      return i;
2701
    }
2702
 
2703
  if (gfc_current_ns->parent != NULL)
2704
    {
2705
      i = gfc_find_sym_tree (name, gfc_current_ns->parent, 1, &st);
2706
      if (i)
2707
        return i;
2708
 
2709
      if (st != NULL)
2710
        {
2711
          *result = st;
2712
          return 0;
2713
        }
2714
    }
2715
 
2716
  return gfc_get_sym_tree (name, gfc_current_ns, result, false);
2717
}
2718
 
2719
 
2720
int
2721
gfc_get_ha_symbol (const char *name, gfc_symbol **result)
2722
{
2723
  int i;
2724
  gfc_symtree *st;
2725
 
2726
  i = gfc_get_ha_sym_tree (name, &st);
2727
 
2728
  if (st)
2729
    *result = st->n.sym;
2730
  else
2731
    *result = NULL;
2732
 
2733
  return i;
2734
}
2735
 
2736
/* Return true if both symbols could refer to the same data object.  Does
2737
   not take account of aliasing due to equivalence statements.  */
2738
 
2739
int
2740
gfc_symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym)
2741
{
2742
  /* Aliasing isn't possible if the symbols have different base types.  */
2743
  if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
2744
    return 0;
2745
 
2746
  /* Pointers can point to other pointers, target objects and allocatable
2747
     objects.  Two allocatable objects cannot share the same storage.  */
2748
  if (lsym->attr.pointer
2749
      && (rsym->attr.pointer || rsym->attr.allocatable || rsym->attr.target))
2750
    return 1;
2751
  if (lsym->attr.target && rsym->attr.pointer)
2752
    return 1;
2753
  if (lsym->attr.allocatable && rsym->attr.pointer)
2754
    return 1;
2755
 
2756
  return 0;
2757
}
2758
 
2759
 
2760
/* Undoes all the changes made to symbols in the current statement.
2761
   This subroutine is made simpler due to the fact that attributes are
2762
   never removed once added.  */
2763
 
2764
void
2765
gfc_undo_symbols (void)
2766
{
2767
  gfc_symbol *p, *q, *old;
2768
  tentative_tbp *tbp, *tbq;
2769
 
2770
  for (p = changed_syms; p; p = q)
2771
    {
2772
      q = p->tlink;
2773
 
2774
      if (p->gfc_new)
2775
        {
2776
          /* Symbol was new.  */
2777
          if (p->attr.in_common && p->common_block && p->common_block->head)
2778
            {
2779
              /* If the symbol was added to any common block, it
2780
                 needs to be removed to stop the resolver looking
2781
                 for a (possibly) dead symbol.  */
2782
 
2783
              if (p->common_block->head == p)
2784
                p->common_block->head = p->common_next;
2785
              else
2786
                {
2787
                  gfc_symbol *cparent, *csym;
2788
 
2789
                  cparent = p->common_block->head;
2790
                  csym = cparent->common_next;
2791
 
2792
                  while (csym != p)
2793
                    {
2794
                      cparent = csym;
2795
                      csym = csym->common_next;
2796
                    }
2797
 
2798
                  gcc_assert(cparent->common_next == p);
2799
 
2800
                  cparent->common_next = csym->common_next;
2801
                }
2802
            }
2803
 
2804
          gfc_delete_symtree (&p->ns->sym_root, p->name);
2805
 
2806
          p->refs--;
2807
          if (p->refs < 0)
2808
            gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2809
          if (p->refs == 0)
2810
            gfc_free_symbol (p);
2811
          continue;
2812
        }
2813
 
2814
      /* Restore previous state of symbol.  Just copy simple stuff.  */
2815
      p->mark = 0;
2816
      old = p->old_symbol;
2817
 
2818
      p->ts.type = old->ts.type;
2819
      p->ts.kind = old->ts.kind;
2820
 
2821
      p->attr = old->attr;
2822
 
2823
      if (p->value != old->value)
2824
        {
2825
          gfc_free_expr (old->value);
2826
          p->value = NULL;
2827
        }
2828
 
2829
      if (p->as != old->as)
2830
        {
2831
          if (p->as)
2832
            gfc_free_array_spec (p->as);
2833
          p->as = old->as;
2834
        }
2835
 
2836
      p->generic = old->generic;
2837
      p->component_access = old->component_access;
2838
 
2839
      if (p->namelist != NULL && old->namelist == NULL)
2840
        {
2841
          gfc_free_namelist (p->namelist);
2842
          p->namelist = NULL;
2843
        }
2844
      else
2845
        {
2846
          if (p->namelist_tail != old->namelist_tail)
2847
            {
2848
              gfc_free_namelist (old->namelist_tail);
2849
              old->namelist_tail->next = NULL;
2850
            }
2851
        }
2852
 
2853
      p->namelist_tail = old->namelist_tail;
2854
 
2855
      if (p->formal != old->formal)
2856
        {
2857
          gfc_free_formal_arglist (p->formal);
2858
          p->formal = old->formal;
2859
        }
2860
 
2861
      gfc_free (p->old_symbol);
2862
      p->old_symbol = NULL;
2863
      p->tlink = NULL;
2864
    }
2865
 
2866
  changed_syms = NULL;
2867
 
2868
  for (tbp = tentative_tbp_list; tbp; tbp = tbq)
2869
    {
2870
      tbq = tbp->next;
2871
      /* Procedure is already marked `error' by default.  */
2872
      gfc_free (tbp);
2873
    }
2874
  tentative_tbp_list = NULL;
2875
}
2876
 
2877
 
2878
/* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2879
   components of old_symbol that might need deallocation are the "allocatables"
2880
   that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2881
   namelist_tail.  In case these differ between old_symbol and sym, it's just
2882
   because sym->namelist has gotten a few more items.  */
2883
 
2884
static void
2885
free_old_symbol (gfc_symbol *sym)
2886
{
2887
 
2888
  if (sym->old_symbol == NULL)
2889
    return;
2890
 
2891
  if (sym->old_symbol->as != sym->as)
2892
    gfc_free_array_spec (sym->old_symbol->as);
2893
 
2894
  if (sym->old_symbol->value != sym->value)
2895
    gfc_free_expr (sym->old_symbol->value);
2896
 
2897
  if (sym->old_symbol->formal != sym->formal)
2898
    gfc_free_formal_arglist (sym->old_symbol->formal);
2899
 
2900
  gfc_free (sym->old_symbol);
2901
  sym->old_symbol = NULL;
2902
}
2903
 
2904
 
2905
/* Makes the changes made in the current statement permanent-- gets
2906
   rid of undo information.  */
2907
 
2908
void
2909
gfc_commit_symbols (void)
2910
{
2911
  gfc_symbol *p, *q;
2912
  tentative_tbp *tbp, *tbq;
2913
 
2914
  for (p = changed_syms; p; p = q)
2915
    {
2916
      q = p->tlink;
2917
      p->tlink = NULL;
2918
      p->mark = 0;
2919
      p->gfc_new = 0;
2920
      free_old_symbol (p);
2921
    }
2922
  changed_syms = NULL;
2923
 
2924
  for (tbp = tentative_tbp_list; tbp; tbp = tbq)
2925
    {
2926
      tbq = tbp->next;
2927
      tbp->proc->error = 0;
2928
      gfc_free (tbp);
2929
    }
2930
  tentative_tbp_list = NULL;
2931
}
2932
 
2933
 
2934
/* Makes the changes made in one symbol permanent -- gets rid of undo
2935
   information.  */
2936
 
2937
void
2938
gfc_commit_symbol (gfc_symbol *sym)
2939
{
2940
  gfc_symbol *p;
2941
 
2942
  if (changed_syms == sym)
2943
    changed_syms = sym->tlink;
2944
  else
2945
    {
2946
      for (p = changed_syms; p; p = p->tlink)
2947
        if (p->tlink == sym)
2948
          {
2949
            p->tlink = sym->tlink;
2950
            break;
2951
          }
2952
    }
2953
 
2954
  sym->tlink = NULL;
2955
  sym->mark = 0;
2956
  sym->gfc_new = 0;
2957
 
2958
  free_old_symbol (sym);
2959
}
2960
 
2961
 
2962
/* Recursively free trees containing type-bound procedures.  */
2963
 
2964
static void
2965
free_tb_tree (gfc_symtree *t)
2966
{
2967
  if (t == NULL)
2968
    return;
2969
 
2970
  free_tb_tree (t->left);
2971
  free_tb_tree (t->right);
2972
 
2973
  /* TODO: Free type-bound procedure structs themselves; probably needs some
2974
     sort of ref-counting mechanism.  */
2975
 
2976
  gfc_free (t);
2977
}
2978
 
2979
 
2980
/* Recursive function that deletes an entire tree and all the common
2981
   head structures it points to.  */
2982
 
2983
static void
2984
free_common_tree (gfc_symtree * common_tree)
2985
{
2986
  if (common_tree == NULL)
2987
    return;
2988
 
2989
  free_common_tree (common_tree->left);
2990
  free_common_tree (common_tree->right);
2991
 
2992
  gfc_free (common_tree);
2993
}
2994
 
2995
 
2996
/* Recursive function that deletes an entire tree and all the user
2997
   operator nodes that it contains.  */
2998
 
2999
static void
3000
free_uop_tree (gfc_symtree *uop_tree)
3001
{
3002
  if (uop_tree == NULL)
3003
    return;
3004
 
3005
  free_uop_tree (uop_tree->left);
3006
  free_uop_tree (uop_tree->right);
3007
 
3008
  gfc_free_interface (uop_tree->n.uop->op);
3009
  gfc_free (uop_tree->n.uop);
3010
  gfc_free (uop_tree);
3011
}
3012
 
3013
 
3014
/* Recursive function that deletes an entire tree and all the symbols
3015
   that it contains.  */
3016
 
3017
static void
3018
free_sym_tree (gfc_symtree *sym_tree)
3019
{
3020
  gfc_namespace *ns;
3021
  gfc_symbol *sym;
3022
 
3023
  if (sym_tree == NULL)
3024
    return;
3025
 
3026
  free_sym_tree (sym_tree->left);
3027
  free_sym_tree (sym_tree->right);
3028
 
3029
  sym = sym_tree->n.sym;
3030
 
3031
  sym->refs--;
3032
  if (sym->refs < 0)
3033
    gfc_internal_error ("free_sym_tree(): Negative refs");
3034
 
3035
  if (sym->formal_ns != NULL && sym->refs == 1)
3036
    {
3037
      /* As formal_ns contains a reference to sym, delete formal_ns just
3038
         before the deletion of sym.  */
3039
      ns = sym->formal_ns;
3040
      sym->formal_ns = NULL;
3041
      gfc_free_namespace (ns);
3042
    }
3043
  else if (sym->refs == 0)
3044
    {
3045
      /* Go ahead and delete the symbol.  */
3046
      gfc_free_symbol (sym);
3047
    }
3048
 
3049
  gfc_free (sym_tree);
3050
}
3051
 
3052
 
3053
/* Free the derived type list.  */
3054
 
3055
void
3056
gfc_free_dt_list (void)
3057
{
3058
  gfc_dt_list *dt, *n;
3059
 
3060
  for (dt = gfc_derived_types; dt; dt = n)
3061
    {
3062
      n = dt->next;
3063
      gfc_free (dt);
3064
    }
3065
 
3066
  gfc_derived_types = NULL;
3067
}
3068
 
3069
 
3070
/* Free the gfc_equiv_info's.  */
3071
 
3072
static void
3073
gfc_free_equiv_infos (gfc_equiv_info *s)
3074
{
3075
  if (s == NULL)
3076
    return;
3077
  gfc_free_equiv_infos (s->next);
3078
  gfc_free (s);
3079
}
3080
 
3081
 
3082
/* Free the gfc_equiv_lists.  */
3083
 
3084
static void
3085
gfc_free_equiv_lists (gfc_equiv_list *l)
3086
{
3087
  if (l == NULL)
3088
    return;
3089
  gfc_free_equiv_lists (l->next);
3090
  gfc_free_equiv_infos (l->equiv);
3091
  gfc_free (l);
3092
}
3093
 
3094
 
3095
/* Free a finalizer procedure list.  */
3096
 
3097
void
3098
gfc_free_finalizer (gfc_finalizer* el)
3099
{
3100
  if (el)
3101
    {
3102
      if (el->proc_sym)
3103
        {
3104
          --el->proc_sym->refs;
3105
          if (!el->proc_sym->refs)
3106
            gfc_free_symbol (el->proc_sym);
3107
        }
3108
 
3109
      gfc_free (el);
3110
    }
3111
}
3112
 
3113
static void
3114
gfc_free_finalizer_list (gfc_finalizer* list)
3115
{
3116
  while (list)
3117
    {
3118
      gfc_finalizer* current = list;
3119
      list = list->next;
3120
      gfc_free_finalizer (current);
3121
    }
3122
}
3123
 
3124
 
3125
/* Create a new gfc_charlen structure and add it to a namespace.
3126
   If 'old_cl' is given, the newly created charlen will be a copy of it.  */
3127
 
3128
gfc_charlen*
3129
gfc_new_charlen (gfc_namespace *ns, gfc_charlen *old_cl)
3130
{
3131
  gfc_charlen *cl;
3132
  cl = gfc_get_charlen ();
3133
 
3134
  /* Put into namespace.  */
3135
  cl->next = ns->cl_list;
3136
  ns->cl_list = cl;
3137
 
3138
  /* Copy old_cl.  */
3139
  if (old_cl)
3140
    {
3141
      cl->length = gfc_copy_expr (old_cl->length);
3142
      cl->length_from_typespec = old_cl->length_from_typespec;
3143
      cl->backend_decl = old_cl->backend_decl;
3144
      cl->passed_length = old_cl->passed_length;
3145
      cl->resolved = old_cl->resolved;
3146
    }
3147
 
3148
  return cl;
3149
}
3150
 
3151
 
3152
/* Free the charlen list from cl to end (end is not freed).
3153
   Free the whole list if end is NULL.  */
3154
 
3155
void gfc_free_charlen (gfc_charlen *cl, gfc_charlen *end)
3156
{
3157
  gfc_charlen *cl2;
3158
 
3159
  for (; cl != end; cl = cl2)
3160
    {
3161
      gcc_assert (cl);
3162
 
3163
      cl2 = cl->next;
3164
      gfc_free_expr (cl->length);
3165
      gfc_free (cl);
3166
    }
3167
}
3168
 
3169
 
3170
/* Free a namespace structure and everything below it.  Interface
3171
   lists associated with intrinsic operators are not freed.  These are
3172
   taken care of when a specific name is freed.  */
3173
 
3174
void
3175
gfc_free_namespace (gfc_namespace *ns)
3176
{
3177
  gfc_namespace *p, *q;
3178
  int i;
3179
 
3180
  if (ns == NULL)
3181
    return;
3182
 
3183
  ns->refs--;
3184
  if (ns->refs > 0)
3185
    return;
3186
  gcc_assert (ns->refs == 0);
3187
 
3188
  gfc_free_statements (ns->code);
3189
 
3190
  free_sym_tree (ns->sym_root);
3191
  free_uop_tree (ns->uop_root);
3192
  free_common_tree (ns->common_root);
3193
  free_tb_tree (ns->tb_sym_root);
3194
  free_tb_tree (ns->tb_uop_root);
3195
  gfc_free_finalizer_list (ns->finalizers);
3196
  gfc_free_charlen (ns->cl_list, NULL);
3197
  free_st_labels (ns->st_labels);
3198
 
3199
  gfc_free_equiv (ns->equiv);
3200
  gfc_free_equiv_lists (ns->equiv_lists);
3201
  gfc_free_use_stmts (ns->use_stmts);
3202
 
3203
  for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3204
    gfc_free_interface (ns->op[i]);
3205
 
3206
  gfc_free_data (ns->data);
3207
  p = ns->contained;
3208
  gfc_free (ns);
3209
 
3210
  /* Recursively free any contained namespaces.  */
3211
  while (p != NULL)
3212
    {
3213
      q = p;
3214
      p = p->sibling;
3215
      gfc_free_namespace (q);
3216
    }
3217
}
3218
 
3219
 
3220
void
3221
gfc_symbol_init_2 (void)
3222
{
3223
 
3224
  gfc_current_ns = gfc_get_namespace (NULL, 0);
3225
}
3226
 
3227
 
3228
void
3229
gfc_symbol_done_2 (void)
3230
{
3231
 
3232
  gfc_free_namespace (gfc_current_ns);
3233
  gfc_current_ns = NULL;
3234
  gfc_free_dt_list ();
3235
}
3236
 
3237
 
3238
/* Clear mark bits from symbol nodes associated with a symtree node.  */
3239
 
3240
static void
3241
clear_sym_mark (gfc_symtree *st)
3242
{
3243
 
3244
  st->n.sym->mark = 0;
3245
}
3246
 
3247
 
3248
/* Recursively traverse the symtree nodes.  */
3249
 
3250
void
3251
gfc_traverse_symtree (gfc_symtree *st, void (*func) (gfc_symtree *))
3252
{
3253
  if (!st)
3254
    return;
3255
 
3256
  gfc_traverse_symtree (st->left, func);
3257
  (*func) (st);
3258
  gfc_traverse_symtree (st->right, func);
3259
}
3260
 
3261
 
3262
/* Recursive namespace traversal function.  */
3263
 
3264
static void
3265
traverse_ns (gfc_symtree *st, void (*func) (gfc_symbol *))
3266
{
3267
 
3268
  if (st == NULL)
3269
    return;
3270
 
3271
  traverse_ns (st->left, func);
3272
 
3273
  if (st->n.sym->mark == 0)
3274
    (*func) (st->n.sym);
3275
  st->n.sym->mark = 1;
3276
 
3277
  traverse_ns (st->right, func);
3278
}
3279
 
3280
 
3281
/* Call a given function for all symbols in the namespace.  We take
3282
   care that each gfc_symbol node is called exactly once.  */
3283
 
3284
void
3285
gfc_traverse_ns (gfc_namespace *ns, void (*func) (gfc_symbol *))
3286
{
3287
 
3288
  gfc_traverse_symtree (ns->sym_root, clear_sym_mark);
3289
 
3290
  traverse_ns (ns->sym_root, func);
3291
}
3292
 
3293
 
3294
/* Return TRUE when name is the name of an intrinsic type.  */
3295
 
3296
bool
3297
gfc_is_intrinsic_typename (const char *name)
3298
{
3299
  if (strcmp (name, "integer") == 0
3300
      || strcmp (name, "real") == 0
3301
      || strcmp (name, "character") == 0
3302
      || strcmp (name, "logical") == 0
3303
      || strcmp (name, "complex") == 0
3304
      || strcmp (name, "doubleprecision") == 0
3305
      || strcmp (name, "doublecomplex") == 0)
3306
    return true;
3307
  else
3308
    return false;
3309
}
3310
 
3311
 
3312
/* Return TRUE if the symbol is an automatic variable.  */
3313
 
3314
static bool
3315
gfc_is_var_automatic (gfc_symbol *sym)
3316
{
3317
  /* Pointer and allocatable variables are never automatic.  */
3318
  if (sym->attr.pointer || sym->attr.allocatable)
3319
    return false;
3320
  /* Check for arrays with non-constant size.  */
3321
  if (sym->attr.dimension && sym->as
3322
      && !gfc_is_compile_time_shape (sym->as))
3323
    return true;
3324
  /* Check for non-constant length character variables.  */
3325
  if (sym->ts.type == BT_CHARACTER
3326
      && sym->ts.u.cl
3327
      && !gfc_is_constant_expr (sym->ts.u.cl->length))
3328
    return true;
3329
  return false;
3330
}
3331
 
3332
/* Given a symbol, mark it as SAVEd if it is allowed.  */
3333
 
3334
static void
3335
save_symbol (gfc_symbol *sym)
3336
{
3337
 
3338
  if (sym->attr.use_assoc)
3339
    return;
3340
 
3341
  if (sym->attr.in_common
3342
      || sym->attr.dummy
3343
      || sym->attr.result
3344
      || sym->attr.flavor != FL_VARIABLE)
3345
    return;
3346
  /* Automatic objects are not saved.  */
3347
  if (gfc_is_var_automatic (sym))
3348
    return;
3349
  gfc_add_save (&sym->attr, sym->name, &sym->declared_at);
3350
}
3351
 
3352
 
3353
/* Mark those symbols which can be SAVEd as such.  */
3354
 
3355
void
3356
gfc_save_all (gfc_namespace *ns)
3357
{
3358
  gfc_traverse_ns (ns, save_symbol);
3359
}
3360
 
3361
 
3362
#ifdef GFC_DEBUG
3363
/* Make sure that no changes to symbols are pending.  */
3364
 
3365
void
3366
gfc_symbol_state(void) {
3367
 
3368
  if (changed_syms != NULL)
3369
    gfc_internal_error("Symbol changes still pending!");
3370
}
3371
#endif
3372
 
3373
 
3374
/************** Global symbol handling ************/
3375
 
3376
 
3377
/* Search a tree for the global symbol.  */
3378
 
3379
gfc_gsymbol *
3380
gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name)
3381
{
3382
  int c;
3383
 
3384
  if (symbol == NULL)
3385
    return NULL;
3386
 
3387
  while (symbol)
3388
    {
3389
      c = strcmp (name, symbol->name);
3390
      if (!c)
3391
        return symbol;
3392
 
3393
      symbol = (c < 0) ? symbol->left : symbol->right;
3394
    }
3395
 
3396
  return NULL;
3397
}
3398
 
3399
 
3400
/* Compare two global symbols. Used for managing the BB tree.  */
3401
 
3402
static int
3403
gsym_compare (void *_s1, void *_s2)
3404
{
3405
  gfc_gsymbol *s1, *s2;
3406
 
3407
  s1 = (gfc_gsymbol *) _s1;
3408
  s2 = (gfc_gsymbol *) _s2;
3409
  return strcmp (s1->name, s2->name);
3410
}
3411
 
3412
 
3413
/* Get a global symbol, creating it if it doesn't exist.  */
3414
 
3415
gfc_gsymbol *
3416
gfc_get_gsymbol (const char *name)
3417
{
3418
  gfc_gsymbol *s;
3419
 
3420
  s = gfc_find_gsymbol (gfc_gsym_root, name);
3421
  if (s != NULL)
3422
    return s;
3423
 
3424
  s = XCNEW (gfc_gsymbol);
3425
  s->type = GSYM_UNKNOWN;
3426
  s->name = gfc_get_string (name);
3427
 
3428
  gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);
3429
 
3430
  return s;
3431
}
3432
 
3433
 
3434
static gfc_symbol *
3435
get_iso_c_binding_dt (int sym_id)
3436
{
3437
  gfc_dt_list *dt_list;
3438
 
3439
  dt_list = gfc_derived_types;
3440
 
3441
  /* Loop through the derived types in the name list, searching for
3442
     the desired symbol from iso_c_binding.  Search the parent namespaces
3443
     if necessary and requested to (parent_flag).  */
3444
  while (dt_list != NULL)
3445
    {
3446
      if (dt_list->derived->from_intmod != INTMOD_NONE
3447
          && dt_list->derived->intmod_sym_id == sym_id)
3448
        return dt_list->derived;
3449
 
3450
      dt_list = dt_list->next;
3451
    }
3452
 
3453
  return NULL;
3454
}
3455
 
3456
 
3457
/* Verifies that the given derived type symbol, derived_sym, is interoperable
3458
   with C.  This is necessary for any derived type that is BIND(C) and for
3459
   derived types that are parameters to functions that are BIND(C).  All
3460
   fields of the derived type are required to be interoperable, and are tested
3461
   for such.  If an error occurs, the errors are reported here, allowing for
3462
   multiple errors to be handled for a single derived type.  */
3463
 
3464
gfc_try
3465
verify_bind_c_derived_type (gfc_symbol *derived_sym)
3466
{
3467
  gfc_component *curr_comp = NULL;
3468
  gfc_try is_c_interop = FAILURE;
3469
  gfc_try retval = SUCCESS;
3470
 
3471
  if (derived_sym == NULL)
3472
    gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
3473
                        "unexpectedly NULL");
3474
 
3475
  /* If we've already looked at this derived symbol, do not look at it again
3476
     so we don't repeat warnings/errors.  */
3477
  if (derived_sym->ts.is_c_interop)
3478
    return SUCCESS;
3479
 
3480
  /* The derived type must have the BIND attribute to be interoperable
3481
     J3/04-007, Section 15.2.3.  */
3482
  if (derived_sym->attr.is_bind_c != 1)
3483
    {
3484
      derived_sym->ts.is_c_interop = 0;
3485
      gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
3486
                     "attribute to be C interoperable", derived_sym->name,
3487
                     &(derived_sym->declared_at));
3488
      retval = FAILURE;
3489
    }
3490
 
3491
  curr_comp = derived_sym->components;
3492
 
3493
  /* TODO: is this really an error?  */
3494
  if (curr_comp == NULL)
3495
    {
3496
      gfc_error ("Derived type '%s' at %L is empty",
3497
                 derived_sym->name, &(derived_sym->declared_at));
3498
      return FAILURE;
3499
    }
3500
 
3501
  /* Initialize the derived type as being C interoperable.
3502
     If we find an error in the components, this will be set false.  */
3503
  derived_sym->ts.is_c_interop = 1;
3504
 
3505
  /* Loop through the list of components to verify that the kind of
3506
     each is a C interoperable type.  */
3507
  do
3508
    {
3509
      /* The components cannot be pointers (fortran sense).
3510
         J3/04-007, Section 15.2.3, C1505.      */
3511
      if (curr_comp->attr.pointer != 0)
3512
        {
3513
          gfc_error ("Component '%s' at %L cannot have the "
3514
                     "POINTER attribute because it is a member "
3515
                     "of the BIND(C) derived type '%s' at %L",
3516
                     curr_comp->name, &(curr_comp->loc),
3517
                     derived_sym->name, &(derived_sym->declared_at));
3518
          retval = FAILURE;
3519
        }
3520
 
3521
      if (curr_comp->attr.proc_pointer != 0)
3522
        {
3523
          gfc_error ("Procedure pointer component '%s' at %L cannot be a member"
3524
                     " of the BIND(C) derived type '%s' at %L", curr_comp->name,
3525
                     &curr_comp->loc, derived_sym->name,
3526
                     &derived_sym->declared_at);
3527
          retval = FAILURE;
3528
        }
3529
 
3530
      /* The components cannot be allocatable.
3531
         J3/04-007, Section 15.2.3, C1505.      */
3532
      if (curr_comp->attr.allocatable != 0)
3533
        {
3534
          gfc_error ("Component '%s' at %L cannot have the "
3535
                     "ALLOCATABLE attribute because it is a member "
3536
                     "of the BIND(C) derived type '%s' at %L",
3537
                     curr_comp->name, &(curr_comp->loc),
3538
                     derived_sym->name, &(derived_sym->declared_at));
3539
          retval = FAILURE;
3540
        }
3541
 
3542
      /* BIND(C) derived types must have interoperable components.  */
3543
      if (curr_comp->ts.type == BT_DERIVED
3544
          && curr_comp->ts.u.derived->ts.is_iso_c != 1
3545
          && curr_comp->ts.u.derived != derived_sym)
3546
        {
3547
          /* This should be allowed; the draft says a derived-type can not
3548
             have type parameters if it is has the BIND attribute.  Type
3549
             parameters seem to be for making parameterized derived types.
3550
             There's no need to verify the type if it is c_ptr/c_funptr.  */
3551
          retval = verify_bind_c_derived_type (curr_comp->ts.u.derived);
3552
        }
3553
      else
3554
        {
3555
          /* Grab the typespec for the given component and test the kind.  */
3556
          is_c_interop = verify_c_interop (&(curr_comp->ts));
3557
 
3558
          if (is_c_interop != SUCCESS)
3559
            {
3560
              /* Report warning and continue since not fatal.  The
3561
                 draft does specify a constraint that requires all fields
3562
                 to interoperate, but if the user says real(4), etc., it
3563
                 may interoperate with *something* in C, but the compiler
3564
                 most likely won't know exactly what.  Further, it may not
3565
                 interoperate with the same data type(s) in C if the user
3566
                 recompiles with different flags (e.g., -m32 and -m64 on
3567
                 x86_64 and using integer(4) to claim interop with a
3568
                 C_LONG).  */
3569
              if (derived_sym->attr.is_bind_c == 1)
3570
                /* If the derived type is bind(c), all fields must be
3571
                   interop.  */
3572
                gfc_warning ("Component '%s' in derived type '%s' at %L "
3573
                             "may not be C interoperable, even though "
3574
                             "derived type '%s' is BIND(C)",
3575
                             curr_comp->name, derived_sym->name,
3576
                             &(curr_comp->loc), derived_sym->name);
3577
              else
3578
                /* If derived type is param to bind(c) routine, or to one
3579
                   of the iso_c_binding procs, it must be interoperable, so
3580
                   all fields must interop too.  */
3581
                gfc_warning ("Component '%s' in derived type '%s' at %L "
3582
                             "may not be C interoperable",
3583
                             curr_comp->name, derived_sym->name,
3584
                             &(curr_comp->loc));
3585
            }
3586
        }
3587
 
3588
      curr_comp = curr_comp->next;
3589
    } while (curr_comp != NULL);
3590
 
3591
 
3592
  /* Make sure we don't have conflicts with the attributes.  */
3593
  if (derived_sym->attr.access == ACCESS_PRIVATE)
3594
    {
3595
      gfc_error ("Derived type '%s' at %L cannot be declared with both "
3596
                 "PRIVATE and BIND(C) attributes", derived_sym->name,
3597
                 &(derived_sym->declared_at));
3598
      retval = FAILURE;
3599
    }
3600
 
3601
  if (derived_sym->attr.sequence != 0)
3602
    {
3603
      gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
3604
                 "attribute because it is BIND(C)", derived_sym->name,
3605
                 &(derived_sym->declared_at));
3606
      retval = FAILURE;
3607
    }
3608
 
3609
  /* Mark the derived type as not being C interoperable if we found an
3610
     error.  If there were only warnings, proceed with the assumption
3611
     it's interoperable.  */
3612
  if (retval == FAILURE)
3613
    derived_sym->ts.is_c_interop = 0;
3614
 
3615
  return retval;
3616
}
3617
 
3618
 
3619
/* Generate symbols for the named constants c_null_ptr and c_null_funptr.  */
3620
 
3621
static gfc_try
3622
gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
3623
                           const char *module_name)
3624
{
3625
  gfc_symtree *tmp_symtree;
3626
  gfc_symbol *tmp_sym;
3627
 
3628
  tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, ptr_name);
3629
 
3630
  if (tmp_symtree != NULL)
3631
    tmp_sym = tmp_symtree->n.sym;
3632
  else
3633
    {
3634
      tmp_sym = NULL;
3635
      gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
3636
                          "create symbol for %s", ptr_name);
3637
    }
3638
 
3639
  /* Set up the symbol's important fields.  Save attr required so we can
3640
     initialize the ptr to NULL.  */
3641
  tmp_sym->attr.save = SAVE_EXPLICIT;
3642
  tmp_sym->ts.is_c_interop = 1;
3643
  tmp_sym->attr.is_c_interop = 1;
3644
  tmp_sym->ts.is_iso_c = 1;
3645
  tmp_sym->ts.type = BT_DERIVED;
3646
 
3647
  /* The c_ptr and c_funptr derived types will provide the
3648
     definition for c_null_ptr and c_null_funptr, respectively.  */
3649
  if (ptr_id == ISOCBINDING_NULL_PTR)
3650
    tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_PTR);
3651
  else
3652
    tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3653
  if (tmp_sym->ts.u.derived == NULL)
3654
    {
3655
      /* This can occur if the user forgot to declare c_ptr or
3656
         c_funptr and they're trying to use one of the procedures
3657
         that has arg(s) of the missing type.  In this case, a
3658
         regular version of the thing should have been put in the
3659
         current ns.  */
3660
      generate_isocbinding_symbol (module_name, ptr_id == ISOCBINDING_NULL_PTR
3661
                                   ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR,
3662
                                   (const char *) (ptr_id == ISOCBINDING_NULL_PTR
3663
                                   ? "_gfortran_iso_c_binding_c_ptr"
3664
                                   : "_gfortran_iso_c_binding_c_funptr"));
3665
 
3666
      tmp_sym->ts.u.derived =
3667
        get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
3668
                              ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR);
3669
    }
3670
 
3671
  /* Module name is some mangled version of iso_c_binding.  */
3672
  tmp_sym->module = gfc_get_string (module_name);
3673
 
3674
  /* Say it's from the iso_c_binding module.  */
3675
  tmp_sym->attr.is_iso_c = 1;
3676
 
3677
  tmp_sym->attr.use_assoc = 1;
3678
  tmp_sym->attr.is_bind_c = 1;
3679
  /* Set the binding_label.  */
3680
  sprintf (tmp_sym->binding_label, "%s_%s", module_name, tmp_sym->name);
3681
 
3682
  /* Set the c_address field of c_null_ptr and c_null_funptr to
3683
     the value of NULL.  */
3684
  tmp_sym->value = gfc_get_expr ();
3685
  tmp_sym->value->expr_type = EXPR_STRUCTURE;
3686
  tmp_sym->value->ts.type = BT_DERIVED;
3687
  tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived;
3688
  tmp_sym->value->value.constructor = gfc_get_constructor ();
3689
  tmp_sym->value->value.constructor->expr = gfc_get_expr ();
3690
  tmp_sym->value->value.constructor->expr->expr_type = EXPR_NULL;
3691
  tmp_sym->value->value.constructor->expr->ts.is_iso_c = 1;
3692
  /* Must declare c_null_ptr and c_null_funptr as having the
3693
     PARAMETER attribute so they can be used in init expressions.  */
3694
  tmp_sym->attr.flavor = FL_PARAMETER;
3695
 
3696
  return SUCCESS;
3697
}
3698
 
3699
 
3700
/* Add a formal argument, gfc_formal_arglist, to the
3701
   end of the given list of arguments.  Set the reference to the
3702
   provided symbol, param_sym, in the argument.  */
3703
 
3704
static void
3705
add_formal_arg (gfc_formal_arglist **head,
3706
                gfc_formal_arglist **tail,
3707
                gfc_formal_arglist *formal_arg,
3708
                gfc_symbol *param_sym)
3709
{
3710
  /* Put in list, either as first arg or at the tail (curr arg).  */
3711
  if (*head == NULL)
3712
    *head = *tail = formal_arg;
3713
  else
3714
    {
3715
      (*tail)->next = formal_arg;
3716
      (*tail) = formal_arg;
3717
    }
3718
 
3719
  (*tail)->sym = param_sym;
3720
  (*tail)->next = NULL;
3721
 
3722
  return;
3723
}
3724
 
3725
 
3726
/* Generates a symbol representing the CPTR argument to an
3727
   iso_c_binding procedure.  Also, create a gfc_formal_arglist for the
3728
   CPTR and add it to the provided argument list.  */
3729
 
3730
static void
3731
gen_cptr_param (gfc_formal_arglist **head,
3732
                gfc_formal_arglist **tail,
3733
                const char *module_name,
3734
                gfc_namespace *ns, const char *c_ptr_name,
3735
                int iso_c_sym_id)
3736
{
3737
  gfc_symbol *param_sym = NULL;
3738
  gfc_symbol *c_ptr_sym = NULL;
3739
  gfc_symtree *param_symtree = NULL;
3740
  gfc_formal_arglist *formal_arg = NULL;
3741
  const char *c_ptr_in;
3742
  const char *c_ptr_type = NULL;
3743
 
3744
  if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3745
    c_ptr_type = "_gfortran_iso_c_binding_c_funptr";
3746
  else
3747
    c_ptr_type = "_gfortran_iso_c_binding_c_ptr";
3748
 
3749
  if(c_ptr_name == NULL)
3750
    c_ptr_in = "gfc_cptr__";
3751
  else
3752
    c_ptr_in = c_ptr_name;
3753
  gfc_get_sym_tree (c_ptr_in, ns, &param_symtree, false);
3754
  if (param_symtree != NULL)
3755
    param_sym = param_symtree->n.sym;
3756
  else
3757
    gfc_internal_error ("gen_cptr_param(): Unable to "
3758
                        "create symbol for %s", c_ptr_in);
3759
 
3760
  /* Set up the appropriate fields for the new c_ptr param sym.  */
3761
  param_sym->refs++;
3762
  param_sym->attr.flavor = FL_DERIVED;
3763
  param_sym->ts.type = BT_DERIVED;
3764
  param_sym->attr.intent = INTENT_IN;
3765
  param_sym->attr.dummy = 1;
3766
 
3767
  /* This will pass the ptr to the iso_c routines as a (void *).  */
3768
  param_sym->attr.value = 1;
3769
  param_sym->attr.use_assoc = 1;
3770
 
3771
  /* Get the symbol for c_ptr or c_funptr, no matter what it's name is
3772
     (user renamed).  */
3773
  if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3774
    c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3775
  else
3776
    c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_PTR);
3777
  if (c_ptr_sym == NULL)
3778
    {
3779
      /* This can happen if the user did not define c_ptr but they are
3780
         trying to use one of the iso_c_binding functions that need it.  */
3781
      if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3782
        generate_isocbinding_symbol (module_name, ISOCBINDING_FUNPTR,
3783
                                     (const char *)c_ptr_type);
3784
      else
3785
        generate_isocbinding_symbol (module_name, ISOCBINDING_PTR,
3786
                                     (const char *)c_ptr_type);
3787
 
3788
      gfc_get_ha_symbol (c_ptr_type, &(c_ptr_sym));
3789
    }
3790
 
3791
  param_sym->ts.u.derived = c_ptr_sym;
3792
  param_sym->module = gfc_get_string (module_name);
3793
 
3794
  /* Make new formal arg.  */
3795
  formal_arg = gfc_get_formal_arglist ();
3796
  /* Add arg to list of formal args (the CPTR arg).  */
3797
  add_formal_arg (head, tail, formal_arg, param_sym);
3798 378 julius
 
3799
  /* Validate changes.  */
3800
  gfc_commit_symbol (param_sym);
3801 285 jeremybenn
}
3802
 
3803
 
3804
/* Generates a symbol representing the FPTR argument to an
3805
   iso_c_binding procedure.  Also, create a gfc_formal_arglist for the
3806
   FPTR and add it to the provided argument list.  */
3807
 
3808
static void
3809
gen_fptr_param (gfc_formal_arglist **head,
3810
                gfc_formal_arglist **tail,
3811
                const char *module_name,
3812
                gfc_namespace *ns, const char *f_ptr_name, int proc)
3813
{
3814
  gfc_symbol *param_sym = NULL;
3815
  gfc_symtree *param_symtree = NULL;
3816
  gfc_formal_arglist *formal_arg = NULL;
3817
  const char *f_ptr_out = "gfc_fptr__";
3818
 
3819
  if (f_ptr_name != NULL)
3820
    f_ptr_out = f_ptr_name;
3821
 
3822
  gfc_get_sym_tree (f_ptr_out, ns, &param_symtree, false);
3823
  if (param_symtree != NULL)
3824
    param_sym = param_symtree->n.sym;
3825
  else
3826
    gfc_internal_error ("generateFPtrParam(): Unable to "
3827
                        "create symbol for %s", f_ptr_out);
3828
 
3829
  /* Set up the necessary fields for the fptr output param sym.  */
3830
  param_sym->refs++;
3831
  if (proc)
3832
    param_sym->attr.proc_pointer = 1;
3833
  else
3834
    param_sym->attr.pointer = 1;
3835
  param_sym->attr.dummy = 1;
3836
  param_sym->attr.use_assoc = 1;
3837
 
3838
  /* ISO C Binding type to allow any pointer type as actual param.  */
3839
  param_sym->ts.type = BT_VOID;
3840
  param_sym->module = gfc_get_string (module_name);
3841
 
3842
  /* Make the arg.  */
3843
  formal_arg = gfc_get_formal_arglist ();
3844
  /* Add arg to list of formal args.  */
3845
  add_formal_arg (head, tail, formal_arg, param_sym);
3846 378 julius
 
3847
  /* Validate changes.  */
3848
  gfc_commit_symbol (param_sym);
3849 285 jeremybenn
}
3850
 
3851
 
3852
/* Generates a symbol representing the optional SHAPE argument for the
3853
   iso_c_binding c_f_pointer() procedure.  Also, create a
3854
   gfc_formal_arglist for the SHAPE and add it to the provided
3855
   argument list.  */
3856
 
3857
static void
3858
gen_shape_param (gfc_formal_arglist **head,
3859
                 gfc_formal_arglist **tail,
3860
                 const char *module_name,
3861
                 gfc_namespace *ns, const char *shape_param_name)
3862
{
3863
  gfc_symbol *param_sym = NULL;
3864
  gfc_symtree *param_symtree = NULL;
3865
  gfc_formal_arglist *formal_arg = NULL;
3866
  const char *shape_param = "gfc_shape_array__";
3867
  int i;
3868
 
3869
  if (shape_param_name != NULL)
3870
    shape_param = shape_param_name;
3871
 
3872
  gfc_get_sym_tree (shape_param, ns, &param_symtree, false);
3873
  if (param_symtree != NULL)
3874
    param_sym = param_symtree->n.sym;
3875
  else
3876
    gfc_internal_error ("generateShapeParam(): Unable to "
3877
                        "create symbol for %s", shape_param);
3878
 
3879
  /* Set up the necessary fields for the shape input param sym.  */
3880
  param_sym->refs++;
3881
  param_sym->attr.dummy = 1;
3882
  param_sym->attr.use_assoc = 1;
3883
 
3884
  /* Integer array, rank 1, describing the shape of the object.  Make it's
3885
     type BT_VOID initially so we can accept any type/kind combination of
3886
     integer.  During gfc_iso_c_sub_interface (resolve.c), we'll make it
3887
     of BT_INTEGER type.  */
3888
  param_sym->ts.type = BT_VOID;
3889
 
3890
  /* Initialize the kind to default integer.  However, it will be overridden
3891
     during resolution to match the kind of the SHAPE parameter given as
3892
     the actual argument (to allow for any valid integer kind).  */
3893
  param_sym->ts.kind = gfc_default_integer_kind;
3894
  param_sym->as = gfc_get_array_spec ();
3895
 
3896
  /* Clear out the dimension info for the array.  */
3897
  for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3898
    {
3899
      param_sym->as->lower[i] = NULL;
3900
      param_sym->as->upper[i] = NULL;
3901
    }
3902
  param_sym->as->rank = 1;
3903
  param_sym->as->lower[0] = gfc_int_expr (1);
3904
 
3905
  /* The extent is unknown until we get it.  The length give us
3906
     the rank the incoming pointer.  */
3907
  param_sym->as->type = AS_ASSUMED_SHAPE;
3908
 
3909
  /* The arg is also optional; it is required iff the second arg
3910
     (fptr) is to an array, otherwise, it's ignored.  */
3911
  param_sym->attr.optional = 1;
3912
  param_sym->attr.intent = INTENT_IN;
3913
  param_sym->attr.dimension = 1;
3914
  param_sym->module = gfc_get_string (module_name);
3915
 
3916
  /* Make the arg.  */
3917
  formal_arg = gfc_get_formal_arglist ();
3918
  /* Add arg to list of formal args.  */
3919
  add_formal_arg (head, tail, formal_arg, param_sym);
3920 378 julius
 
3921
  /* Validate changes.  */
3922
  gfc_commit_symbol (param_sym);
3923 285 jeremybenn
}
3924
 
3925
 
3926
/* Add a procedure interface to the given symbol (i.e., store a
3927
   reference to the list of formal arguments).  */
3928
 
3929
static void
3930
add_proc_interface (gfc_symbol *sym, ifsrc source,
3931
                    gfc_formal_arglist *formal)
3932
{
3933
 
3934
  sym->formal = formal;
3935
  sym->attr.if_source = source;
3936
}
3937
 
3938
 
3939
/* Copy the formal args from an existing symbol, src, into a new
3940
   symbol, dest.  New formal args are created, and the description of
3941
   each arg is set according to the existing ones.  This function is
3942
   used when creating procedure declaration variables from a procedure
3943
   declaration statement (see match_proc_decl()) to create the formal
3944
   args based on the args of a given named interface.  */
3945
 
3946
void
3947
gfc_copy_formal_args (gfc_symbol *dest, gfc_symbol *src)
3948
{
3949
  gfc_formal_arglist *head = NULL;
3950
  gfc_formal_arglist *tail = NULL;
3951
  gfc_formal_arglist *formal_arg = NULL;
3952
  gfc_formal_arglist *curr_arg = NULL;
3953
  gfc_formal_arglist *formal_prev = NULL;
3954
  /* Save current namespace so we can change it for formal args.  */
3955
  gfc_namespace *parent_ns = gfc_current_ns;
3956
 
3957
  /* Create a new namespace, which will be the formal ns (namespace
3958
     of the formal args).  */
3959
  gfc_current_ns = gfc_get_namespace (parent_ns, 0);
3960
  gfc_current_ns->proc_name = dest;
3961
 
3962
  for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
3963
    {
3964
      formal_arg = gfc_get_formal_arglist ();
3965
      gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
3966
 
3967
      /* May need to copy more info for the symbol.  */
3968
      formal_arg->sym->attr = curr_arg->sym->attr;
3969
      formal_arg->sym->ts = curr_arg->sym->ts;
3970
      formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
3971
      gfc_copy_formal_args (formal_arg->sym, curr_arg->sym);
3972
 
3973
      /* If this isn't the first arg, set up the next ptr.  For the
3974
        last arg built, the formal_arg->next will never get set to
3975
        anything other than NULL.  */
3976
      if (formal_prev != NULL)
3977
        formal_prev->next = formal_arg;
3978
      else
3979
        formal_arg->next = NULL;
3980
 
3981
      formal_prev = formal_arg;
3982
 
3983
      /* Add arg to list of formal args.  */
3984
      add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
3985 378 julius
 
3986
      /* Validate changes.  */
3987
      gfc_commit_symbol (formal_arg->sym);
3988 285 jeremybenn
    }
3989
 
3990
  /* Add the interface to the symbol.  */
3991
  add_proc_interface (dest, IFSRC_DECL, head);
3992
 
3993
  /* Store the formal namespace information.  */
3994
  if (dest->formal != NULL)
3995
    /* The current ns should be that for the dest proc.  */
3996
    dest->formal_ns = gfc_current_ns;
3997
  /* Restore the current namespace to what it was on entry.  */
3998
  gfc_current_ns = parent_ns;
3999
}
4000
 
4001
 
4002
void
4003
gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src)
4004
{
4005
  gfc_formal_arglist *head = NULL;
4006
  gfc_formal_arglist *tail = NULL;
4007
  gfc_formal_arglist *formal_arg = NULL;
4008
  gfc_intrinsic_arg *curr_arg = NULL;
4009
  gfc_formal_arglist *formal_prev = NULL;
4010
  /* Save current namespace so we can change it for formal args.  */
4011
  gfc_namespace *parent_ns = gfc_current_ns;
4012
 
4013
  /* Create a new namespace, which will be the formal ns (namespace
4014
     of the formal args).  */
4015
  gfc_current_ns = gfc_get_namespace (parent_ns, 0);
4016
  gfc_current_ns->proc_name = dest;
4017
 
4018
  for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
4019
    {
4020
      formal_arg = gfc_get_formal_arglist ();
4021
      gfc_get_symbol (curr_arg->name, gfc_current_ns, &(formal_arg->sym));
4022
 
4023
      /* May need to copy more info for the symbol.  */
4024
      formal_arg->sym->ts = curr_arg->ts;
4025
      formal_arg->sym->attr.optional = curr_arg->optional;
4026
      formal_arg->sym->attr.intent = curr_arg->intent;
4027
      formal_arg->sym->attr.flavor = FL_VARIABLE;
4028
      formal_arg->sym->attr.dummy = 1;
4029
 
4030
      if (formal_arg->sym->ts.type == BT_CHARACTER)
4031
        formal_arg->sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4032
 
4033
      /* If this isn't the first arg, set up the next ptr.  For the
4034
        last arg built, the formal_arg->next will never get set to
4035
        anything other than NULL.  */
4036
      if (formal_prev != NULL)
4037
        formal_prev->next = formal_arg;
4038
      else
4039
        formal_arg->next = NULL;
4040
 
4041
      formal_prev = formal_arg;
4042
 
4043
      /* Add arg to list of formal args.  */
4044
      add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
4045 378 julius
 
4046
      /* Validate changes.  */
4047
      gfc_commit_symbol (formal_arg->sym);
4048 285 jeremybenn
    }
4049
 
4050
  /* Add the interface to the symbol.  */
4051
  add_proc_interface (dest, IFSRC_DECL, head);
4052
 
4053
  /* Store the formal namespace information.  */
4054
  if (dest->formal != NULL)
4055
    /* The current ns should be that for the dest proc.  */
4056
    dest->formal_ns = gfc_current_ns;
4057
  /* Restore the current namespace to what it was on entry.  */
4058
  gfc_current_ns = parent_ns;
4059
}
4060
 
4061
 
4062
void
4063
gfc_copy_formal_args_ppc (gfc_component *dest, gfc_symbol *src)
4064
{
4065
  gfc_formal_arglist *head = NULL;
4066
  gfc_formal_arglist *tail = NULL;
4067
  gfc_formal_arglist *formal_arg = NULL;
4068
  gfc_formal_arglist *curr_arg = NULL;
4069
  gfc_formal_arglist *formal_prev = NULL;
4070
  /* Save current namespace so we can change it for formal args.  */
4071
  gfc_namespace *parent_ns = gfc_current_ns;
4072
 
4073
  /* Create a new namespace, which will be the formal ns (namespace
4074
     of the formal args).  */
4075
  gfc_current_ns = gfc_get_namespace (parent_ns, 0);
4076
  /* TODO: gfc_current_ns->proc_name = dest;*/
4077
 
4078
  for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
4079
    {
4080
      formal_arg = gfc_get_formal_arglist ();
4081
      gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
4082
 
4083
      /* May need to copy more info for the symbol.  */
4084
      formal_arg->sym->attr = curr_arg->sym->attr;
4085
      formal_arg->sym->ts = curr_arg->sym->ts;
4086
      formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
4087
      gfc_copy_formal_args (formal_arg->sym, curr_arg->sym);
4088
 
4089
      /* If this isn't the first arg, set up the next ptr.  For the
4090
        last arg built, the formal_arg->next will never get set to
4091
        anything other than NULL.  */
4092
      if (formal_prev != NULL)
4093
        formal_prev->next = formal_arg;
4094
      else
4095
        formal_arg->next = NULL;
4096
 
4097
      formal_prev = formal_arg;
4098
 
4099
      /* Add arg to list of formal args.  */
4100
      add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
4101 378 julius
 
4102
      /* Validate changes.  */
4103
      gfc_commit_symbol (formal_arg->sym);
4104 285 jeremybenn
    }
4105
 
4106
  /* Add the interface to the symbol.  */
4107
  dest->formal = head;
4108
  dest->attr.if_source = IFSRC_DECL;
4109
 
4110
  /* Store the formal namespace information.  */
4111
  if (dest->formal != NULL)
4112
    /* The current ns should be that for the dest proc.  */
4113
    dest->formal_ns = gfc_current_ns;
4114
  /* Restore the current namespace to what it was on entry.  */
4115
  gfc_current_ns = parent_ns;
4116
}
4117
 
4118
 
4119
/* Builds the parameter list for the iso_c_binding procedure
4120
   c_f_pointer or c_f_procpointer.  The old_sym typically refers to a
4121
   generic version of either the c_f_pointer or c_f_procpointer
4122
   functions.  The new_proc_sym represents a "resolved" version of the
4123
   symbol.  The functions are resolved to match the types of their
4124
   parameters; for example, c_f_pointer(cptr, fptr) would resolve to
4125
   something similar to c_f_pointer_i4 if the type of data object fptr
4126
   pointed to was a default integer.  The actual name of the resolved
4127
   procedure symbol is further mangled with the module name, etc., but
4128
   the idea holds true.  */
4129
 
4130
static void
4131
build_formal_args (gfc_symbol *new_proc_sym,
4132
                   gfc_symbol *old_sym, int add_optional_arg)
4133
{
4134
  gfc_formal_arglist *head = NULL, *tail = NULL;
4135
  gfc_namespace *parent_ns = NULL;
4136
 
4137
  parent_ns = gfc_current_ns;
4138
  /* Create a new namespace, which will be the formal ns (namespace
4139
     of the formal args).  */
4140
  gfc_current_ns = gfc_get_namespace(parent_ns, 0);
4141
  gfc_current_ns->proc_name = new_proc_sym;
4142
 
4143
  /* Generate the params.  */
4144
  if (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
4145
    {
4146
      gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4147
                      gfc_current_ns, "cptr", old_sym->intmod_sym_id);
4148
      gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
4149
                      gfc_current_ns, "fptr", 1);
4150
    }
4151
  else if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
4152
    {
4153
      gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4154
                      gfc_current_ns, "cptr", old_sym->intmod_sym_id);
4155
      gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
4156
                      gfc_current_ns, "fptr", 0);
4157
      /* If we're dealing with c_f_pointer, it has an optional third arg.  */
4158
      gen_shape_param (&head, &tail,(const char *) new_proc_sym->module,
4159
                       gfc_current_ns, "shape");
4160
 
4161
    }
4162
  else if (old_sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
4163
    {
4164
      /* c_associated has one required arg and one optional; both
4165
         are c_ptrs.  */
4166
      gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4167
                      gfc_current_ns, "c_ptr_1", ISOCBINDING_ASSOCIATED);
4168
      if (add_optional_arg)
4169
        {
4170
          gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4171
                          gfc_current_ns, "c_ptr_2", ISOCBINDING_ASSOCIATED);
4172
          /* The last param is optional so mark it as such.  */
4173
          tail->sym->attr.optional = 1;
4174
        }
4175
    }
4176
 
4177
  /* Add the interface (store formal args to new_proc_sym).  */
4178
  add_proc_interface (new_proc_sym, IFSRC_DECL, head);
4179
 
4180
  /* Set up the formal_ns pointer to the one created for the
4181
     new procedure so it'll get cleaned up during gfc_free_symbol().  */
4182
  new_proc_sym->formal_ns = gfc_current_ns;
4183
 
4184
  gfc_current_ns = parent_ns;
4185
}
4186
 
4187
static int
4188
std_for_isocbinding_symbol (int id)
4189
{
4190
  switch (id)
4191
    {
4192
#define NAMED_INTCST(a,b,c,d) \
4193
      case a:\
4194
        return d;
4195
#include "iso-c-binding.def"
4196
#undef NAMED_INTCST
4197
       default:
4198
         return GFC_STD_F2003;
4199
    }
4200
}
4201
 
4202
/* Generate the given set of C interoperable kind objects, or all
4203
   interoperable kinds.  This function will only be given kind objects
4204
   for valid iso_c_binding defined types because this is verified when
4205
   the 'use' statement is parsed.  If the user gives an 'only' clause,
4206
   the specific kinds are looked up; if they don't exist, an error is
4207
   reported.  If the user does not give an 'only' clause, all
4208
   iso_c_binding symbols are generated.  If a list of specific kinds
4209
   is given, it must have a NULL in the first empty spot to mark the
4210
   end of the list.  */
4211
 
4212
 
4213
void
4214
generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
4215
                             const char *local_name)
4216
{
4217
  const char *const name = (local_name && local_name[0]) ? local_name
4218
                                             : c_interop_kinds_table[s].name;
4219
  gfc_symtree *tmp_symtree = NULL;
4220
  gfc_symbol *tmp_sym = NULL;
4221
  gfc_dt_list **dt_list_ptr = NULL;
4222
  gfc_component *tmp_comp = NULL;
4223
  char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1];
4224
  int index;
4225
 
4226
  if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR)
4227
    return;
4228
  tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
4229
 
4230
  /* Already exists in this scope so don't re-add it.
4231
     TODO: we should probably check that it's really the same symbol.  */
4232
  if (tmp_symtree != NULL)
4233
    return;
4234
 
4235
  /* Create the sym tree in the current ns.  */
4236
  gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
4237
  if (tmp_symtree)
4238
    tmp_sym = tmp_symtree->n.sym;
4239
  else
4240
    gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4241
                        "create symbol");
4242
 
4243
  /* Say what module this symbol belongs to.  */
4244
  tmp_sym->module = gfc_get_string (mod_name);
4245
  tmp_sym->from_intmod = INTMOD_ISO_C_BINDING;
4246
  tmp_sym->intmod_sym_id = s;
4247
 
4248
  switch (s)
4249
    {
4250
 
4251
#define NAMED_INTCST(a,b,c,d) case a : 
4252
#define NAMED_REALCST(a,b,c) case a :
4253
#define NAMED_CMPXCST(a,b,c) case a :
4254
#define NAMED_LOGCST(a,b,c) case a :
4255
#define NAMED_CHARKNDCST(a,b,c) case a :
4256
#include "iso-c-binding.def"
4257
 
4258
        tmp_sym->value = gfc_int_expr (c_interop_kinds_table[s].value);
4259
 
4260
        /* Initialize an integer constant expression node.  */
4261
        tmp_sym->attr.flavor = FL_PARAMETER;
4262
        tmp_sym->ts.type = BT_INTEGER;
4263
        tmp_sym->ts.kind = gfc_default_integer_kind;
4264
 
4265
        /* Mark this type as a C interoperable one.  */
4266
        tmp_sym->ts.is_c_interop = 1;
4267
        tmp_sym->ts.is_iso_c = 1;
4268
        tmp_sym->value->ts.is_c_interop = 1;
4269
        tmp_sym->value->ts.is_iso_c = 1;
4270
        tmp_sym->attr.is_c_interop = 1;
4271
 
4272
        /* Tell what f90 type this c interop kind is valid.  */
4273
        tmp_sym->ts.f90_type = c_interop_kinds_table[s].f90_type;
4274
 
4275
        /* Say it's from the iso_c_binding module.  */
4276
        tmp_sym->attr.is_iso_c = 1;
4277
 
4278
        /* Make it use associated.  */
4279
        tmp_sym->attr.use_assoc = 1;
4280
        break;
4281
 
4282
 
4283
#define NAMED_CHARCST(a,b,c) case a :
4284
#include "iso-c-binding.def"
4285
 
4286
        /* Initialize an integer constant expression node for the
4287
           length of the character.  */
4288
        tmp_sym->value = gfc_get_expr ();
4289
        tmp_sym->value->expr_type = EXPR_CONSTANT;
4290
        tmp_sym->value->ts.type = BT_CHARACTER;
4291
        tmp_sym->value->ts.kind = gfc_default_character_kind;
4292
        tmp_sym->value->where = gfc_current_locus;
4293
        tmp_sym->value->ts.is_c_interop = 1;
4294
        tmp_sym->value->ts.is_iso_c = 1;
4295
        tmp_sym->value->value.character.length = 1;
4296
        tmp_sym->value->value.character.string = gfc_get_wide_string (2);
4297
        tmp_sym->value->value.character.string[0]
4298
          = (gfc_char_t) c_interop_kinds_table[s].value;
4299
        tmp_sym->value->value.character.string[1] = '\0';
4300
        tmp_sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4301
        tmp_sym->ts.u.cl->length = gfc_int_expr (1);
4302
 
4303
        /* May not need this in both attr and ts, but do need in
4304
           attr for writing module file.  */
4305
        tmp_sym->attr.is_c_interop = 1;
4306
 
4307
        tmp_sym->attr.flavor = FL_PARAMETER;
4308
        tmp_sym->ts.type = BT_CHARACTER;
4309
 
4310
        /* Need to set it to the C_CHAR kind.  */
4311
        tmp_sym->ts.kind = gfc_default_character_kind;
4312
 
4313
        /* Mark this type as a C interoperable one.  */
4314
        tmp_sym->ts.is_c_interop = 1;
4315
        tmp_sym->ts.is_iso_c = 1;
4316
 
4317
        /* Tell what f90 type this c interop kind is valid.  */
4318
        tmp_sym->ts.f90_type = BT_CHARACTER;
4319
 
4320
        /* Say it's from the iso_c_binding module.  */
4321
        tmp_sym->attr.is_iso_c = 1;
4322
 
4323
        /* Make it use associated.  */
4324
        tmp_sym->attr.use_assoc = 1;
4325
        break;
4326
 
4327
      case ISOCBINDING_PTR:
4328
      case ISOCBINDING_FUNPTR:
4329
 
4330
        /* Initialize an integer constant expression node.  */
4331
        tmp_sym->attr.flavor = FL_DERIVED;
4332
        tmp_sym->ts.is_c_interop = 1;
4333
        tmp_sym->attr.is_c_interop = 1;
4334
        tmp_sym->attr.is_iso_c = 1;
4335
        tmp_sym->ts.is_iso_c = 1;
4336
        tmp_sym->ts.type = BT_DERIVED;
4337
 
4338
        /* A derived type must have the bind attribute to be
4339
           interoperable (J3/04-007, Section 15.2.3), even though
4340
           the binding label is not used.  */
4341
        tmp_sym->attr.is_bind_c = 1;
4342
 
4343
        tmp_sym->attr.referenced = 1;
4344
 
4345
        tmp_sym->ts.u.derived = tmp_sym;
4346
 
4347
        /* Add the symbol created for the derived type to the current ns.  */
4348
        dt_list_ptr = &(gfc_derived_types);
4349
        while (*dt_list_ptr != NULL && (*dt_list_ptr)->next != NULL)
4350
          dt_list_ptr = &((*dt_list_ptr)->next);
4351
 
4352
        /* There is already at least one derived type in the list, so append
4353
           the one we're currently building for c_ptr or c_funptr.  */
4354
        if (*dt_list_ptr != NULL)
4355
          dt_list_ptr = &((*dt_list_ptr)->next);
4356
        (*dt_list_ptr) = gfc_get_dt_list ();
4357
        (*dt_list_ptr)->derived = tmp_sym;
4358
        (*dt_list_ptr)->next = NULL;
4359
 
4360
        /* Set up the component of the derived type, which will be
4361
           an integer with kind equal to c_ptr_size.  Mangle the name of
4362
           the field for the c_address to prevent the curious user from
4363
           trying to access it from Fortran.  */
4364
        sprintf (comp_name, "__%s_%s", tmp_sym->name, "c_address");
4365
        gfc_add_component (tmp_sym, comp_name, &tmp_comp);
4366
        if (tmp_comp == NULL)
4367
          gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4368
                              "create component for c_address");
4369
 
4370
        tmp_comp->ts.type = BT_INTEGER;
4371
 
4372
        /* Set this because the module will need to read/write this field.  */
4373
        tmp_comp->ts.f90_type = BT_INTEGER;
4374
 
4375
        /* The kinds for c_ptr and c_funptr are the same.  */
4376
        index = get_c_kind ("c_ptr", c_interop_kinds_table);
4377
        tmp_comp->ts.kind = c_interop_kinds_table[index].value;
4378
 
4379
        tmp_comp->attr.pointer = 0;
4380
        tmp_comp->attr.dimension = 0;
4381
 
4382
        /* Mark the component as C interoperable.  */
4383
        tmp_comp->ts.is_c_interop = 1;
4384
 
4385
        /* Make it use associated (iso_c_binding module).  */
4386
        tmp_sym->attr.use_assoc = 1;
4387
        break;
4388
 
4389
      case ISOCBINDING_NULL_PTR:
4390
      case ISOCBINDING_NULL_FUNPTR:
4391
        gen_special_c_interop_ptr (s, name, mod_name);
4392
        break;
4393
 
4394
      case ISOCBINDING_F_POINTER:
4395
      case ISOCBINDING_ASSOCIATED:
4396
      case ISOCBINDING_LOC:
4397
      case ISOCBINDING_FUNLOC:
4398
      case ISOCBINDING_F_PROCPOINTER:
4399
 
4400
        tmp_sym->attr.proc = PROC_MODULE;
4401
 
4402
        /* Use the procedure's name as it is in the iso_c_binding module for
4403
           setting the binding label in case the user renamed the symbol.  */
4404
        sprintf (tmp_sym->binding_label, "%s_%s", mod_name,
4405
                 c_interop_kinds_table[s].name);
4406
        tmp_sym->attr.is_iso_c = 1;
4407
        if (s == ISOCBINDING_F_POINTER || s == ISOCBINDING_F_PROCPOINTER)
4408
          tmp_sym->attr.subroutine = 1;
4409
        else
4410
          {
4411
            /* TODO!  This needs to be finished more for the expr of the
4412
               function or something!
4413
               This may not need to be here, because trying to do c_loc
4414
               as an external.  */
4415
            if (s == ISOCBINDING_ASSOCIATED)
4416
              {
4417
                tmp_sym->attr.function = 1;
4418
                tmp_sym->ts.type = BT_LOGICAL;
4419
                tmp_sym->ts.kind = gfc_default_logical_kind;
4420
                tmp_sym->result = tmp_sym;
4421
              }
4422
            else
4423
              {
4424
               /* Here, we're taking the simple approach.  We're defining
4425
                  c_loc as an external identifier so the compiler will put
4426
                  what we expect on the stack for the address we want the
4427
                  C address of.  */
4428
                tmp_sym->ts.type = BT_DERIVED;
4429
                if (s == ISOCBINDING_LOC)
4430
                  tmp_sym->ts.u.derived =
4431
                    get_iso_c_binding_dt (ISOCBINDING_PTR);
4432
                else
4433
                  tmp_sym->ts.u.derived =
4434
                    get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
4435
 
4436
                if (tmp_sym->ts.u.derived == NULL)
4437
                  {
4438
                    /* Create the necessary derived type so we can continue
4439
                       processing the file.  */
4440
                    generate_isocbinding_symbol
4441
                      (mod_name, s == ISOCBINDING_FUNLOC
4442
                                 ? ISOCBINDING_FUNPTR : ISOCBINDING_PTR,
4443
                       (const char *)(s == ISOCBINDING_FUNLOC
4444
                                ? "_gfortran_iso_c_binding_c_funptr"
4445
                                : "_gfortran_iso_c_binding_c_ptr"));
4446
                    tmp_sym->ts.u.derived =
4447
                      get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC
4448
                                            ? ISOCBINDING_FUNPTR
4449
                                            : ISOCBINDING_PTR);
4450
                  }
4451
 
4452
                /* The function result is itself (no result clause).  */
4453
                tmp_sym->result = tmp_sym;
4454
                tmp_sym->attr.external = 1;
4455
                tmp_sym->attr.use_assoc = 0;
4456
                tmp_sym->attr.pure = 1;
4457
                tmp_sym->attr.if_source = IFSRC_UNKNOWN;
4458
                tmp_sym->attr.proc = PROC_UNKNOWN;
4459
              }
4460
          }
4461
 
4462
        tmp_sym->attr.flavor = FL_PROCEDURE;
4463
        tmp_sym->attr.contained = 0;
4464
 
4465
       /* Try using this builder routine, with the new and old symbols
4466
          both being the generic iso_c proc sym being created.  This
4467
          will create the formal args (and the new namespace for them).
4468
          Don't build an arg list for c_loc because we're going to treat
4469
          c_loc as an external procedure.  */
4470
        if (s != ISOCBINDING_LOC && s != ISOCBINDING_FUNLOC)
4471
          /* The 1 says to add any optional args, if applicable.  */
4472
          build_formal_args (tmp_sym, tmp_sym, 1);
4473
 
4474
        /* Set this after setting up the symbol, to prevent error messages.  */
4475
        tmp_sym->attr.use_assoc = 1;
4476
 
4477
        /* This symbol will not be referenced directly.  It will be
4478
           resolved to the implementation for the given f90 kind.  */
4479
        tmp_sym->attr.referenced = 0;
4480
 
4481
        break;
4482
 
4483
      default:
4484
        gcc_unreachable ();
4485
    }
4486 378 julius
  gfc_commit_symbol (tmp_sym);
4487 285 jeremybenn
}
4488
 
4489
 
4490
/* Creates a new symbol based off of an old iso_c symbol, with a new
4491
   binding label.  This function can be used to create a new,
4492
   resolved, version of a procedure symbol for c_f_pointer or
4493
   c_f_procpointer that is based on the generic symbols.  A new
4494
   parameter list is created for the new symbol using
4495
   build_formal_args().  The add_optional_flag specifies whether the
4496
   to add the optional SHAPE argument.  The new symbol is
4497
   returned.  */
4498
 
4499
gfc_symbol *
4500
get_iso_c_sym (gfc_symbol *old_sym, char *new_name,
4501
               char *new_binding_label, int add_optional_arg)
4502
{
4503
  gfc_symtree *new_symtree = NULL;
4504
 
4505
  /* See if we have a symbol by that name already available, looking
4506
     through any parent namespaces.  */
4507
  gfc_find_sym_tree (new_name, gfc_current_ns, 1, &new_symtree);
4508
  if (new_symtree != NULL)
4509
    /* Return the existing symbol.  */
4510
    return new_symtree->n.sym;
4511
 
4512
  /* Create the symtree/symbol, with attempted host association.  */
4513
  gfc_get_ha_sym_tree (new_name, &new_symtree);
4514
  if (new_symtree == NULL)
4515
    gfc_internal_error ("get_iso_c_sym(): Unable to create "
4516
                        "symtree for '%s'", new_name);
4517
 
4518
  /* Now fill in the fields of the resolved symbol with the old sym.  */
4519
  strcpy (new_symtree->n.sym->binding_label, new_binding_label);
4520
  new_symtree->n.sym->attr = old_sym->attr;
4521
  new_symtree->n.sym->ts = old_sym->ts;
4522
  new_symtree->n.sym->module = gfc_get_string (old_sym->module);
4523
  new_symtree->n.sym->from_intmod = old_sym->from_intmod;
4524
  new_symtree->n.sym->intmod_sym_id = old_sym->intmod_sym_id;
4525
  if (old_sym->attr.function)
4526
    new_symtree->n.sym->result = new_symtree->n.sym;
4527
  /* Build the formal arg list.  */
4528
  build_formal_args (new_symtree->n.sym, old_sym, add_optional_arg);
4529
 
4530
  gfc_commit_symbol (new_symtree->n.sym);
4531
 
4532
  return new_symtree->n.sym;
4533
}
4534
 
4535
 
4536
/* Check that a symbol is already typed.  If strict is not set, an untyped
4537
   symbol is acceptable for non-standard-conforming mode.  */
4538
 
4539
gfc_try
4540
gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns,
4541
                        bool strict, locus where)
4542
{
4543
  gcc_assert (sym);
4544
 
4545
  if (gfc_matching_prefix)
4546
    return SUCCESS;
4547
 
4548
  /* Check for the type and try to give it an implicit one.  */
4549
  if (sym->ts.type == BT_UNKNOWN
4550
      && gfc_set_default_type (sym, 0, ns) == FAILURE)
4551
    {
4552
      if (strict)
4553
        {
4554
          gfc_error ("Symbol '%s' is used before it is typed at %L",
4555
                     sym->name, &where);
4556
          return FAILURE;
4557
        }
4558
 
4559
      if (gfc_notify_std (GFC_STD_GNU,
4560
                          "Extension: Symbol '%s' is used before"
4561
                          " it is typed at %L", sym->name, &where) == FAILURE)
4562
        return FAILURE;
4563
    }
4564
 
4565
  /* Everything is ok.  */
4566
  return SUCCESS;
4567
}
4568
 
4569
 
4570
/* Construct a typebound-procedure structure.  Those are stored in a tentative
4571
   list and marked `error' until symbols are committed.  */
4572
 
4573
gfc_typebound_proc*
4574
gfc_get_typebound_proc (void)
4575
{
4576
  gfc_typebound_proc *result;
4577
  tentative_tbp *list_node;
4578
 
4579
  result = XCNEW (gfc_typebound_proc);
4580
  result->error = 1;
4581
 
4582
  list_node = XCNEW (tentative_tbp);
4583
  list_node->next = tentative_tbp_list;
4584
  list_node->proc = result;
4585
  tentative_tbp_list = list_node;
4586
 
4587
  return result;
4588
}
4589
 
4590
 
4591
/* Get the super-type of a given derived type.  */
4592
 
4593
gfc_symbol*
4594
gfc_get_derived_super_type (gfc_symbol* derived)
4595
{
4596
  if (!derived->attr.extension)
4597
    return NULL;
4598
 
4599
  gcc_assert (derived->components);
4600
  gcc_assert (derived->components->ts.type == BT_DERIVED);
4601
  gcc_assert (derived->components->ts.u.derived);
4602
 
4603
  return derived->components->ts.u.derived;
4604
}
4605
 
4606
 
4607
/* Get the ultimate super-type of a given derived type.  */
4608
 
4609
gfc_symbol*
4610
gfc_get_ultimate_derived_super_type (gfc_symbol* derived)
4611
{
4612
  if (!derived->attr.extension)
4613
    return NULL;
4614
 
4615
  derived = gfc_get_derived_super_type (derived);
4616
 
4617
  if (derived->attr.extension)
4618
    return gfc_get_ultimate_derived_super_type (derived);
4619
  else
4620
    return derived;
4621
}
4622
 
4623
 
4624
/* Check if a derived type t2 is an extension of (or equal to) a type t1.  */
4625
 
4626
bool
4627
gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2)
4628
{
4629
  while (!gfc_compare_derived_types (t1, t2) && t2->attr.extension)
4630
    t2 = gfc_get_derived_super_type (t2);
4631
  return gfc_compare_derived_types (t1, t2);
4632
}
4633
 
4634
 
4635
/* Check if two typespecs are type compatible (F03:5.1.1.2):
4636
   If ts1 is nonpolymorphic, ts2 must be the same type.
4637
   If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1.  */
4638
 
4639
bool
4640
gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
4641
{
4642
  gfc_component *cmp1, *cmp2;
4643
 
4644
  bool is_class1 = (ts1->type == BT_CLASS);
4645
  bool is_class2 = (ts2->type == BT_CLASS);
4646
  bool is_derived1 = (ts1->type == BT_DERIVED);
4647
  bool is_derived2 = (ts2->type == BT_DERIVED);
4648
 
4649
  if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2)
4650
    return (ts1->type == ts2->type);
4651
 
4652
  if (is_derived1 && is_derived2)
4653
    return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
4654
 
4655
  cmp1 = cmp2 = NULL;
4656
 
4657
  if (is_class1)
4658
    {
4659
      cmp1 = gfc_find_component (ts1->u.derived, "$data", true, false);
4660
      if (cmp1 == NULL)
4661
        return 0;
4662
    }
4663
 
4664
  if (is_class2)
4665
    {
4666
      cmp2 = gfc_find_component (ts2->u.derived, "$data", true, false);
4667
      if (cmp2 == NULL)
4668
        return 0;
4669
    }
4670
 
4671
  if (is_class1 && is_derived2)
4672
    return gfc_type_is_extension_of (cmp1->ts.u.derived, ts2->u.derived);
4673
 
4674
  else if (is_class1 && is_class2)
4675
    return gfc_type_is_extension_of (cmp1->ts.u.derived, cmp2->ts.u.derived);
4676
 
4677
  else
4678
    return 0;
4679
}
4680
 
4681
 
4682
/* Build a polymorphic CLASS entity, using the symbol that comes from
4683
   build_sym. A CLASS entity is represented by an encapsulating type,
4684
   which contains the declared type as '$data' component, plus a pointer
4685
   component '$vptr' which determines the dynamic type.  */
4686
 
4687
gfc_try
4688
gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
4689
                        gfc_array_spec **as)
4690
{
4691
  char name[GFC_MAX_SYMBOL_LEN + 5];
4692
  gfc_symbol *fclass;
4693
  gfc_symbol *vtab;
4694
  gfc_component *c;
4695
 
4696
  /* Determine the name of the encapsulating type.  */
4697
  if ((*as) && (*as)->rank && attr->allocatable)
4698
    sprintf (name, ".class.%s.%d.a", ts->u.derived->name, (*as)->rank);
4699
  else if ((*as) && (*as)->rank)
4700
    sprintf (name, ".class.%s.%d", ts->u.derived->name, (*as)->rank);
4701
  else if (attr->allocatable)
4702
    sprintf (name, ".class.%s.a", ts->u.derived->name);
4703
  else
4704
    sprintf (name, ".class.%s", ts->u.derived->name);
4705
 
4706
  gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass);
4707
  if (fclass == NULL)
4708
    {
4709
      gfc_symtree *st;
4710
      /* If not there, create a new symbol.  */
4711
      fclass = gfc_new_symbol (name, ts->u.derived->ns);
4712
      st = gfc_new_symtree (&ts->u.derived->ns->sym_root, name);
4713
      st->n.sym = fclass;
4714
      gfc_set_sym_referenced (fclass);
4715
      fclass->refs++;
4716
      fclass->ts.type = BT_UNKNOWN;
4717
      fclass->attr.abstract = ts->u.derived->attr.abstract;
4718
      if (ts->u.derived->f2k_derived)
4719
        fclass->f2k_derived = gfc_get_namespace (NULL, 0);
4720
      if (gfc_add_flavor (&fclass->attr, FL_DERIVED,
4721
          NULL, &gfc_current_locus) == FAILURE)
4722
        return FAILURE;
4723
 
4724
      /* Add component '$data'.  */
4725
      if (gfc_add_component (fclass, "$data", &c) == FAILURE)
4726
        return FAILURE;
4727
      c->ts = *ts;
4728
      c->ts.type = BT_DERIVED;
4729
      c->attr.access = ACCESS_PRIVATE;
4730
      c->ts.u.derived = ts->u.derived;
4731
      c->attr.class_pointer = attr->pointer;
4732
      c->attr.pointer = attr->pointer || attr->dummy;
4733
      c->attr.allocatable = attr->allocatable;
4734
      c->attr.dimension = attr->dimension;
4735
      c->attr.abstract = ts->u.derived->attr.abstract;
4736
      c->as = (*as);
4737
      c->initializer = gfc_get_expr ();
4738
      c->initializer->expr_type = EXPR_NULL;
4739
 
4740
      /* Add component '$vptr'.  */
4741
      if (gfc_add_component (fclass, "$vptr", &c) == FAILURE)
4742
        return FAILURE;
4743
      c->ts.type = BT_DERIVED;
4744
      vtab = gfc_find_derived_vtab (ts->u.derived);
4745
      gcc_assert (vtab);
4746
      c->ts.u.derived = vtab->ts.u.derived;
4747
      c->attr.pointer = 1;
4748
      c->initializer = gfc_get_expr ();
4749
      c->initializer->expr_type = EXPR_NULL;
4750
    }
4751
 
4752
  /* Since the extension field is 8 bit wide, we can only have
4753
     up to 255 extension levels.  */
4754
  if (ts->u.derived->attr.extension == 255)
4755
    {
4756
      gfc_error ("Maximum extension level reached with type '%s' at %L",
4757
                 ts->u.derived->name, &ts->u.derived->declared_at);
4758
      return FAILURE;
4759
    }
4760
 
4761
  fclass->attr.extension = ts->u.derived->attr.extension + 1;
4762
  fclass->attr.is_class = 1;
4763
  ts->u.derived = fclass;
4764
  attr->allocatable = attr->pointer = attr->dimension = 0;
4765
  (*as) = NULL;  /* XXX */
4766
  return SUCCESS;
4767
}
4768
 
4769
 
4770
/* Find the symbol for a derived type's vtab.  */
4771
 
4772
gfc_symbol *
4773
gfc_find_derived_vtab (gfc_symbol *derived)
4774
{
4775
  gfc_namespace *ns;
4776
  gfc_symbol *vtab = NULL, *vtype = NULL;
4777
  char name[2 * GFC_MAX_SYMBOL_LEN + 8];
4778
 
4779
  ns = gfc_current_ns;
4780
 
4781
  for (; ns; ns = ns->parent)
4782
    if (!ns->parent)
4783
      break;
4784
 
4785
  if (ns)
4786
    {
4787
      sprintf (name, "vtab$%s", derived->name);
4788
      gfc_find_symbol (name, ns, 0, &vtab);
4789
 
4790
      if (vtab == NULL)
4791
        {
4792
          gfc_get_symbol (name, ns, &vtab);
4793
          vtab->ts.type = BT_DERIVED;
4794
          vtab->attr.flavor = FL_VARIABLE;
4795
          vtab->attr.target = 1;
4796
          vtab->attr.save = SAVE_EXPLICIT;
4797
          vtab->attr.vtab = 1;
4798
          vtab->attr.access = ACCESS_PRIVATE;
4799
          vtab->refs++;
4800
          gfc_set_sym_referenced (vtab);
4801
          sprintf (name, "vtype$%s", derived->name);
4802
 
4803
          gfc_find_symbol (name, ns, 0, &vtype);
4804
          if (vtype == NULL)
4805
            {
4806
              gfc_component *c;
4807
              gfc_symbol *parent = NULL, *parent_vtab = NULL;
4808
 
4809
              gfc_get_symbol (name, ns, &vtype);
4810
              if (gfc_add_flavor (&vtype->attr, FL_DERIVED,
4811
                                  NULL, &gfc_current_locus) == FAILURE)
4812
                return NULL;
4813
              vtype->refs++;
4814
              gfc_set_sym_referenced (vtype);
4815
              vtype->attr.access = ACCESS_PRIVATE;
4816
 
4817
              /* Add component '$hash'.  */
4818
              if (gfc_add_component (vtype, "$hash", &c) == FAILURE)
4819
                return NULL;
4820
              c->ts.type = BT_INTEGER;
4821
              c->ts.kind = 4;
4822
              c->attr.access = ACCESS_PRIVATE;
4823
              c->initializer = gfc_int_expr (derived->hash_value);
4824
 
4825
              /* Add component '$size'.  */
4826
              if (gfc_add_component (vtype, "$size", &c) == FAILURE)
4827
                return NULL;
4828
              c->ts.type = BT_INTEGER;
4829
              c->ts.kind = 4;
4830
              c->attr.access = ACCESS_PRIVATE;
4831
              /* Remember the derived type in ts.u.derived,
4832
                 so that the correct initializer can be set later on
4833
                 (in gfc_conv_structure).  */
4834
              c->ts.u.derived = derived;
4835
              c->initializer = gfc_int_expr (0);
4836
 
4837
              /* Add component $extends.  */
4838
              if (gfc_add_component (vtype, "$extends", &c) == FAILURE)
4839
                return NULL;
4840
              c->attr.pointer = 1;
4841
              c->attr.access = ACCESS_PRIVATE;
4842
              c->initializer = gfc_get_expr ();
4843
              parent = gfc_get_derived_super_type (derived);
4844
              if (parent)
4845
                {
4846
                  parent_vtab = gfc_find_derived_vtab (parent);
4847
                  c->ts.type = BT_DERIVED;
4848
                  c->ts.u.derived = parent_vtab->ts.u.derived;
4849
                  c->initializer->expr_type = EXPR_VARIABLE;
4850
                  gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns, 0,
4851
                                     &c->initializer->symtree);
4852
                }
4853
              else
4854
                {
4855
                  c->ts.type = BT_DERIVED;
4856
                  c->ts.u.derived = vtype;
4857
                  c->initializer->expr_type = EXPR_NULL;
4858
                }
4859 378 julius
              gfc_commit_symbol (vtype);
4860 285 jeremybenn
            }
4861
          vtab->ts.u.derived = vtype;
4862
 
4863
          vtab->value = gfc_default_initializer (&vtab->ts);
4864 378 julius
          gfc_commit_symbol (vtab);
4865 285 jeremybenn
        }
4866
    }
4867
 
4868
  return vtab;
4869
}
4870
 
4871
 
4872
/* General worker function to find either a type-bound procedure or a
4873
   type-bound user operator.  */
4874
 
4875
static gfc_symtree*
4876
find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t,
4877
                         const char* name, bool noaccess, bool uop,
4878
                         locus* where)
4879
{
4880
  gfc_symtree* res;
4881
  gfc_symtree* root;
4882
 
4883
  /* Set correct symbol-root.  */
4884
  gcc_assert (derived->f2k_derived);
4885
  root = (uop ? derived->f2k_derived->tb_uop_root
4886
              : derived->f2k_derived->tb_sym_root);
4887
 
4888
  /* Set default to failure.  */
4889
  if (t)
4890
    *t = FAILURE;
4891
 
4892
  /* Try to find it in the current type's namespace.  */
4893
  res = gfc_find_symtree (root, name);
4894
  if (res && res->n.tb && !res->n.tb->error)
4895
    {
4896
      /* We found one.  */
4897
      if (t)
4898
        *t = SUCCESS;
4899
 
4900
      if (!noaccess && derived->attr.use_assoc
4901
          && res->n.tb->access == ACCESS_PRIVATE)
4902
        {
4903
          if (where)
4904
            gfc_error ("'%s' of '%s' is PRIVATE at %L",
4905
                       name, derived->name, where);
4906
          if (t)
4907
            *t = FAILURE;
4908
        }
4909
 
4910
      return res;
4911
    }
4912
 
4913
  /* Otherwise, recurse on parent type if derived is an extension.  */
4914
  if (derived->attr.extension)
4915
    {
4916
      gfc_symbol* super_type;
4917
      super_type = gfc_get_derived_super_type (derived);
4918
      gcc_assert (super_type);
4919
 
4920
      return find_typebound_proc_uop (super_type, t, name,
4921
                                      noaccess, uop, where);
4922
    }
4923
 
4924
  /* Nothing found.  */
4925
  return NULL;
4926
}
4927
 
4928
 
4929
/* Find a type-bound procedure or user operator by name for a derived-type
4930
   (looking recursively through the super-types).  */
4931
 
4932
gfc_symtree*
4933
gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
4934
                         const char* name, bool noaccess, locus* where)
4935
{
4936
  return find_typebound_proc_uop (derived, t, name, noaccess, false, where);
4937
}
4938
 
4939
gfc_symtree*
4940
gfc_find_typebound_user_op (gfc_symbol* derived, gfc_try* t,
4941
                            const char* name, bool noaccess, locus* where)
4942
{
4943
  return find_typebound_proc_uop (derived, t, name, noaccess, true, where);
4944
}
4945
 
4946
 
4947
/* Find a type-bound intrinsic operator looking recursively through the
4948
   super-type hierarchy.  */
4949
 
4950
gfc_typebound_proc*
4951
gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t,
4952
                                 gfc_intrinsic_op op, bool noaccess,
4953
                                 locus* where)
4954
{
4955
  gfc_typebound_proc* res;
4956
 
4957
  /* Set default to failure.  */
4958
  if (t)
4959
    *t = FAILURE;
4960
 
4961
  /* Try to find it in the current type's namespace.  */
4962
  if (derived->f2k_derived)
4963
    res = derived->f2k_derived->tb_op[op];
4964
  else
4965
    res = NULL;
4966
 
4967
  /* Check access.  */
4968
  if (res && !res->error)
4969
    {
4970
      /* We found one.  */
4971
      if (t)
4972
        *t = SUCCESS;
4973
 
4974
      if (!noaccess && derived->attr.use_assoc
4975
          && res->access == ACCESS_PRIVATE)
4976
        {
4977
          if (where)
4978
            gfc_error ("'%s' of '%s' is PRIVATE at %L",
4979
                       gfc_op2string (op), derived->name, where);
4980
          if (t)
4981
            *t = FAILURE;
4982
        }
4983
 
4984
      return res;
4985
    }
4986
 
4987
  /* Otherwise, recurse on parent type if derived is an extension.  */
4988
  if (derived->attr.extension)
4989
    {
4990
      gfc_symbol* super_type;
4991
      super_type = gfc_get_derived_super_type (derived);
4992
      gcc_assert (super_type);
4993
 
4994
      return gfc_find_typebound_intrinsic_op (super_type, t, op,
4995
                                              noaccess, where);
4996
    }
4997
 
4998
  /* Nothing found.  */
4999
  return NULL;
5000
}
5001
 
5002
 
5003
/* Get a typebound-procedure symtree or create and insert it if not yet
5004
   present.  This is like a very simplified version of gfc_get_sym_tree for
5005
   tbp-symtrees rather than regular ones.  */
5006
 
5007
gfc_symtree*
5008
gfc_get_tbp_symtree (gfc_symtree **root, const char *name)
5009
{
5010
  gfc_symtree *result;
5011
 
5012
  result = gfc_find_symtree (*root, name);
5013
  if (!result)
5014
    {
5015
      result = gfc_new_symtree (root, name);
5016
      gcc_assert (result);
5017
      result->n.tb = NULL;
5018
    }
5019
 
5020
  return result;
5021
}

powered by: WebSVN 2.1.0

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