1/* Backend support for Fortran 95 basic types and derived types. 2 Copyright (C) 2002-2016 Free Software Foundation, Inc. 3 Contributed by Paul Brook <paul@nowt.org> 4 and Steven Bosscher <s.bosscher@student.tudelft.nl> 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/* trans-types.c -- gfortran backend types */ 23 24#include "config.h" 25#include "system.h" 26#include "coretypes.h" 27#include "tm.h" /* For INTMAX_TYPE, INT8_TYPE, INT16_TYPE, INT32_TYPE, 28 INT64_TYPE, INT_LEAST8_TYPE, INT_LEAST16_TYPE, 29 INT_LEAST32_TYPE, INT_LEAST64_TYPE, INT_FAST8_TYPE, 30 INT_FAST16_TYPE, INT_FAST32_TYPE, INT_FAST64_TYPE, 31 BOOL_TYPE_SIZE, BITS_PER_UNIT, POINTER_SIZE, 32 INT_TYPE_SIZE, CHAR_TYPE_SIZE, SHORT_TYPE_SIZE, 33 LONG_TYPE_SIZE, LONG_LONG_TYPE_SIZE, 34 FLOAT_TYPE_SIZE, DOUBLE_TYPE_SIZE and 35 LONG_DOUBLE_TYPE_SIZE. */ 36#include "hash-set.h" 37#include "machmode.h" 38#include "vec.h" 39#include "double-int.h" 40#include "input.h" 41#include "alias.h" 42#include "symtab.h" 43#include "wide-int.h" 44#include "inchash.h" 45#include "real.h" 46#include "tree.h" 47#include "fold-const.h" 48#include "stor-layout.h" 49#include "stringpool.h" 50#include "langhooks.h" /* For iso-c-bindings.def. */ 51#include "target.h" 52#include "ggc.h" 53#include "gfortran.h" 54#include "diagnostic-core.h" /* For fatal_error. */ 55#include "toplev.h" /* For rest_of_decl_compilation. */ 56#include "trans.h" 57#include "trans-types.h" 58#include "trans-const.h" 59#include "flags.h" 60#include "dwarf2out.h" /* For struct array_descr_info. */ 61 62 63#if (GFC_MAX_DIMENSIONS < 10) 64#define GFC_RANK_DIGITS 1 65#define GFC_RANK_PRINTF_FORMAT "%01d" 66#elif (GFC_MAX_DIMENSIONS < 100) 67#define GFC_RANK_DIGITS 2 68#define GFC_RANK_PRINTF_FORMAT "%02d" 69#else 70#error If you really need >99 dimensions, continue the sequence above... 71#endif 72 73/* array of structs so we don't have to worry about xmalloc or free */ 74CInteropKind_t c_interop_kinds_table[ISOCBINDING_NUMBER]; 75 76tree gfc_array_index_type; 77tree gfc_array_range_type; 78tree gfc_character1_type_node; 79tree pvoid_type_node; 80tree prvoid_type_node; 81tree ppvoid_type_node; 82tree pchar_type_node; 83tree pfunc_type_node; 84 85tree gfc_charlen_type_node; 86 87tree float128_type_node = NULL_TREE; 88tree complex_float128_type_node = NULL_TREE; 89 90bool gfc_real16_is_float128 = false; 91 92static GTY(()) tree gfc_desc_dim_type; 93static GTY(()) tree gfc_max_array_element_size; 94static GTY(()) tree gfc_array_descriptor_base[2 * (GFC_MAX_DIMENSIONS+1)]; 95static GTY(()) tree gfc_array_descriptor_base_caf[2 * (GFC_MAX_DIMENSIONS+1)]; 96 97/* Arrays for all integral and real kinds. We'll fill this in at runtime 98 after the target has a chance to process command-line options. */ 99 100#define MAX_INT_KINDS 5 101gfc_integer_info gfc_integer_kinds[MAX_INT_KINDS + 1]; 102gfc_logical_info gfc_logical_kinds[MAX_INT_KINDS + 1]; 103static GTY(()) tree gfc_integer_types[MAX_INT_KINDS + 1]; 104static GTY(()) tree gfc_logical_types[MAX_INT_KINDS + 1]; 105 106#define MAX_REAL_KINDS 5 107gfc_real_info gfc_real_kinds[MAX_REAL_KINDS + 1]; 108static GTY(()) tree gfc_real_types[MAX_REAL_KINDS + 1]; 109static GTY(()) tree gfc_complex_types[MAX_REAL_KINDS + 1]; 110 111#define MAX_CHARACTER_KINDS 2 112gfc_character_info gfc_character_kinds[MAX_CHARACTER_KINDS + 1]; 113static GTY(()) tree gfc_character_types[MAX_CHARACTER_KINDS + 1]; 114static GTY(()) tree gfc_pcharacter_types[MAX_CHARACTER_KINDS + 1]; 115 116static tree gfc_add_field_to_struct_1 (tree, tree, tree, tree **); 117 118/* The integer kind to use for array indices. This will be set to the 119 proper value based on target information from the backend. */ 120 121int gfc_index_integer_kind; 122 123/* The default kinds of the various types. */ 124 125int gfc_default_integer_kind; 126int gfc_max_integer_kind; 127int gfc_default_real_kind; 128int gfc_default_double_kind; 129int gfc_default_character_kind; 130int gfc_default_logical_kind; 131int gfc_default_complex_kind; 132int gfc_c_int_kind; 133int gfc_atomic_int_kind; 134int gfc_atomic_logical_kind; 135 136/* The kind size used for record offsets. If the target system supports 137 kind=8, this will be set to 8, otherwise it is set to 4. */ 138int gfc_intio_kind; 139 140/* The integer kind used to store character lengths. */ 141int gfc_charlen_int_kind; 142 143/* The size of the numeric storage unit and character storage unit. */ 144int gfc_numeric_storage_size; 145int gfc_character_storage_size; 146 147 148bool 149gfc_check_any_c_kind (gfc_typespec *ts) 150{ 151 int i; 152 153 for (i = 0; i < ISOCBINDING_NUMBER; i++) 154 { 155 /* Check for any C interoperable kind for the given type/kind in ts. 156 This can be used after verify_c_interop to make sure that the 157 Fortran kind being used exists in at least some form for C. */ 158 if (c_interop_kinds_table[i].f90_type == ts->type && 159 c_interop_kinds_table[i].value == ts->kind) 160 return true; 161 } 162 163 return false; 164} 165 166 167static int 168get_real_kind_from_node (tree type) 169{ 170 int i; 171 172 for (i = 0; gfc_real_kinds[i].kind != 0; i++) 173 if (gfc_real_kinds[i].mode_precision == TYPE_PRECISION (type)) 174 return gfc_real_kinds[i].kind; 175 176 return -4; 177} 178 179static int 180get_int_kind_from_node (tree type) 181{ 182 int i; 183 184 if (!type) 185 return -2; 186 187 for (i = 0; gfc_integer_kinds[i].kind != 0; i++) 188 if (gfc_integer_kinds[i].bit_size == TYPE_PRECISION (type)) 189 return gfc_integer_kinds[i].kind; 190 191 return -1; 192} 193 194/* Return a typenode for the "standard" C type with a given name. */ 195static tree 196get_typenode_from_name (const char *name) 197{ 198 if (name == NULL || *name == '\0') 199 return NULL_TREE; 200 201 if (strcmp (name, "char") == 0) 202 return char_type_node; 203 if (strcmp (name, "unsigned char") == 0) 204 return unsigned_char_type_node; 205 if (strcmp (name, "signed char") == 0) 206 return signed_char_type_node; 207 208 if (strcmp (name, "short int") == 0) 209 return short_integer_type_node; 210 if (strcmp (name, "short unsigned int") == 0) 211 return short_unsigned_type_node; 212 213 if (strcmp (name, "int") == 0) 214 return integer_type_node; 215 if (strcmp (name, "unsigned int") == 0) 216 return unsigned_type_node; 217 218 if (strcmp (name, "long int") == 0) 219 return long_integer_type_node; 220 if (strcmp (name, "long unsigned int") == 0) 221 return long_unsigned_type_node; 222 223 if (strcmp (name, "long long int") == 0) 224 return long_long_integer_type_node; 225 if (strcmp (name, "long long unsigned int") == 0) 226 return long_long_unsigned_type_node; 227 228 gcc_unreachable (); 229} 230 231static int 232get_int_kind_from_name (const char *name) 233{ 234 return get_int_kind_from_node (get_typenode_from_name (name)); 235} 236 237 238/* Get the kind number corresponding to an integer of given size, 239 following the required return values for ISO_FORTRAN_ENV INT* constants: 240 -2 is returned if we support a kind of larger size, -1 otherwise. */ 241int 242gfc_get_int_kind_from_width_isofortranenv (int size) 243{ 244 int i; 245 246 /* Look for a kind with matching storage size. */ 247 for (i = 0; gfc_integer_kinds[i].kind != 0; i++) 248 if (gfc_integer_kinds[i].bit_size == size) 249 return gfc_integer_kinds[i].kind; 250 251 /* Look for a kind with larger storage size. */ 252 for (i = 0; gfc_integer_kinds[i].kind != 0; i++) 253 if (gfc_integer_kinds[i].bit_size > size) 254 return -2; 255 256 return -1; 257} 258 259/* Get the kind number corresponding to a real of given storage size, 260 following the required return values for ISO_FORTRAN_ENV REAL* constants: 261 -2 is returned if we support a kind of larger size, -1 otherwise. */ 262int 263gfc_get_real_kind_from_width_isofortranenv (int size) 264{ 265 int i; 266 267 size /= 8; 268 269 /* Look for a kind with matching storage size. */ 270 for (i = 0; gfc_real_kinds[i].kind != 0; i++) 271 if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds[i].kind)) == size) 272 return gfc_real_kinds[i].kind; 273 274 /* Look for a kind with larger storage size. */ 275 for (i = 0; gfc_real_kinds[i].kind != 0; i++) 276 if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds[i].kind)) > size) 277 return -2; 278 279 return -1; 280} 281 282 283 284static int 285get_int_kind_from_width (int size) 286{ 287 int i; 288 289 for (i = 0; gfc_integer_kinds[i].kind != 0; i++) 290 if (gfc_integer_kinds[i].bit_size == size) 291 return gfc_integer_kinds[i].kind; 292 293 return -2; 294} 295 296static int 297get_int_kind_from_minimal_width (int size) 298{ 299 int i; 300 301 for (i = 0; gfc_integer_kinds[i].kind != 0; i++) 302 if (gfc_integer_kinds[i].bit_size >= size) 303 return gfc_integer_kinds[i].kind; 304 305 return -2; 306} 307 308 309/* Generate the CInteropKind_t objects for the C interoperable 310 kinds. */ 311 312void 313gfc_init_c_interop_kinds (void) 314{ 315 int i; 316 317 /* init all pointers in the list to NULL */ 318 for (i = 0; i < ISOCBINDING_NUMBER; i++) 319 { 320 /* Initialize the name and value fields. */ 321 c_interop_kinds_table[i].name[0] = '\0'; 322 c_interop_kinds_table[i].value = -100; 323 c_interop_kinds_table[i].f90_type = BT_UNKNOWN; 324 } 325 326#define NAMED_INTCST(a,b,c,d) \ 327 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \ 328 c_interop_kinds_table[a].f90_type = BT_INTEGER; \ 329 c_interop_kinds_table[a].value = c; 330#define NAMED_REALCST(a,b,c,d) \ 331 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \ 332 c_interop_kinds_table[a].f90_type = BT_REAL; \ 333 c_interop_kinds_table[a].value = c; 334#define NAMED_CMPXCST(a,b,c,d) \ 335 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \ 336 c_interop_kinds_table[a].f90_type = BT_COMPLEX; \ 337 c_interop_kinds_table[a].value = c; 338#define NAMED_LOGCST(a,b,c) \ 339 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \ 340 c_interop_kinds_table[a].f90_type = BT_LOGICAL; \ 341 c_interop_kinds_table[a].value = c; 342#define NAMED_CHARKNDCST(a,b,c) \ 343 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \ 344 c_interop_kinds_table[a].f90_type = BT_CHARACTER; \ 345 c_interop_kinds_table[a].value = c; 346#define NAMED_CHARCST(a,b,c) \ 347 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \ 348 c_interop_kinds_table[a].f90_type = BT_CHARACTER; \ 349 c_interop_kinds_table[a].value = c; 350#define DERIVED_TYPE(a,b,c) \ 351 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \ 352 c_interop_kinds_table[a].f90_type = BT_DERIVED; \ 353 c_interop_kinds_table[a].value = c; 354#define NAMED_FUNCTION(a,b,c,d) \ 355 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \ 356 c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \ 357 c_interop_kinds_table[a].value = c; 358#define NAMED_SUBROUTINE(a,b,c,d) \ 359 strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \ 360 c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \ 361 c_interop_kinds_table[a].value = c; 362#include "iso-c-binding.def" 363} 364 365 366/* Query the target to determine which machine modes are available for 367 computation. Choose KIND numbers for them. */ 368 369void 370gfc_init_kinds (void) 371{ 372 unsigned int mode; 373 int i_index, r_index, kind; 374 bool saw_i4 = false, saw_i8 = false; 375 bool saw_r4 = false, saw_r8 = false, saw_r10 = false, saw_r16 = false; 376 377 for (i_index = 0, mode = MIN_MODE_INT; mode <= MAX_MODE_INT; mode++) 378 { 379 int kind, bitsize; 380 381 if (!targetm.scalar_mode_supported_p ((machine_mode) mode)) 382 continue; 383 384 /* The middle end doesn't support constants larger than 2*HWI. 385 Perhaps the target hook shouldn't have accepted these either, 386 but just to be safe... */ 387 bitsize = GET_MODE_BITSIZE ((machine_mode) mode); 388 if (bitsize > 2*HOST_BITS_PER_WIDE_INT) 389 continue; 390 391 gcc_assert (i_index != MAX_INT_KINDS); 392 393 /* Let the kind equal the bit size divided by 8. This insulates the 394 programmer from the underlying byte size. */ 395 kind = bitsize / 8; 396 397 if (kind == 4) 398 saw_i4 = true; 399 if (kind == 8) 400 saw_i8 = true; 401 402 gfc_integer_kinds[i_index].kind = kind; 403 gfc_integer_kinds[i_index].radix = 2; 404 gfc_integer_kinds[i_index].digits = bitsize - 1; 405 gfc_integer_kinds[i_index].bit_size = bitsize; 406 407 gfc_logical_kinds[i_index].kind = kind; 408 gfc_logical_kinds[i_index].bit_size = bitsize; 409 410 i_index += 1; 411 } 412 413 /* Set the kind used to match GFC_INT_IO in libgfortran. This is 414 used for large file access. */ 415 416 if (saw_i8) 417 gfc_intio_kind = 8; 418 else 419 gfc_intio_kind = 4; 420 421 /* If we do not at least have kind = 4, everything is pointless. */ 422 gcc_assert(saw_i4); 423 424 /* Set the maximum integer kind. Used with at least BOZ constants. */ 425 gfc_max_integer_kind = gfc_integer_kinds[i_index - 1].kind; 426 427 for (r_index = 0, mode = MIN_MODE_FLOAT; mode <= MAX_MODE_FLOAT; mode++) 428 { 429 const struct real_format *fmt = 430 REAL_MODE_FORMAT ((machine_mode) mode); 431 int kind; 432 433 if (fmt == NULL) 434 continue; 435 if (!targetm.scalar_mode_supported_p ((machine_mode) mode)) 436 continue; 437 438 /* Only let float, double, long double and __float128 go through. 439 Runtime support for others is not provided, so they would be 440 useless. */ 441 if (!targetm.libgcc_floating_mode_supported_p ((machine_mode) 442 mode)) 443 continue; 444 if (mode != TYPE_MODE (float_type_node) 445 && (mode != TYPE_MODE (double_type_node)) 446 && (mode != TYPE_MODE (long_double_type_node)) 447#if defined(HAVE_TFmode) && defined(ENABLE_LIBQUADMATH_SUPPORT) 448 && (mode != TFmode) 449#endif 450 ) 451 continue; 452 453 /* Let the kind equal the precision divided by 8, rounding up. Again, 454 this insulates the programmer from the underlying byte size. 455 456 Also, it effectively deals with IEEE extended formats. There, the 457 total size of the type may equal 16, but it's got 6 bytes of padding 458 and the increased size can get in the way of a real IEEE quad format 459 which may also be supported by the target. 460 461 We round up so as to handle IA-64 __floatreg (RFmode), which is an 462 82 bit type. Not to be confused with __float80 (XFmode), which is 463 an 80 bit type also supported by IA-64. So XFmode should come out 464 to be kind=10, and RFmode should come out to be kind=11. Egads. */ 465 466 kind = (GET_MODE_PRECISION (mode) + 7) / 8; 467 468 if (kind == 4) 469 saw_r4 = true; 470 if (kind == 8) 471 saw_r8 = true; 472 if (kind == 10) 473 saw_r10 = true; 474 if (kind == 16) 475 saw_r16 = true; 476 477 /* Careful we don't stumble a weird internal mode. */ 478 gcc_assert (r_index <= 0 || gfc_real_kinds[r_index-1].kind != kind); 479 /* Or have too many modes for the allocated space. */ 480 gcc_assert (r_index != MAX_REAL_KINDS); 481 482 gfc_real_kinds[r_index].kind = kind; 483 gfc_real_kinds[r_index].radix = fmt->b; 484 gfc_real_kinds[r_index].digits = fmt->p; 485 gfc_real_kinds[r_index].min_exponent = fmt->emin; 486 gfc_real_kinds[r_index].max_exponent = fmt->emax; 487 if (fmt->pnan < fmt->p) 488 /* This is an IBM extended double format (or the MIPS variant) 489 made up of two IEEE doubles. The value of the long double is 490 the sum of the values of the two parts. The most significant 491 part is required to be the value of the long double rounded 492 to the nearest double. If we use emax of 1024 then we can't 493 represent huge(x) = (1 - b**(-p)) * b**(emax-1) * b, because 494 rounding will make the most significant part overflow. */ 495 gfc_real_kinds[r_index].max_exponent = fmt->emax - 1; 496 gfc_real_kinds[r_index].mode_precision = GET_MODE_PRECISION (mode); 497 r_index += 1; 498 } 499 500 /* Choose the default integer kind. We choose 4 unless the user directs us 501 otherwise. Even if the user specified that the default integer kind is 8, 502 the numeric storage size is not 64 bits. In this case, a warning will be 503 issued when NUMERIC_STORAGE_SIZE is used. Set NUMERIC_STORAGE_SIZE to 32. */ 504 505 gfc_numeric_storage_size = 4 * 8; 506 507 if (flag_default_integer) 508 { 509 if (!saw_i8) 510 gfc_fatal_error ("INTEGER(KIND=8) is not available for " 511 "%<-fdefault-integer-8%> option"); 512 513 gfc_default_integer_kind = 8; 514 515 } 516 else if (flag_integer4_kind == 8) 517 { 518 if (!saw_i8) 519 gfc_fatal_error ("INTEGER(KIND=8) is not available for " 520 "%<-finteger-4-integer-8%> option"); 521 522 gfc_default_integer_kind = 8; 523 } 524 else if (saw_i4) 525 { 526 gfc_default_integer_kind = 4; 527 } 528 else 529 { 530 gfc_default_integer_kind = gfc_integer_kinds[i_index - 1].kind; 531 gfc_numeric_storage_size = gfc_integer_kinds[i_index - 1].bit_size; 532 } 533 534 /* Choose the default real kind. Again, we choose 4 when possible. */ 535 if (flag_default_real) 536 { 537 if (!saw_r8) 538 gfc_fatal_error ("REAL(KIND=8) is not available for " 539 "%<-fdefault-real-8%> option"); 540 541 gfc_default_real_kind = 8; 542 } 543 else if (flag_real4_kind == 8) 544 { 545 if (!saw_r8) 546 gfc_fatal_error ("REAL(KIND=8) is not available for %<-freal-4-real-8%> " 547 "option"); 548 549 gfc_default_real_kind = 8; 550 } 551 else if (flag_real4_kind == 10) 552 { 553 if (!saw_r10) 554 gfc_fatal_error ("REAL(KIND=10) is not available for " 555 "%<-freal-4-real-10%> option"); 556 557 gfc_default_real_kind = 10; 558 } 559 else if (flag_real4_kind == 16) 560 { 561 if (!saw_r16) 562 gfc_fatal_error ("REAL(KIND=16) is not available for " 563 "%<-freal-4-real-16%> option"); 564 565 gfc_default_real_kind = 16; 566 } 567 else if (saw_r4) 568 gfc_default_real_kind = 4; 569 else 570 gfc_default_real_kind = gfc_real_kinds[0].kind; 571 572 /* Choose the default double kind. If -fdefault-real and -fdefault-double 573 are specified, we use kind=8, if it's available. If -fdefault-real is 574 specified without -fdefault-double, we use kind=16, if it's available. 575 Otherwise we do not change anything. */ 576 if (flag_default_double && !flag_default_real) 577 gfc_fatal_error ("Use of %<-fdefault-double-8%> requires " 578 "%<-fdefault-real-8%>"); 579 580 if (flag_default_real && flag_default_double && saw_r8) 581 gfc_default_double_kind = 8; 582 else if (flag_default_real && saw_r16) 583 gfc_default_double_kind = 16; 584 else if (flag_real8_kind == 4) 585 { 586 if (!saw_r4) 587 gfc_fatal_error ("REAL(KIND=4) is not available for " 588 "%<-freal-8-real-4%> option"); 589 590 gfc_default_double_kind = 4; 591 } 592 else if (flag_real8_kind == 10 ) 593 { 594 if (!saw_r10) 595 gfc_fatal_error ("REAL(KIND=10) is not available for " 596 "%<-freal-8-real-10%> option"); 597 598 gfc_default_double_kind = 10; 599 } 600 else if (flag_real8_kind == 16 ) 601 { 602 if (!saw_r16) 603 gfc_fatal_error ("REAL(KIND=10) is not available for " 604 "%<-freal-8-real-16%> option"); 605 606 gfc_default_double_kind = 16; 607 } 608 else if (saw_r4 && saw_r8) 609 gfc_default_double_kind = 8; 610 else 611 { 612 /* F95 14.6.3.1: A nonpointer scalar object of type double precision 613 real ... occupies two contiguous numeric storage units. 614 615 Therefore we must be supplied a kind twice as large as we chose 616 for single precision. There are loopholes, in that double 617 precision must *occupy* two storage units, though it doesn't have 618 to *use* two storage units. Which means that you can make this 619 kind artificially wide by padding it. But at present there are 620 no GCC targets for which a two-word type does not exist, so we 621 just let gfc_validate_kind abort and tell us if something breaks. */ 622 623 gfc_default_double_kind 624 = gfc_validate_kind (BT_REAL, gfc_default_real_kind * 2, false); 625 } 626 627 /* The default logical kind is constrained to be the same as the 628 default integer kind. Similarly with complex and real. */ 629 gfc_default_logical_kind = gfc_default_integer_kind; 630 gfc_default_complex_kind = gfc_default_real_kind; 631 632 /* We only have two character kinds: ASCII and UCS-4. 633 ASCII corresponds to a 8-bit integer type, if one is available. 634 UCS-4 corresponds to a 32-bit integer type, if one is available. */ 635 i_index = 0; 636 if ((kind = get_int_kind_from_width (8)) > 0) 637 { 638 gfc_character_kinds[i_index].kind = kind; 639 gfc_character_kinds[i_index].bit_size = 8; 640 gfc_character_kinds[i_index].name = "ascii"; 641 i_index++; 642 } 643 if ((kind = get_int_kind_from_width (32)) > 0) 644 { 645 gfc_character_kinds[i_index].kind = kind; 646 gfc_character_kinds[i_index].bit_size = 32; 647 gfc_character_kinds[i_index].name = "iso_10646"; 648 i_index++; 649 } 650 651 /* Choose the smallest integer kind for our default character. */ 652 gfc_default_character_kind = gfc_character_kinds[0].kind; 653 gfc_character_storage_size = gfc_default_character_kind * 8; 654 655 gfc_index_integer_kind = get_int_kind_from_name (PTRDIFF_TYPE); 656 657 /* Pick a kind the same size as the C "int" type. */ 658 gfc_c_int_kind = INT_TYPE_SIZE / 8; 659 660 /* Choose atomic kinds to match C's int. */ 661 gfc_atomic_int_kind = gfc_c_int_kind; 662 gfc_atomic_logical_kind = gfc_c_int_kind; 663} 664 665 666/* Make sure that a valid kind is present. Returns an index into the 667 associated kinds array, -1 if the kind is not present. */ 668 669static int 670validate_integer (int kind) 671{ 672 int i; 673 674 for (i = 0; gfc_integer_kinds[i].kind != 0; i++) 675 if (gfc_integer_kinds[i].kind == kind) 676 return i; 677 678 return -1; 679} 680 681static int 682validate_real (int kind) 683{ 684 int i; 685 686 for (i = 0; gfc_real_kinds[i].kind != 0; i++) 687 if (gfc_real_kinds[i].kind == kind) 688 return i; 689 690 return -1; 691} 692 693static int 694validate_logical (int kind) 695{ 696 int i; 697 698 for (i = 0; gfc_logical_kinds[i].kind; i++) 699 if (gfc_logical_kinds[i].kind == kind) 700 return i; 701 702 return -1; 703} 704 705static int 706validate_character (int kind) 707{ 708 int i; 709 710 for (i = 0; gfc_character_kinds[i].kind; i++) 711 if (gfc_character_kinds[i].kind == kind) 712 return i; 713 714 return -1; 715} 716 717/* Validate a kind given a basic type. The return value is the same 718 for the child functions, with -1 indicating nonexistence of the 719 type. If MAY_FAIL is false, then -1 is never returned, and we ICE. */ 720 721int 722gfc_validate_kind (bt type, int kind, bool may_fail) 723{ 724 int rc; 725 726 switch (type) 727 { 728 case BT_REAL: /* Fall through */ 729 case BT_COMPLEX: 730 rc = validate_real (kind); 731 break; 732 case BT_INTEGER: 733 rc = validate_integer (kind); 734 break; 735 case BT_LOGICAL: 736 rc = validate_logical (kind); 737 break; 738 case BT_CHARACTER: 739 rc = validate_character (kind); 740 break; 741 742 default: 743 gfc_internal_error ("gfc_validate_kind(): Got bad type"); 744 } 745 746 if (rc < 0 && !may_fail) 747 gfc_internal_error ("gfc_validate_kind(): Got bad kind"); 748 749 return rc; 750} 751 752 753/* Four subroutines of gfc_init_types. Create type nodes for the given kind. 754 Reuse common type nodes where possible. Recognize if the kind matches up 755 with a C type. This will be used later in determining which routines may 756 be scarfed from libm. */ 757 758static tree 759gfc_build_int_type (gfc_integer_info *info) 760{ 761 int mode_precision = info->bit_size; 762 763 if (mode_precision == CHAR_TYPE_SIZE) 764 info->c_char = 1; 765 if (mode_precision == SHORT_TYPE_SIZE) 766 info->c_short = 1; 767 if (mode_precision == INT_TYPE_SIZE) 768 info->c_int = 1; 769 if (mode_precision == LONG_TYPE_SIZE) 770 info->c_long = 1; 771 if (mode_precision == LONG_LONG_TYPE_SIZE) 772 info->c_long_long = 1; 773 774 if (TYPE_PRECISION (intQI_type_node) == mode_precision) 775 return intQI_type_node; 776 if (TYPE_PRECISION (intHI_type_node) == mode_precision) 777 return intHI_type_node; 778 if (TYPE_PRECISION (intSI_type_node) == mode_precision) 779 return intSI_type_node; 780 if (TYPE_PRECISION (intDI_type_node) == mode_precision) 781 return intDI_type_node; 782 if (TYPE_PRECISION (intTI_type_node) == mode_precision) 783 return intTI_type_node; 784 785 return make_signed_type (mode_precision); 786} 787 788tree 789gfc_build_uint_type (int size) 790{ 791 if (size == CHAR_TYPE_SIZE) 792 return unsigned_char_type_node; 793 if (size == SHORT_TYPE_SIZE) 794 return short_unsigned_type_node; 795 if (size == INT_TYPE_SIZE) 796 return unsigned_type_node; 797 if (size == LONG_TYPE_SIZE) 798 return long_unsigned_type_node; 799 if (size == LONG_LONG_TYPE_SIZE) 800 return long_long_unsigned_type_node; 801 802 return make_unsigned_type (size); 803} 804 805 806static tree 807gfc_build_real_type (gfc_real_info *info) 808{ 809 int mode_precision = info->mode_precision; 810 tree new_type; 811 812 if (mode_precision == FLOAT_TYPE_SIZE) 813 info->c_float = 1; 814 if (mode_precision == DOUBLE_TYPE_SIZE) 815 info->c_double = 1; 816 if (mode_precision == LONG_DOUBLE_TYPE_SIZE) 817 info->c_long_double = 1; 818 if (mode_precision != LONG_DOUBLE_TYPE_SIZE && mode_precision == 128) 819 { 820 info->c_float128 = 1; 821 gfc_real16_is_float128 = true; 822 } 823 824 if (TYPE_PRECISION (float_type_node) == mode_precision) 825 return float_type_node; 826 if (TYPE_PRECISION (double_type_node) == mode_precision) 827 return double_type_node; 828 if (TYPE_PRECISION (long_double_type_node) == mode_precision) 829 return long_double_type_node; 830 831 new_type = make_node (REAL_TYPE); 832 TYPE_PRECISION (new_type) = mode_precision; 833 layout_type (new_type); 834 return new_type; 835} 836 837static tree 838gfc_build_complex_type (tree scalar_type) 839{ 840 tree new_type; 841 842 if (scalar_type == NULL) 843 return NULL; 844 if (scalar_type == float_type_node) 845 return complex_float_type_node; 846 if (scalar_type == double_type_node) 847 return complex_double_type_node; 848 if (scalar_type == long_double_type_node) 849 return complex_long_double_type_node; 850 851 new_type = make_node (COMPLEX_TYPE); 852 TREE_TYPE (new_type) = scalar_type; 853 layout_type (new_type); 854 return new_type; 855} 856 857static tree 858gfc_build_logical_type (gfc_logical_info *info) 859{ 860 int bit_size = info->bit_size; 861 tree new_type; 862 863 if (bit_size == BOOL_TYPE_SIZE) 864 { 865 info->c_bool = 1; 866 return boolean_type_node; 867 } 868 869 new_type = make_unsigned_type (bit_size); 870 TREE_SET_CODE (new_type, BOOLEAN_TYPE); 871 TYPE_MAX_VALUE (new_type) = build_int_cst (new_type, 1); 872 TYPE_PRECISION (new_type) = 1; 873 874 return new_type; 875} 876 877 878/* Create the backend type nodes. We map them to their 879 equivalent C type, at least for now. We also give 880 names to the types here, and we push them in the 881 global binding level context.*/ 882 883void 884gfc_init_types (void) 885{ 886 char name_buf[18]; 887 int index; 888 tree type; 889 unsigned n; 890 891 /* Create and name the types. */ 892#define PUSH_TYPE(name, node) \ 893 pushdecl (build_decl (input_location, \ 894 TYPE_DECL, get_identifier (name), node)) 895 896 for (index = 0; gfc_integer_kinds[index].kind != 0; ++index) 897 { 898 type = gfc_build_int_type (&gfc_integer_kinds[index]); 899 /* Ensure integer(kind=1) doesn't have TYPE_STRING_FLAG set. */ 900 if (TYPE_STRING_FLAG (type)) 901 type = make_signed_type (gfc_integer_kinds[index].bit_size); 902 gfc_integer_types[index] = type; 903 snprintf (name_buf, sizeof(name_buf), "integer(kind=%d)", 904 gfc_integer_kinds[index].kind); 905 PUSH_TYPE (name_buf, type); 906 } 907 908 for (index = 0; gfc_logical_kinds[index].kind != 0; ++index) 909 { 910 type = gfc_build_logical_type (&gfc_logical_kinds[index]); 911 gfc_logical_types[index] = type; 912 snprintf (name_buf, sizeof(name_buf), "logical(kind=%d)", 913 gfc_logical_kinds[index].kind); 914 PUSH_TYPE (name_buf, type); 915 } 916 917 for (index = 0; gfc_real_kinds[index].kind != 0; index++) 918 { 919 type = gfc_build_real_type (&gfc_real_kinds[index]); 920 gfc_real_types[index] = type; 921 snprintf (name_buf, sizeof(name_buf), "real(kind=%d)", 922 gfc_real_kinds[index].kind); 923 PUSH_TYPE (name_buf, type); 924 925 if (gfc_real_kinds[index].c_float128) 926 float128_type_node = type; 927 928 type = gfc_build_complex_type (type); 929 gfc_complex_types[index] = type; 930 snprintf (name_buf, sizeof(name_buf), "complex(kind=%d)", 931 gfc_real_kinds[index].kind); 932 PUSH_TYPE (name_buf, type); 933 934 if (gfc_real_kinds[index].c_float128) 935 complex_float128_type_node = type; 936 } 937 938 for (index = 0; gfc_character_kinds[index].kind != 0; ++index) 939 { 940 type = gfc_build_uint_type (gfc_character_kinds[index].bit_size); 941 type = build_qualified_type (type, TYPE_UNQUALIFIED); 942 snprintf (name_buf, sizeof(name_buf), "character(kind=%d)", 943 gfc_character_kinds[index].kind); 944 PUSH_TYPE (name_buf, type); 945 gfc_character_types[index] = type; 946 gfc_pcharacter_types[index] = build_pointer_type (type); 947 } 948 gfc_character1_type_node = gfc_character_types[0]; 949 950 PUSH_TYPE ("byte", unsigned_char_type_node); 951 PUSH_TYPE ("void", void_type_node); 952 953 /* DBX debugging output gets upset if these aren't set. */ 954 if (!TYPE_NAME (integer_type_node)) 955 PUSH_TYPE ("c_integer", integer_type_node); 956 if (!TYPE_NAME (char_type_node)) 957 PUSH_TYPE ("c_char", char_type_node); 958 959#undef PUSH_TYPE 960 961 pvoid_type_node = build_pointer_type (void_type_node); 962 prvoid_type_node = build_qualified_type (pvoid_type_node, TYPE_QUAL_RESTRICT); 963 ppvoid_type_node = build_pointer_type (pvoid_type_node); 964 pchar_type_node = build_pointer_type (gfc_character1_type_node); 965 pfunc_type_node 966 = build_pointer_type (build_function_type_list (void_type_node, NULL_TREE)); 967 968 gfc_array_index_type = gfc_get_int_type (gfc_index_integer_kind); 969 /* We cannot use gfc_index_zero_node in definition of gfc_array_range_type, 970 since this function is called before gfc_init_constants. */ 971 gfc_array_range_type 972 = build_range_type (gfc_array_index_type, 973 build_int_cst (gfc_array_index_type, 0), 974 NULL_TREE); 975 976 /* The maximum array element size that can be handled is determined 977 by the number of bits available to store this field in the array 978 descriptor. */ 979 980 n = TYPE_PRECISION (gfc_array_index_type) - GFC_DTYPE_SIZE_SHIFT; 981 gfc_max_array_element_size 982 = wide_int_to_tree (size_type_node, 983 wi::mask (n, UNSIGNED, 984 TYPE_PRECISION (size_type_node))); 985 986 boolean_type_node = gfc_get_logical_type (gfc_default_logical_kind); 987 boolean_true_node = build_int_cst (boolean_type_node, 1); 988 boolean_false_node = build_int_cst (boolean_type_node, 0); 989 990 /* ??? Shouldn't this be based on gfc_index_integer_kind or so? */ 991 gfc_charlen_int_kind = 4; 992 gfc_charlen_type_node = gfc_get_int_type (gfc_charlen_int_kind); 993} 994 995/* Get the type node for the given type and kind. */ 996 997tree 998gfc_get_int_type (int kind) 999{ 1000 int index = gfc_validate_kind (BT_INTEGER, kind, true); 1001 return index < 0 ? 0 : gfc_integer_types[index]; 1002} 1003 1004tree 1005gfc_get_real_type (int kind) 1006{ 1007 int index = gfc_validate_kind (BT_REAL, kind, true); 1008 return index < 0 ? 0 : gfc_real_types[index]; 1009} 1010 1011tree 1012gfc_get_complex_type (int kind) 1013{ 1014 int index = gfc_validate_kind (BT_COMPLEX, kind, true); 1015 return index < 0 ? 0 : gfc_complex_types[index]; 1016} 1017 1018tree 1019gfc_get_logical_type (int kind) 1020{ 1021 int index = gfc_validate_kind (BT_LOGICAL, kind, true); 1022 return index < 0 ? 0 : gfc_logical_types[index]; 1023} 1024 1025tree 1026gfc_get_char_type (int kind) 1027{ 1028 int index = gfc_validate_kind (BT_CHARACTER, kind, true); 1029 return index < 0 ? 0 : gfc_character_types[index]; 1030} 1031 1032tree 1033gfc_get_pchar_type (int kind) 1034{ 1035 int index = gfc_validate_kind (BT_CHARACTER, kind, true); 1036 return index < 0 ? 0 : gfc_pcharacter_types[index]; 1037} 1038 1039 1040/* Create a character type with the given kind and length. */ 1041 1042tree 1043gfc_get_character_type_len_for_eltype (tree eltype, tree len) 1044{ 1045 tree bounds, type; 1046 1047 bounds = build_range_type (gfc_charlen_type_node, gfc_index_one_node, len); 1048 type = build_array_type (eltype, bounds); 1049 TYPE_STRING_FLAG (type) = 1; 1050 1051 return type; 1052} 1053 1054tree 1055gfc_get_character_type_len (int kind, tree len) 1056{ 1057 gfc_validate_kind (BT_CHARACTER, kind, false); 1058 return gfc_get_character_type_len_for_eltype (gfc_get_char_type (kind), len); 1059} 1060 1061 1062/* Get a type node for a character kind. */ 1063 1064tree 1065gfc_get_character_type (int kind, gfc_charlen * cl) 1066{ 1067 tree len; 1068 1069 len = (cl == NULL) ? NULL_TREE : cl->backend_decl; 1070 if (len && POINTER_TYPE_P (TREE_TYPE (len))) 1071 len = build_fold_indirect_ref (len); 1072 1073 return gfc_get_character_type_len (kind, len); 1074} 1075 1076/* Covert a basic type. This will be an array for character types. */ 1077 1078tree 1079gfc_typenode_for_spec (gfc_typespec * spec) 1080{ 1081 tree basetype; 1082 1083 switch (spec->type) 1084 { 1085 case BT_UNKNOWN: 1086 gcc_unreachable (); 1087 1088 case BT_INTEGER: 1089 /* We use INTEGER(c_intptr_t) for C_PTR and C_FUNPTR once the symbol 1090 has been resolved. This is done so we can convert C_PTR and 1091 C_FUNPTR to simple variables that get translated to (void *). */ 1092 if (spec->f90_type == BT_VOID) 1093 { 1094 if (spec->u.derived 1095 && spec->u.derived->intmod_sym_id == ISOCBINDING_PTR) 1096 basetype = ptr_type_node; 1097 else 1098 basetype = pfunc_type_node; 1099 } 1100 else 1101 basetype = gfc_get_int_type (spec->kind); 1102 break; 1103 1104 case BT_REAL: 1105 basetype = gfc_get_real_type (spec->kind); 1106 break; 1107 1108 case BT_COMPLEX: 1109 basetype = gfc_get_complex_type (spec->kind); 1110 break; 1111 1112 case BT_LOGICAL: 1113 basetype = gfc_get_logical_type (spec->kind); 1114 break; 1115 1116 case BT_CHARACTER: 1117 basetype = gfc_get_character_type (spec->kind, spec->u.cl); 1118 break; 1119 1120 case BT_HOLLERITH: 1121 /* Since this cannot be used, return a length one character. */ 1122 basetype = gfc_get_character_type_len (gfc_default_character_kind, 1123 gfc_index_one_node); 1124 break; 1125 1126 case BT_DERIVED: 1127 case BT_CLASS: 1128 basetype = gfc_get_derived_type (spec->u.derived); 1129 1130 if (spec->type == BT_CLASS) 1131 GFC_CLASS_TYPE_P (basetype) = 1; 1132 1133 /* If we're dealing with either C_PTR or C_FUNPTR, we modified the 1134 type and kind to fit a (void *) and the basetype returned was a 1135 ptr_type_node. We need to pass up this new information to the 1136 symbol that was declared of type C_PTR or C_FUNPTR. */ 1137 if (spec->u.derived->ts.f90_type == BT_VOID) 1138 { 1139 spec->type = BT_INTEGER; 1140 spec->kind = gfc_index_integer_kind; 1141 spec->f90_type = BT_VOID; 1142 } 1143 break; 1144 case BT_VOID: 1145 case BT_ASSUMED: 1146 /* This is for the second arg to c_f_pointer and c_f_procpointer 1147 of the iso_c_binding module, to accept any ptr type. */ 1148 basetype = ptr_type_node; 1149 if (spec->f90_type == BT_VOID) 1150 { 1151 if (spec->u.derived 1152 && spec->u.derived->intmod_sym_id == ISOCBINDING_PTR) 1153 basetype = ptr_type_node; 1154 else 1155 basetype = pfunc_type_node; 1156 } 1157 break; 1158 default: 1159 gcc_unreachable (); 1160 } 1161 return basetype; 1162} 1163 1164/* Build an INT_CST for constant expressions, otherwise return NULL_TREE. */ 1165 1166static tree 1167gfc_conv_array_bound (gfc_expr * expr) 1168{ 1169 /* If expr is an integer constant, return that. */ 1170 if (expr != NULL && expr->expr_type == EXPR_CONSTANT) 1171 return gfc_conv_mpz_to_tree (expr->value.integer, gfc_index_integer_kind); 1172 1173 /* Otherwise return NULL. */ 1174 return NULL_TREE; 1175} 1176 1177/* Return the type of an element of the array. Note that scalar coarrays 1178 are special. In particular, for GFC_ARRAY_TYPE_P, the original argument 1179 (with POINTER_TYPE stripped) is returned. */ 1180 1181tree 1182gfc_get_element_type (tree type) 1183{ 1184 tree element; 1185 1186 if (GFC_ARRAY_TYPE_P (type)) 1187 { 1188 if (TREE_CODE (type) == POINTER_TYPE) 1189 type = TREE_TYPE (type); 1190 if (GFC_TYPE_ARRAY_RANK (type) == 0) 1191 { 1192 gcc_assert (GFC_TYPE_ARRAY_CORANK (type) > 0); 1193 element = type; 1194 } 1195 else 1196 { 1197 gcc_assert (TREE_CODE (type) == ARRAY_TYPE); 1198 element = TREE_TYPE (type); 1199 } 1200 } 1201 else 1202 { 1203 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); 1204 element = GFC_TYPE_ARRAY_DATAPTR_TYPE (type); 1205 1206 gcc_assert (TREE_CODE (element) == POINTER_TYPE); 1207 element = TREE_TYPE (element); 1208 1209 /* For arrays, which are not scalar coarrays. */ 1210 if (TREE_CODE (element) == ARRAY_TYPE && !TYPE_STRING_FLAG (element)) 1211 element = TREE_TYPE (element); 1212 } 1213 1214 return element; 1215} 1216 1217/* Build an array. This function is called from gfc_sym_type(). 1218 Actually returns array descriptor type. 1219 1220 Format of array descriptors is as follows: 1221 1222 struct gfc_array_descriptor 1223 { 1224 array *data 1225 index offset; 1226 index dtype; 1227 struct descriptor_dimension dimension[N_DIM]; 1228 } 1229 1230 struct descriptor_dimension 1231 { 1232 index stride; 1233 index lbound; 1234 index ubound; 1235 } 1236 1237 Translation code should use gfc_conv_descriptor_* rather than 1238 accessing the descriptor directly. Any changes to the array 1239 descriptor type will require changes in gfc_conv_descriptor_* and 1240 gfc_build_array_initializer. 1241 1242 This is represented internally as a RECORD_TYPE. The index nodes 1243 are gfc_array_index_type and the data node is a pointer to the 1244 data. See below for the handling of character types. 1245 1246 The dtype member is formatted as follows: 1247 rank = dtype & GFC_DTYPE_RANK_MASK // 3 bits 1248 type = (dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT // 3 bits 1249 size = dtype >> GFC_DTYPE_SIZE_SHIFT 1250 1251 I originally used nested ARRAY_TYPE nodes to represent arrays, but 1252 this generated poor code for assumed/deferred size arrays. These 1253 require use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part 1254 of the GENERIC grammar. Also, there is no way to explicitly set 1255 the array stride, so all data must be packed(1). I've tried to 1256 mark all the functions which would require modification with a GCC 1257 ARRAYS comment. 1258 1259 The data component points to the first element in the array. The 1260 offset field is the position of the origin of the array (i.e. element 1261 (0, 0 ...)). This may be outside the bounds of the array. 1262 1263 An element is accessed by 1264 data[offset + index0*stride0 + index1*stride1 + index2*stride2] 1265 This gives good performance as the computation does not involve the 1266 bounds of the array. For packed arrays, this is optimized further 1267 by substituting the known strides. 1268 1269 This system has one problem: all array bounds must be within 2^31 1270 elements of the origin (2^63 on 64-bit machines). For example 1271 integer, dimension (80000:90000, 80000:90000, 2) :: array 1272 may not work properly on 32-bit machines because 80000*80000 > 1273 2^31, so the calculation for stride2 would overflow. This may 1274 still work, but I haven't checked, and it relies on the overflow 1275 doing the right thing. 1276 1277 The way to fix this problem is to access elements as follows: 1278 data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1] 1279 Obviously this is much slower. I will make this a compile time 1280 option, something like -fsmall-array-offsets. Mixing code compiled 1281 with and without this switch will work. 1282 1283 (1) This can be worked around by modifying the upper bound of the 1284 previous dimension. This requires extra fields in the descriptor 1285 (both real_ubound and fake_ubound). */ 1286 1287 1288/* Returns true if the array sym does not require a descriptor. */ 1289 1290int 1291gfc_is_nodesc_array (gfc_symbol * sym) 1292{ 1293 gcc_assert (sym->attr.dimension || sym->attr.codimension); 1294 1295 /* We only want local arrays. */ 1296 if (sym->attr.pointer || sym->attr.allocatable) 1297 return 0; 1298 1299 /* We want a descriptor for associate-name arrays that do not have an 1300 explicitly known shape already. */ 1301 if (sym->assoc && sym->as->type != AS_EXPLICIT) 1302 return 0; 1303 1304 if (sym->attr.dummy) 1305 return sym->as->type != AS_ASSUMED_SHAPE 1306 && sym->as->type != AS_ASSUMED_RANK; 1307 1308 if (sym->attr.result || sym->attr.function) 1309 return 0; 1310 1311 gcc_assert (sym->as->type == AS_EXPLICIT || sym->as->cp_was_assumed); 1312 1313 return 1; 1314} 1315 1316 1317/* Create an array descriptor type. */ 1318 1319static tree 1320gfc_build_array_type (tree type, gfc_array_spec * as, 1321 enum gfc_array_kind akind, bool restricted, 1322 bool contiguous) 1323{ 1324 tree lbound[GFC_MAX_DIMENSIONS]; 1325 tree ubound[GFC_MAX_DIMENSIONS]; 1326 int n, corank; 1327 1328 /* Assumed-shape arrays do not have codimension information stored in the 1329 descriptor. */ 1330 corank = as->corank; 1331 if (as->type == AS_ASSUMED_SHAPE || 1332 (as->type == AS_ASSUMED_RANK && akind == GFC_ARRAY_ALLOCATABLE)) 1333 corank = 0; 1334 1335 if (as->type == AS_ASSUMED_RANK) 1336 for (n = 0; n < GFC_MAX_DIMENSIONS; n++) 1337 { 1338 lbound[n] = NULL_TREE; 1339 ubound[n] = NULL_TREE; 1340 } 1341 1342 for (n = 0; n < as->rank; n++) 1343 { 1344 /* Create expressions for the known bounds of the array. */ 1345 if (as->type == AS_ASSUMED_SHAPE && as->lower[n] == NULL) 1346 lbound[n] = gfc_index_one_node; 1347 else 1348 lbound[n] = gfc_conv_array_bound (as->lower[n]); 1349 ubound[n] = gfc_conv_array_bound (as->upper[n]); 1350 } 1351 1352 for (n = as->rank; n < as->rank + corank; n++) 1353 { 1354 if (as->type != AS_DEFERRED && as->lower[n] == NULL) 1355 lbound[n] = gfc_index_one_node; 1356 else 1357 lbound[n] = gfc_conv_array_bound (as->lower[n]); 1358 1359 if (n < as->rank + corank - 1) 1360 ubound[n] = gfc_conv_array_bound (as->upper[n]); 1361 } 1362 1363 if (as->type == AS_ASSUMED_SHAPE) 1364 akind = contiguous ? GFC_ARRAY_ASSUMED_SHAPE_CONT 1365 : GFC_ARRAY_ASSUMED_SHAPE; 1366 else if (as->type == AS_ASSUMED_RANK) 1367 akind = contiguous ? GFC_ARRAY_ASSUMED_RANK_CONT 1368 : GFC_ARRAY_ASSUMED_RANK; 1369 return gfc_get_array_type_bounds (type, as->rank == -1 1370 ? GFC_MAX_DIMENSIONS : as->rank, 1371 corank, lbound, 1372 ubound, 0, akind, restricted); 1373} 1374 1375/* Returns the struct descriptor_dimension type. */ 1376 1377static tree 1378gfc_get_desc_dim_type (void) 1379{ 1380 tree type; 1381 tree decl, *chain = NULL; 1382 1383 if (gfc_desc_dim_type) 1384 return gfc_desc_dim_type; 1385 1386 /* Build the type node. */ 1387 type = make_node (RECORD_TYPE); 1388 1389 TYPE_NAME (type) = get_identifier ("descriptor_dimension"); 1390 TYPE_PACKED (type) = 1; 1391 1392 /* Consists of the stride, lbound and ubound members. */ 1393 decl = gfc_add_field_to_struct_1 (type, 1394 get_identifier ("stride"), 1395 gfc_array_index_type, &chain); 1396 TREE_NO_WARNING (decl) = 1; 1397 1398 decl = gfc_add_field_to_struct_1 (type, 1399 get_identifier ("lbound"), 1400 gfc_array_index_type, &chain); 1401 TREE_NO_WARNING (decl) = 1; 1402 1403 decl = gfc_add_field_to_struct_1 (type, 1404 get_identifier ("ubound"), 1405 gfc_array_index_type, &chain); 1406 TREE_NO_WARNING (decl) = 1; 1407 1408 /* Finish off the type. */ 1409 gfc_finish_type (type); 1410 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type)) = 1; 1411 1412 gfc_desc_dim_type = type; 1413 return type; 1414} 1415 1416 1417/* Return the DTYPE for an array. This describes the type and type parameters 1418 of the array. */ 1419/* TODO: Only call this when the value is actually used, and make all the 1420 unknown cases abort. */ 1421 1422tree 1423gfc_get_dtype_rank_type (int rank, tree etype) 1424{ 1425 tree size; 1426 int n; 1427 HOST_WIDE_INT i; 1428 tree tmp; 1429 tree dtype; 1430 1431 switch (TREE_CODE (etype)) 1432 { 1433 case INTEGER_TYPE: 1434 n = BT_INTEGER; 1435 break; 1436 1437 case BOOLEAN_TYPE: 1438 n = BT_LOGICAL; 1439 break; 1440 1441 case REAL_TYPE: 1442 n = BT_REAL; 1443 break; 1444 1445 case COMPLEX_TYPE: 1446 n = BT_COMPLEX; 1447 break; 1448 1449 /* We will never have arrays of arrays. */ 1450 case RECORD_TYPE: 1451 n = BT_DERIVED; 1452 break; 1453 1454 case ARRAY_TYPE: 1455 n = BT_CHARACTER; 1456 break; 1457 1458 case POINTER_TYPE: 1459 n = BT_ASSUMED; 1460 break; 1461 1462 default: 1463 /* TODO: Don't do dtype for temporary descriptorless arrays. */ 1464 /* We can strange array types for temporary arrays. */ 1465 return gfc_index_zero_node; 1466 } 1467 1468 gcc_assert (rank <= GFC_DTYPE_RANK_MASK); 1469 size = TYPE_SIZE_UNIT (etype); 1470 1471 i = rank | (n << GFC_DTYPE_TYPE_SHIFT); 1472 if (size && INTEGER_CST_P (size)) 1473 { 1474 if (tree_int_cst_lt (gfc_max_array_element_size, size)) 1475 gfc_fatal_error ("Array element size too big at %C"); 1476 1477 i += TREE_INT_CST_LOW (size) << GFC_DTYPE_SIZE_SHIFT; 1478 } 1479 dtype = build_int_cst (gfc_array_index_type, i); 1480 1481 if (size && !INTEGER_CST_P (size)) 1482 { 1483 tmp = build_int_cst (gfc_array_index_type, GFC_DTYPE_SIZE_SHIFT); 1484 tmp = fold_build2_loc (input_location, LSHIFT_EXPR, 1485 gfc_array_index_type, 1486 fold_convert (gfc_array_index_type, size), tmp); 1487 dtype = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, 1488 tmp, dtype); 1489 } 1490 /* If we don't know the size we leave it as zero. This should never happen 1491 for anything that is actually used. */ 1492 /* TODO: Check this is actually true, particularly when repacking 1493 assumed size parameters. */ 1494 1495 return dtype; 1496} 1497 1498 1499tree 1500gfc_get_dtype (tree type) 1501{ 1502 tree dtype; 1503 tree etype; 1504 int rank; 1505 1506 gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type)); 1507 1508 if (GFC_TYPE_ARRAY_DTYPE (type)) 1509 return GFC_TYPE_ARRAY_DTYPE (type); 1510 1511 rank = GFC_TYPE_ARRAY_RANK (type); 1512 etype = gfc_get_element_type (type); 1513 dtype = gfc_get_dtype_rank_type (rank, etype); 1514 1515 GFC_TYPE_ARRAY_DTYPE (type) = dtype; 1516 return dtype; 1517} 1518 1519 1520/* Build an array type for use without a descriptor, packed according 1521 to the value of PACKED. */ 1522 1523tree 1524gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed, 1525 bool restricted) 1526{ 1527 tree range; 1528 tree type; 1529 tree tmp; 1530 int n; 1531 int known_stride; 1532 int known_offset; 1533 mpz_t offset; 1534 mpz_t stride; 1535 mpz_t delta; 1536 gfc_expr *expr; 1537 1538 mpz_init_set_ui (offset, 0); 1539 mpz_init_set_ui (stride, 1); 1540 mpz_init (delta); 1541 1542 /* We don't use build_array_type because this does not include include 1543 lang-specific information (i.e. the bounds of the array) when checking 1544 for duplicates. */ 1545 if (as->rank) 1546 type = make_node (ARRAY_TYPE); 1547 else 1548 type = build_variant_type_copy (etype); 1549 1550 GFC_ARRAY_TYPE_P (type) = 1; 1551 TYPE_LANG_SPECIFIC (type) = ggc_cleared_alloc<struct lang_type> (); 1552 1553 known_stride = (packed != PACKED_NO); 1554 known_offset = 1; 1555 for (n = 0; n < as->rank; n++) 1556 { 1557 /* Fill in the stride and bound components of the type. */ 1558 if (known_stride) 1559 tmp = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind); 1560 else 1561 tmp = NULL_TREE; 1562 GFC_TYPE_ARRAY_STRIDE (type, n) = tmp; 1563 1564 expr = as->lower[n]; 1565 if (expr->expr_type == EXPR_CONSTANT) 1566 { 1567 tmp = gfc_conv_mpz_to_tree (expr->value.integer, 1568 gfc_index_integer_kind); 1569 } 1570 else 1571 { 1572 known_stride = 0; 1573 tmp = NULL_TREE; 1574 } 1575 GFC_TYPE_ARRAY_LBOUND (type, n) = tmp; 1576 1577 if (known_stride) 1578 { 1579 /* Calculate the offset. */ 1580 mpz_mul (delta, stride, as->lower[n]->value.integer); 1581 mpz_sub (offset, offset, delta); 1582 } 1583 else 1584 known_offset = 0; 1585 1586 expr = as->upper[n]; 1587 if (expr && expr->expr_type == EXPR_CONSTANT) 1588 { 1589 tmp = gfc_conv_mpz_to_tree (expr->value.integer, 1590 gfc_index_integer_kind); 1591 } 1592 else 1593 { 1594 tmp = NULL_TREE; 1595 known_stride = 0; 1596 } 1597 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp; 1598 1599 if (known_stride) 1600 { 1601 /* Calculate the stride. */ 1602 mpz_sub (delta, as->upper[n]->value.integer, 1603 as->lower[n]->value.integer); 1604 mpz_add_ui (delta, delta, 1); 1605 mpz_mul (stride, stride, delta); 1606 } 1607 1608 /* Only the first stride is known for partial packed arrays. */ 1609 if (packed == PACKED_NO || packed == PACKED_PARTIAL) 1610 known_stride = 0; 1611 } 1612 for (n = as->rank; n < as->rank + as->corank; n++) 1613 { 1614 expr = as->lower[n]; 1615 if (expr->expr_type == EXPR_CONSTANT) 1616 tmp = gfc_conv_mpz_to_tree (expr->value.integer, 1617 gfc_index_integer_kind); 1618 else 1619 tmp = NULL_TREE; 1620 GFC_TYPE_ARRAY_LBOUND (type, n) = tmp; 1621 1622 expr = as->upper[n]; 1623 if (expr && expr->expr_type == EXPR_CONSTANT) 1624 tmp = gfc_conv_mpz_to_tree (expr->value.integer, 1625 gfc_index_integer_kind); 1626 else 1627 tmp = NULL_TREE; 1628 if (n < as->rank + as->corank - 1) 1629 GFC_TYPE_ARRAY_UBOUND (type, n) = tmp; 1630 } 1631 1632 if (known_offset) 1633 { 1634 GFC_TYPE_ARRAY_OFFSET (type) = 1635 gfc_conv_mpz_to_tree (offset, gfc_index_integer_kind); 1636 } 1637 else 1638 GFC_TYPE_ARRAY_OFFSET (type) = NULL_TREE; 1639 1640 if (known_stride) 1641 { 1642 GFC_TYPE_ARRAY_SIZE (type) = 1643 gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind); 1644 } 1645 else 1646 GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE; 1647 1648 GFC_TYPE_ARRAY_RANK (type) = as->rank; 1649 GFC_TYPE_ARRAY_CORANK (type) = as->corank; 1650 GFC_TYPE_ARRAY_DTYPE (type) = NULL_TREE; 1651 range = build_range_type (gfc_array_index_type, gfc_index_zero_node, 1652 NULL_TREE); 1653 /* TODO: use main type if it is unbounded. */ 1654 GFC_TYPE_ARRAY_DATAPTR_TYPE (type) = 1655 build_pointer_type (build_array_type (etype, range)); 1656 if (restricted) 1657 GFC_TYPE_ARRAY_DATAPTR_TYPE (type) = 1658 build_qualified_type (GFC_TYPE_ARRAY_DATAPTR_TYPE (type), 1659 TYPE_QUAL_RESTRICT); 1660 1661 if (as->rank == 0) 1662 { 1663 if (packed != PACKED_STATIC || flag_coarray == GFC_FCOARRAY_LIB) 1664 { 1665 type = build_pointer_type (type); 1666 1667 if (restricted) 1668 type = build_qualified_type (type, TYPE_QUAL_RESTRICT); 1669 1670 GFC_ARRAY_TYPE_P (type) = 1; 1671 TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type)); 1672 } 1673 1674 return type; 1675 } 1676 1677 if (known_stride) 1678 { 1679 mpz_sub_ui (stride, stride, 1); 1680 range = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind); 1681 } 1682 else 1683 range = NULL_TREE; 1684 1685 range = build_range_type (gfc_array_index_type, gfc_index_zero_node, range); 1686 TYPE_DOMAIN (type) = range; 1687 1688 build_pointer_type (etype); 1689 TREE_TYPE (type) = etype; 1690 1691 layout_type (type); 1692 1693 mpz_clear (offset); 1694 mpz_clear (stride); 1695 mpz_clear (delta); 1696 1697 /* Represent packed arrays as multi-dimensional if they have rank > 1698 1 and with proper bounds, instead of flat arrays. This makes for 1699 better debug info. */ 1700 if (known_offset) 1701 { 1702 tree gtype = etype, rtype, type_decl; 1703 1704 for (n = as->rank - 1; n >= 0; n--) 1705 { 1706 rtype = build_range_type (gfc_array_index_type, 1707 GFC_TYPE_ARRAY_LBOUND (type, n), 1708 GFC_TYPE_ARRAY_UBOUND (type, n)); 1709 gtype = build_array_type (gtype, rtype); 1710 } 1711 TYPE_NAME (type) = type_decl = build_decl (input_location, 1712 TYPE_DECL, NULL, gtype); 1713 DECL_ORIGINAL_TYPE (type_decl) = gtype; 1714 } 1715 1716 if (packed != PACKED_STATIC || !known_stride 1717 || (as->corank && flag_coarray == GFC_FCOARRAY_LIB)) 1718 { 1719 /* For dummy arrays and automatic (heap allocated) arrays we 1720 want a pointer to the array. */ 1721 type = build_pointer_type (type); 1722 if (restricted) 1723 type = build_qualified_type (type, TYPE_QUAL_RESTRICT); 1724 GFC_ARRAY_TYPE_P (type) = 1; 1725 TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type)); 1726 } 1727 return type; 1728} 1729 1730 1731/* Return or create the base type for an array descriptor. */ 1732 1733static tree 1734gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted, 1735 enum gfc_array_kind akind) 1736{ 1737 tree fat_type, decl, arraytype, *chain = NULL; 1738 char name[16 + 2*GFC_RANK_DIGITS + 1 + 1]; 1739 int idx; 1740 1741 /* Assumed-rank array. */ 1742 if (dimen == -1) 1743 dimen = GFC_MAX_DIMENSIONS; 1744 1745 idx = 2 * (codimen + dimen) + restricted; 1746 1747 gcc_assert (codimen + dimen >= 0 && codimen + dimen <= GFC_MAX_DIMENSIONS); 1748 1749 if (flag_coarray == GFC_FCOARRAY_LIB && codimen) 1750 { 1751 if (gfc_array_descriptor_base_caf[idx]) 1752 return gfc_array_descriptor_base_caf[idx]; 1753 } 1754 else if (gfc_array_descriptor_base[idx]) 1755 return gfc_array_descriptor_base[idx]; 1756 1757 /* Build the type node. */ 1758 fat_type = make_node (RECORD_TYPE); 1759 1760 sprintf (name, "array_descriptor" GFC_RANK_PRINTF_FORMAT, dimen + codimen); 1761 TYPE_NAME (fat_type) = get_identifier (name); 1762 TYPE_NAMELESS (fat_type) = 1; 1763 1764 /* Add the data member as the first element of the descriptor. */ 1765 decl = gfc_add_field_to_struct_1 (fat_type, 1766 get_identifier ("data"), 1767 (restricted 1768 ? prvoid_type_node 1769 : ptr_type_node), &chain); 1770 1771 /* Add the base component. */ 1772 decl = gfc_add_field_to_struct_1 (fat_type, 1773 get_identifier ("offset"), 1774 gfc_array_index_type, &chain); 1775 TREE_NO_WARNING (decl) = 1; 1776 1777 /* Add the dtype component. */ 1778 decl = gfc_add_field_to_struct_1 (fat_type, 1779 get_identifier ("dtype"), 1780 gfc_array_index_type, &chain); 1781 TREE_NO_WARNING (decl) = 1; 1782 1783 /* Build the array type for the stride and bound components. */ 1784 if (dimen + codimen > 0) 1785 { 1786 arraytype = 1787 build_array_type (gfc_get_desc_dim_type (), 1788 build_range_type (gfc_array_index_type, 1789 gfc_index_zero_node, 1790 gfc_rank_cst[codimen + dimen - 1])); 1791 1792 decl = gfc_add_field_to_struct_1 (fat_type, get_identifier ("dim"), 1793 arraytype, &chain); 1794 TREE_NO_WARNING (decl) = 1; 1795 } 1796 1797 if (flag_coarray == GFC_FCOARRAY_LIB && codimen 1798 && akind == GFC_ARRAY_ALLOCATABLE) 1799 { 1800 decl = gfc_add_field_to_struct_1 (fat_type, 1801 get_identifier ("token"), 1802 prvoid_type_node, &chain); 1803 TREE_NO_WARNING (decl) = 1; 1804 } 1805 1806 /* Finish off the type. */ 1807 gfc_finish_type (fat_type); 1808 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (fat_type)) = 1; 1809 1810 if (flag_coarray == GFC_FCOARRAY_LIB && codimen 1811 && akind == GFC_ARRAY_ALLOCATABLE) 1812 gfc_array_descriptor_base_caf[idx] = fat_type; 1813 else 1814 gfc_array_descriptor_base[idx] = fat_type; 1815 1816 return fat_type; 1817} 1818 1819 1820/* Build an array (descriptor) type with given bounds. */ 1821 1822tree 1823gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound, 1824 tree * ubound, int packed, 1825 enum gfc_array_kind akind, bool restricted) 1826{ 1827 char name[8 + 2*GFC_RANK_DIGITS + 1 + GFC_MAX_SYMBOL_LEN]; 1828 tree fat_type, base_type, arraytype, lower, upper, stride, tmp, rtype; 1829 const char *type_name; 1830 int n; 1831 1832 base_type = gfc_get_array_descriptor_base (dimen, codimen, restricted, akind); 1833 fat_type = build_distinct_type_copy (base_type); 1834 /* Make sure that nontarget and target array type have the same canonical 1835 type (and same stub decl for debug info). */ 1836 base_type = gfc_get_array_descriptor_base (dimen, codimen, false, akind); 1837 TYPE_CANONICAL (fat_type) = base_type; 1838 TYPE_STUB_DECL (fat_type) = TYPE_STUB_DECL (base_type); 1839 1840 tmp = TYPE_NAME (etype); 1841 if (tmp && TREE_CODE (tmp) == TYPE_DECL) 1842 tmp = DECL_NAME (tmp); 1843 if (tmp) 1844 type_name = IDENTIFIER_POINTER (tmp); 1845 else 1846 type_name = "unknown"; 1847 sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen + codimen, 1848 GFC_MAX_SYMBOL_LEN, type_name); 1849 TYPE_NAME (fat_type) = get_identifier (name); 1850 TYPE_NAMELESS (fat_type) = 1; 1851 1852 GFC_DESCRIPTOR_TYPE_P (fat_type) = 1; 1853 TYPE_LANG_SPECIFIC (fat_type) = ggc_cleared_alloc<struct lang_type> (); 1854 1855 GFC_TYPE_ARRAY_RANK (fat_type) = dimen; 1856 GFC_TYPE_ARRAY_CORANK (fat_type) = codimen; 1857 GFC_TYPE_ARRAY_DTYPE (fat_type) = NULL_TREE; 1858 GFC_TYPE_ARRAY_AKIND (fat_type) = akind; 1859 1860 /* Build an array descriptor record type. */ 1861 if (packed != 0) 1862 stride = gfc_index_one_node; 1863 else 1864 stride = NULL_TREE; 1865 for (n = 0; n < dimen + codimen; n++) 1866 { 1867 if (n < dimen) 1868 GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride; 1869 1870 if (lbound) 1871 lower = lbound[n]; 1872 else 1873 lower = NULL_TREE; 1874 1875 if (lower != NULL_TREE) 1876 { 1877 if (INTEGER_CST_P (lower)) 1878 GFC_TYPE_ARRAY_LBOUND (fat_type, n) = lower; 1879 else 1880 lower = NULL_TREE; 1881 } 1882 1883 if (codimen && n == dimen + codimen - 1) 1884 break; 1885 1886 upper = ubound[n]; 1887 if (upper != NULL_TREE) 1888 { 1889 if (INTEGER_CST_P (upper)) 1890 GFC_TYPE_ARRAY_UBOUND (fat_type, n) = upper; 1891 else 1892 upper = NULL_TREE; 1893 } 1894 1895 if (n >= dimen) 1896 continue; 1897 1898 if (upper != NULL_TREE && lower != NULL_TREE && stride != NULL_TREE) 1899 { 1900 tmp = fold_build2_loc (input_location, MINUS_EXPR, 1901 gfc_array_index_type, upper, lower); 1902 tmp = fold_build2_loc (input_location, PLUS_EXPR, 1903 gfc_array_index_type, tmp, 1904 gfc_index_one_node); 1905 stride = fold_build2_loc (input_location, MULT_EXPR, 1906 gfc_array_index_type, tmp, stride); 1907 /* Check the folding worked. */ 1908 gcc_assert (INTEGER_CST_P (stride)); 1909 } 1910 else 1911 stride = NULL_TREE; 1912 } 1913 GFC_TYPE_ARRAY_SIZE (fat_type) = stride; 1914 1915 /* TODO: known offsets for descriptors. */ 1916 GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE; 1917 1918 if (dimen == 0) 1919 { 1920 arraytype = build_pointer_type (etype); 1921 if (restricted) 1922 arraytype = build_qualified_type (arraytype, TYPE_QUAL_RESTRICT); 1923 1924 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype; 1925 return fat_type; 1926 } 1927 1928 /* We define data as an array with the correct size if possible. 1929 Much better than doing pointer arithmetic. */ 1930 if (stride) 1931 rtype = build_range_type (gfc_array_index_type, gfc_index_zero_node, 1932 int_const_binop (MINUS_EXPR, stride, 1933 build_int_cst (TREE_TYPE (stride), 1))); 1934 else 1935 rtype = gfc_array_range_type; 1936 arraytype = build_array_type (etype, rtype); 1937 arraytype = build_pointer_type (arraytype); 1938 if (restricted) 1939 arraytype = build_qualified_type (arraytype, TYPE_QUAL_RESTRICT); 1940 GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype; 1941 1942 /* This will generate the base declarations we need to emit debug 1943 information for this type. FIXME: there must be a better way to 1944 avoid divergence between compilations with and without debug 1945 information. */ 1946 { 1947 struct array_descr_info info; 1948 gfc_get_array_descr_info (fat_type, &info); 1949 gfc_get_array_descr_info (build_pointer_type (fat_type), &info); 1950 } 1951 1952 return fat_type; 1953} 1954 1955/* Build a pointer type. This function is called from gfc_sym_type(). */ 1956 1957static tree 1958gfc_build_pointer_type (gfc_symbol * sym, tree type) 1959{ 1960 /* Array pointer types aren't actually pointers. */ 1961 if (sym->attr.dimension) 1962 return type; 1963 else 1964 return build_pointer_type (type); 1965} 1966 1967static tree gfc_nonrestricted_type (tree t); 1968/* Given two record or union type nodes TO and FROM, ensure 1969 that all fields in FROM have a corresponding field in TO, 1970 their type being nonrestrict variants. This accepts a TO 1971 node that already has a prefix of the fields in FROM. */ 1972static void 1973mirror_fields (tree to, tree from) 1974{ 1975 tree fto, ffrom; 1976 tree *chain; 1977 1978 /* Forward to the end of TOs fields. */ 1979 fto = TYPE_FIELDS (to); 1980 ffrom = TYPE_FIELDS (from); 1981 chain = &TYPE_FIELDS (to); 1982 while (fto) 1983 { 1984 gcc_assert (ffrom && DECL_NAME (fto) == DECL_NAME (ffrom)); 1985 chain = &DECL_CHAIN (fto); 1986 fto = DECL_CHAIN (fto); 1987 ffrom = DECL_CHAIN (ffrom); 1988 } 1989 1990 /* Now add all fields remaining in FROM (starting with ffrom). */ 1991 for (; ffrom; ffrom = DECL_CHAIN (ffrom)) 1992 { 1993 tree newfield = copy_node (ffrom); 1994 DECL_CONTEXT (newfield) = to; 1995 /* The store to DECL_CHAIN might seem redundant with the 1996 stores to *chain, but not clearing it here would mean 1997 leaving a chain into the old fields. If ever 1998 our called functions would look at them confusion 1999 will arise. */ 2000 DECL_CHAIN (newfield) = NULL_TREE; 2001 *chain = newfield; 2002 chain = &DECL_CHAIN (newfield); 2003 2004 if (TREE_CODE (ffrom) == FIELD_DECL) 2005 { 2006 tree elemtype = gfc_nonrestricted_type (TREE_TYPE (ffrom)); 2007 TREE_TYPE (newfield) = elemtype; 2008 } 2009 } 2010 *chain = NULL_TREE; 2011} 2012 2013/* Given a type T, returns a different type of the same structure, 2014 except that all types it refers to (recursively) are always 2015 non-restrict qualified types. */ 2016static tree 2017gfc_nonrestricted_type (tree t) 2018{ 2019 tree ret = t; 2020 2021 /* If the type isn't laid out yet, don't copy it. If something 2022 needs it for real it should wait until the type got finished. */ 2023 if (!TYPE_SIZE (t)) 2024 return t; 2025 2026 if (!TYPE_LANG_SPECIFIC (t)) 2027 TYPE_LANG_SPECIFIC (t) = ggc_cleared_alloc<struct lang_type> (); 2028 /* If we're dealing with this very node already further up 2029 the call chain (recursion via pointers and struct members) 2030 we haven't yet determined if we really need a new type node. 2031 Assume we don't, return T itself. */ 2032 if (TYPE_LANG_SPECIFIC (t)->nonrestricted_type == error_mark_node) 2033 return t; 2034 2035 /* If we have calculated this all already, just return it. */ 2036 if (TYPE_LANG_SPECIFIC (t)->nonrestricted_type) 2037 return TYPE_LANG_SPECIFIC (t)->nonrestricted_type; 2038 2039 /* Mark this type. */ 2040 TYPE_LANG_SPECIFIC (t)->nonrestricted_type = error_mark_node; 2041 2042 switch (TREE_CODE (t)) 2043 { 2044 default: 2045 break; 2046 2047 case POINTER_TYPE: 2048 case REFERENCE_TYPE: 2049 { 2050 tree totype = gfc_nonrestricted_type (TREE_TYPE (t)); 2051 if (totype == TREE_TYPE (t)) 2052 ret = t; 2053 else if (TREE_CODE (t) == POINTER_TYPE) 2054 ret = build_pointer_type (totype); 2055 else 2056 ret = build_reference_type (totype); 2057 ret = build_qualified_type (ret, 2058 TYPE_QUALS (t) & ~TYPE_QUAL_RESTRICT); 2059 } 2060 break; 2061 2062 case ARRAY_TYPE: 2063 { 2064 tree elemtype = gfc_nonrestricted_type (TREE_TYPE (t)); 2065 if (elemtype == TREE_TYPE (t)) 2066 ret = t; 2067 else 2068 { 2069 ret = build_variant_type_copy (t); 2070 TREE_TYPE (ret) = elemtype; 2071 if (TYPE_LANG_SPECIFIC (t) 2072 && GFC_TYPE_ARRAY_DATAPTR_TYPE (t)) 2073 { 2074 tree dataptr_type = GFC_TYPE_ARRAY_DATAPTR_TYPE (t); 2075 dataptr_type = gfc_nonrestricted_type (dataptr_type); 2076 if (dataptr_type != GFC_TYPE_ARRAY_DATAPTR_TYPE (t)) 2077 { 2078 TYPE_LANG_SPECIFIC (ret) 2079 = ggc_cleared_alloc<struct lang_type> (); 2080 *TYPE_LANG_SPECIFIC (ret) = *TYPE_LANG_SPECIFIC (t); 2081 GFC_TYPE_ARRAY_DATAPTR_TYPE (ret) = dataptr_type; 2082 } 2083 } 2084 } 2085 } 2086 break; 2087 2088 case RECORD_TYPE: 2089 case UNION_TYPE: 2090 case QUAL_UNION_TYPE: 2091 { 2092 tree field; 2093 /* First determine if we need a new type at all. 2094 Careful, the two calls to gfc_nonrestricted_type per field 2095 might return different values. That happens exactly when 2096 one of the fields reaches back to this very record type 2097 (via pointers). The first calls will assume that we don't 2098 need to copy T (see the error_mark_node marking). If there 2099 are any reasons for copying T apart from having to copy T, 2100 we'll indeed copy it, and the second calls to 2101 gfc_nonrestricted_type will use that new node if they 2102 reach back to T. */ 2103 for (field = TYPE_FIELDS (t); field; field = DECL_CHAIN (field)) 2104 if (TREE_CODE (field) == FIELD_DECL) 2105 { 2106 tree elemtype = gfc_nonrestricted_type (TREE_TYPE (field)); 2107 if (elemtype != TREE_TYPE (field)) 2108 break; 2109 } 2110 if (!field) 2111 break; 2112 ret = build_variant_type_copy (t); 2113 TYPE_FIELDS (ret) = NULL_TREE; 2114 2115 /* Here we make sure that as soon as we know we have to copy 2116 T, that also fields reaching back to us will use the new 2117 copy. It's okay if that copy still contains the old fields, 2118 we won't look at them. */ 2119 TYPE_LANG_SPECIFIC (t)->nonrestricted_type = ret; 2120 mirror_fields (ret, t); 2121 } 2122 break; 2123 } 2124 2125 TYPE_LANG_SPECIFIC (t)->nonrestricted_type = ret; 2126 return ret; 2127} 2128 2129 2130/* Return the type for a symbol. Special handling is required for character 2131 types to get the correct level of indirection. 2132 For functions return the return type. 2133 For subroutines return void_type_node. 2134 Calling this multiple times for the same symbol should be avoided, 2135 especially for character and array types. */ 2136 2137tree 2138gfc_sym_type (gfc_symbol * sym) 2139{ 2140 tree type; 2141 int byref; 2142 bool restricted; 2143 2144 /* Procedure Pointers inside COMMON blocks. */ 2145 if (sym->attr.proc_pointer && sym->attr.in_common) 2146 { 2147 /* Unset proc_pointer as gfc_get_function_type calls gfc_sym_type. */ 2148 sym->attr.proc_pointer = 0; 2149 type = build_pointer_type (gfc_get_function_type (sym)); 2150 sym->attr.proc_pointer = 1; 2151 return type; 2152 } 2153 2154 if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function) 2155 return void_type_node; 2156 2157 /* In the case of a function the fake result variable may have a 2158 type different from the function type, so don't return early in 2159 that case. */ 2160 if (sym->backend_decl && !sym->attr.function) 2161 return TREE_TYPE (sym->backend_decl); 2162 2163 if (sym->ts.type == BT_CHARACTER 2164 && ((sym->attr.function && sym->attr.is_bind_c) 2165 || (sym->attr.result 2166 && sym->ns->proc_name 2167 && sym->ns->proc_name->attr.is_bind_c) 2168 || (sym->ts.deferred && (!sym->ts.u.cl 2169 || !sym->ts.u.cl->backend_decl)))) 2170 type = gfc_character1_type_node; 2171 else 2172 type = gfc_typenode_for_spec (&sym->ts); 2173 2174 if (sym->attr.dummy && !sym->attr.function && !sym->attr.value) 2175 byref = 1; 2176 else 2177 byref = 0; 2178 2179 restricted = !sym->attr.target && !sym->attr.pointer 2180 && !sym->attr.proc_pointer && !sym->attr.cray_pointee; 2181 if (!restricted) 2182 type = gfc_nonrestricted_type (type); 2183 2184 if (sym->attr.dimension || sym->attr.codimension) 2185 { 2186 if (gfc_is_nodesc_array (sym)) 2187 { 2188 /* If this is a character argument of unknown length, just use the 2189 base type. */ 2190 if (sym->ts.type != BT_CHARACTER 2191 || !(sym->attr.dummy || sym->attr.function) 2192 || sym->ts.u.cl->backend_decl) 2193 { 2194 type = gfc_get_nodesc_array_type (type, sym->as, 2195 byref ? PACKED_FULL 2196 : PACKED_STATIC, 2197 restricted); 2198 byref = 0; 2199 } 2200 } 2201 else 2202 { 2203 enum gfc_array_kind akind = GFC_ARRAY_UNKNOWN; 2204 if (sym->attr.pointer) 2205 akind = sym->attr.contiguous ? GFC_ARRAY_POINTER_CONT 2206 : GFC_ARRAY_POINTER; 2207 else if (sym->attr.allocatable) 2208 akind = GFC_ARRAY_ALLOCATABLE; 2209 type = gfc_build_array_type (type, sym->as, akind, restricted, 2210 sym->attr.contiguous); 2211 } 2212 } 2213 else 2214 { 2215 if (sym->attr.allocatable || sym->attr.pointer 2216 || gfc_is_associate_pointer (sym)) 2217 type = gfc_build_pointer_type (sym, type); 2218 } 2219 2220 /* We currently pass all parameters by reference. 2221 See f95_get_function_decl. For dummy function parameters return the 2222 function type. */ 2223 if (byref) 2224 { 2225 /* We must use pointer types for potentially absent variables. The 2226 optimizers assume a reference type argument is never NULL. */ 2227 if (sym->attr.optional 2228 || (sym->ns->proc_name && sym->ns->proc_name->attr.entry_master)) 2229 type = build_pointer_type (type); 2230 else 2231 { 2232 type = build_reference_type (type); 2233 if (restricted) 2234 type = build_qualified_type (type, TYPE_QUAL_RESTRICT); 2235 } 2236 } 2237 2238 return (type); 2239} 2240 2241/* Layout and output debug info for a record type. */ 2242 2243void 2244gfc_finish_type (tree type) 2245{ 2246 tree decl; 2247 2248 decl = build_decl (input_location, 2249 TYPE_DECL, NULL_TREE, type); 2250 TYPE_STUB_DECL (type) = decl; 2251 layout_type (type); 2252 rest_of_type_compilation (type, 1); 2253 rest_of_decl_compilation (decl, 1, 0); 2254} 2255 2256/* Add a field of given NAME and TYPE to the context of a UNION_TYPE 2257 or RECORD_TYPE pointed to by CONTEXT. The new field is chained 2258 to the end of the field list pointed to by *CHAIN. 2259 2260 Returns a pointer to the new field. */ 2261 2262static tree 2263gfc_add_field_to_struct_1 (tree context, tree name, tree type, tree **chain) 2264{ 2265 tree decl = build_decl (input_location, FIELD_DECL, name, type); 2266 2267 DECL_CONTEXT (decl) = context; 2268 DECL_CHAIN (decl) = NULL_TREE; 2269 if (TYPE_FIELDS (context) == NULL_TREE) 2270 TYPE_FIELDS (context) = decl; 2271 if (chain != NULL) 2272 { 2273 if (*chain != NULL) 2274 **chain = decl; 2275 *chain = &DECL_CHAIN (decl); 2276 } 2277 2278 return decl; 2279} 2280 2281/* Like `gfc_add_field_to_struct_1', but adds alignment 2282 information. */ 2283 2284tree 2285gfc_add_field_to_struct (tree context, tree name, tree type, tree **chain) 2286{ 2287 tree decl = gfc_add_field_to_struct_1 (context, name, type, chain); 2288 2289 DECL_INITIAL (decl) = 0; 2290 DECL_ALIGN (decl) = 0; 2291 DECL_USER_ALIGN (decl) = 0; 2292 2293 return decl; 2294} 2295 2296 2297/* Copy the backend_decl and component backend_decls if 2298 the two derived type symbols are "equal", as described 2299 in 4.4.2 and resolved by gfc_compare_derived_types. */ 2300 2301int 2302gfc_copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to, 2303 bool from_gsym) 2304{ 2305 gfc_component *to_cm; 2306 gfc_component *from_cm; 2307 2308 if (from == to) 2309 return 1; 2310 2311 if (from->backend_decl == NULL 2312 || !gfc_compare_derived_types (from, to)) 2313 return 0; 2314 2315 to->backend_decl = from->backend_decl; 2316 2317 to_cm = to->components; 2318 from_cm = from->components; 2319 2320 /* Copy the component declarations. If a component is itself 2321 a derived type, we need a copy of its component declarations. 2322 This is done by recursing into gfc_get_derived_type and 2323 ensures that the component's component declarations have 2324 been built. If it is a character, we need the character 2325 length, as well. */ 2326 for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next) 2327 { 2328 to_cm->backend_decl = from_cm->backend_decl; 2329 if (from_cm->ts.type == BT_DERIVED 2330 && (!from_cm->attr.pointer || from_gsym)) 2331 gfc_get_derived_type (to_cm->ts.u.derived); 2332 else if (from_cm->ts.type == BT_CLASS 2333 && (!CLASS_DATA (from_cm)->attr.class_pointer || from_gsym)) 2334 gfc_get_derived_type (to_cm->ts.u.derived); 2335 else if (from_cm->ts.type == BT_CHARACTER) 2336 to_cm->ts.u.cl->backend_decl = from_cm->ts.u.cl->backend_decl; 2337 } 2338 2339 return 1; 2340} 2341 2342 2343/* Build a tree node for a procedure pointer component. */ 2344 2345tree 2346gfc_get_ppc_type (gfc_component* c) 2347{ 2348 tree t; 2349 2350 /* Explicit interface. */ 2351 if (c->attr.if_source != IFSRC_UNKNOWN && c->ts.interface) 2352 return build_pointer_type (gfc_get_function_type (c->ts.interface)); 2353 2354 /* Implicit interface (only return value may be known). */ 2355 if (c->attr.function && !c->attr.dimension && c->ts.type != BT_CHARACTER) 2356 t = gfc_typenode_for_spec (&c->ts); 2357 else 2358 t = void_type_node; 2359 2360 return build_pointer_type (build_function_type_list (t, NULL_TREE)); 2361} 2362 2363 2364/* Build a tree node for a derived type. If there are equal 2365 derived types, with different local names, these are built 2366 at the same time. If an equal derived type has been built 2367 in a parent namespace, this is used. */ 2368 2369tree 2370gfc_get_derived_type (gfc_symbol * derived) 2371{ 2372 tree typenode = NULL, field = NULL, field_type = NULL; 2373 tree canonical = NULL_TREE; 2374 tree *chain = NULL; 2375 bool got_canonical = false; 2376 bool unlimited_entity = false; 2377 gfc_component *c; 2378 gfc_dt_list *dt; 2379 gfc_namespace *ns; 2380 tree tmp; 2381 2382 if (derived->attr.unlimited_polymorphic 2383 || (flag_coarray == GFC_FCOARRAY_LIB 2384 && derived->from_intmod == INTMOD_ISO_FORTRAN_ENV 2385 && (derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE 2386 || derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE))) 2387 return ptr_type_node; 2388 2389 if (flag_coarray != GFC_FCOARRAY_LIB 2390 && derived->from_intmod == INTMOD_ISO_FORTRAN_ENV 2391 && derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE) 2392 return gfc_get_int_type (gfc_default_integer_kind); 2393 2394 if (derived && derived->attr.flavor == FL_PROCEDURE 2395 && derived->attr.generic) 2396 derived = gfc_find_dt_in_generic (derived); 2397 2398 /* See if it's one of the iso_c_binding derived types. */ 2399 if (derived->attr.is_iso_c == 1 || derived->ts.f90_type == BT_VOID) 2400 { 2401 if (derived->backend_decl) 2402 return derived->backend_decl; 2403 2404 if (derived->intmod_sym_id == ISOCBINDING_PTR) 2405 derived->backend_decl = ptr_type_node; 2406 else 2407 derived->backend_decl = pfunc_type_node; 2408 2409 derived->ts.kind = gfc_index_integer_kind; 2410 derived->ts.type = BT_INTEGER; 2411 /* Set the f90_type to BT_VOID as a way to recognize something of type 2412 BT_INTEGER that needs to fit a void * for the purpose of the 2413 iso_c_binding derived types. */ 2414 derived->ts.f90_type = BT_VOID; 2415 2416 return derived->backend_decl; 2417 } 2418 2419 /* If use associated, use the module type for this one. */ 2420 if (derived->backend_decl == NULL 2421 && derived->attr.use_assoc 2422 && derived->module 2423 && gfc_get_module_backend_decl (derived)) 2424 goto copy_derived_types; 2425 2426 /* The derived types from an earlier namespace can be used as the 2427 canonical type. */ 2428 if (derived->backend_decl == NULL && !derived->attr.use_assoc 2429 && gfc_global_ns_list) 2430 { 2431 for (ns = gfc_global_ns_list; 2432 ns->translated && !got_canonical; 2433 ns = ns->sibling) 2434 { 2435 dt = ns->derived_types; 2436 for (; dt && !canonical; dt = dt->next) 2437 { 2438 gfc_copy_dt_decls_ifequal (dt->derived, derived, true); 2439 if (derived->backend_decl) 2440 got_canonical = true; 2441 } 2442 } 2443 } 2444 2445 /* Store up the canonical type to be added to this one. */ 2446 if (got_canonical) 2447 { 2448 if (TYPE_CANONICAL (derived->backend_decl)) 2449 canonical = TYPE_CANONICAL (derived->backend_decl); 2450 else 2451 canonical = derived->backend_decl; 2452 2453 derived->backend_decl = NULL_TREE; 2454 } 2455 2456 /* derived->backend_decl != 0 means we saw it before, but its 2457 components' backend_decl may have not been built. */ 2458 if (derived->backend_decl) 2459 { 2460 /* Its components' backend_decl have been built or we are 2461 seeing recursion through the formal arglist of a procedure 2462 pointer component. */ 2463 if (TYPE_FIELDS (derived->backend_decl)) 2464 return derived->backend_decl; 2465 else if (derived->attr.abstract 2466 && derived->attr.proc_pointer_comp) 2467 { 2468 /* If an abstract derived type with procedure pointer 2469 components has no other type of component, return the 2470 backend_decl. Otherwise build the components if any of the 2471 non-procedure pointer components have no backend_decl. */ 2472 for (c = derived->components; c; c = c->next) 2473 { 2474 if (!c->attr.proc_pointer && c->backend_decl == NULL) 2475 break; 2476 else if (c->next == NULL) 2477 return derived->backend_decl; 2478 } 2479 typenode = derived->backend_decl; 2480 } 2481 else 2482 typenode = derived->backend_decl; 2483 } 2484 else 2485 { 2486 /* We see this derived type first time, so build the type node. */ 2487 typenode = make_node (RECORD_TYPE); 2488 TYPE_NAME (typenode) = get_identifier (derived->name); 2489 TYPE_PACKED (typenode) = flag_pack_derived; 2490 derived->backend_decl = typenode; 2491 } 2492 2493 if (derived->components 2494 && derived->components->ts.type == BT_DERIVED 2495 && strcmp (derived->components->name, "_data") == 0 2496 && derived->components->ts.u.derived->attr.unlimited_polymorphic) 2497 unlimited_entity = true; 2498 2499 /* Go through the derived type components, building them as 2500 necessary. The reason for doing this now is that it is 2501 possible to recurse back to this derived type through a 2502 pointer component (PR24092). If this happens, the fields 2503 will be built and so we can return the type. */ 2504 for (c = derived->components; c; c = c->next) 2505 { 2506 if (c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS) 2507 continue; 2508 2509 if ((!c->attr.pointer && !c->attr.proc_pointer) 2510 || c->ts.u.derived->backend_decl == NULL) 2511 c->ts.u.derived->backend_decl = gfc_get_derived_type (c->ts.u.derived); 2512 2513 if (c->ts.u.derived->attr.is_iso_c) 2514 { 2515 /* Need to copy the modified ts from the derived type. The 2516 typespec was modified because C_PTR/C_FUNPTR are translated 2517 into (void *) from derived types. */ 2518 c->ts.type = c->ts.u.derived->ts.type; 2519 c->ts.kind = c->ts.u.derived->ts.kind; 2520 c->ts.f90_type = c->ts.u.derived->ts.f90_type; 2521 if (c->initializer) 2522 { 2523 c->initializer->ts.type = c->ts.type; 2524 c->initializer->ts.kind = c->ts.kind; 2525 c->initializer->ts.f90_type = c->ts.f90_type; 2526 c->initializer->expr_type = EXPR_NULL; 2527 } 2528 } 2529 } 2530 2531 if (TYPE_FIELDS (derived->backend_decl)) 2532 return derived->backend_decl; 2533 2534 /* Build the type member list. Install the newly created RECORD_TYPE 2535 node as DECL_CONTEXT of each FIELD_DECL. */ 2536 for (c = derived->components; c; c = c->next) 2537 { 2538 /* Prevent infinite recursion, when the procedure pointer type is 2539 the same as derived, by forcing the procedure pointer component to 2540 be built as if the explicit interface does not exist. */ 2541 if (c->attr.proc_pointer 2542 && ((c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS) 2543 || (c->ts.u.derived 2544 && !gfc_compare_derived_types (derived, c->ts.u.derived)))) 2545 field_type = gfc_get_ppc_type (c); 2546 else if (c->attr.proc_pointer && derived->backend_decl) 2547 { 2548 tmp = build_function_type_list (derived->backend_decl, NULL_TREE); 2549 field_type = build_pointer_type (tmp); 2550 } 2551 else if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) 2552 field_type = c->ts.u.derived->backend_decl; 2553 else 2554 { 2555 if (c->ts.type == BT_CHARACTER && !c->ts.deferred) 2556 { 2557 /* Evaluate the string length. */ 2558 gfc_conv_const_charlen (c->ts.u.cl); 2559 gcc_assert (c->ts.u.cl->backend_decl); 2560 } 2561 else if (c->ts.type == BT_CHARACTER) 2562 c->ts.u.cl->backend_decl 2563 = build_int_cst (gfc_charlen_type_node, 0); 2564 2565 field_type = gfc_typenode_for_spec (&c->ts); 2566 } 2567 2568 /* This returns an array descriptor type. Initialization may be 2569 required. */ 2570 if ((c->attr.dimension || c->attr.codimension) && !c->attr.proc_pointer ) 2571 { 2572 if (c->attr.pointer || c->attr.allocatable) 2573 { 2574 enum gfc_array_kind akind; 2575 if (c->attr.pointer) 2576 akind = c->attr.contiguous ? GFC_ARRAY_POINTER_CONT 2577 : GFC_ARRAY_POINTER; 2578 else 2579 akind = GFC_ARRAY_ALLOCATABLE; 2580 /* Pointers to arrays aren't actually pointer types. The 2581 descriptors are separate, but the data is common. */ 2582 field_type = gfc_build_array_type (field_type, c->as, akind, 2583 !c->attr.target 2584 && !c->attr.pointer, 2585 c->attr.contiguous); 2586 } 2587 else 2588 field_type = gfc_get_nodesc_array_type (field_type, c->as, 2589 PACKED_STATIC, 2590 !c->attr.target); 2591 } 2592 else if ((c->attr.pointer || c->attr.allocatable) 2593 && !c->attr.proc_pointer 2594 && !(unlimited_entity && c == derived->components)) 2595 field_type = build_pointer_type (field_type); 2596 2597 if (c->attr.pointer) 2598 field_type = gfc_nonrestricted_type (field_type); 2599 2600 /* vtype fields can point to different types to the base type. */ 2601 if (c->ts.type == BT_DERIVED 2602 && c->ts.u.derived && c->ts.u.derived->attr.vtype) 2603 field_type = build_pointer_type_for_mode (TREE_TYPE (field_type), 2604 ptr_mode, true); 2605 2606 /* Ensure that the CLASS language specific flag is set. */ 2607 if (c->ts.type == BT_CLASS) 2608 { 2609 if (POINTER_TYPE_P (field_type)) 2610 GFC_CLASS_TYPE_P (TREE_TYPE (field_type)) = 1; 2611 else 2612 GFC_CLASS_TYPE_P (field_type) = 1; 2613 } 2614 2615 field = gfc_add_field_to_struct (typenode, 2616 get_identifier (c->name), 2617 field_type, &chain); 2618 if (c->loc.lb) 2619 gfc_set_decl_location (field, &c->loc); 2620 else if (derived->declared_at.lb) 2621 gfc_set_decl_location (field, &derived->declared_at); 2622 2623 gfc_finish_decl_attrs (field, &c->attr); 2624 2625 DECL_PACKED (field) |= TYPE_PACKED (typenode); 2626 2627 gcc_assert (field); 2628 if (!c->backend_decl) 2629 c->backend_decl = field; 2630 } 2631 2632 /* Now lay out the derived type, including the fields. */ 2633 if (canonical) 2634 TYPE_CANONICAL (typenode) = canonical; 2635 2636 gfc_finish_type (typenode); 2637 gfc_set_decl_location (TYPE_STUB_DECL (typenode), &derived->declared_at); 2638 if (derived->module && derived->ns->proc_name 2639 && derived->ns->proc_name->attr.flavor == FL_MODULE) 2640 { 2641 if (derived->ns->proc_name->backend_decl 2642 && TREE_CODE (derived->ns->proc_name->backend_decl) 2643 == NAMESPACE_DECL) 2644 { 2645 TYPE_CONTEXT (typenode) = derived->ns->proc_name->backend_decl; 2646 DECL_CONTEXT (TYPE_STUB_DECL (typenode)) 2647 = derived->ns->proc_name->backend_decl; 2648 } 2649 } 2650 2651 derived->backend_decl = typenode; 2652 2653copy_derived_types: 2654 2655 for (dt = gfc_derived_types; dt; dt = dt->next) 2656 gfc_copy_dt_decls_ifequal (derived, dt->derived, false); 2657 2658 return derived->backend_decl; 2659} 2660 2661 2662int 2663gfc_return_by_reference (gfc_symbol * sym) 2664{ 2665 if (!sym->attr.function) 2666 return 0; 2667 2668 if (sym->attr.dimension) 2669 return 1; 2670 2671 if (sym->ts.type == BT_CHARACTER 2672 && !sym->attr.is_bind_c 2673 && (!sym->attr.result 2674 || !sym->ns->proc_name 2675 || !sym->ns->proc_name->attr.is_bind_c)) 2676 return 1; 2677 2678 /* Possibly return complex numbers by reference for g77 compatibility. 2679 We don't do this for calls to intrinsics (as the library uses the 2680 -fno-f2c calling convention), nor for calls to functions which always 2681 require an explicit interface, as no compatibility problems can 2682 arise there. */ 2683 if (flag_f2c && sym->ts.type == BT_COMPLEX 2684 && !sym->attr.intrinsic && !sym->attr.always_explicit) 2685 return 1; 2686 2687 return 0; 2688} 2689 2690static tree 2691gfc_get_mixed_entry_union (gfc_namespace *ns) 2692{ 2693 tree type; 2694 tree *chain = NULL; 2695 char name[GFC_MAX_SYMBOL_LEN + 1]; 2696 gfc_entry_list *el, *el2; 2697 2698 gcc_assert (ns->proc_name->attr.mixed_entry_master); 2699 gcc_assert (memcmp (ns->proc_name->name, "master.", 7) == 0); 2700 2701 snprintf (name, GFC_MAX_SYMBOL_LEN, "munion.%s", ns->proc_name->name + 7); 2702 2703 /* Build the type node. */ 2704 type = make_node (UNION_TYPE); 2705 2706 TYPE_NAME (type) = get_identifier (name); 2707 2708 for (el = ns->entries; el; el = el->next) 2709 { 2710 /* Search for duplicates. */ 2711 for (el2 = ns->entries; el2 != el; el2 = el2->next) 2712 if (el2->sym->result == el->sym->result) 2713 break; 2714 2715 if (el == el2) 2716 gfc_add_field_to_struct_1 (type, 2717 get_identifier (el->sym->result->name), 2718 gfc_sym_type (el->sym->result), &chain); 2719 } 2720 2721 /* Finish off the type. */ 2722 gfc_finish_type (type); 2723 TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type)) = 1; 2724 return type; 2725} 2726 2727/* Create a "fn spec" based on the formal arguments; 2728 cf. create_function_arglist. */ 2729 2730static tree 2731create_fn_spec (gfc_symbol *sym, tree fntype) 2732{ 2733 char spec[150]; 2734 size_t spec_len; 2735 gfc_formal_arglist *f; 2736 tree tmp; 2737 2738 memset (&spec, 0, sizeof (spec)); 2739 spec[0] = '.'; 2740 spec_len = 1; 2741 2742 if (sym->attr.entry_master) 2743 spec[spec_len++] = 'R'; 2744 if (gfc_return_by_reference (sym)) 2745 { 2746 gfc_symbol *result = sym->result ? sym->result : sym; 2747 2748 if (result->attr.pointer || sym->attr.proc_pointer) 2749 spec[spec_len++] = '.'; 2750 else 2751 spec[spec_len++] = 'w'; 2752 if (sym->ts.type == BT_CHARACTER) 2753 spec[spec_len++] = 'R'; 2754 } 2755 2756 for (f = gfc_sym_get_dummy_args (sym); f; f = f->next) 2757 if (spec_len < sizeof (spec)) 2758 { 2759 if (!f->sym || f->sym->attr.pointer || f->sym->attr.target 2760 || f->sym->attr.external || f->sym->attr.cray_pointer 2761 || (f->sym->ts.type == BT_DERIVED 2762 && (f->sym->ts.u.derived->attr.proc_pointer_comp 2763 || f->sym->ts.u.derived->attr.pointer_comp)) 2764 || (f->sym->ts.type == BT_CLASS 2765 && (CLASS_DATA (f->sym)->ts.u.derived->attr.proc_pointer_comp 2766 || CLASS_DATA (f->sym)->ts.u.derived->attr.pointer_comp))) 2767 spec[spec_len++] = '.'; 2768 else if (f->sym->attr.intent == INTENT_IN) 2769 spec[spec_len++] = 'r'; 2770 else if (f->sym) 2771 spec[spec_len++] = 'w'; 2772 } 2773 2774 tmp = build_tree_list (NULL_TREE, build_string (spec_len, spec)); 2775 tmp = tree_cons (get_identifier ("fn spec"), tmp, TYPE_ATTRIBUTES (fntype)); 2776 return build_type_attribute_variant (fntype, tmp); 2777} 2778 2779 2780tree 2781gfc_get_function_type (gfc_symbol * sym) 2782{ 2783 tree type; 2784 vec<tree, va_gc> *typelist = NULL; 2785 gfc_formal_arglist *f; 2786 gfc_symbol *arg; 2787 int alternate_return = 0; 2788 bool is_varargs = true; 2789 2790 /* Make sure this symbol is a function, a subroutine or the main 2791 program. */ 2792 gcc_assert (sym->attr.flavor == FL_PROCEDURE 2793 || sym->attr.flavor == FL_PROGRAM); 2794 2795 /* To avoid recursing infinitely on recursive types, we use error_mark_node 2796 so that they can be detected here and handled further down. */ 2797 if (sym->backend_decl == NULL) 2798 sym->backend_decl = error_mark_node; 2799 else if (sym->backend_decl == error_mark_node) 2800 goto arg_type_list_done; 2801 else if (sym->attr.proc_pointer) 2802 return TREE_TYPE (TREE_TYPE (sym->backend_decl)); 2803 else 2804 return TREE_TYPE (sym->backend_decl); 2805 2806 if (sym->attr.entry_master) 2807 /* Additional parameter for selecting an entry point. */ 2808 vec_safe_push (typelist, gfc_array_index_type); 2809 2810 if (sym->result) 2811 arg = sym->result; 2812 else 2813 arg = sym; 2814 2815 if (arg->ts.type == BT_CHARACTER) 2816 gfc_conv_const_charlen (arg->ts.u.cl); 2817 2818 /* Some functions we use an extra parameter for the return value. */ 2819 if (gfc_return_by_reference (sym)) 2820 { 2821 type = gfc_sym_type (arg); 2822 if (arg->ts.type == BT_COMPLEX 2823 || arg->attr.dimension 2824 || arg->ts.type == BT_CHARACTER) 2825 type = build_reference_type (type); 2826 2827 vec_safe_push (typelist, type); 2828 if (arg->ts.type == BT_CHARACTER) 2829 { 2830 if (!arg->ts.deferred) 2831 /* Transfer by value. */ 2832 vec_safe_push (typelist, gfc_charlen_type_node); 2833 else 2834 /* Deferred character lengths are transferred by reference 2835 so that the value can be returned. */ 2836 vec_safe_push (typelist, build_pointer_type(gfc_charlen_type_node)); 2837 } 2838 } 2839 2840 /* Build the argument types for the function. */ 2841 for (f = gfc_sym_get_dummy_args (sym); f; f = f->next) 2842 { 2843 arg = f->sym; 2844 if (arg) 2845 { 2846 /* Evaluate constant character lengths here so that they can be 2847 included in the type. */ 2848 if (arg->ts.type == BT_CHARACTER) 2849 gfc_conv_const_charlen (arg->ts.u.cl); 2850 2851 if (arg->attr.flavor == FL_PROCEDURE) 2852 { 2853 type = gfc_get_function_type (arg); 2854 type = build_pointer_type (type); 2855 } 2856 else 2857 type = gfc_sym_type (arg); 2858 2859 /* Parameter Passing Convention 2860 2861 We currently pass all parameters by reference. 2862 Parameters with INTENT(IN) could be passed by value. 2863 The problem arises if a function is called via an implicit 2864 prototype. In this situation the INTENT is not known. 2865 For this reason all parameters to global functions must be 2866 passed by reference. Passing by value would potentially 2867 generate bad code. Worse there would be no way of telling that 2868 this code was bad, except that it would give incorrect results. 2869 2870 Contained procedures could pass by value as these are never 2871 used without an explicit interface, and cannot be passed as 2872 actual parameters for a dummy procedure. */ 2873 2874 vec_safe_push (typelist, type); 2875 } 2876 else 2877 { 2878 if (sym->attr.subroutine) 2879 alternate_return = 1; 2880 } 2881 } 2882 2883 /* Add hidden string length parameters. */ 2884 for (f = gfc_sym_get_dummy_args (sym); f; f = f->next) 2885 { 2886 arg = f->sym; 2887 if (arg && arg->ts.type == BT_CHARACTER && !sym->attr.is_bind_c) 2888 { 2889 if (!arg->ts.deferred) 2890 /* Transfer by value. */ 2891 type = gfc_charlen_type_node; 2892 else 2893 /* Deferred character lengths are transferred by reference 2894 so that the value can be returned. */ 2895 type = build_pointer_type (gfc_charlen_type_node); 2896 2897 vec_safe_push (typelist, type); 2898 } 2899 } 2900 2901 if (!vec_safe_is_empty (typelist) 2902 || sym->attr.is_main_program 2903 || sym->attr.if_source != IFSRC_UNKNOWN) 2904 is_varargs = false; 2905 2906 if (sym->backend_decl == error_mark_node) 2907 sym->backend_decl = NULL_TREE; 2908 2909arg_type_list_done: 2910 2911 if (alternate_return) 2912 type = integer_type_node; 2913 else if (!sym->attr.function || gfc_return_by_reference (sym)) 2914 type = void_type_node; 2915 else if (sym->attr.mixed_entry_master) 2916 type = gfc_get_mixed_entry_union (sym->ns); 2917 else if (flag_f2c && sym->ts.type == BT_REAL 2918 && sym->ts.kind == gfc_default_real_kind 2919 && !sym->attr.always_explicit) 2920 { 2921 /* Special case: f2c calling conventions require that (scalar) 2922 default REAL functions return the C type double instead. f2c 2923 compatibility is only an issue with functions that don't 2924 require an explicit interface, as only these could be 2925 implemented in Fortran 77. */ 2926 sym->ts.kind = gfc_default_double_kind; 2927 type = gfc_typenode_for_spec (&sym->ts); 2928 sym->ts.kind = gfc_default_real_kind; 2929 } 2930 else if (sym->result && sym->result->attr.proc_pointer) 2931 /* Procedure pointer return values. */ 2932 { 2933 if (sym->result->attr.result && strcmp (sym->name,"ppr@") != 0) 2934 { 2935 /* Unset proc_pointer as gfc_get_function_type 2936 is called recursively. */ 2937 sym->result->attr.proc_pointer = 0; 2938 type = build_pointer_type (gfc_get_function_type (sym->result)); 2939 sym->result->attr.proc_pointer = 1; 2940 } 2941 else 2942 type = gfc_sym_type (sym->result); 2943 } 2944 else 2945 type = gfc_sym_type (sym); 2946 2947 if (is_varargs) 2948 type = build_varargs_function_type_vec (type, typelist); 2949 else 2950 type = build_function_type_vec (type, typelist); 2951 type = create_fn_spec (sym, type); 2952 2953 return type; 2954} 2955 2956/* Language hooks for middle-end access to type nodes. */ 2957 2958/* Return an integer type with BITS bits of precision, 2959 that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */ 2960 2961tree 2962gfc_type_for_size (unsigned bits, int unsignedp) 2963{ 2964 if (!unsignedp) 2965 { 2966 int i; 2967 for (i = 0; i <= MAX_INT_KINDS; ++i) 2968 { 2969 tree type = gfc_integer_types[i]; 2970 if (type && bits == TYPE_PRECISION (type)) 2971 return type; 2972 } 2973 2974 /* Handle TImode as a special case because it is used by some backends 2975 (e.g. ARM) even though it is not available for normal use. */ 2976#if HOST_BITS_PER_WIDE_INT >= 64 2977 if (bits == TYPE_PRECISION (intTI_type_node)) 2978 return intTI_type_node; 2979#endif 2980 2981 if (bits <= TYPE_PRECISION (intQI_type_node)) 2982 return intQI_type_node; 2983 if (bits <= TYPE_PRECISION (intHI_type_node)) 2984 return intHI_type_node; 2985 if (bits <= TYPE_PRECISION (intSI_type_node)) 2986 return intSI_type_node; 2987 if (bits <= TYPE_PRECISION (intDI_type_node)) 2988 return intDI_type_node; 2989 if (bits <= TYPE_PRECISION (intTI_type_node)) 2990 return intTI_type_node; 2991 } 2992 else 2993 { 2994 if (bits <= TYPE_PRECISION (unsigned_intQI_type_node)) 2995 return unsigned_intQI_type_node; 2996 if (bits <= TYPE_PRECISION (unsigned_intHI_type_node)) 2997 return unsigned_intHI_type_node; 2998 if (bits <= TYPE_PRECISION (unsigned_intSI_type_node)) 2999 return unsigned_intSI_type_node; 3000 if (bits <= TYPE_PRECISION (unsigned_intDI_type_node)) 3001 return unsigned_intDI_type_node; 3002 if (bits <= TYPE_PRECISION (unsigned_intTI_type_node)) 3003 return unsigned_intTI_type_node; 3004 } 3005 3006 return NULL_TREE; 3007} 3008 3009/* Return a data type that has machine mode MODE. If the mode is an 3010 integer, then UNSIGNEDP selects between signed and unsigned types. */ 3011 3012tree 3013gfc_type_for_mode (machine_mode mode, int unsignedp) 3014{ 3015 int i; 3016 tree *base; 3017 3018 if (GET_MODE_CLASS (mode) == MODE_FLOAT) 3019 base = gfc_real_types; 3020 else if (GET_MODE_CLASS (mode) == MODE_COMPLEX_FLOAT) 3021 base = gfc_complex_types; 3022 else if (SCALAR_INT_MODE_P (mode)) 3023 { 3024 tree type = gfc_type_for_size (GET_MODE_PRECISION (mode), unsignedp); 3025 return type != NULL_TREE && mode == TYPE_MODE (type) ? type : NULL_TREE; 3026 } 3027 else if (VECTOR_MODE_P (mode)) 3028 { 3029 machine_mode inner_mode = GET_MODE_INNER (mode); 3030 tree inner_type = gfc_type_for_mode (inner_mode, unsignedp); 3031 if (inner_type != NULL_TREE) 3032 return build_vector_type_for_mode (inner_type, mode); 3033 return NULL_TREE; 3034 } 3035 else 3036 return NULL_TREE; 3037 3038 for (i = 0; i <= MAX_REAL_KINDS; ++i) 3039 { 3040 tree type = base[i]; 3041 if (type && mode == TYPE_MODE (type)) 3042 return type; 3043 } 3044 3045 return NULL_TREE; 3046} 3047 3048/* Return TRUE if TYPE is a type with a hidden descriptor, fill in INFO 3049 in that case. */ 3050 3051bool 3052gfc_get_array_descr_info (const_tree type, struct array_descr_info *info) 3053{ 3054 int rank, dim; 3055 bool indirect = false; 3056 tree etype, ptype, field, t, base_decl; 3057 tree data_off, dim_off, dim_size, elem_size; 3058 tree lower_suboff, upper_suboff, stride_suboff; 3059 3060 if (! GFC_DESCRIPTOR_TYPE_P (type)) 3061 { 3062 if (! POINTER_TYPE_P (type)) 3063 return false; 3064 type = TREE_TYPE (type); 3065 if (! GFC_DESCRIPTOR_TYPE_P (type)) 3066 return false; 3067 indirect = true; 3068 } 3069 3070 rank = GFC_TYPE_ARRAY_RANK (type); 3071 if (rank >= (int) (sizeof (info->dimen) / sizeof (info->dimen[0]))) 3072 return false; 3073 3074 etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type); 3075 gcc_assert (POINTER_TYPE_P (etype)); 3076 etype = TREE_TYPE (etype); 3077 3078 /* If the type is not a scalar coarray. */ 3079 if (TREE_CODE (etype) == ARRAY_TYPE) 3080 etype = TREE_TYPE (etype); 3081 3082 /* Can't handle variable sized elements yet. */ 3083 if (int_size_in_bytes (etype) <= 0) 3084 return false; 3085 /* Nor non-constant lower bounds in assumed shape arrays. */ 3086 if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE 3087 || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT) 3088 { 3089 for (dim = 0; dim < rank; dim++) 3090 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE 3091 || TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type, dim)) != INTEGER_CST) 3092 return false; 3093 } 3094 3095 memset (info, '\0', sizeof (*info)); 3096 info->ndimensions = rank; 3097 info->ordering = array_descr_ordering_column_major; 3098 info->element_type = etype; 3099 ptype = build_pointer_type (gfc_array_index_type); 3100 base_decl = GFC_TYPE_ARRAY_BASE_DECL (type, indirect); 3101 if (!base_decl) 3102 { 3103 base_decl = make_node (DEBUG_EXPR_DECL); 3104 DECL_ARTIFICIAL (base_decl) = 1; 3105 TREE_TYPE (base_decl) = indirect ? build_pointer_type (ptype) : ptype; 3106 DECL_MODE (base_decl) = TYPE_MODE (TREE_TYPE (base_decl)); 3107 GFC_TYPE_ARRAY_BASE_DECL (type, indirect) = base_decl; 3108 } 3109 info->base_decl = base_decl; 3110 if (indirect) 3111 base_decl = build1 (INDIRECT_REF, ptype, base_decl); 3112 3113 if (GFC_TYPE_ARRAY_SPAN (type)) 3114 elem_size = GFC_TYPE_ARRAY_SPAN (type); 3115 else 3116 elem_size = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (etype)); 3117 field = TYPE_FIELDS (TYPE_MAIN_VARIANT (type)); 3118 data_off = byte_position (field); 3119 field = DECL_CHAIN (field); 3120 field = DECL_CHAIN (field); 3121 field = DECL_CHAIN (field); 3122 dim_off = byte_position (field); 3123 dim_size = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (field))); 3124 field = TYPE_FIELDS (TREE_TYPE (TREE_TYPE (field))); 3125 stride_suboff = byte_position (field); 3126 field = DECL_CHAIN (field); 3127 lower_suboff = byte_position (field); 3128 field = DECL_CHAIN (field); 3129 upper_suboff = byte_position (field); 3130 3131 t = base_decl; 3132 if (!integer_zerop (data_off)) 3133 t = fold_build_pointer_plus (t, data_off); 3134 t = build1 (NOP_EXPR, build_pointer_type (ptr_type_node), t); 3135 info->data_location = build1 (INDIRECT_REF, ptr_type_node, t); 3136 if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE) 3137 info->allocated = build2 (NE_EXPR, boolean_type_node, 3138 info->data_location, null_pointer_node); 3139 else if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER 3140 || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT) 3141 info->associated = build2 (NE_EXPR, boolean_type_node, 3142 info->data_location, null_pointer_node); 3143 3144 for (dim = 0; dim < rank; dim++) 3145 { 3146 t = fold_build_pointer_plus (base_decl, 3147 size_binop (PLUS_EXPR, 3148 dim_off, lower_suboff)); 3149 t = build1 (INDIRECT_REF, gfc_array_index_type, t); 3150 info->dimen[dim].lower_bound = t; 3151 t = fold_build_pointer_plus (base_decl, 3152 size_binop (PLUS_EXPR, 3153 dim_off, upper_suboff)); 3154 t = build1 (INDIRECT_REF, gfc_array_index_type, t); 3155 info->dimen[dim].upper_bound = t; 3156 if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE 3157 || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT) 3158 { 3159 /* Assumed shape arrays have known lower bounds. */ 3160 info->dimen[dim].upper_bound 3161 = build2 (MINUS_EXPR, gfc_array_index_type, 3162 info->dimen[dim].upper_bound, 3163 info->dimen[dim].lower_bound); 3164 info->dimen[dim].lower_bound 3165 = fold_convert (gfc_array_index_type, 3166 GFC_TYPE_ARRAY_LBOUND (type, dim)); 3167 info->dimen[dim].upper_bound 3168 = build2 (PLUS_EXPR, gfc_array_index_type, 3169 info->dimen[dim].lower_bound, 3170 info->dimen[dim].upper_bound); 3171 } 3172 t = fold_build_pointer_plus (base_decl, 3173 size_binop (PLUS_EXPR, 3174 dim_off, stride_suboff)); 3175 t = build1 (INDIRECT_REF, gfc_array_index_type, t); 3176 t = build2 (MULT_EXPR, gfc_array_index_type, t, elem_size); 3177 info->dimen[dim].stride = t; 3178 dim_off = size_binop (PLUS_EXPR, dim_off, dim_size); 3179 } 3180 3181 return true; 3182} 3183 3184 3185/* Create a type to handle vector subscripts for coarray library calls. It 3186 has the form: 3187 struct caf_vector_t { 3188 size_t nvec; // size of the vector 3189 union { 3190 struct { 3191 void *vector; 3192 int kind; 3193 } v; 3194 struct { 3195 ptrdiff_t lower_bound; 3196 ptrdiff_t upper_bound; 3197 ptrdiff_t stride; 3198 } triplet; 3199 } u; 3200 } 3201 where nvec == 0 for DIMEN_ELEMENT or DIMEN_RANGE and nvec being the vector 3202 size in case of DIMEN_VECTOR, where kind is the integer type of the vector. */ 3203 3204tree 3205gfc_get_caf_vector_type (int dim) 3206{ 3207 static tree vector_types[GFC_MAX_DIMENSIONS]; 3208 static tree vec_type = NULL_TREE; 3209 tree triplet_struct_type, vect_struct_type, union_type, tmp, *chain; 3210 3211 if (vector_types[dim-1] != NULL_TREE) 3212 return vector_types[dim-1]; 3213 3214 if (vec_type == NULL_TREE) 3215 { 3216 chain = 0; 3217 vect_struct_type = make_node (RECORD_TYPE); 3218 tmp = gfc_add_field_to_struct_1 (vect_struct_type, 3219 get_identifier ("vector"), 3220 pvoid_type_node, &chain); 3221 TREE_NO_WARNING (tmp) = 1; 3222 tmp = gfc_add_field_to_struct_1 (vect_struct_type, 3223 get_identifier ("kind"), 3224 integer_type_node, &chain); 3225 TREE_NO_WARNING (tmp) = 1; 3226 gfc_finish_type (vect_struct_type); 3227 3228 chain = 0; 3229 triplet_struct_type = make_node (RECORD_TYPE); 3230 tmp = gfc_add_field_to_struct_1 (triplet_struct_type, 3231 get_identifier ("lower_bound"), 3232 gfc_array_index_type, &chain); 3233 TREE_NO_WARNING (tmp) = 1; 3234 tmp = gfc_add_field_to_struct_1 (triplet_struct_type, 3235 get_identifier ("upper_bound"), 3236 gfc_array_index_type, &chain); 3237 TREE_NO_WARNING (tmp) = 1; 3238 tmp = gfc_add_field_to_struct_1 (triplet_struct_type, get_identifier ("stride"), 3239 gfc_array_index_type, &chain); 3240 TREE_NO_WARNING (tmp) = 1; 3241 gfc_finish_type (triplet_struct_type); 3242 3243 chain = 0; 3244 union_type = make_node (UNION_TYPE); 3245 tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("v"), 3246 vect_struct_type, &chain); 3247 TREE_NO_WARNING (tmp) = 1; 3248 tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("triplet"), 3249 triplet_struct_type, &chain); 3250 TREE_NO_WARNING (tmp) = 1; 3251 gfc_finish_type (union_type); 3252 3253 chain = 0; 3254 vec_type = make_node (RECORD_TYPE); 3255 tmp = gfc_add_field_to_struct_1 (vec_type, get_identifier ("nvec"), 3256 size_type_node, &chain); 3257 TREE_NO_WARNING (tmp) = 1; 3258 tmp = gfc_add_field_to_struct_1 (vec_type, get_identifier ("u"), 3259 union_type, &chain); 3260 TREE_NO_WARNING (tmp) = 1; 3261 gfc_finish_type (vec_type); 3262 TYPE_NAME (vec_type) = get_identifier ("caf_vector_t"); 3263 } 3264 3265 tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, 3266 gfc_rank_cst[dim-1]); 3267 vector_types[dim-1] = build_array_type (vec_type, tmp); 3268 return vector_types[dim-1]; 3269} 3270 3271#include "gt-fortran-trans-types.h" 3272