1/* Supporting functions for resolving DATA statement. 2 Copyright (C) 2002-2015 Free Software Foundation, Inc. 3 Contributed by Lifang Zeng <zlf605@hotmail.com> 4 5This file is part of GCC. 6 7GCC is free software; you can redistribute it and/or modify it under 8the terms of the GNU General Public License as published by the Free 9Software Foundation; either version 3, or (at your option) any later 10version. 11 12GCC is distributed in the hope that it will be useful, but WITHOUT ANY 13WARRANTY; without even the implied warranty of MERCHANTABILITY or 14FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 15for more details. 16 17You should have received a copy of the GNU General Public License 18along with GCC; see the file COPYING3. If not see 19<http://www.gnu.org/licenses/>. */ 20 21 22/* Notes for DATA statement implementation: 23 24 We first assign initial value to each symbol by gfc_assign_data_value 25 during resolving DATA statement. Refer to check_data_variable and 26 traverse_data_list in resolve.c. 27 28 The complexity exists in the handling of array section, implied do 29 and array of struct appeared in DATA statement. 30 31 We call gfc_conv_structure, gfc_con_array_array_initializer, 32 etc., to convert the initial value. Refer to trans-expr.c and 33 trans-array.c. */ 34 35#include "config.h" 36#include "system.h" 37#include "coretypes.h" 38#include "gfortran.h" 39#include "data.h" 40#include "constructor.h" 41 42static void formalize_init_expr (gfc_expr *); 43 44/* Calculate the array element offset. */ 45 46static void 47get_array_index (gfc_array_ref *ar, mpz_t *offset) 48{ 49 gfc_expr *e; 50 int i; 51 mpz_t delta; 52 mpz_t tmp; 53 54 mpz_init (tmp); 55 mpz_set_si (*offset, 0); 56 mpz_init_set_si (delta, 1); 57 for (i = 0; i < ar->dimen; i++) 58 { 59 e = gfc_copy_expr (ar->start[i]); 60 gfc_simplify_expr (e, 1); 61 62 if ((gfc_is_constant_expr (ar->as->lower[i]) == 0) 63 || (gfc_is_constant_expr (ar->as->upper[i]) == 0) 64 || (gfc_is_constant_expr (e) == 0)) 65 gfc_error ("non-constant array in DATA statement %L", &ar->where); 66 67 mpz_set (tmp, e->value.integer); 68 gfc_free_expr (e); 69 mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer); 70 mpz_mul (tmp, tmp, delta); 71 mpz_add (*offset, tmp, *offset); 72 73 mpz_sub (tmp, ar->as->upper[i]->value.integer, 74 ar->as->lower[i]->value.integer); 75 mpz_add_ui (tmp, tmp, 1); 76 mpz_mul (delta, tmp, delta); 77 } 78 mpz_clear (delta); 79 mpz_clear (tmp); 80} 81 82/* Find if there is a constructor which component is equal to COM. 83 TODO: remove this, use symbol.c(gfc_find_component) instead. */ 84 85static gfc_constructor * 86find_con_by_component (gfc_component *com, gfc_constructor_base base) 87{ 88 gfc_constructor *c; 89 90 for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) 91 if (com == c->n.component) 92 return c; 93 94 return NULL; 95} 96 97 98/* Create a character type initialization expression from RVALUE. 99 TS [and REF] describe [the substring of] the variable being initialized. 100 INIT is the existing initializer, not NULL. Initialization is performed 101 according to normal assignment rules. */ 102 103static gfc_expr * 104create_character_initializer (gfc_expr *init, gfc_typespec *ts, 105 gfc_ref *ref, gfc_expr *rvalue) 106{ 107 int len, start, end, tlen; 108 gfc_char_t *dest; 109 bool alloced_init = false; 110 111 gfc_extract_int (ts->u.cl->length, &len); 112 113 if (init == NULL) 114 { 115 /* Create a new initializer. */ 116 init = gfc_get_character_expr (ts->kind, NULL, NULL, len); 117 init->ts = *ts; 118 alloced_init = true; 119 } 120 121 dest = init->value.character.string; 122 123 if (ref) 124 { 125 gfc_expr *start_expr, *end_expr; 126 127 gcc_assert (ref->type == REF_SUBSTRING); 128 129 /* Only set a substring of the destination. Fortran substring bounds 130 are one-based [start, end], we want zero based [start, end). */ 131 start_expr = gfc_copy_expr (ref->u.ss.start); 132 end_expr = gfc_copy_expr (ref->u.ss.end); 133 134 if ((!gfc_simplify_expr(start_expr, 1)) 135 || !(gfc_simplify_expr(end_expr, 1))) 136 { 137 gfc_error ("failure to simplify substring reference in DATA " 138 "statement at %L", &ref->u.ss.start->where); 139 gfc_free_expr (start_expr); 140 gfc_free_expr (end_expr); 141 if (alloced_init) 142 gfc_free_expr (init); 143 return NULL; 144 } 145 146 gfc_extract_int (start_expr, &start); 147 gfc_free_expr (start_expr); 148 start--; 149 gfc_extract_int (end_expr, &end); 150 gfc_free_expr (end_expr); 151 } 152 else 153 { 154 /* Set the whole string. */ 155 start = 0; 156 end = len; 157 } 158 159 /* Copy the initial value. */ 160 if (rvalue->ts.type == BT_HOLLERITH) 161 len = rvalue->representation.length - rvalue->ts.u.pad; 162 else 163 len = rvalue->value.character.length; 164 165 tlen = end - start; 166 if (len > tlen) 167 { 168 if (tlen < 0) 169 { 170 gfc_warning_now (0, "Unused initialization string at %L because " 171 "variable has zero length", &rvalue->where); 172 len = 0; 173 } 174 else 175 { 176 gfc_warning_now (0, "Initialization string at %L was truncated to " 177 "fit the variable (%d/%d)", &rvalue->where, 178 tlen, len); 179 len = tlen; 180 } 181 } 182 183 if (rvalue->ts.type == BT_HOLLERITH) 184 { 185 int i; 186 for (i = 0; i < len; i++) 187 dest[start+i] = rvalue->representation.string[i]; 188 } 189 else 190 memcpy (&dest[start], rvalue->value.character.string, 191 len * sizeof (gfc_char_t)); 192 193 /* Pad with spaces. Substrings will already be blanked. */ 194 if (len < tlen && ref == NULL) 195 gfc_wide_memset (&dest[start + len], ' ', end - (start + len)); 196 197 if (rvalue->ts.type == BT_HOLLERITH) 198 { 199 init->representation.length = init->value.character.length; 200 init->representation.string 201 = gfc_widechar_to_char (init->value.character.string, 202 init->value.character.length); 203 } 204 205 return init; 206} 207 208 209/* Assign the initial value RVALUE to LVALUE's symbol->value. If the 210 LVALUE already has an initialization, we extend this, otherwise we 211 create a new one. If REPEAT is non-NULL, initialize *REPEAT 212 consecutive values in LVALUE the same value in RVALUE. In that case, 213 LVALUE must refer to a full array, not an array section. */ 214 215bool 216gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index, 217 mpz_t *repeat) 218{ 219 gfc_ref *ref; 220 gfc_expr *init; 221 gfc_expr *expr = NULL; 222 gfc_constructor *con; 223 gfc_constructor *last_con; 224 gfc_symbol *symbol; 225 gfc_typespec *last_ts; 226 mpz_t offset; 227 228 symbol = lvalue->symtree->n.sym; 229 init = symbol->value; 230 last_ts = &symbol->ts; 231 last_con = NULL; 232 mpz_init_set_si (offset, 0); 233 234 /* Find/create the parent expressions for subobject references. */ 235 for (ref = lvalue->ref; ref; ref = ref->next) 236 { 237 /* Break out of the loop if we find a substring. */ 238 if (ref->type == REF_SUBSTRING) 239 { 240 /* A substring should always be the last subobject reference. */ 241 gcc_assert (ref->next == NULL); 242 break; 243 } 244 245 /* Use the existing initializer expression if it exists. Otherwise 246 create a new one. */ 247 if (init == NULL) 248 expr = gfc_get_expr (); 249 else 250 expr = init; 251 252 /* Find or create this element. */ 253 switch (ref->type) 254 { 255 case REF_ARRAY: 256 if (ref->u.ar.as->rank == 0) 257 { 258 gcc_assert (ref->u.ar.as->corank > 0); 259 if (init == NULL) 260 free (expr); 261 continue; 262 } 263 264 if (init && expr->expr_type != EXPR_ARRAY) 265 { 266 gfc_error_1 ("'%s' at %L already is initialized at %L", 267 lvalue->symtree->n.sym->name, &lvalue->where, 268 &init->where); 269 goto abort; 270 } 271 272 if (init == NULL) 273 { 274 /* The element typespec will be the same as the array 275 typespec. */ 276 expr->ts = *last_ts; 277 /* Setup the expression to hold the constructor. */ 278 expr->expr_type = EXPR_ARRAY; 279 expr->rank = ref->u.ar.as->rank; 280 } 281 282 if (ref->u.ar.type == AR_ELEMENT) 283 get_array_index (&ref->u.ar, &offset); 284 else 285 mpz_set (offset, index); 286 287 /* Check the bounds. */ 288 if (mpz_cmp_si (offset, 0) < 0) 289 { 290 gfc_error ("Data element below array lower bound at %L", 291 &lvalue->where); 292 goto abort; 293 } 294 else if (repeat != NULL 295 && ref->u.ar.type != AR_ELEMENT) 296 { 297 mpz_t size, end; 298 gcc_assert (ref->u.ar.type == AR_FULL 299 && ref->next == NULL); 300 mpz_init_set (end, offset); 301 mpz_add (end, end, *repeat); 302 if (spec_size (ref->u.ar.as, &size)) 303 { 304 if (mpz_cmp (end, size) > 0) 305 { 306 mpz_clear (size); 307 gfc_error ("Data element above array upper bound at %L", 308 &lvalue->where); 309 goto abort; 310 } 311 mpz_clear (size); 312 } 313 314 con = gfc_constructor_lookup (expr->value.constructor, 315 mpz_get_si (offset)); 316 if (!con) 317 { 318 con = gfc_constructor_lookup_next (expr->value.constructor, 319 mpz_get_si (offset)); 320 if (con != NULL && mpz_cmp (con->offset, end) >= 0) 321 con = NULL; 322 } 323 324 /* Overwriting an existing initializer is non-standard but 325 usually only provokes a warning from other compilers. */ 326 if (con != NULL && con->expr != NULL) 327 { 328 /* Order in which the expressions arrive here depends on 329 whether they are from data statements or F95 style 330 declarations. Therefore, check which is the most 331 recent. */ 332 gfc_expr *exprd; 333 exprd = (LOCATION_LINE (con->expr->where.lb->location) 334 > LOCATION_LINE (rvalue->where.lb->location)) 335 ? con->expr : rvalue; 336 if (gfc_notify_std (GFC_STD_GNU, 337 "re-initialization of %qs at %L", 338 symbol->name, &exprd->where) == false) 339 return false; 340 } 341 342 while (con != NULL) 343 { 344 gfc_constructor *next_con = gfc_constructor_next (con); 345 346 if (mpz_cmp (con->offset, end) >= 0) 347 break; 348 if (mpz_cmp (con->offset, offset) < 0) 349 { 350 gcc_assert (mpz_cmp_si (con->repeat, 1) > 0); 351 mpz_sub (con->repeat, offset, con->offset); 352 } 353 else if (mpz_cmp_si (con->repeat, 1) > 0 354 && mpz_get_si (con->offset) 355 + mpz_get_si (con->repeat) > mpz_get_si (end)) 356 { 357 int endi; 358 splay_tree_node node 359 = splay_tree_lookup (con->base, 360 mpz_get_si (con->offset)); 361 gcc_assert (node 362 && con == (gfc_constructor *) node->value 363 && node->key == (splay_tree_key) 364 mpz_get_si (con->offset)); 365 endi = mpz_get_si (con->offset) 366 + mpz_get_si (con->repeat); 367 if (endi > mpz_get_si (end) + 1) 368 mpz_set_si (con->repeat, endi - mpz_get_si (end)); 369 else 370 mpz_set_si (con->repeat, 1); 371 mpz_set (con->offset, end); 372 node->key = (splay_tree_key) mpz_get_si (end); 373 break; 374 } 375 else 376 gfc_constructor_remove (con); 377 con = next_con; 378 } 379 380 con = gfc_constructor_insert_expr (&expr->value.constructor, 381 NULL, &rvalue->where, 382 mpz_get_si (offset)); 383 mpz_set (con->repeat, *repeat); 384 repeat = NULL; 385 mpz_clear (end); 386 break; 387 } 388 else 389 { 390 mpz_t size; 391 if (spec_size (ref->u.ar.as, &size)) 392 { 393 if (mpz_cmp (offset, size) >= 0) 394 { 395 mpz_clear (size); 396 gfc_error ("Data element above array upper bound at %L", 397 &lvalue->where); 398 goto abort; 399 } 400 mpz_clear (size); 401 } 402 } 403 404 con = gfc_constructor_lookup (expr->value.constructor, 405 mpz_get_si (offset)); 406 if (!con) 407 { 408 con = gfc_constructor_insert_expr (&expr->value.constructor, 409 NULL, &rvalue->where, 410 mpz_get_si (offset)); 411 } 412 else if (mpz_cmp_si (con->repeat, 1) > 0) 413 { 414 /* Need to split a range. */ 415 if (mpz_cmp (con->offset, offset) < 0) 416 { 417 gfc_constructor *pred_con = con; 418 con = gfc_constructor_insert_expr (&expr->value.constructor, 419 NULL, &con->where, 420 mpz_get_si (offset)); 421 con->expr = gfc_copy_expr (pred_con->expr); 422 mpz_add (con->repeat, pred_con->offset, pred_con->repeat); 423 mpz_sub (con->repeat, con->repeat, offset); 424 mpz_sub (pred_con->repeat, offset, pred_con->offset); 425 } 426 if (mpz_cmp_si (con->repeat, 1) > 0) 427 { 428 gfc_constructor *succ_con; 429 succ_con 430 = gfc_constructor_insert_expr (&expr->value.constructor, 431 NULL, &con->where, 432 mpz_get_si (offset) + 1); 433 succ_con->expr = gfc_copy_expr (con->expr); 434 mpz_sub_ui (succ_con->repeat, con->repeat, 1); 435 mpz_set_si (con->repeat, 1); 436 } 437 } 438 break; 439 440 case REF_COMPONENT: 441 if (init == NULL) 442 { 443 /* Setup the expression to hold the constructor. */ 444 expr->expr_type = EXPR_STRUCTURE; 445 expr->ts.type = BT_DERIVED; 446 expr->ts.u.derived = ref->u.c.sym; 447 } 448 else 449 gcc_assert (expr->expr_type == EXPR_STRUCTURE); 450 last_ts = &ref->u.c.component->ts; 451 452 /* Find the same element in the existing constructor. */ 453 con = find_con_by_component (ref->u.c.component, 454 expr->value.constructor); 455 456 if (con == NULL) 457 { 458 /* Create a new constructor. */ 459 con = gfc_constructor_append_expr (&expr->value.constructor, 460 NULL, NULL); 461 con->n.component = ref->u.c.component; 462 } 463 break; 464 465 default: 466 gcc_unreachable (); 467 } 468 469 if (init == NULL) 470 { 471 /* Point the container at the new expression. */ 472 if (last_con == NULL) 473 symbol->value = expr; 474 else 475 last_con->expr = expr; 476 } 477 init = con->expr; 478 last_con = con; 479 } 480 481 mpz_clear (offset); 482 gcc_assert (repeat == NULL); 483 484 if (ref || last_ts->type == BT_CHARACTER) 485 { 486 if (lvalue->ts.u.cl->length == NULL && !(ref && ref->u.ss.length != NULL)) 487 return false; 488 expr = create_character_initializer (init, last_ts, ref, rvalue); 489 } 490 else 491 { 492 /* Overwriting an existing initializer is non-standard but usually only 493 provokes a warning from other compilers. */ 494 if (init != NULL) 495 { 496 /* Order in which the expressions arrive here depends on whether 497 they are from data statements or F95 style declarations. 498 Therefore, check which is the most recent. */ 499 expr = (LOCATION_LINE (init->where.lb->location) 500 > LOCATION_LINE (rvalue->where.lb->location)) 501 ? init : rvalue; 502 if (gfc_notify_std (GFC_STD_GNU, 503 "re-initialization of %qs at %L", 504 symbol->name, &expr->where) == false) 505 return false; 506 } 507 508 expr = gfc_copy_expr (rvalue); 509 if (!gfc_compare_types (&lvalue->ts, &expr->ts)) 510 gfc_convert_type (expr, &lvalue->ts, 0); 511 } 512 513 if (last_con == NULL) 514 symbol->value = expr; 515 else 516 last_con->expr = expr; 517 518 return true; 519 520abort: 521 if (!init) 522 gfc_free_expr (expr); 523 mpz_clear (offset); 524 return false; 525} 526 527 528/* Modify the index of array section and re-calculate the array offset. */ 529 530void 531gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar, 532 mpz_t *offset_ret) 533{ 534 int i; 535 mpz_t delta; 536 mpz_t tmp; 537 bool forwards; 538 int cmp; 539 540 for (i = 0; i < ar->dimen; i++) 541 { 542 if (ar->dimen_type[i] != DIMEN_RANGE) 543 continue; 544 545 if (ar->stride[i]) 546 { 547 mpz_add (section_index[i], section_index[i], 548 ar->stride[i]->value.integer); 549 if (mpz_cmp_si (ar->stride[i]->value.integer, 0) >= 0) 550 forwards = true; 551 else 552 forwards = false; 553 } 554 else 555 { 556 mpz_add_ui (section_index[i], section_index[i], 1); 557 forwards = true; 558 } 559 560 if (ar->end[i]) 561 cmp = mpz_cmp (section_index[i], ar->end[i]->value.integer); 562 else 563 cmp = mpz_cmp (section_index[i], ar->as->upper[i]->value.integer); 564 565 if ((cmp > 0 && forwards) || (cmp < 0 && !forwards)) 566 { 567 /* Reset index to start, then loop to advance the next index. */ 568 if (ar->start[i]) 569 mpz_set (section_index[i], ar->start[i]->value.integer); 570 else 571 mpz_set (section_index[i], ar->as->lower[i]->value.integer); 572 } 573 else 574 break; 575 } 576 577 mpz_set_si (*offset_ret, 0); 578 mpz_init_set_si (delta, 1); 579 mpz_init (tmp); 580 for (i = 0; i < ar->dimen; i++) 581 { 582 mpz_sub (tmp, section_index[i], ar->as->lower[i]->value.integer); 583 mpz_mul (tmp, tmp, delta); 584 mpz_add (*offset_ret, tmp, *offset_ret); 585 586 mpz_sub (tmp, ar->as->upper[i]->value.integer, 587 ar->as->lower[i]->value.integer); 588 mpz_add_ui (tmp, tmp, 1); 589 mpz_mul (delta, tmp, delta); 590 } 591 mpz_clear (tmp); 592 mpz_clear (delta); 593} 594 595 596/* Rearrange a structure constructor so the elements are in the specified 597 order. Also insert NULL entries if necessary. */ 598 599static void 600formalize_structure_cons (gfc_expr *expr) 601{ 602 gfc_constructor_base base = NULL; 603 gfc_constructor *cur; 604 gfc_component *order; 605 606 /* Constructor is already formalized. */ 607 cur = gfc_constructor_first (expr->value.constructor); 608 if (!cur || cur->n.component == NULL) 609 return; 610 611 for (order = expr->ts.u.derived->components; order; order = order->next) 612 { 613 cur = find_con_by_component (order, expr->value.constructor); 614 if (cur) 615 gfc_constructor_append_expr (&base, cur->expr, &cur->expr->where); 616 else 617 gfc_constructor_append_expr (&base, NULL, NULL); 618 } 619 620 /* For all what it's worth, one would expect 621 gfc_constructor_free (expr->value.constructor); 622 here. However, if the constructor is actually free'd, 623 hell breaks loose in the testsuite?! */ 624 625 expr->value.constructor = base; 626} 627 628 629/* Make sure an initialization expression is in normalized form, i.e., all 630 elements of the constructors are in the correct order. */ 631 632static void 633formalize_init_expr (gfc_expr *expr) 634{ 635 expr_t type; 636 gfc_constructor *c; 637 638 if (expr == NULL) 639 return; 640 641 type = expr->expr_type; 642 switch (type) 643 { 644 case EXPR_ARRAY: 645 for (c = gfc_constructor_first (expr->value.constructor); 646 c; c = gfc_constructor_next (c)) 647 formalize_init_expr (c->expr); 648 649 break; 650 651 case EXPR_STRUCTURE: 652 formalize_structure_cons (expr); 653 break; 654 655 default: 656 break; 657 } 658} 659 660 661/* Resolve symbol's initial value after all data statement. */ 662 663void 664gfc_formalize_init_value (gfc_symbol *sym) 665{ 666 formalize_init_expr (sym->value); 667} 668 669 670/* Get the integer value into RET_AS and SECTION from AS and AR, and return 671 offset. */ 672 673void 674gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset) 675{ 676 int i; 677 mpz_t delta; 678 mpz_t tmp; 679 680 mpz_set_si (*offset, 0); 681 mpz_init (tmp); 682 mpz_init_set_si (delta, 1); 683 for (i = 0; i < ar->dimen; i++) 684 { 685 mpz_init (section_index[i]); 686 switch (ar->dimen_type[i]) 687 { 688 case DIMEN_ELEMENT: 689 case DIMEN_RANGE: 690 if (ar->start[i]) 691 { 692 mpz_sub (tmp, ar->start[i]->value.integer, 693 ar->as->lower[i]->value.integer); 694 mpz_mul (tmp, tmp, delta); 695 mpz_add (*offset, tmp, *offset); 696 mpz_set (section_index[i], ar->start[i]->value.integer); 697 } 698 else 699 mpz_set (section_index[i], ar->as->lower[i]->value.integer); 700 break; 701 702 case DIMEN_VECTOR: 703 gfc_internal_error ("TODO: Vector sections in data statements"); 704 705 default: 706 gcc_unreachable (); 707 } 708 709 mpz_sub (tmp, ar->as->upper[i]->value.integer, 710 ar->as->lower[i]->value.integer); 711 mpz_add_ui (tmp, tmp, 1); 712 mpz_mul (delta, tmp, delta); 713 } 714 715 mpz_clear (tmp); 716 mpz_clear (delta); 717} 718 719