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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [fortran/] [class.c] - Blame information for rev 713

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

Line No. Rev Author Line
1 712 jeremybenn
/* Implementation of Fortran 2003 Polymorphism.
2
   Copyright (C) 2009, 2010
3
   Free Software Foundation, Inc.
4
   Contributed by Paul Richard Thomas <pault@gcc.gnu.org>
5
   and Janus Weil <janus@gcc.gnu.org>
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
/* class.c -- This file contains the front end functions needed to service
25
              the implementation of Fortran 2003 polymorphism and other
26
              object-oriented features.  */
27
 
28
 
29
/* Outline of the internal representation:
30
 
31
   Each CLASS variable is encapsulated by a class container, which is a
32
   structure with two fields:
33
    * _data: A pointer to the actual data of the variable. This field has the
34
             declared type of the class variable and its attributes
35
             (pointer/allocatable/dimension/...).
36
    * _vptr: A pointer to the vtable entry (see below) of the dynamic type.
37
 
38
   For each derived type we set up a "vtable" entry, i.e. a structure with the
39
   following fields:
40
    * _hash:     A hash value serving as a unique identifier for this type.
41
    * _size:     The size in bytes of the derived type.
42
    * _extends:  A pointer to the vtable entry of the parent derived type.
43
    * _def_init: A pointer to a default initialized variable of this type.
44
    * _copy:     A procedure pointer to a copying procedure.
45
   After these follow procedure pointer components for the specific
46
   type-bound procedures.  */
47
 
48
 
49
#include "config.h"
50
#include "system.h"
51
#include "gfortran.h"
52
#include "constructor.h"
53
 
54
 
55
/* Inserts a derived type component reference in a data reference chain.
56
    TS: base type of the ref chain so far, in which we will pick the component
57
    REF: the address of the GFC_REF pointer to update
58
    NAME: name of the component to insert
59
   Note that component insertion makes sense only if we are at the end of
60
   the chain (*REF == NULL) or if we are adding a missing "_data" component
61
   to access the actual contents of a class object.  */
62
 
63
static void
64
insert_component_ref (gfc_typespec *ts, gfc_ref **ref, const char * const name)
65
{
66
  gfc_symbol *type_sym;
67
  gfc_ref *new_ref;
68
 
69
  gcc_assert (ts->type == BT_DERIVED || ts->type == BT_CLASS);
70
  type_sym = ts->u.derived;
71
 
72
  new_ref = gfc_get_ref ();
73
  new_ref->type = REF_COMPONENT;
74
  new_ref->next = *ref;
75
  new_ref->u.c.sym = type_sym;
76
  new_ref->u.c.component = gfc_find_component (type_sym, name, true, true);
77
  gcc_assert (new_ref->u.c.component);
78
 
79
  if (new_ref->next)
80
    {
81
      gfc_ref *next = NULL;
82
 
83
      /* We need to update the base type in the trailing reference chain to
84
         that of the new component.  */
85
 
86
      gcc_assert (strcmp (name, "_data") == 0);
87
 
88
      if (new_ref->next->type == REF_COMPONENT)
89
        next = new_ref->next;
90
      else if (new_ref->next->type == REF_ARRAY
91
               && new_ref->next->next
92
               && new_ref->next->next->type == REF_COMPONENT)
93
        next = new_ref->next->next;
94
 
95
      if (next != NULL)
96
        {
97
          gcc_assert (new_ref->u.c.component->ts.type == BT_CLASS
98
                      || new_ref->u.c.component->ts.type == BT_DERIVED);
99
          next->u.c.sym = new_ref->u.c.component->ts.u.derived;
100
        }
101
    }
102
 
103
  *ref = new_ref;
104
}
105
 
106
 
107
/* Tells whether we need to add a "_data" reference to access REF subobject
108
   from an object of type TS.  If FIRST_REF_IN_CHAIN is set, then the base
109
   object accessed by REF is a variable; in other words it is a full object,
110
   not a subobject.  */
111
 
112
static bool
113
class_data_ref_missing (gfc_typespec *ts, gfc_ref *ref, bool first_ref_in_chain)
114
{
115
  /* Only class containers may need the "_data" reference.  */
116
  if (ts->type != BT_CLASS)
117
    return false;
118
 
119
  /* Accessing a class container with an array reference is certainly wrong.  */
120
  if (ref->type != REF_COMPONENT)
121
    return true;
122
 
123
  /* Accessing the class container's fields is fine.  */
124
  if (ref->u.c.component->name[0] == '_')
125
    return false;
126
 
127
  /* At this point we have a class container with a non class container's field
128
     component reference.  We don't want to add the "_data" component if we are
129
     at the first reference and the symbol's type is an extended derived type.
130
     In that case, conv_parent_component_references will do the right thing so
131
     it is not absolutely necessary.  Omitting it prevents a regression (see
132
     class_41.f03) in the interface mapping mechanism.  When evaluating string
133
     lengths depending on dummy arguments, we create a fake symbol with a type
134
     equal to that of the dummy type.  However, because of type extension,
135
     the backend type (corresponding to the actual argument) can have a
136
     different (extended) type.  Adding the "_data" component explicitly, using
137
     the base type, confuses the gfc_conv_component_ref code which deals with
138
     the extended type.  */
139
  if (first_ref_in_chain && ts->u.derived->attr.extension)
140
    return false;
141
 
142
  /* We have a class container with a non class container's field component
143
     reference that doesn't fall into the above.  */
144
  return true;
145
}
146
 
147
 
148
/* Browse through a data reference chain and add the missing "_data" references
149
   when a subobject of a class object is accessed without it.
150
   Note that it doesn't add the "_data" reference when the class container
151
   is the last element in the reference chain.  */
152
 
153
void
154
gfc_fix_class_refs (gfc_expr *e)
155
{
156
  gfc_typespec *ts;
157
  gfc_ref **ref;
158
 
159
  if ((e->expr_type != EXPR_VARIABLE
160
       && e->expr_type != EXPR_FUNCTION)
161
      || (e->expr_type == EXPR_FUNCTION
162
          && e->value.function.isym != NULL))
163
    return;
164
 
165
  ts = &e->symtree->n.sym->ts;
166
 
167
  for (ref = &e->ref; *ref != NULL; ref = &(*ref)->next)
168
    {
169
      if (class_data_ref_missing (ts, *ref, ref == &e->ref))
170
        insert_component_ref (ts, ref, "_data");
171
 
172
      if ((*ref)->type == REF_COMPONENT)
173
        ts = &(*ref)->u.c.component->ts;
174
    }
175
}
176
 
177
 
178
/* Insert a reference to the component of the given name.
179
   Only to be used with CLASS containers and vtables.  */
180
 
181
void
182
gfc_add_component_ref (gfc_expr *e, const char *name)
183
{
184
  gfc_ref **tail = &(e->ref);
185
  gfc_ref *next = NULL;
186
  gfc_symbol *derived = e->symtree->n.sym->ts.u.derived;
187
  while (*tail != NULL)
188
    {
189
      if ((*tail)->type == REF_COMPONENT)
190
        {
191
          if (strcmp ((*tail)->u.c.component->name, "_data") == 0
192
                && (*tail)->next
193
                && (*tail)->next->type == REF_ARRAY
194
                && (*tail)->next->next == NULL)
195
            return;
196
          derived = (*tail)->u.c.component->ts.u.derived;
197
        }
198
      if ((*tail)->type == REF_ARRAY && (*tail)->next == NULL)
199
        break;
200
      tail = &((*tail)->next);
201
    }
202
  if (*tail != NULL && strcmp (name, "_data") == 0)
203
    next = *tail;
204
  (*tail) = gfc_get_ref();
205
  (*tail)->next = next;
206
  (*tail)->type = REF_COMPONENT;
207
  (*tail)->u.c.sym = derived;
208
  (*tail)->u.c.component = gfc_find_component (derived, name, true, true);
209
  gcc_assert((*tail)->u.c.component);
210
  if (!next)
211
    e->ts = (*tail)->u.c.component->ts;
212
}
213
 
214
 
215
/* This is used to add both the _data component reference and an array
216
   reference to class expressions.  Used in translation of intrinsic
217
   array inquiry functions.  */
218
 
219
void
220
gfc_add_class_array_ref (gfc_expr *e)
221
{
222
  int rank =  CLASS_DATA (e)->as->rank;
223
  gfc_array_spec *as = CLASS_DATA (e)->as;
224
  gfc_ref *ref = NULL;
225
  gfc_add_component_ref (e, "_data");
226
  e->rank = rank;
227
  for (ref = e->ref; ref; ref = ref->next)
228
    if (!ref->next)
229
      break;
230
  if (ref->type != REF_ARRAY)
231
    {
232
      ref->next = gfc_get_ref ();
233
      ref = ref->next;
234
      ref->type = REF_ARRAY;
235
      ref->u.ar.type = AR_FULL;
236
      ref->u.ar.as = as;
237
    }
238
}
239
 
240
 
241
/* Unfortunately, class array expressions can appear in various conditions;
242
   with and without both _data component and an arrayspec.  This function
243
   deals with that variability.  The previous reference to 'ref' is to a
244
   class array.  */
245
 
246
static bool
247
class_array_ref_detected (gfc_ref *ref, bool *full_array)
248
{
249
  bool no_data = false;
250
  bool with_data = false;
251
 
252
  /* An array reference with no _data component.  */
253
  if (ref && ref->type == REF_ARRAY
254
        && !ref->next
255
        && ref->u.ar.type != AR_ELEMENT)
256
    {
257
      if (full_array)
258
        *full_array = ref->u.ar.type == AR_FULL;
259
      no_data = true;
260
    }
261
 
262
  /* Cover cases where _data appears, with or without an array ref.  */
263
  if (ref && ref->type == REF_COMPONENT
264
        && strcmp (ref->u.c.component->name, "_data") == 0)
265
    {
266
      if (!ref->next)
267
        {
268
          with_data = true;
269
          if (full_array)
270
            *full_array = true;
271
        }
272
      else if (ref->next && ref->next->type == REF_ARRAY
273
            && !ref->next->next
274
            && ref->type == REF_COMPONENT
275
            && ref->next->type == REF_ARRAY
276
            && ref->next->u.ar.type != AR_ELEMENT)
277
        {
278
          with_data = true;
279
          if (full_array)
280
            *full_array = ref->next->u.ar.type == AR_FULL;
281
        }
282
    }
283
 
284
  return no_data || with_data;
285
}
286
 
287
 
288
/* Returns true if the expression contains a reference to a class
289
   array.  Notice that class array elements return false.  */
290
 
291
bool
292
gfc_is_class_array_ref (gfc_expr *e, bool *full_array)
293
{
294
  gfc_ref *ref;
295
 
296
  if (!e->rank)
297
    return false;
298
 
299
  if (full_array)
300
    *full_array= false;
301
 
302
  /* Is this a class array object? ie. Is the symbol of type class?  */
303
  if (e->symtree
304
        && e->symtree->n.sym->ts.type == BT_CLASS
305
        && CLASS_DATA (e->symtree->n.sym)
306
        && CLASS_DATA (e->symtree->n.sym)->attr.dimension
307
        && class_array_ref_detected (e->ref, full_array))
308
    return true;
309
 
310
  /* Or is this a class array component reference?  */
311
  for (ref = e->ref; ref; ref = ref->next)
312
    {
313
      if (ref->type == REF_COMPONENT
314
            && ref->u.c.component->ts.type == BT_CLASS
315
            && CLASS_DATA (ref->u.c.component)->attr.dimension
316
            && class_array_ref_detected (ref->next, full_array))
317
        return true;
318
    }
319
 
320
  return false;
321
}
322
 
323
 
324
/* Returns true if the expression is a reference to a class
325
   scalar.  This function is necessary because such expressions
326
   can be dressed with a reference to the _data component and so
327
   have a type other than BT_CLASS.  */
328
 
329
bool
330
gfc_is_class_scalar_expr (gfc_expr *e)
331
{
332
  gfc_ref *ref;
333
 
334
  if (e->rank)
335
    return false;
336
 
337
  /* Is this a class object?  */
338
  if (e->symtree
339
        && e->symtree->n.sym->ts.type == BT_CLASS
340
        && CLASS_DATA (e->symtree->n.sym)
341
        && !CLASS_DATA (e->symtree->n.sym)->attr.dimension
342
        && (e->ref == NULL
343
            || (strcmp (e->ref->u.c.component->name, "_data") == 0
344
                && e->ref->next == NULL)))
345
    return true;
346
 
347
  /* Or is the final reference BT_CLASS or _data?  */
348
  for (ref = e->ref; ref; ref = ref->next)
349
    {
350
      if (ref->type == REF_COMPONENT
351
            && ref->u.c.component->ts.type == BT_CLASS
352
            && CLASS_DATA (ref->u.c.component)
353
            && !CLASS_DATA (ref->u.c.component)->attr.dimension
354
            && (ref->next == NULL
355
                || (strcmp (ref->next->u.c.component->name, "_data") == 0
356
                    && ref->next->next == NULL)))
357
        return true;
358
    }
359
 
360
  return false;
361
}
362
 
363
 
364
/* Build a NULL initializer for CLASS pointers,
365
   initializing the _data component to NULL and
366
   the _vptr component to the declared type.  */
367
 
368
gfc_expr *
369
gfc_class_null_initializer (gfc_typespec *ts)
370
{
371
  gfc_expr *init;
372
  gfc_component *comp;
373
 
374
  init = gfc_get_structure_constructor_expr (ts->type, ts->kind,
375
                                             &ts->u.derived->declared_at);
376
  init->ts = *ts;
377
 
378
  for (comp = ts->u.derived->components; comp; comp = comp->next)
379
    {
380
      gfc_constructor *ctor = gfc_constructor_get();
381
      if (strcmp (comp->name, "_vptr") == 0)
382
        ctor->expr = gfc_lval_expr_from_sym (gfc_find_derived_vtab (ts->u.derived));
383
      else
384
        ctor->expr = gfc_get_null_expr (NULL);
385
      gfc_constructor_append (&init->value.constructor, ctor);
386
    }
387
 
388
  return init;
389
}
390
 
391
 
392
/* Create a unique string identifier for a derived type, composed of its name
393
   and module name. This is used to construct unique names for the class
394
   containers and vtab symbols.  */
395
 
396
static void
397
get_unique_type_string (char *string, gfc_symbol *derived)
398
{
399
  char dt_name[GFC_MAX_SYMBOL_LEN+1];
400
  sprintf (dt_name, "%s", derived->name);
401
  dt_name[0] = TOUPPER (dt_name[0]);
402
  if (derived->module)
403
    sprintf (string, "%s_%s", derived->module, dt_name);
404
  else if (derived->ns->proc_name)
405
    sprintf (string, "%s_%s", derived->ns->proc_name->name, dt_name);
406
  else
407
    sprintf (string, "_%s", dt_name);
408
}
409
 
410
 
411
/* A relative of 'get_unique_type_string' which makes sure the generated
412
   string will not be too long (replacing it by a hash string if needed).  */
413
 
414
static void
415
get_unique_hashed_string (char *string, gfc_symbol *derived)
416
{
417
  char tmp[2*GFC_MAX_SYMBOL_LEN+2];
418
  get_unique_type_string (&tmp[0], derived);
419
  /* If string is too long, use hash value in hex representation (allow for
420
     extra decoration, cf. gfc_build_class_symbol & gfc_find_derived_vtab).
421
     We need space to for 15 characters "__class_" + symbol name + "_%d_%da",
422
     where %d is the (co)rank which can be up to n = 15.  */
423
  if (strlen (tmp) > GFC_MAX_SYMBOL_LEN - 15)
424
    {
425
      int h = gfc_hash_value (derived);
426
      sprintf (string, "%X", h);
427
    }
428
  else
429
    strcpy (string, tmp);
430
}
431
 
432
 
433
/* Assign a hash value for a derived type. The algorithm is that of SDBM.  */
434
 
435
unsigned int
436
gfc_hash_value (gfc_symbol *sym)
437
{
438
  unsigned int hash = 0;
439
  char c[2*(GFC_MAX_SYMBOL_LEN+1)];
440
  int i, len;
441
 
442
  get_unique_type_string (&c[0], sym);
443
  len = strlen (c);
444
 
445
  for (i = 0; i < len; i++)
446
    hash = (hash << 6) + (hash << 16) - hash + c[i];
447
 
448
  /* Return the hash but take the modulus for the sake of module read,
449
     even though this slightly increases the chance of collision.  */
450
  return (hash % 100000000);
451
}
452
 
453
 
454
/* Build a polymorphic CLASS entity, using the symbol that comes from
455
   build_sym. A CLASS entity is represented by an encapsulating type,
456
   which contains the declared type as '_data' component, plus a pointer
457
   component '_vptr' which determines the dynamic type.  */
458
 
459
gfc_try
460
gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
461
                        gfc_array_spec **as, bool delayed_vtab)
462
{
463
  char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
464
  gfc_symbol *fclass;
465
  gfc_symbol *vtab;
466
  gfc_component *c;
467
 
468
  if (as && *as && (*as)->type == AS_ASSUMED_SIZE)
469
    {
470
      gfc_error ("Assumed size polymorphic objects or components, such "
471
                 "as that at %C, have not yet been implemented");
472
      return FAILURE;
473
    }
474
 
475
  if (attr->class_ok)
476
    /* Class container has already been built.  */
477
    return SUCCESS;
478
 
479
  attr->class_ok = attr->dummy || attr->pointer || attr->allocatable
480
                   || attr->select_type_temporary;
481
 
482
  if (!attr->class_ok)
483
    /* We can not build the class container yet.  */
484
    return SUCCESS;
485
 
486
  /* Determine the name of the encapsulating type.  */
487
  get_unique_hashed_string (tname, ts->u.derived);
488
  if ((*as) && attr->allocatable)
489
    sprintf (name, "__class_%s_%d_%da", tname, (*as)->rank, (*as)->corank);
490
  else if ((*as))
491
    sprintf (name, "__class_%s_%d_%d", tname, (*as)->rank, (*as)->corank);
492
  else if (attr->pointer)
493
    sprintf (name, "__class_%s_p", tname);
494
  else if (attr->allocatable)
495
    sprintf (name, "__class_%s_a", tname);
496
  else
497
    sprintf (name, "__class_%s", tname);
498
 
499
  gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass);
500
  if (fclass == NULL)
501
    {
502
      gfc_symtree *st;
503
      /* If not there, create a new symbol.  */
504
      fclass = gfc_new_symbol (name, ts->u.derived->ns);
505
      st = gfc_new_symtree (&ts->u.derived->ns->sym_root, name);
506
      st->n.sym = fclass;
507
      gfc_set_sym_referenced (fclass);
508
      fclass->refs++;
509
      fclass->ts.type = BT_UNKNOWN;
510
      fclass->attr.abstract = ts->u.derived->attr.abstract;
511
      if (ts->u.derived->f2k_derived)
512
        fclass->f2k_derived = gfc_get_namespace (NULL, 0);
513
      if (gfc_add_flavor (&fclass->attr, FL_DERIVED,
514
          NULL, &gfc_current_locus) == FAILURE)
515
        return FAILURE;
516
 
517
      /* Add component '_data'.  */
518
      if (gfc_add_component (fclass, "_data", &c) == FAILURE)
519
        return FAILURE;
520
      c->ts = *ts;
521
      c->ts.type = BT_DERIVED;
522
      c->attr.access = ACCESS_PRIVATE;
523
      c->ts.u.derived = ts->u.derived;
524
      c->attr.class_pointer = attr->pointer;
525
      c->attr.pointer = attr->pointer || (attr->dummy && !attr->allocatable)
526
                        || attr->select_type_temporary;
527
      c->attr.allocatable = attr->allocatable;
528
      c->attr.dimension = attr->dimension;
529
      c->attr.codimension = attr->codimension;
530
      c->attr.abstract = ts->u.derived->attr.abstract;
531
      c->as = (*as);
532
      c->initializer = NULL;
533
 
534
      /* Add component '_vptr'.  */
535
      if (gfc_add_component (fclass, "_vptr", &c) == FAILURE)
536
        return FAILURE;
537
      c->ts.type = BT_DERIVED;
538
      if (delayed_vtab)
539
        c->ts.u.derived = NULL;
540
      else
541
        {
542
          vtab = gfc_find_derived_vtab (ts->u.derived);
543
          gcc_assert (vtab);
544
          c->ts.u.derived = vtab->ts.u.derived;
545
        }
546
      c->attr.access = ACCESS_PRIVATE;
547
      c->attr.pointer = 1;
548
    }
549
  else if (!fclass->f2k_derived)
550
    fclass->f2k_derived = gfc_get_namespace (NULL, 0);
551
 
552
  /* Since the extension field is 8 bit wide, we can only have
553
     up to 255 extension levels.  */
554
  if (ts->u.derived->attr.extension == 255)
555
    {
556
      gfc_error ("Maximum extension level reached with type '%s' at %L",
557
                 ts->u.derived->name, &ts->u.derived->declared_at);
558
      return FAILURE;
559
    }
560
 
561
  fclass->attr.extension = ts->u.derived->attr.extension + 1;
562
  fclass->attr.alloc_comp = ts->u.derived->attr.alloc_comp;
563
  fclass->attr.is_class = 1;
564
  ts->u.derived = fclass;
565
  attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0;
566
  (*as) = NULL;
567
  return SUCCESS;
568
}
569
 
570
 
571
/* Add a procedure pointer component to the vtype
572
   to represent a specific type-bound procedure.  */
573
 
574
static void
575
add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb)
576
{
577
  gfc_component *c;
578
 
579
  if (tb->non_overridable)
580
    return;
581
 
582
  c = gfc_find_component (vtype, name, true, true);
583
 
584
  if (c == NULL)
585
    {
586
      /* Add procedure component.  */
587
      if (gfc_add_component (vtype, name, &c) == FAILURE)
588
        return;
589
 
590
      if (!c->tb)
591
        c->tb = XCNEW (gfc_typebound_proc);
592
      *c->tb = *tb;
593
      c->tb->ppc = 1;
594
      c->attr.procedure = 1;
595
      c->attr.proc_pointer = 1;
596
      c->attr.flavor = FL_PROCEDURE;
597
      c->attr.access = ACCESS_PRIVATE;
598
      c->attr.external = 1;
599
      c->attr.untyped = 1;
600
      c->attr.if_source = IFSRC_IFBODY;
601
    }
602
  else if (c->attr.proc_pointer && c->tb)
603
    {
604
      *c->tb = *tb;
605
      c->tb->ppc = 1;
606
    }
607
 
608
  if (tb->u.specific)
609
    {
610
      c->ts.interface = tb->u.specific->n.sym;
611
      if (!tb->deferred)
612
        c->initializer = gfc_get_variable_expr (tb->u.specific);
613
    }
614
}
615
 
616
 
617
/* Add all specific type-bound procedures in the symtree 'st' to a vtype.  */
618
 
619
static void
620
add_procs_to_declared_vtab1 (gfc_symtree *st, gfc_symbol *vtype)
621
{
622
  if (!st)
623
    return;
624
 
625
  if (st->left)
626
    add_procs_to_declared_vtab1 (st->left, vtype);
627
 
628
  if (st->right)
629
    add_procs_to_declared_vtab1 (st->right, vtype);
630
 
631
  if (st->n.tb && !st->n.tb->error
632
      && !st->n.tb->is_generic && st->n.tb->u.specific)
633
    add_proc_comp (vtype, st->name, st->n.tb);
634
}
635
 
636
 
637
/* Copy procedure pointers components from the parent type.  */
638
 
639
static void
640
copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype)
641
{
642
  gfc_component *cmp;
643
  gfc_symbol *vtab;
644
 
645
  vtab = gfc_find_derived_vtab (declared);
646
 
647
  for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next)
648
    {
649
      if (gfc_find_component (vtype, cmp->name, true, true))
650
        continue;
651
 
652
      add_proc_comp (vtype, cmp->name, cmp->tb);
653
    }
654
}
655
 
656
 
657
/* Add procedure pointers for all type-bound procedures to a vtab.  */
658
 
659
static void
660
add_procs_to_declared_vtab (gfc_symbol *derived, gfc_symbol *vtype)
661
{
662
  gfc_symbol* super_type;
663
 
664
  super_type = gfc_get_derived_super_type (derived);
665
 
666
  if (super_type && (super_type != derived))
667
    {
668
      /* Make sure that the PPCs appear in the same order as in the parent.  */
669
      copy_vtab_proc_comps (super_type, vtype);
670
      /* Only needed to get the PPC initializers right.  */
671
      add_procs_to_declared_vtab (super_type, vtype);
672
    }
673
 
674
  if (derived->f2k_derived && derived->f2k_derived->tb_sym_root)
675
    add_procs_to_declared_vtab1 (derived->f2k_derived->tb_sym_root, vtype);
676
 
677
  if (derived->f2k_derived && derived->f2k_derived->tb_uop_root)
678
    add_procs_to_declared_vtab1 (derived->f2k_derived->tb_uop_root, vtype);
679
}
680
 
681
 
682
/* Find (or generate) the symbol for a derived type's vtab.  */
683
 
684
gfc_symbol *
685
gfc_find_derived_vtab (gfc_symbol *derived)
686
{
687
  gfc_namespace *ns;
688
  gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL;
689
  gfc_symbol *copy = NULL, *src = NULL, *dst = NULL;
690
 
691
  /* Find the top-level namespace (MODULE or PROGRAM).  */
692
  for (ns = gfc_current_ns; ns; ns = ns->parent)
693
    if (!ns->parent)
694
      break;
695
 
696
  /* If the type is a class container, use the underlying derived type.  */
697
  if (derived->attr.is_class)
698
    derived = gfc_get_derived_super_type (derived);
699
 
700
  if (ns)
701
    {
702
      char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1];
703
 
704
      get_unique_hashed_string (tname, derived);
705
      sprintf (name, "__vtab_%s", tname);
706
 
707
      /* Look for the vtab symbol in various namespaces.  */
708
      gfc_find_symbol (name, gfc_current_ns, 0, &vtab);
709
      if (vtab == NULL)
710
        gfc_find_symbol (name, ns, 0, &vtab);
711
      if (vtab == NULL)
712
        gfc_find_symbol (name, derived->ns, 0, &vtab);
713
 
714
      if (vtab == NULL)
715
        {
716
          gfc_get_symbol (name, ns, &vtab);
717
          vtab->ts.type = BT_DERIVED;
718
          if (gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL,
719
                              &gfc_current_locus) == FAILURE)
720
            goto cleanup;
721
          vtab->attr.target = 1;
722
          vtab->attr.save = SAVE_IMPLICIT;
723
          vtab->attr.vtab = 1;
724
          vtab->attr.access = ACCESS_PUBLIC;
725
          gfc_set_sym_referenced (vtab);
726
          sprintf (name, "__vtype_%s", tname);
727
 
728
          gfc_find_symbol (name, ns, 0, &vtype);
729
          if (vtype == NULL)
730
            {
731
              gfc_component *c;
732
              gfc_symbol *parent = NULL, *parent_vtab = NULL;
733
 
734
              gfc_get_symbol (name, ns, &vtype);
735
              if (gfc_add_flavor (&vtype->attr, FL_DERIVED,
736
                                  NULL, &gfc_current_locus) == FAILURE)
737
                goto cleanup;
738
              vtype->attr.access = ACCESS_PUBLIC;
739
              vtype->attr.vtype = 1;
740
              gfc_set_sym_referenced (vtype);
741
 
742
              /* Add component '_hash'.  */
743
              if (gfc_add_component (vtype, "_hash", &c) == FAILURE)
744
                goto cleanup;
745
              c->ts.type = BT_INTEGER;
746
              c->ts.kind = 4;
747
              c->attr.access = ACCESS_PRIVATE;
748
              c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
749
                                                 NULL, derived->hash_value);
750
 
751
              /* Add component '_size'.  */
752
              if (gfc_add_component (vtype, "_size", &c) == FAILURE)
753
                goto cleanup;
754
              c->ts.type = BT_INTEGER;
755
              c->ts.kind = 4;
756
              c->attr.access = ACCESS_PRIVATE;
757
              /* Remember the derived type in ts.u.derived,
758
                 so that the correct initializer can be set later on
759
                 (in gfc_conv_structure).  */
760
              c->ts.u.derived = derived;
761
              c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
762
                                                 NULL, 0);
763
 
764
              /* Add component _extends.  */
765
              if (gfc_add_component (vtype, "_extends", &c) == FAILURE)
766
                goto cleanup;
767
              c->attr.pointer = 1;
768
              c->attr.access = ACCESS_PRIVATE;
769
              parent = gfc_get_derived_super_type (derived);
770
              if (parent)
771
                {
772
                  parent_vtab = gfc_find_derived_vtab (parent);
773
                  c->ts.type = BT_DERIVED;
774
                  c->ts.u.derived = parent_vtab->ts.u.derived;
775
                  c->initializer = gfc_get_expr ();
776
                  c->initializer->expr_type = EXPR_VARIABLE;
777
                  gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns,
778
                                     0, &c->initializer->symtree);
779
                }
780
              else
781
                {
782
                  c->ts.type = BT_DERIVED;
783
                  c->ts.u.derived = vtype;
784
                  c->initializer = gfc_get_null_expr (NULL);
785
                }
786
 
787
              if (derived->components == NULL && !derived->attr.zero_comp)
788
                {
789
                  /* At this point an error must have occurred.
790
                     Prevent further errors on the vtype components.  */
791
                  found_sym = vtab;
792
                  goto have_vtype;
793
                }
794
 
795
              /* Add component _def_init.  */
796
              if (gfc_add_component (vtype, "_def_init", &c) == FAILURE)
797
                goto cleanup;
798
              c->attr.pointer = 1;
799
              c->attr.access = ACCESS_PRIVATE;
800
              c->ts.type = BT_DERIVED;
801
              c->ts.u.derived = derived;
802
              if (derived->attr.abstract)
803
                c->initializer = gfc_get_null_expr (NULL);
804
              else
805
                {
806
                  /* Construct default initialization variable.  */
807
                  sprintf (name, "__def_init_%s", tname);
808
                  gfc_get_symbol (name, ns, &def_init);
809
                  def_init->attr.target = 1;
810
                  def_init->attr.save = SAVE_IMPLICIT;
811
                  def_init->attr.access = ACCESS_PUBLIC;
812
                  def_init->attr.flavor = FL_VARIABLE;
813
                  gfc_set_sym_referenced (def_init);
814
                  def_init->ts.type = BT_DERIVED;
815
                  def_init->ts.u.derived = derived;
816
                  def_init->value = gfc_default_initializer (&def_init->ts);
817
 
818
                  c->initializer = gfc_lval_expr_from_sym (def_init);
819
                }
820
 
821
              /* Add component _copy.  */
822
              if (gfc_add_component (vtype, "_copy", &c) == FAILURE)
823
                goto cleanup;
824
              c->attr.proc_pointer = 1;
825
              c->attr.access = ACCESS_PRIVATE;
826
              c->tb = XCNEW (gfc_typebound_proc);
827
              c->tb->ppc = 1;
828
              if (derived->attr.abstract)
829
                c->initializer = gfc_get_null_expr (NULL);
830
              else
831
                {
832
                  /* Set up namespace.  */
833
                  gfc_namespace *sub_ns = gfc_get_namespace (ns, 0);
834
                  sub_ns->sibling = ns->contained;
835
                  ns->contained = sub_ns;
836
                  sub_ns->resolved = 1;
837
                  /* Set up procedure symbol.  */
838
                  sprintf (name, "__copy_%s", tname);
839
                  gfc_get_symbol (name, sub_ns, &copy);
840
                  sub_ns->proc_name = copy;
841
                  copy->attr.flavor = FL_PROCEDURE;
842
                  copy->attr.subroutine = 1;
843
                  copy->attr.pure = 1;
844
                  copy->attr.if_source = IFSRC_DECL;
845
                  /* This is elemental so that arrays are automatically
846
                     treated correctly by the scalarizer.  */
847
                  copy->attr.elemental = 1;
848
                  if (ns->proc_name->attr.flavor == FL_MODULE)
849
                    copy->module = ns->proc_name->name;
850
                  gfc_set_sym_referenced (copy);
851
                  /* Set up formal arguments.  */
852
                  gfc_get_symbol ("src", sub_ns, &src);
853
                  src->ts.type = BT_DERIVED;
854
                  src->ts.u.derived = derived;
855
                  src->attr.flavor = FL_VARIABLE;
856
                  src->attr.dummy = 1;
857
                  src->attr.intent = INTENT_IN;
858
                  gfc_set_sym_referenced (src);
859
                  copy->formal = gfc_get_formal_arglist ();
860
                  copy->formal->sym = src;
861
                  gfc_get_symbol ("dst", sub_ns, &dst);
862
                  dst->ts.type = BT_DERIVED;
863
                  dst->ts.u.derived = derived;
864
                  dst->attr.flavor = FL_VARIABLE;
865
                  dst->attr.dummy = 1;
866
                  dst->attr.intent = INTENT_OUT;
867
                  gfc_set_sym_referenced (dst);
868
                  copy->formal->next = gfc_get_formal_arglist ();
869
                  copy->formal->next->sym = dst;
870
                  /* Set up code.  */
871
                  sub_ns->code = gfc_get_code ();
872
                  sub_ns->code->op = EXEC_INIT_ASSIGN;
873
                  sub_ns->code->expr1 = gfc_lval_expr_from_sym (dst);
874
                  sub_ns->code->expr2 = gfc_lval_expr_from_sym (src);
875
                  /* Set initializer.  */
876
                  c->initializer = gfc_lval_expr_from_sym (copy);
877
                  c->ts.interface = copy;
878
                }
879
 
880
              /* Add procedure pointers for type-bound procedures.  */
881
              add_procs_to_declared_vtab (derived, vtype);
882
            }
883
 
884
have_vtype:
885
          vtab->ts.u.derived = vtype;
886
          vtab->value = gfc_default_initializer (&vtab->ts);
887
        }
888
    }
889
 
890
  found_sym = vtab;
891
 
892
cleanup:
893
  /* It is unexpected to have some symbols added at resolution or code
894
     generation time. We commit the changes in order to keep a clean state.  */
895
  if (found_sym)
896
    {
897
      gfc_commit_symbol (vtab);
898
      if (vtype)
899
        gfc_commit_symbol (vtype);
900
      if (def_init)
901
        gfc_commit_symbol (def_init);
902
      if (copy)
903
        gfc_commit_symbol (copy);
904
      if (src)
905
        gfc_commit_symbol (src);
906
      if (dst)
907
        gfc_commit_symbol (dst);
908
    }
909
  else
910
    gfc_undo_symbols ();
911
 
912
  return found_sym;
913
}
914
 
915
 
916
/* General worker function to find either a type-bound procedure or a
917
   type-bound user operator.  */
918
 
919
static gfc_symtree*
920
find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t,
921
                         const char* name, bool noaccess, bool uop,
922
                         locus* where)
923
{
924
  gfc_symtree* res;
925
  gfc_symtree* root;
926
 
927
  /* Set correct symbol-root.  */
928
  gcc_assert (derived->f2k_derived);
929
  root = (uop ? derived->f2k_derived->tb_uop_root
930
              : derived->f2k_derived->tb_sym_root);
931
 
932
  /* Set default to failure.  */
933
  if (t)
934
    *t = FAILURE;
935
 
936
  /* Try to find it in the current type's namespace.  */
937
  res = gfc_find_symtree (root, name);
938
  if (res && res->n.tb && !res->n.tb->error)
939
    {
940
      /* We found one.  */
941
      if (t)
942
        *t = SUCCESS;
943
 
944
      if (!noaccess && derived->attr.use_assoc
945
          && res->n.tb->access == ACCESS_PRIVATE)
946
        {
947
          if (where)
948
            gfc_error ("'%s' of '%s' is PRIVATE at %L",
949
                       name, derived->name, where);
950
          if (t)
951
            *t = FAILURE;
952
        }
953
 
954
      return res;
955
    }
956
 
957
  /* Otherwise, recurse on parent type if derived is an extension.  */
958
  if (derived->attr.extension)
959
    {
960
      gfc_symbol* super_type;
961
      super_type = gfc_get_derived_super_type (derived);
962
      gcc_assert (super_type);
963
 
964
      return find_typebound_proc_uop (super_type, t, name,
965
                                      noaccess, uop, where);
966
    }
967
 
968
  /* Nothing found.  */
969
  return NULL;
970
}
971
 
972
 
973
/* Find a type-bound procedure or user operator by name for a derived-type
974
   (looking recursively through the super-types).  */
975
 
976
gfc_symtree*
977
gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
978
                         const char* name, bool noaccess, locus* where)
979
{
980
  return find_typebound_proc_uop (derived, t, name, noaccess, false, where);
981
}
982
 
983
gfc_symtree*
984
gfc_find_typebound_user_op (gfc_symbol* derived, gfc_try* t,
985
                            const char* name, bool noaccess, locus* where)
986
{
987
  return find_typebound_proc_uop (derived, t, name, noaccess, true, where);
988
}
989
 
990
 
991
/* Find a type-bound intrinsic operator looking recursively through the
992
   super-type hierarchy.  */
993
 
994
gfc_typebound_proc*
995
gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t,
996
                                 gfc_intrinsic_op op, bool noaccess,
997
                                 locus* where)
998
{
999
  gfc_typebound_proc* res;
1000
 
1001
  /* Set default to failure.  */
1002
  if (t)
1003
    *t = FAILURE;
1004
 
1005
  /* Try to find it in the current type's namespace.  */
1006
  if (derived->f2k_derived)
1007
    res = derived->f2k_derived->tb_op[op];
1008
  else
1009
    res = NULL;
1010
 
1011
  /* Check access.  */
1012
  if (res && !res->error)
1013
    {
1014
      /* We found one.  */
1015
      if (t)
1016
        *t = SUCCESS;
1017
 
1018
      if (!noaccess && derived->attr.use_assoc
1019
          && res->access == ACCESS_PRIVATE)
1020
        {
1021
          if (where)
1022
            gfc_error ("'%s' of '%s' is PRIVATE at %L",
1023
                       gfc_op2string (op), derived->name, where);
1024
          if (t)
1025
            *t = FAILURE;
1026
        }
1027
 
1028
      return res;
1029
    }
1030
 
1031
  /* Otherwise, recurse on parent type if derived is an extension.  */
1032
  if (derived->attr.extension)
1033
    {
1034
      gfc_symbol* super_type;
1035
      super_type = gfc_get_derived_super_type (derived);
1036
      gcc_assert (super_type);
1037
 
1038
      return gfc_find_typebound_intrinsic_op (super_type, t, op,
1039
                                              noaccess, where);
1040
    }
1041
 
1042
  /* Nothing found.  */
1043
  return NULL;
1044
}
1045
 
1046
 
1047
/* Get a typebound-procedure symtree or create and insert it if not yet
1048
   present.  This is like a very simplified version of gfc_get_sym_tree for
1049
   tbp-symtrees rather than regular ones.  */
1050
 
1051
gfc_symtree*
1052
gfc_get_tbp_symtree (gfc_symtree **root, const char *name)
1053
{
1054
  gfc_symtree *result;
1055
 
1056
  result = gfc_find_symtree (*root, name);
1057
  if (!result)
1058
    {
1059
      result = gfc_new_symtree (root, name);
1060
      gcc_assert (result);
1061
      result->n.tb = NULL;
1062
    }
1063
 
1064
  return result;
1065
}

powered by: WebSVN 2.1.0

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