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