]>
git.ipfire.org Git - thirdparty/gcc.git/blob - gcc/fortran/class.c
1 /* 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>
7 This file is part of GCC.
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
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
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/>. */
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. */
29 /* Outline of the internal representation:
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.
38 For each derived type we set up a "vtable" entry, i.e. a structure with the
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. */
52 #include "constructor.h"
55 /* Insert a reference to the component of the given name.
56 Only to be used with CLASS containers and vtables. */
59 gfc_add_component_ref (gfc_expr
*e
, const char *name
)
61 gfc_ref
**tail
= &(e
->ref
);
63 gfc_symbol
*derived
= e
->symtree
->n
.sym
->ts
.u
.derived
;
66 if ((*tail
)->type
== REF_COMPONENT
)
68 if (strcmp ((*tail
)->u
.c
.component
->name
, "_data") == 0
70 && (*tail
)->next
->type
== REF_ARRAY
71 && (*tail
)->next
->next
== NULL
)
73 derived
= (*tail
)->u
.c
.component
->ts
.u
.derived
;
75 if ((*tail
)->type
== REF_ARRAY
&& (*tail
)->next
== NULL
)
77 tail
= &((*tail
)->next
);
79 if (*tail
!= NULL
&& strcmp (name
, "_data") == 0)
81 (*tail
) = gfc_get_ref();
83 (*tail
)->type
= REF_COMPONENT
;
84 (*tail
)->u
.c
.sym
= derived
;
85 (*tail
)->u
.c
.component
= gfc_find_component (derived
, name
, true, true);
86 gcc_assert((*tail
)->u
.c
.component
);
88 e
->ts
= (*tail
)->u
.c
.component
->ts
;
92 /* This is used to add both the _data component reference and an array
93 reference to class expressions. Used in translation of intrinsic
94 array inquiry functions. */
97 gfc_add_class_array_ref (gfc_expr
*e
)
99 int rank
= CLASS_DATA (e
)->as
->rank
;
100 gfc_array_spec
*as
= CLASS_DATA (e
)->as
;
102 gfc_add_component_ref (e
, "_data");
104 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
107 if (ref
->type
!= REF_ARRAY
)
109 ref
->next
= gfc_get_ref ();
111 ref
->type
= REF_ARRAY
;
112 ref
->u
.ar
.type
= AR_FULL
;
118 /* Unfortunately, class array expressions can appear in various conditions;
119 with and without both _data component and an arrayspec. This function
120 deals with that variability. The previous reference to 'ref' is to a
124 class_array_ref_detected (gfc_ref
*ref
, bool *full_array
)
126 bool no_data
= false;
127 bool with_data
= false;
129 /* An array reference with no _data component. */
130 if (ref
&& ref
->type
== REF_ARRAY
132 && ref
->u
.ar
.type
!= AR_ELEMENT
)
135 *full_array
= ref
->u
.ar
.type
== AR_FULL
;
139 /* Cover cases where _data appears, with or without an array ref. */
140 if (ref
&& ref
->type
== REF_COMPONENT
141 && strcmp (ref
->u
.c
.component
->name
, "_data") == 0)
149 else if (ref
->next
&& ref
->next
->type
== REF_ARRAY
151 && ref
->type
== REF_COMPONENT
152 && ref
->next
->type
== REF_ARRAY
153 && ref
->next
->u
.ar
.type
!= AR_ELEMENT
)
157 *full_array
= ref
->next
->u
.ar
.type
== AR_FULL
;
161 return no_data
|| with_data
;
165 /* Returns true if the expression contains a reference to a class
166 array. Notice that class array elements return false. */
169 gfc_is_class_array_ref (gfc_expr
*e
, bool *full_array
)
179 /* Is this a class array object? ie. Is the symbol of type class? */
181 && e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
182 && CLASS_DATA (e
->symtree
->n
.sym
)
183 && CLASS_DATA (e
->symtree
->n
.sym
)->attr
.dimension
184 && class_array_ref_detected (e
->ref
, full_array
))
187 /* Or is this a class array component reference? */
188 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
190 if (ref
->type
== REF_COMPONENT
191 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
192 && CLASS_DATA (ref
->u
.c
.component
)->attr
.dimension
193 && class_array_ref_detected (ref
->next
, full_array
))
201 /* Returns true if the expression is a reference to a class
202 scalar. This function is necessary because such expressions
203 can be dressed with a reference to the _data component and so
204 have a type other than BT_CLASS. */
207 gfc_is_class_scalar_expr (gfc_expr
*e
)
214 /* Is this a class object? */
216 && e
->symtree
->n
.sym
->ts
.type
== BT_CLASS
217 && CLASS_DATA (e
->symtree
->n
.sym
)
218 && !CLASS_DATA (e
->symtree
->n
.sym
)->attr
.dimension
220 || (strcmp (e
->ref
->u
.c
.component
->name
, "_data") == 0
221 && e
->ref
->next
== NULL
)))
224 /* Or is the final reference BT_CLASS or _data? */
225 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
227 if (ref
->type
== REF_COMPONENT
228 && ref
->u
.c
.component
->ts
.type
== BT_CLASS
229 && CLASS_DATA (ref
->u
.c
.component
)
230 && !CLASS_DATA (ref
->u
.c
.component
)->attr
.dimension
231 && (ref
->next
== NULL
232 || (strcmp (ref
->next
->u
.c
.component
->name
, "_data") == 0
233 && ref
->next
->next
== NULL
)))
241 /* Build a NULL initializer for CLASS pointers,
242 initializing the _data component to NULL and
243 the _vptr component to the declared type. */
246 gfc_class_null_initializer (gfc_typespec
*ts
)
251 init
= gfc_get_structure_constructor_expr (ts
->type
, ts
->kind
,
252 &ts
->u
.derived
->declared_at
);
255 for (comp
= ts
->u
.derived
->components
; comp
; comp
= comp
->next
)
257 gfc_constructor
*ctor
= gfc_constructor_get();
258 if (strcmp (comp
->name
, "_vptr") == 0)
259 ctor
->expr
= gfc_lval_expr_from_sym (gfc_find_derived_vtab (ts
->u
.derived
));
261 ctor
->expr
= gfc_get_null_expr (NULL
);
262 gfc_constructor_append (&init
->value
.constructor
, ctor
);
269 /* Create a unique string identifier for a derived type, composed of its name
270 and module name. This is used to construct unique names for the class
271 containers and vtab symbols. */
274 get_unique_type_string (char *string
, gfc_symbol
*derived
)
276 char dt_name
[GFC_MAX_SYMBOL_LEN
+1];
277 sprintf (dt_name
, "%s", derived
->name
);
278 dt_name
[0] = TOUPPER (dt_name
[0]);
280 sprintf (string
, "%s_%s", derived
->module
, dt_name
);
281 else if (derived
->ns
->proc_name
)
282 sprintf (string
, "%s_%s", derived
->ns
->proc_name
->name
, dt_name
);
284 sprintf (string
, "_%s", dt_name
);
288 /* A relative of 'get_unique_type_string' which makes sure the generated
289 string will not be too long (replacing it by a hash string if needed). */
292 get_unique_hashed_string (char *string
, gfc_symbol
*derived
)
294 char tmp
[2*GFC_MAX_SYMBOL_LEN
+2];
295 get_unique_type_string (&tmp
[0], derived
);
296 /* If string is too long, use hash value in hex representation (allow for
297 extra decoration, cf. gfc_build_class_symbol & gfc_find_derived_vtab).
298 We need space to for 15 characters "__class_" + symbol name + "_%d_%da",
299 where %d is the (co)rank which can be up to n = 15. */
300 if (strlen (tmp
) > GFC_MAX_SYMBOL_LEN
- 15)
302 int h
= gfc_hash_value (derived
);
303 sprintf (string
, "%X", h
);
306 strcpy (string
, tmp
);
310 /* Assign a hash value for a derived type. The algorithm is that of SDBM. */
313 gfc_hash_value (gfc_symbol
*sym
)
315 unsigned int hash
= 0;
316 char c
[2*(GFC_MAX_SYMBOL_LEN
+1)];
319 get_unique_type_string (&c
[0], sym
);
322 for (i
= 0; i
< len
; i
++)
323 hash
= (hash
<< 6) + (hash
<< 16) - hash
+ c
[i
];
325 /* Return the hash but take the modulus for the sake of module read,
326 even though this slightly increases the chance of collision. */
327 return (hash
% 100000000);
331 /* Build a polymorphic CLASS entity, using the symbol that comes from
332 build_sym. A CLASS entity is represented by an encapsulating type,
333 which contains the declared type as '_data' component, plus a pointer
334 component '_vptr' which determines the dynamic type. */
337 gfc_build_class_symbol (gfc_typespec
*ts
, symbol_attribute
*attr
,
338 gfc_array_spec
**as
, bool delayed_vtab
)
340 char name
[GFC_MAX_SYMBOL_LEN
+1], tname
[GFC_MAX_SYMBOL_LEN
+1];
345 if (as
&& *as
&& (*as
)->type
== AS_ASSUMED_SIZE
)
347 gfc_error ("Assumed size polymorphic objects or components, such "
348 "as that at %C, have not yet been implemented");
353 /* Class container has already been built. */
356 attr
->class_ok
= attr
->dummy
|| attr
->pointer
|| attr
->allocatable
357 || attr
->select_type_temporary
;
360 /* We can not build the class container yet. */
363 /* Determine the name of the encapsulating type. */
364 get_unique_hashed_string (tname
, ts
->u
.derived
);
365 if ((*as
) && attr
->allocatable
)
366 sprintf (name
, "__class_%s_%d_%da", tname
, (*as
)->rank
, (*as
)->corank
);
368 sprintf (name
, "__class_%s_%d_%d", tname
, (*as
)->rank
, (*as
)->corank
);
369 else if (attr
->pointer
)
370 sprintf (name
, "__class_%s_p", tname
);
371 else if (attr
->allocatable
)
372 sprintf (name
, "__class_%s_a", tname
);
374 sprintf (name
, "__class_%s", tname
);
376 gfc_find_symbol (name
, ts
->u
.derived
->ns
, 0, &fclass
);
380 /* If not there, create a new symbol. */
381 fclass
= gfc_new_symbol (name
, ts
->u
.derived
->ns
);
382 st
= gfc_new_symtree (&ts
->u
.derived
->ns
->sym_root
, name
);
384 gfc_set_sym_referenced (fclass
);
386 fclass
->ts
.type
= BT_UNKNOWN
;
387 fclass
->attr
.abstract
= ts
->u
.derived
->attr
.abstract
;
388 if (ts
->u
.derived
->f2k_derived
)
389 fclass
->f2k_derived
= gfc_get_namespace (NULL
, 0);
390 if (gfc_add_flavor (&fclass
->attr
, FL_DERIVED
,
391 NULL
, &gfc_current_locus
) == FAILURE
)
394 /* Add component '_data'. */
395 if (gfc_add_component (fclass
, "_data", &c
) == FAILURE
)
398 c
->ts
.type
= BT_DERIVED
;
399 c
->attr
.access
= ACCESS_PRIVATE
;
400 c
->ts
.u
.derived
= ts
->u
.derived
;
401 c
->attr
.class_pointer
= attr
->pointer
;
402 c
->attr
.pointer
= attr
->pointer
|| (attr
->dummy
&& !attr
->allocatable
)
403 || attr
->select_type_temporary
;
404 c
->attr
.allocatable
= attr
->allocatable
;
405 c
->attr
.dimension
= attr
->dimension
;
406 c
->attr
.codimension
= attr
->codimension
;
407 c
->attr
.abstract
= ts
->u
.derived
->attr
.abstract
;
409 c
->initializer
= NULL
;
411 /* Add component '_vptr'. */
412 if (gfc_add_component (fclass
, "_vptr", &c
) == FAILURE
)
414 c
->ts
.type
= BT_DERIVED
;
416 c
->ts
.u
.derived
= NULL
;
419 vtab
= gfc_find_derived_vtab (ts
->u
.derived
);
421 c
->ts
.u
.derived
= vtab
->ts
.u
.derived
;
423 c
->attr
.access
= ACCESS_PRIVATE
;
426 else if (!fclass
->f2k_derived
)
427 fclass
->f2k_derived
= gfc_get_namespace (NULL
, 0);
429 /* Since the extension field is 8 bit wide, we can only have
430 up to 255 extension levels. */
431 if (ts
->u
.derived
->attr
.extension
== 255)
433 gfc_error ("Maximum extension level reached with type '%s' at %L",
434 ts
->u
.derived
->name
, &ts
->u
.derived
->declared_at
);
438 fclass
->attr
.extension
= ts
->u
.derived
->attr
.extension
+ 1;
439 fclass
->attr
.alloc_comp
= ts
->u
.derived
->attr
.alloc_comp
;
440 fclass
->attr
.is_class
= 1;
441 ts
->u
.derived
= fclass
;
442 attr
->allocatable
= attr
->pointer
= attr
->dimension
= attr
->codimension
= 0;
448 /* Add a procedure pointer component to the vtype
449 to represent a specific type-bound procedure. */
452 add_proc_comp (gfc_symbol
*vtype
, const char *name
, gfc_typebound_proc
*tb
)
456 if (tb
->non_overridable
)
459 c
= gfc_find_component (vtype
, name
, true, true);
463 /* Add procedure component. */
464 if (gfc_add_component (vtype
, name
, &c
) == FAILURE
)
468 c
->tb
= XCNEW (gfc_typebound_proc
);
471 c
->attr
.procedure
= 1;
472 c
->attr
.proc_pointer
= 1;
473 c
->attr
.flavor
= FL_PROCEDURE
;
474 c
->attr
.access
= ACCESS_PRIVATE
;
475 c
->attr
.external
= 1;
477 c
->attr
.if_source
= IFSRC_IFBODY
;
479 else if (c
->attr
.proc_pointer
&& c
->tb
)
487 c
->ts
.interface
= tb
->u
.specific
->n
.sym
;
489 c
->initializer
= gfc_get_variable_expr (tb
->u
.specific
);
494 /* Add all specific type-bound procedures in the symtree 'st' to a vtype. */
497 add_procs_to_declared_vtab1 (gfc_symtree
*st
, gfc_symbol
*vtype
)
503 add_procs_to_declared_vtab1 (st
->left
, vtype
);
506 add_procs_to_declared_vtab1 (st
->right
, vtype
);
508 if (st
->n
.tb
&& !st
->n
.tb
->error
509 && !st
->n
.tb
->is_generic
&& st
->n
.tb
->u
.specific
)
510 add_proc_comp (vtype
, st
->name
, st
->n
.tb
);
514 /* Copy procedure pointers components from the parent type. */
517 copy_vtab_proc_comps (gfc_symbol
*declared
, gfc_symbol
*vtype
)
522 vtab
= gfc_find_derived_vtab (declared
);
524 for (cmp
= vtab
->ts
.u
.derived
->components
; cmp
; cmp
= cmp
->next
)
526 if (gfc_find_component (vtype
, cmp
->name
, true, true))
529 add_proc_comp (vtype
, cmp
->name
, cmp
->tb
);
534 /* Add procedure pointers for all type-bound procedures to a vtab. */
537 add_procs_to_declared_vtab (gfc_symbol
*derived
, gfc_symbol
*vtype
)
539 gfc_symbol
* super_type
;
541 super_type
= gfc_get_derived_super_type (derived
);
543 if (super_type
&& (super_type
!= derived
))
545 /* Make sure that the PPCs appear in the same order as in the parent. */
546 copy_vtab_proc_comps (super_type
, vtype
);
547 /* Only needed to get the PPC initializers right. */
548 add_procs_to_declared_vtab (super_type
, vtype
);
551 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_sym_root
)
552 add_procs_to_declared_vtab1 (derived
->f2k_derived
->tb_sym_root
, vtype
);
554 if (derived
->f2k_derived
&& derived
->f2k_derived
->tb_uop_root
)
555 add_procs_to_declared_vtab1 (derived
->f2k_derived
->tb_uop_root
, vtype
);
559 /* Find (or generate) the symbol for a derived type's vtab. */
562 gfc_find_derived_vtab (gfc_symbol
*derived
)
565 gfc_symbol
*vtab
= NULL
, *vtype
= NULL
, *found_sym
= NULL
, *def_init
= NULL
;
566 gfc_symbol
*copy
= NULL
, *src
= NULL
, *dst
= NULL
;
568 /* Find the top-level namespace (MODULE or PROGRAM). */
569 for (ns
= gfc_current_ns
; ns
; ns
= ns
->parent
)
573 /* If the type is a class container, use the underlying derived type. */
574 if (derived
->attr
.is_class
)
575 derived
= gfc_get_derived_super_type (derived
);
579 char name
[GFC_MAX_SYMBOL_LEN
+1], tname
[GFC_MAX_SYMBOL_LEN
+1];
581 get_unique_hashed_string (tname
, derived
);
582 sprintf (name
, "__vtab_%s", tname
);
584 /* Look for the vtab symbol in various namespaces. */
585 gfc_find_symbol (name
, gfc_current_ns
, 0, &vtab
);
587 gfc_find_symbol (name
, ns
, 0, &vtab
);
589 gfc_find_symbol (name
, derived
->ns
, 0, &vtab
);
593 gfc_get_symbol (name
, ns
, &vtab
);
594 vtab
->ts
.type
= BT_DERIVED
;
595 if (gfc_add_flavor (&vtab
->attr
, FL_VARIABLE
, NULL
,
596 &gfc_current_locus
) == FAILURE
)
598 vtab
->attr
.target
= 1;
599 vtab
->attr
.save
= SAVE_IMPLICIT
;
601 vtab
->attr
.access
= ACCESS_PUBLIC
;
602 gfc_set_sym_referenced (vtab
);
603 sprintf (name
, "__vtype_%s", tname
);
605 gfc_find_symbol (name
, ns
, 0, &vtype
);
609 gfc_symbol
*parent
= NULL
, *parent_vtab
= NULL
;
611 gfc_get_symbol (name
, ns
, &vtype
);
612 if (gfc_add_flavor (&vtype
->attr
, FL_DERIVED
,
613 NULL
, &gfc_current_locus
) == FAILURE
)
615 vtype
->attr
.access
= ACCESS_PUBLIC
;
616 vtype
->attr
.vtype
= 1;
617 gfc_set_sym_referenced (vtype
);
619 /* Add component '_hash'. */
620 if (gfc_add_component (vtype
, "_hash", &c
) == FAILURE
)
622 c
->ts
.type
= BT_INTEGER
;
624 c
->attr
.access
= ACCESS_PRIVATE
;
625 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
626 NULL
, derived
->hash_value
);
628 /* Add component '_size'. */
629 if (gfc_add_component (vtype
, "_size", &c
) == FAILURE
)
631 c
->ts
.type
= BT_INTEGER
;
633 c
->attr
.access
= ACCESS_PRIVATE
;
634 /* Remember the derived type in ts.u.derived,
635 so that the correct initializer can be set later on
636 (in gfc_conv_structure). */
637 c
->ts
.u
.derived
= derived
;
638 c
->initializer
= gfc_get_int_expr (gfc_default_integer_kind
,
641 /* Add component _extends. */
642 if (gfc_add_component (vtype
, "_extends", &c
) == FAILURE
)
645 c
->attr
.access
= ACCESS_PRIVATE
;
646 parent
= gfc_get_derived_super_type (derived
);
649 parent_vtab
= gfc_find_derived_vtab (parent
);
650 c
->ts
.type
= BT_DERIVED
;
651 c
->ts
.u
.derived
= parent_vtab
->ts
.u
.derived
;
652 c
->initializer
= gfc_get_expr ();
653 c
->initializer
->expr_type
= EXPR_VARIABLE
;
654 gfc_find_sym_tree (parent_vtab
->name
, parent_vtab
->ns
,
655 0, &c
->initializer
->symtree
);
659 c
->ts
.type
= BT_DERIVED
;
660 c
->ts
.u
.derived
= vtype
;
661 c
->initializer
= gfc_get_null_expr (NULL
);
664 if (derived
->components
== NULL
&& !derived
->attr
.zero_comp
)
666 /* At this point an error must have occurred.
667 Prevent further errors on the vtype components. */
672 /* Add component _def_init. */
673 if (gfc_add_component (vtype
, "_def_init", &c
) == FAILURE
)
676 c
->attr
.access
= ACCESS_PRIVATE
;
677 c
->ts
.type
= BT_DERIVED
;
678 c
->ts
.u
.derived
= derived
;
679 if (derived
->attr
.abstract
)
680 c
->initializer
= gfc_get_null_expr (NULL
);
683 /* Construct default initialization variable. */
684 sprintf (name
, "__def_init_%s", tname
);
685 gfc_get_symbol (name
, ns
, &def_init
);
686 def_init
->attr
.target
= 1;
687 def_init
->attr
.save
= SAVE_IMPLICIT
;
688 def_init
->attr
.access
= ACCESS_PUBLIC
;
689 def_init
->attr
.flavor
= FL_VARIABLE
;
690 gfc_set_sym_referenced (def_init
);
691 def_init
->ts
.type
= BT_DERIVED
;
692 def_init
->ts
.u
.derived
= derived
;
693 def_init
->value
= gfc_default_initializer (&def_init
->ts
);
695 c
->initializer
= gfc_lval_expr_from_sym (def_init
);
698 /* Add component _copy. */
699 if (gfc_add_component (vtype
, "_copy", &c
) == FAILURE
)
701 c
->attr
.proc_pointer
= 1;
702 c
->attr
.access
= ACCESS_PRIVATE
;
703 c
->tb
= XCNEW (gfc_typebound_proc
);
705 if (derived
->attr
.abstract
)
706 c
->initializer
= gfc_get_null_expr (NULL
);
709 /* Set up namespace. */
710 gfc_namespace
*sub_ns
= gfc_get_namespace (ns
, 0);
711 sub_ns
->sibling
= ns
->contained
;
712 ns
->contained
= sub_ns
;
713 sub_ns
->resolved
= 1;
714 /* Set up procedure symbol. */
715 sprintf (name
, "__copy_%s", tname
);
716 gfc_get_symbol (name
, sub_ns
, ©
);
717 sub_ns
->proc_name
= copy
;
718 copy
->attr
.flavor
= FL_PROCEDURE
;
719 copy
->attr
.subroutine
= 1;
721 copy
->attr
.if_source
= IFSRC_DECL
;
722 /* This is elemental so that arrays are automatically
723 treated correctly by the scalarizer. */
724 copy
->attr
.elemental
= 1;
725 if (ns
->proc_name
->attr
.flavor
== FL_MODULE
)
726 copy
->module
= ns
->proc_name
->name
;
727 gfc_set_sym_referenced (copy
);
728 /* Set up formal arguments. */
729 gfc_get_symbol ("src", sub_ns
, &src
);
730 src
->ts
.type
= BT_DERIVED
;
731 src
->ts
.u
.derived
= derived
;
732 src
->attr
.flavor
= FL_VARIABLE
;
734 src
->attr
.intent
= INTENT_IN
;
735 gfc_set_sym_referenced (src
);
736 copy
->formal
= gfc_get_formal_arglist ();
737 copy
->formal
->sym
= src
;
738 gfc_get_symbol ("dst", sub_ns
, &dst
);
739 dst
->ts
.type
= BT_DERIVED
;
740 dst
->ts
.u
.derived
= derived
;
741 dst
->attr
.flavor
= FL_VARIABLE
;
743 dst
->attr
.intent
= INTENT_OUT
;
744 gfc_set_sym_referenced (dst
);
745 copy
->formal
->next
= gfc_get_formal_arglist ();
746 copy
->formal
->next
->sym
= dst
;
748 sub_ns
->code
= gfc_get_code ();
749 sub_ns
->code
->op
= EXEC_INIT_ASSIGN
;
750 sub_ns
->code
->expr1
= gfc_lval_expr_from_sym (dst
);
751 sub_ns
->code
->expr2
= gfc_lval_expr_from_sym (src
);
752 /* Set initializer. */
753 c
->initializer
= gfc_lval_expr_from_sym (copy
);
754 c
->ts
.interface
= copy
;
757 /* Add procedure pointers for type-bound procedures. */
758 add_procs_to_declared_vtab (derived
, vtype
);
762 vtab
->ts
.u
.derived
= vtype
;
763 vtab
->value
= gfc_default_initializer (&vtab
->ts
);
770 /* It is unexpected to have some symbols added at resolution or code
771 generation time. We commit the changes in order to keep a clean state. */
774 gfc_commit_symbol (vtab
);
776 gfc_commit_symbol (vtype
);
778 gfc_commit_symbol (def_init
);
780 gfc_commit_symbol (copy
);
782 gfc_commit_symbol (src
);
784 gfc_commit_symbol (dst
);
793 /* General worker function to find either a type-bound procedure or a
794 type-bound user operator. */
797 find_typebound_proc_uop (gfc_symbol
* derived
, gfc_try
* t
,
798 const char* name
, bool noaccess
, bool uop
,
804 /* Set correct symbol-root. */
805 gcc_assert (derived
->f2k_derived
);
806 root
= (uop
? derived
->f2k_derived
->tb_uop_root
807 : derived
->f2k_derived
->tb_sym_root
);
809 /* Set default to failure. */
813 /* Try to find it in the current type's namespace. */
814 res
= gfc_find_symtree (root
, name
);
815 if (res
&& res
->n
.tb
&& !res
->n
.tb
->error
)
821 if (!noaccess
&& derived
->attr
.use_assoc
822 && res
->n
.tb
->access
== ACCESS_PRIVATE
)
825 gfc_error ("'%s' of '%s' is PRIVATE at %L",
826 name
, derived
->name
, where
);
834 /* Otherwise, recurse on parent type if derived is an extension. */
835 if (derived
->attr
.extension
)
837 gfc_symbol
* super_type
;
838 super_type
= gfc_get_derived_super_type (derived
);
839 gcc_assert (super_type
);
841 return find_typebound_proc_uop (super_type
, t
, name
,
842 noaccess
, uop
, where
);
850 /* Find a type-bound procedure or user operator by name for a derived-type
851 (looking recursively through the super-types). */
854 gfc_find_typebound_proc (gfc_symbol
* derived
, gfc_try
* t
,
855 const char* name
, bool noaccess
, locus
* where
)
857 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, false, where
);
861 gfc_find_typebound_user_op (gfc_symbol
* derived
, gfc_try
* t
,
862 const char* name
, bool noaccess
, locus
* where
)
864 return find_typebound_proc_uop (derived
, t
, name
, noaccess
, true, where
);
868 /* Find a type-bound intrinsic operator looking recursively through the
869 super-type hierarchy. */
872 gfc_find_typebound_intrinsic_op (gfc_symbol
* derived
, gfc_try
* t
,
873 gfc_intrinsic_op op
, bool noaccess
,
876 gfc_typebound_proc
* res
;
878 /* Set default to failure. */
882 /* Try to find it in the current type's namespace. */
883 if (derived
->f2k_derived
)
884 res
= derived
->f2k_derived
->tb_op
[op
];
889 if (res
&& !res
->error
)
895 if (!noaccess
&& derived
->attr
.use_assoc
896 && res
->access
== ACCESS_PRIVATE
)
899 gfc_error ("'%s' of '%s' is PRIVATE at %L",
900 gfc_op2string (op
), derived
->name
, where
);
908 /* Otherwise, recurse on parent type if derived is an extension. */
909 if (derived
->attr
.extension
)
911 gfc_symbol
* super_type
;
912 super_type
= gfc_get_derived_super_type (derived
);
913 gcc_assert (super_type
);
915 return gfc_find_typebound_intrinsic_op (super_type
, t
, op
,
924 /* Get a typebound-procedure symtree or create and insert it if not yet
925 present. This is like a very simplified version of gfc_get_sym_tree for
926 tbp-symtrees rather than regular ones. */
929 gfc_get_tbp_symtree (gfc_symtree
**root
, const char *name
)
933 result
= gfc_find_symtree (*root
, name
);
936 result
= gfc_new_symtree (root
, name
);