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