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, ©);
|
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 |
|
|
}
|