1/* Implementation of Fortran 2003 Polymorphism. 2 Copyright (C) 2009-2015 Free Software Foundation, Inc. 3 Contributed by Paul Richard Thomas <pault@gcc.gnu.org> 4 and Janus Weil <janus@gcc.gnu.org> 5 6This file is part of GCC. 7 8GCC is free software; you can redistribute it and/or modify it under 9the terms of the GNU General Public License as published by the Free 10Software Foundation; either version 3, or (at your option) any later 11version. 12 13GCC is distributed in the hope that it will be useful, but WITHOUT ANY 14WARRANTY; without even the implied warranty of MERCHANTABILITY or 15FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 16for more details. 17 18You should have received a copy of the GNU General Public License 19along with GCC; see the file COPYING3. If not see 20<http://www.gnu.org/licenses/>. */ 21 22 23/* class.c -- This file contains the front end functions needed to service 24 the implementation of Fortran 2003 polymorphism and other 25 object-oriented features. */ 26 27 28/* Outline of the internal representation: 29 30 Each CLASS variable is encapsulated by a class container, which is a 31 structure with two fields: 32 * _data: A pointer to the actual data of the variable. This field has the 33 declared type of the class variable and its attributes 34 (pointer/allocatable/dimension/...). 35 * _vptr: A pointer to the vtable entry (see below) of the dynamic type. 36 37 Only for unlimited polymorphic classes: 38 * _len: An integer(4) to store the string length when the unlimited 39 polymorphic pointer is used to point to a char array. The '_len' 40 component will be zero when no character array is stored in 41 '_data'. 42 43 For each derived type we set up a "vtable" entry, i.e. a structure with the 44 following fields: 45 * _hash: A hash value serving as a unique identifier for this type. 46 * _size: The size in bytes of the derived type. 47 * _extends: A pointer to the vtable entry of the parent derived type. 48 * _def_init: A pointer to a default initialized variable of this type. 49 * _copy: A procedure pointer to a copying procedure. 50 * _final: A procedure pointer to a wrapper function, which frees 51 allocatable components and calls FINAL subroutines. 52 53 After these follow procedure pointer components for the specific 54 type-bound procedures. */ 55 56 57#include "config.h" 58#include "system.h" 59#include "coretypes.h" 60#include "gfortran.h" 61#include "constructor.h" 62#include "target-memory.h" 63 64/* Inserts a derived type component reference in a data reference chain. 65 TS: base type of the ref chain so far, in which we will pick the component 66 REF: the address of the GFC_REF pointer to update 67 NAME: name of the component to insert 68 Note that component insertion makes sense only if we are at the end of 69 the chain (*REF == NULL) or if we are adding a missing "_data" component 70 to access the actual contents of a class object. */ 71 72static void 73insert_component_ref (gfc_typespec *ts, gfc_ref **ref, const char * const name) 74{ 75 gfc_symbol *type_sym; 76 gfc_ref *new_ref; 77 78 gcc_assert (ts->type == BT_DERIVED || ts->type == BT_CLASS); 79 type_sym = ts->u.derived; 80 81 new_ref = gfc_get_ref (); 82 new_ref->type = REF_COMPONENT; 83 new_ref->next = *ref; 84 new_ref->u.c.sym = type_sym; 85 new_ref->u.c.component = gfc_find_component (type_sym, name, true, true); 86 gcc_assert (new_ref->u.c.component); 87 88 if (new_ref->next) 89 { 90 gfc_ref *next = NULL; 91 92 /* We need to update the base type in the trailing reference chain to 93 that of the new component. */ 94 95 gcc_assert (strcmp (name, "_data") == 0); 96 97 if (new_ref->next->type == REF_COMPONENT) 98 next = new_ref->next; 99 else if (new_ref->next->type == REF_ARRAY 100 && new_ref->next->next 101 && new_ref->next->next->type == REF_COMPONENT) 102 next = new_ref->next->next; 103 104 if (next != NULL) 105 { 106 gcc_assert (new_ref->u.c.component->ts.type == BT_CLASS 107 || new_ref->u.c.component->ts.type == BT_DERIVED); 108 next->u.c.sym = new_ref->u.c.component->ts.u.derived; 109 } 110 } 111 112 *ref = new_ref; 113} 114 115 116/* Tells whether we need to add a "_data" reference to access REF subobject 117 from an object of type TS. If FIRST_REF_IN_CHAIN is set, then the base 118 object accessed by REF is a variable; in other words it is a full object, 119 not a subobject. */ 120 121static bool 122class_data_ref_missing (gfc_typespec *ts, gfc_ref *ref, bool first_ref_in_chain) 123{ 124 /* Only class containers may need the "_data" reference. */ 125 if (ts->type != BT_CLASS) 126 return false; 127 128 /* Accessing a class container with an array reference is certainly wrong. */ 129 if (ref->type != REF_COMPONENT) 130 return true; 131 132 /* Accessing the class container's fields is fine. */ 133 if (ref->u.c.component->name[0] == '_') 134 return false; 135 136 /* At this point we have a class container with a non class container's field 137 component reference. We don't want to add the "_data" component if we are 138 at the first reference and the symbol's type is an extended derived type. 139 In that case, conv_parent_component_references will do the right thing so 140 it is not absolutely necessary. Omitting it prevents a regression (see 141 class_41.f03) in the interface mapping mechanism. When evaluating string 142 lengths depending on dummy arguments, we create a fake symbol with a type 143 equal to that of the dummy type. However, because of type extension, 144 the backend type (corresponding to the actual argument) can have a 145 different (extended) type. Adding the "_data" component explicitly, using 146 the base type, confuses the gfc_conv_component_ref code which deals with 147 the extended type. */ 148 if (first_ref_in_chain && ts->u.derived->attr.extension) 149 return false; 150 151 /* We have a class container with a non class container's field component 152 reference that doesn't fall into the above. */ 153 return true; 154} 155 156 157/* Browse through a data reference chain and add the missing "_data" references 158 when a subobject of a class object is accessed without it. 159 Note that it doesn't add the "_data" reference when the class container 160 is the last element in the reference chain. */ 161 162void 163gfc_fix_class_refs (gfc_expr *e) 164{ 165 gfc_typespec *ts; 166 gfc_ref **ref; 167 168 if ((e->expr_type != EXPR_VARIABLE 169 && e->expr_type != EXPR_FUNCTION) 170 || (e->expr_type == EXPR_FUNCTION 171 && e->value.function.isym != NULL)) 172 return; 173 174 if (e->expr_type == EXPR_VARIABLE) 175 ts = &e->symtree->n.sym->ts; 176 else 177 { 178 gfc_symbol *func; 179 180 gcc_assert (e->expr_type == EXPR_FUNCTION); 181 if (e->value.function.esym != NULL) 182 func = e->value.function.esym; 183 else 184 func = e->symtree->n.sym; 185 186 if (func->result != NULL) 187 ts = &func->result->ts; 188 else 189 ts = &func->ts; 190 } 191 192 for (ref = &e->ref; *ref != NULL; ref = &(*ref)->next) 193 { 194 if (class_data_ref_missing (ts, *ref, ref == &e->ref)) 195 insert_component_ref (ts, ref, "_data"); 196 197 if ((*ref)->type == REF_COMPONENT) 198 ts = &(*ref)->u.c.component->ts; 199 } 200} 201 202 203/* Insert a reference to the component of the given name. 204 Only to be used with CLASS containers and vtables. */ 205 206void 207gfc_add_component_ref (gfc_expr *e, const char *name) 208{ 209 gfc_ref **tail = &(e->ref); 210 gfc_ref *next = NULL; 211 gfc_symbol *derived = e->symtree->n.sym->ts.u.derived; 212 while (*tail != NULL) 213 { 214 if ((*tail)->type == REF_COMPONENT) 215 { 216 if (strcmp ((*tail)->u.c.component->name, "_data") == 0 217 && (*tail)->next 218 && (*tail)->next->type == REF_ARRAY 219 && (*tail)->next->next == NULL) 220 return; 221 derived = (*tail)->u.c.component->ts.u.derived; 222 } 223 if ((*tail)->type == REF_ARRAY && (*tail)->next == NULL) 224 break; 225 tail = &((*tail)->next); 226 } 227 if (derived->components->next->ts.type == BT_DERIVED && 228 derived->components->next->ts.u.derived == NULL) 229 { 230 /* Fix up missing vtype. */ 231 gfc_symbol *vtab = gfc_find_derived_vtab (derived->components->ts.u.derived); 232 gcc_assert (vtab); 233 derived->components->next->ts.u.derived = vtab->ts.u.derived; 234 } 235 if (*tail != NULL && strcmp (name, "_data") == 0) 236 next = *tail; 237 else 238 /* Avoid losing memory. */ 239 gfc_free_ref_list (*tail); 240 (*tail) = gfc_get_ref(); 241 (*tail)->next = next; 242 (*tail)->type = REF_COMPONENT; 243 (*tail)->u.c.sym = derived; 244 (*tail)->u.c.component = gfc_find_component (derived, name, true, true); 245 gcc_assert((*tail)->u.c.component); 246 if (!next) 247 e->ts = (*tail)->u.c.component->ts; 248} 249 250 251/* This is used to add both the _data component reference and an array 252 reference to class expressions. Used in translation of intrinsic 253 array inquiry functions. */ 254 255void 256gfc_add_class_array_ref (gfc_expr *e) 257{ 258 int rank = CLASS_DATA (e)->as->rank; 259 gfc_array_spec *as = CLASS_DATA (e)->as; 260 gfc_ref *ref = NULL; 261 gfc_add_component_ref (e, "_data"); 262 e->rank = rank; 263 for (ref = e->ref; ref; ref = ref->next) 264 if (!ref->next) 265 break; 266 if (ref->type != REF_ARRAY) 267 { 268 ref->next = gfc_get_ref (); 269 ref = ref->next; 270 ref->type = REF_ARRAY; 271 ref->u.ar.type = AR_FULL; 272 ref->u.ar.as = as; 273 } 274} 275 276 277/* Unfortunately, class array expressions can appear in various conditions; 278 with and without both _data component and an arrayspec. This function 279 deals with that variability. The previous reference to 'ref' is to a 280 class array. */ 281 282static bool 283class_array_ref_detected (gfc_ref *ref, bool *full_array) 284{ 285 bool no_data = false; 286 bool with_data = false; 287 288 /* An array reference with no _data component. */ 289 if (ref && ref->type == REF_ARRAY 290 && !ref->next 291 && ref->u.ar.type != AR_ELEMENT) 292 { 293 if (full_array) 294 *full_array = ref->u.ar.type == AR_FULL; 295 no_data = true; 296 } 297 298 /* Cover cases where _data appears, with or without an array ref. */ 299 if (ref && ref->type == REF_COMPONENT 300 && strcmp (ref->u.c.component->name, "_data") == 0) 301 { 302 if (!ref->next) 303 { 304 with_data = true; 305 if (full_array) 306 *full_array = true; 307 } 308 else if (ref->next && ref->next->type == REF_ARRAY 309 && !ref->next->next 310 && ref->type == REF_COMPONENT 311 && ref->next->type == REF_ARRAY 312 && ref->next->u.ar.type != AR_ELEMENT) 313 { 314 with_data = true; 315 if (full_array) 316 *full_array = ref->next->u.ar.type == AR_FULL; 317 } 318 } 319 320 return no_data || with_data; 321} 322 323 324/* Returns true if the expression contains a reference to a class 325 array. Notice that class array elements return false. */ 326 327bool 328gfc_is_class_array_ref (gfc_expr *e, bool *full_array) 329{ 330 gfc_ref *ref; 331 332 if (!e->rank) 333 return false; 334 335 if (full_array) 336 *full_array= false; 337 338 /* Is this a class array object? ie. Is the symbol of type class? */ 339 if (e->symtree 340 && e->symtree->n.sym->ts.type == BT_CLASS 341 && CLASS_DATA (e->symtree->n.sym) 342 && CLASS_DATA (e->symtree->n.sym)->attr.dimension 343 && class_array_ref_detected (e->ref, full_array)) 344 return true; 345 346 /* Or is this a class array component reference? */ 347 for (ref = e->ref; ref; ref = ref->next) 348 { 349 if (ref->type == REF_COMPONENT 350 && ref->u.c.component->ts.type == BT_CLASS 351 && CLASS_DATA (ref->u.c.component)->attr.dimension 352 && class_array_ref_detected (ref->next, full_array)) 353 return true; 354 } 355 356 return false; 357} 358 359 360/* Returns true if the expression is a reference to a class 361 scalar. This function is necessary because such expressions 362 can be dressed with a reference to the _data component and so 363 have a type other than BT_CLASS. */ 364 365bool 366gfc_is_class_scalar_expr (gfc_expr *e) 367{ 368 gfc_ref *ref; 369 370 if (e->rank) 371 return false; 372 373 /* Is this a class object? */ 374 if (e->symtree 375 && e->symtree->n.sym->ts.type == BT_CLASS 376 && CLASS_DATA (e->symtree->n.sym) 377 && !CLASS_DATA (e->symtree->n.sym)->attr.dimension 378 && (e->ref == NULL 379 || (strcmp (e->ref->u.c.component->name, "_data") == 0 380 && e->ref->next == NULL))) 381 return true; 382 383 /* Or is the final reference BT_CLASS or _data? */ 384 for (ref = e->ref; ref; ref = ref->next) 385 { 386 if (ref->type == REF_COMPONENT 387 && ref->u.c.component->ts.type == BT_CLASS 388 && CLASS_DATA (ref->u.c.component) 389 && !CLASS_DATA (ref->u.c.component)->attr.dimension 390 && (ref->next == NULL 391 || (strcmp (ref->next->u.c.component->name, "_data") == 0 392 && ref->next->next == NULL))) 393 return true; 394 } 395 396 return false; 397} 398 399 400/* Tells whether the expression E is a reference to a (scalar) class container. 401 Scalar because array class containers usually have an array reference after 402 them, and gfc_fix_class_refs will add the missing "_data" component reference 403 in that case. */ 404 405bool 406gfc_is_class_container_ref (gfc_expr *e) 407{ 408 gfc_ref *ref; 409 bool result; 410 411 if (e->expr_type != EXPR_VARIABLE) 412 return e->ts.type == BT_CLASS; 413 414 if (e->symtree->n.sym->ts.type == BT_CLASS) 415 result = true; 416 else 417 result = false; 418 419 for (ref = e->ref; ref; ref = ref->next) 420 { 421 if (ref->type != REF_COMPONENT) 422 result = false; 423 else if (ref->u.c.component->ts.type == BT_CLASS) 424 result = true; 425 else 426 result = false; 427 } 428 429 return result; 430} 431 432 433/* Build an initializer for CLASS pointers, 434 initializing the _data component to the init_expr (or NULL) and the _vptr 435 component to the corresponding type (or the declared type, given by ts). */ 436 437gfc_expr * 438gfc_class_initializer (gfc_typespec *ts, gfc_expr *init_expr) 439{ 440 gfc_expr *init; 441 gfc_component *comp; 442 gfc_symbol *vtab = NULL; 443 444 if (init_expr && init_expr->expr_type != EXPR_NULL) 445 vtab = gfc_find_vtab (&init_expr->ts); 446 else 447 vtab = gfc_find_vtab (ts); 448 449 init = gfc_get_structure_constructor_expr (ts->type, ts->kind, 450 &ts->u.derived->declared_at); 451 init->ts = *ts; 452 453 for (comp = ts->u.derived->components; comp; comp = comp->next) 454 { 455 gfc_constructor *ctor = gfc_constructor_get(); 456 if (strcmp (comp->name, "_vptr") == 0 && vtab) 457 ctor->expr = gfc_lval_expr_from_sym (vtab); 458 else if (init_expr && init_expr->expr_type != EXPR_NULL) 459 ctor->expr = gfc_copy_expr (init_expr); 460 else 461 ctor->expr = gfc_get_null_expr (NULL); 462 gfc_constructor_append (&init->value.constructor, ctor); 463 } 464 465 return init; 466} 467 468 469/* Create a unique string identifier for a derived type, composed of its name 470 and module name. This is used to construct unique names for the class 471 containers and vtab symbols. */ 472 473static void 474get_unique_type_string (char *string, gfc_symbol *derived) 475{ 476 char dt_name[GFC_MAX_SYMBOL_LEN+1]; 477 if (derived->attr.unlimited_polymorphic) 478 strcpy (dt_name, "STAR"); 479 else 480 strcpy (dt_name, derived->name); 481 dt_name[0] = TOUPPER (dt_name[0]); 482 if (derived->attr.unlimited_polymorphic) 483 sprintf (string, "_%s", dt_name); 484 else if (derived->module) 485 sprintf (string, "%s_%s", derived->module, dt_name); 486 else if (derived->ns->proc_name) 487 sprintf (string, "%s_%s", derived->ns->proc_name->name, dt_name); 488 else 489 sprintf (string, "_%s", dt_name); 490} 491 492 493/* A relative of 'get_unique_type_string' which makes sure the generated 494 string will not be too long (replacing it by a hash string if needed). */ 495 496static void 497get_unique_hashed_string (char *string, gfc_symbol *derived) 498{ 499 char tmp[2*GFC_MAX_SYMBOL_LEN+2]; 500 get_unique_type_string (&tmp[0], derived); 501 /* If string is too long, use hash value in hex representation (allow for 502 extra decoration, cf. gfc_build_class_symbol & gfc_find_derived_vtab). 503 We need space to for 15 characters "__class_" + symbol name + "_%d_%da", 504 where %d is the (co)rank which can be up to n = 15. */ 505 if (strlen (tmp) > GFC_MAX_SYMBOL_LEN - 15) 506 { 507 int h = gfc_hash_value (derived); 508 sprintf (string, "%X", h); 509 } 510 else 511 strcpy (string, tmp); 512} 513 514 515/* Assign a hash value for a derived type. The algorithm is that of SDBM. */ 516 517unsigned int 518gfc_hash_value (gfc_symbol *sym) 519{ 520 unsigned int hash = 0; 521 char c[2*(GFC_MAX_SYMBOL_LEN+1)]; 522 int i, len; 523 524 get_unique_type_string (&c[0], sym); 525 len = strlen (c); 526 527 for (i = 0; i < len; i++) 528 hash = (hash << 6) + (hash << 16) - hash + c[i]; 529 530 /* Return the hash but take the modulus for the sake of module read, 531 even though this slightly increases the chance of collision. */ 532 return (hash % 100000000); 533} 534 535 536/* Assign a hash value for an intrinsic type. The algorithm is that of SDBM. */ 537 538unsigned int 539gfc_intrinsic_hash_value (gfc_typespec *ts) 540{ 541 unsigned int hash = 0; 542 const char *c = gfc_typename (ts); 543 int i, len; 544 545 len = strlen (c); 546 547 for (i = 0; i < len; i++) 548 hash = (hash << 6) + (hash << 16) - hash + c[i]; 549 550 /* Return the hash but take the modulus for the sake of module read, 551 even though this slightly increases the chance of collision. */ 552 return (hash % 100000000); 553} 554 555 556/* Get the _len component from a class/derived object storing a string. 557 For unlimited polymorphic entities a ref to the _data component is available 558 while a ref to the _len component is needed. This routine traverese the 559 ref-chain and strips the last ref to a _data from it replacing it with a 560 ref to the _len component. */ 561 562gfc_expr * 563gfc_get_len_component (gfc_expr *e) 564{ 565 gfc_expr *ptr; 566 gfc_ref *ref, **last; 567 568 ptr = gfc_copy_expr (e); 569 570 /* We need to remove the last _data component ref from ptr. */ 571 last = &(ptr->ref); 572 ref = ptr->ref; 573 while (ref) 574 { 575 if (!ref->next 576 && ref->type == REF_COMPONENT 577 && strcmp ("_data", ref->u.c.component->name)== 0) 578 { 579 gfc_free_ref_list (ref); 580 *last = NULL; 581 break; 582 } 583 last = &(ref->next); 584 ref = ref->next; 585 } 586 /* And replace if with a ref to the _len component. */ 587 gfc_add_component_ref (ptr, "_len"); 588 return ptr; 589} 590 591 592/* Build a polymorphic CLASS entity, using the symbol that comes from 593 build_sym. A CLASS entity is represented by an encapsulating type, 594 which contains the declared type as '_data' component, plus a pointer 595 component '_vptr' which determines the dynamic type. When this CLASS 596 entity is unlimited polymorphic, then also add a component '_len' to 597 store the length of string when that is stored in it. */ 598 599bool 600gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, 601 gfc_array_spec **as) 602{ 603 char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1]; 604 gfc_symbol *fclass; 605 gfc_symbol *vtab; 606 gfc_component *c; 607 gfc_namespace *ns; 608 int rank; 609 610 gcc_assert (as); 611 612 if (*as && (*as)->type == AS_ASSUMED_SIZE) 613 { 614 gfc_error ("Assumed size polymorphic objects or components, such " 615 "as that at %C, have not yet been implemented"); 616 return false; 617 } 618 619 if (attr->class_ok) 620 /* Class container has already been built. */ 621 return true; 622 623 attr->class_ok = attr->dummy || attr->pointer || attr->allocatable 624 || attr->select_type_temporary || attr->associate_var; 625 626 if (!attr->class_ok) 627 /* We can not build the class container yet. */ 628 return true; 629 630 /* Determine the name of the encapsulating type. */ 631 rank = !(*as) || (*as)->rank == -1 ? GFC_MAX_DIMENSIONS : (*as)->rank; 632 get_unique_hashed_string (tname, ts->u.derived); 633 if ((*as) && attr->allocatable) 634 sprintf (name, "__class_%s_%d_%da", tname, rank, (*as)->corank); 635 else if ((*as) && attr->pointer) 636 sprintf (name, "__class_%s_%d_%dp", tname, rank, (*as)->corank); 637 else if ((*as)) 638 sprintf (name, "__class_%s_%d_%dt", tname, rank, (*as)->corank); 639 else if (attr->pointer) 640 sprintf (name, "__class_%s_p", tname); 641 else if (attr->allocatable) 642 sprintf (name, "__class_%s_a", tname); 643 else 644 sprintf (name, "__class_%s_t", tname); 645 646 if (ts->u.derived->attr.unlimited_polymorphic) 647 { 648 /* Find the top-level namespace. */ 649 for (ns = gfc_current_ns; ns; ns = ns->parent) 650 if (!ns->parent) 651 break; 652 } 653 else 654 ns = ts->u.derived->ns; 655 656 gfc_find_symbol (name, ns, 0, &fclass); 657 if (fclass == NULL) 658 { 659 gfc_symtree *st; 660 /* If not there, create a new symbol. */ 661 fclass = gfc_new_symbol (name, ns); 662 st = gfc_new_symtree (&ns->sym_root, name); 663 st->n.sym = fclass; 664 gfc_set_sym_referenced (fclass); 665 fclass->refs++; 666 fclass->ts.type = BT_UNKNOWN; 667 if (!ts->u.derived->attr.unlimited_polymorphic) 668 fclass->attr.abstract = ts->u.derived->attr.abstract; 669 fclass->f2k_derived = gfc_get_namespace (NULL, 0); 670 if (!gfc_add_flavor (&fclass->attr, FL_DERIVED, NULL, 671 &gfc_current_locus)) 672 return false; 673 674 /* Add component '_data'. */ 675 if (!gfc_add_component (fclass, "_data", &c)) 676 return false; 677 c->ts = *ts; 678 c->ts.type = BT_DERIVED; 679 c->attr.access = ACCESS_PRIVATE; 680 c->ts.u.derived = ts->u.derived; 681 c->attr.class_pointer = attr->pointer; 682 c->attr.pointer = attr->pointer || (attr->dummy && !attr->allocatable) 683 || attr->select_type_temporary; 684 c->attr.allocatable = attr->allocatable; 685 c->attr.dimension = attr->dimension; 686 c->attr.codimension = attr->codimension; 687 c->attr.abstract = fclass->attr.abstract; 688 c->as = (*as); 689 c->initializer = NULL; 690 691 /* Add component '_vptr'. */ 692 if (!gfc_add_component (fclass, "_vptr", &c)) 693 return false; 694 c->ts.type = BT_DERIVED; 695 c->attr.access = ACCESS_PRIVATE; 696 c->attr.pointer = 1; 697 698 if (ts->u.derived->attr.unlimited_polymorphic) 699 { 700 vtab = gfc_find_derived_vtab (ts->u.derived); 701 gcc_assert (vtab); 702 c->ts.u.derived = vtab->ts.u.derived; 703 704 /* Add component '_len'. Only unlimited polymorphic pointers may 705 have a string assigned to them, i.e., only those need the _len 706 component. */ 707 if (!gfc_add_component (fclass, "_len", &c)) 708 return false; 709 c->ts.type = BT_INTEGER; 710 c->ts.kind = 4; 711 c->attr.access = ACCESS_PRIVATE; 712 c->attr.artificial = 1; 713 } 714 else 715 /* Build vtab later. */ 716 c->ts.u.derived = NULL; 717 } 718 719 if (!ts->u.derived->attr.unlimited_polymorphic) 720 { 721 /* Since the extension field is 8 bit wide, we can only have 722 up to 255 extension levels. */ 723 if (ts->u.derived->attr.extension == 255) 724 { 725 gfc_error ("Maximum extension level reached with type %qs at %L", 726 ts->u.derived->name, &ts->u.derived->declared_at); 727 return false; 728 } 729 730 fclass->attr.extension = ts->u.derived->attr.extension + 1; 731 fclass->attr.alloc_comp = ts->u.derived->attr.alloc_comp; 732 fclass->attr.coarray_comp = ts->u.derived->attr.coarray_comp; 733 } 734 735 fclass->attr.is_class = 1; 736 ts->u.derived = fclass; 737 attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0; 738 (*as) = NULL; 739 return true; 740} 741 742 743/* Add a procedure pointer component to the vtype 744 to represent a specific type-bound procedure. */ 745 746static void 747add_proc_comp (gfc_symbol *vtype, const char *name, gfc_typebound_proc *tb) 748{ 749 gfc_component *c; 750 751 if (tb->non_overridable) 752 return; 753 754 c = gfc_find_component (vtype, name, true, true); 755 756 if (c == NULL) 757 { 758 /* Add procedure component. */ 759 if (!gfc_add_component (vtype, name, &c)) 760 return; 761 762 if (!c->tb) 763 c->tb = XCNEW (gfc_typebound_proc); 764 *c->tb = *tb; 765 c->tb->ppc = 1; 766 c->attr.procedure = 1; 767 c->attr.proc_pointer = 1; 768 c->attr.flavor = FL_PROCEDURE; 769 c->attr.access = ACCESS_PRIVATE; 770 c->attr.external = 1; 771 c->attr.untyped = 1; 772 c->attr.if_source = IFSRC_IFBODY; 773 } 774 else if (c->attr.proc_pointer && c->tb) 775 { 776 *c->tb = *tb; 777 c->tb->ppc = 1; 778 } 779 780 if (tb->u.specific) 781 { 782 gfc_symbol *ifc = tb->u.specific->n.sym; 783 c->ts.interface = ifc; 784 if (!tb->deferred) 785 c->initializer = gfc_get_variable_expr (tb->u.specific); 786 c->attr.pure = ifc->attr.pure; 787 } 788} 789 790 791/* Add all specific type-bound procedures in the symtree 'st' to a vtype. */ 792 793static void 794add_procs_to_declared_vtab1 (gfc_symtree *st, gfc_symbol *vtype) 795{ 796 if (!st) 797 return; 798 799 if (st->left) 800 add_procs_to_declared_vtab1 (st->left, vtype); 801 802 if (st->right) 803 add_procs_to_declared_vtab1 (st->right, vtype); 804 805 if (st->n.tb && !st->n.tb->error 806 && !st->n.tb->is_generic && st->n.tb->u.specific) 807 add_proc_comp (vtype, st->name, st->n.tb); 808} 809 810 811/* Copy procedure pointers components from the parent type. */ 812 813static void 814copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype) 815{ 816 gfc_component *cmp; 817 gfc_symbol *vtab; 818 819 vtab = gfc_find_derived_vtab (declared); 820 821 for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next) 822 { 823 if (gfc_find_component (vtype, cmp->name, true, true)) 824 continue; 825 826 add_proc_comp (vtype, cmp->name, cmp->tb); 827 } 828} 829 830 831/* Returns true if any of its nonpointer nonallocatable components or 832 their nonpointer nonallocatable subcomponents has a finalization 833 subroutine. */ 834 835static bool 836has_finalizer_component (gfc_symbol *derived) 837{ 838 gfc_component *c; 839 840 for (c = derived->components; c; c = c->next) 841 { 842 if (c->ts.type == BT_DERIVED && c->ts.u.derived->f2k_derived 843 && c->ts.u.derived->f2k_derived->finalizers) 844 return true; 845 846 /* Stop infinite recursion through this function by inhibiting 847 calls when the derived type and that of the component are 848 the same. */ 849 if (c->ts.type == BT_DERIVED 850 && !gfc_compare_derived_types (derived, c->ts.u.derived) 851 && !c->attr.pointer && !c->attr.allocatable 852 && has_finalizer_component (c->ts.u.derived)) 853 return true; 854 } 855 return false; 856} 857 858 859static bool 860comp_is_finalizable (gfc_component *comp) 861{ 862 if (comp->attr.proc_pointer) 863 return false; 864 else if (comp->attr.allocatable && comp->ts.type != BT_CLASS) 865 return true; 866 else if (comp->ts.type == BT_DERIVED && !comp->attr.pointer 867 && (comp->ts.u.derived->attr.alloc_comp 868 || has_finalizer_component (comp->ts.u.derived) 869 || (comp->ts.u.derived->f2k_derived 870 && comp->ts.u.derived->f2k_derived->finalizers))) 871 return true; 872 else if (comp->ts.type == BT_CLASS && CLASS_DATA (comp) 873 && CLASS_DATA (comp)->attr.allocatable) 874 return true; 875 else 876 return false; 877} 878 879 880/* Call DEALLOCATE for the passed component if it is allocatable, if it is 881 neither allocatable nor a pointer but has a finalizer, call it. If it 882 is a nonpointer component with allocatable components or has finalizers, walk 883 them. Either of them is required; other nonallocatables and pointers aren't 884 handled gracefully. 885 Note: If the component is allocatable, the DEALLOCATE handling takes care 886 of calling the appropriate finalizers, coarray deregistering, and 887 deallocation of allocatable subcomponents. */ 888 889static void 890finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp, 891 gfc_symbol *stat, gfc_symbol *fini_coarray, gfc_code **code, 892 gfc_namespace *sub_ns) 893{ 894 gfc_expr *e; 895 gfc_ref *ref; 896 897 if (!comp_is_finalizable (comp)) 898 return; 899 900 e = gfc_copy_expr (expr); 901 if (!e->ref) 902 e->ref = ref = gfc_get_ref (); 903 else 904 { 905 for (ref = e->ref; ref->next; ref = ref->next) 906 ; 907 ref->next = gfc_get_ref (); 908 ref = ref->next; 909 } 910 ref->type = REF_COMPONENT; 911 ref->u.c.sym = derived; 912 ref->u.c.component = comp; 913 e->ts = comp->ts; 914 915 if (comp->attr.dimension || comp->attr.codimension 916 || (comp->ts.type == BT_CLASS && CLASS_DATA (comp) 917 && (CLASS_DATA (comp)->attr.dimension 918 || CLASS_DATA (comp)->attr.codimension))) 919 { 920 ref->next = gfc_get_ref (); 921 ref->next->type = REF_ARRAY; 922 ref->next->u.ar.dimen = 0; 923 ref->next->u.ar.as = comp->ts.type == BT_CLASS ? CLASS_DATA (comp)->as 924 : comp->as; 925 e->rank = ref->next->u.ar.as->rank; 926 ref->next->u.ar.type = e->rank ? AR_FULL : AR_ELEMENT; 927 } 928 929 /* Call DEALLOCATE (comp, stat=ignore). */ 930 if (comp->attr.allocatable 931 || (comp->ts.type == BT_CLASS && CLASS_DATA (comp) 932 && CLASS_DATA (comp)->attr.allocatable)) 933 { 934 gfc_code *dealloc, *block = NULL; 935 936 /* Add IF (fini_coarray). */ 937 if (comp->attr.codimension 938 || (comp->ts.type == BT_CLASS && CLASS_DATA (comp) 939 && CLASS_DATA (comp)->attr.codimension)) 940 { 941 block = gfc_get_code (EXEC_IF); 942 if (*code) 943 { 944 (*code)->next = block; 945 (*code) = (*code)->next; 946 } 947 else 948 (*code) = block; 949 950 block->block = gfc_get_code (EXEC_IF); 951 block = block->block; 952 block->expr1 = gfc_lval_expr_from_sym (fini_coarray); 953 } 954 955 dealloc = gfc_get_code (EXEC_DEALLOCATE); 956 957 dealloc->ext.alloc.list = gfc_get_alloc (); 958 dealloc->ext.alloc.list->expr = e; 959 dealloc->expr1 = gfc_lval_expr_from_sym (stat); 960 961 gfc_code *cond = gfc_get_code (EXEC_IF); 962 cond->block = gfc_get_code (EXEC_IF); 963 cond->block->expr1 = gfc_get_expr (); 964 cond->block->expr1->expr_type = EXPR_FUNCTION; 965 gfc_get_sym_tree ("associated", sub_ns, &cond->block->expr1->symtree, false); 966 cond->block->expr1->symtree->n.sym->attr.flavor = FL_PROCEDURE; 967 cond->block->expr1->symtree->n.sym->attr.intrinsic = 1; 968 cond->block->expr1->symtree->n.sym->result = cond->block->expr1->symtree->n.sym; 969 gfc_commit_symbol (cond->block->expr1->symtree->n.sym); 970 cond->block->expr1->ts.type = BT_LOGICAL; 971 cond->block->expr1->ts.kind = gfc_default_logical_kind; 972 cond->block->expr1->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_ASSOCIATED); 973 cond->block->expr1->value.function.actual = gfc_get_actual_arglist (); 974 cond->block->expr1->value.function.actual->expr = gfc_copy_expr (expr); 975 cond->block->expr1->value.function.actual->next = gfc_get_actual_arglist (); 976 cond->block->next = dealloc; 977 978 if (block) 979 block->next = cond; 980 else if (*code) 981 { 982 (*code)->next = cond; 983 (*code) = (*code)->next; 984 } 985 else 986 (*code) = cond; 987 } 988 else if (comp->ts.type == BT_DERIVED 989 && comp->ts.u.derived->f2k_derived 990 && comp->ts.u.derived->f2k_derived->finalizers) 991 { 992 /* Call FINAL_WRAPPER (comp); */ 993 gfc_code *final_wrap; 994 gfc_symbol *vtab; 995 gfc_component *c; 996 997 vtab = gfc_find_derived_vtab (comp->ts.u.derived); 998 for (c = vtab->ts.u.derived->components; c; c = c->next) 999 if (strcmp (c->name, "_final") == 0) 1000 break; 1001 1002 gcc_assert (c); 1003 final_wrap = gfc_get_code (EXEC_CALL); 1004 final_wrap->symtree = c->initializer->symtree; 1005 final_wrap->resolved_sym = c->initializer->symtree->n.sym; 1006 final_wrap->ext.actual = gfc_get_actual_arglist (); 1007 final_wrap->ext.actual->expr = e; 1008 1009 if (*code) 1010 { 1011 (*code)->next = final_wrap; 1012 (*code) = (*code)->next; 1013 } 1014 else 1015 (*code) = final_wrap; 1016 } 1017 else 1018 { 1019 gfc_component *c; 1020 1021 for (c = comp->ts.u.derived->components; c; c = c->next) 1022 finalize_component (e, comp->ts.u.derived, c, stat, fini_coarray, code, 1023 sub_ns); 1024 gfc_free_expr (e); 1025 } 1026} 1027 1028 1029/* Generate code equivalent to 1030 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr) 1031 + offset, c_ptr), ptr). */ 1032 1033static gfc_code * 1034finalization_scalarizer (gfc_symbol *array, gfc_symbol *ptr, 1035 gfc_expr *offset, gfc_namespace *sub_ns) 1036{ 1037 gfc_code *block; 1038 gfc_expr *expr, *expr2; 1039 1040 /* C_F_POINTER(). */ 1041 block = gfc_get_code (EXEC_CALL); 1042 gfc_get_sym_tree ("c_f_pointer", sub_ns, &block->symtree, true); 1043 block->resolved_sym = block->symtree->n.sym; 1044 block->resolved_sym->attr.flavor = FL_PROCEDURE; 1045 block->resolved_sym->attr.intrinsic = 1; 1046 block->resolved_sym->attr.subroutine = 1; 1047 block->resolved_sym->from_intmod = INTMOD_ISO_C_BINDING; 1048 block->resolved_sym->intmod_sym_id = ISOCBINDING_F_POINTER; 1049 block->resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_C_F_POINTER); 1050 gfc_commit_symbol (block->resolved_sym); 1051 1052 /* C_F_POINTER's first argument: TRANSFER ( <addr>, c_intptr_t). */ 1053 block->ext.actual = gfc_get_actual_arglist (); 1054 block->ext.actual->next = gfc_get_actual_arglist (); 1055 block->ext.actual->next->expr = gfc_get_int_expr (gfc_index_integer_kind, 1056 NULL, 0); 1057 block->ext.actual->next->next = gfc_get_actual_arglist (); /* SIZE. */ 1058 1059 /* The <addr> part: TRANSFER (C_LOC (array), c_intptr_t). */ 1060 1061 /* TRANSFER's first argument: C_LOC (array). */ 1062 expr = gfc_get_expr (); 1063 expr->expr_type = EXPR_FUNCTION; 1064 gfc_get_sym_tree ("c_loc", sub_ns, &expr->symtree, false); 1065 expr->symtree->n.sym->attr.flavor = FL_PROCEDURE; 1066 expr->symtree->n.sym->intmod_sym_id = ISOCBINDING_LOC; 1067 expr->symtree->n.sym->attr.intrinsic = 1; 1068 expr->symtree->n.sym->from_intmod = INTMOD_ISO_C_BINDING; 1069 expr->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_C_LOC); 1070 expr->value.function.actual = gfc_get_actual_arglist (); 1071 expr->value.function.actual->expr 1072 = gfc_lval_expr_from_sym (array); 1073 expr->symtree->n.sym->result = expr->symtree->n.sym; 1074 gfc_commit_symbol (expr->symtree->n.sym); 1075 expr->ts.type = BT_INTEGER; 1076 expr->ts.kind = gfc_index_integer_kind; 1077 1078 /* TRANSFER. */ 1079 expr2 = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_TRANSFER, "transfer", 1080 gfc_current_locus, 3, expr, 1081 gfc_get_int_expr (gfc_index_integer_kind, 1082 NULL, 0), NULL); 1083 expr2->ts.type = BT_INTEGER; 1084 expr2->ts.kind = gfc_index_integer_kind; 1085 1086 /* <array addr> + <offset>. */ 1087 block->ext.actual->expr = gfc_get_expr (); 1088 block->ext.actual->expr->expr_type = EXPR_OP; 1089 block->ext.actual->expr->value.op.op = INTRINSIC_PLUS; 1090 block->ext.actual->expr->value.op.op1 = expr2; 1091 block->ext.actual->expr->value.op.op2 = offset; 1092 block->ext.actual->expr->ts = expr->ts; 1093 1094 /* C_F_POINTER's 2nd arg: ptr -- and its absent shape=. */ 1095 block->ext.actual->next = gfc_get_actual_arglist (); 1096 block->ext.actual->next->expr = gfc_lval_expr_from_sym (ptr); 1097 block->ext.actual->next->next = gfc_get_actual_arglist (); 1098 1099 return block; 1100} 1101 1102 1103/* Calculates the offset to the (idx+1)th element of an array, taking the 1104 stride into account. It generates the code: 1105 offset = 0 1106 do idx2 = 1, rank 1107 offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1) * strides(idx2) 1108 end do 1109 offset = offset * byte_stride. */ 1110 1111static gfc_code* 1112finalization_get_offset (gfc_symbol *idx, gfc_symbol *idx2, gfc_symbol *offset, 1113 gfc_symbol *strides, gfc_symbol *sizes, 1114 gfc_symbol *byte_stride, gfc_expr *rank, 1115 gfc_code *block, gfc_namespace *sub_ns) 1116{ 1117 gfc_iterator *iter; 1118 gfc_expr *expr, *expr2; 1119 1120 /* offset = 0. */ 1121 block->next = gfc_get_code (EXEC_ASSIGN); 1122 block = block->next; 1123 block->expr1 = gfc_lval_expr_from_sym (offset); 1124 block->expr2 = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0); 1125 1126 /* Create loop. */ 1127 iter = gfc_get_iterator (); 1128 iter->var = gfc_lval_expr_from_sym (idx2); 1129 iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); 1130 iter->end = gfc_copy_expr (rank); 1131 iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); 1132 block->next = gfc_get_code (EXEC_DO); 1133 block = block->next; 1134 block->ext.iterator = iter; 1135 block->block = gfc_get_code (EXEC_DO); 1136 1137 /* Loop body: offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1) 1138 * strides(idx2). */ 1139 1140 /* mod (idx, sizes(idx2)). */ 1141 expr = gfc_lval_expr_from_sym (sizes); 1142 expr->ref = gfc_get_ref (); 1143 expr->ref->type = REF_ARRAY; 1144 expr->ref->u.ar.as = sizes->as; 1145 expr->ref->u.ar.type = AR_ELEMENT; 1146 expr->ref->u.ar.dimen = 1; 1147 expr->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; 1148 expr->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx2); 1149 1150 expr = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_MOD, "mod", 1151 gfc_current_locus, 2, 1152 gfc_lval_expr_from_sym (idx), expr); 1153 expr->ts = idx->ts; 1154 1155 /* (...) / sizes(idx2-1). */ 1156 expr2 = gfc_get_expr (); 1157 expr2->expr_type = EXPR_OP; 1158 expr2->value.op.op = INTRINSIC_DIVIDE; 1159 expr2->value.op.op1 = expr; 1160 expr2->value.op.op2 = gfc_lval_expr_from_sym (sizes); 1161 expr2->value.op.op2->ref = gfc_get_ref (); 1162 expr2->value.op.op2->ref->type = REF_ARRAY; 1163 expr2->value.op.op2->ref->u.ar.as = sizes->as; 1164 expr2->value.op.op2->ref->u.ar.type = AR_ELEMENT; 1165 expr2->value.op.op2->ref->u.ar.dimen = 1; 1166 expr2->value.op.op2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; 1167 expr2->value.op.op2->ref->u.ar.start[0] = gfc_get_expr (); 1168 expr2->value.op.op2->ref->u.ar.start[0]->expr_type = EXPR_OP; 1169 expr2->value.op.op2->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS; 1170 expr2->value.op.op2->ref->u.ar.start[0]->value.op.op1 1171 = gfc_lval_expr_from_sym (idx2); 1172 expr2->value.op.op2->ref->u.ar.start[0]->value.op.op2 1173 = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); 1174 expr2->value.op.op2->ref->u.ar.start[0]->ts 1175 = expr2->value.op.op2->ref->u.ar.start[0]->value.op.op1->ts; 1176 expr2->ts = idx->ts; 1177 1178 /* ... * strides(idx2). */ 1179 expr = gfc_get_expr (); 1180 expr->expr_type = EXPR_OP; 1181 expr->value.op.op = INTRINSIC_TIMES; 1182 expr->value.op.op1 = expr2; 1183 expr->value.op.op2 = gfc_lval_expr_from_sym (strides); 1184 expr->value.op.op2->ref = gfc_get_ref (); 1185 expr->value.op.op2->ref->type = REF_ARRAY; 1186 expr->value.op.op2->ref->u.ar.type = AR_ELEMENT; 1187 expr->value.op.op2->ref->u.ar.dimen = 1; 1188 expr->value.op.op2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; 1189 expr->value.op.op2->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx2); 1190 expr->value.op.op2->ref->u.ar.as = strides->as; 1191 expr->ts = idx->ts; 1192 1193 /* offset = offset + ... */ 1194 block->block->next = gfc_get_code (EXEC_ASSIGN); 1195 block->block->next->expr1 = gfc_lval_expr_from_sym (offset); 1196 block->block->next->expr2 = gfc_get_expr (); 1197 block->block->next->expr2->expr_type = EXPR_OP; 1198 block->block->next->expr2->value.op.op = INTRINSIC_PLUS; 1199 block->block->next->expr2->value.op.op1 = gfc_lval_expr_from_sym (offset); 1200 block->block->next->expr2->value.op.op2 = expr; 1201 block->block->next->expr2->ts = idx->ts; 1202 1203 /* After the loop: offset = offset * byte_stride. */ 1204 block->next = gfc_get_code (EXEC_ASSIGN); 1205 block = block->next; 1206 block->expr1 = gfc_lval_expr_from_sym (offset); 1207 block->expr2 = gfc_get_expr (); 1208 block->expr2->expr_type = EXPR_OP; 1209 block->expr2->value.op.op = INTRINSIC_TIMES; 1210 block->expr2->value.op.op1 = gfc_lval_expr_from_sym (offset); 1211 block->expr2->value.op.op2 = gfc_lval_expr_from_sym (byte_stride); 1212 block->expr2->ts = block->expr2->value.op.op1->ts; 1213 return block; 1214} 1215 1216 1217/* Insert code of the following form: 1218 1219 block 1220 integer(c_intptr_t) :: i 1221 1222 if ((byte_stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE 1223 && (is_contiguous || !final_rank3->attr.contiguous 1224 || final_rank3->as->type != AS_ASSUMED_SHAPE)) 1225 || 0 == STORAGE_SIZE (array)) then 1226 call final_rank3 (array) 1227 else 1228 block 1229 integer(c_intptr_t) :: offset, j 1230 type(t) :: tmp(shape (array)) 1231 1232 do i = 0, size (array)-1 1233 offset = obtain_offset(i, strides, sizes, byte_stride) 1234 addr = transfer (c_loc (array), addr) + offset 1235 call c_f_pointer (transfer (addr, cptr), ptr) 1236 1237 addr = transfer (c_loc (tmp), addr) 1238 + i * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE 1239 call c_f_pointer (transfer (addr, cptr), ptr2) 1240 ptr2 = ptr 1241 end do 1242 call final_rank3 (tmp) 1243 end block 1244 end if 1245 block */ 1246 1247static void 1248finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini, 1249 gfc_symbol *array, gfc_symbol *byte_stride, 1250 gfc_symbol *idx, gfc_symbol *ptr, 1251 gfc_symbol *nelem, 1252 gfc_symbol *strides, gfc_symbol *sizes, 1253 gfc_symbol *idx2, gfc_symbol *offset, 1254 gfc_symbol *is_contiguous, gfc_expr *rank, 1255 gfc_namespace *sub_ns) 1256{ 1257 gfc_symbol *tmp_array, *ptr2; 1258 gfc_expr *size_expr, *offset2, *expr; 1259 gfc_namespace *ns; 1260 gfc_iterator *iter; 1261 gfc_code *block2; 1262 int i; 1263 1264 block->next = gfc_get_code (EXEC_IF); 1265 block = block->next; 1266 1267 block->block = gfc_get_code (EXEC_IF); 1268 block = block->block; 1269 1270 /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */ 1271 size_expr = gfc_get_expr (); 1272 size_expr->where = gfc_current_locus; 1273 size_expr->expr_type = EXPR_OP; 1274 size_expr->value.op.op = INTRINSIC_DIVIDE; 1275 1276 /* STORAGE_SIZE (array,kind=c_intptr_t). */ 1277 size_expr->value.op.op1 1278 = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_STORAGE_SIZE, 1279 "storage_size", gfc_current_locus, 2, 1280 gfc_lval_expr_from_sym (array), 1281 gfc_get_int_expr (gfc_index_integer_kind, 1282 NULL, 0)); 1283 1284 /* NUMERIC_STORAGE_SIZE. */ 1285 size_expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1286 gfc_character_storage_size); 1287 size_expr->value.op.op1->ts = size_expr->value.op.op2->ts; 1288 size_expr->ts = size_expr->value.op.op1->ts; 1289 1290 /* IF condition: (stride == size_expr 1291 && ((fini's as->ASSUMED_SIZE && !fini's attr.contiguous) 1292 || is_contiguous) 1293 || 0 == size_expr. */ 1294 block->expr1 = gfc_get_expr (); 1295 block->expr1->ts.type = BT_LOGICAL; 1296 block->expr1->ts.kind = gfc_default_logical_kind; 1297 block->expr1->expr_type = EXPR_OP; 1298 block->expr1->where = gfc_current_locus; 1299 1300 block->expr1->value.op.op = INTRINSIC_OR; 1301 1302 /* byte_stride == size_expr */ 1303 expr = gfc_get_expr (); 1304 expr->ts.type = BT_LOGICAL; 1305 expr->ts.kind = gfc_default_logical_kind; 1306 expr->expr_type = EXPR_OP; 1307 expr->where = gfc_current_locus; 1308 expr->value.op.op = INTRINSIC_EQ; 1309 expr->value.op.op1 1310 = gfc_lval_expr_from_sym (byte_stride); 1311 expr->value.op.op2 = size_expr; 1312 1313 /* If strides aren't allowed (not assumed shape or CONTIGUOUS), 1314 add is_contiguous check. */ 1315 1316 if (fini->proc_tree->n.sym->formal->sym->as->type != AS_ASSUMED_SHAPE 1317 || fini->proc_tree->n.sym->formal->sym->attr.contiguous) 1318 { 1319 gfc_expr *expr2; 1320 expr2 = gfc_get_expr (); 1321 expr2->ts.type = BT_LOGICAL; 1322 expr2->ts.kind = gfc_default_logical_kind; 1323 expr2->expr_type = EXPR_OP; 1324 expr2->where = gfc_current_locus; 1325 expr2->value.op.op = INTRINSIC_AND; 1326 expr2->value.op.op1 = expr; 1327 expr2->value.op.op2 = gfc_lval_expr_from_sym (is_contiguous); 1328 expr = expr2; 1329 } 1330 1331 block->expr1->value.op.op1 = expr; 1332 1333 /* 0 == size_expr */ 1334 block->expr1->value.op.op2 = gfc_get_expr (); 1335 block->expr1->value.op.op2->ts.type = BT_LOGICAL; 1336 block->expr1->value.op.op2->ts.kind = gfc_default_logical_kind; 1337 block->expr1->value.op.op2->expr_type = EXPR_OP; 1338 block->expr1->value.op.op2->where = gfc_current_locus; 1339 block->expr1->value.op.op2->value.op.op = INTRINSIC_EQ; 1340 block->expr1->value.op.op2->value.op.op1 = 1341 gfc_get_int_expr (gfc_index_integer_kind, NULL, 0); 1342 block->expr1->value.op.op2->value.op.op2 = gfc_copy_expr (size_expr); 1343 1344 /* IF body: call final subroutine. */ 1345 block->next = gfc_get_code (EXEC_CALL); 1346 block->next->symtree = fini->proc_tree; 1347 block->next->resolved_sym = fini->proc_tree->n.sym; 1348 block->next->ext.actual = gfc_get_actual_arglist (); 1349 block->next->ext.actual->expr = gfc_lval_expr_from_sym (array); 1350 1351 /* ELSE. */ 1352 1353 block->block = gfc_get_code (EXEC_IF); 1354 block = block->block; 1355 1356 /* BLOCK ... END BLOCK. */ 1357 block->next = gfc_get_code (EXEC_BLOCK); 1358 block = block->next; 1359 1360 ns = gfc_build_block_ns (sub_ns); 1361 block->ext.block.ns = ns; 1362 block->ext.block.assoc = NULL; 1363 1364 gfc_get_symbol ("ptr2", ns, &ptr2); 1365 ptr2->ts.type = BT_DERIVED; 1366 ptr2->ts.u.derived = array->ts.u.derived; 1367 ptr2->attr.flavor = FL_VARIABLE; 1368 ptr2->attr.pointer = 1; 1369 ptr2->attr.artificial = 1; 1370 gfc_set_sym_referenced (ptr2); 1371 gfc_commit_symbol (ptr2); 1372 1373 gfc_get_symbol ("tmp_array", ns, &tmp_array); 1374 tmp_array->ts.type = BT_DERIVED; 1375 tmp_array->ts.u.derived = array->ts.u.derived; 1376 tmp_array->attr.flavor = FL_VARIABLE; 1377 tmp_array->attr.dimension = 1; 1378 tmp_array->attr.artificial = 1; 1379 tmp_array->as = gfc_get_array_spec(); 1380 tmp_array->attr.intent = INTENT_INOUT; 1381 tmp_array->as->type = AS_EXPLICIT; 1382 tmp_array->as->rank = fini->proc_tree->n.sym->formal->sym->as->rank; 1383 1384 for (i = 0; i < tmp_array->as->rank; i++) 1385 { 1386 gfc_expr *shape_expr; 1387 tmp_array->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, 1388 NULL, 1); 1389 /* SIZE (array, dim=i+1, kind=gfc_index_integer_kind). */ 1390 shape_expr 1391 = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_SIZE, "size", 1392 gfc_current_locus, 3, 1393 gfc_lval_expr_from_sym (array), 1394 gfc_get_int_expr (gfc_default_integer_kind, 1395 NULL, i+1), 1396 gfc_get_int_expr (gfc_default_integer_kind, 1397 NULL, 1398 gfc_index_integer_kind)); 1399 shape_expr->ts.kind = gfc_index_integer_kind; 1400 tmp_array->as->upper[i] = shape_expr; 1401 } 1402 gfc_set_sym_referenced (tmp_array); 1403 gfc_commit_symbol (tmp_array); 1404 1405 /* Create loop. */ 1406 iter = gfc_get_iterator (); 1407 iter->var = gfc_lval_expr_from_sym (idx); 1408 iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0); 1409 iter->end = gfc_lval_expr_from_sym (nelem); 1410 iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); 1411 1412 block = gfc_get_code (EXEC_DO); 1413 ns->code = block; 1414 block->ext.iterator = iter; 1415 block->block = gfc_get_code (EXEC_DO); 1416 1417 /* Offset calculation for the new array: idx * size of type (in bytes). */ 1418 offset2 = gfc_get_expr (); 1419 offset2->expr_type = EXPR_OP; 1420 offset2->value.op.op = INTRINSIC_TIMES; 1421 offset2->value.op.op1 = gfc_lval_expr_from_sym (idx); 1422 offset2->value.op.op2 = gfc_copy_expr (size_expr); 1423 offset2->ts = byte_stride->ts; 1424 1425 /* Offset calculation of "array". */ 1426 block2 = finalization_get_offset (idx, idx2, offset, strides, sizes, 1427 byte_stride, rank, block->block, sub_ns); 1428 1429 /* Create code for 1430 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr) 1431 + idx * stride, c_ptr), ptr). */ 1432 block2->next = finalization_scalarizer (array, ptr, 1433 gfc_lval_expr_from_sym (offset), 1434 sub_ns); 1435 block2 = block2->next; 1436 block2->next = finalization_scalarizer (tmp_array, ptr2, offset2, sub_ns); 1437 block2 = block2->next; 1438 1439 /* ptr2 = ptr. */ 1440 block2->next = gfc_get_code (EXEC_ASSIGN); 1441 block2 = block2->next; 1442 block2->expr1 = gfc_lval_expr_from_sym (ptr2); 1443 block2->expr2 = gfc_lval_expr_from_sym (ptr); 1444 1445 /* Call now the user's final subroutine. */ 1446 block->next = gfc_get_code (EXEC_CALL); 1447 block = block->next; 1448 block->symtree = fini->proc_tree; 1449 block->resolved_sym = fini->proc_tree->n.sym; 1450 block->ext.actual = gfc_get_actual_arglist (); 1451 block->ext.actual->expr = gfc_lval_expr_from_sym (tmp_array); 1452 1453 if (fini->proc_tree->n.sym->formal->sym->attr.intent == INTENT_IN) 1454 return; 1455 1456 /* Copy back. */ 1457 1458 /* Loop. */ 1459 iter = gfc_get_iterator (); 1460 iter->var = gfc_lval_expr_from_sym (idx); 1461 iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0); 1462 iter->end = gfc_lval_expr_from_sym (nelem); 1463 iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); 1464 1465 block->next = gfc_get_code (EXEC_DO); 1466 block = block->next; 1467 block->ext.iterator = iter; 1468 block->block = gfc_get_code (EXEC_DO); 1469 1470 /* Offset calculation of "array". */ 1471 block2 = finalization_get_offset (idx, idx2, offset, strides, sizes, 1472 byte_stride, rank, block->block, sub_ns); 1473 1474 /* Create code for 1475 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr) 1476 + offset, c_ptr), ptr). */ 1477 block2->next = finalization_scalarizer (array, ptr, 1478 gfc_lval_expr_from_sym (offset), 1479 sub_ns); 1480 block2 = block2->next; 1481 block2->next = finalization_scalarizer (tmp_array, ptr2, 1482 gfc_copy_expr (offset2), sub_ns); 1483 block2 = block2->next; 1484 1485 /* ptr = ptr2. */ 1486 block2->next = gfc_get_code (EXEC_ASSIGN); 1487 block2->next->expr1 = gfc_lval_expr_from_sym (ptr); 1488 block2->next->expr2 = gfc_lval_expr_from_sym (ptr2); 1489} 1490 1491 1492/* Generate the finalization/polymorphic freeing wrapper subroutine for the 1493 derived type "derived". The function first calls the approriate FINAL 1494 subroutine, then it DEALLOCATEs (finalizes/frees) the allocatable 1495 components (but not the inherited ones). Last, it calls the wrapper 1496 subroutine of the parent. The generated wrapper procedure takes as argument 1497 an assumed-rank array. 1498 If neither allocatable components nor FINAL subroutines exists, the vtab 1499 will contain a NULL pointer. 1500 The generated function has the form 1501 _final(assumed-rank array, stride, skip_corarray) 1502 where the array has to be contiguous (except of the lowest dimension). The 1503 stride (in bytes) is used to allow different sizes for ancestor types by 1504 skipping over the additionally added components in the scalarizer. If 1505 "fini_coarray" is false, coarray components are not finalized to allow for 1506 the correct semantic with intrinsic assignment. */ 1507 1508static void 1509generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, 1510 const char *tname, gfc_component *vtab_final) 1511{ 1512 gfc_symbol *final, *array, *fini_coarray, *byte_stride, *sizes, *strides; 1513 gfc_symbol *ptr = NULL, *idx, *idx2, *is_contiguous, *offset, *nelem; 1514 gfc_component *comp; 1515 gfc_namespace *sub_ns; 1516 gfc_code *last_code, *block; 1517 char name[GFC_MAX_SYMBOL_LEN+1]; 1518 bool finalizable_comp = false; 1519 bool expr_null_wrapper = false; 1520 gfc_expr *ancestor_wrapper = NULL, *rank; 1521 gfc_iterator *iter; 1522 1523 if (derived->attr.unlimited_polymorphic) 1524 { 1525 vtab_final->initializer = gfc_get_null_expr (NULL); 1526 return; 1527 } 1528 1529 /* Search for the ancestor's finalizers. */ 1530 if (derived->attr.extension && derived->components 1531 && (!derived->components->ts.u.derived->attr.abstract 1532 || has_finalizer_component (derived))) 1533 { 1534 gfc_symbol *vtab; 1535 gfc_component *comp; 1536 1537 vtab = gfc_find_derived_vtab (derived->components->ts.u.derived); 1538 for (comp = vtab->ts.u.derived->components; comp; comp = comp->next) 1539 if (comp->name[0] == '_' && comp->name[1] == 'f') 1540 { 1541 ancestor_wrapper = comp->initializer; 1542 break; 1543 } 1544 } 1545 1546 /* No wrapper of the ancestor and no own FINAL subroutines and allocatable 1547 components: Return a NULL() expression; we defer this a bit to have have 1548 an interface declaration. */ 1549 if ((!ancestor_wrapper || ancestor_wrapper->expr_type == EXPR_NULL) 1550 && !derived->attr.alloc_comp 1551 && (!derived->f2k_derived || !derived->f2k_derived->finalizers) 1552 && !has_finalizer_component (derived)) 1553 expr_null_wrapper = true; 1554 else 1555 /* Check whether there are new allocatable components. */ 1556 for (comp = derived->components; comp; comp = comp->next) 1557 { 1558 if (comp == derived->components && derived->attr.extension 1559 && ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL) 1560 continue; 1561 1562 finalizable_comp |= comp_is_finalizable (comp); 1563 } 1564 1565 /* If there is no new finalizer and no new allocatable, return with 1566 an expr to the ancestor's one. */ 1567 if (!expr_null_wrapper && !finalizable_comp 1568 && (!derived->f2k_derived || !derived->f2k_derived->finalizers)) 1569 { 1570 gcc_assert (ancestor_wrapper && ancestor_wrapper->ref == NULL 1571 && ancestor_wrapper->expr_type == EXPR_VARIABLE); 1572 vtab_final->initializer = gfc_copy_expr (ancestor_wrapper); 1573 vtab_final->ts.interface = vtab_final->initializer->symtree->n.sym; 1574 return; 1575 } 1576 1577 /* We now create a wrapper, which does the following: 1578 1. Call the suitable finalization subroutine for this type 1579 2. Loop over all noninherited allocatable components and noninherited 1580 components with allocatable components and DEALLOCATE those; this will 1581 take care of finalizers, coarray deregistering and allocatable 1582 nested components. 1583 3. Call the ancestor's finalizer. */ 1584 1585 /* Declare the wrapper function; it takes an assumed-rank array 1586 and a VALUE logical as arguments. */ 1587 1588 /* Set up the namespace. */ 1589 sub_ns = gfc_get_namespace (ns, 0); 1590 sub_ns->sibling = ns->contained; 1591 if (!expr_null_wrapper) 1592 ns->contained = sub_ns; 1593 sub_ns->resolved = 1; 1594 1595 /* Set up the procedure symbol. */ 1596 sprintf (name, "__final_%s", tname); 1597 gfc_get_symbol (name, sub_ns, &final); 1598 sub_ns->proc_name = final; 1599 final->attr.flavor = FL_PROCEDURE; 1600 final->attr.function = 1; 1601 final->attr.pure = 0; 1602 final->result = final; 1603 final->ts.type = BT_INTEGER; 1604 final->ts.kind = 4; 1605 final->attr.artificial = 1; 1606 final->attr.always_explicit = 1; 1607 final->attr.if_source = expr_null_wrapper ? IFSRC_IFBODY : IFSRC_DECL; 1608 if (ns->proc_name->attr.flavor == FL_MODULE) 1609 final->module = ns->proc_name->name; 1610 gfc_set_sym_referenced (final); 1611 gfc_commit_symbol (final); 1612 1613 /* Set up formal argument. */ 1614 gfc_get_symbol ("array", sub_ns, &array); 1615 array->ts.type = BT_DERIVED; 1616 array->ts.u.derived = derived; 1617 array->attr.flavor = FL_VARIABLE; 1618 array->attr.dummy = 1; 1619 array->attr.contiguous = 1; 1620 array->attr.dimension = 1; 1621 array->attr.artificial = 1; 1622 array->as = gfc_get_array_spec(); 1623 array->as->type = AS_ASSUMED_RANK; 1624 array->as->rank = -1; 1625 array->attr.intent = INTENT_INOUT; 1626 gfc_set_sym_referenced (array); 1627 final->formal = gfc_get_formal_arglist (); 1628 final->formal->sym = array; 1629 gfc_commit_symbol (array); 1630 1631 /* Set up formal argument. */ 1632 gfc_get_symbol ("byte_stride", sub_ns, &byte_stride); 1633 byte_stride->ts.type = BT_INTEGER; 1634 byte_stride->ts.kind = gfc_index_integer_kind; 1635 byte_stride->attr.flavor = FL_VARIABLE; 1636 byte_stride->attr.dummy = 1; 1637 byte_stride->attr.value = 1; 1638 byte_stride->attr.artificial = 1; 1639 gfc_set_sym_referenced (byte_stride); 1640 final->formal->next = gfc_get_formal_arglist (); 1641 final->formal->next->sym = byte_stride; 1642 gfc_commit_symbol (byte_stride); 1643 1644 /* Set up formal argument. */ 1645 gfc_get_symbol ("fini_coarray", sub_ns, &fini_coarray); 1646 fini_coarray->ts.type = BT_LOGICAL; 1647 fini_coarray->ts.kind = 1; 1648 fini_coarray->attr.flavor = FL_VARIABLE; 1649 fini_coarray->attr.dummy = 1; 1650 fini_coarray->attr.value = 1; 1651 fini_coarray->attr.artificial = 1; 1652 gfc_set_sym_referenced (fini_coarray); 1653 final->formal->next->next = gfc_get_formal_arglist (); 1654 final->formal->next->next->sym = fini_coarray; 1655 gfc_commit_symbol (fini_coarray); 1656 1657 /* Return with a NULL() expression but with an interface which has 1658 the formal arguments. */ 1659 if (expr_null_wrapper) 1660 { 1661 vtab_final->initializer = gfc_get_null_expr (NULL); 1662 vtab_final->ts.interface = final; 1663 return; 1664 } 1665 1666 /* Local variables. */ 1667 1668 gfc_get_symbol ("idx", sub_ns, &idx); 1669 idx->ts.type = BT_INTEGER; 1670 idx->ts.kind = gfc_index_integer_kind; 1671 idx->attr.flavor = FL_VARIABLE; 1672 idx->attr.artificial = 1; 1673 gfc_set_sym_referenced (idx); 1674 gfc_commit_symbol (idx); 1675 1676 gfc_get_symbol ("idx2", sub_ns, &idx2); 1677 idx2->ts.type = BT_INTEGER; 1678 idx2->ts.kind = gfc_index_integer_kind; 1679 idx2->attr.flavor = FL_VARIABLE; 1680 idx2->attr.artificial = 1; 1681 gfc_set_sym_referenced (idx2); 1682 gfc_commit_symbol (idx2); 1683 1684 gfc_get_symbol ("offset", sub_ns, &offset); 1685 offset->ts.type = BT_INTEGER; 1686 offset->ts.kind = gfc_index_integer_kind; 1687 offset->attr.flavor = FL_VARIABLE; 1688 offset->attr.artificial = 1; 1689 gfc_set_sym_referenced (offset); 1690 gfc_commit_symbol (offset); 1691 1692 /* Create RANK expression. */ 1693 rank = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_RANK, "rank", 1694 gfc_current_locus, 1, 1695 gfc_lval_expr_from_sym (array)); 1696 if (rank->ts.kind != idx->ts.kind) 1697 gfc_convert_type_warn (rank, &idx->ts, 2, 0); 1698 1699 /* Create is_contiguous variable. */ 1700 gfc_get_symbol ("is_contiguous", sub_ns, &is_contiguous); 1701 is_contiguous->ts.type = BT_LOGICAL; 1702 is_contiguous->ts.kind = gfc_default_logical_kind; 1703 is_contiguous->attr.flavor = FL_VARIABLE; 1704 is_contiguous->attr.artificial = 1; 1705 gfc_set_sym_referenced (is_contiguous); 1706 gfc_commit_symbol (is_contiguous); 1707 1708 /* Create "sizes(0..rank)" variable, which contains the multiplied 1709 up extent of the dimensions, i.e. sizes(0) = 1, sizes(1) = extent(dim=1), 1710 sizes(2) = sizes(1) * extent(dim=2) etc. */ 1711 gfc_get_symbol ("sizes", sub_ns, &sizes); 1712 sizes->ts.type = BT_INTEGER; 1713 sizes->ts.kind = gfc_index_integer_kind; 1714 sizes->attr.flavor = FL_VARIABLE; 1715 sizes->attr.dimension = 1; 1716 sizes->attr.artificial = 1; 1717 sizes->as = gfc_get_array_spec(); 1718 sizes->attr.intent = INTENT_INOUT; 1719 sizes->as->type = AS_EXPLICIT; 1720 sizes->as->rank = 1; 1721 sizes->as->lower[0] = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0); 1722 sizes->as->upper[0] = gfc_copy_expr (rank); 1723 gfc_set_sym_referenced (sizes); 1724 gfc_commit_symbol (sizes); 1725 1726 /* Create "strides(1..rank)" variable, which contains the strides per 1727 dimension. */ 1728 gfc_get_symbol ("strides", sub_ns, &strides); 1729 strides->ts.type = BT_INTEGER; 1730 strides->ts.kind = gfc_index_integer_kind; 1731 strides->attr.flavor = FL_VARIABLE; 1732 strides->attr.dimension = 1; 1733 strides->attr.artificial = 1; 1734 strides->as = gfc_get_array_spec(); 1735 strides->attr.intent = INTENT_INOUT; 1736 strides->as->type = AS_EXPLICIT; 1737 strides->as->rank = 1; 1738 strides->as->lower[0] = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); 1739 strides->as->upper[0] = gfc_copy_expr (rank); 1740 gfc_set_sym_referenced (strides); 1741 gfc_commit_symbol (strides); 1742 1743 1744 /* Set return value to 0. */ 1745 last_code = gfc_get_code (EXEC_ASSIGN); 1746 last_code->expr1 = gfc_lval_expr_from_sym (final); 1747 last_code->expr2 = gfc_get_int_expr (4, NULL, 0); 1748 sub_ns->code = last_code; 1749 1750 /* Set: is_contiguous = .true. */ 1751 last_code->next = gfc_get_code (EXEC_ASSIGN); 1752 last_code = last_code->next; 1753 last_code->expr1 = gfc_lval_expr_from_sym (is_contiguous); 1754 last_code->expr2 = gfc_get_logical_expr (gfc_default_logical_kind, 1755 &gfc_current_locus, true); 1756 1757 /* Set: sizes(0) = 1. */ 1758 last_code->next = gfc_get_code (EXEC_ASSIGN); 1759 last_code = last_code->next; 1760 last_code->expr1 = gfc_lval_expr_from_sym (sizes); 1761 last_code->expr1->ref = gfc_get_ref (); 1762 last_code->expr1->ref->type = REF_ARRAY; 1763 last_code->expr1->ref->u.ar.type = AR_ELEMENT; 1764 last_code->expr1->ref->u.ar.dimen = 1; 1765 last_code->expr1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; 1766 last_code->expr1->ref->u.ar.start[0] 1767 = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0); 1768 last_code->expr1->ref->u.ar.as = sizes->as; 1769 last_code->expr2 = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); 1770 1771 /* Create: 1772 DO idx = 1, rank 1773 strides(idx) = _F._stride (array, dim=idx) 1774 sizes(idx) = sizes(i-1) * size(array, dim=idx, kind=index_kind) 1775 if (strides (idx) /= sizes(i-1)) is_contiguous = .false. 1776 END DO. */ 1777 1778 /* Create loop. */ 1779 iter = gfc_get_iterator (); 1780 iter->var = gfc_lval_expr_from_sym (idx); 1781 iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); 1782 iter->end = gfc_copy_expr (rank); 1783 iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); 1784 last_code->next = gfc_get_code (EXEC_DO); 1785 last_code = last_code->next; 1786 last_code->ext.iterator = iter; 1787 last_code->block = gfc_get_code (EXEC_DO); 1788 1789 /* strides(idx) = _F._stride(array,dim=idx). */ 1790 last_code->block->next = gfc_get_code (EXEC_ASSIGN); 1791 block = last_code->block->next; 1792 1793 block->expr1 = gfc_lval_expr_from_sym (strides); 1794 block->expr1->ref = gfc_get_ref (); 1795 block->expr1->ref->type = REF_ARRAY; 1796 block->expr1->ref->u.ar.type = AR_ELEMENT; 1797 block->expr1->ref->u.ar.dimen = 1; 1798 block->expr1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; 1799 block->expr1->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx); 1800 block->expr1->ref->u.ar.as = strides->as; 1801 1802 block->expr2 = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_STRIDE, "stride", 1803 gfc_current_locus, 2, 1804 gfc_lval_expr_from_sym (array), 1805 gfc_lval_expr_from_sym (idx)); 1806 1807 /* sizes(idx) = sizes(idx-1) * size(array,dim=idx, kind=index_kind). */ 1808 block->next = gfc_get_code (EXEC_ASSIGN); 1809 block = block->next; 1810 1811 /* sizes(idx) = ... */ 1812 block->expr1 = gfc_lval_expr_from_sym (sizes); 1813 block->expr1->ref = gfc_get_ref (); 1814 block->expr1->ref->type = REF_ARRAY; 1815 block->expr1->ref->u.ar.type = AR_ELEMENT; 1816 block->expr1->ref->u.ar.dimen = 1; 1817 block->expr1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; 1818 block->expr1->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx); 1819 block->expr1->ref->u.ar.as = sizes->as; 1820 1821 block->expr2 = gfc_get_expr (); 1822 block->expr2->expr_type = EXPR_OP; 1823 block->expr2->value.op.op = INTRINSIC_TIMES; 1824 1825 /* sizes(idx-1). */ 1826 block->expr2->value.op.op1 = gfc_lval_expr_from_sym (sizes); 1827 block->expr2->value.op.op1->ref = gfc_get_ref (); 1828 block->expr2->value.op.op1->ref->type = REF_ARRAY; 1829 block->expr2->value.op.op1->ref->u.ar.as = sizes->as; 1830 block->expr2->value.op.op1->ref->u.ar.type = AR_ELEMENT; 1831 block->expr2->value.op.op1->ref->u.ar.dimen = 1; 1832 block->expr2->value.op.op1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; 1833 block->expr2->value.op.op1->ref->u.ar.start[0] = gfc_get_expr (); 1834 block->expr2->value.op.op1->ref->u.ar.start[0]->expr_type = EXPR_OP; 1835 block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS; 1836 block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op1 1837 = gfc_lval_expr_from_sym (idx); 1838 block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op2 1839 = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); 1840 block->expr2->value.op.op1->ref->u.ar.start[0]->ts 1841 = block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op1->ts; 1842 1843 /* size(array, dim=idx, kind=index_kind). */ 1844 block->expr2->value.op.op2 1845 = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_SIZE, "size", 1846 gfc_current_locus, 3, 1847 gfc_lval_expr_from_sym (array), 1848 gfc_lval_expr_from_sym (idx), 1849 gfc_get_int_expr (gfc_index_integer_kind, 1850 NULL, 1851 gfc_index_integer_kind)); 1852 block->expr2->value.op.op2->ts.kind = gfc_index_integer_kind; 1853 block->expr2->ts = idx->ts; 1854 1855 /* if (strides (idx) /= sizes(idx-1)) is_contiguous = .false. */ 1856 block->next = gfc_get_code (EXEC_IF); 1857 block = block->next; 1858 1859 block->block = gfc_get_code (EXEC_IF); 1860 block = block->block; 1861 1862 /* if condition: strides(idx) /= sizes(idx-1). */ 1863 block->expr1 = gfc_get_expr (); 1864 block->expr1->ts.type = BT_LOGICAL; 1865 block->expr1->ts.kind = gfc_default_logical_kind; 1866 block->expr1->expr_type = EXPR_OP; 1867 block->expr1->where = gfc_current_locus; 1868 block->expr1->value.op.op = INTRINSIC_NE; 1869 1870 block->expr1->value.op.op1 = gfc_lval_expr_from_sym (strides); 1871 block->expr1->value.op.op1->ref = gfc_get_ref (); 1872 block->expr1->value.op.op1->ref->type = REF_ARRAY; 1873 block->expr1->value.op.op1->ref->u.ar.type = AR_ELEMENT; 1874 block->expr1->value.op.op1->ref->u.ar.dimen = 1; 1875 block->expr1->value.op.op1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; 1876 block->expr1->value.op.op1->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx); 1877 block->expr1->value.op.op1->ref->u.ar.as = strides->as; 1878 1879 block->expr1->value.op.op2 = gfc_lval_expr_from_sym (sizes); 1880 block->expr1->value.op.op2->ref = gfc_get_ref (); 1881 block->expr1->value.op.op2->ref->type = REF_ARRAY; 1882 block->expr1->value.op.op2->ref->u.ar.as = sizes->as; 1883 block->expr1->value.op.op2->ref->u.ar.type = AR_ELEMENT; 1884 block->expr1->value.op.op2->ref->u.ar.dimen = 1; 1885 block->expr1->value.op.op2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; 1886 block->expr1->value.op.op2->ref->u.ar.start[0] = gfc_get_expr (); 1887 block->expr1->value.op.op2->ref->u.ar.start[0]->expr_type = EXPR_OP; 1888 block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS; 1889 block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op1 1890 = gfc_lval_expr_from_sym (idx); 1891 block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op2 1892 = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); 1893 block->expr1->value.op.op2->ref->u.ar.start[0]->ts 1894 = block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op1->ts; 1895 1896 /* if body: is_contiguous = .false. */ 1897 block->next = gfc_get_code (EXEC_ASSIGN); 1898 block = block->next; 1899 block->expr1 = gfc_lval_expr_from_sym (is_contiguous); 1900 block->expr2 = gfc_get_logical_expr (gfc_default_logical_kind, 1901 &gfc_current_locus, false); 1902 1903 /* Obtain the size (number of elements) of "array" MINUS ONE, 1904 which is used in the scalarization. */ 1905 gfc_get_symbol ("nelem", sub_ns, &nelem); 1906 nelem->ts.type = BT_INTEGER; 1907 nelem->ts.kind = gfc_index_integer_kind; 1908 nelem->attr.flavor = FL_VARIABLE; 1909 nelem->attr.artificial = 1; 1910 gfc_set_sym_referenced (nelem); 1911 gfc_commit_symbol (nelem); 1912 1913 /* nelem = sizes (rank) - 1. */ 1914 last_code->next = gfc_get_code (EXEC_ASSIGN); 1915 last_code = last_code->next; 1916 1917 last_code->expr1 = gfc_lval_expr_from_sym (nelem); 1918 1919 last_code->expr2 = gfc_get_expr (); 1920 last_code->expr2->expr_type = EXPR_OP; 1921 last_code->expr2->value.op.op = INTRINSIC_MINUS; 1922 last_code->expr2->value.op.op2 1923 = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); 1924 last_code->expr2->ts = last_code->expr2->value.op.op2->ts; 1925 1926 last_code->expr2->value.op.op1 = gfc_lval_expr_from_sym (sizes); 1927 last_code->expr2->value.op.op1->ref = gfc_get_ref (); 1928 last_code->expr2->value.op.op1->ref->type = REF_ARRAY; 1929 last_code->expr2->value.op.op1->ref->u.ar.type = AR_ELEMENT; 1930 last_code->expr2->value.op.op1->ref->u.ar.dimen = 1; 1931 last_code->expr2->value.op.op1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; 1932 last_code->expr2->value.op.op1->ref->u.ar.start[0] = gfc_copy_expr (rank); 1933 last_code->expr2->value.op.op1->ref->u.ar.as = sizes->as; 1934 1935 /* Call final subroutines. We now generate code like: 1936 use iso_c_binding 1937 integer, pointer :: ptr 1938 type(c_ptr) :: cptr 1939 integer(c_intptr_t) :: i, addr 1940 1941 select case (rank (array)) 1942 case (3) 1943 ! If needed, the array is packed 1944 call final_rank3 (array) 1945 case default: 1946 do i = 0, size (array)-1 1947 addr = transfer (c_loc (array), addr) + i * stride 1948 call c_f_pointer (transfer (addr, cptr), ptr) 1949 call elemental_final (ptr) 1950 end do 1951 end select */ 1952 1953 if (derived->f2k_derived && derived->f2k_derived->finalizers) 1954 { 1955 gfc_finalizer *fini, *fini_elem = NULL; 1956 1957 gfc_get_symbol ("ptr1", sub_ns, &ptr); 1958 ptr->ts.type = BT_DERIVED; 1959 ptr->ts.u.derived = derived; 1960 ptr->attr.flavor = FL_VARIABLE; 1961 ptr->attr.pointer = 1; 1962 ptr->attr.artificial = 1; 1963 gfc_set_sym_referenced (ptr); 1964 gfc_commit_symbol (ptr); 1965 1966 /* SELECT CASE (RANK (array)). */ 1967 last_code->next = gfc_get_code (EXEC_SELECT); 1968 last_code = last_code->next; 1969 last_code->expr1 = gfc_copy_expr (rank); 1970 block = NULL; 1971 1972 for (fini = derived->f2k_derived->finalizers; fini; fini = fini->next) 1973 { 1974 gcc_assert (fini->proc_tree); /* Should have been set in gfc_resolve_finalizers. */ 1975 if (fini->proc_tree->n.sym->attr.elemental) 1976 { 1977 fini_elem = fini; 1978 continue; 1979 } 1980 1981 /* CASE (fini_rank). */ 1982 if (block) 1983 { 1984 block->block = gfc_get_code (EXEC_SELECT); 1985 block = block->block; 1986 } 1987 else 1988 { 1989 block = gfc_get_code (EXEC_SELECT); 1990 last_code->block = block; 1991 } 1992 block->ext.block.case_list = gfc_get_case (); 1993 block->ext.block.case_list->where = gfc_current_locus; 1994 if (fini->proc_tree->n.sym->formal->sym->attr.dimension) 1995 block->ext.block.case_list->low 1996 = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1997 fini->proc_tree->n.sym->formal->sym->as->rank); 1998 else 1999 block->ext.block.case_list->low 2000 = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); 2001 block->ext.block.case_list->high 2002 = gfc_copy_expr (block->ext.block.case_list->low); 2003 2004 /* CALL fini_rank (array) - possibly with packing. */ 2005 if (fini->proc_tree->n.sym->formal->sym->attr.dimension) 2006 finalizer_insert_packed_call (block, fini, array, byte_stride, 2007 idx, ptr, nelem, strides, 2008 sizes, idx2, offset, is_contiguous, 2009 rank, sub_ns); 2010 else 2011 { 2012 block->next = gfc_get_code (EXEC_CALL); 2013 block->next->symtree = fini->proc_tree; 2014 block->next->resolved_sym = fini->proc_tree->n.sym; 2015 block->next->ext.actual = gfc_get_actual_arglist (); 2016 block->next->ext.actual->expr = gfc_lval_expr_from_sym (array); 2017 } 2018 } 2019 2020 /* Elemental call - scalarized. */ 2021 if (fini_elem) 2022 { 2023 /* CASE DEFAULT. */ 2024 if (block) 2025 { 2026 block->block = gfc_get_code (EXEC_SELECT); 2027 block = block->block; 2028 } 2029 else 2030 { 2031 block = gfc_get_code (EXEC_SELECT); 2032 last_code->block = block; 2033 } 2034 block->ext.block.case_list = gfc_get_case (); 2035 2036 /* Create loop. */ 2037 iter = gfc_get_iterator (); 2038 iter->var = gfc_lval_expr_from_sym (idx); 2039 iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0); 2040 iter->end = gfc_lval_expr_from_sym (nelem); 2041 iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); 2042 block->next = gfc_get_code (EXEC_DO); 2043 block = block->next; 2044 block->ext.iterator = iter; 2045 block->block = gfc_get_code (EXEC_DO); 2046 2047 /* Offset calculation. */ 2048 block = finalization_get_offset (idx, idx2, offset, strides, sizes, 2049 byte_stride, rank, block->block, 2050 sub_ns); 2051 2052 /* Create code for 2053 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr) 2054 + offset, c_ptr), ptr). */ 2055 block->next 2056 = finalization_scalarizer (array, ptr, 2057 gfc_lval_expr_from_sym (offset), 2058 sub_ns); 2059 block = block->next; 2060 2061 /* CALL final_elemental (array). */ 2062 block->next = gfc_get_code (EXEC_CALL); 2063 block = block->next; 2064 block->symtree = fini_elem->proc_tree; 2065 block->resolved_sym = fini_elem->proc_sym; 2066 block->ext.actual = gfc_get_actual_arglist (); 2067 block->ext.actual->expr = gfc_lval_expr_from_sym (ptr); 2068 } 2069 } 2070 2071 /* Finalize and deallocate allocatable components. The same manual 2072 scalarization is used as above. */ 2073 2074 if (finalizable_comp) 2075 { 2076 gfc_symbol *stat; 2077 gfc_code *block = NULL; 2078 2079 if (!ptr) 2080 { 2081 gfc_get_symbol ("ptr2", sub_ns, &ptr); 2082 ptr->ts.type = BT_DERIVED; 2083 ptr->ts.u.derived = derived; 2084 ptr->attr.flavor = FL_VARIABLE; 2085 ptr->attr.pointer = 1; 2086 ptr->attr.artificial = 1; 2087 gfc_set_sym_referenced (ptr); 2088 gfc_commit_symbol (ptr); 2089 } 2090 2091 gfc_get_symbol ("ignore", sub_ns, &stat); 2092 stat->attr.flavor = FL_VARIABLE; 2093 stat->attr.artificial = 1; 2094 stat->ts.type = BT_INTEGER; 2095 stat->ts.kind = gfc_default_integer_kind; 2096 gfc_set_sym_referenced (stat); 2097 gfc_commit_symbol (stat); 2098 2099 /* Create loop. */ 2100 iter = gfc_get_iterator (); 2101 iter->var = gfc_lval_expr_from_sym (idx); 2102 iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0); 2103 iter->end = gfc_lval_expr_from_sym (nelem); 2104 iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); 2105 last_code->next = gfc_get_code (EXEC_DO); 2106 last_code = last_code->next; 2107 last_code->ext.iterator = iter; 2108 last_code->block = gfc_get_code (EXEC_DO); 2109 2110 /* Offset calculation. */ 2111 block = finalization_get_offset (idx, idx2, offset, strides, sizes, 2112 byte_stride, rank, last_code->block, 2113 sub_ns); 2114 2115 /* Create code for 2116 CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr) 2117 + idx * stride, c_ptr), ptr). */ 2118 block->next = finalization_scalarizer (array, ptr, 2119 gfc_lval_expr_from_sym(offset), 2120 sub_ns); 2121 block = block->next; 2122 2123 for (comp = derived->components; comp; comp = comp->next) 2124 { 2125 if (comp == derived->components && derived->attr.extension 2126 && ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL) 2127 continue; 2128 2129 finalize_component (gfc_lval_expr_from_sym (ptr), derived, comp, 2130 stat, fini_coarray, &block, sub_ns); 2131 if (!last_code->block->next) 2132 last_code->block->next = block; 2133 } 2134 2135 } 2136 2137 /* Call the finalizer of the ancestor. */ 2138 if (ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL) 2139 { 2140 last_code->next = gfc_get_code (EXEC_CALL); 2141 last_code = last_code->next; 2142 last_code->symtree = ancestor_wrapper->symtree; 2143 last_code->resolved_sym = ancestor_wrapper->symtree->n.sym; 2144 2145 last_code->ext.actual = gfc_get_actual_arglist (); 2146 last_code->ext.actual->expr = gfc_lval_expr_from_sym (array); 2147 last_code->ext.actual->next = gfc_get_actual_arglist (); 2148 last_code->ext.actual->next->expr = gfc_lval_expr_from_sym (byte_stride); 2149 last_code->ext.actual->next->next = gfc_get_actual_arglist (); 2150 last_code->ext.actual->next->next->expr 2151 = gfc_lval_expr_from_sym (fini_coarray); 2152 } 2153 2154 gfc_free_expr (rank); 2155 vtab_final->initializer = gfc_lval_expr_from_sym (final); 2156 vtab_final->ts.interface = final; 2157} 2158 2159 2160/* Add procedure pointers for all type-bound procedures to a vtab. */ 2161 2162static void 2163add_procs_to_declared_vtab (gfc_symbol *derived, gfc_symbol *vtype) 2164{ 2165 gfc_symbol* super_type; 2166 2167 super_type = gfc_get_derived_super_type (derived); 2168 2169 if (super_type && (super_type != derived)) 2170 { 2171 /* Make sure that the PPCs appear in the same order as in the parent. */ 2172 copy_vtab_proc_comps (super_type, vtype); 2173 /* Only needed to get the PPC initializers right. */ 2174 add_procs_to_declared_vtab (super_type, vtype); 2175 } 2176 2177 if (derived->f2k_derived && derived->f2k_derived->tb_sym_root) 2178 add_procs_to_declared_vtab1 (derived->f2k_derived->tb_sym_root, vtype); 2179 2180 if (derived->f2k_derived && derived->f2k_derived->tb_uop_root) 2181 add_procs_to_declared_vtab1 (derived->f2k_derived->tb_uop_root, vtype); 2182} 2183 2184 2185/* Find or generate the symbol for a derived type's vtab. */ 2186 2187gfc_symbol * 2188gfc_find_derived_vtab (gfc_symbol *derived) 2189{ 2190 gfc_namespace *ns; 2191 gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL; 2192 gfc_symbol *copy = NULL, *src = NULL, *dst = NULL; 2193 2194 /* Find the top-level namespace. */ 2195 for (ns = gfc_current_ns; ns; ns = ns->parent) 2196 if (!ns->parent) 2197 break; 2198 2199 /* If the type is a class container, use the underlying derived type. */ 2200 if (!derived->attr.unlimited_polymorphic && derived->attr.is_class) 2201 derived = gfc_get_derived_super_type (derived); 2202 2203 if (ns) 2204 { 2205 char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1]; 2206 2207 get_unique_hashed_string (tname, derived); 2208 sprintf (name, "__vtab_%s", tname); 2209 2210 /* Look for the vtab symbol in various namespaces. */ 2211 gfc_find_symbol (name, gfc_current_ns, 0, &vtab); 2212 if (vtab == NULL) 2213 gfc_find_symbol (name, ns, 0, &vtab); 2214 if (vtab == NULL) 2215 gfc_find_symbol (name, derived->ns, 0, &vtab); 2216 2217 if (vtab == NULL) 2218 { 2219 gfc_get_symbol (name, ns, &vtab); 2220 vtab->ts.type = BT_DERIVED; 2221 if (!gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL, 2222 &gfc_current_locus)) 2223 goto cleanup; 2224 vtab->attr.target = 1; 2225 vtab->attr.save = SAVE_IMPLICIT; 2226 vtab->attr.vtab = 1; 2227 vtab->attr.access = ACCESS_PUBLIC; 2228 gfc_set_sym_referenced (vtab); 2229 sprintf (name, "__vtype_%s", tname); 2230 2231 gfc_find_symbol (name, ns, 0, &vtype); 2232 if (vtype == NULL) 2233 { 2234 gfc_component *c; 2235 gfc_symbol *parent = NULL, *parent_vtab = NULL; 2236 2237 gfc_get_symbol (name, ns, &vtype); 2238 if (!gfc_add_flavor (&vtype->attr, FL_DERIVED, NULL, 2239 &gfc_current_locus)) 2240 goto cleanup; 2241 vtype->attr.access = ACCESS_PUBLIC; 2242 vtype->attr.vtype = 1; 2243 gfc_set_sym_referenced (vtype); 2244 2245 /* Add component '_hash'. */ 2246 if (!gfc_add_component (vtype, "_hash", &c)) 2247 goto cleanup; 2248 c->ts.type = BT_INTEGER; 2249 c->ts.kind = 4; 2250 c->attr.access = ACCESS_PRIVATE; 2251 c->initializer = gfc_get_int_expr (gfc_default_integer_kind, 2252 NULL, derived->hash_value); 2253 2254 /* Add component '_size'. */ 2255 if (!gfc_add_component (vtype, "_size", &c)) 2256 goto cleanup; 2257 c->ts.type = BT_INTEGER; 2258 c->ts.kind = 4; 2259 c->attr.access = ACCESS_PRIVATE; 2260 /* Remember the derived type in ts.u.derived, 2261 so that the correct initializer can be set later on 2262 (in gfc_conv_structure). */ 2263 c->ts.u.derived = derived; 2264 c->initializer = gfc_get_int_expr (gfc_default_integer_kind, 2265 NULL, 0); 2266 2267 /* Add component _extends. */ 2268 if (!gfc_add_component (vtype, "_extends", &c)) 2269 goto cleanup; 2270 c->attr.pointer = 1; 2271 c->attr.access = ACCESS_PRIVATE; 2272 if (!derived->attr.unlimited_polymorphic) 2273 parent = gfc_get_derived_super_type (derived); 2274 else 2275 parent = NULL; 2276 2277 if (parent) 2278 { 2279 parent_vtab = gfc_find_derived_vtab (parent); 2280 c->ts.type = BT_DERIVED; 2281 c->ts.u.derived = parent_vtab->ts.u.derived; 2282 c->initializer = gfc_get_expr (); 2283 c->initializer->expr_type = EXPR_VARIABLE; 2284 gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns, 2285 0, &c->initializer->symtree); 2286 } 2287 else 2288 { 2289 c->ts.type = BT_DERIVED; 2290 c->ts.u.derived = vtype; 2291 c->initializer = gfc_get_null_expr (NULL); 2292 } 2293 2294 if (!derived->attr.unlimited_polymorphic 2295 && derived->components == NULL 2296 && !derived->attr.zero_comp) 2297 { 2298 /* At this point an error must have occurred. 2299 Prevent further errors on the vtype components. */ 2300 found_sym = vtab; 2301 goto have_vtype; 2302 } 2303 2304 /* Add component _def_init. */ 2305 if (!gfc_add_component (vtype, "_def_init", &c)) 2306 goto cleanup; 2307 c->attr.pointer = 1; 2308 c->attr.artificial = 1; 2309 c->attr.access = ACCESS_PRIVATE; 2310 c->ts.type = BT_DERIVED; 2311 c->ts.u.derived = derived; 2312 if (derived->attr.unlimited_polymorphic 2313 || derived->attr.abstract) 2314 c->initializer = gfc_get_null_expr (NULL); 2315 else 2316 { 2317 /* Construct default initialization variable. */ 2318 sprintf (name, "__def_init_%s", tname); 2319 gfc_get_symbol (name, ns, &def_init); 2320 def_init->attr.target = 1; 2321 def_init->attr.artificial = 1; 2322 def_init->attr.save = SAVE_IMPLICIT; 2323 def_init->attr.access = ACCESS_PUBLIC; 2324 def_init->attr.flavor = FL_VARIABLE; 2325 gfc_set_sym_referenced (def_init); 2326 def_init->ts.type = BT_DERIVED; 2327 def_init->ts.u.derived = derived; 2328 def_init->value = gfc_default_initializer (&def_init->ts); 2329 2330 c->initializer = gfc_lval_expr_from_sym (def_init); 2331 } 2332 2333 /* Add component _copy. */ 2334 if (!gfc_add_component (vtype, "_copy", &c)) 2335 goto cleanup; 2336 c->attr.proc_pointer = 1; 2337 c->attr.access = ACCESS_PRIVATE; 2338 c->tb = XCNEW (gfc_typebound_proc); 2339 c->tb->ppc = 1; 2340 if (derived->attr.unlimited_polymorphic 2341 || derived->attr.abstract) 2342 c->initializer = gfc_get_null_expr (NULL); 2343 else 2344 { 2345 /* Set up namespace. */ 2346 gfc_namespace *sub_ns = gfc_get_namespace (ns, 0); 2347 sub_ns->sibling = ns->contained; 2348 ns->contained = sub_ns; 2349 sub_ns->resolved = 1; 2350 /* Set up procedure symbol. */ 2351 sprintf (name, "__copy_%s", tname); 2352 gfc_get_symbol (name, sub_ns, ©); 2353 sub_ns->proc_name = copy; 2354 copy->attr.flavor = FL_PROCEDURE; 2355 copy->attr.subroutine = 1; 2356 copy->attr.pure = 1; 2357 copy->attr.artificial = 1; 2358 copy->attr.if_source = IFSRC_DECL; 2359 /* This is elemental so that arrays are automatically 2360 treated correctly by the scalarizer. */ 2361 copy->attr.elemental = 1; 2362 if (ns->proc_name->attr.flavor == FL_MODULE) 2363 copy->module = ns->proc_name->name; 2364 gfc_set_sym_referenced (copy); 2365 /* Set up formal arguments. */ 2366 gfc_get_symbol ("src", sub_ns, &src); 2367 src->ts.type = BT_DERIVED; 2368 src->ts.u.derived = derived; 2369 src->attr.flavor = FL_VARIABLE; 2370 src->attr.dummy = 1; 2371 src->attr.artificial = 1; 2372 src->attr.intent = INTENT_IN; 2373 gfc_set_sym_referenced (src); 2374 copy->formal = gfc_get_formal_arglist (); 2375 copy->formal->sym = src; 2376 gfc_get_symbol ("dst", sub_ns, &dst); 2377 dst->ts.type = BT_DERIVED; 2378 dst->ts.u.derived = derived; 2379 dst->attr.flavor = FL_VARIABLE; 2380 dst->attr.dummy = 1; 2381 dst->attr.artificial = 1; 2382 dst->attr.intent = INTENT_INOUT; 2383 gfc_set_sym_referenced (dst); 2384 copy->formal->next = gfc_get_formal_arglist (); 2385 copy->formal->next->sym = dst; 2386 /* Set up code. */ 2387 sub_ns->code = gfc_get_code (EXEC_INIT_ASSIGN); 2388 sub_ns->code->expr1 = gfc_lval_expr_from_sym (dst); 2389 sub_ns->code->expr2 = gfc_lval_expr_from_sym (src); 2390 /* Set initializer. */ 2391 c->initializer = gfc_lval_expr_from_sym (copy); 2392 c->ts.interface = copy; 2393 } 2394 2395 /* Add component _final, which contains a procedure pointer to 2396 a wrapper which handles both the freeing of allocatable 2397 components and the calls to finalization subroutines. 2398 Note: The actual wrapper function can only be generated 2399 at resolution time. */ 2400 if (!gfc_add_component (vtype, "_final", &c)) 2401 goto cleanup; 2402 c->attr.proc_pointer = 1; 2403 c->attr.access = ACCESS_PRIVATE; 2404 c->tb = XCNEW (gfc_typebound_proc); 2405 c->tb->ppc = 1; 2406 generate_finalization_wrapper (derived, ns, tname, c); 2407 2408 /* Add procedure pointers for type-bound procedures. */ 2409 if (!derived->attr.unlimited_polymorphic) 2410 add_procs_to_declared_vtab (derived, vtype); 2411 } 2412 2413have_vtype: 2414 vtab->ts.u.derived = vtype; 2415 vtab->value = gfc_default_initializer (&vtab->ts); 2416 } 2417 } 2418 2419 found_sym = vtab; 2420 2421cleanup: 2422 /* It is unexpected to have some symbols added at resolution or code 2423 generation time. We commit the changes in order to keep a clean state. */ 2424 if (found_sym) 2425 { 2426 gfc_commit_symbol (vtab); 2427 if (vtype) 2428 gfc_commit_symbol (vtype); 2429 if (def_init) 2430 gfc_commit_symbol (def_init); 2431 if (copy) 2432 gfc_commit_symbol (copy); 2433 if (src) 2434 gfc_commit_symbol (src); 2435 if (dst) 2436 gfc_commit_symbol (dst); 2437 } 2438 else 2439 gfc_undo_symbols (); 2440 2441 return found_sym; 2442} 2443 2444 2445/* Check if a derived type is finalizable. That is the case if it 2446 (1) has a FINAL subroutine or 2447 (2) has a nonpointer nonallocatable component of finalizable type. 2448 If it is finalizable, return an expression containing the 2449 finalization wrapper. */ 2450 2451bool 2452gfc_is_finalizable (gfc_symbol *derived, gfc_expr **final_expr) 2453{ 2454 gfc_symbol *vtab; 2455 gfc_component *c; 2456 2457 /* (1) Check for FINAL subroutines. */ 2458 if (derived->f2k_derived && derived->f2k_derived->finalizers) 2459 goto yes; 2460 2461 /* (2) Check for components of finalizable type. */ 2462 for (c = derived->components; c; c = c->next) 2463 if (c->ts.type == BT_DERIVED 2464 && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable 2465 && gfc_is_finalizable (c->ts.u.derived, NULL)) 2466 goto yes; 2467 2468 return false; 2469 2470yes: 2471 /* Make sure vtab is generated. */ 2472 vtab = gfc_find_derived_vtab (derived); 2473 if (final_expr) 2474 { 2475 /* Return finalizer expression. */ 2476 gfc_component *final; 2477 final = vtab->ts.u.derived->components->next->next->next->next->next; 2478 gcc_assert (strcmp (final->name, "_final") == 0); 2479 gcc_assert (final->initializer 2480 && final->initializer->expr_type != EXPR_NULL); 2481 *final_expr = final->initializer; 2482 } 2483 return true; 2484} 2485 2486 2487/* Find (or generate) the symbol for an intrinsic type's vtab. This is 2488 needed to support unlimited polymorphism. */ 2489 2490static gfc_symbol * 2491find_intrinsic_vtab (gfc_typespec *ts) 2492{ 2493 gfc_namespace *ns; 2494 gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL; 2495 gfc_symbol *copy = NULL, *src = NULL, *dst = NULL; 2496 int charlen = 0; 2497 2498 if (ts->type == BT_CHARACTER && !ts->deferred && ts->u.cl && ts->u.cl->length 2499 && ts->u.cl->length->expr_type == EXPR_CONSTANT) 2500 charlen = mpz_get_si (ts->u.cl->length->value.integer); 2501 2502 /* Find the top-level namespace. */ 2503 for (ns = gfc_current_ns; ns; ns = ns->parent) 2504 if (!ns->parent) 2505 break; 2506 2507 if (ns) 2508 { 2509 char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1]; 2510 2511 if (ts->type == BT_CHARACTER) 2512 sprintf (tname, "%s_%d_%d", gfc_basic_typename (ts->type), 2513 charlen, ts->kind); 2514 else 2515 sprintf (tname, "%s_%d_", gfc_basic_typename (ts->type), ts->kind); 2516 2517 sprintf (name, "__vtab_%s", tname); 2518 2519 /* Look for the vtab symbol in various namespaces. */ 2520 gfc_find_symbol (name, gfc_current_ns, 0, &vtab); 2521 if (vtab == NULL) 2522 gfc_find_symbol (name, ns, 0, &vtab); 2523 2524 if (vtab == NULL) 2525 { 2526 gfc_get_symbol (name, ns, &vtab); 2527 vtab->ts.type = BT_DERIVED; 2528 if (!gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL, 2529 &gfc_current_locus)) 2530 goto cleanup; 2531 vtab->attr.target = 1; 2532 vtab->attr.save = SAVE_IMPLICIT; 2533 vtab->attr.vtab = 1; 2534 vtab->attr.access = ACCESS_PUBLIC; 2535 gfc_set_sym_referenced (vtab); 2536 sprintf (name, "__vtype_%s", tname); 2537 2538 gfc_find_symbol (name, ns, 0, &vtype); 2539 if (vtype == NULL) 2540 { 2541 gfc_component *c; 2542 int hash; 2543 gfc_namespace *sub_ns; 2544 gfc_namespace *contained; 2545 gfc_expr *e; 2546 2547 gfc_get_symbol (name, ns, &vtype); 2548 if (!gfc_add_flavor (&vtype->attr, FL_DERIVED, NULL, 2549 &gfc_current_locus)) 2550 goto cleanup; 2551 vtype->attr.access = ACCESS_PUBLIC; 2552 vtype->attr.vtype = 1; 2553 gfc_set_sym_referenced (vtype); 2554 2555 /* Add component '_hash'. */ 2556 if (!gfc_add_component (vtype, "_hash", &c)) 2557 goto cleanup; 2558 c->ts.type = BT_INTEGER; 2559 c->ts.kind = 4; 2560 c->attr.access = ACCESS_PRIVATE; 2561 hash = gfc_intrinsic_hash_value (ts); 2562 c->initializer = gfc_get_int_expr (gfc_default_integer_kind, 2563 NULL, hash); 2564 2565 /* Add component '_size'. */ 2566 if (!gfc_add_component (vtype, "_size", &c)) 2567 goto cleanup; 2568 c->ts.type = BT_INTEGER; 2569 c->ts.kind = 4; 2570 c->attr.access = ACCESS_PRIVATE; 2571 2572 /* Build a minimal expression to make use of 2573 target-memory.c/gfc_element_size for 'size'. Special handling 2574 for character arrays, that are not constant sized: to support 2575 len (str) * kind, only the kind information is stored in the 2576 vtab. */ 2577 e = gfc_get_expr (); 2578 e->ts = *ts; 2579 e->expr_type = EXPR_VARIABLE; 2580 c->initializer = gfc_get_int_expr (gfc_default_integer_kind, 2581 NULL, 2582 ts->type == BT_CHARACTER 2583 && charlen == 0 ? 2584 ts->kind : 2585 (int)gfc_element_size (e)); 2586 gfc_free_expr (e); 2587 2588 /* Add component _extends. */ 2589 if (!gfc_add_component (vtype, "_extends", &c)) 2590 goto cleanup; 2591 c->attr.pointer = 1; 2592 c->attr.access = ACCESS_PRIVATE; 2593 c->ts.type = BT_VOID; 2594 c->initializer = gfc_get_null_expr (NULL); 2595 2596 /* Add component _def_init. */ 2597 if (!gfc_add_component (vtype, "_def_init", &c)) 2598 goto cleanup; 2599 c->attr.pointer = 1; 2600 c->attr.access = ACCESS_PRIVATE; 2601 c->ts.type = BT_VOID; 2602 c->initializer = gfc_get_null_expr (NULL); 2603 2604 /* Add component _copy. */ 2605 if (!gfc_add_component (vtype, "_copy", &c)) 2606 goto cleanup; 2607 c->attr.proc_pointer = 1; 2608 c->attr.access = ACCESS_PRIVATE; 2609 c->tb = XCNEW (gfc_typebound_proc); 2610 c->tb->ppc = 1; 2611 2612 if (ts->type != BT_CHARACTER) 2613 sprintf (name, "__copy_%s", tname); 2614 else 2615 { 2616 /* __copy is always the same for characters. 2617 Check to see if copy function already exists. */ 2618 sprintf (name, "__copy_character_%d", ts->kind); 2619 contained = ns->contained; 2620 for (; contained; contained = contained->sibling) 2621 if (contained->proc_name 2622 && strcmp (name, contained->proc_name->name) == 0) 2623 { 2624 copy = contained->proc_name; 2625 goto got_char_copy; 2626 } 2627 } 2628 2629 /* Set up namespace. */ 2630 sub_ns = gfc_get_namespace (ns, 0); 2631 sub_ns->sibling = ns->contained; 2632 ns->contained = sub_ns; 2633 sub_ns->resolved = 1; 2634 /* Set up procedure symbol. */ 2635 gfc_get_symbol (name, sub_ns, ©); 2636 sub_ns->proc_name = copy; 2637 copy->attr.flavor = FL_PROCEDURE; 2638 copy->attr.subroutine = 1; 2639 copy->attr.pure = 1; 2640 copy->attr.if_source = IFSRC_DECL; 2641 /* This is elemental so that arrays are automatically 2642 treated correctly by the scalarizer. */ 2643 copy->attr.elemental = 1; 2644 if (ns->proc_name->attr.flavor == FL_MODULE) 2645 copy->module = ns->proc_name->name; 2646 gfc_set_sym_referenced (copy); 2647 /* Set up formal arguments. */ 2648 gfc_get_symbol ("src", sub_ns, &src); 2649 src->ts.type = ts->type; 2650 src->ts.kind = ts->kind; 2651 src->attr.flavor = FL_VARIABLE; 2652 src->attr.dummy = 1; 2653 src->attr.intent = INTENT_IN; 2654 gfc_set_sym_referenced (src); 2655 copy->formal = gfc_get_formal_arglist (); 2656 copy->formal->sym = src; 2657 gfc_get_symbol ("dst", sub_ns, &dst); 2658 dst->ts.type = ts->type; 2659 dst->ts.kind = ts->kind; 2660 dst->attr.flavor = FL_VARIABLE; 2661 dst->attr.dummy = 1; 2662 dst->attr.intent = INTENT_INOUT; 2663 gfc_set_sym_referenced (dst); 2664 copy->formal->next = gfc_get_formal_arglist (); 2665 copy->formal->next->sym = dst; 2666 /* Set up code. */ 2667 sub_ns->code = gfc_get_code (EXEC_INIT_ASSIGN); 2668 sub_ns->code->expr1 = gfc_lval_expr_from_sym (dst); 2669 sub_ns->code->expr2 = gfc_lval_expr_from_sym (src); 2670 got_char_copy: 2671 /* Set initializer. */ 2672 c->initializer = gfc_lval_expr_from_sym (copy); 2673 c->ts.interface = copy; 2674 2675 /* Add component _final. */ 2676 if (!gfc_add_component (vtype, "_final", &c)) 2677 goto cleanup; 2678 c->attr.proc_pointer = 1; 2679 c->attr.access = ACCESS_PRIVATE; 2680 c->tb = XCNEW (gfc_typebound_proc); 2681 c->tb->ppc = 1; 2682 c->initializer = gfc_get_null_expr (NULL); 2683 } 2684 vtab->ts.u.derived = vtype; 2685 vtab->value = gfc_default_initializer (&vtab->ts); 2686 } 2687 } 2688 2689 found_sym = vtab; 2690 2691cleanup: 2692 /* It is unexpected to have some symbols added at resolution or code 2693 generation time. We commit the changes in order to keep a clean state. */ 2694 if (found_sym) 2695 { 2696 gfc_commit_symbol (vtab); 2697 if (vtype) 2698 gfc_commit_symbol (vtype); 2699 if (copy) 2700 gfc_commit_symbol (copy); 2701 if (src) 2702 gfc_commit_symbol (src); 2703 if (dst) 2704 gfc_commit_symbol (dst); 2705 } 2706 else 2707 gfc_undo_symbols (); 2708 2709 return found_sym; 2710} 2711 2712 2713/* Find (or generate) a vtab for an arbitrary type (derived or intrinsic). */ 2714 2715gfc_symbol * 2716gfc_find_vtab (gfc_typespec *ts) 2717{ 2718 switch (ts->type) 2719 { 2720 case BT_UNKNOWN: 2721 return NULL; 2722 case BT_DERIVED: 2723 return gfc_find_derived_vtab (ts->u.derived); 2724 case BT_CLASS: 2725 return gfc_find_derived_vtab (ts->u.derived->components->ts.u.derived); 2726 default: 2727 return find_intrinsic_vtab (ts); 2728 } 2729} 2730 2731 2732/* General worker function to find either a type-bound procedure or a 2733 type-bound user operator. */ 2734 2735static gfc_symtree* 2736find_typebound_proc_uop (gfc_symbol* derived, bool* t, 2737 const char* name, bool noaccess, bool uop, 2738 locus* where) 2739{ 2740 gfc_symtree* res; 2741 gfc_symtree* root; 2742 2743 /* Set default to failure. */ 2744 if (t) 2745 *t = false; 2746 2747 if (derived->f2k_derived) 2748 /* Set correct symbol-root. */ 2749 root = (uop ? derived->f2k_derived->tb_uop_root 2750 : derived->f2k_derived->tb_sym_root); 2751 else 2752 return NULL; 2753 2754 /* Try to find it in the current type's namespace. */ 2755 res = gfc_find_symtree (root, name); 2756 if (res && res->n.tb && !res->n.tb->error) 2757 { 2758 /* We found one. */ 2759 if (t) 2760 *t = true; 2761 2762 if (!noaccess && derived->attr.use_assoc 2763 && res->n.tb->access == ACCESS_PRIVATE) 2764 { 2765 if (where) 2766 gfc_error ("%qs of %qs is PRIVATE at %L", 2767 name, derived->name, where); 2768 if (t) 2769 *t = false; 2770 } 2771 2772 return res; 2773 } 2774 2775 /* Otherwise, recurse on parent type if derived is an extension. */ 2776 if (derived->attr.extension) 2777 { 2778 gfc_symbol* super_type; 2779 super_type = gfc_get_derived_super_type (derived); 2780 gcc_assert (super_type); 2781 2782 return find_typebound_proc_uop (super_type, t, name, 2783 noaccess, uop, where); 2784 } 2785 2786 /* Nothing found. */ 2787 return NULL; 2788} 2789 2790 2791/* Find a type-bound procedure or user operator by name for a derived-type 2792 (looking recursively through the super-types). */ 2793 2794gfc_symtree* 2795gfc_find_typebound_proc (gfc_symbol* derived, bool* t, 2796 const char* name, bool noaccess, locus* where) 2797{ 2798 return find_typebound_proc_uop (derived, t, name, noaccess, false, where); 2799} 2800 2801gfc_symtree* 2802gfc_find_typebound_user_op (gfc_symbol* derived, bool* t, 2803 const char* name, bool noaccess, locus* where) 2804{ 2805 return find_typebound_proc_uop (derived, t, name, noaccess, true, where); 2806} 2807 2808 2809/* Find a type-bound intrinsic operator looking recursively through the 2810 super-type hierarchy. */ 2811 2812gfc_typebound_proc* 2813gfc_find_typebound_intrinsic_op (gfc_symbol* derived, bool* t, 2814 gfc_intrinsic_op op, bool noaccess, 2815 locus* where) 2816{ 2817 gfc_typebound_proc* res; 2818 2819 /* Set default to failure. */ 2820 if (t) 2821 *t = false; 2822 2823 /* Try to find it in the current type's namespace. */ 2824 if (derived->f2k_derived) 2825 res = derived->f2k_derived->tb_op[op]; 2826 else 2827 res = NULL; 2828 2829 /* Check access. */ 2830 if (res && !res->error) 2831 { 2832 /* We found one. */ 2833 if (t) 2834 *t = true; 2835 2836 if (!noaccess && derived->attr.use_assoc 2837 && res->access == ACCESS_PRIVATE) 2838 { 2839 if (where) 2840 gfc_error ("%qs of %qs is PRIVATE at %L", 2841 gfc_op2string (op), derived->name, where); 2842 if (t) 2843 *t = false; 2844 } 2845 2846 return res; 2847 } 2848 2849 /* Otherwise, recurse on parent type if derived is an extension. */ 2850 if (derived->attr.extension) 2851 { 2852 gfc_symbol* super_type; 2853 super_type = gfc_get_derived_super_type (derived); 2854 gcc_assert (super_type); 2855 2856 return gfc_find_typebound_intrinsic_op (super_type, t, op, 2857 noaccess, where); 2858 } 2859 2860 /* Nothing found. */ 2861 return NULL; 2862} 2863 2864 2865/* Get a typebound-procedure symtree or create and insert it if not yet 2866 present. This is like a very simplified version of gfc_get_sym_tree for 2867 tbp-symtrees rather than regular ones. */ 2868 2869gfc_symtree* 2870gfc_get_tbp_symtree (gfc_symtree **root, const char *name) 2871{ 2872 gfc_symtree *result; 2873 2874 result = gfc_find_symtree (*root, name); 2875 if (!result) 2876 { 2877 result = gfc_new_symtree (root, name); 2878 gcc_assert (result); 2879 result->n.tb = NULL; 2880 } 2881 2882 return result; 2883} 2884