1 /* Handle modules, which amounts to loading and saving symbols and 2 their attendant structures. 3 Copyright (C) 2000-2019 Free Software Foundation, Inc. 4 Contributed by Andy Vaught 5 6 This file is part of GCC. 7 8 GCC is free software; you can redistribute it and/or modify it under 9 the terms of the GNU General Public License as published by the Free 10 Software Foundation; either version 3, or (at your option) any later 11 version. 12 13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY 14 WARRANTY; without even the implied warranty of MERCHANTABILITY or 15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 16 for more details. 17 18 You should have received a copy of the GNU General Public License 19 along with GCC; see the file COPYING3. If not see 20 <http://www.gnu.org/licenses/>. */ 21 22 /* The syntax of gfortran modules resembles that of lisp lists, i.e. a 23 sequence of atoms, which can be left or right parenthesis, names, 24 integers or strings. Parenthesis are always matched which allows 25 us to skip over sections at high speed without having to know 26 anything about the internal structure of the lists. A "name" is 27 usually a fortran 95 identifier, but can also start with '@' in 28 order to reference a hidden symbol. 29 30 The first line of a module is an informational message about what 31 created the module, the file it came from and when it was created. 32 The second line is a warning for people not to edit the module. 33 The rest of the module looks like: 34 35 ( ( <Interface info for UPLUS> ) 36 ( <Interface info for UMINUS> ) 37 ... 38 ) 39 ( ( <name of operator interface> <module of op interface> <i/f1> ... ) 40 ... 41 ) 42 ( ( <name of generic interface> <module of generic interface> <i/f1> ... ) 43 ... 44 ) 45 ( ( <common name> <symbol> <saved flag>) 46 ... 47 ) 48 49 ( equivalence list ) 50 51 ( <Symbol Number (in no particular order)> 52 <True name of symbol> 53 <Module name of symbol> 54 ( <symbol information> ) 55 ... 56 ) 57 ( <Symtree name> 58 <Ambiguous flag> 59 <Symbol number> 60 ... 61 ) 62 63 In general, symbols refer to other symbols by their symbol number, 64 which are zero based. Symbols are written to the module in no 65 particular order. */ 66 67 #include "config.h" 68 #include "system.h" 69 #include "coretypes.h" 70 #include "options.h" 71 #include "tree.h" 72 #include "gfortran.h" 73 #include "stringpool.h" 74 #include "arith.h" 75 #include "match.h" 76 #include "parse.h" /* FIXME */ 77 #include "constructor.h" 78 #include "cpp.h" 79 #include "scanner.h" 80 #include <zlib.h> 81 82 #define MODULE_EXTENSION ".mod" 83 #define SUBMODULE_EXTENSION ".smod" 84 85 /* Don't put any single quote (') in MOD_VERSION, if you want it to be 86 recognized. */ 87 #define MOD_VERSION "15" 88 89 90 /* Structure that describes a position within a module file. */ 91 92 typedef struct 93 { 94 int column, line; 95 long pos; 96 } 97 module_locus; 98 99 /* Structure for list of symbols of intrinsic modules. */ 100 typedef struct 101 { 102 int id; 103 const char *name; 104 int value; 105 int standard; 106 } 107 intmod_sym; 108 109 110 typedef enum 111 { 112 P_UNKNOWN = 0, P_OTHER, P_NAMESPACE, P_COMPONENT, P_SYMBOL 113 } 114 pointer_t; 115 116 /* The fixup structure lists pointers to pointers that have to 117 be updated when a pointer value becomes known. */ 118 119 typedef struct fixup_t 120 { 121 void **pointer; 122 struct fixup_t *next; 123 } 124 fixup_t; 125 126 127 /* Structure for holding extra info needed for pointers being read. */ 128 129 enum gfc_rsym_state 130 { 131 UNUSED, 132 NEEDED, 133 USED 134 }; 135 136 enum gfc_wsym_state 137 { 138 UNREFERENCED = 0, 139 NEEDS_WRITE, 140 WRITTEN 141 }; 142 143 typedef struct pointer_info 144 { 145 BBT_HEADER (pointer_info); 146 HOST_WIDE_INT integer; 147 pointer_t type; 148 149 /* The first component of each member of the union is the pointer 150 being stored. */ 151 152 fixup_t *fixup; 153 154 union 155 { 156 void *pointer; /* Member for doing pointer searches. */ 157 158 struct 159 { 160 gfc_symbol *sym; 161 char *true_name, *module, *binding_label; 162 fixup_t *stfixup; 163 gfc_symtree *symtree; 164 enum gfc_rsym_state state; 165 int ns, referenced, renamed; 166 module_locus where; 167 } 168 rsym; 169 170 struct 171 { 172 gfc_symbol *sym; 173 enum gfc_wsym_state state; 174 } 175 wsym; 176 } 177 u; 178 179 } 180 pointer_info; 181 182 #define gfc_get_pointer_info() XCNEW (pointer_info) 183 184 185 /* Local variables */ 186 187 /* The gzFile for the module we're reading or writing. */ 188 static gzFile module_fp; 189 190 191 /* The name of the module we're reading (USE'ing) or writing. */ 192 static const char *module_name; 193 /* The name of the .smod file that the submodule will write to. */ 194 static const char *submodule_name; 195 196 static gfc_use_list *module_list; 197 198 /* If we're reading an intrinsic module, this is its ID. */ 199 static intmod_id current_intmod; 200 201 /* Content of module. */ 202 static char* module_content; 203 204 static long module_pos; 205 static int module_line, module_column, only_flag; 206 static int prev_module_line, prev_module_column; 207 208 static enum 209 { IO_INPUT, IO_OUTPUT } 210 iomode; 211 212 static gfc_use_rename *gfc_rename_list; 213 static pointer_info *pi_root; 214 static int symbol_number; /* Counter for assigning symbol numbers */ 215 216 /* Tells mio_expr_ref to make symbols for unused equivalence members. */ 217 static bool in_load_equiv; 218 219 220 221 /*****************************************************************/ 222 223 /* Pointer/integer conversion. Pointers between structures are stored 224 as integers in the module file. The next couple of subroutines 225 handle this translation for reading and writing. */ 226 227 /* Recursively free the tree of pointer structures. */ 228 229 static void 230 free_pi_tree (pointer_info *p) 231 { 232 if (p == NULL) 233 return; 234 235 if (p->fixup != NULL) 236 gfc_internal_error ("free_pi_tree(): Unresolved fixup"); 237 238 free_pi_tree (p->left); 239 free_pi_tree (p->right); 240 241 if (iomode == IO_INPUT) 242 { 243 XDELETEVEC (p->u.rsym.true_name); 244 XDELETEVEC (p->u.rsym.module); 245 XDELETEVEC (p->u.rsym.binding_label); 246 } 247 248 free (p); 249 } 250 251 252 /* Compare pointers when searching by pointer. Used when writing a 253 module. */ 254 255 static int 256 compare_pointers (void *_sn1, void *_sn2) 257 { 258 pointer_info *sn1, *sn2; 259 260 sn1 = (pointer_info *) _sn1; 261 sn2 = (pointer_info *) _sn2; 262 263 if (sn1->u.pointer < sn2->u.pointer) 264 return -1; 265 if (sn1->u.pointer > sn2->u.pointer) 266 return 1; 267 268 return 0; 269 } 270 271 272 /* Compare integers when searching by integer. Used when reading a 273 module. */ 274 275 static int 276 compare_integers (void *_sn1, void *_sn2) 277 { 278 pointer_info *sn1, *sn2; 279 280 sn1 = (pointer_info *) _sn1; 281 sn2 = (pointer_info *) _sn2; 282 283 if (sn1->integer < sn2->integer) 284 return -1; 285 if (sn1->integer > sn2->integer) 286 return 1; 287 288 return 0; 289 } 290 291 292 /* Initialize the pointer_info tree. */ 293 294 static void 295 init_pi_tree (void) 296 { 297 compare_fn compare; 298 pointer_info *p; 299 300 pi_root = NULL; 301 compare = (iomode == IO_INPUT) ? compare_integers : compare_pointers; 302 303 /* Pointer 0 is the NULL pointer. */ 304 p = gfc_get_pointer_info (); 305 p->u.pointer = NULL; 306 p->integer = 0; 307 p->type = P_OTHER; 308 309 gfc_insert_bbt (&pi_root, p, compare); 310 311 /* Pointer 1 is the current namespace. */ 312 p = gfc_get_pointer_info (); 313 p->u.pointer = gfc_current_ns; 314 p->integer = 1; 315 p->type = P_NAMESPACE; 316 317 gfc_insert_bbt (&pi_root, p, compare); 318 319 symbol_number = 2; 320 } 321 322 323 /* During module writing, call here with a pointer to something, 324 returning the pointer_info node. */ 325 326 static pointer_info * 327 find_pointer (void *gp) 328 { 329 pointer_info *p; 330 331 p = pi_root; 332 while (p != NULL) 333 { 334 if (p->u.pointer == gp) 335 break; 336 p = (gp < p->u.pointer) ? p->left : p->right; 337 } 338 339 return p; 340 } 341 342 343 /* Given a pointer while writing, returns the pointer_info tree node, 344 creating it if it doesn't exist. */ 345 346 static pointer_info * 347 get_pointer (void *gp) 348 { 349 pointer_info *p; 350 351 p = find_pointer (gp); 352 if (p != NULL) 353 return p; 354 355 /* Pointer doesn't have an integer. Give it one. */ 356 p = gfc_get_pointer_info (); 357 358 p->u.pointer = gp; 359 p->integer = symbol_number++; 360 361 gfc_insert_bbt (&pi_root, p, compare_pointers); 362 363 return p; 364 } 365 366 367 /* Given an integer during reading, find it in the pointer_info tree, 368 creating the node if not found. */ 369 370 static pointer_info * 371 get_integer (HOST_WIDE_INT integer) 372 { 373 pointer_info *p, t; 374 int c; 375 376 t.integer = integer; 377 378 p = pi_root; 379 while (p != NULL) 380 { 381 c = compare_integers (&t, p); 382 if (c == 0) 383 break; 384 385 p = (c < 0) ? p->left : p->right; 386 } 387 388 if (p != NULL) 389 return p; 390 391 p = gfc_get_pointer_info (); 392 p->integer = integer; 393 p->u.pointer = NULL; 394 395 gfc_insert_bbt (&pi_root, p, compare_integers); 396 397 return p; 398 } 399 400 401 /* Resolve any fixups using a known pointer. */ 402 403 static void 404 resolve_fixups (fixup_t *f, void *gp) 405 { 406 fixup_t *next; 407 408 for (; f; f = next) 409 { 410 next = f->next; 411 *(f->pointer) = gp; 412 free (f); 413 } 414 } 415 416 417 /* Convert a string such that it starts with a lower-case character. Used 418 to convert the symtree name of a derived-type to the symbol name or to 419 the name of the associated generic function. */ 420 421 const char * 422 gfc_dt_lower_string (const char *name) 423 { 424 if (name[0] != (char) TOLOWER ((unsigned char) name[0])) 425 return gfc_get_string ("%c%s", (char) TOLOWER ((unsigned char) name[0]), 426 &name[1]); 427 return gfc_get_string ("%s", name); 428 } 429 430 431 /* Convert a string such that it starts with an upper-case character. Used to 432 return the symtree-name for a derived type; the symbol name itself and the 433 symtree/symbol name of the associated generic function start with a lower- 434 case character. */ 435 436 const char * 437 gfc_dt_upper_string (const char *name) 438 { 439 if (name[0] != (char) TOUPPER ((unsigned char) name[0])) 440 return gfc_get_string ("%c%s", (char) TOUPPER ((unsigned char) name[0]), 441 &name[1]); 442 return gfc_get_string ("%s", name); 443 } 444 445 /* Call here during module reading when we know what pointer to 446 associate with an integer. Any fixups that exist are resolved at 447 this time. */ 448 449 static void 450 associate_integer_pointer (pointer_info *p, void *gp) 451 { 452 if (p->u.pointer != NULL) 453 gfc_internal_error ("associate_integer_pointer(): Already associated"); 454 455 p->u.pointer = gp; 456 457 resolve_fixups (p->fixup, gp); 458 459 p->fixup = NULL; 460 } 461 462 463 /* During module reading, given an integer and a pointer to a pointer, 464 either store the pointer from an already-known value or create a 465 fixup structure in order to store things later. Returns zero if 466 the reference has been actually stored, or nonzero if the reference 467 must be fixed later (i.e., associate_integer_pointer must be called 468 sometime later. Returns the pointer_info structure. */ 469 470 static pointer_info * 471 add_fixup (HOST_WIDE_INT integer, void *gp) 472 { 473 pointer_info *p; 474 fixup_t *f; 475 char **cp; 476 477 p = get_integer (integer); 478 479 if (p->integer == 0 || p->u.pointer != NULL) 480 { 481 cp = (char **) gp; 482 *cp = (char *) p->u.pointer; 483 } 484 else 485 { 486 f = XCNEW (fixup_t); 487 488 f->next = p->fixup; 489 p->fixup = f; 490 491 f->pointer = (void **) gp; 492 } 493 494 return p; 495 } 496 497 498 /*****************************************************************/ 499 500 /* Parser related subroutines */ 501 502 /* Free the rename list left behind by a USE statement. */ 503 504 static void 505 free_rename (gfc_use_rename *list) 506 { 507 gfc_use_rename *next; 508 509 for (; list; list = next) 510 { 511 next = list->next; 512 free (list); 513 } 514 } 515 516 517 /* Match a USE statement. */ 518 519 match 520 gfc_match_use (void) 521 { 522 char name[GFC_MAX_SYMBOL_LEN + 1], module_nature[GFC_MAX_SYMBOL_LEN + 1]; 523 gfc_use_rename *tail = NULL, *new_use; 524 interface_type type, type2; 525 gfc_intrinsic_op op; 526 match m; 527 gfc_use_list *use_list; 528 gfc_symtree *st; 529 locus loc; 530 531 use_list = gfc_get_use_list (); 532 533 if (gfc_match (" , ") == MATCH_YES) 534 { 535 if ((m = gfc_match (" %n ::", module_nature)) == MATCH_YES) 536 { 537 if (!gfc_notify_std (GFC_STD_F2003, "module " 538 "nature in USE statement at %C")) 539 goto cleanup; 540 541 if (strcmp (module_nature, "intrinsic") == 0) 542 use_list->intrinsic = true; 543 else 544 { 545 if (strcmp (module_nature, "non_intrinsic") == 0) 546 use_list->non_intrinsic = true; 547 else 548 { 549 gfc_error ("Module nature in USE statement at %C shall " 550 "be either INTRINSIC or NON_INTRINSIC"); 551 goto cleanup; 552 } 553 } 554 } 555 else 556 { 557 /* Help output a better error message than "Unclassifiable 558 statement". */ 559 gfc_match (" %n", module_nature); 560 if (strcmp (module_nature, "intrinsic") == 0 561 || strcmp (module_nature, "non_intrinsic") == 0) 562 gfc_error ("\"::\" was expected after module nature at %C " 563 "but was not found"); 564 free (use_list); 565 return m; 566 } 567 } 568 else 569 { 570 m = gfc_match (" ::"); 571 if (m == MATCH_YES && 572 !gfc_notify_std(GFC_STD_F2003, "\"USE :: module\" at %C")) 573 goto cleanup; 574 575 if (m != MATCH_YES) 576 { 577 m = gfc_match ("% "); 578 if (m != MATCH_YES) 579 { 580 free (use_list); 581 return m; 582 } 583 } 584 } 585 586 use_list->where = gfc_current_locus; 587 588 m = gfc_match_name (name); 589 if (m != MATCH_YES) 590 { 591 free (use_list); 592 return m; 593 } 594 595 use_list->module_name = gfc_get_string ("%s", name); 596 597 if (gfc_match_eos () == MATCH_YES) 598 goto done; 599 600 if (gfc_match_char (',') != MATCH_YES) 601 goto syntax; 602 603 if (gfc_match (" only :") == MATCH_YES) 604 use_list->only_flag = true; 605 606 if (gfc_match_eos () == MATCH_YES) 607 goto done; 608 609 for (;;) 610 { 611 /* Get a new rename struct and add it to the rename list. */ 612 new_use = gfc_get_use_rename (); 613 new_use->where = gfc_current_locus; 614 new_use->found = 0; 615 616 if (use_list->rename == NULL) 617 use_list->rename = new_use; 618 else 619 tail->next = new_use; 620 tail = new_use; 621 622 /* See what kind of interface we're dealing with. Assume it is 623 not an operator. */ 624 new_use->op = INTRINSIC_NONE; 625 if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR) 626 goto cleanup; 627 628 switch (type) 629 { 630 case INTERFACE_NAMELESS: 631 gfc_error ("Missing generic specification in USE statement at %C"); 632 goto cleanup; 633 634 case INTERFACE_USER_OP: 635 case INTERFACE_GENERIC: 636 case INTERFACE_DTIO: 637 loc = gfc_current_locus; 638 639 m = gfc_match (" =>"); 640 641 if (type == INTERFACE_USER_OP && m == MATCH_YES 642 && (!gfc_notify_std(GFC_STD_F2003, "Renaming " 643 "operators in USE statements at %C"))) 644 goto cleanup; 645 646 if (type == INTERFACE_USER_OP) 647 new_use->op = INTRINSIC_USER; 648 649 st = gfc_find_symtree (gfc_current_ns->sym_root, name); 650 if (st && type != INTERFACE_USER_OP) 651 { 652 if (m == MATCH_YES) 653 gfc_error ("Symbol %qs at %L conflicts with the rename symbol " 654 "at %L", name, &st->n.sym->declared_at, &loc); 655 else 656 gfc_error ("Symbol %qs at %L conflicts with the symbol " 657 "at %L", name, &st->n.sym->declared_at, &loc); 658 goto cleanup; 659 } 660 661 if (use_list->only_flag) 662 { 663 if (m != MATCH_YES) 664 strcpy (new_use->use_name, name); 665 else 666 { 667 strcpy (new_use->local_name, name); 668 m = gfc_match_generic_spec (&type2, new_use->use_name, &op); 669 if (type != type2) 670 goto syntax; 671 if (m == MATCH_NO) 672 goto syntax; 673 if (m == MATCH_ERROR) 674 goto cleanup; 675 } 676 } 677 else 678 { 679 if (m != MATCH_YES) 680 goto syntax; 681 strcpy (new_use->local_name, name); 682 683 m = gfc_match_generic_spec (&type2, new_use->use_name, &op); 684 if (type != type2) 685 goto syntax; 686 if (m == MATCH_NO) 687 goto syntax; 688 if (m == MATCH_ERROR) 689 goto cleanup; 690 } 691 692 if (strcmp (new_use->use_name, use_list->module_name) == 0 693 || strcmp (new_use->local_name, use_list->module_name) == 0) 694 { 695 gfc_error ("The name %qs at %C has already been used as " 696 "an external module name", use_list->module_name); 697 goto cleanup; 698 } 699 break; 700 701 case INTERFACE_INTRINSIC_OP: 702 new_use->op = op; 703 break; 704 705 default: 706 gcc_unreachable (); 707 } 708 709 if (gfc_match_eos () == MATCH_YES) 710 break; 711 if (gfc_match_char (',') != MATCH_YES) 712 goto syntax; 713 } 714 715 done: 716 if (module_list) 717 { 718 gfc_use_list *last = module_list; 719 while (last->next) 720 last = last->next; 721 last->next = use_list; 722 } 723 else 724 module_list = use_list; 725 726 return MATCH_YES; 727 728 syntax: 729 gfc_syntax_error (ST_USE); 730 731 cleanup: 732 free_rename (use_list->rename); 733 free (use_list); 734 return MATCH_ERROR; 735 } 736 737 738 /* Match a SUBMODULE statement. 739 740 According to F2008:11.2.3.2, "The submodule identifier is the 741 ordered pair whose first element is the ancestor module name and 742 whose second element is the submodule name. 'Submodule_name' is 743 used for the submodule filename and uses '@' as a separator, whilst 744 the name of the symbol for the module uses '.' as a a separator. 745 The reasons for these choices are: 746 (i) To follow another leading brand in the submodule filenames; 747 (ii) Since '.' is not particularly visible in the filenames; and 748 (iii) The linker does not permit '@' in mnemonics. */ 749 750 match 751 gfc_match_submodule (void) 752 { 753 match m; 754 char name[GFC_MAX_SYMBOL_LEN + 1]; 755 gfc_use_list *use_list; 756 bool seen_colon = false; 757 758 if (!gfc_notify_std (GFC_STD_F2008, "SUBMODULE declaration at %C")) 759 return MATCH_ERROR; 760 761 if (gfc_current_state () != COMP_NONE) 762 { 763 gfc_error ("SUBMODULE declaration at %C cannot appear within " 764 "another scoping unit"); 765 return MATCH_ERROR; 766 } 767 768 gfc_new_block = NULL; 769 gcc_assert (module_list == NULL); 770 771 if (gfc_match_char ('(') != MATCH_YES) 772 goto syntax; 773 774 while (1) 775 { 776 m = gfc_match (" %n", name); 777 if (m != MATCH_YES) 778 goto syntax; 779 780 use_list = gfc_get_use_list (); 781 use_list->where = gfc_current_locus; 782 783 if (module_list) 784 { 785 gfc_use_list *last = module_list; 786 while (last->next) 787 last = last->next; 788 last->next = use_list; 789 use_list->module_name 790 = gfc_get_string ("%s.%s", module_list->module_name, name); 791 use_list->submodule_name 792 = gfc_get_string ("%s@%s", module_list->module_name, name); 793 } 794 else 795 { 796 module_list = use_list; 797 use_list->module_name = gfc_get_string ("%s", name); 798 use_list->submodule_name = use_list->module_name; 799 } 800 801 if (gfc_match_char (')') == MATCH_YES) 802 break; 803 804 if (gfc_match_char (':') != MATCH_YES 805 || seen_colon) 806 goto syntax; 807 808 seen_colon = true; 809 } 810 811 m = gfc_match (" %s%t", &gfc_new_block); 812 if (m != MATCH_YES) 813 goto syntax; 814 815 submodule_name = gfc_get_string ("%s@%s", module_list->module_name, 816 gfc_new_block->name); 817 818 gfc_new_block->name = gfc_get_string ("%s.%s", 819 module_list->module_name, 820 gfc_new_block->name); 821 822 if (!gfc_add_flavor (&gfc_new_block->attr, FL_MODULE, 823 gfc_new_block->name, NULL)) 824 return MATCH_ERROR; 825 826 /* Just retain the ultimate .(s)mod file for reading, since it 827 contains all the information in its ancestors. */ 828 use_list = module_list; 829 for (; module_list->next; use_list = module_list) 830 { 831 module_list = use_list->next; 832 free (use_list); 833 } 834 835 return MATCH_YES; 836 837 syntax: 838 gfc_error ("Syntax error in SUBMODULE statement at %C"); 839 return MATCH_ERROR; 840 } 841 842 843 /* Given a name and a number, inst, return the inst name 844 under which to load this symbol. Returns NULL if this 845 symbol shouldn't be loaded. If inst is zero, returns 846 the number of instances of this name. If interface is 847 true, a user-defined operator is sought, otherwise only 848 non-operators are sought. */ 849 850 static const char * 851 find_use_name_n (const char *name, int *inst, bool interface) 852 { 853 gfc_use_rename *u; 854 const char *low_name = NULL; 855 int i; 856 857 /* For derived types. */ 858 if (name[0] != (char) TOLOWER ((unsigned char) name[0])) 859 low_name = gfc_dt_lower_string (name); 860 861 i = 0; 862 for (u = gfc_rename_list; u; u = u->next) 863 { 864 if ((!low_name && strcmp (u->use_name, name) != 0) 865 || (low_name && strcmp (u->use_name, low_name) != 0) 866 || (u->op == INTRINSIC_USER && !interface) 867 || (u->op != INTRINSIC_USER && interface)) 868 continue; 869 if (++i == *inst) 870 break; 871 } 872 873 if (!*inst) 874 { 875 *inst = i; 876 return NULL; 877 } 878 879 if (u == NULL) 880 return only_flag ? NULL : name; 881 882 u->found = 1; 883 884 if (low_name) 885 { 886 if (u->local_name[0] == '\0') 887 return name; 888 return gfc_dt_upper_string (u->local_name); 889 } 890 891 return (u->local_name[0] != '\0') ? u->local_name : name; 892 } 893 894 895 /* Given a name, return the name under which to load this symbol. 896 Returns NULL if this symbol shouldn't be loaded. */ 897 898 static const char * 899 find_use_name (const char *name, bool interface) 900 { 901 int i = 1; 902 return find_use_name_n (name, &i, interface); 903 } 904 905 906 /* Given a real name, return the number of use names associated with it. */ 907 908 static int 909 number_use_names (const char *name, bool interface) 910 { 911 int i = 0; 912 find_use_name_n (name, &i, interface); 913 return i; 914 } 915 916 917 /* Try to find the operator in the current list. */ 918 919 static gfc_use_rename * 920 find_use_operator (gfc_intrinsic_op op) 921 { 922 gfc_use_rename *u; 923 924 for (u = gfc_rename_list; u; u = u->next) 925 if (u->op == op) 926 return u; 927 928 return NULL; 929 } 930 931 932 /*****************************************************************/ 933 934 /* The next couple of subroutines maintain a tree used to avoid a 935 brute-force search for a combination of true name and module name. 936 While symtree names, the name that a particular symbol is known by 937 can changed with USE statements, we still have to keep track of the 938 true names to generate the correct reference, and also avoid 939 loading the same real symbol twice in a program unit. 940 941 When we start reading, the true name tree is built and maintained 942 as symbols are read. The tree is searched as we load new symbols 943 to see if it already exists someplace in the namespace. */ 944 945 typedef struct true_name 946 { 947 BBT_HEADER (true_name); 948 const char *name; 949 gfc_symbol *sym; 950 } 951 true_name; 952 953 static true_name *true_name_root; 954 955 956 /* Compare two true_name structures. */ 957 958 static int 959 compare_true_names (void *_t1, void *_t2) 960 { 961 true_name *t1, *t2; 962 int c; 963 964 t1 = (true_name *) _t1; 965 t2 = (true_name *) _t2; 966 967 c = ((t1->sym->module > t2->sym->module) 968 - (t1->sym->module < t2->sym->module)); 969 if (c != 0) 970 return c; 971 972 return strcmp (t1->name, t2->name); 973 } 974 975 976 /* Given a true name, search the true name tree to see if it exists 977 within the main namespace. */ 978 979 static gfc_symbol * 980 find_true_name (const char *name, const char *module) 981 { 982 true_name t, *p; 983 gfc_symbol sym; 984 int c; 985 986 t.name = gfc_get_string ("%s", name); 987 if (module != NULL) 988 sym.module = gfc_get_string ("%s", module); 989 else 990 sym.module = NULL; 991 t.sym = &sym; 992 993 p = true_name_root; 994 while (p != NULL) 995 { 996 c = compare_true_names ((void *) (&t), (void *) p); 997 if (c == 0) 998 return p->sym; 999 1000 p = (c < 0) ? p->left : p->right; 1001 } 1002 1003 return NULL; 1004 } 1005 1006 1007 /* Given a gfc_symbol pointer that is not in the true name tree, add it. */ 1008 1009 static void 1010 add_true_name (gfc_symbol *sym) 1011 { 1012 true_name *t; 1013 1014 t = XCNEW (true_name); 1015 t->sym = sym; 1016 if (gfc_fl_struct (sym->attr.flavor)) 1017 t->name = gfc_dt_upper_string (sym->name); 1018 else 1019 t->name = sym->name; 1020 1021 gfc_insert_bbt (&true_name_root, t, compare_true_names); 1022 } 1023 1024 1025 /* Recursive function to build the initial true name tree by 1026 recursively traversing the current namespace. */ 1027 1028 static void 1029 build_tnt (gfc_symtree *st) 1030 { 1031 const char *name; 1032 if (st == NULL) 1033 return; 1034 1035 build_tnt (st->left); 1036 build_tnt (st->right); 1037 1038 if (gfc_fl_struct (st->n.sym->attr.flavor)) 1039 name = gfc_dt_upper_string (st->n.sym->name); 1040 else 1041 name = st->n.sym->name; 1042 1043 if (find_true_name (name, st->n.sym->module) != NULL) 1044 return; 1045 1046 add_true_name (st->n.sym); 1047 } 1048 1049 1050 /* Initialize the true name tree with the current namespace. */ 1051 1052 static void 1053 init_true_name_tree (void) 1054 { 1055 true_name_root = NULL; 1056 build_tnt (gfc_current_ns->sym_root); 1057 } 1058 1059 1060 /* Recursively free a true name tree node. */ 1061 1062 static void 1063 free_true_name (true_name *t) 1064 { 1065 if (t == NULL) 1066 return; 1067 free_true_name (t->left); 1068 free_true_name (t->right); 1069 1070 free (t); 1071 } 1072 1073 1074 /*****************************************************************/ 1075 1076 /* Module reading and writing. */ 1077 1078 /* The following are versions similar to the ones in scanner.c, but 1079 for dealing with compressed module files. */ 1080 1081 static gzFile 1082 gzopen_included_file_1 (const char *name, gfc_directorylist *list, 1083 bool module, bool system) 1084 { 1085 char *fullname; 1086 gfc_directorylist *p; 1087 gzFile f; 1088 1089 for (p = list; p; p = p->next) 1090 { 1091 if (module && !p->use_for_modules) 1092 continue; 1093 1094 fullname = (char *) alloca(strlen (p->path) + strlen (name) + 1); 1095 strcpy (fullname, p->path); 1096 strcat (fullname, name); 1097 1098 f = gzopen (fullname, "r"); 1099 if (f != NULL) 1100 { 1101 if (gfc_cpp_makedep ()) 1102 gfc_cpp_add_dep (fullname, system); 1103 1104 return f; 1105 } 1106 } 1107 1108 return NULL; 1109 } 1110 1111 static gzFile 1112 gzopen_included_file (const char *name, bool include_cwd, bool module) 1113 { 1114 gzFile f = NULL; 1115 1116 if (IS_ABSOLUTE_PATH (name) || include_cwd) 1117 { 1118 f = gzopen (name, "r"); 1119 if (f && gfc_cpp_makedep ()) 1120 gfc_cpp_add_dep (name, false); 1121 } 1122 1123 if (!f) 1124 f = gzopen_included_file_1 (name, include_dirs, module, false); 1125 1126 return f; 1127 } 1128 1129 static gzFile 1130 gzopen_intrinsic_module (const char* name) 1131 { 1132 gzFile f = NULL; 1133 1134 if (IS_ABSOLUTE_PATH (name)) 1135 { 1136 f = gzopen (name, "r"); 1137 if (f && gfc_cpp_makedep ()) 1138 gfc_cpp_add_dep (name, true); 1139 } 1140 1141 if (!f) 1142 f = gzopen_included_file_1 (name, intrinsic_modules_dirs, true, true); 1143 1144 return f; 1145 } 1146 1147 1148 enum atom_type 1149 { 1150 ATOM_NAME, ATOM_LPAREN, ATOM_RPAREN, ATOM_INTEGER, ATOM_STRING 1151 }; 1152 1153 static atom_type last_atom; 1154 1155 1156 /* The name buffer must be at least as long as a symbol name. Right 1157 now it's not clear how we're going to store numeric constants-- 1158 probably as a hexadecimal string, since this will allow the exact 1159 number to be preserved (this can't be done by a decimal 1160 representation). Worry about that later. TODO! */ 1161 1162 #define MAX_ATOM_SIZE 100 1163 1164 static HOST_WIDE_INT atom_int; 1165 static char *atom_string, atom_name[MAX_ATOM_SIZE]; 1166 1167 1168 /* Report problems with a module. Error reporting is not very 1169 elaborate, since this sorts of errors shouldn't really happen. 1170 This subroutine never returns. */ 1171 1172 static void bad_module (const char *) ATTRIBUTE_NORETURN; 1173 1174 static void 1175 bad_module (const char *msgid) 1176 { 1177 XDELETEVEC (module_content); 1178 module_content = NULL; 1179 1180 switch (iomode) 1181 { 1182 case IO_INPUT: 1183 gfc_fatal_error ("Reading module %qs at line %d column %d: %s", 1184 module_name, module_line, module_column, msgid); 1185 break; 1186 case IO_OUTPUT: 1187 gfc_fatal_error ("Writing module %qs at line %d column %d: %s", 1188 module_name, module_line, module_column, msgid); 1189 break; 1190 default: 1191 gfc_fatal_error ("Module %qs at line %d column %d: %s", 1192 module_name, module_line, module_column, msgid); 1193 break; 1194 } 1195 } 1196 1197 1198 /* Set the module's input pointer. */ 1199 1200 static void 1201 set_module_locus (module_locus *m) 1202 { 1203 module_column = m->column; 1204 module_line = m->line; 1205 module_pos = m->pos; 1206 } 1207 1208 1209 /* Get the module's input pointer so that we can restore it later. */ 1210 1211 static void 1212 get_module_locus (module_locus *m) 1213 { 1214 m->column = module_column; 1215 m->line = module_line; 1216 m->pos = module_pos; 1217 } 1218 1219 1220 /* Get the next character in the module, updating our reckoning of 1221 where we are. */ 1222 1223 static int 1224 module_char (void) 1225 { 1226 const char c = module_content[module_pos++]; 1227 if (c == '\0') 1228 bad_module ("Unexpected EOF"); 1229 1230 prev_module_line = module_line; 1231 prev_module_column = module_column; 1232 1233 if (c == '\n') 1234 { 1235 module_line++; 1236 module_column = 0; 1237 } 1238 1239 module_column++; 1240 return c; 1241 } 1242 1243 /* Unget a character while remembering the line and column. Works for 1244 a single character only. */ 1245 1246 static void 1247 module_unget_char (void) 1248 { 1249 module_line = prev_module_line; 1250 module_column = prev_module_column; 1251 module_pos--; 1252 } 1253 1254 /* Parse a string constant. The delimiter is guaranteed to be a 1255 single quote. */ 1256 1257 static void 1258 parse_string (void) 1259 { 1260 int c; 1261 size_t cursz = 30; 1262 size_t len = 0; 1263 1264 atom_string = XNEWVEC (char, cursz); 1265 1266 for ( ; ; ) 1267 { 1268 c = module_char (); 1269 1270 if (c == '\'') 1271 { 1272 int c2 = module_char (); 1273 if (c2 != '\'') 1274 { 1275 module_unget_char (); 1276 break; 1277 } 1278 } 1279 1280 if (len >= cursz) 1281 { 1282 cursz *= 2; 1283 atom_string = XRESIZEVEC (char, atom_string, cursz); 1284 } 1285 atom_string[len] = c; 1286 len++; 1287 } 1288 1289 atom_string = XRESIZEVEC (char, atom_string, len + 1); 1290 atom_string[len] = '\0'; /* C-style string for debug purposes. */ 1291 } 1292 1293 1294 /* Parse an integer. Should fit in a HOST_WIDE_INT. */ 1295 1296 static void 1297 parse_integer (int c) 1298 { 1299 atom_int = c - '0'; 1300 1301 for (;;) 1302 { 1303 c = module_char (); 1304 if (!ISDIGIT (c)) 1305 { 1306 module_unget_char (); 1307 break; 1308 } 1309 1310 atom_int = 10 * atom_int + c - '0'; 1311 } 1312 1313 } 1314 1315 1316 /* Parse a name. */ 1317 1318 static void 1319 parse_name (int c) 1320 { 1321 char *p; 1322 int len; 1323 1324 p = atom_name; 1325 1326 *p++ = c; 1327 len = 1; 1328 1329 for (;;) 1330 { 1331 c = module_char (); 1332 if (!ISALNUM (c) && c != '_' && c != '-') 1333 { 1334 module_unget_char (); 1335 break; 1336 } 1337 1338 *p++ = c; 1339 if (++len > GFC_MAX_SYMBOL_LEN) 1340 bad_module ("Name too long"); 1341 } 1342 1343 *p = '\0'; 1344 1345 } 1346 1347 1348 /* Read the next atom in the module's input stream. */ 1349 1350 static atom_type 1351 parse_atom (void) 1352 { 1353 int c; 1354 1355 do 1356 { 1357 c = module_char (); 1358 } 1359 while (c == ' ' || c == '\r' || c == '\n'); 1360 1361 switch (c) 1362 { 1363 case '(': 1364 return ATOM_LPAREN; 1365 1366 case ')': 1367 return ATOM_RPAREN; 1368 1369 case '\'': 1370 parse_string (); 1371 return ATOM_STRING; 1372 1373 case '0': 1374 case '1': 1375 case '2': 1376 case '3': 1377 case '4': 1378 case '5': 1379 case '6': 1380 case '7': 1381 case '8': 1382 case '9': 1383 parse_integer (c); 1384 return ATOM_INTEGER; 1385 1386 case 'a': 1387 case 'b': 1388 case 'c': 1389 case 'd': 1390 case 'e': 1391 case 'f': 1392 case 'g': 1393 case 'h': 1394 case 'i': 1395 case 'j': 1396 case 'k': 1397 case 'l': 1398 case 'm': 1399 case 'n': 1400 case 'o': 1401 case 'p': 1402 case 'q': 1403 case 'r': 1404 case 's': 1405 case 't': 1406 case 'u': 1407 case 'v': 1408 case 'w': 1409 case 'x': 1410 case 'y': 1411 case 'z': 1412 case 'A': 1413 case 'B': 1414 case 'C': 1415 case 'D': 1416 case 'E': 1417 case 'F': 1418 case 'G': 1419 case 'H': 1420 case 'I': 1421 case 'J': 1422 case 'K': 1423 case 'L': 1424 case 'M': 1425 case 'N': 1426 case 'O': 1427 case 'P': 1428 case 'Q': 1429 case 'R': 1430 case 'S': 1431 case 'T': 1432 case 'U': 1433 case 'V': 1434 case 'W': 1435 case 'X': 1436 case 'Y': 1437 case 'Z': 1438 parse_name (c); 1439 return ATOM_NAME; 1440 1441 default: 1442 bad_module ("Bad name"); 1443 } 1444 1445 /* Not reached. */ 1446 } 1447 1448 1449 /* Peek at the next atom on the input. */ 1450 1451 static atom_type 1452 peek_atom (void) 1453 { 1454 int c; 1455 1456 do 1457 { 1458 c = module_char (); 1459 } 1460 while (c == ' ' || c == '\r' || c == '\n'); 1461 1462 switch (c) 1463 { 1464 case '(': 1465 module_unget_char (); 1466 return ATOM_LPAREN; 1467 1468 case ')': 1469 module_unget_char (); 1470 return ATOM_RPAREN; 1471 1472 case '\'': 1473 module_unget_char (); 1474 return ATOM_STRING; 1475 1476 case '0': 1477 case '1': 1478 case '2': 1479 case '3': 1480 case '4': 1481 case '5': 1482 case '6': 1483 case '7': 1484 case '8': 1485 case '9': 1486 module_unget_char (); 1487 return ATOM_INTEGER; 1488 1489 case 'a': 1490 case 'b': 1491 case 'c': 1492 case 'd': 1493 case 'e': 1494 case 'f': 1495 case 'g': 1496 case 'h': 1497 case 'i': 1498 case 'j': 1499 case 'k': 1500 case 'l': 1501 case 'm': 1502 case 'n': 1503 case 'o': 1504 case 'p': 1505 case 'q': 1506 case 'r': 1507 case 's': 1508 case 't': 1509 case 'u': 1510 case 'v': 1511 case 'w': 1512 case 'x': 1513 case 'y': 1514 case 'z': 1515 case 'A': 1516 case 'B': 1517 case 'C': 1518 case 'D': 1519 case 'E': 1520 case 'F': 1521 case 'G': 1522 case 'H': 1523 case 'I': 1524 case 'J': 1525 case 'K': 1526 case 'L': 1527 case 'M': 1528 case 'N': 1529 case 'O': 1530 case 'P': 1531 case 'Q': 1532 case 'R': 1533 case 'S': 1534 case 'T': 1535 case 'U': 1536 case 'V': 1537 case 'W': 1538 case 'X': 1539 case 'Y': 1540 case 'Z': 1541 module_unget_char (); 1542 return ATOM_NAME; 1543 1544 default: 1545 bad_module ("Bad name"); 1546 } 1547 } 1548 1549 1550 /* Read the next atom from the input, requiring that it be a 1551 particular kind. */ 1552 1553 static void 1554 require_atom (atom_type type) 1555 { 1556 atom_type t; 1557 const char *p; 1558 int column, line; 1559 1560 column = module_column; 1561 line = module_line; 1562 1563 t = parse_atom (); 1564 if (t != type) 1565 { 1566 switch (type) 1567 { 1568 case ATOM_NAME: 1569 p = _("Expected name"); 1570 break; 1571 case ATOM_LPAREN: 1572 p = _("Expected left parenthesis"); 1573 break; 1574 case ATOM_RPAREN: 1575 p = _("Expected right parenthesis"); 1576 break; 1577 case ATOM_INTEGER: 1578 p = _("Expected integer"); 1579 break; 1580 case ATOM_STRING: 1581 p = _("Expected string"); 1582 break; 1583 default: 1584 gfc_internal_error ("require_atom(): bad atom type required"); 1585 } 1586 1587 module_column = column; 1588 module_line = line; 1589 bad_module (p); 1590 } 1591 } 1592 1593 1594 /* Given a pointer to an mstring array, require that the current input 1595 be one of the strings in the array. We return the enum value. */ 1596 1597 static int 1598 find_enum (const mstring *m) 1599 { 1600 int i; 1601 1602 i = gfc_string2code (m, atom_name); 1603 if (i >= 0) 1604 return i; 1605 1606 bad_module ("find_enum(): Enum not found"); 1607 1608 /* Not reached. */ 1609 } 1610 1611 1612 /* Read a string. The caller is responsible for freeing. */ 1613 1614 static char* 1615 read_string (void) 1616 { 1617 char* p; 1618 require_atom (ATOM_STRING); 1619 p = atom_string; 1620 atom_string = NULL; 1621 return p; 1622 } 1623 1624 1625 /**************** Module output subroutines ***************************/ 1626 1627 /* Output a character to a module file. */ 1628 1629 static void 1630 write_char (char out) 1631 { 1632 if (gzputc (module_fp, out) == EOF) 1633 gfc_fatal_error ("Error writing modules file: %s", xstrerror (errno)); 1634 1635 if (out != '\n') 1636 module_column++; 1637 else 1638 { 1639 module_column = 1; 1640 module_line++; 1641 } 1642 } 1643 1644 1645 /* Write an atom to a module. The line wrapping isn't perfect, but it 1646 should work most of the time. This isn't that big of a deal, since 1647 the file really isn't meant to be read by people anyway. */ 1648 1649 static void 1650 write_atom (atom_type atom, const void *v) 1651 { 1652 char buffer[32]; 1653 1654 /* Workaround -Wmaybe-uninitialized false positive during 1655 profiledbootstrap by initializing them. */ 1656 int len; 1657 HOST_WIDE_INT i = 0; 1658 const char *p; 1659 1660 switch (atom) 1661 { 1662 case ATOM_STRING: 1663 case ATOM_NAME: 1664 p = (const char *) v; 1665 break; 1666 1667 case ATOM_LPAREN: 1668 p = "("; 1669 break; 1670 1671 case ATOM_RPAREN: 1672 p = ")"; 1673 break; 1674 1675 case ATOM_INTEGER: 1676 i = *((const HOST_WIDE_INT *) v); 1677 1678 snprintf (buffer, sizeof (buffer), HOST_WIDE_INT_PRINT_DEC, i); 1679 p = buffer; 1680 break; 1681 1682 default: 1683 gfc_internal_error ("write_atom(): Trying to write dab atom"); 1684 1685 } 1686 1687 if(p == NULL || *p == '\0') 1688 len = 0; 1689 else 1690 len = strlen (p); 1691 1692 if (atom != ATOM_RPAREN) 1693 { 1694 if (module_column + len > 72) 1695 write_char ('\n'); 1696 else 1697 { 1698 1699 if (last_atom != ATOM_LPAREN && module_column != 1) 1700 write_char (' '); 1701 } 1702 } 1703 1704 if (atom == ATOM_STRING) 1705 write_char ('\''); 1706 1707 while (p != NULL && *p) 1708 { 1709 if (atom == ATOM_STRING && *p == '\'') 1710 write_char ('\''); 1711 write_char (*p++); 1712 } 1713 1714 if (atom == ATOM_STRING) 1715 write_char ('\''); 1716 1717 last_atom = atom; 1718 } 1719 1720 1721 1722 /***************** Mid-level I/O subroutines *****************/ 1723 1724 /* These subroutines let their caller read or write atoms without 1725 caring about which of the two is actually happening. This lets a 1726 subroutine concentrate on the actual format of the data being 1727 written. */ 1728 1729 static void mio_expr (gfc_expr **); 1730 pointer_info *mio_symbol_ref (gfc_symbol **); 1731 pointer_info *mio_interface_rest (gfc_interface **); 1732 static void mio_symtree_ref (gfc_symtree **); 1733 1734 /* Read or write an enumerated value. On writing, we return the input 1735 value for the convenience of callers. We avoid using an integer 1736 pointer because enums are sometimes inside bitfields. */ 1737 1738 static int 1739 mio_name (int t, const mstring *m) 1740 { 1741 if (iomode == IO_OUTPUT) 1742 write_atom (ATOM_NAME, gfc_code2string (m, t)); 1743 else 1744 { 1745 require_atom (ATOM_NAME); 1746 t = find_enum (m); 1747 } 1748 1749 return t; 1750 } 1751 1752 /* Specialization of mio_name. */ 1753 1754 #define DECL_MIO_NAME(TYPE) \ 1755 static inline TYPE \ 1756 MIO_NAME(TYPE) (TYPE t, const mstring *m) \ 1757 { \ 1758 return (TYPE) mio_name ((int) t, m); \ 1759 } 1760 #define MIO_NAME(TYPE) mio_name_##TYPE 1761 1762 static void 1763 mio_lparen (void) 1764 { 1765 if (iomode == IO_OUTPUT) 1766 write_atom (ATOM_LPAREN, NULL); 1767 else 1768 require_atom (ATOM_LPAREN); 1769 } 1770 1771 1772 static void 1773 mio_rparen (void) 1774 { 1775 if (iomode == IO_OUTPUT) 1776 write_atom (ATOM_RPAREN, NULL); 1777 else 1778 require_atom (ATOM_RPAREN); 1779 } 1780 1781 1782 static void 1783 mio_integer (int *ip) 1784 { 1785 if (iomode == IO_OUTPUT) 1786 { 1787 HOST_WIDE_INT hwi = *ip; 1788 write_atom (ATOM_INTEGER, &hwi); 1789 } 1790 else 1791 { 1792 require_atom (ATOM_INTEGER); 1793 *ip = atom_int; 1794 } 1795 } 1796 1797 static void 1798 mio_hwi (HOST_WIDE_INT *hwi) 1799 { 1800 if (iomode == IO_OUTPUT) 1801 write_atom (ATOM_INTEGER, hwi); 1802 else 1803 { 1804 require_atom (ATOM_INTEGER); 1805 *hwi = atom_int; 1806 } 1807 } 1808 1809 1810 /* Read or write a gfc_intrinsic_op value. */ 1811 1812 static void 1813 mio_intrinsic_op (gfc_intrinsic_op* op) 1814 { 1815 /* FIXME: Would be nicer to do this via the operators symbolic name. */ 1816 if (iomode == IO_OUTPUT) 1817 { 1818 HOST_WIDE_INT converted = (HOST_WIDE_INT) *op; 1819 write_atom (ATOM_INTEGER, &converted); 1820 } 1821 else 1822 { 1823 require_atom (ATOM_INTEGER); 1824 *op = (gfc_intrinsic_op) atom_int; 1825 } 1826 } 1827 1828 1829 /* Read or write a character pointer that points to a string on the heap. */ 1830 1831 static const char * 1832 mio_allocated_string (const char *s) 1833 { 1834 if (iomode == IO_OUTPUT) 1835 { 1836 write_atom (ATOM_STRING, s); 1837 return s; 1838 } 1839 else 1840 { 1841 require_atom (ATOM_STRING); 1842 return atom_string; 1843 } 1844 } 1845 1846 1847 /* Functions for quoting and unquoting strings. */ 1848 1849 static char * 1850 quote_string (const gfc_char_t *s, const size_t slength) 1851 { 1852 const gfc_char_t *p; 1853 char *res, *q; 1854 size_t len = 0, i; 1855 1856 /* Calculate the length we'll need: a backslash takes two ("\\"), 1857 non-printable characters take 10 ("\Uxxxxxxxx") and others take 1. */ 1858 for (p = s, i = 0; i < slength; p++, i++) 1859 { 1860 if (*p == '\\') 1861 len += 2; 1862 else if (!gfc_wide_is_printable (*p)) 1863 len += 10; 1864 else 1865 len++; 1866 } 1867 1868 q = res = XCNEWVEC (char, len + 1); 1869 for (p = s, i = 0; i < slength; p++, i++) 1870 { 1871 if (*p == '\\') 1872 *q++ = '\\', *q++ = '\\'; 1873 else if (!gfc_wide_is_printable (*p)) 1874 { 1875 sprintf (q, "\\U%08" HOST_WIDE_INT_PRINT "x", 1876 (unsigned HOST_WIDE_INT) *p); 1877 q += 10; 1878 } 1879 else 1880 *q++ = (unsigned char) *p; 1881 } 1882 1883 res[len] = '\0'; 1884 return res; 1885 } 1886 1887 static gfc_char_t * 1888 unquote_string (const char *s) 1889 { 1890 size_t len, i; 1891 const char *p; 1892 gfc_char_t *res; 1893 1894 for (p = s, len = 0; *p; p++, len++) 1895 { 1896 if (*p != '\\') 1897 continue; 1898 1899 if (p[1] == '\\') 1900 p++; 1901 else if (p[1] == 'U') 1902 p += 9; /* That is a "\U????????". */ 1903 else 1904 gfc_internal_error ("unquote_string(): got bad string"); 1905 } 1906 1907 res = gfc_get_wide_string (len + 1); 1908 for (i = 0, p = s; i < len; i++, p++) 1909 { 1910 gcc_assert (*p); 1911 1912 if (*p != '\\') 1913 res[i] = (unsigned char) *p; 1914 else if (p[1] == '\\') 1915 { 1916 res[i] = (unsigned char) '\\'; 1917 p++; 1918 } 1919 else 1920 { 1921 /* We read the 8-digits hexadecimal constant that follows. */ 1922 int j; 1923 unsigned n; 1924 gfc_char_t c = 0; 1925 1926 gcc_assert (p[1] == 'U'); 1927 for (j = 0; j < 8; j++) 1928 { 1929 c = c << 4; 1930 gcc_assert (sscanf (&p[j+2], "%01x", &n) == 1); 1931 c += n; 1932 } 1933 1934 res[i] = c; 1935 p += 9; 1936 } 1937 } 1938 1939 res[len] = '\0'; 1940 return res; 1941 } 1942 1943 1944 /* Read or write a character pointer that points to a wide string on the 1945 heap, performing quoting/unquoting of nonprintable characters using the 1946 form \U???????? (where each ? is a hexadecimal digit). 1947 Length is the length of the string, only known and used in output mode. */ 1948 1949 static const gfc_char_t * 1950 mio_allocated_wide_string (const gfc_char_t *s, const size_t length) 1951 { 1952 if (iomode == IO_OUTPUT) 1953 { 1954 char *quoted = quote_string (s, length); 1955 write_atom (ATOM_STRING, quoted); 1956 free (quoted); 1957 return s; 1958 } 1959 else 1960 { 1961 gfc_char_t *unquoted; 1962 1963 require_atom (ATOM_STRING); 1964 unquoted = unquote_string (atom_string); 1965 free (atom_string); 1966 return unquoted; 1967 } 1968 } 1969 1970 1971 /* Read or write a string that is in static memory. */ 1972 1973 static void 1974 mio_pool_string (const char **stringp) 1975 { 1976 /* TODO: one could write the string only once, and refer to it via a 1977 fixup pointer. */ 1978 1979 /* As a special case we have to deal with a NULL string. This 1980 happens for the 'module' member of 'gfc_symbol's that are not in a 1981 module. We read / write these as the empty string. */ 1982 if (iomode == IO_OUTPUT) 1983 { 1984 const char *p = *stringp == NULL ? "" : *stringp; 1985 write_atom (ATOM_STRING, p); 1986 } 1987 else 1988 { 1989 require_atom (ATOM_STRING); 1990 *stringp = (atom_string[0] == '\0' 1991 ? NULL : gfc_get_string ("%s", atom_string)); 1992 free (atom_string); 1993 } 1994 } 1995 1996 1997 /* Read or write a string that is inside of some already-allocated 1998 structure. */ 1999 2000 static void 2001 mio_internal_string (char *string) 2002 { 2003 if (iomode == IO_OUTPUT) 2004 write_atom (ATOM_STRING, string); 2005 else 2006 { 2007 require_atom (ATOM_STRING); 2008 strcpy (string, atom_string); 2009 free (atom_string); 2010 } 2011 } 2012 2013 2014 enum ab_attribute 2015 { AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL, 2016 AB_POINTER, AB_TARGET, AB_DUMMY, AB_RESULT, AB_DATA, 2017 AB_IN_NAMELIST, AB_IN_COMMON, AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE, 2018 AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT, 2019 AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE, 2020 AB_ALLOC_COMP, AB_POINTER_COMP, AB_PROC_POINTER_COMP, AB_PRIVATE_COMP, 2021 AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_LOCK_COMP, AB_EVENT_COMP, 2022 AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP, 2023 AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION, 2024 AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER, 2025 AB_IMPLICIT_PURE, AB_ARTIFICIAL, AB_UNLIMITED_POLY, AB_OMP_DECLARE_TARGET, 2026 AB_ARRAY_OUTER_DEPENDENCY, AB_MODULE_PROCEDURE, AB_OACC_DECLARE_CREATE, 2027 AB_OACC_DECLARE_COPYIN, AB_OACC_DECLARE_DEVICEPTR, 2028 AB_OACC_DECLARE_DEVICE_RESIDENT, AB_OACC_DECLARE_LINK, 2029 AB_OMP_DECLARE_TARGET_LINK, AB_PDT_KIND, AB_PDT_LEN, AB_PDT_TYPE, 2030 AB_PDT_TEMPLATE, AB_PDT_ARRAY, AB_PDT_STRING, 2031 AB_OACC_ROUTINE_LOP_GANG, AB_OACC_ROUTINE_LOP_WORKER, 2032 AB_OACC_ROUTINE_LOP_VECTOR, AB_OACC_ROUTINE_LOP_SEQ 2033 }; 2034 2035 static const mstring attr_bits[] = 2036 { 2037 minit ("ALLOCATABLE", AB_ALLOCATABLE), 2038 minit ("ARTIFICIAL", AB_ARTIFICIAL), 2039 minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS), 2040 minit ("DIMENSION", AB_DIMENSION), 2041 minit ("CODIMENSION", AB_CODIMENSION), 2042 minit ("CONTIGUOUS", AB_CONTIGUOUS), 2043 minit ("EXTERNAL", AB_EXTERNAL), 2044 minit ("INTRINSIC", AB_INTRINSIC), 2045 minit ("OPTIONAL", AB_OPTIONAL), 2046 minit ("POINTER", AB_POINTER), 2047 minit ("VOLATILE", AB_VOLATILE), 2048 minit ("TARGET", AB_TARGET), 2049 minit ("THREADPRIVATE", AB_THREADPRIVATE), 2050 minit ("DUMMY", AB_DUMMY), 2051 minit ("RESULT", AB_RESULT), 2052 minit ("DATA", AB_DATA), 2053 minit ("IN_NAMELIST", AB_IN_NAMELIST), 2054 minit ("IN_COMMON", AB_IN_COMMON), 2055 minit ("FUNCTION", AB_FUNCTION), 2056 minit ("SUBROUTINE", AB_SUBROUTINE), 2057 minit ("SEQUENCE", AB_SEQUENCE), 2058 minit ("ELEMENTAL", AB_ELEMENTAL), 2059 minit ("PURE", AB_PURE), 2060 minit ("RECURSIVE", AB_RECURSIVE), 2061 minit ("GENERIC", AB_GENERIC), 2062 minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT), 2063 minit ("CRAY_POINTER", AB_CRAY_POINTER), 2064 minit ("CRAY_POINTEE", AB_CRAY_POINTEE), 2065 minit ("IS_BIND_C", AB_IS_BIND_C), 2066 minit ("IS_C_INTEROP", AB_IS_C_INTEROP), 2067 minit ("IS_ISO_C", AB_IS_ISO_C), 2068 minit ("VALUE", AB_VALUE), 2069 minit ("ALLOC_COMP", AB_ALLOC_COMP), 2070 minit ("COARRAY_COMP", AB_COARRAY_COMP), 2071 minit ("LOCK_COMP", AB_LOCK_COMP), 2072 minit ("EVENT_COMP", AB_EVENT_COMP), 2073 minit ("POINTER_COMP", AB_POINTER_COMP), 2074 minit ("PROC_POINTER_COMP", AB_PROC_POINTER_COMP), 2075 minit ("PRIVATE_COMP", AB_PRIVATE_COMP), 2076 minit ("ZERO_COMP", AB_ZERO_COMP), 2077 minit ("PROTECTED", AB_PROTECTED), 2078 minit ("ABSTRACT", AB_ABSTRACT), 2079 minit ("IS_CLASS", AB_IS_CLASS), 2080 minit ("PROCEDURE", AB_PROCEDURE), 2081 minit ("PROC_POINTER", AB_PROC_POINTER), 2082 minit ("VTYPE", AB_VTYPE), 2083 minit ("VTAB", AB_VTAB), 2084 minit ("CLASS_POINTER", AB_CLASS_POINTER), 2085 minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE), 2086 minit ("UNLIMITED_POLY", AB_UNLIMITED_POLY), 2087 minit ("OMP_DECLARE_TARGET", AB_OMP_DECLARE_TARGET), 2088 minit ("ARRAY_OUTER_DEPENDENCY", AB_ARRAY_OUTER_DEPENDENCY), 2089 minit ("MODULE_PROCEDURE", AB_MODULE_PROCEDURE), 2090 minit ("OACC_DECLARE_CREATE", AB_OACC_DECLARE_CREATE), 2091 minit ("OACC_DECLARE_COPYIN", AB_OACC_DECLARE_COPYIN), 2092 minit ("OACC_DECLARE_DEVICEPTR", AB_OACC_DECLARE_DEVICEPTR), 2093 minit ("OACC_DECLARE_DEVICE_RESIDENT", AB_OACC_DECLARE_DEVICE_RESIDENT), 2094 minit ("OACC_DECLARE_LINK", AB_OACC_DECLARE_LINK), 2095 minit ("OMP_DECLARE_TARGET_LINK", AB_OMP_DECLARE_TARGET_LINK), 2096 minit ("PDT_KIND", AB_PDT_KIND), 2097 minit ("PDT_LEN", AB_PDT_LEN), 2098 minit ("PDT_TYPE", AB_PDT_TYPE), 2099 minit ("PDT_TEMPLATE", AB_PDT_TEMPLATE), 2100 minit ("PDT_ARRAY", AB_PDT_ARRAY), 2101 minit ("PDT_STRING", AB_PDT_STRING), 2102 minit ("OACC_ROUTINE_LOP_GANG", AB_OACC_ROUTINE_LOP_GANG), 2103 minit ("OACC_ROUTINE_LOP_WORKER", AB_OACC_ROUTINE_LOP_WORKER), 2104 minit ("OACC_ROUTINE_LOP_VECTOR", AB_OACC_ROUTINE_LOP_VECTOR), 2105 minit ("OACC_ROUTINE_LOP_SEQ", AB_OACC_ROUTINE_LOP_SEQ), 2106 minit (NULL, -1) 2107 }; 2108 2109 /* For binding attributes. */ 2110 static const mstring binding_passing[] = 2111 { 2112 minit ("PASS", 0), 2113 minit ("NOPASS", 1), 2114 minit (NULL, -1) 2115 }; 2116 static const mstring binding_overriding[] = 2117 { 2118 minit ("OVERRIDABLE", 0), 2119 minit ("NON_OVERRIDABLE", 1), 2120 minit ("DEFERRED", 2), 2121 minit (NULL, -1) 2122 }; 2123 static const mstring binding_generic[] = 2124 { 2125 minit ("SPECIFIC", 0), 2126 minit ("GENERIC", 1), 2127 minit (NULL, -1) 2128 }; 2129 static const mstring binding_ppc[] = 2130 { 2131 minit ("NO_PPC", 0), 2132 minit ("PPC", 1), 2133 minit (NULL, -1) 2134 }; 2135 2136 /* Specialization of mio_name. */ 2137 DECL_MIO_NAME (ab_attribute) 2138 DECL_MIO_NAME (ar_type) 2139 DECL_MIO_NAME (array_type) 2140 DECL_MIO_NAME (bt) 2141 DECL_MIO_NAME (expr_t) 2142 DECL_MIO_NAME (gfc_access) 2143 DECL_MIO_NAME (gfc_intrinsic_op) 2144 DECL_MIO_NAME (ifsrc) 2145 DECL_MIO_NAME (save_state) 2146 DECL_MIO_NAME (procedure_type) 2147 DECL_MIO_NAME (ref_type) 2148 DECL_MIO_NAME (sym_flavor) 2149 DECL_MIO_NAME (sym_intent) 2150 DECL_MIO_NAME (inquiry_type) 2151 #undef DECL_MIO_NAME 2152 2153 /* Verify OACC_ROUTINE_LOP_NONE. */ 2154 2155 static void 2156 verify_OACC_ROUTINE_LOP_NONE (enum oacc_routine_lop lop) 2157 { 2158 if (lop != OACC_ROUTINE_LOP_NONE) 2159 bad_module ("Unsupported: multiple OpenACC 'routine' levels of parallelism"); 2160 } 2161 2162 /* Symbol attributes are stored in list with the first three elements 2163 being the enumerated fields, while the remaining elements (if any) 2164 indicate the individual attribute bits. The access field is not 2165 saved-- it controls what symbols are exported when a module is 2166 written. */ 2167 2168 static void 2169 mio_symbol_attribute (symbol_attribute *attr) 2170 { 2171 atom_type t; 2172 unsigned ext_attr,extension_level; 2173 2174 mio_lparen (); 2175 2176 attr->flavor = MIO_NAME (sym_flavor) (attr->flavor, flavors); 2177 attr->intent = MIO_NAME (sym_intent) (attr->intent, intents); 2178 attr->proc = MIO_NAME (procedure_type) (attr->proc, procedures); 2179 attr->if_source = MIO_NAME (ifsrc) (attr->if_source, ifsrc_types); 2180 attr->save = MIO_NAME (save_state) (attr->save, save_status); 2181 2182 ext_attr = attr->ext_attr; 2183 mio_integer ((int *) &ext_attr); 2184 attr->ext_attr = ext_attr; 2185 2186 extension_level = attr->extension; 2187 mio_integer ((int *) &extension_level); 2188 attr->extension = extension_level; 2189 2190 if (iomode == IO_OUTPUT) 2191 { 2192 if (attr->allocatable) 2193 MIO_NAME (ab_attribute) (AB_ALLOCATABLE, attr_bits); 2194 if (attr->artificial) 2195 MIO_NAME (ab_attribute) (AB_ARTIFICIAL, attr_bits); 2196 if (attr->asynchronous) 2197 MIO_NAME (ab_attribute) (AB_ASYNCHRONOUS, attr_bits); 2198 if (attr->dimension) 2199 MIO_NAME (ab_attribute) (AB_DIMENSION, attr_bits); 2200 if (attr->codimension) 2201 MIO_NAME (ab_attribute) (AB_CODIMENSION, attr_bits); 2202 if (attr->contiguous) 2203 MIO_NAME (ab_attribute) (AB_CONTIGUOUS, attr_bits); 2204 if (attr->external) 2205 MIO_NAME (ab_attribute) (AB_EXTERNAL, attr_bits); 2206 if (attr->intrinsic) 2207 MIO_NAME (ab_attribute) (AB_INTRINSIC, attr_bits); 2208 if (attr->optional) 2209 MIO_NAME (ab_attribute) (AB_OPTIONAL, attr_bits); 2210 if (attr->pointer) 2211 MIO_NAME (ab_attribute) (AB_POINTER, attr_bits); 2212 if (attr->class_pointer) 2213 MIO_NAME (ab_attribute) (AB_CLASS_POINTER, attr_bits); 2214 if (attr->is_protected) 2215 MIO_NAME (ab_attribute) (AB_PROTECTED, attr_bits); 2216 if (attr->value) 2217 MIO_NAME (ab_attribute) (AB_VALUE, attr_bits); 2218 if (attr->volatile_) 2219 MIO_NAME (ab_attribute) (AB_VOLATILE, attr_bits); 2220 if (attr->target) 2221 MIO_NAME (ab_attribute) (AB_TARGET, attr_bits); 2222 if (attr->threadprivate) 2223 MIO_NAME (ab_attribute) (AB_THREADPRIVATE, attr_bits); 2224 if (attr->dummy) 2225 MIO_NAME (ab_attribute) (AB_DUMMY, attr_bits); 2226 if (attr->result) 2227 MIO_NAME (ab_attribute) (AB_RESULT, attr_bits); 2228 /* We deliberately don't preserve the "entry" flag. */ 2229 2230 if (attr->data) 2231 MIO_NAME (ab_attribute) (AB_DATA, attr_bits); 2232 if (attr->in_namelist) 2233 MIO_NAME (ab_attribute) (AB_IN_NAMELIST, attr_bits); 2234 if (attr->in_common) 2235 MIO_NAME (ab_attribute) (AB_IN_COMMON, attr_bits); 2236 2237 if (attr->function) 2238 MIO_NAME (ab_attribute) (AB_FUNCTION, attr_bits); 2239 if (attr->subroutine) 2240 MIO_NAME (ab_attribute) (AB_SUBROUTINE, attr_bits); 2241 if (attr->generic) 2242 MIO_NAME (ab_attribute) (AB_GENERIC, attr_bits); 2243 if (attr->abstract) 2244 MIO_NAME (ab_attribute) (AB_ABSTRACT, attr_bits); 2245 2246 if (attr->sequence) 2247 MIO_NAME (ab_attribute) (AB_SEQUENCE, attr_bits); 2248 if (attr->elemental) 2249 MIO_NAME (ab_attribute) (AB_ELEMENTAL, attr_bits); 2250 if (attr->pure) 2251 MIO_NAME (ab_attribute) (AB_PURE, attr_bits); 2252 if (attr->implicit_pure) 2253 MIO_NAME (ab_attribute) (AB_IMPLICIT_PURE, attr_bits); 2254 if (attr->unlimited_polymorphic) 2255 MIO_NAME (ab_attribute) (AB_UNLIMITED_POLY, attr_bits); 2256 if (attr->recursive) 2257 MIO_NAME (ab_attribute) (AB_RECURSIVE, attr_bits); 2258 if (attr->always_explicit) 2259 MIO_NAME (ab_attribute) (AB_ALWAYS_EXPLICIT, attr_bits); 2260 if (attr->cray_pointer) 2261 MIO_NAME (ab_attribute) (AB_CRAY_POINTER, attr_bits); 2262 if (attr->cray_pointee) 2263 MIO_NAME (ab_attribute) (AB_CRAY_POINTEE, attr_bits); 2264 if (attr->is_bind_c) 2265 MIO_NAME(ab_attribute) (AB_IS_BIND_C, attr_bits); 2266 if (attr->is_c_interop) 2267 MIO_NAME(ab_attribute) (AB_IS_C_INTEROP, attr_bits); 2268 if (attr->is_iso_c) 2269 MIO_NAME(ab_attribute) (AB_IS_ISO_C, attr_bits); 2270 if (attr->alloc_comp) 2271 MIO_NAME (ab_attribute) (AB_ALLOC_COMP, attr_bits); 2272 if (attr->pointer_comp) 2273 MIO_NAME (ab_attribute) (AB_POINTER_COMP, attr_bits); 2274 if (attr->proc_pointer_comp) 2275 MIO_NAME (ab_attribute) (AB_PROC_POINTER_COMP, attr_bits); 2276 if (attr->private_comp) 2277 MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits); 2278 if (attr->coarray_comp) 2279 MIO_NAME (ab_attribute) (AB_COARRAY_COMP, attr_bits); 2280 if (attr->lock_comp) 2281 MIO_NAME (ab_attribute) (AB_LOCK_COMP, attr_bits); 2282 if (attr->event_comp) 2283 MIO_NAME (ab_attribute) (AB_EVENT_COMP, attr_bits); 2284 if (attr->zero_comp) 2285 MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits); 2286 if (attr->is_class) 2287 MIO_NAME (ab_attribute) (AB_IS_CLASS, attr_bits); 2288 if (attr->procedure) 2289 MIO_NAME (ab_attribute) (AB_PROCEDURE, attr_bits); 2290 if (attr->proc_pointer) 2291 MIO_NAME (ab_attribute) (AB_PROC_POINTER, attr_bits); 2292 if (attr->vtype) 2293 MIO_NAME (ab_attribute) (AB_VTYPE, attr_bits); 2294 if (attr->vtab) 2295 MIO_NAME (ab_attribute) (AB_VTAB, attr_bits); 2296 if (attr->omp_declare_target) 2297 MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET, attr_bits); 2298 if (attr->array_outer_dependency) 2299 MIO_NAME (ab_attribute) (AB_ARRAY_OUTER_DEPENDENCY, attr_bits); 2300 if (attr->module_procedure) 2301 MIO_NAME (ab_attribute) (AB_MODULE_PROCEDURE, attr_bits); 2302 if (attr->oacc_declare_create) 2303 MIO_NAME (ab_attribute) (AB_OACC_DECLARE_CREATE, attr_bits); 2304 if (attr->oacc_declare_copyin) 2305 MIO_NAME (ab_attribute) (AB_OACC_DECLARE_COPYIN, attr_bits); 2306 if (attr->oacc_declare_deviceptr) 2307 MIO_NAME (ab_attribute) (AB_OACC_DECLARE_DEVICEPTR, attr_bits); 2308 if (attr->oacc_declare_device_resident) 2309 MIO_NAME (ab_attribute) (AB_OACC_DECLARE_DEVICE_RESIDENT, attr_bits); 2310 if (attr->oacc_declare_link) 2311 MIO_NAME (ab_attribute) (AB_OACC_DECLARE_LINK, attr_bits); 2312 if (attr->omp_declare_target_link) 2313 MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET_LINK, attr_bits); 2314 if (attr->pdt_kind) 2315 MIO_NAME (ab_attribute) (AB_PDT_KIND, attr_bits); 2316 if (attr->pdt_len) 2317 MIO_NAME (ab_attribute) (AB_PDT_LEN, attr_bits); 2318 if (attr->pdt_type) 2319 MIO_NAME (ab_attribute) (AB_PDT_TYPE, attr_bits); 2320 if (attr->pdt_template) 2321 MIO_NAME (ab_attribute) (AB_PDT_TEMPLATE, attr_bits); 2322 if (attr->pdt_array) 2323 MIO_NAME (ab_attribute) (AB_PDT_ARRAY, attr_bits); 2324 if (attr->pdt_string) 2325 MIO_NAME (ab_attribute) (AB_PDT_STRING, attr_bits); 2326 switch (attr->oacc_routine_lop) 2327 { 2328 case OACC_ROUTINE_LOP_NONE: 2329 /* This is the default anyway, and for maintaining compatibility with 2330 the current MOD_VERSION, we're not emitting anything in that 2331 case. */ 2332 break; 2333 case OACC_ROUTINE_LOP_GANG: 2334 MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_LOP_GANG, attr_bits); 2335 break; 2336 case OACC_ROUTINE_LOP_WORKER: 2337 MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_LOP_WORKER, attr_bits); 2338 break; 2339 case OACC_ROUTINE_LOP_VECTOR: 2340 MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_LOP_VECTOR, attr_bits); 2341 break; 2342 case OACC_ROUTINE_LOP_SEQ: 2343 MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_LOP_SEQ, attr_bits); 2344 break; 2345 case OACC_ROUTINE_LOP_ERROR: 2346 /* ... intentionally omitted here; it's only unsed internally. */ 2347 default: 2348 gcc_unreachable (); 2349 } 2350 2351 mio_rparen (); 2352 2353 } 2354 else 2355 { 2356 for (;;) 2357 { 2358 t = parse_atom (); 2359 if (t == ATOM_RPAREN) 2360 break; 2361 if (t != ATOM_NAME) 2362 bad_module ("Expected attribute bit name"); 2363 2364 switch ((ab_attribute) find_enum (attr_bits)) 2365 { 2366 case AB_ALLOCATABLE: 2367 attr->allocatable = 1; 2368 break; 2369 case AB_ARTIFICIAL: 2370 attr->artificial = 1; 2371 break; 2372 case AB_ASYNCHRONOUS: 2373 attr->asynchronous = 1; 2374 break; 2375 case AB_DIMENSION: 2376 attr->dimension = 1; 2377 break; 2378 case AB_CODIMENSION: 2379 attr->codimension = 1; 2380 break; 2381 case AB_CONTIGUOUS: 2382 attr->contiguous = 1; 2383 break; 2384 case AB_EXTERNAL: 2385 attr->external = 1; 2386 break; 2387 case AB_INTRINSIC: 2388 attr->intrinsic = 1; 2389 break; 2390 case AB_OPTIONAL: 2391 attr->optional = 1; 2392 break; 2393 case AB_POINTER: 2394 attr->pointer = 1; 2395 break; 2396 case AB_CLASS_POINTER: 2397 attr->class_pointer = 1; 2398 break; 2399 case AB_PROTECTED: 2400 attr->is_protected = 1; 2401 break; 2402 case AB_VALUE: 2403 attr->value = 1; 2404 break; 2405 case AB_VOLATILE: 2406 attr->volatile_ = 1; 2407 break; 2408 case AB_TARGET: 2409 attr->target = 1; 2410 break; 2411 case AB_THREADPRIVATE: 2412 attr->threadprivate = 1; 2413 break; 2414 case AB_DUMMY: 2415 attr->dummy = 1; 2416 break; 2417 case AB_RESULT: 2418 attr->result = 1; 2419 break; 2420 case AB_DATA: 2421 attr->data = 1; 2422 break; 2423 case AB_IN_NAMELIST: 2424 attr->in_namelist = 1; 2425 break; 2426 case AB_IN_COMMON: 2427 attr->in_common = 1; 2428 break; 2429 case AB_FUNCTION: 2430 attr->function = 1; 2431 break; 2432 case AB_SUBROUTINE: 2433 attr->subroutine = 1; 2434 break; 2435 case AB_GENERIC: 2436 attr->generic = 1; 2437 break; 2438 case AB_ABSTRACT: 2439 attr->abstract = 1; 2440 break; 2441 case AB_SEQUENCE: 2442 attr->sequence = 1; 2443 break; 2444 case AB_ELEMENTAL: 2445 attr->elemental = 1; 2446 break; 2447 case AB_PURE: 2448 attr->pure = 1; 2449 break; 2450 case AB_IMPLICIT_PURE: 2451 attr->implicit_pure = 1; 2452 break; 2453 case AB_UNLIMITED_POLY: 2454 attr->unlimited_polymorphic = 1; 2455 break; 2456 case AB_RECURSIVE: 2457 attr->recursive = 1; 2458 break; 2459 case AB_ALWAYS_EXPLICIT: 2460 attr->always_explicit = 1; 2461 break; 2462 case AB_CRAY_POINTER: 2463 attr->cray_pointer = 1; 2464 break; 2465 case AB_CRAY_POINTEE: 2466 attr->cray_pointee = 1; 2467 break; 2468 case AB_IS_BIND_C: 2469 attr->is_bind_c = 1; 2470 break; 2471 case AB_IS_C_INTEROP: 2472 attr->is_c_interop = 1; 2473 break; 2474 case AB_IS_ISO_C: 2475 attr->is_iso_c = 1; 2476 break; 2477 case AB_ALLOC_COMP: 2478 attr->alloc_comp = 1; 2479 break; 2480 case AB_COARRAY_COMP: 2481 attr->coarray_comp = 1; 2482 break; 2483 case AB_LOCK_COMP: 2484 attr->lock_comp = 1; 2485 break; 2486 case AB_EVENT_COMP: 2487 attr->event_comp = 1; 2488 break; 2489 case AB_POINTER_COMP: 2490 attr->pointer_comp = 1; 2491 break; 2492 case AB_PROC_POINTER_COMP: 2493 attr->proc_pointer_comp = 1; 2494 break; 2495 case AB_PRIVATE_COMP: 2496 attr->private_comp = 1; 2497 break; 2498 case AB_ZERO_COMP: 2499 attr->zero_comp = 1; 2500 break; 2501 case AB_IS_CLASS: 2502 attr->is_class = 1; 2503 break; 2504 case AB_PROCEDURE: 2505 attr->procedure = 1; 2506 break; 2507 case AB_PROC_POINTER: 2508 attr->proc_pointer = 1; 2509 break; 2510 case AB_VTYPE: 2511 attr->vtype = 1; 2512 break; 2513 case AB_VTAB: 2514 attr->vtab = 1; 2515 break; 2516 case AB_OMP_DECLARE_TARGET: 2517 attr->omp_declare_target = 1; 2518 break; 2519 case AB_OMP_DECLARE_TARGET_LINK: 2520 attr->omp_declare_target_link = 1; 2521 break; 2522 case AB_ARRAY_OUTER_DEPENDENCY: 2523 attr->array_outer_dependency =1; 2524 break; 2525 case AB_MODULE_PROCEDURE: 2526 attr->module_procedure =1; 2527 break; 2528 case AB_OACC_DECLARE_CREATE: 2529 attr->oacc_declare_create = 1; 2530 break; 2531 case AB_OACC_DECLARE_COPYIN: 2532 attr->oacc_declare_copyin = 1; 2533 break; 2534 case AB_OACC_DECLARE_DEVICEPTR: 2535 attr->oacc_declare_deviceptr = 1; 2536 break; 2537 case AB_OACC_DECLARE_DEVICE_RESIDENT: 2538 attr->oacc_declare_device_resident = 1; 2539 break; 2540 case AB_OACC_DECLARE_LINK: 2541 attr->oacc_declare_link = 1; 2542 break; 2543 case AB_PDT_KIND: 2544 attr->pdt_kind = 1; 2545 break; 2546 case AB_PDT_LEN: 2547 attr->pdt_len = 1; 2548 break; 2549 case AB_PDT_TYPE: 2550 attr->pdt_type = 1; 2551 break; 2552 case AB_PDT_TEMPLATE: 2553 attr->pdt_template = 1; 2554 break; 2555 case AB_PDT_ARRAY: 2556 attr->pdt_array = 1; 2557 break; 2558 case AB_PDT_STRING: 2559 attr->pdt_string = 1; 2560 break; 2561 case AB_OACC_ROUTINE_LOP_GANG: 2562 verify_OACC_ROUTINE_LOP_NONE (attr->oacc_routine_lop); 2563 attr->oacc_routine_lop = OACC_ROUTINE_LOP_GANG; 2564 break; 2565 case AB_OACC_ROUTINE_LOP_WORKER: 2566 verify_OACC_ROUTINE_LOP_NONE (attr->oacc_routine_lop); 2567 attr->oacc_routine_lop = OACC_ROUTINE_LOP_WORKER; 2568 break; 2569 case AB_OACC_ROUTINE_LOP_VECTOR: 2570 verify_OACC_ROUTINE_LOP_NONE (attr->oacc_routine_lop); 2571 attr->oacc_routine_lop = OACC_ROUTINE_LOP_VECTOR; 2572 break; 2573 case AB_OACC_ROUTINE_LOP_SEQ: 2574 verify_OACC_ROUTINE_LOP_NONE (attr->oacc_routine_lop); 2575 attr->oacc_routine_lop = OACC_ROUTINE_LOP_SEQ; 2576 break; 2577 } 2578 } 2579 } 2580 } 2581 2582 2583 static const mstring bt_types[] = { 2584 minit ("INTEGER", BT_INTEGER), 2585 minit ("REAL", BT_REAL), 2586 minit ("COMPLEX", BT_COMPLEX), 2587 minit ("LOGICAL", BT_LOGICAL), 2588 minit ("CHARACTER", BT_CHARACTER), 2589 minit ("UNION", BT_UNION), 2590 minit ("DERIVED", BT_DERIVED), 2591 minit ("CLASS", BT_CLASS), 2592 minit ("PROCEDURE", BT_PROCEDURE), 2593 minit ("UNKNOWN", BT_UNKNOWN), 2594 minit ("VOID", BT_VOID), 2595 minit ("ASSUMED", BT_ASSUMED), 2596 minit (NULL, -1) 2597 }; 2598 2599 2600 static void 2601 mio_charlen (gfc_charlen **clp) 2602 { 2603 gfc_charlen *cl; 2604 2605 mio_lparen (); 2606 2607 if (iomode == IO_OUTPUT) 2608 { 2609 cl = *clp; 2610 if (cl != NULL) 2611 mio_expr (&cl->length); 2612 } 2613 else 2614 { 2615 if (peek_atom () != ATOM_RPAREN) 2616 { 2617 cl = gfc_new_charlen (gfc_current_ns, NULL); 2618 mio_expr (&cl->length); 2619 *clp = cl; 2620 } 2621 } 2622 2623 mio_rparen (); 2624 } 2625 2626 2627 /* See if a name is a generated name. */ 2628 2629 static int 2630 check_unique_name (const char *name) 2631 { 2632 return *name == '@'; 2633 } 2634 2635 2636 static void 2637 mio_typespec (gfc_typespec *ts) 2638 { 2639 mio_lparen (); 2640 2641 ts->type = MIO_NAME (bt) (ts->type, bt_types); 2642 2643 if (!gfc_bt_struct (ts->type) && ts->type != BT_CLASS) 2644 mio_integer (&ts->kind); 2645 else 2646 mio_symbol_ref (&ts->u.derived); 2647 2648 mio_symbol_ref (&ts->interface); 2649 2650 /* Add info for C interop and is_iso_c. */ 2651 mio_integer (&ts->is_c_interop); 2652 mio_integer (&ts->is_iso_c); 2653 2654 /* If the typespec is for an identifier either from iso_c_binding, or 2655 a constant that was initialized to an identifier from it, use the 2656 f90_type. Otherwise, use the ts->type, since it shouldn't matter. */ 2657 if (ts->is_iso_c) 2658 ts->f90_type = MIO_NAME (bt) (ts->f90_type, bt_types); 2659 else 2660 ts->f90_type = MIO_NAME (bt) (ts->type, bt_types); 2661 2662 if (ts->type != BT_CHARACTER) 2663 { 2664 /* ts->u.cl is only valid for BT_CHARACTER. */ 2665 mio_lparen (); 2666 mio_rparen (); 2667 } 2668 else 2669 mio_charlen (&ts->u.cl); 2670 2671 /* So as not to disturb the existing API, use an ATOM_NAME to 2672 transmit deferred characteristic for characters (F2003). */ 2673 if (iomode == IO_OUTPUT) 2674 { 2675 if (ts->type == BT_CHARACTER && ts->deferred) 2676 write_atom (ATOM_NAME, "DEFERRED_CL"); 2677 } 2678 else if (peek_atom () != ATOM_RPAREN) 2679 { 2680 if (parse_atom () != ATOM_NAME) 2681 bad_module ("Expected string"); 2682 ts->deferred = 1; 2683 } 2684 2685 mio_rparen (); 2686 } 2687 2688 2689 static const mstring array_spec_types[] = { 2690 minit ("EXPLICIT", AS_EXPLICIT), 2691 minit ("ASSUMED_RANK", AS_ASSUMED_RANK), 2692 minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE), 2693 minit ("DEFERRED", AS_DEFERRED), 2694 minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE), 2695 minit (NULL, -1) 2696 }; 2697 2698 2699 static void 2700 mio_array_spec (gfc_array_spec **asp) 2701 { 2702 gfc_array_spec *as; 2703 int i; 2704 2705 mio_lparen (); 2706 2707 if (iomode == IO_OUTPUT) 2708 { 2709 int rank; 2710 2711 if (*asp == NULL) 2712 goto done; 2713 as = *asp; 2714 2715 /* mio_integer expects nonnegative values. */ 2716 rank = as->rank > 0 ? as->rank : 0; 2717 mio_integer (&rank); 2718 } 2719 else 2720 { 2721 if (peek_atom () == ATOM_RPAREN) 2722 { 2723 *asp = NULL; 2724 goto done; 2725 } 2726 2727 *asp = as = gfc_get_array_spec (); 2728 mio_integer (&as->rank); 2729 } 2730 2731 mio_integer (&as->corank); 2732 as->type = MIO_NAME (array_type) (as->type, array_spec_types); 2733 2734 if (iomode == IO_INPUT && as->type == AS_ASSUMED_RANK) 2735 as->rank = -1; 2736 if (iomode == IO_INPUT && as->corank) 2737 as->cotype = (as->type == AS_DEFERRED) ? AS_DEFERRED : AS_EXPLICIT; 2738 2739 if (as->rank + as->corank > 0) 2740 for (i = 0; i < as->rank + as->corank; i++) 2741 { 2742 mio_expr (&as->lower[i]); 2743 mio_expr (&as->upper[i]); 2744 } 2745 2746 done: 2747 mio_rparen (); 2748 } 2749 2750 2751 /* Given a pointer to an array reference structure (which lives in a 2752 gfc_ref structure), find the corresponding array specification 2753 structure. Storing the pointer in the ref structure doesn't quite 2754 work when loading from a module. Generating code for an array 2755 reference also needs more information than just the array spec. */ 2756 2757 static const mstring array_ref_types[] = { 2758 minit ("FULL", AR_FULL), 2759 minit ("ELEMENT", AR_ELEMENT), 2760 minit ("SECTION", AR_SECTION), 2761 minit (NULL, -1) 2762 }; 2763 2764 2765 static void 2766 mio_array_ref (gfc_array_ref *ar) 2767 { 2768 int i; 2769 2770 mio_lparen (); 2771 ar->type = MIO_NAME (ar_type) (ar->type, array_ref_types); 2772 mio_integer (&ar->dimen); 2773 2774 switch (ar->type) 2775 { 2776 case AR_FULL: 2777 break; 2778 2779 case AR_ELEMENT: 2780 for (i = 0; i < ar->dimen; i++) 2781 mio_expr (&ar->start[i]); 2782 2783 break; 2784 2785 case AR_SECTION: 2786 for (i = 0; i < ar->dimen; i++) 2787 { 2788 mio_expr (&ar->start[i]); 2789 mio_expr (&ar->end[i]); 2790 mio_expr (&ar->stride[i]); 2791 } 2792 2793 break; 2794 2795 case AR_UNKNOWN: 2796 gfc_internal_error ("mio_array_ref(): Unknown array ref"); 2797 } 2798 2799 /* Unfortunately, ar->dimen_type is an anonymous enumerated type so 2800 we can't call mio_integer directly. Instead loop over each element 2801 and cast it to/from an integer. */ 2802 if (iomode == IO_OUTPUT) 2803 { 2804 for (i = 0; i < ar->dimen; i++) 2805 { 2806 HOST_WIDE_INT tmp = (HOST_WIDE_INT)ar->dimen_type[i]; 2807 write_atom (ATOM_INTEGER, &tmp); 2808 } 2809 } 2810 else 2811 { 2812 for (i = 0; i < ar->dimen; i++) 2813 { 2814 require_atom (ATOM_INTEGER); 2815 ar->dimen_type[i] = (enum gfc_array_ref_dimen_type) atom_int; 2816 } 2817 } 2818 2819 if (iomode == IO_INPUT) 2820 { 2821 ar->where = gfc_current_locus; 2822 2823 for (i = 0; i < ar->dimen; i++) 2824 ar->c_where[i] = gfc_current_locus; 2825 } 2826 2827 mio_rparen (); 2828 } 2829 2830 2831 /* Saves or restores a pointer. The pointer is converted back and 2832 forth from an integer. We return the pointer_info pointer so that 2833 the caller can take additional action based on the pointer type. */ 2834 2835 static pointer_info * 2836 mio_pointer_ref (void *gp) 2837 { 2838 pointer_info *p; 2839 2840 if (iomode == IO_OUTPUT) 2841 { 2842 p = get_pointer (*((char **) gp)); 2843 HOST_WIDE_INT hwi = p->integer; 2844 write_atom (ATOM_INTEGER, &hwi); 2845 } 2846 else 2847 { 2848 require_atom (ATOM_INTEGER); 2849 p = add_fixup (atom_int, gp); 2850 } 2851 2852 return p; 2853 } 2854 2855 2856 /* Save and load references to components that occur within 2857 expressions. We have to describe these references by a number and 2858 by name. The number is necessary for forward references during 2859 reading, and the name is necessary if the symbol already exists in 2860 the namespace and is not loaded again. */ 2861 2862 static void 2863 mio_component_ref (gfc_component **cp) 2864 { 2865 pointer_info *p; 2866 2867 p = mio_pointer_ref (cp); 2868 if (p->type == P_UNKNOWN) 2869 p->type = P_COMPONENT; 2870 } 2871 2872 2873 static void mio_namespace_ref (gfc_namespace **nsp); 2874 static void mio_formal_arglist (gfc_formal_arglist **formal); 2875 static void mio_typebound_proc (gfc_typebound_proc** proc); 2876 static void mio_actual_arglist (gfc_actual_arglist **ap, bool pdt); 2877 2878 static void 2879 mio_component (gfc_component *c, int vtype) 2880 { 2881 pointer_info *p; 2882 2883 mio_lparen (); 2884 2885 if (iomode == IO_OUTPUT) 2886 { 2887 p = get_pointer (c); 2888 mio_hwi (&p->integer); 2889 } 2890 else 2891 { 2892 HOST_WIDE_INT n; 2893 mio_hwi (&n); 2894 p = get_integer (n); 2895 associate_integer_pointer (p, c); 2896 } 2897 2898 if (p->type == P_UNKNOWN) 2899 p->type = P_COMPONENT; 2900 2901 mio_pool_string (&c->name); 2902 mio_typespec (&c->ts); 2903 mio_array_spec (&c->as); 2904 2905 /* PDT templates store the expression for the kind of a component here. */ 2906 mio_expr (&c->kind_expr); 2907 2908 /* PDT types store the component specification list here. */ 2909 mio_actual_arglist (&c->param_list, true); 2910 2911 mio_symbol_attribute (&c->attr); 2912 if (c->ts.type == BT_CLASS) 2913 c->attr.class_ok = 1; 2914 c->attr.access = MIO_NAME (gfc_access) (c->attr.access, access_types); 2915 2916 if (!vtype || strcmp (c->name, "_final") == 0 2917 || strcmp (c->name, "_hash") == 0) 2918 mio_expr (&c->initializer); 2919 2920 if (c->attr.proc_pointer) 2921 mio_typebound_proc (&c->tb); 2922 2923 c->loc = gfc_current_locus; 2924 2925 mio_rparen (); 2926 } 2927 2928 2929 static void 2930 mio_component_list (gfc_component **cp, int vtype) 2931 { 2932 gfc_component *c, *tail; 2933 2934 mio_lparen (); 2935 2936 if (iomode == IO_OUTPUT) 2937 { 2938 for (c = *cp; c; c = c->next) 2939 mio_component (c, vtype); 2940 } 2941 else 2942 { 2943 *cp = NULL; 2944 tail = NULL; 2945 2946 for (;;) 2947 { 2948 if (peek_atom () == ATOM_RPAREN) 2949 break; 2950 2951 c = gfc_get_component (); 2952 mio_component (c, vtype); 2953 2954 if (tail == NULL) 2955 *cp = c; 2956 else 2957 tail->next = c; 2958 2959 tail = c; 2960 } 2961 } 2962 2963 mio_rparen (); 2964 } 2965 2966 2967 static void 2968 mio_actual_arg (gfc_actual_arglist *a, bool pdt) 2969 { 2970 mio_lparen (); 2971 mio_pool_string (&a->name); 2972 mio_expr (&a->expr); 2973 if (pdt) 2974 mio_integer ((int *)&a->spec_type); 2975 mio_rparen (); 2976 } 2977 2978 2979 static void 2980 mio_actual_arglist (gfc_actual_arglist **ap, bool pdt) 2981 { 2982 gfc_actual_arglist *a, *tail; 2983 2984 mio_lparen (); 2985 2986 if (iomode == IO_OUTPUT) 2987 { 2988 for (a = *ap; a; a = a->next) 2989 mio_actual_arg (a, pdt); 2990 2991 } 2992 else 2993 { 2994 tail = NULL; 2995 2996 for (;;) 2997 { 2998 if (peek_atom () != ATOM_LPAREN) 2999 break; 3000 3001 a = gfc_get_actual_arglist (); 3002 3003 if (tail == NULL) 3004 *ap = a; 3005 else 3006 tail->next = a; 3007 3008 tail = a; 3009 mio_actual_arg (a, pdt); 3010 } 3011 } 3012 3013 mio_rparen (); 3014 } 3015 3016 3017 /* Read and write formal argument lists. */ 3018 3019 static void 3020 mio_formal_arglist (gfc_formal_arglist **formal) 3021 { 3022 gfc_formal_arglist *f, *tail; 3023 3024 mio_lparen (); 3025 3026 if (iomode == IO_OUTPUT) 3027 { 3028 for (f = *formal; f; f = f->next) 3029 mio_symbol_ref (&f->sym); 3030 } 3031 else 3032 { 3033 *formal = tail = NULL; 3034 3035 while (peek_atom () != ATOM_RPAREN) 3036 { 3037 f = gfc_get_formal_arglist (); 3038 mio_symbol_ref (&f->sym); 3039 3040 if (*formal == NULL) 3041 *formal = f; 3042 else 3043 tail->next = f; 3044 3045 tail = f; 3046 } 3047 } 3048 3049 mio_rparen (); 3050 } 3051 3052 3053 /* Save or restore a reference to a symbol node. */ 3054 3055 pointer_info * 3056 mio_symbol_ref (gfc_symbol **symp) 3057 { 3058 pointer_info *p; 3059 3060 p = mio_pointer_ref (symp); 3061 if (p->type == P_UNKNOWN) 3062 p->type = P_SYMBOL; 3063 3064 if (iomode == IO_OUTPUT) 3065 { 3066 if (p->u.wsym.state == UNREFERENCED) 3067 p->u.wsym.state = NEEDS_WRITE; 3068 } 3069 else 3070 { 3071 if (p->u.rsym.state == UNUSED) 3072 p->u.rsym.state = NEEDED; 3073 } 3074 return p; 3075 } 3076 3077 3078 /* Save or restore a reference to a symtree node. */ 3079 3080 static void 3081 mio_symtree_ref (gfc_symtree **stp) 3082 { 3083 pointer_info *p; 3084 fixup_t *f; 3085 3086 if (iomode == IO_OUTPUT) 3087 mio_symbol_ref (&(*stp)->n.sym); 3088 else 3089 { 3090 require_atom (ATOM_INTEGER); 3091 p = get_integer (atom_int); 3092 3093 /* An unused equivalence member; make a symbol and a symtree 3094 for it. */ 3095 if (in_load_equiv && p->u.rsym.symtree == NULL) 3096 { 3097 /* Since this is not used, it must have a unique name. */ 3098 p->u.rsym.symtree = gfc_get_unique_symtree (gfc_current_ns); 3099 3100 /* Make the symbol. */ 3101 if (p->u.rsym.sym == NULL) 3102 { 3103 p->u.rsym.sym = gfc_new_symbol (p->u.rsym.true_name, 3104 gfc_current_ns); 3105 p->u.rsym.sym->module = gfc_get_string ("%s", p->u.rsym.module); 3106 } 3107 3108 p->u.rsym.symtree->n.sym = p->u.rsym.sym; 3109 p->u.rsym.symtree->n.sym->refs++; 3110 p->u.rsym.referenced = 1; 3111 3112 /* If the symbol is PRIVATE and in COMMON, load_commons will 3113 generate a fixup symbol, which must be associated. */ 3114 if (p->fixup) 3115 resolve_fixups (p->fixup, p->u.rsym.sym); 3116 p->fixup = NULL; 3117 } 3118 3119 if (p->type == P_UNKNOWN) 3120 p->type = P_SYMBOL; 3121 3122 if (p->u.rsym.state == UNUSED) 3123 p->u.rsym.state = NEEDED; 3124 3125 if (p->u.rsym.symtree != NULL) 3126 { 3127 *stp = p->u.rsym.symtree; 3128 } 3129 else 3130 { 3131 f = XCNEW (fixup_t); 3132 3133 f->next = p->u.rsym.stfixup; 3134 p->u.rsym.stfixup = f; 3135 3136 f->pointer = (void **) stp; 3137 } 3138 } 3139 } 3140 3141 3142 static void 3143 mio_iterator (gfc_iterator **ip) 3144 { 3145 gfc_iterator *iter; 3146 3147 mio_lparen (); 3148 3149 if (iomode == IO_OUTPUT) 3150 { 3151 if (*ip == NULL) 3152 goto done; 3153 } 3154 else 3155 { 3156 if (peek_atom () == ATOM_RPAREN) 3157 { 3158 *ip = NULL; 3159 goto done; 3160 } 3161 3162 *ip = gfc_get_iterator (); 3163 } 3164 3165 iter = *ip; 3166 3167 mio_expr (&iter->var); 3168 mio_expr (&iter->start); 3169 mio_expr (&iter->end); 3170 mio_expr (&iter->step); 3171 3172 done: 3173 mio_rparen (); 3174 } 3175 3176 3177 static void 3178 mio_constructor (gfc_constructor_base *cp) 3179 { 3180 gfc_constructor *c; 3181 3182 mio_lparen (); 3183 3184 if (iomode == IO_OUTPUT) 3185 { 3186 for (c = gfc_constructor_first (*cp); c; c = gfc_constructor_next (c)) 3187 { 3188 mio_lparen (); 3189 mio_expr (&c->expr); 3190 mio_iterator (&c->iterator); 3191 mio_rparen (); 3192 } 3193 } 3194 else 3195 { 3196 while (peek_atom () != ATOM_RPAREN) 3197 { 3198 c = gfc_constructor_append_expr (cp, NULL, NULL); 3199 3200 mio_lparen (); 3201 mio_expr (&c->expr); 3202 mio_iterator (&c->iterator); 3203 mio_rparen (); 3204 } 3205 } 3206 3207 mio_rparen (); 3208 } 3209 3210 3211 static const mstring ref_types[] = { 3212 minit ("ARRAY", REF_ARRAY), 3213 minit ("COMPONENT", REF_COMPONENT), 3214 minit ("SUBSTRING", REF_SUBSTRING), 3215 minit ("INQUIRY", REF_INQUIRY), 3216 minit (NULL, -1) 3217 }; 3218 3219 static const mstring inquiry_types[] = { 3220 minit ("RE", INQUIRY_RE), 3221 minit ("IM", INQUIRY_IM), 3222 minit ("KIND", INQUIRY_KIND), 3223 minit ("LEN", INQUIRY_LEN), 3224 minit (NULL, -1) 3225 }; 3226 3227 3228 static void 3229 mio_ref (gfc_ref **rp) 3230 { 3231 gfc_ref *r; 3232 3233 mio_lparen (); 3234 3235 r = *rp; 3236 r->type = MIO_NAME (ref_type) (r->type, ref_types); 3237 3238 switch (r->type) 3239 { 3240 case REF_ARRAY: 3241 mio_array_ref (&r->u.ar); 3242 break; 3243 3244 case REF_COMPONENT: 3245 mio_symbol_ref (&r->u.c.sym); 3246 mio_component_ref (&r->u.c.component); 3247 break; 3248 3249 case REF_SUBSTRING: 3250 mio_expr (&r->u.ss.start); 3251 mio_expr (&r->u.ss.end); 3252 mio_charlen (&r->u.ss.length); 3253 break; 3254 3255 case REF_INQUIRY: 3256 r->u.i = MIO_NAME (inquiry_type) (r->u.i, inquiry_types); 3257 break; 3258 } 3259 3260 mio_rparen (); 3261 } 3262 3263 3264 static void 3265 mio_ref_list (gfc_ref **rp) 3266 { 3267 gfc_ref *ref, *head, *tail; 3268 3269 mio_lparen (); 3270 3271 if (iomode == IO_OUTPUT) 3272 { 3273 for (ref = *rp; ref; ref = ref->next) 3274 mio_ref (&ref); 3275 } 3276 else 3277 { 3278 head = tail = NULL; 3279 3280 while (peek_atom () != ATOM_RPAREN) 3281 { 3282 if (head == NULL) 3283 head = tail = gfc_get_ref (); 3284 else 3285 { 3286 tail->next = gfc_get_ref (); 3287 tail = tail->next; 3288 } 3289 3290 mio_ref (&tail); 3291 } 3292 3293 *rp = head; 3294 } 3295 3296 mio_rparen (); 3297 } 3298 3299 3300 /* Read and write an integer value. */ 3301 3302 static void 3303 mio_gmp_integer (mpz_t *integer) 3304 { 3305 char *p; 3306 3307 if (iomode == IO_INPUT) 3308 { 3309 if (parse_atom () != ATOM_STRING) 3310 bad_module ("Expected integer string"); 3311 3312 mpz_init (*integer); 3313 if (mpz_set_str (*integer, atom_string, 10)) 3314 bad_module ("Error converting integer"); 3315 3316 free (atom_string); 3317 } 3318 else 3319 { 3320 p = mpz_get_str (NULL, 10, *integer); 3321 write_atom (ATOM_STRING, p); 3322 free (p); 3323 } 3324 } 3325 3326 3327 static void 3328 mio_gmp_real (mpfr_t *real) 3329 { 3330 mp_exp_t exponent; 3331 char *p; 3332 3333 if (iomode == IO_INPUT) 3334 { 3335 if (parse_atom () != ATOM_STRING) 3336 bad_module ("Expected real string"); 3337 3338 mpfr_init (*real); 3339 mpfr_set_str (*real, atom_string, 16, GFC_RND_MODE); 3340 free (atom_string); 3341 } 3342 else 3343 { 3344 p = mpfr_get_str (NULL, &exponent, 16, 0, *real, GFC_RND_MODE); 3345 3346 if (mpfr_nan_p (*real) || mpfr_inf_p (*real)) 3347 { 3348 write_atom (ATOM_STRING, p); 3349 free (p); 3350 return; 3351 } 3352 3353 atom_string = XCNEWVEC (char, strlen (p) + 20); 3354 3355 sprintf (atom_string, "0.%s@%ld", p, exponent); 3356 3357 /* Fix negative numbers. */ 3358 if (atom_string[2] == '-') 3359 { 3360 atom_string[0] = '-'; 3361 atom_string[1] = '0'; 3362 atom_string[2] = '.'; 3363 } 3364 3365 write_atom (ATOM_STRING, atom_string); 3366 3367 free (atom_string); 3368 free (p); 3369 } 3370 } 3371 3372 3373 /* Save and restore the shape of an array constructor. */ 3374 3375 static void 3376 mio_shape (mpz_t **pshape, int rank) 3377 { 3378 mpz_t *shape; 3379 atom_type t; 3380 int n; 3381 3382 /* A NULL shape is represented by (). */ 3383 mio_lparen (); 3384 3385 if (iomode == IO_OUTPUT) 3386 { 3387 shape = *pshape; 3388 if (!shape) 3389 { 3390 mio_rparen (); 3391 return; 3392 } 3393 } 3394 else 3395 { 3396 t = peek_atom (); 3397 if (t == ATOM_RPAREN) 3398 { 3399 *pshape = NULL; 3400 mio_rparen (); 3401 return; 3402 } 3403 3404 shape = gfc_get_shape (rank); 3405 *pshape = shape; 3406 } 3407 3408 for (n = 0; n < rank; n++) 3409 mio_gmp_integer (&shape[n]); 3410 3411 mio_rparen (); 3412 } 3413 3414 3415 static const mstring expr_types[] = { 3416 minit ("OP", EXPR_OP), 3417 minit ("FUNCTION", EXPR_FUNCTION), 3418 minit ("CONSTANT", EXPR_CONSTANT), 3419 minit ("VARIABLE", EXPR_VARIABLE), 3420 minit ("SUBSTRING", EXPR_SUBSTRING), 3421 minit ("STRUCTURE", EXPR_STRUCTURE), 3422 minit ("ARRAY", EXPR_ARRAY), 3423 minit ("NULL", EXPR_NULL), 3424 minit ("COMPCALL", EXPR_COMPCALL), 3425 minit (NULL, -1) 3426 }; 3427 3428 /* INTRINSIC_ASSIGN is missing because it is used as an index for 3429 generic operators, not in expressions. INTRINSIC_USER is also 3430 replaced by the correct function name by the time we see it. */ 3431 3432 static const mstring intrinsics[] = 3433 { 3434 minit ("UPLUS", INTRINSIC_UPLUS), 3435 minit ("UMINUS", INTRINSIC_UMINUS), 3436 minit ("PLUS", INTRINSIC_PLUS), 3437 minit ("MINUS", INTRINSIC_MINUS), 3438 minit ("TIMES", INTRINSIC_TIMES), 3439 minit ("DIVIDE", INTRINSIC_DIVIDE), 3440 minit ("POWER", INTRINSIC_POWER), 3441 minit ("CONCAT", INTRINSIC_CONCAT), 3442 minit ("AND", INTRINSIC_AND), 3443 minit ("OR", INTRINSIC_OR), 3444 minit ("EQV", INTRINSIC_EQV), 3445 minit ("NEQV", INTRINSIC_NEQV), 3446 minit ("EQ_SIGN", INTRINSIC_EQ), 3447 minit ("EQ", INTRINSIC_EQ_OS), 3448 minit ("NE_SIGN", INTRINSIC_NE), 3449 minit ("NE", INTRINSIC_NE_OS), 3450 minit ("GT_SIGN", INTRINSIC_GT), 3451 minit ("GT", INTRINSIC_GT_OS), 3452 minit ("GE_SIGN", INTRINSIC_GE), 3453 minit ("GE", INTRINSIC_GE_OS), 3454 minit ("LT_SIGN", INTRINSIC_LT), 3455 minit ("LT", INTRINSIC_LT_OS), 3456 minit ("LE_SIGN", INTRINSIC_LE), 3457 minit ("LE", INTRINSIC_LE_OS), 3458 minit ("NOT", INTRINSIC_NOT), 3459 minit ("PARENTHESES", INTRINSIC_PARENTHESES), 3460 minit ("USER", INTRINSIC_USER), 3461 minit (NULL, -1) 3462 }; 3463 3464 3465 /* Remedy a couple of situations where the gfc_expr's can be defective. */ 3466 3467 static void 3468 fix_mio_expr (gfc_expr *e) 3469 { 3470 gfc_symtree *ns_st = NULL; 3471 const char *fname; 3472 3473 if (iomode != IO_OUTPUT) 3474 return; 3475 3476 if (e->symtree) 3477 { 3478 /* If this is a symtree for a symbol that came from a contained module 3479 namespace, it has a unique name and we should look in the current 3480 namespace to see if the required, non-contained symbol is available 3481 yet. If so, the latter should be written. */ 3482 if (e->symtree->n.sym && check_unique_name (e->symtree->name)) 3483 { 3484 const char *name = e->symtree->n.sym->name; 3485 if (gfc_fl_struct (e->symtree->n.sym->attr.flavor)) 3486 name = gfc_dt_upper_string (name); 3487 ns_st = gfc_find_symtree (gfc_current_ns->sym_root, name); 3488 } 3489 3490 /* On the other hand, if the existing symbol is the module name or the 3491 new symbol is a dummy argument, do not do the promotion. */ 3492 if (ns_st && ns_st->n.sym 3493 && ns_st->n.sym->attr.flavor != FL_MODULE 3494 && !e->symtree->n.sym->attr.dummy) 3495 e->symtree = ns_st; 3496 } 3497 else if (e->expr_type == EXPR_FUNCTION 3498 && (e->value.function.name || e->value.function.isym)) 3499 { 3500 gfc_symbol *sym; 3501 3502 /* In some circumstances, a function used in an initialization 3503 expression, in one use associated module, can fail to be 3504 coupled to its symtree when used in a specification 3505 expression in another module. */ 3506 fname = e->value.function.esym ? e->value.function.esym->name 3507 : e->value.function.isym->name; 3508 e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname); 3509 3510 if (e->symtree) 3511 return; 3512 3513 /* This is probably a reference to a private procedure from another 3514 module. To prevent a segfault, make a generic with no specific 3515 instances. If this module is used, without the required 3516 specific coming from somewhere, the appropriate error message 3517 is issued. */ 3518 gfc_get_symbol (fname, gfc_current_ns, &sym); 3519 sym->attr.flavor = FL_PROCEDURE; 3520 sym->attr.generic = 1; 3521 e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname); 3522 gfc_commit_symbol (sym); 3523 } 3524 } 3525 3526 3527 /* Read and write expressions. The form "()" is allowed to indicate a 3528 NULL expression. */ 3529 3530 static void 3531 mio_expr (gfc_expr **ep) 3532 { 3533 HOST_WIDE_INT hwi; 3534 gfc_expr *e; 3535 atom_type t; 3536 int flag; 3537 3538 mio_lparen (); 3539 3540 if (iomode == IO_OUTPUT) 3541 { 3542 if (*ep == NULL) 3543 { 3544 mio_rparen (); 3545 return; 3546 } 3547 3548 e = *ep; 3549 MIO_NAME (expr_t) (e->expr_type, expr_types); 3550 } 3551 else 3552 { 3553 t = parse_atom (); 3554 if (t == ATOM_RPAREN) 3555 { 3556 *ep = NULL; 3557 return; 3558 } 3559 3560 if (t != ATOM_NAME) 3561 bad_module ("Expected expression type"); 3562 3563 e = *ep = gfc_get_expr (); 3564 e->where = gfc_current_locus; 3565 e->expr_type = (expr_t) find_enum (expr_types); 3566 } 3567 3568 mio_typespec (&e->ts); 3569 mio_integer (&e->rank); 3570 3571 fix_mio_expr (e); 3572 3573 switch (e->expr_type) 3574 { 3575 case EXPR_OP: 3576 e->value.op.op 3577 = MIO_NAME (gfc_intrinsic_op) (e->value.op.op, intrinsics); 3578 3579 switch (e->value.op.op) 3580 { 3581 case INTRINSIC_UPLUS: 3582 case INTRINSIC_UMINUS: 3583 case INTRINSIC_NOT: 3584 case INTRINSIC_PARENTHESES: 3585 mio_expr (&e->value.op.op1); 3586 break; 3587 3588 case INTRINSIC_PLUS: 3589 case INTRINSIC_MINUS: 3590 case INTRINSIC_TIMES: 3591 case INTRINSIC_DIVIDE: 3592 case INTRINSIC_POWER: 3593 case INTRINSIC_CONCAT: 3594 case INTRINSIC_AND: 3595 case INTRINSIC_OR: 3596 case INTRINSIC_EQV: 3597 case INTRINSIC_NEQV: 3598 case INTRINSIC_EQ: 3599 case INTRINSIC_EQ_OS: 3600 case INTRINSIC_NE: 3601 case INTRINSIC_NE_OS: 3602 case INTRINSIC_GT: 3603 case INTRINSIC_GT_OS: 3604 case INTRINSIC_GE: 3605 case INTRINSIC_GE_OS: 3606 case INTRINSIC_LT: 3607 case INTRINSIC_LT_OS: 3608 case INTRINSIC_LE: 3609 case INTRINSIC_LE_OS: 3610 mio_expr (&e->value.op.op1); 3611 mio_expr (&e->value.op.op2); 3612 break; 3613 3614 case INTRINSIC_USER: 3615 /* INTRINSIC_USER should not appear in resolved expressions, 3616 though for UDRs we need to stream unresolved ones. */ 3617 if (iomode == IO_OUTPUT) 3618 write_atom (ATOM_STRING, e->value.op.uop->name); 3619 else 3620 { 3621 char *name = read_string (); 3622 const char *uop_name = find_use_name (name, true); 3623 if (uop_name == NULL) 3624 { 3625 size_t len = strlen (name); 3626 char *name2 = XCNEWVEC (char, len + 2); 3627 memcpy (name2, name, len); 3628 name2[len] = ' '; 3629 name2[len + 1] = '\0'; 3630 free (name); 3631 uop_name = name = name2; 3632 } 3633 e->value.op.uop = gfc_get_uop (uop_name); 3634 free (name); 3635 } 3636 mio_expr (&e->value.op.op1); 3637 mio_expr (&e->value.op.op2); 3638 break; 3639 3640 default: 3641 bad_module ("Bad operator"); 3642 } 3643 3644 break; 3645 3646 case EXPR_FUNCTION: 3647 mio_symtree_ref (&e->symtree); 3648 mio_actual_arglist (&e->value.function.actual, false); 3649 3650 if (iomode == IO_OUTPUT) 3651 { 3652 e->value.function.name 3653 = mio_allocated_string (e->value.function.name); 3654 if (e->value.function.esym) 3655 flag = 1; 3656 else if (e->ref) 3657 flag = 2; 3658 else if (e->value.function.isym == NULL) 3659 flag = 3; 3660 else 3661 flag = 0; 3662 mio_integer (&flag); 3663 switch (flag) 3664 { 3665 case 1: 3666 mio_symbol_ref (&e->value.function.esym); 3667 break; 3668 case 2: 3669 mio_ref_list (&e->ref); 3670 break; 3671 case 3: 3672 break; 3673 default: 3674 write_atom (ATOM_STRING, e->value.function.isym->name); 3675 } 3676 } 3677 else 3678 { 3679 require_atom (ATOM_STRING); 3680 if (atom_string[0] == '\0') 3681 e->value.function.name = NULL; 3682 else 3683 e->value.function.name = gfc_get_string ("%s", atom_string); 3684 free (atom_string); 3685 3686 mio_integer (&flag); 3687 switch (flag) 3688 { 3689 case 1: 3690 mio_symbol_ref (&e->value.function.esym); 3691 break; 3692 case 2: 3693 mio_ref_list (&e->ref); 3694 break; 3695 case 3: 3696 break; 3697 default: 3698 require_atom (ATOM_STRING); 3699 e->value.function.isym = gfc_find_function (atom_string); 3700 free (atom_string); 3701 } 3702 } 3703 3704 break; 3705 3706 case EXPR_VARIABLE: 3707 mio_symtree_ref (&e->symtree); 3708 mio_ref_list (&e->ref); 3709 break; 3710 3711 case EXPR_SUBSTRING: 3712 e->value.character.string 3713 = CONST_CAST (gfc_char_t *, 3714 mio_allocated_wide_string (e->value.character.string, 3715 e->value.character.length)); 3716 mio_ref_list (&e->ref); 3717 break; 3718 3719 case EXPR_STRUCTURE: 3720 case EXPR_ARRAY: 3721 mio_constructor (&e->value.constructor); 3722 mio_shape (&e->shape, e->rank); 3723 break; 3724 3725 case EXPR_CONSTANT: 3726 switch (e->ts.type) 3727 { 3728 case BT_INTEGER: 3729 mio_gmp_integer (&e->value.integer); 3730 break; 3731 3732 case BT_REAL: 3733 gfc_set_model_kind (e->ts.kind); 3734 mio_gmp_real (&e->value.real); 3735 break; 3736 3737 case BT_COMPLEX: 3738 gfc_set_model_kind (e->ts.kind); 3739 mio_gmp_real (&mpc_realref (e->value.complex)); 3740 mio_gmp_real (&mpc_imagref (e->value.complex)); 3741 break; 3742 3743 case BT_LOGICAL: 3744 mio_integer (&e->value.logical); 3745 break; 3746 3747 case BT_CHARACTER: 3748 hwi = e->value.character.length; 3749 mio_hwi (&hwi); 3750 e->value.character.length = hwi; 3751 e->value.character.string 3752 = CONST_CAST (gfc_char_t *, 3753 mio_allocated_wide_string (e->value.character.string, 3754 e->value.character.length)); 3755 break; 3756 3757 default: 3758 bad_module ("Bad type in constant expression"); 3759 } 3760 3761 break; 3762 3763 case EXPR_NULL: 3764 break; 3765 3766 case EXPR_COMPCALL: 3767 case EXPR_PPC: 3768 case EXPR_UNKNOWN: 3769 gcc_unreachable (); 3770 break; 3771 } 3772 3773 /* PDT types store the expression specification list here. */ 3774 mio_actual_arglist (&e->param_list, true); 3775 3776 mio_rparen (); 3777 } 3778 3779 3780 /* Read and write namelists. */ 3781 3782 static void 3783 mio_namelist (gfc_symbol *sym) 3784 { 3785 gfc_namelist *n, *m; 3786 3787 mio_lparen (); 3788 3789 if (iomode == IO_OUTPUT) 3790 { 3791 for (n = sym->namelist; n; n = n->next) 3792 mio_symbol_ref (&n->sym); 3793 } 3794 else 3795 { 3796 m = NULL; 3797 while (peek_atom () != ATOM_RPAREN) 3798 { 3799 n = gfc_get_namelist (); 3800 mio_symbol_ref (&n->sym); 3801 3802 if (sym->namelist == NULL) 3803 sym->namelist = n; 3804 else 3805 m->next = n; 3806 3807 m = n; 3808 } 3809 sym->namelist_tail = m; 3810 } 3811 3812 mio_rparen (); 3813 } 3814 3815 3816 /* Save/restore lists of gfc_interface structures. When loading an 3817 interface, we are really appending to the existing list of 3818 interfaces. Checking for duplicate and ambiguous interfaces has to 3819 be done later when all symbols have been loaded. */ 3820 3821 pointer_info * 3822 mio_interface_rest (gfc_interface **ip) 3823 { 3824 gfc_interface *tail, *p; 3825 pointer_info *pi = NULL; 3826 3827 if (iomode == IO_OUTPUT) 3828 { 3829 if (ip != NULL) 3830 for (p = *ip; p; p = p->next) 3831 mio_symbol_ref (&p->sym); 3832 } 3833 else 3834 { 3835 if (*ip == NULL) 3836 tail = NULL; 3837 else 3838 { 3839 tail = *ip; 3840 while (tail->next) 3841 tail = tail->next; 3842 } 3843 3844 for (;;) 3845 { 3846 if (peek_atom () == ATOM_RPAREN) 3847 break; 3848 3849 p = gfc_get_interface (); 3850 p->where = gfc_current_locus; 3851 pi = mio_symbol_ref (&p->sym); 3852 3853 if (tail == NULL) 3854 *ip = p; 3855 else 3856 tail->next = p; 3857 3858 tail = p; 3859 } 3860 } 3861 3862 mio_rparen (); 3863 return pi; 3864 } 3865 3866 3867 /* Save/restore a nameless operator interface. */ 3868 3869 static void 3870 mio_interface (gfc_interface **ip) 3871 { 3872 mio_lparen (); 3873 mio_interface_rest (ip); 3874 } 3875 3876 3877 /* Save/restore a named operator interface. */ 3878 3879 static void 3880 mio_symbol_interface (const char **name, const char **module, 3881 gfc_interface **ip) 3882 { 3883 mio_lparen (); 3884 mio_pool_string (name); 3885 mio_pool_string (module); 3886 mio_interface_rest (ip); 3887 } 3888 3889 3890 static void 3891 mio_namespace_ref (gfc_namespace **nsp) 3892 { 3893 gfc_namespace *ns; 3894 pointer_info *p; 3895 3896 p = mio_pointer_ref (nsp); 3897 3898 if (p->type == P_UNKNOWN) 3899 p->type = P_NAMESPACE; 3900 3901 if (iomode == IO_INPUT && p->integer != 0) 3902 { 3903 ns = (gfc_namespace *) p->u.pointer; 3904 if (ns == NULL) 3905 { 3906 ns = gfc_get_namespace (NULL, 0); 3907 associate_integer_pointer (p, ns); 3908 } 3909 else 3910 ns->refs++; 3911 } 3912 } 3913 3914 3915 /* Save/restore the f2k_derived namespace of a derived-type symbol. */ 3916 3917 static gfc_namespace* current_f2k_derived; 3918 3919 static void 3920 mio_typebound_proc (gfc_typebound_proc** proc) 3921 { 3922 int flag; 3923 int overriding_flag; 3924 3925 if (iomode == IO_INPUT) 3926 { 3927 *proc = gfc_get_typebound_proc (NULL); 3928 (*proc)->where = gfc_current_locus; 3929 } 3930 gcc_assert (*proc); 3931 3932 mio_lparen (); 3933 3934 (*proc)->access = MIO_NAME (gfc_access) ((*proc)->access, access_types); 3935 3936 /* IO the NON_OVERRIDABLE/DEFERRED combination. */ 3937 gcc_assert (!((*proc)->deferred && (*proc)->non_overridable)); 3938 overriding_flag = ((*proc)->deferred << 1) | (*proc)->non_overridable; 3939 overriding_flag = mio_name (overriding_flag, binding_overriding); 3940 (*proc)->deferred = ((overriding_flag & 2) != 0); 3941 (*proc)->non_overridable = ((overriding_flag & 1) != 0); 3942 gcc_assert (!((*proc)->deferred && (*proc)->non_overridable)); 3943 3944 (*proc)->nopass = mio_name ((*proc)->nopass, binding_passing); 3945 (*proc)->is_generic = mio_name ((*proc)->is_generic, binding_generic); 3946 (*proc)->ppc = mio_name((*proc)->ppc, binding_ppc); 3947 3948 mio_pool_string (&((*proc)->pass_arg)); 3949 3950 flag = (int) (*proc)->pass_arg_num; 3951 mio_integer (&flag); 3952 (*proc)->pass_arg_num = (unsigned) flag; 3953 3954 if ((*proc)->is_generic) 3955 { 3956 gfc_tbp_generic* g; 3957 int iop; 3958 3959 mio_lparen (); 3960 3961 if (iomode == IO_OUTPUT) 3962 for (g = (*proc)->u.generic; g; g = g->next) 3963 { 3964 iop = (int) g->is_operator; 3965 mio_integer (&iop); 3966 mio_allocated_string (g->specific_st->name); 3967 } 3968 else 3969 { 3970 (*proc)->u.generic = NULL; 3971 while (peek_atom () != ATOM_RPAREN) 3972 { 3973 gfc_symtree** sym_root; 3974 3975 g = gfc_get_tbp_generic (); 3976 g->specific = NULL; 3977 3978 mio_integer (&iop); 3979 g->is_operator = (bool) iop; 3980 3981 require_atom (ATOM_STRING); 3982 sym_root = ¤t_f2k_derived->tb_sym_root; 3983 g->specific_st = gfc_get_tbp_symtree (sym_root, atom_string); 3984 free (atom_string); 3985 3986 g->next = (*proc)->u.generic; 3987 (*proc)->u.generic = g; 3988 } 3989 } 3990 3991 mio_rparen (); 3992 } 3993 else if (!(*proc)->ppc) 3994 mio_symtree_ref (&(*proc)->u.specific); 3995 3996 mio_rparen (); 3997 } 3998 3999 /* Walker-callback function for this purpose. */ 4000 static void 4001 mio_typebound_symtree (gfc_symtree* st) 4002 { 4003 if (iomode == IO_OUTPUT && !st->n.tb) 4004 return; 4005 4006 if (iomode == IO_OUTPUT) 4007 { 4008 mio_lparen (); 4009 mio_allocated_string (st->name); 4010 } 4011 /* For IO_INPUT, the above is done in mio_f2k_derived. */ 4012 4013 mio_typebound_proc (&st->n.tb); 4014 mio_rparen (); 4015 } 4016 4017 /* IO a full symtree (in all depth). */ 4018 static void 4019 mio_full_typebound_tree (gfc_symtree** root) 4020 { 4021 mio_lparen (); 4022 4023 if (iomode == IO_OUTPUT) 4024 gfc_traverse_symtree (*root, &mio_typebound_symtree); 4025 else 4026 { 4027 while (peek_atom () == ATOM_LPAREN) 4028 { 4029 gfc_symtree* st; 4030 4031 mio_lparen (); 4032 4033 require_atom (ATOM_STRING); 4034 st = gfc_get_tbp_symtree (root, atom_string); 4035 free (atom_string); 4036 4037 mio_typebound_symtree (st); 4038 } 4039 } 4040 4041 mio_rparen (); 4042 } 4043 4044 static void 4045 mio_finalizer (gfc_finalizer **f) 4046 { 4047 if (iomode == IO_OUTPUT) 4048 { 4049 gcc_assert (*f); 4050 gcc_assert ((*f)->proc_tree); /* Should already be resolved. */ 4051 mio_symtree_ref (&(*f)->proc_tree); 4052 } 4053 else 4054 { 4055 *f = gfc_get_finalizer (); 4056 (*f)->where = gfc_current_locus; /* Value should not matter. */ 4057 (*f)->next = NULL; 4058 4059 mio_symtree_ref (&(*f)->proc_tree); 4060 (*f)->proc_sym = NULL; 4061 } 4062 } 4063 4064 static void 4065 mio_f2k_derived (gfc_namespace *f2k) 4066 { 4067 current_f2k_derived = f2k; 4068 4069 /* Handle the list of finalizer procedures. */ 4070 mio_lparen (); 4071 if (iomode == IO_OUTPUT) 4072 { 4073 gfc_finalizer *f; 4074 for (f = f2k->finalizers; f; f = f->next) 4075 mio_finalizer (&f); 4076 } 4077 else 4078 { 4079 f2k->finalizers = NULL; 4080 while (peek_atom () != ATOM_RPAREN) 4081 { 4082 gfc_finalizer *cur = NULL; 4083 mio_finalizer (&cur); 4084 cur->next = f2k->finalizers; 4085 f2k->finalizers = cur; 4086 } 4087 } 4088 mio_rparen (); 4089 4090 /* Handle type-bound procedures. */ 4091 mio_full_typebound_tree (&f2k->tb_sym_root); 4092 4093 /* Type-bound user operators. */ 4094 mio_full_typebound_tree (&f2k->tb_uop_root); 4095 4096 /* Type-bound intrinsic operators. */ 4097 mio_lparen (); 4098 if (iomode == IO_OUTPUT) 4099 { 4100 int op; 4101 for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; ++op) 4102 { 4103 gfc_intrinsic_op realop; 4104 4105 if (op == INTRINSIC_USER || !f2k->tb_op[op]) 4106 continue; 4107 4108 mio_lparen (); 4109 realop = (gfc_intrinsic_op) op; 4110 mio_intrinsic_op (&realop); 4111 mio_typebound_proc (&f2k->tb_op[op]); 4112 mio_rparen (); 4113 } 4114 } 4115 else 4116 while (peek_atom () != ATOM_RPAREN) 4117 { 4118 gfc_intrinsic_op op = GFC_INTRINSIC_BEGIN; /* Silence GCC. */ 4119 4120 mio_lparen (); 4121 mio_intrinsic_op (&op); 4122 mio_typebound_proc (&f2k->tb_op[op]); 4123 mio_rparen (); 4124 } 4125 mio_rparen (); 4126 } 4127 4128 static void 4129 mio_full_f2k_derived (gfc_symbol *sym) 4130 { 4131 mio_lparen (); 4132 4133 if (iomode == IO_OUTPUT) 4134 { 4135 if (sym->f2k_derived) 4136 mio_f2k_derived (sym->f2k_derived); 4137 } 4138 else 4139 { 4140 if (peek_atom () != ATOM_RPAREN) 4141 { 4142 gfc_namespace *ns; 4143 4144 sym->f2k_derived = gfc_get_namespace (NULL, 0); 4145 4146 /* PDT templates make use of the mechanisms for formal args 4147 and so the parameter symbols are stored in the formal 4148 namespace. Transfer the sym_root to f2k_derived and then 4149 free the formal namespace since it is uneeded. */ 4150 if (sym->attr.pdt_template && sym->formal && sym->formal->sym) 4151 { 4152 ns = sym->formal->sym->ns; 4153 sym->f2k_derived->sym_root = ns->sym_root; 4154 ns->sym_root = NULL; 4155 ns->refs++; 4156 gfc_free_namespace (ns); 4157 ns = NULL; 4158 } 4159 4160 mio_f2k_derived (sym->f2k_derived); 4161 } 4162 else 4163 gcc_assert (!sym->f2k_derived); 4164 } 4165 4166 mio_rparen (); 4167 } 4168 4169 static const mstring omp_declare_simd_clauses[] = 4170 { 4171 minit ("INBRANCH", 0), 4172 minit ("NOTINBRANCH", 1), 4173 minit ("SIMDLEN", 2), 4174 minit ("UNIFORM", 3), 4175 minit ("LINEAR", 4), 4176 minit ("ALIGNED", 5), 4177 minit ("LINEAR_REF", 33), 4178 minit ("LINEAR_VAL", 34), 4179 minit ("LINEAR_UVAL", 35), 4180 minit (NULL, -1) 4181 }; 4182 4183 /* Handle !$omp declare simd. */ 4184 4185 static void 4186 mio_omp_declare_simd (gfc_namespace *ns, gfc_omp_declare_simd **odsp) 4187 { 4188 if (iomode == IO_OUTPUT) 4189 { 4190 if (*odsp == NULL) 4191 return; 4192 } 4193 else if (peek_atom () != ATOM_LPAREN) 4194 return; 4195 4196 gfc_omp_declare_simd *ods = *odsp; 4197 4198 mio_lparen (); 4199 if (iomode == IO_OUTPUT) 4200 { 4201 write_atom (ATOM_NAME, "OMP_DECLARE_SIMD"); 4202 if (ods->clauses) 4203 { 4204 gfc_omp_namelist *n; 4205 4206 if (ods->clauses->inbranch) 4207 mio_name (0, omp_declare_simd_clauses); 4208 if (ods->clauses->notinbranch) 4209 mio_name (1, omp_declare_simd_clauses); 4210 if (ods->clauses->simdlen_expr) 4211 { 4212 mio_name (2, omp_declare_simd_clauses); 4213 mio_expr (&ods->clauses->simdlen_expr); 4214 } 4215 for (n = ods->clauses->lists[OMP_LIST_UNIFORM]; n; n = n->next) 4216 { 4217 mio_name (3, omp_declare_simd_clauses); 4218 mio_symbol_ref (&n->sym); 4219 } 4220 for (n = ods->clauses->lists[OMP_LIST_LINEAR]; n; n = n->next) 4221 { 4222 if (n->u.linear_op == OMP_LINEAR_DEFAULT) 4223 mio_name (4, omp_declare_simd_clauses); 4224 else 4225 mio_name (32 + n->u.linear_op, omp_declare_simd_clauses); 4226 mio_symbol_ref (&n->sym); 4227 mio_expr (&n->expr); 4228 } 4229 for (n = ods->clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next) 4230 { 4231 mio_name (5, omp_declare_simd_clauses); 4232 mio_symbol_ref (&n->sym); 4233 mio_expr (&n->expr); 4234 } 4235 } 4236 } 4237 else 4238 { 4239 gfc_omp_namelist **ptrs[3] = { NULL, NULL, NULL }; 4240 4241 require_atom (ATOM_NAME); 4242 *odsp = ods = gfc_get_omp_declare_simd (); 4243 ods->where = gfc_current_locus; 4244 ods->proc_name = ns->proc_name; 4245 if (peek_atom () == ATOM_NAME) 4246 { 4247 ods->clauses = gfc_get_omp_clauses (); 4248 ptrs[0] = &ods->clauses->lists[OMP_LIST_UNIFORM]; 4249 ptrs[1] = &ods->clauses->lists[OMP_LIST_LINEAR]; 4250 ptrs[2] = &ods->clauses->lists[OMP_LIST_ALIGNED]; 4251 } 4252 while (peek_atom () == ATOM_NAME) 4253 { 4254 gfc_omp_namelist *n; 4255 int t = mio_name (0, omp_declare_simd_clauses); 4256 4257 switch (t) 4258 { 4259 case 0: ods->clauses->inbranch = true; break; 4260 case 1: ods->clauses->notinbranch = true; break; 4261 case 2: mio_expr (&ods->clauses->simdlen_expr); break; 4262 case 3: 4263 case 4: 4264 case 5: 4265 *ptrs[t - 3] = n = gfc_get_omp_namelist (); 4266 finish_namelist: 4267 n->where = gfc_current_locus; 4268 ptrs[t - 3] = &n->next; 4269 mio_symbol_ref (&n->sym); 4270 if (t != 3) 4271 mio_expr (&n->expr); 4272 break; 4273 case 33: 4274 case 34: 4275 case 35: 4276 *ptrs[1] = n = gfc_get_omp_namelist (); 4277 n->u.linear_op = (enum gfc_omp_linear_op) (t - 32); 4278 t = 4; 4279 goto finish_namelist; 4280 } 4281 } 4282 } 4283 4284 mio_omp_declare_simd (ns, &ods->next); 4285 4286 mio_rparen (); 4287 } 4288 4289 4290 static const mstring omp_declare_reduction_stmt[] = 4291 { 4292 minit ("ASSIGN", 0), 4293 minit ("CALL", 1), 4294 minit (NULL, -1) 4295 }; 4296 4297 4298 static void 4299 mio_omp_udr_expr (gfc_omp_udr *udr, gfc_symbol **sym1, gfc_symbol **sym2, 4300 gfc_namespace *ns, bool is_initializer) 4301 { 4302 if (iomode == IO_OUTPUT) 4303 { 4304 if ((*sym1)->module == NULL) 4305 { 4306 (*sym1)->module = module_name; 4307 (*sym2)->module = module_name; 4308 } 4309 mio_symbol_ref (sym1); 4310 mio_symbol_ref (sym2); 4311 if (ns->code->op == EXEC_ASSIGN) 4312 { 4313 mio_name (0, omp_declare_reduction_stmt); 4314 mio_expr (&ns->code->expr1); 4315 mio_expr (&ns->code->expr2); 4316 } 4317 else 4318 { 4319 int flag; 4320 mio_name (1, omp_declare_reduction_stmt); 4321 mio_symtree_ref (&ns->code->symtree); 4322 mio_actual_arglist (&ns->code->ext.actual, false); 4323 4324 flag = ns->code->resolved_isym != NULL; 4325 mio_integer (&flag); 4326 if (flag) 4327 write_atom (ATOM_STRING, ns->code->resolved_isym->name); 4328 else 4329 mio_symbol_ref (&ns->code->resolved_sym); 4330 } 4331 } 4332 else 4333 { 4334 pointer_info *p1 = mio_symbol_ref (sym1); 4335 pointer_info *p2 = mio_symbol_ref (sym2); 4336 gfc_symbol *sym; 4337 gcc_assert (p1->u.rsym.ns == p2->u.rsym.ns); 4338 gcc_assert (p1->u.rsym.sym == NULL); 4339 /* Add hidden symbols to the symtree. */ 4340 pointer_info *q = get_integer (p1->u.rsym.ns); 4341 q->u.pointer = (void *) ns; 4342 sym = gfc_new_symbol (is_initializer ? "omp_priv" : "omp_out", ns); 4343 sym->ts = udr->ts; 4344 sym->module = gfc_get_string ("%s", p1->u.rsym.module); 4345 associate_integer_pointer (p1, sym); 4346 sym->attr.omp_udr_artificial_var = 1; 4347 gcc_assert (p2->u.rsym.sym == NULL); 4348 sym = gfc_new_symbol (is_initializer ? "omp_orig" : "omp_in", ns); 4349 sym->ts = udr->ts; 4350 sym->module = gfc_get_string ("%s", p2->u.rsym.module); 4351 associate_integer_pointer (p2, sym); 4352 sym->attr.omp_udr_artificial_var = 1; 4353 if (mio_name (0, omp_declare_reduction_stmt) == 0) 4354 { 4355 ns->code = gfc_get_code (EXEC_ASSIGN); 4356 mio_expr (&ns->code->expr1); 4357 mio_expr (&ns->code->expr2); 4358 } 4359 else 4360 { 4361 int flag; 4362 ns->code = gfc_get_code (EXEC_CALL); 4363 mio_symtree_ref (&ns->code->symtree); 4364 mio_actual_arglist (&ns->code->ext.actual, false); 4365 4366 mio_integer (&flag); 4367 if (flag) 4368 { 4369 require_atom (ATOM_STRING); 4370 ns->code->resolved_isym = gfc_find_subroutine (atom_string); 4371 free (atom_string); 4372 } 4373 else 4374 mio_symbol_ref (&ns->code->resolved_sym); 4375 } 4376 ns->code->loc = gfc_current_locus; 4377 ns->omp_udr_ns = 1; 4378 } 4379 } 4380 4381 4382 /* Unlike most other routines, the address of the symbol node is already 4383 fixed on input and the name/module has already been filled in. 4384 If you update the symbol format here, don't forget to update read_module 4385 as well (look for "seek to the symbol's component list"). */ 4386 4387 static void 4388 mio_symbol (gfc_symbol *sym) 4389 { 4390 int intmod = INTMOD_NONE; 4391 4392 mio_lparen (); 4393 4394 mio_symbol_attribute (&sym->attr); 4395 4396 /* Note that components are always saved, even if they are supposed 4397 to be private. Component access is checked during searching. */ 4398 mio_component_list (&sym->components, sym->attr.vtype); 4399 if (sym->components != NULL) 4400 sym->component_access 4401 = MIO_NAME (gfc_access) (sym->component_access, access_types); 4402 4403 mio_typespec (&sym->ts); 4404 if (sym->ts.type == BT_CLASS) 4405 sym->attr.class_ok = 1; 4406 4407 if (iomode == IO_OUTPUT) 4408 mio_namespace_ref (&sym->formal_ns); 4409 else 4410 { 4411 mio_namespace_ref (&sym->formal_ns); 4412 if (sym->formal_ns) 4413 sym->formal_ns->proc_name = sym; 4414 } 4415 4416 /* Save/restore common block links. */ 4417 mio_symbol_ref (&sym->common_next); 4418 4419 mio_formal_arglist (&sym->formal); 4420 4421 if (sym->attr.flavor == FL_PARAMETER) 4422 mio_expr (&sym->value); 4423 4424 mio_array_spec (&sym->as); 4425 4426 mio_symbol_ref (&sym->result); 4427 4428 if (sym->attr.cray_pointee) 4429 mio_symbol_ref (&sym->cp_pointer); 4430 4431 /* Load/save the f2k_derived namespace of a derived-type symbol. */ 4432 mio_full_f2k_derived (sym); 4433 4434 /* PDT types store the symbol specification list here. */ 4435 mio_actual_arglist (&sym->param_list, true); 4436 4437 mio_namelist (sym); 4438 4439 /* Add the fields that say whether this is from an intrinsic module, 4440 and if so, what symbol it is within the module. */ 4441 /* mio_integer (&(sym->from_intmod)); */ 4442 if (iomode == IO_OUTPUT) 4443 { 4444 intmod = sym->from_intmod; 4445 mio_integer (&intmod); 4446 } 4447 else 4448 { 4449 mio_integer (&intmod); 4450 if (current_intmod) 4451 sym->from_intmod = current_intmod; 4452 else 4453 sym->from_intmod = (intmod_id) intmod; 4454 } 4455 4456 mio_integer (&(sym->intmod_sym_id)); 4457 4458 if (gfc_fl_struct (sym->attr.flavor)) 4459 mio_integer (&(sym->hash_value)); 4460 4461 if (sym->formal_ns 4462 && sym->formal_ns->proc_name == sym 4463 && sym->formal_ns->entries == NULL) 4464 mio_omp_declare_simd (sym->formal_ns, &sym->formal_ns->omp_declare_simd); 4465 4466 mio_rparen (); 4467 } 4468 4469 4470 /************************* Top level subroutines *************************/ 4471 4472 /* A recursive function to look for a specific symbol by name and by 4473 module. Whilst several symtrees might point to one symbol, its 4474 is sufficient for the purposes here than one exist. Note that 4475 generic interfaces are distinguished as are symbols that have been 4476 renamed in another module. */ 4477 static gfc_symtree * 4478 find_symbol (gfc_symtree *st, const char *name, 4479 const char *module, int generic) 4480 { 4481 int c; 4482 gfc_symtree *retval, *s; 4483 4484 if (st == NULL || st->n.sym == NULL) 4485 return NULL; 4486 4487 c = strcmp (name, st->n.sym->name); 4488 if (c == 0 && st->n.sym->module 4489 && strcmp (module, st->n.sym->module) == 0 4490 && !check_unique_name (st->name)) 4491 { 4492 s = gfc_find_symtree (gfc_current_ns->sym_root, name); 4493 4494 /* Detect symbols that are renamed by use association in another 4495 module by the absence of a symtree and null attr.use_rename, 4496 since the latter is not transmitted in the module file. */ 4497 if (((!generic && !st->n.sym->attr.generic) 4498 || (generic && st->n.sym->attr.generic)) 4499 && !(s == NULL && !st->n.sym->attr.use_rename)) 4500 return st; 4501 } 4502 4503 retval = find_symbol (st->left, name, module, generic); 4504 4505 if (retval == NULL) 4506 retval = find_symbol (st->right, name, module, generic); 4507 4508 return retval; 4509 } 4510 4511 4512 /* Skip a list between balanced left and right parens. 4513 By setting NEST_LEVEL one assumes that a number of NEST_LEVEL opening parens 4514 have been already parsed by hand, and the remaining of the content is to be 4515 skipped here. The default value is 0 (balanced parens). */ 4516 4517 static void 4518 skip_list (int nest_level = 0) 4519 { 4520 int level; 4521 4522 level = nest_level; 4523 do 4524 { 4525 switch (parse_atom ()) 4526 { 4527 case ATOM_LPAREN: 4528 level++; 4529 break; 4530 4531 case ATOM_RPAREN: 4532 level--; 4533 break; 4534 4535 case ATOM_STRING: 4536 free (atom_string); 4537 break; 4538 4539 case ATOM_NAME: 4540 case ATOM_INTEGER: 4541 break; 4542 } 4543 } 4544 while (level > 0); 4545 } 4546 4547 4548 /* Load operator interfaces from the module. Interfaces are unusual 4549 in that they attach themselves to existing symbols. */ 4550 4551 static void 4552 load_operator_interfaces (void) 4553 { 4554 const char *p; 4555 char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1]; 4556 gfc_user_op *uop; 4557 pointer_info *pi = NULL; 4558 int n, i; 4559 4560 mio_lparen (); 4561 4562 while (peek_atom () != ATOM_RPAREN) 4563 { 4564 mio_lparen (); 4565 4566 mio_internal_string (name); 4567 mio_internal_string (module); 4568 4569 n = number_use_names (name, true); 4570 n = n ? n : 1; 4571 4572 for (i = 1; i <= n; i++) 4573 { 4574 /* Decide if we need to load this one or not. */ 4575 p = find_use_name_n (name, &i, true); 4576 4577 if (p == NULL) 4578 { 4579 while (parse_atom () != ATOM_RPAREN); 4580 continue; 4581 } 4582 4583 if (i == 1) 4584 { 4585 uop = gfc_get_uop (p); 4586 pi = mio_interface_rest (&uop->op); 4587 } 4588 else 4589 { 4590 if (gfc_find_uop (p, NULL)) 4591 continue; 4592 uop = gfc_get_uop (p); 4593 uop->op = gfc_get_interface (); 4594 uop->op->where = gfc_current_locus; 4595 add_fixup (pi->integer, &uop->op->sym); 4596 } 4597 } 4598 } 4599 4600 mio_rparen (); 4601 } 4602 4603 4604 /* Load interfaces from the module. Interfaces are unusual in that 4605 they attach themselves to existing symbols. */ 4606 4607 static void 4608 load_generic_interfaces (void) 4609 { 4610 const char *p; 4611 char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1]; 4612 gfc_symbol *sym; 4613 gfc_interface *generic = NULL, *gen = NULL; 4614 int n, i, renamed; 4615 bool ambiguous_set = false; 4616 4617 mio_lparen (); 4618 4619 while (peek_atom () != ATOM_RPAREN) 4620 { 4621 mio_lparen (); 4622 4623 mio_internal_string (name); 4624 mio_internal_string (module); 4625 4626 n = number_use_names (name, false); 4627 renamed = n ? 1 : 0; 4628 n = n ? n : 1; 4629 4630 for (i = 1; i <= n; i++) 4631 { 4632 gfc_symtree *st; 4633 /* Decide if we need to load this one or not. */ 4634 p = find_use_name_n (name, &i, false); 4635 4636 if (!p || gfc_find_symbol (p, NULL, 0, &sym)) 4637 { 4638 /* Skip the specific names for these cases. */ 4639 while (i == 1 && parse_atom () != ATOM_RPAREN); 4640 4641 continue; 4642 } 4643 4644 st = find_symbol (gfc_current_ns->sym_root, 4645 name, module_name, 1); 4646 4647 /* If the symbol exists already and is being USEd without being 4648 in an ONLY clause, do not load a new symtree(11.3.2). */ 4649 if (!only_flag && st) 4650 sym = st->n.sym; 4651 4652 if (!sym) 4653 { 4654 if (st) 4655 { 4656 sym = st->n.sym; 4657 if (strcmp (st->name, p) != 0) 4658 { 4659 st = gfc_new_symtree (&gfc_current_ns->sym_root, p); 4660 st->n.sym = sym; 4661 sym->refs++; 4662 } 4663 } 4664 4665 /* Since we haven't found a valid generic interface, we had 4666 better make one. */ 4667 if (!sym) 4668 { 4669 gfc_get_symbol (p, NULL, &sym); 4670 sym->name = gfc_get_string ("%s", name); 4671 sym->module = module_name; 4672 sym->attr.flavor = FL_PROCEDURE; 4673 sym->attr.generic = 1; 4674 sym->attr.use_assoc = 1; 4675 } 4676 } 4677 else 4678 { 4679 /* Unless sym is a generic interface, this reference 4680 is ambiguous. */ 4681 if (st == NULL) 4682 st = gfc_find_symtree (gfc_current_ns->sym_root, p); 4683 4684 sym = st->n.sym; 4685 4686 if (st && !sym->attr.generic 4687 && !st->ambiguous 4688 && sym->module 4689 && strcmp (module, sym->module)) 4690 { 4691 ambiguous_set = true; 4692 st->ambiguous = 1; 4693 } 4694 } 4695 4696 sym->attr.use_only = only_flag; 4697 sym->attr.use_rename = renamed; 4698 4699 if (i == 1) 4700 { 4701 mio_interface_rest (&sym->generic); 4702 generic = sym->generic; 4703 } 4704 else if (!sym->generic) 4705 { 4706 sym->generic = generic; 4707 sym->attr.generic_copy = 1; 4708 } 4709 4710 /* If a procedure that is not generic has generic interfaces 4711 that include itself, it is generic! We need to take care 4712 to retain symbols ambiguous that were already so. */ 4713 if (sym->attr.use_assoc 4714 && !sym->attr.generic 4715 && sym->attr.flavor == FL_PROCEDURE) 4716 { 4717 for (gen = generic; gen; gen = gen->next) 4718 { 4719 if (gen->sym == sym) 4720 { 4721 sym->attr.generic = 1; 4722 if (ambiguous_set) 4723 st->ambiguous = 0; 4724 break; 4725 } 4726 } 4727 } 4728 4729 } 4730 } 4731 4732 mio_rparen (); 4733 } 4734 4735 4736 /* Load common blocks. */ 4737 4738 static void 4739 load_commons (void) 4740 { 4741 char name[GFC_MAX_SYMBOL_LEN + 1]; 4742 gfc_common_head *p; 4743 4744 mio_lparen (); 4745 4746 while (peek_atom () != ATOM_RPAREN) 4747 { 4748 int flags; 4749 char* label; 4750 mio_lparen (); 4751 mio_internal_string (name); 4752 4753 p = gfc_get_common (name, 1); 4754 4755 mio_symbol_ref (&p->head); 4756 mio_integer (&flags); 4757 if (flags & 1) 4758 p->saved = 1; 4759 if (flags & 2) 4760 p->threadprivate = 1; 4761 p->use_assoc = 1; 4762 4763 /* Get whether this was a bind(c) common or not. */ 4764 mio_integer (&p->is_bind_c); 4765 /* Get the binding label. */ 4766 label = read_string (); 4767 if (strlen (label)) 4768 p->binding_label = IDENTIFIER_POINTER (get_identifier (label)); 4769 XDELETEVEC (label); 4770 4771 mio_rparen (); 4772 } 4773 4774 mio_rparen (); 4775 } 4776 4777 4778 /* Load equivalences. The flag in_load_equiv informs mio_expr_ref of this 4779 so that unused variables are not loaded and so that the expression can 4780 be safely freed. */ 4781 4782 static void 4783 load_equiv (void) 4784 { 4785 gfc_equiv *head, *tail, *end, *eq, *equiv; 4786 bool duplicate; 4787 4788 mio_lparen (); 4789 in_load_equiv = true; 4790 4791 end = gfc_current_ns->equiv; 4792 while (end != NULL && end->next != NULL) 4793 end = end->next; 4794 4795 while (peek_atom () != ATOM_RPAREN) { 4796 mio_lparen (); 4797 head = tail = NULL; 4798 4799 while(peek_atom () != ATOM_RPAREN) 4800 { 4801 if (head == NULL) 4802 head = tail = gfc_get_equiv (); 4803 else 4804 { 4805 tail->eq = gfc_get_equiv (); 4806 tail = tail->eq; 4807 } 4808 4809 mio_pool_string (&tail->module); 4810 mio_expr (&tail->expr); 4811 } 4812 4813 /* Check for duplicate equivalences being loaded from different modules */ 4814 duplicate = false; 4815 for (equiv = gfc_current_ns->equiv; equiv; equiv = equiv->next) 4816 { 4817 if (equiv->module && head->module 4818 && strcmp (equiv->module, head->module) == 0) 4819 { 4820 duplicate = true; 4821 break; 4822 } 4823 } 4824 4825 if (duplicate) 4826 { 4827 for (eq = head; eq; eq = head) 4828 { 4829 head = eq->eq; 4830 gfc_free_expr (eq->expr); 4831 free (eq); 4832 } 4833 } 4834 4835 if (end == NULL) 4836 gfc_current_ns->equiv = head; 4837 else 4838 end->next = head; 4839 4840 if (head != NULL) 4841 end = head; 4842 4843 mio_rparen (); 4844 } 4845 4846 mio_rparen (); 4847 in_load_equiv = false; 4848 } 4849 4850 4851 /* This function loads OpenMP user defined reductions. */ 4852 static void 4853 load_omp_udrs (void) 4854 { 4855 mio_lparen (); 4856 while (peek_atom () != ATOM_RPAREN) 4857 { 4858 const char *name = NULL, *newname; 4859 char *altname; 4860 gfc_typespec ts; 4861 gfc_symtree *st; 4862 gfc_omp_reduction_op rop = OMP_REDUCTION_USER; 4863 4864 mio_lparen (); 4865 mio_pool_string (&name); 4866 gfc_clear_ts (&ts); 4867 mio_typespec (&ts); 4868 if (gfc_str_startswith (name, "operator ")) 4869 { 4870 const char *p = name + sizeof ("operator ") - 1; 4871 if (strcmp (p, "+") == 0) 4872 rop = OMP_REDUCTION_PLUS; 4873 else if (strcmp (p, "*") == 0) 4874 rop = OMP_REDUCTION_TIMES; 4875 else if (strcmp (p, "-") == 0) 4876 rop = OMP_REDUCTION_MINUS; 4877 else if (strcmp (p, ".and.") == 0) 4878 rop = OMP_REDUCTION_AND; 4879 else if (strcmp (p, ".or.") == 0) 4880 rop = OMP_REDUCTION_OR; 4881 else if (strcmp (p, ".eqv.") == 0) 4882 rop = OMP_REDUCTION_EQV; 4883 else if (strcmp (p, ".neqv.") == 0) 4884 rop = OMP_REDUCTION_NEQV; 4885 } 4886 altname = NULL; 4887 if (rop == OMP_REDUCTION_USER && name[0] == '.') 4888 { 4889 size_t len = strlen (name + 1); 4890 altname = XALLOCAVEC (char, len); 4891 gcc_assert (name[len] == '.'); 4892 memcpy (altname, name + 1, len - 1); 4893 altname[len - 1] = '\0'; 4894 } 4895 newname = name; 4896 if (rop == OMP_REDUCTION_USER) 4897 newname = find_use_name (altname ? altname : name, !!altname); 4898 else if (only_flag && find_use_operator ((gfc_intrinsic_op) rop) == NULL) 4899 newname = NULL; 4900 if (newname == NULL) 4901 { 4902 skip_list (1); 4903 continue; 4904 } 4905 if (altname && newname != altname) 4906 { 4907 size_t len = strlen (newname); 4908 altname = XALLOCAVEC (char, len + 3); 4909 altname[0] = '.'; 4910 memcpy (altname + 1, newname, len); 4911 altname[len + 1] = '.'; 4912 altname[len + 2] = '\0'; 4913 name = gfc_get_string ("%s", altname); 4914 } 4915 st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name); 4916 gfc_omp_udr *udr = gfc_omp_udr_find (st, &ts); 4917 if (udr) 4918 { 4919 require_atom (ATOM_INTEGER); 4920 pointer_info *p = get_integer (atom_int); 4921 if (strcmp (p->u.rsym.module, udr->omp_out->module)) 4922 { 4923 gfc_error ("Ambiguous !$OMP DECLARE REDUCTION from " 4924 "module %s at %L", 4925 p->u.rsym.module, &gfc_current_locus); 4926 gfc_error ("Previous !$OMP DECLARE REDUCTION from module " 4927 "%s at %L", 4928 udr->omp_out->module, &udr->where); 4929 } 4930 skip_list (1); 4931 continue; 4932 } 4933 udr = gfc_get_omp_udr (); 4934 udr->name = name; 4935 udr->rop = rop; 4936 udr->ts = ts; 4937 udr->where = gfc_current_locus; 4938 udr->combiner_ns = gfc_get_namespace (gfc_current_ns, 1); 4939 udr->combiner_ns->proc_name = gfc_current_ns->proc_name; 4940 mio_omp_udr_expr (udr, &udr->omp_out, &udr->omp_in, udr->combiner_ns, 4941 false); 4942 if (peek_atom () != ATOM_RPAREN) 4943 { 4944 udr->initializer_ns = gfc_get_namespace (gfc_current_ns, 1); 4945 udr->initializer_ns->proc_name = gfc_current_ns->proc_name; 4946 mio_omp_udr_expr (udr, &udr->omp_priv, &udr->omp_orig, 4947 udr->initializer_ns, true); 4948 } 4949 if (st) 4950 { 4951 udr->next = st->n.omp_udr; 4952 st->n.omp_udr = udr; 4953 } 4954 else 4955 { 4956 st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name); 4957 st->n.omp_udr = udr; 4958 } 4959 mio_rparen (); 4960 } 4961 mio_rparen (); 4962 } 4963 4964 4965 /* Recursive function to traverse the pointer_info tree and load a 4966 needed symbol. We return nonzero if we load a symbol and stop the 4967 traversal, because the act of loading can alter the tree. */ 4968 4969 static int 4970 load_needed (pointer_info *p) 4971 { 4972 gfc_namespace *ns; 4973 pointer_info *q; 4974 gfc_symbol *sym; 4975 int rv; 4976 4977 rv = 0; 4978 if (p == NULL) 4979 return rv; 4980 4981 rv |= load_needed (p->left); 4982 rv |= load_needed (p->right); 4983 4984 if (p->type != P_SYMBOL || p->u.rsym.state != NEEDED) 4985 return rv; 4986 4987 p->u.rsym.state = USED; 4988 4989 set_module_locus (&p->u.rsym.where); 4990 4991 sym = p->u.rsym.sym; 4992 if (sym == NULL) 4993 { 4994 q = get_integer (p->u.rsym.ns); 4995 4996 ns = (gfc_namespace *) q->u.pointer; 4997 if (ns == NULL) 4998 { 4999 /* Create an interface namespace if necessary. These are 5000 the namespaces that hold the formal parameters of module 5001 procedures. */ 5002 5003 ns = gfc_get_namespace (NULL, 0); 5004 associate_integer_pointer (q, ns); 5005 } 5006 5007 /* Use the module sym as 'proc_name' so that gfc_get_symbol_decl 5008 doesn't go pear-shaped if the symbol is used. */ 5009 if (!ns->proc_name) 5010 gfc_find_symbol (p->u.rsym.module, gfc_current_ns, 5011 1, &ns->proc_name); 5012 5013 sym = gfc_new_symbol (p->u.rsym.true_name, ns); 5014 sym->name = gfc_dt_lower_string (p->u.rsym.true_name); 5015 sym->module = gfc_get_string ("%s", p->u.rsym.module); 5016 if (p->u.rsym.binding_label) 5017 sym->binding_label = IDENTIFIER_POINTER (get_identifier 5018 (p->u.rsym.binding_label)); 5019 5020 associate_integer_pointer (p, sym); 5021 } 5022 5023 mio_symbol (sym); 5024 sym->attr.use_assoc = 1; 5025 5026 /* Unliked derived types, a STRUCTURE may share names with other symbols. 5027 We greedily converted the the symbol name to lowercase before we knew its 5028 type, so now we must fix it. */ 5029 if (sym->attr.flavor == FL_STRUCT) 5030 sym->name = gfc_dt_upper_string (sym->name); 5031 5032 /* Mark as only or rename for later diagnosis for explicitly imported 5033 but not used warnings; don't mark internal symbols such as __vtab, 5034 __def_init etc. Only mark them if they have been explicitly loaded. */ 5035 5036 if (only_flag && sym->name[0] != '_' && sym->name[1] != '_') 5037 { 5038 gfc_use_rename *u; 5039 5040 /* Search the use/rename list for the variable; if the variable is 5041 found, mark it. */ 5042 for (u = gfc_rename_list; u; u = u->next) 5043 { 5044 if (strcmp (u->use_name, sym->name) == 0) 5045 { 5046 sym->attr.use_only = 1; 5047 break; 5048 } 5049 } 5050 } 5051 5052 if (p->u.rsym.renamed) 5053 sym->attr.use_rename = 1; 5054 5055 return 1; 5056 } 5057 5058 5059 /* Recursive function for cleaning up things after a module has been read. */ 5060 5061 static void 5062 read_cleanup (pointer_info *p) 5063 { 5064 gfc_symtree *st; 5065 pointer_info *q; 5066 5067 if (p == NULL) 5068 return; 5069 5070 read_cleanup (p->left); 5071 read_cleanup (p->right); 5072 5073 if (p->type == P_SYMBOL && p->u.rsym.state == USED && !p->u.rsym.referenced) 5074 { 5075 gfc_namespace *ns; 5076 /* Add hidden symbols to the symtree. */ 5077 q = get_integer (p->u.rsym.ns); 5078 ns = (gfc_namespace *) q->u.pointer; 5079 5080 if (!p->u.rsym.sym->attr.vtype 5081 && !p->u.rsym.sym->attr.vtab) 5082 st = gfc_get_unique_symtree (ns); 5083 else 5084 { 5085 /* There is no reason to use 'unique_symtrees' for vtabs or 5086 vtypes - their name is fine for a symtree and reduces the 5087 namespace pollution. */ 5088 st = gfc_find_symtree (ns->sym_root, p->u.rsym.sym->name); 5089 if (!st) 5090 st = gfc_new_symtree (&ns->sym_root, p->u.rsym.sym->name); 5091 } 5092 5093 st->n.sym = p->u.rsym.sym; 5094 st->n.sym->refs++; 5095 5096 /* Fixup any symtree references. */ 5097 p->u.rsym.symtree = st; 5098 resolve_fixups (p->u.rsym.stfixup, st); 5099 p->u.rsym.stfixup = NULL; 5100 } 5101 5102 /* Free unused symbols. */ 5103 if (p->type == P_SYMBOL && p->u.rsym.state == UNUSED) 5104 gfc_free_symbol (p->u.rsym.sym); 5105 } 5106 5107 5108 /* It is not quite enough to check for ambiguity in the symbols by 5109 the loaded symbol and the new symbol not being identical. */ 5110 static bool 5111 check_for_ambiguous (gfc_symtree *st, pointer_info *info) 5112 { 5113 gfc_symbol *rsym; 5114 module_locus locus; 5115 symbol_attribute attr; 5116 gfc_symbol *st_sym; 5117 5118 if (gfc_current_ns->proc_name && st->name == gfc_current_ns->proc_name->name) 5119 { 5120 gfc_error ("%qs of module %qs, imported at %C, is also the name of the " 5121 "current program unit", st->name, module_name); 5122 return true; 5123 } 5124 5125 st_sym = st->n.sym; 5126 rsym = info->u.rsym.sym; 5127 if (st_sym == rsym) 5128 return false; 5129 5130 if (st_sym->attr.vtab || st_sym->attr.vtype) 5131 return false; 5132 5133 /* If the existing symbol is generic from a different module and 5134 the new symbol is generic there can be no ambiguity. */ 5135 if (st_sym->attr.generic 5136 && st_sym->module 5137 && st_sym->module != module_name) 5138 { 5139 /* The new symbol's attributes have not yet been read. Since 5140 we need attr.generic, read it directly. */ 5141 get_module_locus (&locus); 5142 set_module_locus (&info->u.rsym.where); 5143 mio_lparen (); 5144 attr.generic = 0; 5145 mio_symbol_attribute (&attr); 5146 set_module_locus (&locus); 5147 if (attr.generic) 5148 return false; 5149 } 5150 5151 return true; 5152 } 5153 5154 5155 /* Read a module file. */ 5156 5157 static void 5158 read_module (void) 5159 { 5160 module_locus operator_interfaces, user_operators, omp_udrs; 5161 const char *p; 5162 char name[GFC_MAX_SYMBOL_LEN + 1]; 5163 int i; 5164 /* Workaround -Wmaybe-uninitialized false positive during 5165 profiledbootstrap by initializing them. */ 5166 int ambiguous = 0, j, nuse, symbol = 0; 5167 pointer_info *info, *q; 5168 gfc_use_rename *u = NULL; 5169 gfc_symtree *st; 5170 gfc_symbol *sym; 5171 5172 get_module_locus (&operator_interfaces); /* Skip these for now. */ 5173 skip_list (); 5174 5175 get_module_locus (&user_operators); 5176 skip_list (); 5177 skip_list (); 5178 5179 /* Skip commons and equivalences for now. */ 5180 skip_list (); 5181 skip_list (); 5182 5183 /* Skip OpenMP UDRs. */ 5184 get_module_locus (&omp_udrs); 5185 skip_list (); 5186 5187 mio_lparen (); 5188 5189 /* Create the fixup nodes for all the symbols. */ 5190 5191 while (peek_atom () != ATOM_RPAREN) 5192 { 5193 char* bind_label; 5194 require_atom (ATOM_INTEGER); 5195 info = get_integer (atom_int); 5196 5197 info->type = P_SYMBOL; 5198 info->u.rsym.state = UNUSED; 5199 5200 info->u.rsym.true_name = read_string (); 5201 info->u.rsym.module = read_string (); 5202 bind_label = read_string (); 5203 if (strlen (bind_label)) 5204 info->u.rsym.binding_label = bind_label; 5205 else 5206 XDELETEVEC (bind_label); 5207 5208 require_atom (ATOM_INTEGER); 5209 info->u.rsym.ns = atom_int; 5210 5211 get_module_locus (&info->u.rsym.where); 5212 5213 /* See if the symbol has already been loaded by a previous module. 5214 If so, we reference the existing symbol and prevent it from 5215 being loaded again. This should not happen if the symbol being 5216 read is an index for an assumed shape dummy array (ns != 1). */ 5217 5218 sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module); 5219 5220 if (sym == NULL 5221 || (sym->attr.flavor == FL_VARIABLE && info->u.rsym.ns !=1)) 5222 { 5223 skip_list (); 5224 continue; 5225 } 5226 5227 info->u.rsym.state = USED; 5228 info->u.rsym.sym = sym; 5229 /* The current symbol has already been loaded, so we can avoid loading 5230 it again. However, if it is a derived type, some of its components 5231 can be used in expressions in the module. To avoid the module loading 5232 failing, we need to associate the module's component pointer indexes 5233 with the existing symbol's component pointers. */ 5234 if (gfc_fl_struct (sym->attr.flavor)) 5235 { 5236 gfc_component *c; 5237 5238 /* First seek to the symbol's component list. */ 5239 mio_lparen (); /* symbol opening. */ 5240 skip_list (); /* skip symbol attribute. */ 5241 5242 mio_lparen (); /* component list opening. */ 5243 for (c = sym->components; c; c = c->next) 5244 { 5245 pointer_info *p; 5246 const char *comp_name; 5247 int n; 5248 5249 mio_lparen (); /* component opening. */ 5250 mio_integer (&n); 5251 p = get_integer (n); 5252 if (p->u.pointer == NULL) 5253 associate_integer_pointer (p, c); 5254 mio_pool_string (&comp_name); 5255 if (comp_name != c->name) 5256 { 5257 gfc_fatal_error ("Mismatch in components of derived type " 5258 "%qs from %qs at %C: expecting %qs, " 5259 "but got %qs", sym->name, sym->module, 5260 c->name, comp_name); 5261 } 5262 skip_list (1); /* component end. */ 5263 } 5264 mio_rparen (); /* component list closing. */ 5265 5266 skip_list (1); /* symbol end. */ 5267 } 5268 else 5269 skip_list (); 5270 5271 /* Some symbols do not have a namespace (eg. formal arguments), 5272 so the automatic "unique symtree" mechanism must be suppressed 5273 by marking them as referenced. */ 5274 q = get_integer (info->u.rsym.ns); 5275 if (q->u.pointer == NULL) 5276 { 5277 info->u.rsym.referenced = 1; 5278 continue; 5279 } 5280 } 5281 5282 mio_rparen (); 5283 5284 /* Parse the symtree lists. This lets us mark which symbols need to 5285 be loaded. Renaming is also done at this point by replacing the 5286 symtree name. */ 5287 5288 mio_lparen (); 5289 5290 while (peek_atom () != ATOM_RPAREN) 5291 { 5292 mio_internal_string (name); 5293 mio_integer (&ambiguous); 5294 mio_integer (&symbol); 5295 5296 info = get_integer (symbol); 5297 5298 /* See how many use names there are. If none, go through the start 5299 of the loop at least once. */ 5300 nuse = number_use_names (name, false); 5301 info->u.rsym.renamed = nuse ? 1 : 0; 5302 5303 if (nuse == 0) 5304 nuse = 1; 5305 5306 for (j = 1; j <= nuse; j++) 5307 { 5308 /* Get the jth local name for this symbol. */ 5309 p = find_use_name_n (name, &j, false); 5310 5311 if (p == NULL && strcmp (name, module_name) == 0) 5312 p = name; 5313 5314 /* Exception: Always import vtabs & vtypes. */ 5315 if (p == NULL && name[0] == '_' 5316 && (gfc_str_startswith (name, "__vtab_") 5317 || gfc_str_startswith (name, "__vtype_"))) 5318 p = name; 5319 5320 /* Skip symtree nodes not in an ONLY clause, unless there 5321 is an existing symtree loaded from another USE statement. */ 5322 if (p == NULL) 5323 { 5324 st = gfc_find_symtree (gfc_current_ns->sym_root, name); 5325 if (st != NULL 5326 && strcmp (st->n.sym->name, info->u.rsym.true_name) == 0 5327 && st->n.sym->module != NULL 5328 && strcmp (st->n.sym->module, info->u.rsym.module) == 0) 5329 { 5330 info->u.rsym.symtree = st; 5331 info->u.rsym.sym = st->n.sym; 5332 } 5333 continue; 5334 } 5335 5336 /* If a symbol of the same name and module exists already, 5337 this symbol, which is not in an ONLY clause, must not be 5338 added to the namespace(11.3.2). Note that find_symbol 5339 only returns the first occurrence that it finds. */ 5340 if (!only_flag && !info->u.rsym.renamed 5341 && strcmp (name, module_name) != 0 5342 && find_symbol (gfc_current_ns->sym_root, name, 5343 module_name, 0)) 5344 continue; 5345 5346 st = gfc_find_symtree (gfc_current_ns->sym_root, p); 5347 5348 if (st != NULL 5349 && !(st->n.sym && st->n.sym->attr.used_in_submodule)) 5350 { 5351 /* Check for ambiguous symbols. */ 5352 if (check_for_ambiguous (st, info)) 5353 st->ambiguous = 1; 5354 else 5355 info->u.rsym.symtree = st; 5356 } 5357 else 5358 { 5359 if (st) 5360 { 5361 /* This symbol is host associated from a module in a 5362 submodule. Hide it with a unique symtree. */ 5363 gfc_symtree *s = gfc_get_unique_symtree (gfc_current_ns); 5364 s->n.sym = st->n.sym; 5365 st->n.sym = NULL; 5366 } 5367 else 5368 { 5369 /* Create a symtree node in the current namespace for this 5370 symbol. */ 5371 st = check_unique_name (p) 5372 ? gfc_get_unique_symtree (gfc_current_ns) 5373 : gfc_new_symtree (&gfc_current_ns->sym_root, p); 5374 st->ambiguous = ambiguous; 5375 } 5376 5377 sym = info->u.rsym.sym; 5378 5379 /* Create a symbol node if it doesn't already exist. */ 5380 if (sym == NULL) 5381 { 5382 info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name, 5383 gfc_current_ns); 5384 info->u.rsym.sym->name = gfc_dt_lower_string (info->u.rsym.true_name); 5385 sym = info->u.rsym.sym; 5386 sym->module = gfc_get_string ("%s", info->u.rsym.module); 5387 5388 if (info->u.rsym.binding_label) 5389 { 5390 tree id = get_identifier (info->u.rsym.binding_label); 5391 sym->binding_label = IDENTIFIER_POINTER (id); 5392 } 5393 } 5394 5395 st->n.sym = sym; 5396 st->n.sym->refs++; 5397 5398 if (strcmp (name, p) != 0) 5399 sym->attr.use_rename = 1; 5400 5401 if (name[0] != '_' 5402 || (!gfc_str_startswith (name, "__vtab_") 5403 && !gfc_str_startswith (name, "__vtype_"))) 5404 sym->attr.use_only = only_flag; 5405 5406 /* Store the symtree pointing to this symbol. */ 5407 info->u.rsym.symtree = st; 5408 5409 if (info->u.rsym.state == UNUSED) 5410 info->u.rsym.state = NEEDED; 5411 info->u.rsym.referenced = 1; 5412 } 5413 } 5414 } 5415 5416 mio_rparen (); 5417 5418 /* Load intrinsic operator interfaces. */ 5419 set_module_locus (&operator_interfaces); 5420 mio_lparen (); 5421 5422 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++) 5423 { 5424 if (i == INTRINSIC_USER) 5425 continue; 5426 5427 if (only_flag) 5428 { 5429 u = find_use_operator ((gfc_intrinsic_op) i); 5430 5431 if (u == NULL) 5432 { 5433 skip_list (); 5434 continue; 5435 } 5436 5437 u->found = 1; 5438 } 5439 5440 mio_interface (&gfc_current_ns->op[i]); 5441 if (u && !gfc_current_ns->op[i]) 5442 u->found = 0; 5443 } 5444 5445 mio_rparen (); 5446 5447 /* Load generic and user operator interfaces. These must follow the 5448 loading of symtree because otherwise symbols can be marked as 5449 ambiguous. */ 5450 5451 set_module_locus (&user_operators); 5452 5453 load_operator_interfaces (); 5454 load_generic_interfaces (); 5455 5456 load_commons (); 5457 load_equiv (); 5458 5459 /* Load OpenMP user defined reductions. */ 5460 set_module_locus (&omp_udrs); 5461 load_omp_udrs (); 5462 5463 /* At this point, we read those symbols that are needed but haven't 5464 been loaded yet. If one symbol requires another, the other gets 5465 marked as NEEDED if its previous state was UNUSED. */ 5466 5467 while (load_needed (pi_root)); 5468 5469 /* Make sure all elements of the rename-list were found in the module. */ 5470 5471 for (u = gfc_rename_list; u; u = u->next) 5472 { 5473 if (u->found) 5474 continue; 5475 5476 if (u->op == INTRINSIC_NONE) 5477 { 5478 gfc_error ("Symbol %qs referenced at %L not found in module %qs", 5479 u->use_name, &u->where, module_name); 5480 continue; 5481 } 5482 5483 if (u->op == INTRINSIC_USER) 5484 { 5485 gfc_error ("User operator %qs referenced at %L not found " 5486 "in module %qs", u->use_name, &u->where, module_name); 5487 continue; 5488 } 5489 5490 gfc_error ("Intrinsic operator %qs referenced at %L not found " 5491 "in module %qs", gfc_op2string (u->op), &u->where, 5492 module_name); 5493 } 5494 5495 /* Clean up symbol nodes that were never loaded, create references 5496 to hidden symbols. */ 5497 5498 read_cleanup (pi_root); 5499 } 5500 5501 5502 /* Given an access type that is specific to an entity and the default 5503 access, return nonzero if the entity is publicly accessible. If the 5504 element is declared as PUBLIC, then it is public; if declared 5505 PRIVATE, then private, and otherwise it is public unless the default 5506 access in this context has been declared PRIVATE. */ 5507 5508 static bool dump_smod = false; 5509 5510 static bool 5511 check_access (gfc_access specific_access, gfc_access default_access) 5512 { 5513 if (dump_smod) 5514 return true; 5515 5516 if (specific_access == ACCESS_PUBLIC) 5517 return TRUE; 5518 if (specific_access == ACCESS_PRIVATE) 5519 return FALSE; 5520 5521 if (flag_module_private) 5522 return default_access == ACCESS_PUBLIC; 5523 else 5524 return default_access != ACCESS_PRIVATE; 5525 } 5526 5527 5528 bool 5529 gfc_check_symbol_access (gfc_symbol *sym) 5530 { 5531 if (sym->attr.vtab || sym->attr.vtype) 5532 return true; 5533 else 5534 return check_access (sym->attr.access, sym->ns->default_access); 5535 } 5536 5537 5538 /* A structure to remember which commons we've already written. */ 5539 5540 struct written_common 5541 { 5542 BBT_HEADER(written_common); 5543 const char *name, *label; 5544 }; 5545 5546 static struct written_common *written_commons = NULL; 5547 5548 /* Comparison function used for balancing the binary tree. */ 5549 5550 static int 5551 compare_written_commons (void *a1, void *b1) 5552 { 5553 const char *aname = ((struct written_common *) a1)->name; 5554 const char *alabel = ((struct written_common *) a1)->label; 5555 const char *bname = ((struct written_common *) b1)->name; 5556 const char *blabel = ((struct written_common *) b1)->label; 5557 int c = strcmp (aname, bname); 5558 5559 return (c != 0 ? c : strcmp (alabel, blabel)); 5560 } 5561 5562 /* Free a list of written commons. */ 5563 5564 static void 5565 free_written_common (struct written_common *w) 5566 { 5567 if (!w) 5568 return; 5569 5570 if (w->left) 5571 free_written_common (w->left); 5572 if (w->right) 5573 free_written_common (w->right); 5574 5575 free (w); 5576 } 5577 5578 /* Write a common block to the module -- recursive helper function. */ 5579 5580 static void 5581 write_common_0 (gfc_symtree *st, bool this_module) 5582 { 5583 gfc_common_head *p; 5584 const char * name; 5585 int flags; 5586 const char *label; 5587 struct written_common *w; 5588 bool write_me = true; 5589 5590 if (st == NULL) 5591 return; 5592 5593 write_common_0 (st->left, this_module); 5594 5595 /* We will write out the binding label, or "" if no label given. */ 5596 name = st->n.common->name; 5597 p = st->n.common; 5598 label = (p->is_bind_c && p->binding_label) ? p->binding_label : ""; 5599 5600 /* Check if we've already output this common. */ 5601 w = written_commons; 5602 while (w) 5603 { 5604 int c = strcmp (name, w->name); 5605 c = (c != 0 ? c : strcmp (label, w->label)); 5606 if (c == 0) 5607 write_me = false; 5608 5609 w = (c < 0) ? w->left : w->right; 5610 } 5611 5612 if (this_module && p->use_assoc) 5613 write_me = false; 5614 5615 if (write_me) 5616 { 5617 /* Write the common to the module. */ 5618 mio_lparen (); 5619 mio_pool_string (&name); 5620 5621 mio_symbol_ref (&p->head); 5622 flags = p->saved ? 1 : 0; 5623 if (p->threadprivate) 5624 flags |= 2; 5625 mio_integer (&flags); 5626 5627 /* Write out whether the common block is bind(c) or not. */ 5628 mio_integer (&(p->is_bind_c)); 5629 5630 mio_pool_string (&label); 5631 mio_rparen (); 5632 5633 /* Record that we have written this common. */ 5634 w = XCNEW (struct written_common); 5635 w->name = p->name; 5636 w->label = label; 5637 gfc_insert_bbt (&written_commons, w, compare_written_commons); 5638 } 5639 5640 write_common_0 (st->right, this_module); 5641 } 5642 5643 5644 /* Write a common, by initializing the list of written commons, calling 5645 the recursive function write_common_0() and cleaning up afterwards. */ 5646 5647 static void 5648 write_common (gfc_symtree *st) 5649 { 5650 written_commons = NULL; 5651 write_common_0 (st, true); 5652 write_common_0 (st, false); 5653 free_written_common (written_commons); 5654 written_commons = NULL; 5655 } 5656 5657 5658 /* Write the blank common block to the module. */ 5659 5660 static void 5661 write_blank_common (void) 5662 { 5663 const char * name = BLANK_COMMON_NAME; 5664 int saved; 5665 /* TODO: Blank commons are not bind(c). The F2003 standard probably says 5666 this, but it hasn't been checked. Just making it so for now. */ 5667 int is_bind_c = 0; 5668 5669 if (gfc_current_ns->blank_common.head == NULL) 5670 return; 5671 5672 mio_lparen (); 5673 5674 mio_pool_string (&name); 5675 5676 mio_symbol_ref (&gfc_current_ns->blank_common.head); 5677 saved = gfc_current_ns->blank_common.saved; 5678 mio_integer (&saved); 5679 5680 /* Write out whether the common block is bind(c) or not. */ 5681 mio_integer (&is_bind_c); 5682 5683 /* Write out an empty binding label. */ 5684 write_atom (ATOM_STRING, ""); 5685 5686 mio_rparen (); 5687 } 5688 5689 5690 /* Write equivalences to the module. */ 5691 5692 static void 5693 write_equiv (void) 5694 { 5695 gfc_equiv *eq, *e; 5696 int num; 5697 5698 num = 0; 5699 for (eq = gfc_current_ns->equiv; eq; eq = eq->next) 5700 { 5701 mio_lparen (); 5702 5703 for (e = eq; e; e = e->eq) 5704 { 5705 if (e->module == NULL) 5706 e->module = gfc_get_string ("%s.eq.%d", module_name, num); 5707 mio_allocated_string (e->module); 5708 mio_expr (&e->expr); 5709 } 5710 5711 num++; 5712 mio_rparen (); 5713 } 5714 } 5715 5716 5717 /* Write a symbol to the module. */ 5718 5719 static void 5720 write_symbol (int n, gfc_symbol *sym) 5721 { 5722 const char *label; 5723 5724 if (sym->attr.flavor == FL_UNKNOWN || sym->attr.flavor == FL_LABEL) 5725 gfc_internal_error ("write_symbol(): bad module symbol %qs", sym->name); 5726 5727 mio_integer (&n); 5728 5729 if (gfc_fl_struct (sym->attr.flavor)) 5730 { 5731 const char *name; 5732 name = gfc_dt_upper_string (sym->name); 5733 mio_pool_string (&name); 5734 } 5735 else 5736 mio_pool_string (&sym->name); 5737 5738 mio_pool_string (&sym->module); 5739 if ((sym->attr.is_bind_c || sym->attr.is_iso_c) && sym->binding_label) 5740 { 5741 label = sym->binding_label; 5742 mio_pool_string (&label); 5743 } 5744 else 5745 write_atom (ATOM_STRING, ""); 5746 5747 mio_pointer_ref (&sym->ns); 5748 5749 mio_symbol (sym); 5750 write_char ('\n'); 5751 } 5752 5753 5754 /* Recursive traversal function to write the initial set of symbols to 5755 the module. We check to see if the symbol should be written 5756 according to the access specification. */ 5757 5758 static void 5759 write_symbol0 (gfc_symtree *st) 5760 { 5761 gfc_symbol *sym; 5762 pointer_info *p; 5763 bool dont_write = false; 5764 5765 if (st == NULL) 5766 return; 5767 5768 write_symbol0 (st->left); 5769 5770 sym = st->n.sym; 5771 if (sym->module == NULL) 5772 sym->module = module_name; 5773 5774 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic 5775 && !sym->attr.subroutine && !sym->attr.function) 5776 dont_write = true; 5777 5778 if (!gfc_check_symbol_access (sym)) 5779 dont_write = true; 5780 5781 if (!dont_write) 5782 { 5783 p = get_pointer (sym); 5784 if (p->type == P_UNKNOWN) 5785 p->type = P_SYMBOL; 5786 5787 if (p->u.wsym.state != WRITTEN) 5788 { 5789 write_symbol (p->integer, sym); 5790 p->u.wsym.state = WRITTEN; 5791 } 5792 } 5793 5794 write_symbol0 (st->right); 5795 } 5796 5797 5798 static void 5799 write_omp_udr (gfc_omp_udr *udr) 5800 { 5801 switch (udr->rop) 5802 { 5803 case OMP_REDUCTION_USER: 5804 /* Non-operators can't be used outside of the module. */ 5805 if (udr->name[0] != '.') 5806 return; 5807 else 5808 { 5809 gfc_symtree *st; 5810 size_t len = strlen (udr->name + 1); 5811 char *name = XALLOCAVEC (char, len); 5812 memcpy (name, udr->name, len - 1); 5813 name[len - 1] = '\0'; 5814 st = gfc_find_symtree (gfc_current_ns->uop_root, name); 5815 /* If corresponding user operator is private, don't write 5816 the UDR. */ 5817 if (st != NULL) 5818 { 5819 gfc_user_op *uop = st->n.uop; 5820 if (!check_access (uop->access, uop->ns->default_access)) 5821 return; 5822 } 5823 } 5824 break; 5825 case OMP_REDUCTION_PLUS: 5826 case OMP_REDUCTION_MINUS: 5827 case OMP_REDUCTION_TIMES: 5828 case OMP_REDUCTION_AND: 5829 case OMP_REDUCTION_OR: 5830 case OMP_REDUCTION_EQV: 5831 case OMP_REDUCTION_NEQV: 5832 /* If corresponding operator is private, don't write the UDR. */ 5833 if (!check_access (gfc_current_ns->operator_access[udr->rop], 5834 gfc_current_ns->default_access)) 5835 return; 5836 break; 5837 default: 5838 break; 5839 } 5840 if (udr->ts.type == BT_DERIVED || udr->ts.type == BT_CLASS) 5841 { 5842 /* If derived type is private, don't write the UDR. */ 5843 if (!gfc_check_symbol_access (udr->ts.u.derived)) 5844 return; 5845 } 5846 5847 mio_lparen (); 5848 mio_pool_string (&udr->name); 5849 mio_typespec (&udr->ts); 5850 mio_omp_udr_expr (udr, &udr->omp_out, &udr->omp_in, udr->combiner_ns, false); 5851 if (udr->initializer_ns) 5852 mio_omp_udr_expr (udr, &udr->omp_priv, &udr->omp_orig, 5853 udr->initializer_ns, true); 5854 mio_rparen (); 5855 } 5856 5857 5858 static void 5859 write_omp_udrs (gfc_symtree *st) 5860 { 5861 if (st == NULL) 5862 return; 5863 5864 write_omp_udrs (st->left); 5865 gfc_omp_udr *udr; 5866 for (udr = st->n.omp_udr; udr; udr = udr->next) 5867 write_omp_udr (udr); 5868 write_omp_udrs (st->right); 5869 } 5870 5871 5872 /* Type for the temporary tree used when writing secondary symbols. */ 5873 5874 struct sorted_pointer_info 5875 { 5876 BBT_HEADER (sorted_pointer_info); 5877 5878 pointer_info *p; 5879 }; 5880 5881 #define gfc_get_sorted_pointer_info() XCNEW (sorted_pointer_info) 5882 5883 /* Recursively traverse the temporary tree, free its contents. */ 5884 5885 static void 5886 free_sorted_pointer_info_tree (sorted_pointer_info *p) 5887 { 5888 if (!p) 5889 return; 5890 5891 free_sorted_pointer_info_tree (p->left); 5892 free_sorted_pointer_info_tree (p->right); 5893 5894 free (p); 5895 } 5896 5897 /* Comparison function for the temporary tree. */ 5898 5899 static int 5900 compare_sorted_pointer_info (void *_spi1, void *_spi2) 5901 { 5902 sorted_pointer_info *spi1, *spi2; 5903 spi1 = (sorted_pointer_info *)_spi1; 5904 spi2 = (sorted_pointer_info *)_spi2; 5905 5906 if (spi1->p->integer < spi2->p->integer) 5907 return -1; 5908 if (spi1->p->integer > spi2->p->integer) 5909 return 1; 5910 return 0; 5911 } 5912 5913 5914 /* Finds the symbols that need to be written and collects them in the 5915 sorted_pi tree so that they can be traversed in an order 5916 independent of memory addresses. */ 5917 5918 static void 5919 find_symbols_to_write(sorted_pointer_info **tree, pointer_info *p) 5920 { 5921 if (!p) 5922 return; 5923 5924 if (p->type == P_SYMBOL && p->u.wsym.state == NEEDS_WRITE) 5925 { 5926 sorted_pointer_info *sp = gfc_get_sorted_pointer_info(); 5927 sp->p = p; 5928 5929 gfc_insert_bbt (tree, sp, compare_sorted_pointer_info); 5930 } 5931 5932 find_symbols_to_write (tree, p->left); 5933 find_symbols_to_write (tree, p->right); 5934 } 5935 5936 5937 /* Recursive function that traverses the tree of symbols that need to be 5938 written and writes them in order. */ 5939 5940 static void 5941 write_symbol1_recursion (sorted_pointer_info *sp) 5942 { 5943 if (!sp) 5944 return; 5945 5946 write_symbol1_recursion (sp->left); 5947 5948 pointer_info *p1 = sp->p; 5949 gcc_assert (p1->type == P_SYMBOL && p1->u.wsym.state == NEEDS_WRITE); 5950 5951 p1->u.wsym.state = WRITTEN; 5952 write_symbol (p1->integer, p1->u.wsym.sym); 5953 p1->u.wsym.sym->attr.public_used = 1; 5954 5955 write_symbol1_recursion (sp->right); 5956 } 5957 5958 5959 /* Write the secondary set of symbols to the module file. These are 5960 symbols that were not public yet are needed by the public symbols 5961 or another dependent symbol. The act of writing a symbol can add 5962 symbols to the pointer_info tree, so we return nonzero if a symbol 5963 was written and pass that information upwards. The caller will 5964 then call this function again until nothing was written. It uses 5965 the utility functions and a temporary tree to ensure a reproducible 5966 ordering of the symbol output and thus the module file. */ 5967 5968 static int 5969 write_symbol1 (pointer_info *p) 5970 { 5971 if (!p) 5972 return 0; 5973 5974 /* Put symbols that need to be written into a tree sorted on the 5975 integer field. */ 5976 5977 sorted_pointer_info *spi_root = NULL; 5978 find_symbols_to_write (&spi_root, p); 5979 5980 /* No symbols to write, return. */ 5981 if (!spi_root) 5982 return 0; 5983 5984 /* Otherwise, write and free the tree again. */ 5985 write_symbol1_recursion (spi_root); 5986 free_sorted_pointer_info_tree (spi_root); 5987 5988 return 1; 5989 } 5990 5991 5992 /* Write operator interfaces associated with a symbol. */ 5993 5994 static void 5995 write_operator (gfc_user_op *uop) 5996 { 5997 static char nullstring[] = ""; 5998 const char *p = nullstring; 5999 6000 if (uop->op == NULL || !check_access (uop->access, uop->ns->default_access)) 6001 return; 6002 6003 mio_symbol_interface (&uop->name, &p, &uop->op); 6004 } 6005 6006 6007 /* Write generic interfaces from the namespace sym_root. */ 6008 6009 static void 6010 write_generic (gfc_symtree *st) 6011 { 6012 gfc_symbol *sym; 6013 6014 if (st == NULL) 6015 return; 6016 6017 write_generic (st->left); 6018 6019 sym = st->n.sym; 6020 if (sym && !check_unique_name (st->name) 6021 && sym->generic && gfc_check_symbol_access (sym)) 6022 { 6023 if (!sym->module) 6024 sym->module = module_name; 6025 6026 mio_symbol_interface (&st->name, &sym->module, &sym->generic); 6027 } 6028 6029 write_generic (st->right); 6030 } 6031 6032 6033 static void 6034 write_symtree (gfc_symtree *st) 6035 { 6036 gfc_symbol *sym; 6037 pointer_info *p; 6038 6039 sym = st->n.sym; 6040 6041 /* A symbol in an interface body must not be visible in the 6042 module file. */ 6043 if (sym->ns != gfc_current_ns 6044 && sym->ns->proc_name 6045 && sym->ns->proc_name->attr.if_source == IFSRC_IFBODY) 6046 return; 6047 6048 if (!gfc_check_symbol_access (sym) 6049 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic 6050 && !sym->attr.subroutine && !sym->attr.function)) 6051 return; 6052 6053 if (check_unique_name (st->name)) 6054 return; 6055 6056 p = find_pointer (sym); 6057 if (p == NULL) 6058 gfc_internal_error ("write_symtree(): Symbol not written"); 6059 6060 mio_pool_string (&st->name); 6061 mio_integer (&st->ambiguous); 6062 mio_hwi (&p->integer); 6063 } 6064 6065 6066 static void 6067 write_module (void) 6068 { 6069 int i; 6070 6071 /* Write the operator interfaces. */ 6072 mio_lparen (); 6073 6074 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++) 6075 { 6076 if (i == INTRINSIC_USER) 6077 continue; 6078 6079 mio_interface (check_access (gfc_current_ns->operator_access[i], 6080 gfc_current_ns->default_access) 6081 ? &gfc_current_ns->op[i] : NULL); 6082 } 6083 6084 mio_rparen (); 6085 write_char ('\n'); 6086 write_char ('\n'); 6087 6088 mio_lparen (); 6089 gfc_traverse_user_op (gfc_current_ns, write_operator); 6090 mio_rparen (); 6091 write_char ('\n'); 6092 write_char ('\n'); 6093 6094 mio_lparen (); 6095 write_generic (gfc_current_ns->sym_root); 6096 mio_rparen (); 6097 write_char ('\n'); 6098 write_char ('\n'); 6099 6100 mio_lparen (); 6101 write_blank_common (); 6102 write_common (gfc_current_ns->common_root); 6103 mio_rparen (); 6104 write_char ('\n'); 6105 write_char ('\n'); 6106 6107 mio_lparen (); 6108 write_equiv (); 6109 mio_rparen (); 6110 write_char ('\n'); 6111 write_char ('\n'); 6112 6113 mio_lparen (); 6114 write_omp_udrs (gfc_current_ns->omp_udr_root); 6115 mio_rparen (); 6116 write_char ('\n'); 6117 write_char ('\n'); 6118 6119 /* Write symbol information. First we traverse all symbols in the 6120 primary namespace, writing those that need to be written. 6121 Sometimes writing one symbol will cause another to need to be 6122 written. A list of these symbols ends up on the write stack, and 6123 we end by popping the bottom of the stack and writing the symbol 6124 until the stack is empty. */ 6125 6126 mio_lparen (); 6127 6128 write_symbol0 (gfc_current_ns->sym_root); 6129 while (write_symbol1 (pi_root)) 6130 /* Nothing. */; 6131 6132 mio_rparen (); 6133 6134 write_char ('\n'); 6135 write_char ('\n'); 6136 6137 mio_lparen (); 6138 gfc_traverse_symtree (gfc_current_ns->sym_root, write_symtree); 6139 mio_rparen (); 6140 } 6141 6142 6143 /* Read a CRC32 sum from the gzip trailer of a module file. Returns 6144 true on success, false on failure. */ 6145 6146 static bool 6147 read_crc32_from_module_file (const char* filename, uLong* crc) 6148 { 6149 FILE *file; 6150 char buf[4]; 6151 unsigned int val; 6152 6153 /* Open the file in binary mode. */ 6154 if ((file = fopen (filename, "rb")) == NULL) 6155 return false; 6156 6157 /* The gzip crc32 value is found in the [END-8, END-4] bytes of the 6158 file. See RFC 1952. */ 6159 if (fseek (file, -8, SEEK_END) != 0) 6160 { 6161 fclose (file); 6162 return false; 6163 } 6164 6165 /* Read the CRC32. */ 6166 if (fread (buf, 1, 4, file) != 4) 6167 { 6168 fclose (file); 6169 return false; 6170 } 6171 6172 /* Close the file. */ 6173 fclose (file); 6174 6175 val = (buf[0] & 0xFF) + ((buf[1] & 0xFF) << 8) + ((buf[2] & 0xFF) << 16) 6176 + ((buf[3] & 0xFF) << 24); 6177 *crc = val; 6178 6179 /* For debugging, the CRC value printed in hexadecimal should match 6180 the CRC printed by "zcat -l -v filename". 6181 printf("CRC of file %s is %x\n", filename, val); */ 6182 6183 return true; 6184 } 6185 6186 6187 /* Given module, dump it to disk. If there was an error while 6188 processing the module, dump_flag will be set to zero and we delete 6189 the module file, even if it was already there. */ 6190 6191 static void 6192 dump_module (const char *name, int dump_flag) 6193 { 6194 int n; 6195 char *filename, *filename_tmp; 6196 uLong crc, crc_old; 6197 6198 module_name = gfc_get_string ("%s", name); 6199 6200 if (dump_smod) 6201 { 6202 name = submodule_name; 6203 n = strlen (name) + strlen (SUBMODULE_EXTENSION) + 1; 6204 } 6205 else 6206 n = strlen (name) + strlen (MODULE_EXTENSION) + 1; 6207 6208 if (gfc_option.module_dir != NULL) 6209 { 6210 n += strlen (gfc_option.module_dir); 6211 filename = (char *) alloca (n); 6212 strcpy (filename, gfc_option.module_dir); 6213 strcat (filename, name); 6214 } 6215 else 6216 { 6217 filename = (char *) alloca (n); 6218 strcpy (filename, name); 6219 } 6220 6221 if (dump_smod) 6222 strcat (filename, SUBMODULE_EXTENSION); 6223 else 6224 strcat (filename, MODULE_EXTENSION); 6225 6226 /* Name of the temporary file used to write the module. */ 6227 filename_tmp = (char *) alloca (n + 1); 6228 strcpy (filename_tmp, filename); 6229 strcat (filename_tmp, "0"); 6230 6231 /* There was an error while processing the module. We delete the 6232 module file, even if it was already there. */ 6233 if (!dump_flag) 6234 { 6235 remove (filename); 6236 return; 6237 } 6238 6239 if (gfc_cpp_makedep ()) 6240 gfc_cpp_add_target (filename); 6241 6242 /* Write the module to the temporary file. */ 6243 module_fp = gzopen (filename_tmp, "w"); 6244 if (module_fp == NULL) 6245 gfc_fatal_error ("Cannot open module file %qs for writing at %C: %s", 6246 filename_tmp, xstrerror (errno)); 6247 6248 /* Use lbasename to ensure module files are reproducible regardless 6249 of the build path (see the reproducible builds project). */ 6250 gzprintf (module_fp, "GFORTRAN module version '%s' created from %s\n", 6251 MOD_VERSION, lbasename (gfc_source_file)); 6252 6253 /* Write the module itself. */ 6254 iomode = IO_OUTPUT; 6255 6256 init_pi_tree (); 6257 6258 write_module (); 6259 6260 free_pi_tree (pi_root); 6261 pi_root = NULL; 6262 6263 write_char ('\n'); 6264 6265 if (gzclose (module_fp)) 6266 gfc_fatal_error ("Error writing module file %qs for writing: %s", 6267 filename_tmp, xstrerror (errno)); 6268 6269 /* Read the CRC32 from the gzip trailers of the module files and 6270 compare. */ 6271 if (!read_crc32_from_module_file (filename_tmp, &crc) 6272 || !read_crc32_from_module_file (filename, &crc_old) 6273 || crc_old != crc) 6274 { 6275 /* Module file have changed, replace the old one. */ 6276 if (remove (filename) && errno != ENOENT) 6277 gfc_fatal_error ("Cannot delete module file %qs: %s", filename, 6278 xstrerror (errno)); 6279 if (rename (filename_tmp, filename)) 6280 gfc_fatal_error ("Cannot rename module file %qs to %qs: %s", 6281 filename_tmp, filename, xstrerror (errno)); 6282 } 6283 else 6284 { 6285 if (remove (filename_tmp)) 6286 gfc_fatal_error ("Cannot delete temporary module file %qs: %s", 6287 filename_tmp, xstrerror (errno)); 6288 } 6289 } 6290 6291 6292 /* Suppress the output of a .smod file by module, if no module 6293 procedures have been seen. */ 6294 static bool no_module_procedures; 6295 6296 static void 6297 check_for_module_procedures (gfc_symbol *sym) 6298 { 6299 if (sym && sym->attr.module_procedure) 6300 no_module_procedures = false; 6301 } 6302 6303 6304 void 6305 gfc_dump_module (const char *name, int dump_flag) 6306 { 6307 if (gfc_state_stack->state == COMP_SUBMODULE) 6308 dump_smod = true; 6309 else 6310 dump_smod =false; 6311 6312 no_module_procedures = true; 6313 gfc_traverse_ns (gfc_current_ns, check_for_module_procedures); 6314 6315 dump_module (name, dump_flag); 6316 6317 if (no_module_procedures || dump_smod) 6318 return; 6319 6320 /* Write a submodule file from a module. The 'dump_smod' flag switches 6321 off the check for PRIVATE entities. */ 6322 dump_smod = true; 6323 submodule_name = module_name; 6324 dump_module (name, dump_flag); 6325 dump_smod = false; 6326 } 6327 6328 static void 6329 create_intrinsic_function (const char *name, int id, 6330 const char *modname, intmod_id module, 6331 bool subroutine, gfc_symbol *result_type) 6332 { 6333 gfc_intrinsic_sym *isym; 6334 gfc_symtree *tmp_symtree; 6335 gfc_symbol *sym; 6336 6337 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name); 6338 if (tmp_symtree) 6339 { 6340 if (tmp_symtree->n.sym && tmp_symtree->n.sym->module 6341 && strcmp (modname, tmp_symtree->n.sym->module) == 0) 6342 return; 6343 gfc_error ("Symbol %qs at %C already declared", name); 6344 return; 6345 } 6346 6347 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false); 6348 sym = tmp_symtree->n.sym; 6349 6350 if (subroutine) 6351 { 6352 gfc_isym_id isym_id = gfc_isym_id_by_intmod (module, id); 6353 isym = gfc_intrinsic_subroutine_by_id (isym_id); 6354 sym->attr.subroutine = 1; 6355 } 6356 else 6357 { 6358 gfc_isym_id isym_id = gfc_isym_id_by_intmod (module, id); 6359 isym = gfc_intrinsic_function_by_id (isym_id); 6360 6361 sym->attr.function = 1; 6362 if (result_type) 6363 { 6364 sym->ts.type = BT_DERIVED; 6365 sym->ts.u.derived = result_type; 6366 sym->ts.is_c_interop = 1; 6367 isym->ts.f90_type = BT_VOID; 6368 isym->ts.type = BT_DERIVED; 6369 isym->ts.f90_type = BT_VOID; 6370 isym->ts.u.derived = result_type; 6371 isym->ts.is_c_interop = 1; 6372 } 6373 } 6374 gcc_assert (isym); 6375 6376 sym->attr.flavor = FL_PROCEDURE; 6377 sym->attr.intrinsic = 1; 6378 6379 sym->module = gfc_get_string ("%s", modname); 6380 sym->attr.use_assoc = 1; 6381 sym->from_intmod = module; 6382 sym->intmod_sym_id = id; 6383 } 6384 6385 6386 /* Import the intrinsic ISO_C_BINDING module, generating symbols in 6387 the current namespace for all named constants, pointer types, and 6388 procedures in the module unless the only clause was used or a rename 6389 list was provided. */ 6390 6391 static void 6392 import_iso_c_binding_module (void) 6393 { 6394 gfc_symbol *mod_sym = NULL, *return_type; 6395 gfc_symtree *mod_symtree = NULL, *tmp_symtree; 6396 gfc_symtree *c_ptr = NULL, *c_funptr = NULL; 6397 const char *iso_c_module_name = "__iso_c_binding"; 6398 gfc_use_rename *u; 6399 int i; 6400 bool want_c_ptr = false, want_c_funptr = false; 6401 6402 /* Look only in the current namespace. */ 6403 mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, iso_c_module_name); 6404 6405 if (mod_symtree == NULL) 6406 { 6407 /* symtree doesn't already exist in current namespace. */ 6408 gfc_get_sym_tree (iso_c_module_name, gfc_current_ns, &mod_symtree, 6409 false); 6410 6411 if (mod_symtree != NULL) 6412 mod_sym = mod_symtree->n.sym; 6413 else 6414 gfc_internal_error ("import_iso_c_binding_module(): Unable to " 6415 "create symbol for %s", iso_c_module_name); 6416 6417 mod_sym->attr.flavor = FL_MODULE; 6418 mod_sym->attr.intrinsic = 1; 6419 mod_sym->module = gfc_get_string ("%s", iso_c_module_name); 6420 mod_sym->from_intmod = INTMOD_ISO_C_BINDING; 6421 } 6422 6423 /* Check whether C_PTR or C_FUNPTR are in the include list, if so, load it; 6424 check also whether C_NULL_(FUN)PTR or C_(FUN)LOC are requested, which 6425 need C_(FUN)PTR. */ 6426 for (u = gfc_rename_list; u; u = u->next) 6427 { 6428 if (strcmp (c_interop_kinds_table[ISOCBINDING_NULL_PTR].name, 6429 u->use_name) == 0) 6430 want_c_ptr = true; 6431 else if (strcmp (c_interop_kinds_table[ISOCBINDING_LOC].name, 6432 u->use_name) == 0) 6433 want_c_ptr = true; 6434 else if (strcmp (c_interop_kinds_table[ISOCBINDING_NULL_FUNPTR].name, 6435 u->use_name) == 0) 6436 want_c_funptr = true; 6437 else if (strcmp (c_interop_kinds_table[ISOCBINDING_FUNLOC].name, 6438 u->use_name) == 0) 6439 want_c_funptr = true; 6440 else if (strcmp (c_interop_kinds_table[ISOCBINDING_PTR].name, 6441 u->use_name) == 0) 6442 { 6443 c_ptr = generate_isocbinding_symbol (iso_c_module_name, 6444 (iso_c_binding_symbol) 6445 ISOCBINDING_PTR, 6446 u->local_name[0] ? u->local_name 6447 : u->use_name, 6448 NULL, false); 6449 } 6450 else if (strcmp (c_interop_kinds_table[ISOCBINDING_FUNPTR].name, 6451 u->use_name) == 0) 6452 { 6453 c_funptr 6454 = generate_isocbinding_symbol (iso_c_module_name, 6455 (iso_c_binding_symbol) 6456 ISOCBINDING_FUNPTR, 6457 u->local_name[0] ? u->local_name 6458 : u->use_name, 6459 NULL, false); 6460 } 6461 } 6462 6463 if ((want_c_ptr || !only_flag) && !c_ptr) 6464 c_ptr = generate_isocbinding_symbol (iso_c_module_name, 6465 (iso_c_binding_symbol) 6466 ISOCBINDING_PTR, 6467 NULL, NULL, only_flag); 6468 if ((want_c_funptr || !only_flag) && !c_funptr) 6469 c_funptr = generate_isocbinding_symbol (iso_c_module_name, 6470 (iso_c_binding_symbol) 6471 ISOCBINDING_FUNPTR, 6472 NULL, NULL, only_flag); 6473 6474 /* Generate the symbols for the named constants representing 6475 the kinds for intrinsic data types. */ 6476 for (i = 0; i < ISOCBINDING_NUMBER; i++) 6477 { 6478 bool found = false; 6479 for (u = gfc_rename_list; u; u = u->next) 6480 if (strcmp (c_interop_kinds_table[i].name, u->use_name) == 0) 6481 { 6482 bool not_in_std; 6483 const char *name; 6484 u->found = 1; 6485 found = true; 6486 6487 switch (i) 6488 { 6489 #define NAMED_FUNCTION(a,b,c,d) \ 6490 case a: \ 6491 not_in_std = (gfc_option.allow_std & d) == 0; \ 6492 name = b; \ 6493 break; 6494 #define NAMED_SUBROUTINE(a,b,c,d) \ 6495 case a: \ 6496 not_in_std = (gfc_option.allow_std & d) == 0; \ 6497 name = b; \ 6498 break; 6499 #define NAMED_INTCST(a,b,c,d) \ 6500 case a: \ 6501 not_in_std = (gfc_option.allow_std & d) == 0; \ 6502 name = b; \ 6503 break; 6504 #define NAMED_REALCST(a,b,c,d) \ 6505 case a: \ 6506 not_in_std = (gfc_option.allow_std & d) == 0; \ 6507 name = b; \ 6508 break; 6509 #define NAMED_CMPXCST(a,b,c,d) \ 6510 case a: \ 6511 not_in_std = (gfc_option.allow_std & d) == 0; \ 6512 name = b; \ 6513 break; 6514 #include "iso-c-binding.def" 6515 default: 6516 not_in_std = false; 6517 name = ""; 6518 } 6519 6520 if (not_in_std) 6521 { 6522 gfc_error ("The symbol %qs, referenced at %L, is not " 6523 "in the selected standard", name, &u->where); 6524 continue; 6525 } 6526 6527 switch (i) 6528 { 6529 #define NAMED_FUNCTION(a,b,c,d) \ 6530 case a: \ 6531 if (a == ISOCBINDING_LOC) \ 6532 return_type = c_ptr->n.sym; \ 6533 else if (a == ISOCBINDING_FUNLOC) \ 6534 return_type = c_funptr->n.sym; \ 6535 else \ 6536 return_type = NULL; \ 6537 create_intrinsic_function (u->local_name[0] \ 6538 ? u->local_name : u->use_name, \ 6539 a, iso_c_module_name, \ 6540 INTMOD_ISO_C_BINDING, false, \ 6541 return_type); \ 6542 break; 6543 #define NAMED_SUBROUTINE(a,b,c,d) \ 6544 case a: \ 6545 create_intrinsic_function (u->local_name[0] ? u->local_name \ 6546 : u->use_name, \ 6547 a, iso_c_module_name, \ 6548 INTMOD_ISO_C_BINDING, true, NULL); \ 6549 break; 6550 #include "iso-c-binding.def" 6551 6552 case ISOCBINDING_PTR: 6553 case ISOCBINDING_FUNPTR: 6554 /* Already handled above. */ 6555 break; 6556 default: 6557 if (i == ISOCBINDING_NULL_PTR) 6558 tmp_symtree = c_ptr; 6559 else if (i == ISOCBINDING_NULL_FUNPTR) 6560 tmp_symtree = c_funptr; 6561 else 6562 tmp_symtree = NULL; 6563 generate_isocbinding_symbol (iso_c_module_name, 6564 (iso_c_binding_symbol) i, 6565 u->local_name[0] 6566 ? u->local_name : u->use_name, 6567 tmp_symtree, false); 6568 } 6569 } 6570 6571 if (!found && !only_flag) 6572 { 6573 /* Skip, if the symbol is not in the enabled standard. */ 6574 switch (i) 6575 { 6576 #define NAMED_FUNCTION(a,b,c,d) \ 6577 case a: \ 6578 if ((gfc_option.allow_std & d) == 0) \ 6579 continue; \ 6580 break; 6581 #define NAMED_SUBROUTINE(a,b,c,d) \ 6582 case a: \ 6583 if ((gfc_option.allow_std & d) == 0) \ 6584 continue; \ 6585 break; 6586 #define NAMED_INTCST(a,b,c,d) \ 6587 case a: \ 6588 if ((gfc_option.allow_std & d) == 0) \ 6589 continue; \ 6590 break; 6591 #define NAMED_REALCST(a,b,c,d) \ 6592 case a: \ 6593 if ((gfc_option.allow_std & d) == 0) \ 6594 continue; \ 6595 break; 6596 #define NAMED_CMPXCST(a,b,c,d) \ 6597 case a: \ 6598 if ((gfc_option.allow_std & d) == 0) \ 6599 continue; \ 6600 break; 6601 #include "iso-c-binding.def" 6602 default: 6603 ; /* Not GFC_STD_* versioned. */ 6604 } 6605 6606 switch (i) 6607 { 6608 #define NAMED_FUNCTION(a,b,c,d) \ 6609 case a: \ 6610 if (a == ISOCBINDING_LOC) \ 6611 return_type = c_ptr->n.sym; \ 6612 else if (a == ISOCBINDING_FUNLOC) \ 6613 return_type = c_funptr->n.sym; \ 6614 else \ 6615 return_type = NULL; \ 6616 create_intrinsic_function (b, a, iso_c_module_name, \ 6617 INTMOD_ISO_C_BINDING, false, \ 6618 return_type); \ 6619 break; 6620 #define NAMED_SUBROUTINE(a,b,c,d) \ 6621 case a: \ 6622 create_intrinsic_function (b, a, iso_c_module_name, \ 6623 INTMOD_ISO_C_BINDING, true, NULL); \ 6624 break; 6625 #include "iso-c-binding.def" 6626 6627 case ISOCBINDING_PTR: 6628 case ISOCBINDING_FUNPTR: 6629 /* Already handled above. */ 6630 break; 6631 default: 6632 if (i == ISOCBINDING_NULL_PTR) 6633 tmp_symtree = c_ptr; 6634 else if (i == ISOCBINDING_NULL_FUNPTR) 6635 tmp_symtree = c_funptr; 6636 else 6637 tmp_symtree = NULL; 6638 generate_isocbinding_symbol (iso_c_module_name, 6639 (iso_c_binding_symbol) i, NULL, 6640 tmp_symtree, false); 6641 } 6642 } 6643 } 6644 6645 for (u = gfc_rename_list; u; u = u->next) 6646 { 6647 if (u->found) 6648 continue; 6649 6650 gfc_error ("Symbol %qs referenced at %L not found in intrinsic " 6651 "module ISO_C_BINDING", u->use_name, &u->where); 6652 } 6653 } 6654 6655 6656 /* Add an integer named constant from a given module. */ 6657 6658 static void 6659 create_int_parameter (const char *name, int value, const char *modname, 6660 intmod_id module, int id) 6661 { 6662 gfc_symtree *tmp_symtree; 6663 gfc_symbol *sym; 6664 6665 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name); 6666 if (tmp_symtree != NULL) 6667 { 6668 if (strcmp (modname, tmp_symtree->n.sym->module) == 0) 6669 return; 6670 else 6671 gfc_error ("Symbol %qs already declared", name); 6672 } 6673 6674 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false); 6675 sym = tmp_symtree->n.sym; 6676 6677 sym->module = gfc_get_string ("%s", modname); 6678 sym->attr.flavor = FL_PARAMETER; 6679 sym->ts.type = BT_INTEGER; 6680 sym->ts.kind = gfc_default_integer_kind; 6681 sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL, value); 6682 sym->attr.use_assoc = 1; 6683 sym->from_intmod = module; 6684 sym->intmod_sym_id = id; 6685 } 6686 6687 6688 /* Value is already contained by the array constructor, but not 6689 yet the shape. */ 6690 6691 static void 6692 create_int_parameter_array (const char *name, int size, gfc_expr *value, 6693 const char *modname, intmod_id module, int id) 6694 { 6695 gfc_symtree *tmp_symtree; 6696 gfc_symbol *sym; 6697 6698 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name); 6699 if (tmp_symtree != NULL) 6700 { 6701 if (strcmp (modname, tmp_symtree->n.sym->module) == 0) 6702 return; 6703 else 6704 gfc_error ("Symbol %qs already declared", name); 6705 } 6706 6707 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false); 6708 sym = tmp_symtree->n.sym; 6709 6710 sym->module = gfc_get_string ("%s", modname); 6711 sym->attr.flavor = FL_PARAMETER; 6712 sym->ts.type = BT_INTEGER; 6713 sym->ts.kind = gfc_default_integer_kind; 6714 sym->attr.use_assoc = 1; 6715 sym->from_intmod = module; 6716 sym->intmod_sym_id = id; 6717 sym->attr.dimension = 1; 6718 sym->as = gfc_get_array_spec (); 6719 sym->as->rank = 1; 6720 sym->as->type = AS_EXPLICIT; 6721 sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); 6722 sym->as->upper[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, size); 6723 6724 sym->value = value; 6725 sym->value->shape = gfc_get_shape (1); 6726 mpz_init_set_ui (sym->value->shape[0], size); 6727 } 6728 6729 6730 /* Add an derived type for a given module. */ 6731 6732 static void 6733 create_derived_type (const char *name, const char *modname, 6734 intmod_id module, int id) 6735 { 6736 gfc_symtree *tmp_symtree; 6737 gfc_symbol *sym, *dt_sym; 6738 gfc_interface *intr, *head; 6739 6740 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name); 6741 if (tmp_symtree != NULL) 6742 { 6743 if (strcmp (modname, tmp_symtree->n.sym->module) == 0) 6744 return; 6745 else 6746 gfc_error ("Symbol %qs already declared", name); 6747 } 6748 6749 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false); 6750 sym = tmp_symtree->n.sym; 6751 sym->module = gfc_get_string ("%s", modname); 6752 sym->from_intmod = module; 6753 sym->intmod_sym_id = id; 6754 sym->attr.flavor = FL_PROCEDURE; 6755 sym->attr.function = 1; 6756 sym->attr.generic = 1; 6757 6758 gfc_get_sym_tree (gfc_dt_upper_string (sym->name), 6759 gfc_current_ns, &tmp_symtree, false); 6760 dt_sym = tmp_symtree->n.sym; 6761 dt_sym->name = gfc_get_string ("%s", sym->name); 6762 dt_sym->attr.flavor = FL_DERIVED; 6763 dt_sym->attr.private_comp = 1; 6764 dt_sym->attr.zero_comp = 1; 6765 dt_sym->attr.use_assoc = 1; 6766 dt_sym->module = gfc_get_string ("%s", modname); 6767 dt_sym->from_intmod = module; 6768 dt_sym->intmod_sym_id = id; 6769 6770 head = sym->generic; 6771 intr = gfc_get_interface (); 6772 intr->sym = dt_sym; 6773 intr->where = gfc_current_locus; 6774 intr->next = head; 6775 sym->generic = intr; 6776 sym->attr.if_source = IFSRC_DECL; 6777 } 6778 6779 6780 /* Read the contents of the module file into a temporary buffer. */ 6781 6782 static void 6783 read_module_to_tmpbuf () 6784 { 6785 /* We don't know the uncompressed size, so enlarge the buffer as 6786 needed. */ 6787 int cursz = 4096; 6788 int rsize = cursz; 6789 int len = 0; 6790 6791 module_content = XNEWVEC (char, cursz); 6792 6793 while (1) 6794 { 6795 int nread = gzread (module_fp, module_content + len, rsize); 6796 len += nread; 6797 if (nread < rsize) 6798 break; 6799 cursz *= 2; 6800 module_content = XRESIZEVEC (char, module_content, cursz); 6801 rsize = cursz - len; 6802 } 6803 6804 module_content = XRESIZEVEC (char, module_content, len + 1); 6805 module_content[len] = '\0'; 6806 6807 module_pos = 0; 6808 } 6809 6810 6811 /* USE the ISO_FORTRAN_ENV intrinsic module. */ 6812 6813 static void 6814 use_iso_fortran_env_module (void) 6815 { 6816 static char mod[] = "iso_fortran_env"; 6817 gfc_use_rename *u; 6818 gfc_symbol *mod_sym; 6819 gfc_symtree *mod_symtree; 6820 gfc_expr *expr; 6821 int i, j; 6822 6823 intmod_sym symbol[] = { 6824 #define NAMED_INTCST(a,b,c,d) { a, b, 0, d }, 6825 #define NAMED_KINDARRAY(a,b,c,d) { a, b, 0, d }, 6826 #define NAMED_DERIVED_TYPE(a,b,c,d) { a, b, 0, d }, 6827 #define NAMED_FUNCTION(a,b,c,d) { a, b, c, d }, 6828 #define NAMED_SUBROUTINE(a,b,c,d) { a, b, c, d }, 6829 #include "iso-fortran-env.def" 6830 { ISOFORTRANENV_INVALID, NULL, -1234, 0 } }; 6831 6832 i = 0; 6833 #define NAMED_INTCST(a,b,c,d) symbol[i++].value = c; 6834 #include "iso-fortran-env.def" 6835 6836 /* Generate the symbol for the module itself. */ 6837 mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, mod); 6838 if (mod_symtree == NULL) 6839 { 6840 gfc_get_sym_tree (mod, gfc_current_ns, &mod_symtree, false); 6841 gcc_assert (mod_symtree); 6842 mod_sym = mod_symtree->n.sym; 6843 6844 mod_sym->attr.flavor = FL_MODULE; 6845 mod_sym->attr.intrinsic = 1; 6846 mod_sym->module = gfc_get_string ("%s", mod); 6847 mod_sym->from_intmod = INTMOD_ISO_FORTRAN_ENV; 6848 } 6849 else 6850 if (!mod_symtree->n.sym->attr.intrinsic) 6851 gfc_error ("Use of intrinsic module %qs at %C conflicts with " 6852 "non-intrinsic module name used previously", mod); 6853 6854 /* Generate the symbols for the module integer named constants. */ 6855 6856 for (i = 0; symbol[i].name; i++) 6857 { 6858 bool found = false; 6859 for (u = gfc_rename_list; u; u = u->next) 6860 { 6861 if (strcmp (symbol[i].name, u->use_name) == 0) 6862 { 6863 found = true; 6864 u->found = 1; 6865 6866 if (!gfc_notify_std (symbol[i].standard, "The symbol %qs, " 6867 "referenced at %L, is not in the selected " 6868 "standard", symbol[i].name, &u->where)) 6869 continue; 6870 6871 if ((flag_default_integer || flag_default_real_8) 6872 && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE) 6873 gfc_warning_now (0, "Use of the NUMERIC_STORAGE_SIZE named " 6874 "constant from intrinsic module " 6875 "ISO_FORTRAN_ENV at %L is incompatible with " 6876 "option %qs", &u->where, 6877 flag_default_integer 6878 ? "-fdefault-integer-8" 6879 : "-fdefault-real-8"); 6880 switch (symbol[i].id) 6881 { 6882 #define NAMED_INTCST(a,b,c,d) \ 6883 case a: 6884 #include "iso-fortran-env.def" 6885 create_int_parameter (u->local_name[0] ? u->local_name 6886 : u->use_name, 6887 symbol[i].value, mod, 6888 INTMOD_ISO_FORTRAN_ENV, symbol[i].id); 6889 break; 6890 6891 #define NAMED_KINDARRAY(a,b,KINDS,d) \ 6892 case a:\ 6893 expr = gfc_get_array_expr (BT_INTEGER, \ 6894 gfc_default_integer_kind,\ 6895 NULL); \ 6896 for (j = 0; KINDS[j].kind != 0; j++) \ 6897 gfc_constructor_append_expr (&expr->value.constructor, \ 6898 gfc_get_int_expr (gfc_default_integer_kind, NULL, \ 6899 KINDS[j].kind), NULL); \ 6900 create_int_parameter_array (u->local_name[0] ? u->local_name \ 6901 : u->use_name, \ 6902 j, expr, mod, \ 6903 INTMOD_ISO_FORTRAN_ENV, \ 6904 symbol[i].id); \ 6905 break; 6906 #include "iso-fortran-env.def" 6907 6908 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \ 6909 case a: 6910 #include "iso-fortran-env.def" 6911 create_derived_type (u->local_name[0] ? u->local_name 6912 : u->use_name, 6913 mod, INTMOD_ISO_FORTRAN_ENV, 6914 symbol[i].id); 6915 break; 6916 6917 #define NAMED_FUNCTION(a,b,c,d) \ 6918 case a: 6919 #include "iso-fortran-env.def" 6920 create_intrinsic_function (u->local_name[0] ? u->local_name 6921 : u->use_name, 6922 symbol[i].id, mod, 6923 INTMOD_ISO_FORTRAN_ENV, false, 6924 NULL); 6925 break; 6926 6927 default: 6928 gcc_unreachable (); 6929 } 6930 } 6931 } 6932 6933 if (!found && !only_flag) 6934 { 6935 if ((gfc_option.allow_std & symbol[i].standard) == 0) 6936 continue; 6937 6938 if ((flag_default_integer || flag_default_real_8) 6939 && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE) 6940 gfc_warning_now (0, 6941 "Use of the NUMERIC_STORAGE_SIZE named constant " 6942 "from intrinsic module ISO_FORTRAN_ENV at %C is " 6943 "incompatible with option %s", 6944 flag_default_integer 6945 ? "-fdefault-integer-8" : "-fdefault-real-8"); 6946 6947 switch (symbol[i].id) 6948 { 6949 #define NAMED_INTCST(a,b,c,d) \ 6950 case a: 6951 #include "iso-fortran-env.def" 6952 create_int_parameter (symbol[i].name, symbol[i].value, mod, 6953 INTMOD_ISO_FORTRAN_ENV, symbol[i].id); 6954 break; 6955 6956 #define NAMED_KINDARRAY(a,b,KINDS,d) \ 6957 case a:\ 6958 expr = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, \ 6959 NULL); \ 6960 for (j = 0; KINDS[j].kind != 0; j++) \ 6961 gfc_constructor_append_expr (&expr->value.constructor, \ 6962 gfc_get_int_expr (gfc_default_integer_kind, NULL, \ 6963 KINDS[j].kind), NULL); \ 6964 create_int_parameter_array (symbol[i].name, j, expr, mod, \ 6965 INTMOD_ISO_FORTRAN_ENV, symbol[i].id);\ 6966 break; 6967 #include "iso-fortran-env.def" 6968 6969 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \ 6970 case a: 6971 #include "iso-fortran-env.def" 6972 create_derived_type (symbol[i].name, mod, INTMOD_ISO_FORTRAN_ENV, 6973 symbol[i].id); 6974 break; 6975 6976 #define NAMED_FUNCTION(a,b,c,d) \ 6977 case a: 6978 #include "iso-fortran-env.def" 6979 create_intrinsic_function (symbol[i].name, symbol[i].id, mod, 6980 INTMOD_ISO_FORTRAN_ENV, false, 6981 NULL); 6982 break; 6983 6984 default: 6985 gcc_unreachable (); 6986 } 6987 } 6988 } 6989 6990 for (u = gfc_rename_list; u; u = u->next) 6991 { 6992 if (u->found) 6993 continue; 6994 6995 gfc_error ("Symbol %qs referenced at %L not found in intrinsic " 6996 "module ISO_FORTRAN_ENV", u->use_name, &u->where); 6997 } 6998 } 6999 7000 7001 /* Process a USE directive. */ 7002 7003 static void 7004 gfc_use_module (gfc_use_list *module) 7005 { 7006 char *filename; 7007 gfc_state_data *p; 7008 int c, line, start; 7009 gfc_symtree *mod_symtree; 7010 gfc_use_list *use_stmt; 7011 locus old_locus = gfc_current_locus; 7012 7013 gfc_current_locus = module->where; 7014 module_name = module->module_name; 7015 gfc_rename_list = module->rename; 7016 only_flag = module->only_flag; 7017 current_intmod = INTMOD_NONE; 7018 7019 if (!only_flag) 7020 gfc_warning_now (OPT_Wuse_without_only, 7021 "USE statement at %C has no ONLY qualifier"); 7022 7023 if (gfc_state_stack->state == COMP_MODULE 7024 || module->submodule_name == NULL) 7025 { 7026 filename = XALLOCAVEC (char, strlen (module_name) 7027 + strlen (MODULE_EXTENSION) + 1); 7028 strcpy (filename, module_name); 7029 strcat (filename, MODULE_EXTENSION); 7030 } 7031 else 7032 { 7033 filename = XALLOCAVEC (char, strlen (module->submodule_name) 7034 + strlen (SUBMODULE_EXTENSION) + 1); 7035 strcpy (filename, module->submodule_name); 7036 strcat (filename, SUBMODULE_EXTENSION); 7037 } 7038 7039 /* First, try to find an non-intrinsic module, unless the USE statement 7040 specified that the module is intrinsic. */ 7041 module_fp = NULL; 7042 if (!module->intrinsic) 7043 module_fp = gzopen_included_file (filename, true, true); 7044 7045 /* Then, see if it's an intrinsic one, unless the USE statement 7046 specified that the module is non-intrinsic. */ 7047 if (module_fp == NULL && !module->non_intrinsic) 7048 { 7049 if (strcmp (module_name, "iso_fortran_env") == 0 7050 && gfc_notify_std (GFC_STD_F2003, "ISO_FORTRAN_ENV " 7051 "intrinsic module at %C")) 7052 { 7053 use_iso_fortran_env_module (); 7054 free_rename (module->rename); 7055 module->rename = NULL; 7056 gfc_current_locus = old_locus; 7057 module->intrinsic = true; 7058 return; 7059 } 7060 7061 if (strcmp (module_name, "iso_c_binding") == 0 7062 && gfc_notify_std (GFC_STD_F2003, "ISO_C_BINDING module at %C")) 7063 { 7064 import_iso_c_binding_module(); 7065 free_rename (module->rename); 7066 module->rename = NULL; 7067 gfc_current_locus = old_locus; 7068 module->intrinsic = true; 7069 return; 7070 } 7071 7072 module_fp = gzopen_intrinsic_module (filename); 7073 7074 if (module_fp == NULL && module->intrinsic) 7075 gfc_fatal_error ("Cannot find an intrinsic module named %qs at %C", 7076 module_name); 7077 7078 /* Check for the IEEE modules, so we can mark their symbols 7079 accordingly when we read them. */ 7080 if (strcmp (module_name, "ieee_features") == 0 7081 && gfc_notify_std (GFC_STD_F2003, "IEEE_FEATURES module at %C")) 7082 { 7083 current_intmod = INTMOD_IEEE_FEATURES; 7084 } 7085 else if (strcmp (module_name, "ieee_exceptions") == 0 7086 && gfc_notify_std (GFC_STD_F2003, 7087 "IEEE_EXCEPTIONS module at %C")) 7088 { 7089 current_intmod = INTMOD_IEEE_EXCEPTIONS; 7090 } 7091 else if (strcmp (module_name, "ieee_arithmetic") == 0 7092 && gfc_notify_std (GFC_STD_F2003, 7093 "IEEE_ARITHMETIC module at %C")) 7094 { 7095 current_intmod = INTMOD_IEEE_ARITHMETIC; 7096 } 7097 } 7098 7099 if (module_fp == NULL) 7100 { 7101 if (gfc_state_stack->state != COMP_SUBMODULE 7102 && module->submodule_name == NULL) 7103 gfc_fatal_error ("Cannot open module file %qs for reading at %C: %s", 7104 filename, xstrerror (errno)); 7105 else 7106 gfc_fatal_error ("Module file %qs has not been generated, either " 7107 "because the module does not contain a MODULE " 7108 "PROCEDURE or there is an error in the module.", 7109 filename); 7110 } 7111 7112 /* Check that we haven't already USEd an intrinsic module with the 7113 same name. */ 7114 7115 mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, module_name); 7116 if (mod_symtree && mod_symtree->n.sym->attr.intrinsic) 7117 gfc_error ("Use of non-intrinsic module %qs at %C conflicts with " 7118 "intrinsic module name used previously", module_name); 7119 7120 iomode = IO_INPUT; 7121 module_line = 1; 7122 module_column = 1; 7123 start = 0; 7124 7125 read_module_to_tmpbuf (); 7126 gzclose (module_fp); 7127 7128 /* Skip the first line of the module, after checking that this is 7129 a gfortran module file. */ 7130 line = 0; 7131 while (line < 1) 7132 { 7133 c = module_char (); 7134 if (c == EOF) 7135 bad_module ("Unexpected end of module"); 7136 if (start++ < 3) 7137 parse_name (c); 7138 if ((start == 1 && strcmp (atom_name, "GFORTRAN") != 0) 7139 || (start == 2 && strcmp (atom_name, " module") != 0)) 7140 gfc_fatal_error ("File %qs opened at %C is not a GNU Fortran" 7141 " module file", filename); 7142 if (start == 3) 7143 { 7144 if (strcmp (atom_name, " version") != 0 7145 || module_char () != ' ' 7146 || parse_atom () != ATOM_STRING 7147 || strcmp (atom_string, MOD_VERSION)) 7148 gfc_fatal_error ("Cannot read module file %qs opened at %C," 7149 " because it was created by a different" 7150 " version of GNU Fortran", filename); 7151 7152 free (atom_string); 7153 } 7154 7155 if (c == '\n') 7156 line++; 7157 } 7158 7159 /* Make sure we're not reading the same module that we may be building. */ 7160 for (p = gfc_state_stack; p; p = p->previous) 7161 if ((p->state == COMP_MODULE || p->state == COMP_SUBMODULE) 7162 && strcmp (p->sym->name, module_name) == 0) 7163 { 7164 if (p->state == COMP_SUBMODULE) 7165 gfc_fatal_error ("Cannot USE a submodule that is currently built"); 7166 else 7167 gfc_fatal_error ("Cannot USE a module that is currently built"); 7168 } 7169 7170 init_pi_tree (); 7171 init_true_name_tree (); 7172 7173 read_module (); 7174 7175 free_true_name (true_name_root); 7176 true_name_root = NULL; 7177 7178 free_pi_tree (pi_root); 7179 pi_root = NULL; 7180 7181 XDELETEVEC (module_content); 7182 module_content = NULL; 7183 7184 use_stmt = gfc_get_use_list (); 7185 *use_stmt = *module; 7186 use_stmt->next = gfc_current_ns->use_stmts; 7187 gfc_current_ns->use_stmts = use_stmt; 7188 7189 gfc_current_locus = old_locus; 7190 } 7191 7192 7193 /* Remove duplicated intrinsic operators from the rename list. */ 7194 7195 static void 7196 rename_list_remove_duplicate (gfc_use_rename *list) 7197 { 7198 gfc_use_rename *seek, *last; 7199 7200 for (; list; list = list->next) 7201 if (list->op != INTRINSIC_USER && list->op != INTRINSIC_NONE) 7202 { 7203 last = list; 7204 for (seek = list->next; seek; seek = last->next) 7205 { 7206 if (list->op == seek->op) 7207 { 7208 last->next = seek->next; 7209 free (seek); 7210 } 7211 else 7212 last = seek; 7213 } 7214 } 7215 } 7216 7217 7218 /* Process all USE directives. */ 7219 7220 void 7221 gfc_use_modules (void) 7222 { 7223 gfc_use_list *next, *seek, *last; 7224 7225 for (next = module_list; next; next = next->next) 7226 { 7227 bool non_intrinsic = next->non_intrinsic; 7228 bool intrinsic = next->intrinsic; 7229 bool neither = !non_intrinsic && !intrinsic; 7230 7231 for (seek = next->next; seek; seek = seek->next) 7232 { 7233 if (next->module_name != seek->module_name) 7234 continue; 7235 7236 if (seek->non_intrinsic) 7237 non_intrinsic = true; 7238 else if (seek->intrinsic) 7239 intrinsic = true; 7240 else 7241 neither = true; 7242 } 7243 7244 if (intrinsic && neither && !non_intrinsic) 7245 { 7246 char *filename; 7247 FILE *fp; 7248 7249 filename = XALLOCAVEC (char, 7250 strlen (next->module_name) 7251 + strlen (MODULE_EXTENSION) + 1); 7252 strcpy (filename, next->module_name); 7253 strcat (filename, MODULE_EXTENSION); 7254 fp = gfc_open_included_file (filename, true, true); 7255 if (fp != NULL) 7256 { 7257 non_intrinsic = true; 7258 fclose (fp); 7259 } 7260 } 7261 7262 last = next; 7263 for (seek = next->next; seek; seek = last->next) 7264 { 7265 if (next->module_name != seek->module_name) 7266 { 7267 last = seek; 7268 continue; 7269 } 7270 7271 if ((!next->intrinsic && !seek->intrinsic) 7272 || (next->intrinsic && seek->intrinsic) 7273 || !non_intrinsic) 7274 { 7275 if (!seek->only_flag) 7276 next->only_flag = false; 7277 if (seek->rename) 7278 { 7279 gfc_use_rename *r = seek->rename; 7280 while (r->next) 7281 r = r->next; 7282 r->next = next->rename; 7283 next->rename = seek->rename; 7284 } 7285 last->next = seek->next; 7286 free (seek); 7287 } 7288 else 7289 last = seek; 7290 } 7291 } 7292 7293 for (; module_list; module_list = next) 7294 { 7295 next = module_list->next; 7296 rename_list_remove_duplicate (module_list->rename); 7297 gfc_use_module (module_list); 7298 free (module_list); 7299 } 7300 gfc_rename_list = NULL; 7301 } 7302 7303 7304 void 7305 gfc_free_use_stmts (gfc_use_list *use_stmts) 7306 { 7307 gfc_use_list *next; 7308 for (; use_stmts; use_stmts = next) 7309 { 7310 gfc_use_rename *next_rename; 7311 7312 for (; use_stmts->rename; use_stmts->rename = next_rename) 7313 { 7314 next_rename = use_stmts->rename->next; 7315 free (use_stmts->rename); 7316 } 7317 next = use_stmts->next; 7318 free (use_stmts); 7319 } 7320 } 7321 7322 7323 void 7324 gfc_module_init_2 (void) 7325 { 7326 last_atom = ATOM_LPAREN; 7327 gfc_rename_list = NULL; 7328 module_list = NULL; 7329 } 7330 7331 7332 void 7333 gfc_module_done_2 (void) 7334 { 7335 free_rename (gfc_rename_list); 7336 gfc_rename_list = NULL; 7337 } 7338