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