Fix ifunc detection in target-supports.exp file.
[official-gcc.git] / gcc / fortran / module.c
blobc833e67f71ff087f560be718229e08a807f41bc8
1 /* Handle modules, which amounts to loading and saving symbols and
2 their attendant structures.
3 Copyright (C) 2000-2018 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
11 version.
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16 for more details.
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
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.
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:
35 ( ( <Interface info for UPLUS> )
36 ( <Interface info for UMINUS> )
37 ...
39 ( ( <name of operator interface> <module of op interface> <i/f1> ... )
40 ...
42 ( ( <name of generic interface> <module of generic interface> <i/f1> ... )
43 ...
45 ( ( <common name> <symbol> <saved flag>)
46 ...
49 ( equivalence list )
51 ( <Symbol Number (in no particular order)>
52 <True name of symbol>
53 <Module name of symbol>
54 ( <symbol information> )
55 ...
57 ( <Symtree name>
58 <Ambiguous flag>
59 <Symbol number>
60 ...
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. */
67 #include "config.h"
68 #include "system.h"
69 #include "coretypes.h"
70 #include "options.h"
71 #include "tree.h"
72 #include "gfortran.h"
73 #include "stringpool.h"
74 #include "arith.h"
75 #include "match.h"
76 #include "parse.h" /* FIXME */
77 #include "constructor.h"
78 #include "cpp.h"
79 #include "scanner.h"
80 #include <zlib.h>
82 #define MODULE_EXTENSION ".mod"
83 #define SUBMODULE_EXTENSION ".smod"
85 /* Don't put any single quote (') in MOD_VERSION, if you want it to be
86 recognized. */
87 #define MOD_VERSION "15"
90 /* Structure that describes a position within a module file. */
92 typedef struct
94 int column, line;
95 long pos;
97 module_locus;
99 /* Structure for list of symbols of intrinsic modules. */
100 typedef struct
102 int id;
103 const char *name;
104 int value;
105 int standard;
107 intmod_sym;
110 typedef enum
112 P_UNKNOWN = 0, P_OTHER, P_NAMESPACE, P_COMPONENT, P_SYMBOL
114 pointer_t;
116 /* The fixup structure lists pointers to pointers that have to
117 be updated when a pointer value becomes known. */
119 typedef struct fixup_t
121 void **pointer;
122 struct fixup_t *next;
124 fixup_t;
127 /* Structure for holding extra info needed for pointers being read. */
129 enum gfc_rsym_state
131 UNUSED,
132 NEEDED,
133 USED
136 enum gfc_wsym_state
138 UNREFERENCED = 0,
139 NEEDS_WRITE,
140 WRITTEN
143 typedef struct pointer_info
145 BBT_HEADER (pointer_info);
146 HOST_WIDE_INT integer;
147 pointer_t type;
149 /* The first component of each member of the union is the pointer
150 being stored. */
152 fixup_t *fixup;
154 union
156 void *pointer; /* Member for doing pointer searches. */
158 struct
160 gfc_symbol *sym;
161 char *true_name, *module, *binding_label;
162 fixup_t *stfixup;
163 gfc_symtree *symtree;
164 enum gfc_rsym_state state;
165 int ns, referenced, renamed;
166 module_locus where;
168 rsym;
170 struct
172 gfc_symbol *sym;
173 enum gfc_wsym_state state;
175 wsym;
180 pointer_info;
182 #define gfc_get_pointer_info() XCNEW (pointer_info)
185 /* Local variables */
187 /* The gzFile for the module we're reading or writing. */
188 static gzFile module_fp;
191 /* The name of the module we're reading (USE'ing) or writing. */
192 static const char *module_name;
193 /* The name of the .smod file that the submodule will write to. */
194 static const char *submodule_name;
196 static gfc_use_list *module_list;
198 /* If we're reading an intrinsic module, this is its ID. */
199 static intmod_id current_intmod;
201 /* Content of module. */
202 static char* module_content;
204 static long module_pos;
205 static int module_line, module_column, only_flag;
206 static int prev_module_line, prev_module_column;
208 static enum
209 { IO_INPUT, IO_OUTPUT }
210 iomode;
212 static gfc_use_rename *gfc_rename_list;
213 static pointer_info *pi_root;
214 static int symbol_number; /* Counter for assigning symbol numbers */
216 /* Tells mio_expr_ref to make symbols for unused equivalence members. */
217 static bool in_load_equiv;
221 /*****************************************************************/
223 /* Pointer/integer conversion. Pointers between structures are stored
224 as integers in the module file. The next couple of subroutines
225 handle this translation for reading and writing. */
227 /* Recursively free the tree of pointer structures. */
229 static void
230 free_pi_tree (pointer_info *p)
232 if (p == NULL)
233 return;
235 if (p->fixup != NULL)
236 gfc_internal_error ("free_pi_tree(): Unresolved fixup");
238 free_pi_tree (p->left);
239 free_pi_tree (p->right);
241 if (iomode == IO_INPUT)
243 XDELETEVEC (p->u.rsym.true_name);
244 XDELETEVEC (p->u.rsym.module);
245 XDELETEVEC (p->u.rsym.binding_label);
248 free (p);
252 /* Compare pointers when searching by pointer. Used when writing a
253 module. */
255 static int
256 compare_pointers (void *_sn1, void *_sn2)
258 pointer_info *sn1, *sn2;
260 sn1 = (pointer_info *) _sn1;
261 sn2 = (pointer_info *) _sn2;
263 if (sn1->u.pointer < sn2->u.pointer)
264 return -1;
265 if (sn1->u.pointer > sn2->u.pointer)
266 return 1;
268 return 0;
272 /* Compare integers when searching by integer. Used when reading a
273 module. */
275 static int
276 compare_integers (void *_sn1, void *_sn2)
278 pointer_info *sn1, *sn2;
280 sn1 = (pointer_info *) _sn1;
281 sn2 = (pointer_info *) _sn2;
283 if (sn1->integer < sn2->integer)
284 return -1;
285 if (sn1->integer > sn2->integer)
286 return 1;
288 return 0;
292 /* Initialize the pointer_info tree. */
294 static void
295 init_pi_tree (void)
297 compare_fn compare;
298 pointer_info *p;
300 pi_root = NULL;
301 compare = (iomode == IO_INPUT) ? compare_integers : compare_pointers;
303 /* Pointer 0 is the NULL pointer. */
304 p = gfc_get_pointer_info ();
305 p->u.pointer = NULL;
306 p->integer = 0;
307 p->type = P_OTHER;
309 gfc_insert_bbt (&pi_root, p, compare);
311 /* Pointer 1 is the current namespace. */
312 p = gfc_get_pointer_info ();
313 p->u.pointer = gfc_current_ns;
314 p->integer = 1;
315 p->type = P_NAMESPACE;
317 gfc_insert_bbt (&pi_root, p, compare);
319 symbol_number = 2;
323 /* During module writing, call here with a pointer to something,
324 returning the pointer_info node. */
326 static pointer_info *
327 find_pointer (void *gp)
329 pointer_info *p;
331 p = pi_root;
332 while (p != NULL)
334 if (p->u.pointer == gp)
335 break;
336 p = (gp < p->u.pointer) ? p->left : p->right;
339 return p;
343 /* Given a pointer while writing, returns the pointer_info tree node,
344 creating it if it doesn't exist. */
346 static pointer_info *
347 get_pointer (void *gp)
349 pointer_info *p;
351 p = find_pointer (gp);
352 if (p != NULL)
353 return p;
355 /* Pointer doesn't have an integer. Give it one. */
356 p = gfc_get_pointer_info ();
358 p->u.pointer = gp;
359 p->integer = symbol_number++;
361 gfc_insert_bbt (&pi_root, p, compare_pointers);
363 return p;
367 /* Given an integer during reading, find it in the pointer_info tree,
368 creating the node if not found. */
370 static pointer_info *
371 get_integer (HOST_WIDE_INT integer)
373 pointer_info *p, t;
374 int c;
376 t.integer = integer;
378 p = pi_root;
379 while (p != NULL)
381 c = compare_integers (&t, p);
382 if (c == 0)
383 break;
385 p = (c < 0) ? p->left : p->right;
388 if (p != NULL)
389 return p;
391 p = gfc_get_pointer_info ();
392 p->integer = integer;
393 p->u.pointer = NULL;
395 gfc_insert_bbt (&pi_root, p, compare_integers);
397 return p;
401 /* Resolve any fixups using a known pointer. */
403 static void
404 resolve_fixups (fixup_t *f, void *gp)
406 fixup_t *next;
408 for (; f; f = next)
410 next = f->next;
411 *(f->pointer) = gp;
412 free (f);
417 /* Convert a string such that it starts with a lower-case character. Used
418 to convert the symtree name of a derived-type to the symbol name or to
419 the name of the associated generic function. */
421 const char *
422 gfc_dt_lower_string (const char *name)
424 if (name[0] != (char) TOLOWER ((unsigned char) name[0]))
425 return gfc_get_string ("%c%s", (char) TOLOWER ((unsigned char) name[0]),
426 &name[1]);
427 return gfc_get_string ("%s", name);
431 /* Convert a string such that it starts with an upper-case character. Used to
432 return the symtree-name for a derived type; the symbol name itself and the
433 symtree/symbol name of the associated generic function start with a lower-
434 case character. */
436 const char *
437 gfc_dt_upper_string (const char *name)
439 if (name[0] != (char) TOUPPER ((unsigned char) name[0]))
440 return gfc_get_string ("%c%s", (char) TOUPPER ((unsigned char) name[0]),
441 &name[1]);
442 return gfc_get_string ("%s", name);
445 /* Call here during module reading when we know what pointer to
446 associate with an integer. Any fixups that exist are resolved at
447 this time. */
449 static void
450 associate_integer_pointer (pointer_info *p, void *gp)
452 if (p->u.pointer != NULL)
453 gfc_internal_error ("associate_integer_pointer(): Already associated");
455 p->u.pointer = gp;
457 resolve_fixups (p->fixup, gp);
459 p->fixup = NULL;
463 /* During module reading, given an integer and a pointer to a pointer,
464 either store the pointer from an already-known value or create a
465 fixup structure in order to store things later. Returns zero if
466 the reference has been actually stored, or nonzero if the reference
467 must be fixed later (i.e., associate_integer_pointer must be called
468 sometime later. Returns the pointer_info structure. */
470 static pointer_info *
471 add_fixup (HOST_WIDE_INT integer, void *gp)
473 pointer_info *p;
474 fixup_t *f;
475 char **cp;
477 p = get_integer (integer);
479 if (p->integer == 0 || p->u.pointer != NULL)
481 cp = (char **) gp;
482 *cp = (char *) p->u.pointer;
484 else
486 f = XCNEW (fixup_t);
488 f->next = p->fixup;
489 p->fixup = f;
491 f->pointer = (void **) gp;
494 return p;
498 /*****************************************************************/
500 /* Parser related subroutines */
502 /* Free the rename list left behind by a USE statement. */
504 static void
505 free_rename (gfc_use_rename *list)
507 gfc_use_rename *next;
509 for (; list; list = next)
511 next = list->next;
512 free (list);
517 /* Match a USE statement. */
519 match
520 gfc_match_use (void)
522 char name[GFC_MAX_SYMBOL_LEN + 1], module_nature[GFC_MAX_SYMBOL_LEN + 1];
523 gfc_use_rename *tail = NULL, *new_use;
524 interface_type type, type2;
525 gfc_intrinsic_op op;
526 match m;
527 gfc_use_list *use_list;
529 use_list = gfc_get_use_list ();
531 if (gfc_match (" , ") == MATCH_YES)
533 if ((m = gfc_match (" %n ::", module_nature)) == MATCH_YES)
535 if (!gfc_notify_std (GFC_STD_F2003, "module "
536 "nature in USE statement at %C"))
537 goto cleanup;
539 if (strcmp (module_nature, "intrinsic") == 0)
540 use_list->intrinsic = true;
541 else
543 if (strcmp (module_nature, "non_intrinsic") == 0)
544 use_list->non_intrinsic = true;
545 else
547 gfc_error ("Module nature in USE statement at %C shall "
548 "be either INTRINSIC or NON_INTRINSIC");
549 goto cleanup;
553 else
555 /* Help output a better error message than "Unclassifiable
556 statement". */
557 gfc_match (" %n", module_nature);
558 if (strcmp (module_nature, "intrinsic") == 0
559 || strcmp (module_nature, "non_intrinsic") == 0)
560 gfc_error ("\"::\" was expected after module nature at %C "
561 "but was not found");
562 free (use_list);
563 return m;
566 else
568 m = gfc_match (" ::");
569 if (m == MATCH_YES &&
570 !gfc_notify_std(GFC_STD_F2003, "\"USE :: module\" at %C"))
571 goto cleanup;
573 if (m != MATCH_YES)
575 m = gfc_match ("% ");
576 if (m != MATCH_YES)
578 free (use_list);
579 return m;
584 use_list->where = gfc_current_locus;
586 m = gfc_match_name (name);
587 if (m != MATCH_YES)
589 free (use_list);
590 return m;
593 use_list->module_name = gfc_get_string ("%s", name);
595 if (gfc_match_eos () == MATCH_YES)
596 goto done;
598 if (gfc_match_char (',') != MATCH_YES)
599 goto syntax;
601 if (gfc_match (" only :") == MATCH_YES)
602 use_list->only_flag = true;
604 if (gfc_match_eos () == MATCH_YES)
605 goto done;
607 for (;;)
609 /* Get a new rename struct and add it to the rename list. */
610 new_use = gfc_get_use_rename ();
611 new_use->where = gfc_current_locus;
612 new_use->found = 0;
614 if (use_list->rename == NULL)
615 use_list->rename = new_use;
616 else
617 tail->next = new_use;
618 tail = new_use;
620 /* See what kind of interface we're dealing with. Assume it is
621 not an operator. */
622 new_use->op = INTRINSIC_NONE;
623 if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR)
624 goto cleanup;
626 switch (type)
628 case INTERFACE_NAMELESS:
629 gfc_error ("Missing generic specification in USE statement at %C");
630 goto cleanup;
632 case INTERFACE_USER_OP:
633 case INTERFACE_GENERIC:
634 case INTERFACE_DTIO:
635 m = gfc_match (" =>");
637 if (type == INTERFACE_USER_OP && m == MATCH_YES
638 && (!gfc_notify_std(GFC_STD_F2003, "Renaming "
639 "operators in USE statements at %C")))
640 goto cleanup;
642 if (type == INTERFACE_USER_OP)
643 new_use->op = INTRINSIC_USER;
645 if (use_list->only_flag)
647 if (m != MATCH_YES)
648 strcpy (new_use->use_name, name);
649 else
651 strcpy (new_use->local_name, name);
652 m = gfc_match_generic_spec (&type2, new_use->use_name, &op);
653 if (type != type2)
654 goto syntax;
655 if (m == MATCH_NO)
656 goto syntax;
657 if (m == MATCH_ERROR)
658 goto cleanup;
661 else
663 if (m != MATCH_YES)
664 goto syntax;
665 strcpy (new_use->local_name, name);
667 m = gfc_match_generic_spec (&type2, new_use->use_name, &op);
668 if (type != type2)
669 goto syntax;
670 if (m == MATCH_NO)
671 goto syntax;
672 if (m == MATCH_ERROR)
673 goto cleanup;
676 if (strcmp (new_use->use_name, use_list->module_name) == 0
677 || strcmp (new_use->local_name, use_list->module_name) == 0)
679 gfc_error ("The name %qs at %C has already been used as "
680 "an external module name", use_list->module_name);
681 goto cleanup;
683 break;
685 case INTERFACE_INTRINSIC_OP:
686 new_use->op = op;
687 break;
689 default:
690 gcc_unreachable ();
693 if (gfc_match_eos () == MATCH_YES)
694 break;
695 if (gfc_match_char (',') != MATCH_YES)
696 goto syntax;
699 done:
700 if (module_list)
702 gfc_use_list *last = module_list;
703 while (last->next)
704 last = last->next;
705 last->next = use_list;
707 else
708 module_list = use_list;
710 return MATCH_YES;
712 syntax:
713 gfc_syntax_error (ST_USE);
715 cleanup:
716 free_rename (use_list->rename);
717 free (use_list);
718 return MATCH_ERROR;
722 /* Match a SUBMODULE statement.
724 According to F2008:11.2.3.2, "The submodule identifier is the
725 ordered pair whose first element is the ancestor module name and
726 whose second element is the submodule name. 'Submodule_name' is
727 used for the submodule filename and uses '@' as a separator, whilst
728 the name of the symbol for the module uses '.' as a a separator.
729 The reasons for these choices are:
730 (i) To follow another leading brand in the submodule filenames;
731 (ii) Since '.' is not particularly visible in the filenames; and
732 (iii) The linker does not permit '@' in mnemonics. */
734 match
735 gfc_match_submodule (void)
737 match m;
738 char name[GFC_MAX_SYMBOL_LEN + 1];
739 gfc_use_list *use_list;
740 bool seen_colon = false;
742 if (!gfc_notify_std (GFC_STD_F2008, "SUBMODULE declaration at %C"))
743 return MATCH_ERROR;
745 if (gfc_current_state () != COMP_NONE)
747 gfc_error ("SUBMODULE declaration at %C cannot appear within "
748 "another scoping unit");
749 return MATCH_ERROR;
752 gfc_new_block = NULL;
753 gcc_assert (module_list == NULL);
755 if (gfc_match_char ('(') != MATCH_YES)
756 goto syntax;
758 while (1)
760 m = gfc_match (" %n", name);
761 if (m != MATCH_YES)
762 goto syntax;
764 use_list = gfc_get_use_list ();
765 use_list->where = gfc_current_locus;
767 if (module_list)
769 gfc_use_list *last = module_list;
770 while (last->next)
771 last = last->next;
772 last->next = use_list;
773 use_list->module_name
774 = gfc_get_string ("%s.%s", module_list->module_name, name);
775 use_list->submodule_name
776 = gfc_get_string ("%s@%s", module_list->module_name, name);
778 else
780 module_list = use_list;
781 use_list->module_name = gfc_get_string ("%s", name);
782 use_list->submodule_name = use_list->module_name;
785 if (gfc_match_char (')') == MATCH_YES)
786 break;
788 if (gfc_match_char (':') != MATCH_YES
789 || seen_colon)
790 goto syntax;
792 seen_colon = true;
795 m = gfc_match (" %s%t", &gfc_new_block);
796 if (m != MATCH_YES)
797 goto syntax;
799 submodule_name = gfc_get_string ("%s@%s", module_list->module_name,
800 gfc_new_block->name);
802 gfc_new_block->name = gfc_get_string ("%s.%s",
803 module_list->module_name,
804 gfc_new_block->name);
806 if (!gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
807 gfc_new_block->name, NULL))
808 return MATCH_ERROR;
810 /* Just retain the ultimate .(s)mod file for reading, since it
811 contains all the information in its ancestors. */
812 use_list = module_list;
813 for (; module_list->next; use_list = module_list)
815 module_list = use_list->next;
816 free (use_list);
819 return MATCH_YES;
821 syntax:
822 gfc_error ("Syntax error in SUBMODULE statement at %C");
823 return MATCH_ERROR;
827 /* Given a name and a number, inst, return the inst name
828 under which to load this symbol. Returns NULL if this
829 symbol shouldn't be loaded. If inst is zero, returns
830 the number of instances of this name. If interface is
831 true, a user-defined operator is sought, otherwise only
832 non-operators are sought. */
834 static const char *
835 find_use_name_n (const char *name, int *inst, bool interface)
837 gfc_use_rename *u;
838 const char *low_name = NULL;
839 int i;
841 /* For derived types. */
842 if (name[0] != (char) TOLOWER ((unsigned char) name[0]))
843 low_name = gfc_dt_lower_string (name);
845 i = 0;
846 for (u = gfc_rename_list; u; u = u->next)
848 if ((!low_name && strcmp (u->use_name, name) != 0)
849 || (low_name && strcmp (u->use_name, low_name) != 0)
850 || (u->op == INTRINSIC_USER && !interface)
851 || (u->op != INTRINSIC_USER && interface))
852 continue;
853 if (++i == *inst)
854 break;
857 if (!*inst)
859 *inst = i;
860 return NULL;
863 if (u == NULL)
864 return only_flag ? NULL : name;
866 u->found = 1;
868 if (low_name)
870 if (u->local_name[0] == '\0')
871 return name;
872 return gfc_dt_upper_string (u->local_name);
875 return (u->local_name[0] != '\0') ? u->local_name : name;
879 /* Given a name, return the name under which to load this symbol.
880 Returns NULL if this symbol shouldn't be loaded. */
882 static const char *
883 find_use_name (const char *name, bool interface)
885 int i = 1;
886 return find_use_name_n (name, &i, interface);
890 /* Given a real name, return the number of use names associated with it. */
892 static int
893 number_use_names (const char *name, bool interface)
895 int i = 0;
896 find_use_name_n (name, &i, interface);
897 return i;
901 /* Try to find the operator in the current list. */
903 static gfc_use_rename *
904 find_use_operator (gfc_intrinsic_op op)
906 gfc_use_rename *u;
908 for (u = gfc_rename_list; u; u = u->next)
909 if (u->op == op)
910 return u;
912 return NULL;
916 /*****************************************************************/
918 /* The next couple of subroutines maintain a tree used to avoid a
919 brute-force search for a combination of true name and module name.
920 While symtree names, the name that a particular symbol is known by
921 can changed with USE statements, we still have to keep track of the
922 true names to generate the correct reference, and also avoid
923 loading the same real symbol twice in a program unit.
925 When we start reading, the true name tree is built and maintained
926 as symbols are read. The tree is searched as we load new symbols
927 to see if it already exists someplace in the namespace. */
929 typedef struct true_name
931 BBT_HEADER (true_name);
932 const char *name;
933 gfc_symbol *sym;
935 true_name;
937 static true_name *true_name_root;
940 /* Compare two true_name structures. */
942 static int
943 compare_true_names (void *_t1, void *_t2)
945 true_name *t1, *t2;
946 int c;
948 t1 = (true_name *) _t1;
949 t2 = (true_name *) _t2;
951 c = ((t1->sym->module > t2->sym->module)
952 - (t1->sym->module < t2->sym->module));
953 if (c != 0)
954 return c;
956 return strcmp (t1->name, t2->name);
960 /* Given a true name, search the true name tree to see if it exists
961 within the main namespace. */
963 static gfc_symbol *
964 find_true_name (const char *name, const char *module)
966 true_name t, *p;
967 gfc_symbol sym;
968 int c;
970 t.name = gfc_get_string ("%s", name);
971 if (module != NULL)
972 sym.module = gfc_get_string ("%s", module);
973 else
974 sym.module = NULL;
975 t.sym = &sym;
977 p = true_name_root;
978 while (p != NULL)
980 c = compare_true_names ((void *) (&t), (void *) p);
981 if (c == 0)
982 return p->sym;
984 p = (c < 0) ? p->left : p->right;
987 return NULL;
991 /* Given a gfc_symbol pointer that is not in the true name tree, add it. */
993 static void
994 add_true_name (gfc_symbol *sym)
996 true_name *t;
998 t = XCNEW (true_name);
999 t->sym = sym;
1000 if (gfc_fl_struct (sym->attr.flavor))
1001 t->name = gfc_dt_upper_string (sym->name);
1002 else
1003 t->name = sym->name;
1005 gfc_insert_bbt (&true_name_root, t, compare_true_names);
1009 /* Recursive function to build the initial true name tree by
1010 recursively traversing the current namespace. */
1012 static void
1013 build_tnt (gfc_symtree *st)
1015 const char *name;
1016 if (st == NULL)
1017 return;
1019 build_tnt (st->left);
1020 build_tnt (st->right);
1022 if (gfc_fl_struct (st->n.sym->attr.flavor))
1023 name = gfc_dt_upper_string (st->n.sym->name);
1024 else
1025 name = st->n.sym->name;
1027 if (find_true_name (name, st->n.sym->module) != NULL)
1028 return;
1030 add_true_name (st->n.sym);
1034 /* Initialize the true name tree with the current namespace. */
1036 static void
1037 init_true_name_tree (void)
1039 true_name_root = NULL;
1040 build_tnt (gfc_current_ns->sym_root);
1044 /* Recursively free a true name tree node. */
1046 static void
1047 free_true_name (true_name *t)
1049 if (t == NULL)
1050 return;
1051 free_true_name (t->left);
1052 free_true_name (t->right);
1054 free (t);
1058 /*****************************************************************/
1060 /* Module reading and writing. */
1062 /* The following are versions similar to the ones in scanner.c, but
1063 for dealing with compressed module files. */
1065 static gzFile
1066 gzopen_included_file_1 (const char *name, gfc_directorylist *list,
1067 bool module, bool system)
1069 char *fullname;
1070 gfc_directorylist *p;
1071 gzFile f;
1073 for (p = list; p; p = p->next)
1075 if (module && !p->use_for_modules)
1076 continue;
1078 fullname = (char *) alloca(strlen (p->path) + strlen (name) + 1);
1079 strcpy (fullname, p->path);
1080 strcat (fullname, name);
1082 f = gzopen (fullname, "r");
1083 if (f != NULL)
1085 if (gfc_cpp_makedep ())
1086 gfc_cpp_add_dep (fullname, system);
1088 return f;
1092 return NULL;
1095 static gzFile
1096 gzopen_included_file (const char *name, bool include_cwd, bool module)
1098 gzFile f = NULL;
1100 if (IS_ABSOLUTE_PATH (name) || include_cwd)
1102 f = gzopen (name, "r");
1103 if (f && gfc_cpp_makedep ())
1104 gfc_cpp_add_dep (name, false);
1107 if (!f)
1108 f = gzopen_included_file_1 (name, include_dirs, module, false);
1110 return f;
1113 static gzFile
1114 gzopen_intrinsic_module (const char* name)
1116 gzFile f = NULL;
1118 if (IS_ABSOLUTE_PATH (name))
1120 f = gzopen (name, "r");
1121 if (f && gfc_cpp_makedep ())
1122 gfc_cpp_add_dep (name, true);
1125 if (!f)
1126 f = gzopen_included_file_1 (name, intrinsic_modules_dirs, true, true);
1128 return f;
1132 enum atom_type
1134 ATOM_NAME, ATOM_LPAREN, ATOM_RPAREN, ATOM_INTEGER, ATOM_STRING
1137 static atom_type last_atom;
1140 /* The name buffer must be at least as long as a symbol name. Right
1141 now it's not clear how we're going to store numeric constants--
1142 probably as a hexadecimal string, since this will allow the exact
1143 number to be preserved (this can't be done by a decimal
1144 representation). Worry about that later. TODO! */
1146 #define MAX_ATOM_SIZE 100
1148 static HOST_WIDE_INT atom_int;
1149 static char *atom_string, atom_name[MAX_ATOM_SIZE];
1152 /* Report problems with a module. Error reporting is not very
1153 elaborate, since this sorts of errors shouldn't really happen.
1154 This subroutine never returns. */
1156 static void bad_module (const char *) ATTRIBUTE_NORETURN;
1158 static void
1159 bad_module (const char *msgid)
1161 XDELETEVEC (module_content);
1162 module_content = NULL;
1164 switch (iomode)
1166 case IO_INPUT:
1167 gfc_fatal_error ("Reading module %qs at line %d column %d: %s",
1168 module_name, module_line, module_column, msgid);
1169 break;
1170 case IO_OUTPUT:
1171 gfc_fatal_error ("Writing module %qs at line %d column %d: %s",
1172 module_name, module_line, module_column, msgid);
1173 break;
1174 default:
1175 gfc_fatal_error ("Module %qs at line %d column %d: %s",
1176 module_name, module_line, module_column, msgid);
1177 break;
1182 /* Set the module's input pointer. */
1184 static void
1185 set_module_locus (module_locus *m)
1187 module_column = m->column;
1188 module_line = m->line;
1189 module_pos = m->pos;
1193 /* Get the module's input pointer so that we can restore it later. */
1195 static void
1196 get_module_locus (module_locus *m)
1198 m->column = module_column;
1199 m->line = module_line;
1200 m->pos = module_pos;
1204 /* Get the next character in the module, updating our reckoning of
1205 where we are. */
1207 static int
1208 module_char (void)
1210 const char c = module_content[module_pos++];
1211 if (c == '\0')
1212 bad_module ("Unexpected EOF");
1214 prev_module_line = module_line;
1215 prev_module_column = module_column;
1217 if (c == '\n')
1219 module_line++;
1220 module_column = 0;
1223 module_column++;
1224 return c;
1227 /* Unget a character while remembering the line and column. Works for
1228 a single character only. */
1230 static void
1231 module_unget_char (void)
1233 module_line = prev_module_line;
1234 module_column = prev_module_column;
1235 module_pos--;
1238 /* Parse a string constant. The delimiter is guaranteed to be a
1239 single quote. */
1241 static void
1242 parse_string (void)
1244 int c;
1245 size_t cursz = 30;
1246 size_t len = 0;
1248 atom_string = XNEWVEC (char, cursz);
1250 for ( ; ; )
1252 c = module_char ();
1254 if (c == '\'')
1256 int c2 = module_char ();
1257 if (c2 != '\'')
1259 module_unget_char ();
1260 break;
1264 if (len >= cursz)
1266 cursz *= 2;
1267 atom_string = XRESIZEVEC (char, atom_string, cursz);
1269 atom_string[len] = c;
1270 len++;
1273 atom_string = XRESIZEVEC (char, atom_string, len + 1);
1274 atom_string[len] = '\0'; /* C-style string for debug purposes. */
1278 /* Parse an integer. Should fit in a HOST_WIDE_INT. */
1280 static void
1281 parse_integer (int c)
1283 atom_int = c - '0';
1285 for (;;)
1287 c = module_char ();
1288 if (!ISDIGIT (c))
1290 module_unget_char ();
1291 break;
1294 atom_int = 10 * atom_int + c - '0';
1300 /* Parse a name. */
1302 static void
1303 parse_name (int c)
1305 char *p;
1306 int len;
1308 p = atom_name;
1310 *p++ = c;
1311 len = 1;
1313 for (;;)
1315 c = module_char ();
1316 if (!ISALNUM (c) && c != '_' && c != '-')
1318 module_unget_char ();
1319 break;
1322 *p++ = c;
1323 if (++len > GFC_MAX_SYMBOL_LEN)
1324 bad_module ("Name too long");
1327 *p = '\0';
1332 /* Read the next atom in the module's input stream. */
1334 static atom_type
1335 parse_atom (void)
1337 int c;
1341 c = module_char ();
1343 while (c == ' ' || c == '\r' || c == '\n');
1345 switch (c)
1347 case '(':
1348 return ATOM_LPAREN;
1350 case ')':
1351 return ATOM_RPAREN;
1353 case '\'':
1354 parse_string ();
1355 return ATOM_STRING;
1357 case '0':
1358 case '1':
1359 case '2':
1360 case '3':
1361 case '4':
1362 case '5':
1363 case '6':
1364 case '7':
1365 case '8':
1366 case '9':
1367 parse_integer (c);
1368 return ATOM_INTEGER;
1370 case 'a':
1371 case 'b':
1372 case 'c':
1373 case 'd':
1374 case 'e':
1375 case 'f':
1376 case 'g':
1377 case 'h':
1378 case 'i':
1379 case 'j':
1380 case 'k':
1381 case 'l':
1382 case 'm':
1383 case 'n':
1384 case 'o':
1385 case 'p':
1386 case 'q':
1387 case 'r':
1388 case 's':
1389 case 't':
1390 case 'u':
1391 case 'v':
1392 case 'w':
1393 case 'x':
1394 case 'y':
1395 case 'z':
1396 case 'A':
1397 case 'B':
1398 case 'C':
1399 case 'D':
1400 case 'E':
1401 case 'F':
1402 case 'G':
1403 case 'H':
1404 case 'I':
1405 case 'J':
1406 case 'K':
1407 case 'L':
1408 case 'M':
1409 case 'N':
1410 case 'O':
1411 case 'P':
1412 case 'Q':
1413 case 'R':
1414 case 'S':
1415 case 'T':
1416 case 'U':
1417 case 'V':
1418 case 'W':
1419 case 'X':
1420 case 'Y':
1421 case 'Z':
1422 parse_name (c);
1423 return ATOM_NAME;
1425 default:
1426 bad_module ("Bad name");
1429 /* Not reached. */
1433 /* Peek at the next atom on the input. */
1435 static atom_type
1436 peek_atom (void)
1438 int c;
1442 c = module_char ();
1444 while (c == ' ' || c == '\r' || c == '\n');
1446 switch (c)
1448 case '(':
1449 module_unget_char ();
1450 return ATOM_LPAREN;
1452 case ')':
1453 module_unget_char ();
1454 return ATOM_RPAREN;
1456 case '\'':
1457 module_unget_char ();
1458 return ATOM_STRING;
1460 case '0':
1461 case '1':
1462 case '2':
1463 case '3':
1464 case '4':
1465 case '5':
1466 case '6':
1467 case '7':
1468 case '8':
1469 case '9':
1470 module_unget_char ();
1471 return ATOM_INTEGER;
1473 case 'a':
1474 case 'b':
1475 case 'c':
1476 case 'd':
1477 case 'e':
1478 case 'f':
1479 case 'g':
1480 case 'h':
1481 case 'i':
1482 case 'j':
1483 case 'k':
1484 case 'l':
1485 case 'm':
1486 case 'n':
1487 case 'o':
1488 case 'p':
1489 case 'q':
1490 case 'r':
1491 case 's':
1492 case 't':
1493 case 'u':
1494 case 'v':
1495 case 'w':
1496 case 'x':
1497 case 'y':
1498 case 'z':
1499 case 'A':
1500 case 'B':
1501 case 'C':
1502 case 'D':
1503 case 'E':
1504 case 'F':
1505 case 'G':
1506 case 'H':
1507 case 'I':
1508 case 'J':
1509 case 'K':
1510 case 'L':
1511 case 'M':
1512 case 'N':
1513 case 'O':
1514 case 'P':
1515 case 'Q':
1516 case 'R':
1517 case 'S':
1518 case 'T':
1519 case 'U':
1520 case 'V':
1521 case 'W':
1522 case 'X':
1523 case 'Y':
1524 case 'Z':
1525 module_unget_char ();
1526 return ATOM_NAME;
1528 default:
1529 bad_module ("Bad name");
1534 /* Read the next atom from the input, requiring that it be a
1535 particular kind. */
1537 static void
1538 require_atom (atom_type type)
1540 atom_type t;
1541 const char *p;
1542 int column, line;
1544 column = module_column;
1545 line = module_line;
1547 t = parse_atom ();
1548 if (t != type)
1550 switch (type)
1552 case ATOM_NAME:
1553 p = _("Expected name");
1554 break;
1555 case ATOM_LPAREN:
1556 p = _("Expected left parenthesis");
1557 break;
1558 case ATOM_RPAREN:
1559 p = _("Expected right parenthesis");
1560 break;
1561 case ATOM_INTEGER:
1562 p = _("Expected integer");
1563 break;
1564 case ATOM_STRING:
1565 p = _("Expected string");
1566 break;
1567 default:
1568 gfc_internal_error ("require_atom(): bad atom type required");
1571 module_column = column;
1572 module_line = line;
1573 bad_module (p);
1578 /* Given a pointer to an mstring array, require that the current input
1579 be one of the strings in the array. We return the enum value. */
1581 static int
1582 find_enum (const mstring *m)
1584 int i;
1586 i = gfc_string2code (m, atom_name);
1587 if (i >= 0)
1588 return i;
1590 bad_module ("find_enum(): Enum not found");
1592 /* Not reached. */
1596 /* Read a string. The caller is responsible for freeing. */
1598 static char*
1599 read_string (void)
1601 char* p;
1602 require_atom (ATOM_STRING);
1603 p = atom_string;
1604 atom_string = NULL;
1605 return p;
1609 /**************** Module output subroutines ***************************/
1611 /* Output a character to a module file. */
1613 static void
1614 write_char (char out)
1616 if (gzputc (module_fp, out) == EOF)
1617 gfc_fatal_error ("Error writing modules file: %s", xstrerror (errno));
1619 if (out != '\n')
1620 module_column++;
1621 else
1623 module_column = 1;
1624 module_line++;
1629 /* Write an atom to a module. The line wrapping isn't perfect, but it
1630 should work most of the time. This isn't that big of a deal, since
1631 the file really isn't meant to be read by people anyway. */
1633 static void
1634 write_atom (atom_type atom, const void *v)
1636 char buffer[32];
1638 /* Workaround -Wmaybe-uninitialized false positive during
1639 profiledbootstrap by initializing them. */
1640 int len;
1641 HOST_WIDE_INT i = 0;
1642 const char *p;
1644 switch (atom)
1646 case ATOM_STRING:
1647 case ATOM_NAME:
1648 p = (const char *) v;
1649 break;
1651 case ATOM_LPAREN:
1652 p = "(";
1653 break;
1655 case ATOM_RPAREN:
1656 p = ")";
1657 break;
1659 case ATOM_INTEGER:
1660 i = *((const HOST_WIDE_INT *) v);
1662 snprintf (buffer, sizeof (buffer), HOST_WIDE_INT_PRINT_DEC, i);
1663 p = buffer;
1664 break;
1666 default:
1667 gfc_internal_error ("write_atom(): Trying to write dab atom");
1671 if(p == NULL || *p == '\0')
1672 len = 0;
1673 else
1674 len = strlen (p);
1676 if (atom != ATOM_RPAREN)
1678 if (module_column + len > 72)
1679 write_char ('\n');
1680 else
1683 if (last_atom != ATOM_LPAREN && module_column != 1)
1684 write_char (' ');
1688 if (atom == ATOM_STRING)
1689 write_char ('\'');
1691 while (p != NULL && *p)
1693 if (atom == ATOM_STRING && *p == '\'')
1694 write_char ('\'');
1695 write_char (*p++);
1698 if (atom == ATOM_STRING)
1699 write_char ('\'');
1701 last_atom = atom;
1706 /***************** Mid-level I/O subroutines *****************/
1708 /* These subroutines let their caller read or write atoms without
1709 caring about which of the two is actually happening. This lets a
1710 subroutine concentrate on the actual format of the data being
1711 written. */
1713 static void mio_expr (gfc_expr **);
1714 pointer_info *mio_symbol_ref (gfc_symbol **);
1715 pointer_info *mio_interface_rest (gfc_interface **);
1716 static void mio_symtree_ref (gfc_symtree **);
1718 /* Read or write an enumerated value. On writing, we return the input
1719 value for the convenience of callers. We avoid using an integer
1720 pointer because enums are sometimes inside bitfields. */
1722 static int
1723 mio_name (int t, const mstring *m)
1725 if (iomode == IO_OUTPUT)
1726 write_atom (ATOM_NAME, gfc_code2string (m, t));
1727 else
1729 require_atom (ATOM_NAME);
1730 t = find_enum (m);
1733 return t;
1736 /* Specialization of mio_name. */
1738 #define DECL_MIO_NAME(TYPE) \
1739 static inline TYPE \
1740 MIO_NAME(TYPE) (TYPE t, const mstring *m) \
1742 return (TYPE) mio_name ((int) t, m); \
1744 #define MIO_NAME(TYPE) mio_name_##TYPE
1746 static void
1747 mio_lparen (void)
1749 if (iomode == IO_OUTPUT)
1750 write_atom (ATOM_LPAREN, NULL);
1751 else
1752 require_atom (ATOM_LPAREN);
1756 static void
1757 mio_rparen (void)
1759 if (iomode == IO_OUTPUT)
1760 write_atom (ATOM_RPAREN, NULL);
1761 else
1762 require_atom (ATOM_RPAREN);
1766 static void
1767 mio_integer (int *ip)
1769 if (iomode == IO_OUTPUT)
1771 HOST_WIDE_INT hwi = *ip;
1772 write_atom (ATOM_INTEGER, &hwi);
1774 else
1776 require_atom (ATOM_INTEGER);
1777 *ip = atom_int;
1781 static void
1782 mio_hwi (HOST_WIDE_INT *hwi)
1784 if (iomode == IO_OUTPUT)
1785 write_atom (ATOM_INTEGER, hwi);
1786 else
1788 require_atom (ATOM_INTEGER);
1789 *hwi = atom_int;
1794 /* Read or write a gfc_intrinsic_op value. */
1796 static void
1797 mio_intrinsic_op (gfc_intrinsic_op* op)
1799 /* FIXME: Would be nicer to do this via the operators symbolic name. */
1800 if (iomode == IO_OUTPUT)
1802 HOST_WIDE_INT converted = (HOST_WIDE_INT) *op;
1803 write_atom (ATOM_INTEGER, &converted);
1805 else
1807 require_atom (ATOM_INTEGER);
1808 *op = (gfc_intrinsic_op) atom_int;
1813 /* Read or write a character pointer that points to a string on the heap. */
1815 static const char *
1816 mio_allocated_string (const char *s)
1818 if (iomode == IO_OUTPUT)
1820 write_atom (ATOM_STRING, s);
1821 return s;
1823 else
1825 require_atom (ATOM_STRING);
1826 return atom_string;
1831 /* Functions for quoting and unquoting strings. */
1833 static char *
1834 quote_string (const gfc_char_t *s, const size_t slength)
1836 const gfc_char_t *p;
1837 char *res, *q;
1838 size_t len = 0, i;
1840 /* Calculate the length we'll need: a backslash takes two ("\\"),
1841 non-printable characters take 10 ("\Uxxxxxxxx") and others take 1. */
1842 for (p = s, i = 0; i < slength; p++, i++)
1844 if (*p == '\\')
1845 len += 2;
1846 else if (!gfc_wide_is_printable (*p))
1847 len += 10;
1848 else
1849 len++;
1852 q = res = XCNEWVEC (char, len + 1);
1853 for (p = s, i = 0; i < slength; p++, i++)
1855 if (*p == '\\')
1856 *q++ = '\\', *q++ = '\\';
1857 else if (!gfc_wide_is_printable (*p))
1859 sprintf (q, "\\U%08" HOST_WIDE_INT_PRINT "x",
1860 (unsigned HOST_WIDE_INT) *p);
1861 q += 10;
1863 else
1864 *q++ = (unsigned char) *p;
1867 res[len] = '\0';
1868 return res;
1871 static gfc_char_t *
1872 unquote_string (const char *s)
1874 size_t len, i;
1875 const char *p;
1876 gfc_char_t *res;
1878 for (p = s, len = 0; *p; p++, len++)
1880 if (*p != '\\')
1881 continue;
1883 if (p[1] == '\\')
1884 p++;
1885 else if (p[1] == 'U')
1886 p += 9; /* That is a "\U????????". */
1887 else
1888 gfc_internal_error ("unquote_string(): got bad string");
1891 res = gfc_get_wide_string (len + 1);
1892 for (i = 0, p = s; i < len; i++, p++)
1894 gcc_assert (*p);
1896 if (*p != '\\')
1897 res[i] = (unsigned char) *p;
1898 else if (p[1] == '\\')
1900 res[i] = (unsigned char) '\\';
1901 p++;
1903 else
1905 /* We read the 8-digits hexadecimal constant that follows. */
1906 int j;
1907 unsigned n;
1908 gfc_char_t c = 0;
1910 gcc_assert (p[1] == 'U');
1911 for (j = 0; j < 8; j++)
1913 c = c << 4;
1914 gcc_assert (sscanf (&p[j+2], "%01x", &n) == 1);
1915 c += n;
1918 res[i] = c;
1919 p += 9;
1923 res[len] = '\0';
1924 return res;
1928 /* Read or write a character pointer that points to a wide string on the
1929 heap, performing quoting/unquoting of nonprintable characters using the
1930 form \U???????? (where each ? is a hexadecimal digit).
1931 Length is the length of the string, only known and used in output mode. */
1933 static const gfc_char_t *
1934 mio_allocated_wide_string (const gfc_char_t *s, const size_t length)
1936 if (iomode == IO_OUTPUT)
1938 char *quoted = quote_string (s, length);
1939 write_atom (ATOM_STRING, quoted);
1940 free (quoted);
1941 return s;
1943 else
1945 gfc_char_t *unquoted;
1947 require_atom (ATOM_STRING);
1948 unquoted = unquote_string (atom_string);
1949 free (atom_string);
1950 return unquoted;
1955 /* Read or write a string that is in static memory. */
1957 static void
1958 mio_pool_string (const char **stringp)
1960 /* TODO: one could write the string only once, and refer to it via a
1961 fixup pointer. */
1963 /* As a special case we have to deal with a NULL string. This
1964 happens for the 'module' member of 'gfc_symbol's that are not in a
1965 module. We read / write these as the empty string. */
1966 if (iomode == IO_OUTPUT)
1968 const char *p = *stringp == NULL ? "" : *stringp;
1969 write_atom (ATOM_STRING, p);
1971 else
1973 require_atom (ATOM_STRING);
1974 *stringp = (atom_string[0] == '\0'
1975 ? NULL : gfc_get_string ("%s", atom_string));
1976 free (atom_string);
1981 /* Read or write a string that is inside of some already-allocated
1982 structure. */
1984 static void
1985 mio_internal_string (char *string)
1987 if (iomode == IO_OUTPUT)
1988 write_atom (ATOM_STRING, string);
1989 else
1991 require_atom (ATOM_STRING);
1992 strcpy (string, atom_string);
1993 free (atom_string);
1998 enum ab_attribute
1999 { AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL,
2000 AB_POINTER, AB_TARGET, AB_DUMMY, AB_RESULT, AB_DATA,
2001 AB_IN_NAMELIST, AB_IN_COMMON, AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE,
2002 AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT,
2003 AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE,
2004 AB_ALLOC_COMP, AB_POINTER_COMP, AB_PROC_POINTER_COMP, AB_PRIVATE_COMP,
2005 AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_LOCK_COMP, AB_EVENT_COMP,
2006 AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
2007 AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
2008 AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER,
2009 AB_IMPLICIT_PURE, AB_ARTIFICIAL, AB_UNLIMITED_POLY, AB_OMP_DECLARE_TARGET,
2010 AB_ARRAY_OUTER_DEPENDENCY, AB_MODULE_PROCEDURE, AB_OACC_DECLARE_CREATE,
2011 AB_OACC_DECLARE_COPYIN, AB_OACC_DECLARE_DEVICEPTR,
2012 AB_OACC_DECLARE_DEVICE_RESIDENT, AB_OACC_DECLARE_LINK,
2013 AB_OMP_DECLARE_TARGET_LINK, AB_PDT_KIND, AB_PDT_LEN, AB_PDT_TYPE,
2014 AB_PDT_TEMPLATE, AB_PDT_ARRAY, AB_PDT_STRING
2017 static const mstring attr_bits[] =
2019 minit ("ALLOCATABLE", AB_ALLOCATABLE),
2020 minit ("ARTIFICIAL", AB_ARTIFICIAL),
2021 minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS),
2022 minit ("DIMENSION", AB_DIMENSION),
2023 minit ("CODIMENSION", AB_CODIMENSION),
2024 minit ("CONTIGUOUS", AB_CONTIGUOUS),
2025 minit ("EXTERNAL", AB_EXTERNAL),
2026 minit ("INTRINSIC", AB_INTRINSIC),
2027 minit ("OPTIONAL", AB_OPTIONAL),
2028 minit ("POINTER", AB_POINTER),
2029 minit ("VOLATILE", AB_VOLATILE),
2030 minit ("TARGET", AB_TARGET),
2031 minit ("THREADPRIVATE", AB_THREADPRIVATE),
2032 minit ("DUMMY", AB_DUMMY),
2033 minit ("RESULT", AB_RESULT),
2034 minit ("DATA", AB_DATA),
2035 minit ("IN_NAMELIST", AB_IN_NAMELIST),
2036 minit ("IN_COMMON", AB_IN_COMMON),
2037 minit ("FUNCTION", AB_FUNCTION),
2038 minit ("SUBROUTINE", AB_SUBROUTINE),
2039 minit ("SEQUENCE", AB_SEQUENCE),
2040 minit ("ELEMENTAL", AB_ELEMENTAL),
2041 minit ("PURE", AB_PURE),
2042 minit ("RECURSIVE", AB_RECURSIVE),
2043 minit ("GENERIC", AB_GENERIC),
2044 minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT),
2045 minit ("CRAY_POINTER", AB_CRAY_POINTER),
2046 minit ("CRAY_POINTEE", AB_CRAY_POINTEE),
2047 minit ("IS_BIND_C", AB_IS_BIND_C),
2048 minit ("IS_C_INTEROP", AB_IS_C_INTEROP),
2049 minit ("IS_ISO_C", AB_IS_ISO_C),
2050 minit ("VALUE", AB_VALUE),
2051 minit ("ALLOC_COMP", AB_ALLOC_COMP),
2052 minit ("COARRAY_COMP", AB_COARRAY_COMP),
2053 minit ("LOCK_COMP", AB_LOCK_COMP),
2054 minit ("EVENT_COMP", AB_EVENT_COMP),
2055 minit ("POINTER_COMP", AB_POINTER_COMP),
2056 minit ("PROC_POINTER_COMP", AB_PROC_POINTER_COMP),
2057 minit ("PRIVATE_COMP", AB_PRIVATE_COMP),
2058 minit ("ZERO_COMP", AB_ZERO_COMP),
2059 minit ("PROTECTED", AB_PROTECTED),
2060 minit ("ABSTRACT", AB_ABSTRACT),
2061 minit ("IS_CLASS", AB_IS_CLASS),
2062 minit ("PROCEDURE", AB_PROCEDURE),
2063 minit ("PROC_POINTER", AB_PROC_POINTER),
2064 minit ("VTYPE", AB_VTYPE),
2065 minit ("VTAB", AB_VTAB),
2066 minit ("CLASS_POINTER", AB_CLASS_POINTER),
2067 minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE),
2068 minit ("UNLIMITED_POLY", AB_UNLIMITED_POLY),
2069 minit ("OMP_DECLARE_TARGET", AB_OMP_DECLARE_TARGET),
2070 minit ("ARRAY_OUTER_DEPENDENCY", AB_ARRAY_OUTER_DEPENDENCY),
2071 minit ("MODULE_PROCEDURE", AB_MODULE_PROCEDURE),
2072 minit ("OACC_DECLARE_CREATE", AB_OACC_DECLARE_CREATE),
2073 minit ("OACC_DECLARE_COPYIN", AB_OACC_DECLARE_COPYIN),
2074 minit ("OACC_DECLARE_DEVICEPTR", AB_OACC_DECLARE_DEVICEPTR),
2075 minit ("OACC_DECLARE_DEVICE_RESIDENT", AB_OACC_DECLARE_DEVICE_RESIDENT),
2076 minit ("OACC_DECLARE_LINK", AB_OACC_DECLARE_LINK),
2077 minit ("OMP_DECLARE_TARGET_LINK", AB_OMP_DECLARE_TARGET_LINK),
2078 minit ("PDT_KIND", AB_PDT_KIND),
2079 minit ("PDT_LEN", AB_PDT_LEN),
2080 minit ("PDT_TYPE", AB_PDT_TYPE),
2081 minit ("PDT_TEMPLATE", AB_PDT_TEMPLATE),
2082 minit ("PDT_ARRAY", AB_PDT_ARRAY),
2083 minit ("PDT_STRING", AB_PDT_STRING),
2084 minit (NULL, -1)
2087 /* For binding attributes. */
2088 static const mstring binding_passing[] =
2090 minit ("PASS", 0),
2091 minit ("NOPASS", 1),
2092 minit (NULL, -1)
2094 static const mstring binding_overriding[] =
2096 minit ("OVERRIDABLE", 0),
2097 minit ("NON_OVERRIDABLE", 1),
2098 minit ("DEFERRED", 2),
2099 minit (NULL, -1)
2101 static const mstring binding_generic[] =
2103 minit ("SPECIFIC", 0),
2104 minit ("GENERIC", 1),
2105 minit (NULL, -1)
2107 static const mstring binding_ppc[] =
2109 minit ("NO_PPC", 0),
2110 minit ("PPC", 1),
2111 minit (NULL, -1)
2114 /* Specialization of mio_name. */
2115 DECL_MIO_NAME (ab_attribute)
2116 DECL_MIO_NAME (ar_type)
2117 DECL_MIO_NAME (array_type)
2118 DECL_MIO_NAME (bt)
2119 DECL_MIO_NAME (expr_t)
2120 DECL_MIO_NAME (gfc_access)
2121 DECL_MIO_NAME (gfc_intrinsic_op)
2122 DECL_MIO_NAME (ifsrc)
2123 DECL_MIO_NAME (save_state)
2124 DECL_MIO_NAME (procedure_type)
2125 DECL_MIO_NAME (ref_type)
2126 DECL_MIO_NAME (sym_flavor)
2127 DECL_MIO_NAME (sym_intent)
2128 #undef DECL_MIO_NAME
2130 /* Symbol attributes are stored in list with the first three elements
2131 being the enumerated fields, while the remaining elements (if any)
2132 indicate the individual attribute bits. The access field is not
2133 saved-- it controls what symbols are exported when a module is
2134 written. */
2136 static void
2137 mio_symbol_attribute (symbol_attribute *attr)
2139 atom_type t;
2140 unsigned ext_attr,extension_level;
2142 mio_lparen ();
2144 attr->flavor = MIO_NAME (sym_flavor) (attr->flavor, flavors);
2145 attr->intent = MIO_NAME (sym_intent) (attr->intent, intents);
2146 attr->proc = MIO_NAME (procedure_type) (attr->proc, procedures);
2147 attr->if_source = MIO_NAME (ifsrc) (attr->if_source, ifsrc_types);
2148 attr->save = MIO_NAME (save_state) (attr->save, save_status);
2150 ext_attr = attr->ext_attr;
2151 mio_integer ((int *) &ext_attr);
2152 attr->ext_attr = ext_attr;
2154 extension_level = attr->extension;
2155 mio_integer ((int *) &extension_level);
2156 attr->extension = extension_level;
2158 if (iomode == IO_OUTPUT)
2160 if (attr->allocatable)
2161 MIO_NAME (ab_attribute) (AB_ALLOCATABLE, attr_bits);
2162 if (attr->artificial)
2163 MIO_NAME (ab_attribute) (AB_ARTIFICIAL, attr_bits);
2164 if (attr->asynchronous)
2165 MIO_NAME (ab_attribute) (AB_ASYNCHRONOUS, attr_bits);
2166 if (attr->dimension)
2167 MIO_NAME (ab_attribute) (AB_DIMENSION, attr_bits);
2168 if (attr->codimension)
2169 MIO_NAME (ab_attribute) (AB_CODIMENSION, attr_bits);
2170 if (attr->contiguous)
2171 MIO_NAME (ab_attribute) (AB_CONTIGUOUS, attr_bits);
2172 if (attr->external)
2173 MIO_NAME (ab_attribute) (AB_EXTERNAL, attr_bits);
2174 if (attr->intrinsic)
2175 MIO_NAME (ab_attribute) (AB_INTRINSIC, attr_bits);
2176 if (attr->optional)
2177 MIO_NAME (ab_attribute) (AB_OPTIONAL, attr_bits);
2178 if (attr->pointer)
2179 MIO_NAME (ab_attribute) (AB_POINTER, attr_bits);
2180 if (attr->class_pointer)
2181 MIO_NAME (ab_attribute) (AB_CLASS_POINTER, attr_bits);
2182 if (attr->is_protected)
2183 MIO_NAME (ab_attribute) (AB_PROTECTED, attr_bits);
2184 if (attr->value)
2185 MIO_NAME (ab_attribute) (AB_VALUE, attr_bits);
2186 if (attr->volatile_)
2187 MIO_NAME (ab_attribute) (AB_VOLATILE, attr_bits);
2188 if (attr->target)
2189 MIO_NAME (ab_attribute) (AB_TARGET, attr_bits);
2190 if (attr->threadprivate)
2191 MIO_NAME (ab_attribute) (AB_THREADPRIVATE, attr_bits);
2192 if (attr->dummy)
2193 MIO_NAME (ab_attribute) (AB_DUMMY, attr_bits);
2194 if (attr->result)
2195 MIO_NAME (ab_attribute) (AB_RESULT, attr_bits);
2196 /* We deliberately don't preserve the "entry" flag. */
2198 if (attr->data)
2199 MIO_NAME (ab_attribute) (AB_DATA, attr_bits);
2200 if (attr->in_namelist)
2201 MIO_NAME (ab_attribute) (AB_IN_NAMELIST, attr_bits);
2202 if (attr->in_common)
2203 MIO_NAME (ab_attribute) (AB_IN_COMMON, attr_bits);
2205 if (attr->function)
2206 MIO_NAME (ab_attribute) (AB_FUNCTION, attr_bits);
2207 if (attr->subroutine)
2208 MIO_NAME (ab_attribute) (AB_SUBROUTINE, attr_bits);
2209 if (attr->generic)
2210 MIO_NAME (ab_attribute) (AB_GENERIC, attr_bits);
2211 if (attr->abstract)
2212 MIO_NAME (ab_attribute) (AB_ABSTRACT, attr_bits);
2214 if (attr->sequence)
2215 MIO_NAME (ab_attribute) (AB_SEQUENCE, attr_bits);
2216 if (attr->elemental)
2217 MIO_NAME (ab_attribute) (AB_ELEMENTAL, attr_bits);
2218 if (attr->pure)
2219 MIO_NAME (ab_attribute) (AB_PURE, attr_bits);
2220 if (attr->implicit_pure)
2221 MIO_NAME (ab_attribute) (AB_IMPLICIT_PURE, attr_bits);
2222 if (attr->unlimited_polymorphic)
2223 MIO_NAME (ab_attribute) (AB_UNLIMITED_POLY, attr_bits);
2224 if (attr->recursive)
2225 MIO_NAME (ab_attribute) (AB_RECURSIVE, attr_bits);
2226 if (attr->always_explicit)
2227 MIO_NAME (ab_attribute) (AB_ALWAYS_EXPLICIT, attr_bits);
2228 if (attr->cray_pointer)
2229 MIO_NAME (ab_attribute) (AB_CRAY_POINTER, attr_bits);
2230 if (attr->cray_pointee)
2231 MIO_NAME (ab_attribute) (AB_CRAY_POINTEE, attr_bits);
2232 if (attr->is_bind_c)
2233 MIO_NAME(ab_attribute) (AB_IS_BIND_C, attr_bits);
2234 if (attr->is_c_interop)
2235 MIO_NAME(ab_attribute) (AB_IS_C_INTEROP, attr_bits);
2236 if (attr->is_iso_c)
2237 MIO_NAME(ab_attribute) (AB_IS_ISO_C, attr_bits);
2238 if (attr->alloc_comp)
2239 MIO_NAME (ab_attribute) (AB_ALLOC_COMP, attr_bits);
2240 if (attr->pointer_comp)
2241 MIO_NAME (ab_attribute) (AB_POINTER_COMP, attr_bits);
2242 if (attr->proc_pointer_comp)
2243 MIO_NAME (ab_attribute) (AB_PROC_POINTER_COMP, attr_bits);
2244 if (attr->private_comp)
2245 MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits);
2246 if (attr->coarray_comp)
2247 MIO_NAME (ab_attribute) (AB_COARRAY_COMP, attr_bits);
2248 if (attr->lock_comp)
2249 MIO_NAME (ab_attribute) (AB_LOCK_COMP, attr_bits);
2250 if (attr->event_comp)
2251 MIO_NAME (ab_attribute) (AB_EVENT_COMP, attr_bits);
2252 if (attr->zero_comp)
2253 MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits);
2254 if (attr->is_class)
2255 MIO_NAME (ab_attribute) (AB_IS_CLASS, attr_bits);
2256 if (attr->procedure)
2257 MIO_NAME (ab_attribute) (AB_PROCEDURE, attr_bits);
2258 if (attr->proc_pointer)
2259 MIO_NAME (ab_attribute) (AB_PROC_POINTER, attr_bits);
2260 if (attr->vtype)
2261 MIO_NAME (ab_attribute) (AB_VTYPE, attr_bits);
2262 if (attr->vtab)
2263 MIO_NAME (ab_attribute) (AB_VTAB, attr_bits);
2264 if (attr->omp_declare_target)
2265 MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET, attr_bits);
2266 if (attr->array_outer_dependency)
2267 MIO_NAME (ab_attribute) (AB_ARRAY_OUTER_DEPENDENCY, attr_bits);
2268 if (attr->module_procedure)
2269 MIO_NAME (ab_attribute) (AB_MODULE_PROCEDURE, attr_bits);
2270 if (attr->oacc_declare_create)
2271 MIO_NAME (ab_attribute) (AB_OACC_DECLARE_CREATE, attr_bits);
2272 if (attr->oacc_declare_copyin)
2273 MIO_NAME (ab_attribute) (AB_OACC_DECLARE_COPYIN, attr_bits);
2274 if (attr->oacc_declare_deviceptr)
2275 MIO_NAME (ab_attribute) (AB_OACC_DECLARE_DEVICEPTR, attr_bits);
2276 if (attr->oacc_declare_device_resident)
2277 MIO_NAME (ab_attribute) (AB_OACC_DECLARE_DEVICE_RESIDENT, attr_bits);
2278 if (attr->oacc_declare_link)
2279 MIO_NAME (ab_attribute) (AB_OACC_DECLARE_LINK, attr_bits);
2280 if (attr->omp_declare_target_link)
2281 MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET_LINK, attr_bits);
2282 if (attr->pdt_kind)
2283 MIO_NAME (ab_attribute) (AB_PDT_KIND, attr_bits);
2284 if (attr->pdt_len)
2285 MIO_NAME (ab_attribute) (AB_PDT_LEN, attr_bits);
2286 if (attr->pdt_type)
2287 MIO_NAME (ab_attribute) (AB_PDT_TYPE, attr_bits);
2288 if (attr->pdt_template)
2289 MIO_NAME (ab_attribute) (AB_PDT_TEMPLATE, attr_bits);
2290 if (attr->pdt_array)
2291 MIO_NAME (ab_attribute) (AB_PDT_ARRAY, attr_bits);
2292 if (attr->pdt_string)
2293 MIO_NAME (ab_attribute) (AB_PDT_STRING, attr_bits);
2295 mio_rparen ();
2298 else
2300 for (;;)
2302 t = parse_atom ();
2303 if (t == ATOM_RPAREN)
2304 break;
2305 if (t != ATOM_NAME)
2306 bad_module ("Expected attribute bit name");
2308 switch ((ab_attribute) find_enum (attr_bits))
2310 case AB_ALLOCATABLE:
2311 attr->allocatable = 1;
2312 break;
2313 case AB_ARTIFICIAL:
2314 attr->artificial = 1;
2315 break;
2316 case AB_ASYNCHRONOUS:
2317 attr->asynchronous = 1;
2318 break;
2319 case AB_DIMENSION:
2320 attr->dimension = 1;
2321 break;
2322 case AB_CODIMENSION:
2323 attr->codimension = 1;
2324 break;
2325 case AB_CONTIGUOUS:
2326 attr->contiguous = 1;
2327 break;
2328 case AB_EXTERNAL:
2329 attr->external = 1;
2330 break;
2331 case AB_INTRINSIC:
2332 attr->intrinsic = 1;
2333 break;
2334 case AB_OPTIONAL:
2335 attr->optional = 1;
2336 break;
2337 case AB_POINTER:
2338 attr->pointer = 1;
2339 break;
2340 case AB_CLASS_POINTER:
2341 attr->class_pointer = 1;
2342 break;
2343 case AB_PROTECTED:
2344 attr->is_protected = 1;
2345 break;
2346 case AB_VALUE:
2347 attr->value = 1;
2348 break;
2349 case AB_VOLATILE:
2350 attr->volatile_ = 1;
2351 break;
2352 case AB_TARGET:
2353 attr->target = 1;
2354 break;
2355 case AB_THREADPRIVATE:
2356 attr->threadprivate = 1;
2357 break;
2358 case AB_DUMMY:
2359 attr->dummy = 1;
2360 break;
2361 case AB_RESULT:
2362 attr->result = 1;
2363 break;
2364 case AB_DATA:
2365 attr->data = 1;
2366 break;
2367 case AB_IN_NAMELIST:
2368 attr->in_namelist = 1;
2369 break;
2370 case AB_IN_COMMON:
2371 attr->in_common = 1;
2372 break;
2373 case AB_FUNCTION:
2374 attr->function = 1;
2375 break;
2376 case AB_SUBROUTINE:
2377 attr->subroutine = 1;
2378 break;
2379 case AB_GENERIC:
2380 attr->generic = 1;
2381 break;
2382 case AB_ABSTRACT:
2383 attr->abstract = 1;
2384 break;
2385 case AB_SEQUENCE:
2386 attr->sequence = 1;
2387 break;
2388 case AB_ELEMENTAL:
2389 attr->elemental = 1;
2390 break;
2391 case AB_PURE:
2392 attr->pure = 1;
2393 break;
2394 case AB_IMPLICIT_PURE:
2395 attr->implicit_pure = 1;
2396 break;
2397 case AB_UNLIMITED_POLY:
2398 attr->unlimited_polymorphic = 1;
2399 break;
2400 case AB_RECURSIVE:
2401 attr->recursive = 1;
2402 break;
2403 case AB_ALWAYS_EXPLICIT:
2404 attr->always_explicit = 1;
2405 break;
2406 case AB_CRAY_POINTER:
2407 attr->cray_pointer = 1;
2408 break;
2409 case AB_CRAY_POINTEE:
2410 attr->cray_pointee = 1;
2411 break;
2412 case AB_IS_BIND_C:
2413 attr->is_bind_c = 1;
2414 break;
2415 case AB_IS_C_INTEROP:
2416 attr->is_c_interop = 1;
2417 break;
2418 case AB_IS_ISO_C:
2419 attr->is_iso_c = 1;
2420 break;
2421 case AB_ALLOC_COMP:
2422 attr->alloc_comp = 1;
2423 break;
2424 case AB_COARRAY_COMP:
2425 attr->coarray_comp = 1;
2426 break;
2427 case AB_LOCK_COMP:
2428 attr->lock_comp = 1;
2429 break;
2430 case AB_EVENT_COMP:
2431 attr->event_comp = 1;
2432 break;
2433 case AB_POINTER_COMP:
2434 attr->pointer_comp = 1;
2435 break;
2436 case AB_PROC_POINTER_COMP:
2437 attr->proc_pointer_comp = 1;
2438 break;
2439 case AB_PRIVATE_COMP:
2440 attr->private_comp = 1;
2441 break;
2442 case AB_ZERO_COMP:
2443 attr->zero_comp = 1;
2444 break;
2445 case AB_IS_CLASS:
2446 attr->is_class = 1;
2447 break;
2448 case AB_PROCEDURE:
2449 attr->procedure = 1;
2450 break;
2451 case AB_PROC_POINTER:
2452 attr->proc_pointer = 1;
2453 break;
2454 case AB_VTYPE:
2455 attr->vtype = 1;
2456 break;
2457 case AB_VTAB:
2458 attr->vtab = 1;
2459 break;
2460 case AB_OMP_DECLARE_TARGET:
2461 attr->omp_declare_target = 1;
2462 break;
2463 case AB_OMP_DECLARE_TARGET_LINK:
2464 attr->omp_declare_target_link = 1;
2465 break;
2466 case AB_ARRAY_OUTER_DEPENDENCY:
2467 attr->array_outer_dependency =1;
2468 break;
2469 case AB_MODULE_PROCEDURE:
2470 attr->module_procedure =1;
2471 break;
2472 case AB_OACC_DECLARE_CREATE:
2473 attr->oacc_declare_create = 1;
2474 break;
2475 case AB_OACC_DECLARE_COPYIN:
2476 attr->oacc_declare_copyin = 1;
2477 break;
2478 case AB_OACC_DECLARE_DEVICEPTR:
2479 attr->oacc_declare_deviceptr = 1;
2480 break;
2481 case AB_OACC_DECLARE_DEVICE_RESIDENT:
2482 attr->oacc_declare_device_resident = 1;
2483 break;
2484 case AB_OACC_DECLARE_LINK:
2485 attr->oacc_declare_link = 1;
2486 break;
2487 case AB_PDT_KIND:
2488 attr->pdt_kind = 1;
2489 break;
2490 case AB_PDT_LEN:
2491 attr->pdt_len = 1;
2492 break;
2493 case AB_PDT_TYPE:
2494 attr->pdt_type = 1;
2495 break;
2496 case AB_PDT_TEMPLATE:
2497 attr->pdt_template = 1;
2498 break;
2499 case AB_PDT_ARRAY:
2500 attr->pdt_array = 1;
2501 break;
2502 case AB_PDT_STRING:
2503 attr->pdt_string = 1;
2504 break;
2511 static const mstring bt_types[] = {
2512 minit ("INTEGER", BT_INTEGER),
2513 minit ("REAL", BT_REAL),
2514 minit ("COMPLEX", BT_COMPLEX),
2515 minit ("LOGICAL", BT_LOGICAL),
2516 minit ("CHARACTER", BT_CHARACTER),
2517 minit ("UNION", BT_UNION),
2518 minit ("DERIVED", BT_DERIVED),
2519 minit ("CLASS", BT_CLASS),
2520 minit ("PROCEDURE", BT_PROCEDURE),
2521 minit ("UNKNOWN", BT_UNKNOWN),
2522 minit ("VOID", BT_VOID),
2523 minit ("ASSUMED", BT_ASSUMED),
2524 minit (NULL, -1)
2528 static void
2529 mio_charlen (gfc_charlen **clp)
2531 gfc_charlen *cl;
2533 mio_lparen ();
2535 if (iomode == IO_OUTPUT)
2537 cl = *clp;
2538 if (cl != NULL)
2539 mio_expr (&cl->length);
2541 else
2543 if (peek_atom () != ATOM_RPAREN)
2545 cl = gfc_new_charlen (gfc_current_ns, NULL);
2546 mio_expr (&cl->length);
2547 *clp = cl;
2551 mio_rparen ();
2555 /* See if a name is a generated name. */
2557 static int
2558 check_unique_name (const char *name)
2560 return *name == '@';
2564 static void
2565 mio_typespec (gfc_typespec *ts)
2567 mio_lparen ();
2569 ts->type = MIO_NAME (bt) (ts->type, bt_types);
2571 if (!gfc_bt_struct (ts->type) && ts->type != BT_CLASS)
2572 mio_integer (&ts->kind);
2573 else
2574 mio_symbol_ref (&ts->u.derived);
2576 mio_symbol_ref (&ts->interface);
2578 /* Add info for C interop and is_iso_c. */
2579 mio_integer (&ts->is_c_interop);
2580 mio_integer (&ts->is_iso_c);
2582 /* If the typespec is for an identifier either from iso_c_binding, or
2583 a constant that was initialized to an identifier from it, use the
2584 f90_type. Otherwise, use the ts->type, since it shouldn't matter. */
2585 if (ts->is_iso_c)
2586 ts->f90_type = MIO_NAME (bt) (ts->f90_type, bt_types);
2587 else
2588 ts->f90_type = MIO_NAME (bt) (ts->type, bt_types);
2590 if (ts->type != BT_CHARACTER)
2592 /* ts->u.cl is only valid for BT_CHARACTER. */
2593 mio_lparen ();
2594 mio_rparen ();
2596 else
2597 mio_charlen (&ts->u.cl);
2599 /* So as not to disturb the existing API, use an ATOM_NAME to
2600 transmit deferred characteristic for characters (F2003). */
2601 if (iomode == IO_OUTPUT)
2603 if (ts->type == BT_CHARACTER && ts->deferred)
2604 write_atom (ATOM_NAME, "DEFERRED_CL");
2606 else if (peek_atom () != ATOM_RPAREN)
2608 if (parse_atom () != ATOM_NAME)
2609 bad_module ("Expected string");
2610 ts->deferred = 1;
2613 mio_rparen ();
2617 static const mstring array_spec_types[] = {
2618 minit ("EXPLICIT", AS_EXPLICIT),
2619 minit ("ASSUMED_RANK", AS_ASSUMED_RANK),
2620 minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE),
2621 minit ("DEFERRED", AS_DEFERRED),
2622 minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE),
2623 minit (NULL, -1)
2627 static void
2628 mio_array_spec (gfc_array_spec **asp)
2630 gfc_array_spec *as;
2631 int i;
2633 mio_lparen ();
2635 if (iomode == IO_OUTPUT)
2637 int rank;
2639 if (*asp == NULL)
2640 goto done;
2641 as = *asp;
2643 /* mio_integer expects nonnegative values. */
2644 rank = as->rank > 0 ? as->rank : 0;
2645 mio_integer (&rank);
2647 else
2649 if (peek_atom () == ATOM_RPAREN)
2651 *asp = NULL;
2652 goto done;
2655 *asp = as = gfc_get_array_spec ();
2656 mio_integer (&as->rank);
2659 mio_integer (&as->corank);
2660 as->type = MIO_NAME (array_type) (as->type, array_spec_types);
2662 if (iomode == IO_INPUT && as->type == AS_ASSUMED_RANK)
2663 as->rank = -1;
2664 if (iomode == IO_INPUT && as->corank)
2665 as->cotype = (as->type == AS_DEFERRED) ? AS_DEFERRED : AS_EXPLICIT;
2667 if (as->rank + as->corank > 0)
2668 for (i = 0; i < as->rank + as->corank; i++)
2670 mio_expr (&as->lower[i]);
2671 mio_expr (&as->upper[i]);
2674 done:
2675 mio_rparen ();
2679 /* Given a pointer to an array reference structure (which lives in a
2680 gfc_ref structure), find the corresponding array specification
2681 structure. Storing the pointer in the ref structure doesn't quite
2682 work when loading from a module. Generating code for an array
2683 reference also needs more information than just the array spec. */
2685 static const mstring array_ref_types[] = {
2686 minit ("FULL", AR_FULL),
2687 minit ("ELEMENT", AR_ELEMENT),
2688 minit ("SECTION", AR_SECTION),
2689 minit (NULL, -1)
2693 static void
2694 mio_array_ref (gfc_array_ref *ar)
2696 int i;
2698 mio_lparen ();
2699 ar->type = MIO_NAME (ar_type) (ar->type, array_ref_types);
2700 mio_integer (&ar->dimen);
2702 switch (ar->type)
2704 case AR_FULL:
2705 break;
2707 case AR_ELEMENT:
2708 for (i = 0; i < ar->dimen; i++)
2709 mio_expr (&ar->start[i]);
2711 break;
2713 case AR_SECTION:
2714 for (i = 0; i < ar->dimen; i++)
2716 mio_expr (&ar->start[i]);
2717 mio_expr (&ar->end[i]);
2718 mio_expr (&ar->stride[i]);
2721 break;
2723 case AR_UNKNOWN:
2724 gfc_internal_error ("mio_array_ref(): Unknown array ref");
2727 /* Unfortunately, ar->dimen_type is an anonymous enumerated type so
2728 we can't call mio_integer directly. Instead loop over each element
2729 and cast it to/from an integer. */
2730 if (iomode == IO_OUTPUT)
2732 for (i = 0; i < ar->dimen; i++)
2734 HOST_WIDE_INT tmp = (HOST_WIDE_INT)ar->dimen_type[i];
2735 write_atom (ATOM_INTEGER, &tmp);
2738 else
2740 for (i = 0; i < ar->dimen; i++)
2742 require_atom (ATOM_INTEGER);
2743 ar->dimen_type[i] = (enum gfc_array_ref_dimen_type) atom_int;
2747 if (iomode == IO_INPUT)
2749 ar->where = gfc_current_locus;
2751 for (i = 0; i < ar->dimen; i++)
2752 ar->c_where[i] = gfc_current_locus;
2755 mio_rparen ();
2759 /* Saves or restores a pointer. The pointer is converted back and
2760 forth from an integer. We return the pointer_info pointer so that
2761 the caller can take additional action based on the pointer type. */
2763 static pointer_info *
2764 mio_pointer_ref (void *gp)
2766 pointer_info *p;
2768 if (iomode == IO_OUTPUT)
2770 p = get_pointer (*((char **) gp));
2771 HOST_WIDE_INT hwi = p->integer;
2772 write_atom (ATOM_INTEGER, &hwi);
2774 else
2776 require_atom (ATOM_INTEGER);
2777 p = add_fixup (atom_int, gp);
2780 return p;
2784 /* Save and load references to components that occur within
2785 expressions. We have to describe these references by a number and
2786 by name. The number is necessary for forward references during
2787 reading, and the name is necessary if the symbol already exists in
2788 the namespace and is not loaded again. */
2790 static void
2791 mio_component_ref (gfc_component **cp)
2793 pointer_info *p;
2795 p = mio_pointer_ref (cp);
2796 if (p->type == P_UNKNOWN)
2797 p->type = P_COMPONENT;
2801 static void mio_namespace_ref (gfc_namespace **nsp);
2802 static void mio_formal_arglist (gfc_formal_arglist **formal);
2803 static void mio_typebound_proc (gfc_typebound_proc** proc);
2804 static void mio_actual_arglist (gfc_actual_arglist **ap, bool pdt);
2806 static void
2807 mio_component (gfc_component *c, int vtype)
2809 pointer_info *p;
2811 mio_lparen ();
2813 if (iomode == IO_OUTPUT)
2815 p = get_pointer (c);
2816 mio_hwi (&p->integer);
2818 else
2820 HOST_WIDE_INT n;
2821 mio_hwi (&n);
2822 p = get_integer (n);
2823 associate_integer_pointer (p, c);
2826 if (p->type == P_UNKNOWN)
2827 p->type = P_COMPONENT;
2829 mio_pool_string (&c->name);
2830 mio_typespec (&c->ts);
2831 mio_array_spec (&c->as);
2833 /* PDT templates store the expression for the kind of a component here. */
2834 mio_expr (&c->kind_expr);
2836 /* PDT types store the component specification list here. */
2837 mio_actual_arglist (&c->param_list, true);
2839 mio_symbol_attribute (&c->attr);
2840 if (c->ts.type == BT_CLASS)
2841 c->attr.class_ok = 1;
2842 c->attr.access = MIO_NAME (gfc_access) (c->attr.access, access_types);
2844 if (!vtype || strcmp (c->name, "_final") == 0
2845 || strcmp (c->name, "_hash") == 0)
2846 mio_expr (&c->initializer);
2848 if (c->attr.proc_pointer)
2849 mio_typebound_proc (&c->tb);
2851 mio_rparen ();
2855 static void
2856 mio_component_list (gfc_component **cp, int vtype)
2858 gfc_component *c, *tail;
2860 mio_lparen ();
2862 if (iomode == IO_OUTPUT)
2864 for (c = *cp; c; c = c->next)
2865 mio_component (c, vtype);
2867 else
2869 *cp = NULL;
2870 tail = NULL;
2872 for (;;)
2874 if (peek_atom () == ATOM_RPAREN)
2875 break;
2877 c = gfc_get_component ();
2878 mio_component (c, vtype);
2880 if (tail == NULL)
2881 *cp = c;
2882 else
2883 tail->next = c;
2885 tail = c;
2889 mio_rparen ();
2893 static void
2894 mio_actual_arg (gfc_actual_arglist *a, bool pdt)
2896 mio_lparen ();
2897 mio_pool_string (&a->name);
2898 mio_expr (&a->expr);
2899 if (pdt)
2900 mio_integer ((int *)&a->spec_type);
2901 mio_rparen ();
2905 static void
2906 mio_actual_arglist (gfc_actual_arglist **ap, bool pdt)
2908 gfc_actual_arglist *a, *tail;
2910 mio_lparen ();
2912 if (iomode == IO_OUTPUT)
2914 for (a = *ap; a; a = a->next)
2915 mio_actual_arg (a, pdt);
2918 else
2920 tail = NULL;
2922 for (;;)
2924 if (peek_atom () != ATOM_LPAREN)
2925 break;
2927 a = gfc_get_actual_arglist ();
2929 if (tail == NULL)
2930 *ap = a;
2931 else
2932 tail->next = a;
2934 tail = a;
2935 mio_actual_arg (a, pdt);
2939 mio_rparen ();
2943 /* Read and write formal argument lists. */
2945 static void
2946 mio_formal_arglist (gfc_formal_arglist **formal)
2948 gfc_formal_arglist *f, *tail;
2950 mio_lparen ();
2952 if (iomode == IO_OUTPUT)
2954 for (f = *formal; f; f = f->next)
2955 mio_symbol_ref (&f->sym);
2957 else
2959 *formal = tail = NULL;
2961 while (peek_atom () != ATOM_RPAREN)
2963 f = gfc_get_formal_arglist ();
2964 mio_symbol_ref (&f->sym);
2966 if (*formal == NULL)
2967 *formal = f;
2968 else
2969 tail->next = f;
2971 tail = f;
2975 mio_rparen ();
2979 /* Save or restore a reference to a symbol node. */
2981 pointer_info *
2982 mio_symbol_ref (gfc_symbol **symp)
2984 pointer_info *p;
2986 p = mio_pointer_ref (symp);
2987 if (p->type == P_UNKNOWN)
2988 p->type = P_SYMBOL;
2990 if (iomode == IO_OUTPUT)
2992 if (p->u.wsym.state == UNREFERENCED)
2993 p->u.wsym.state = NEEDS_WRITE;
2995 else
2997 if (p->u.rsym.state == UNUSED)
2998 p->u.rsym.state = NEEDED;
3000 return p;
3004 /* Save or restore a reference to a symtree node. */
3006 static void
3007 mio_symtree_ref (gfc_symtree **stp)
3009 pointer_info *p;
3010 fixup_t *f;
3012 if (iomode == IO_OUTPUT)
3013 mio_symbol_ref (&(*stp)->n.sym);
3014 else
3016 require_atom (ATOM_INTEGER);
3017 p = get_integer (atom_int);
3019 /* An unused equivalence member; make a symbol and a symtree
3020 for it. */
3021 if (in_load_equiv && p->u.rsym.symtree == NULL)
3023 /* Since this is not used, it must have a unique name. */
3024 p->u.rsym.symtree = gfc_get_unique_symtree (gfc_current_ns);
3026 /* Make the symbol. */
3027 if (p->u.rsym.sym == NULL)
3029 p->u.rsym.sym = gfc_new_symbol (p->u.rsym.true_name,
3030 gfc_current_ns);
3031 p->u.rsym.sym->module = gfc_get_string ("%s", p->u.rsym.module);
3034 p->u.rsym.symtree->n.sym = p->u.rsym.sym;
3035 p->u.rsym.symtree->n.sym->refs++;
3036 p->u.rsym.referenced = 1;
3038 /* If the symbol is PRIVATE and in COMMON, load_commons will
3039 generate a fixup symbol, which must be associated. */
3040 if (p->fixup)
3041 resolve_fixups (p->fixup, p->u.rsym.sym);
3042 p->fixup = NULL;
3045 if (p->type == P_UNKNOWN)
3046 p->type = P_SYMBOL;
3048 if (p->u.rsym.state == UNUSED)
3049 p->u.rsym.state = NEEDED;
3051 if (p->u.rsym.symtree != NULL)
3053 *stp = p->u.rsym.symtree;
3055 else
3057 f = XCNEW (fixup_t);
3059 f->next = p->u.rsym.stfixup;
3060 p->u.rsym.stfixup = f;
3062 f->pointer = (void **) stp;
3068 static void
3069 mio_iterator (gfc_iterator **ip)
3071 gfc_iterator *iter;
3073 mio_lparen ();
3075 if (iomode == IO_OUTPUT)
3077 if (*ip == NULL)
3078 goto done;
3080 else
3082 if (peek_atom () == ATOM_RPAREN)
3084 *ip = NULL;
3085 goto done;
3088 *ip = gfc_get_iterator ();
3091 iter = *ip;
3093 mio_expr (&iter->var);
3094 mio_expr (&iter->start);
3095 mio_expr (&iter->end);
3096 mio_expr (&iter->step);
3098 done:
3099 mio_rparen ();
3103 static void
3104 mio_constructor (gfc_constructor_base *cp)
3106 gfc_constructor *c;
3108 mio_lparen ();
3110 if (iomode == IO_OUTPUT)
3112 for (c = gfc_constructor_first (*cp); c; c = gfc_constructor_next (c))
3114 mio_lparen ();
3115 mio_expr (&c->expr);
3116 mio_iterator (&c->iterator);
3117 mio_rparen ();
3120 else
3122 while (peek_atom () != ATOM_RPAREN)
3124 c = gfc_constructor_append_expr (cp, NULL, NULL);
3126 mio_lparen ();
3127 mio_expr (&c->expr);
3128 mio_iterator (&c->iterator);
3129 mio_rparen ();
3133 mio_rparen ();
3137 static const mstring ref_types[] = {
3138 minit ("ARRAY", REF_ARRAY),
3139 minit ("COMPONENT", REF_COMPONENT),
3140 minit ("SUBSTRING", REF_SUBSTRING),
3141 minit (NULL, -1)
3145 static void
3146 mio_ref (gfc_ref **rp)
3148 gfc_ref *r;
3150 mio_lparen ();
3152 r = *rp;
3153 r->type = MIO_NAME (ref_type) (r->type, ref_types);
3155 switch (r->type)
3157 case REF_ARRAY:
3158 mio_array_ref (&r->u.ar);
3159 break;
3161 case REF_COMPONENT:
3162 mio_symbol_ref (&r->u.c.sym);
3163 mio_component_ref (&r->u.c.component);
3164 break;
3166 case REF_SUBSTRING:
3167 mio_expr (&r->u.ss.start);
3168 mio_expr (&r->u.ss.end);
3169 mio_charlen (&r->u.ss.length);
3170 break;
3173 mio_rparen ();
3177 static void
3178 mio_ref_list (gfc_ref **rp)
3180 gfc_ref *ref, *head, *tail;
3182 mio_lparen ();
3184 if (iomode == IO_OUTPUT)
3186 for (ref = *rp; ref; ref = ref->next)
3187 mio_ref (&ref);
3189 else
3191 head = tail = NULL;
3193 while (peek_atom () != ATOM_RPAREN)
3195 if (head == NULL)
3196 head = tail = gfc_get_ref ();
3197 else
3199 tail->next = gfc_get_ref ();
3200 tail = tail->next;
3203 mio_ref (&tail);
3206 *rp = head;
3209 mio_rparen ();
3213 /* Read and write an integer value. */
3215 static void
3216 mio_gmp_integer (mpz_t *integer)
3218 char *p;
3220 if (iomode == IO_INPUT)
3222 if (parse_atom () != ATOM_STRING)
3223 bad_module ("Expected integer string");
3225 mpz_init (*integer);
3226 if (mpz_set_str (*integer, atom_string, 10))
3227 bad_module ("Error converting integer");
3229 free (atom_string);
3231 else
3233 p = mpz_get_str (NULL, 10, *integer);
3234 write_atom (ATOM_STRING, p);
3235 free (p);
3240 static void
3241 mio_gmp_real (mpfr_t *real)
3243 mp_exp_t exponent;
3244 char *p;
3246 if (iomode == IO_INPUT)
3248 if (parse_atom () != ATOM_STRING)
3249 bad_module ("Expected real string");
3251 mpfr_init (*real);
3252 mpfr_set_str (*real, atom_string, 16, GFC_RND_MODE);
3253 free (atom_string);
3255 else
3257 p = mpfr_get_str (NULL, &exponent, 16, 0, *real, GFC_RND_MODE);
3259 if (mpfr_nan_p (*real) || mpfr_inf_p (*real))
3261 write_atom (ATOM_STRING, p);
3262 free (p);
3263 return;
3266 atom_string = XCNEWVEC (char, strlen (p) + 20);
3268 sprintf (atom_string, "0.%s@%ld", p, exponent);
3270 /* Fix negative numbers. */
3271 if (atom_string[2] == '-')
3273 atom_string[0] = '-';
3274 atom_string[1] = '0';
3275 atom_string[2] = '.';
3278 write_atom (ATOM_STRING, atom_string);
3280 free (atom_string);
3281 free (p);
3286 /* Save and restore the shape of an array constructor. */
3288 static void
3289 mio_shape (mpz_t **pshape, int rank)
3291 mpz_t *shape;
3292 atom_type t;
3293 int n;
3295 /* A NULL shape is represented by (). */
3296 mio_lparen ();
3298 if (iomode == IO_OUTPUT)
3300 shape = *pshape;
3301 if (!shape)
3303 mio_rparen ();
3304 return;
3307 else
3309 t = peek_atom ();
3310 if (t == ATOM_RPAREN)
3312 *pshape = NULL;
3313 mio_rparen ();
3314 return;
3317 shape = gfc_get_shape (rank);
3318 *pshape = shape;
3321 for (n = 0; n < rank; n++)
3322 mio_gmp_integer (&shape[n]);
3324 mio_rparen ();
3328 static const mstring expr_types[] = {
3329 minit ("OP", EXPR_OP),
3330 minit ("FUNCTION", EXPR_FUNCTION),
3331 minit ("CONSTANT", EXPR_CONSTANT),
3332 minit ("VARIABLE", EXPR_VARIABLE),
3333 minit ("SUBSTRING", EXPR_SUBSTRING),
3334 minit ("STRUCTURE", EXPR_STRUCTURE),
3335 minit ("ARRAY", EXPR_ARRAY),
3336 minit ("NULL", EXPR_NULL),
3337 minit ("COMPCALL", EXPR_COMPCALL),
3338 minit (NULL, -1)
3341 /* INTRINSIC_ASSIGN is missing because it is used as an index for
3342 generic operators, not in expressions. INTRINSIC_USER is also
3343 replaced by the correct function name by the time we see it. */
3345 static const mstring intrinsics[] =
3347 minit ("UPLUS", INTRINSIC_UPLUS),
3348 minit ("UMINUS", INTRINSIC_UMINUS),
3349 minit ("PLUS", INTRINSIC_PLUS),
3350 minit ("MINUS", INTRINSIC_MINUS),
3351 minit ("TIMES", INTRINSIC_TIMES),
3352 minit ("DIVIDE", INTRINSIC_DIVIDE),
3353 minit ("POWER", INTRINSIC_POWER),
3354 minit ("CONCAT", INTRINSIC_CONCAT),
3355 minit ("AND", INTRINSIC_AND),
3356 minit ("OR", INTRINSIC_OR),
3357 minit ("EQV", INTRINSIC_EQV),
3358 minit ("NEQV", INTRINSIC_NEQV),
3359 minit ("EQ_SIGN", INTRINSIC_EQ),
3360 minit ("EQ", INTRINSIC_EQ_OS),
3361 minit ("NE_SIGN", INTRINSIC_NE),
3362 minit ("NE", INTRINSIC_NE_OS),
3363 minit ("GT_SIGN", INTRINSIC_GT),
3364 minit ("GT", INTRINSIC_GT_OS),
3365 minit ("GE_SIGN", INTRINSIC_GE),
3366 minit ("GE", INTRINSIC_GE_OS),
3367 minit ("LT_SIGN", INTRINSIC_LT),
3368 minit ("LT", INTRINSIC_LT_OS),
3369 minit ("LE_SIGN", INTRINSIC_LE),
3370 minit ("LE", INTRINSIC_LE_OS),
3371 minit ("NOT", INTRINSIC_NOT),
3372 minit ("PARENTHESES", INTRINSIC_PARENTHESES),
3373 minit ("USER", INTRINSIC_USER),
3374 minit (NULL, -1)
3378 /* Remedy a couple of situations where the gfc_expr's can be defective. */
3380 static void
3381 fix_mio_expr (gfc_expr *e)
3383 gfc_symtree *ns_st = NULL;
3384 const char *fname;
3386 if (iomode != IO_OUTPUT)
3387 return;
3389 if (e->symtree)
3391 /* If this is a symtree for a symbol that came from a contained module
3392 namespace, it has a unique name and we should look in the current
3393 namespace to see if the required, non-contained symbol is available
3394 yet. If so, the latter should be written. */
3395 if (e->symtree->n.sym && check_unique_name (e->symtree->name))
3397 const char *name = e->symtree->n.sym->name;
3398 if (gfc_fl_struct (e->symtree->n.sym->attr.flavor))
3399 name = gfc_dt_upper_string (name);
3400 ns_st = gfc_find_symtree (gfc_current_ns->sym_root, name);
3403 /* On the other hand, if the existing symbol is the module name or the
3404 new symbol is a dummy argument, do not do the promotion. */
3405 if (ns_st && ns_st->n.sym
3406 && ns_st->n.sym->attr.flavor != FL_MODULE
3407 && !e->symtree->n.sym->attr.dummy)
3408 e->symtree = ns_st;
3410 else if (e->expr_type == EXPR_FUNCTION
3411 && (e->value.function.name || e->value.function.isym))
3413 gfc_symbol *sym;
3415 /* In some circumstances, a function used in an initialization
3416 expression, in one use associated module, can fail to be
3417 coupled to its symtree when used in a specification
3418 expression in another module. */
3419 fname = e->value.function.esym ? e->value.function.esym->name
3420 : e->value.function.isym->name;
3421 e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
3423 if (e->symtree)
3424 return;
3426 /* This is probably a reference to a private procedure from another
3427 module. To prevent a segfault, make a generic with no specific
3428 instances. If this module is used, without the required
3429 specific coming from somewhere, the appropriate error message
3430 is issued. */
3431 gfc_get_symbol (fname, gfc_current_ns, &sym);
3432 sym->attr.flavor = FL_PROCEDURE;
3433 sym->attr.generic = 1;
3434 e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
3435 gfc_commit_symbol (sym);
3440 /* Read and write expressions. The form "()" is allowed to indicate a
3441 NULL expression. */
3443 static void
3444 mio_expr (gfc_expr **ep)
3446 HOST_WIDE_INT hwi;
3447 gfc_expr *e;
3448 atom_type t;
3449 int flag;
3451 mio_lparen ();
3453 if (iomode == IO_OUTPUT)
3455 if (*ep == NULL)
3457 mio_rparen ();
3458 return;
3461 e = *ep;
3462 MIO_NAME (expr_t) (e->expr_type, expr_types);
3464 else
3466 t = parse_atom ();
3467 if (t == ATOM_RPAREN)
3469 *ep = NULL;
3470 return;
3473 if (t != ATOM_NAME)
3474 bad_module ("Expected expression type");
3476 e = *ep = gfc_get_expr ();
3477 e->where = gfc_current_locus;
3478 e->expr_type = (expr_t) find_enum (expr_types);
3481 mio_typespec (&e->ts);
3482 mio_integer (&e->rank);
3484 fix_mio_expr (e);
3486 switch (e->expr_type)
3488 case EXPR_OP:
3489 e->value.op.op
3490 = MIO_NAME (gfc_intrinsic_op) (e->value.op.op, intrinsics);
3492 switch (e->value.op.op)
3494 case INTRINSIC_UPLUS:
3495 case INTRINSIC_UMINUS:
3496 case INTRINSIC_NOT:
3497 case INTRINSIC_PARENTHESES:
3498 mio_expr (&e->value.op.op1);
3499 break;
3501 case INTRINSIC_PLUS:
3502 case INTRINSIC_MINUS:
3503 case INTRINSIC_TIMES:
3504 case INTRINSIC_DIVIDE:
3505 case INTRINSIC_POWER:
3506 case INTRINSIC_CONCAT:
3507 case INTRINSIC_AND:
3508 case INTRINSIC_OR:
3509 case INTRINSIC_EQV:
3510 case INTRINSIC_NEQV:
3511 case INTRINSIC_EQ:
3512 case INTRINSIC_EQ_OS:
3513 case INTRINSIC_NE:
3514 case INTRINSIC_NE_OS:
3515 case INTRINSIC_GT:
3516 case INTRINSIC_GT_OS:
3517 case INTRINSIC_GE:
3518 case INTRINSIC_GE_OS:
3519 case INTRINSIC_LT:
3520 case INTRINSIC_LT_OS:
3521 case INTRINSIC_LE:
3522 case INTRINSIC_LE_OS:
3523 mio_expr (&e->value.op.op1);
3524 mio_expr (&e->value.op.op2);
3525 break;
3527 case INTRINSIC_USER:
3528 /* INTRINSIC_USER should not appear in resolved expressions,
3529 though for UDRs we need to stream unresolved ones. */
3530 if (iomode == IO_OUTPUT)
3531 write_atom (ATOM_STRING, e->value.op.uop->name);
3532 else
3534 char *name = read_string ();
3535 const char *uop_name = find_use_name (name, true);
3536 if (uop_name == NULL)
3538 size_t len = strlen (name);
3539 char *name2 = XCNEWVEC (char, len + 2);
3540 memcpy (name2, name, len);
3541 name2[len] = ' ';
3542 name2[len + 1] = '\0';
3543 free (name);
3544 uop_name = name = name2;
3546 e->value.op.uop = gfc_get_uop (uop_name);
3547 free (name);
3549 mio_expr (&e->value.op.op1);
3550 mio_expr (&e->value.op.op2);
3551 break;
3553 default:
3554 bad_module ("Bad operator");
3557 break;
3559 case EXPR_FUNCTION:
3560 mio_symtree_ref (&e->symtree);
3561 mio_actual_arglist (&e->value.function.actual, false);
3563 if (iomode == IO_OUTPUT)
3565 e->value.function.name
3566 = mio_allocated_string (e->value.function.name);
3567 if (e->value.function.esym)
3568 flag = 1;
3569 else if (e->ref)
3570 flag = 2;
3571 else if (e->value.function.isym == NULL)
3572 flag = 3;
3573 else
3574 flag = 0;
3575 mio_integer (&flag);
3576 switch (flag)
3578 case 1:
3579 mio_symbol_ref (&e->value.function.esym);
3580 break;
3581 case 2:
3582 mio_ref_list (&e->ref);
3583 break;
3584 case 3:
3585 break;
3586 default:
3587 write_atom (ATOM_STRING, e->value.function.isym->name);
3590 else
3592 require_atom (ATOM_STRING);
3593 if (atom_string[0] == '\0')
3594 e->value.function.name = NULL;
3595 else
3596 e->value.function.name = gfc_get_string ("%s", atom_string);
3597 free (atom_string);
3599 mio_integer (&flag);
3600 switch (flag)
3602 case 1:
3603 mio_symbol_ref (&e->value.function.esym);
3604 break;
3605 case 2:
3606 mio_ref_list (&e->ref);
3607 break;
3608 case 3:
3609 break;
3610 default:
3611 require_atom (ATOM_STRING);
3612 e->value.function.isym = gfc_find_function (atom_string);
3613 free (atom_string);
3617 break;
3619 case EXPR_VARIABLE:
3620 mio_symtree_ref (&e->symtree);
3621 mio_ref_list (&e->ref);
3622 break;
3624 case EXPR_SUBSTRING:
3625 e->value.character.string
3626 = CONST_CAST (gfc_char_t *,
3627 mio_allocated_wide_string (e->value.character.string,
3628 e->value.character.length));
3629 mio_ref_list (&e->ref);
3630 break;
3632 case EXPR_STRUCTURE:
3633 case EXPR_ARRAY:
3634 mio_constructor (&e->value.constructor);
3635 mio_shape (&e->shape, e->rank);
3636 break;
3638 case EXPR_CONSTANT:
3639 switch (e->ts.type)
3641 case BT_INTEGER:
3642 mio_gmp_integer (&e->value.integer);
3643 break;
3645 case BT_REAL:
3646 gfc_set_model_kind (e->ts.kind);
3647 mio_gmp_real (&e->value.real);
3648 break;
3650 case BT_COMPLEX:
3651 gfc_set_model_kind (e->ts.kind);
3652 mio_gmp_real (&mpc_realref (e->value.complex));
3653 mio_gmp_real (&mpc_imagref (e->value.complex));
3654 break;
3656 case BT_LOGICAL:
3657 mio_integer (&e->value.logical);
3658 break;
3660 case BT_CHARACTER:
3661 hwi = e->value.character.length;
3662 mio_hwi (&hwi);
3663 e->value.character.length = hwi;
3664 e->value.character.string
3665 = CONST_CAST (gfc_char_t *,
3666 mio_allocated_wide_string (e->value.character.string,
3667 e->value.character.length));
3668 break;
3670 default:
3671 bad_module ("Bad type in constant expression");
3674 break;
3676 case EXPR_NULL:
3677 break;
3679 case EXPR_COMPCALL:
3680 case EXPR_PPC:
3681 gcc_unreachable ();
3682 break;
3685 /* PDT types store the expression specification list here. */
3686 mio_actual_arglist (&e->param_list, true);
3688 mio_rparen ();
3692 /* Read and write namelists. */
3694 static void
3695 mio_namelist (gfc_symbol *sym)
3697 gfc_namelist *n, *m;
3698 const char *check_name;
3700 mio_lparen ();
3702 if (iomode == IO_OUTPUT)
3704 for (n = sym->namelist; n; n = n->next)
3705 mio_symbol_ref (&n->sym);
3707 else
3709 /* This departure from the standard is flagged as an error.
3710 It does, in fact, work correctly. TODO: Allow it
3711 conditionally? */
3712 if (sym->attr.flavor == FL_NAMELIST)
3714 check_name = find_use_name (sym->name, false);
3715 if (check_name && strcmp (check_name, sym->name) != 0)
3716 gfc_error ("Namelist %s cannot be renamed by USE "
3717 "association to %s", sym->name, check_name);
3720 m = NULL;
3721 while (peek_atom () != ATOM_RPAREN)
3723 n = gfc_get_namelist ();
3724 mio_symbol_ref (&n->sym);
3726 if (sym->namelist == NULL)
3727 sym->namelist = n;
3728 else
3729 m->next = n;
3731 m = n;
3733 sym->namelist_tail = m;
3736 mio_rparen ();
3740 /* Save/restore lists of gfc_interface structures. When loading an
3741 interface, we are really appending to the existing list of
3742 interfaces. Checking for duplicate and ambiguous interfaces has to
3743 be done later when all symbols have been loaded. */
3745 pointer_info *
3746 mio_interface_rest (gfc_interface **ip)
3748 gfc_interface *tail, *p;
3749 pointer_info *pi = NULL;
3751 if (iomode == IO_OUTPUT)
3753 if (ip != NULL)
3754 for (p = *ip; p; p = p->next)
3755 mio_symbol_ref (&p->sym);
3757 else
3759 if (*ip == NULL)
3760 tail = NULL;
3761 else
3763 tail = *ip;
3764 while (tail->next)
3765 tail = tail->next;
3768 for (;;)
3770 if (peek_atom () == ATOM_RPAREN)
3771 break;
3773 p = gfc_get_interface ();
3774 p->where = gfc_current_locus;
3775 pi = mio_symbol_ref (&p->sym);
3777 if (tail == NULL)
3778 *ip = p;
3779 else
3780 tail->next = p;
3782 tail = p;
3786 mio_rparen ();
3787 return pi;
3791 /* Save/restore a nameless operator interface. */
3793 static void
3794 mio_interface (gfc_interface **ip)
3796 mio_lparen ();
3797 mio_interface_rest (ip);
3801 /* Save/restore a named operator interface. */
3803 static void
3804 mio_symbol_interface (const char **name, const char **module,
3805 gfc_interface **ip)
3807 mio_lparen ();
3808 mio_pool_string (name);
3809 mio_pool_string (module);
3810 mio_interface_rest (ip);
3814 static void
3815 mio_namespace_ref (gfc_namespace **nsp)
3817 gfc_namespace *ns;
3818 pointer_info *p;
3820 p = mio_pointer_ref (nsp);
3822 if (p->type == P_UNKNOWN)
3823 p->type = P_NAMESPACE;
3825 if (iomode == IO_INPUT && p->integer != 0)
3827 ns = (gfc_namespace *) p->u.pointer;
3828 if (ns == NULL)
3830 ns = gfc_get_namespace (NULL, 0);
3831 associate_integer_pointer (p, ns);
3833 else
3834 ns->refs++;
3839 /* Save/restore the f2k_derived namespace of a derived-type symbol. */
3841 static gfc_namespace* current_f2k_derived;
3843 static void
3844 mio_typebound_proc (gfc_typebound_proc** proc)
3846 int flag;
3847 int overriding_flag;
3849 if (iomode == IO_INPUT)
3851 *proc = gfc_get_typebound_proc (NULL);
3852 (*proc)->where = gfc_current_locus;
3854 gcc_assert (*proc);
3856 mio_lparen ();
3858 (*proc)->access = MIO_NAME (gfc_access) ((*proc)->access, access_types);
3860 /* IO the NON_OVERRIDABLE/DEFERRED combination. */
3861 gcc_assert (!((*proc)->deferred && (*proc)->non_overridable));
3862 overriding_flag = ((*proc)->deferred << 1) | (*proc)->non_overridable;
3863 overriding_flag = mio_name (overriding_flag, binding_overriding);
3864 (*proc)->deferred = ((overriding_flag & 2) != 0);
3865 (*proc)->non_overridable = ((overriding_flag & 1) != 0);
3866 gcc_assert (!((*proc)->deferred && (*proc)->non_overridable));
3868 (*proc)->nopass = mio_name ((*proc)->nopass, binding_passing);
3869 (*proc)->is_generic = mio_name ((*proc)->is_generic, binding_generic);
3870 (*proc)->ppc = mio_name((*proc)->ppc, binding_ppc);
3872 mio_pool_string (&((*proc)->pass_arg));
3874 flag = (int) (*proc)->pass_arg_num;
3875 mio_integer (&flag);
3876 (*proc)->pass_arg_num = (unsigned) flag;
3878 if ((*proc)->is_generic)
3880 gfc_tbp_generic* g;
3881 int iop;
3883 mio_lparen ();
3885 if (iomode == IO_OUTPUT)
3886 for (g = (*proc)->u.generic; g; g = g->next)
3888 iop = (int) g->is_operator;
3889 mio_integer (&iop);
3890 mio_allocated_string (g->specific_st->name);
3892 else
3894 (*proc)->u.generic = NULL;
3895 while (peek_atom () != ATOM_RPAREN)
3897 gfc_symtree** sym_root;
3899 g = gfc_get_tbp_generic ();
3900 g->specific = NULL;
3902 mio_integer (&iop);
3903 g->is_operator = (bool) iop;
3905 require_atom (ATOM_STRING);
3906 sym_root = &current_f2k_derived->tb_sym_root;
3907 g->specific_st = gfc_get_tbp_symtree (sym_root, atom_string);
3908 free (atom_string);
3910 g->next = (*proc)->u.generic;
3911 (*proc)->u.generic = g;
3915 mio_rparen ();
3917 else if (!(*proc)->ppc)
3918 mio_symtree_ref (&(*proc)->u.specific);
3920 mio_rparen ();
3923 /* Walker-callback function for this purpose. */
3924 static void
3925 mio_typebound_symtree (gfc_symtree* st)
3927 if (iomode == IO_OUTPUT && !st->n.tb)
3928 return;
3930 if (iomode == IO_OUTPUT)
3932 mio_lparen ();
3933 mio_allocated_string (st->name);
3935 /* For IO_INPUT, the above is done in mio_f2k_derived. */
3937 mio_typebound_proc (&st->n.tb);
3938 mio_rparen ();
3941 /* IO a full symtree (in all depth). */
3942 static void
3943 mio_full_typebound_tree (gfc_symtree** root)
3945 mio_lparen ();
3947 if (iomode == IO_OUTPUT)
3948 gfc_traverse_symtree (*root, &mio_typebound_symtree);
3949 else
3951 while (peek_atom () == ATOM_LPAREN)
3953 gfc_symtree* st;
3955 mio_lparen ();
3957 require_atom (ATOM_STRING);
3958 st = gfc_get_tbp_symtree (root, atom_string);
3959 free (atom_string);
3961 mio_typebound_symtree (st);
3965 mio_rparen ();
3968 static void
3969 mio_finalizer (gfc_finalizer **f)
3971 if (iomode == IO_OUTPUT)
3973 gcc_assert (*f);
3974 gcc_assert ((*f)->proc_tree); /* Should already be resolved. */
3975 mio_symtree_ref (&(*f)->proc_tree);
3977 else
3979 *f = gfc_get_finalizer ();
3980 (*f)->where = gfc_current_locus; /* Value should not matter. */
3981 (*f)->next = NULL;
3983 mio_symtree_ref (&(*f)->proc_tree);
3984 (*f)->proc_sym = NULL;
3988 static void
3989 mio_f2k_derived (gfc_namespace *f2k)
3991 current_f2k_derived = f2k;
3993 /* Handle the list of finalizer procedures. */
3994 mio_lparen ();
3995 if (iomode == IO_OUTPUT)
3997 gfc_finalizer *f;
3998 for (f = f2k->finalizers; f; f = f->next)
3999 mio_finalizer (&f);
4001 else
4003 f2k->finalizers = NULL;
4004 while (peek_atom () != ATOM_RPAREN)
4006 gfc_finalizer *cur = NULL;
4007 mio_finalizer (&cur);
4008 cur->next = f2k->finalizers;
4009 f2k->finalizers = cur;
4012 mio_rparen ();
4014 /* Handle type-bound procedures. */
4015 mio_full_typebound_tree (&f2k->tb_sym_root);
4017 /* Type-bound user operators. */
4018 mio_full_typebound_tree (&f2k->tb_uop_root);
4020 /* Type-bound intrinsic operators. */
4021 mio_lparen ();
4022 if (iomode == IO_OUTPUT)
4024 int op;
4025 for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; ++op)
4027 gfc_intrinsic_op realop;
4029 if (op == INTRINSIC_USER || !f2k->tb_op[op])
4030 continue;
4032 mio_lparen ();
4033 realop = (gfc_intrinsic_op) op;
4034 mio_intrinsic_op (&realop);
4035 mio_typebound_proc (&f2k->tb_op[op]);
4036 mio_rparen ();
4039 else
4040 while (peek_atom () != ATOM_RPAREN)
4042 gfc_intrinsic_op op = GFC_INTRINSIC_BEGIN; /* Silence GCC. */
4044 mio_lparen ();
4045 mio_intrinsic_op (&op);
4046 mio_typebound_proc (&f2k->tb_op[op]);
4047 mio_rparen ();
4049 mio_rparen ();
4052 static void
4053 mio_full_f2k_derived (gfc_symbol *sym)
4055 mio_lparen ();
4057 if (iomode == IO_OUTPUT)
4059 if (sym->f2k_derived)
4060 mio_f2k_derived (sym->f2k_derived);
4062 else
4064 if (peek_atom () != ATOM_RPAREN)
4066 gfc_namespace *ns;
4068 sym->f2k_derived = gfc_get_namespace (NULL, 0);
4070 /* PDT templates make use of the mechanisms for formal args
4071 and so the parameter symbols are stored in the formal
4072 namespace. Transfer the sym_root to f2k_derived and then
4073 free the formal namespace since it is uneeded. */
4074 if (sym->attr.pdt_template && sym->formal && sym->formal->sym)
4076 ns = sym->formal->sym->ns;
4077 sym->f2k_derived->sym_root = ns->sym_root;
4078 ns->sym_root = NULL;
4079 ns->refs++;
4080 gfc_free_namespace (ns);
4081 ns = NULL;
4084 mio_f2k_derived (sym->f2k_derived);
4086 else
4087 gcc_assert (!sym->f2k_derived);
4090 mio_rparen ();
4093 static const mstring omp_declare_simd_clauses[] =
4095 minit ("INBRANCH", 0),
4096 minit ("NOTINBRANCH", 1),
4097 minit ("SIMDLEN", 2),
4098 minit ("UNIFORM", 3),
4099 minit ("LINEAR", 4),
4100 minit ("ALIGNED", 5),
4101 minit (NULL, -1)
4104 /* Handle !$omp declare simd. */
4106 static void
4107 mio_omp_declare_simd (gfc_namespace *ns, gfc_omp_declare_simd **odsp)
4109 if (iomode == IO_OUTPUT)
4111 if (*odsp == NULL)
4112 return;
4114 else if (peek_atom () != ATOM_LPAREN)
4115 return;
4117 gfc_omp_declare_simd *ods = *odsp;
4119 mio_lparen ();
4120 if (iomode == IO_OUTPUT)
4122 write_atom (ATOM_NAME, "OMP_DECLARE_SIMD");
4123 if (ods->clauses)
4125 gfc_omp_namelist *n;
4127 if (ods->clauses->inbranch)
4128 mio_name (0, omp_declare_simd_clauses);
4129 if (ods->clauses->notinbranch)
4130 mio_name (1, omp_declare_simd_clauses);
4131 if (ods->clauses->simdlen_expr)
4133 mio_name (2, omp_declare_simd_clauses);
4134 mio_expr (&ods->clauses->simdlen_expr);
4136 for (n = ods->clauses->lists[OMP_LIST_UNIFORM]; n; n = n->next)
4138 mio_name (3, omp_declare_simd_clauses);
4139 mio_symbol_ref (&n->sym);
4141 for (n = ods->clauses->lists[OMP_LIST_LINEAR]; n; n = n->next)
4143 mio_name (4, omp_declare_simd_clauses);
4144 mio_symbol_ref (&n->sym);
4145 mio_expr (&n->expr);
4147 for (n = ods->clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
4149 mio_name (5, omp_declare_simd_clauses);
4150 mio_symbol_ref (&n->sym);
4151 mio_expr (&n->expr);
4155 else
4157 gfc_omp_namelist **ptrs[3] = { NULL, NULL, NULL };
4159 require_atom (ATOM_NAME);
4160 *odsp = ods = gfc_get_omp_declare_simd ();
4161 ods->where = gfc_current_locus;
4162 ods->proc_name = ns->proc_name;
4163 if (peek_atom () == ATOM_NAME)
4165 ods->clauses = gfc_get_omp_clauses ();
4166 ptrs[0] = &ods->clauses->lists[OMP_LIST_UNIFORM];
4167 ptrs[1] = &ods->clauses->lists[OMP_LIST_LINEAR];
4168 ptrs[2] = &ods->clauses->lists[OMP_LIST_ALIGNED];
4170 while (peek_atom () == ATOM_NAME)
4172 gfc_omp_namelist *n;
4173 int t = mio_name (0, omp_declare_simd_clauses);
4175 switch (t)
4177 case 0: ods->clauses->inbranch = true; break;
4178 case 1: ods->clauses->notinbranch = true; break;
4179 case 2: mio_expr (&ods->clauses->simdlen_expr); break;
4180 case 3:
4181 case 4:
4182 case 5:
4183 *ptrs[t - 3] = n = gfc_get_omp_namelist ();
4184 ptrs[t - 3] = &n->next;
4185 mio_symbol_ref (&n->sym);
4186 if (t != 3)
4187 mio_expr (&n->expr);
4188 break;
4193 mio_omp_declare_simd (ns, &ods->next);
4195 mio_rparen ();
4199 static const mstring omp_declare_reduction_stmt[] =
4201 minit ("ASSIGN", 0),
4202 minit ("CALL", 1),
4203 minit (NULL, -1)
4207 static void
4208 mio_omp_udr_expr (gfc_omp_udr *udr, gfc_symbol **sym1, gfc_symbol **sym2,
4209 gfc_namespace *ns, bool is_initializer)
4211 if (iomode == IO_OUTPUT)
4213 if ((*sym1)->module == NULL)
4215 (*sym1)->module = module_name;
4216 (*sym2)->module = module_name;
4218 mio_symbol_ref (sym1);
4219 mio_symbol_ref (sym2);
4220 if (ns->code->op == EXEC_ASSIGN)
4222 mio_name (0, omp_declare_reduction_stmt);
4223 mio_expr (&ns->code->expr1);
4224 mio_expr (&ns->code->expr2);
4226 else
4228 int flag;
4229 mio_name (1, omp_declare_reduction_stmt);
4230 mio_symtree_ref (&ns->code->symtree);
4231 mio_actual_arglist (&ns->code->ext.actual, false);
4233 flag = ns->code->resolved_isym != NULL;
4234 mio_integer (&flag);
4235 if (flag)
4236 write_atom (ATOM_STRING, ns->code->resolved_isym->name);
4237 else
4238 mio_symbol_ref (&ns->code->resolved_sym);
4241 else
4243 pointer_info *p1 = mio_symbol_ref (sym1);
4244 pointer_info *p2 = mio_symbol_ref (sym2);
4245 gfc_symbol *sym;
4246 gcc_assert (p1->u.rsym.ns == p2->u.rsym.ns);
4247 gcc_assert (p1->u.rsym.sym == NULL);
4248 /* Add hidden symbols to the symtree. */
4249 pointer_info *q = get_integer (p1->u.rsym.ns);
4250 q->u.pointer = (void *) ns;
4251 sym = gfc_new_symbol (is_initializer ? "omp_priv" : "omp_out", ns);
4252 sym->ts = udr->ts;
4253 sym->module = gfc_get_string ("%s", p1->u.rsym.module);
4254 associate_integer_pointer (p1, sym);
4255 sym->attr.omp_udr_artificial_var = 1;
4256 gcc_assert (p2->u.rsym.sym == NULL);
4257 sym = gfc_new_symbol (is_initializer ? "omp_orig" : "omp_in", ns);
4258 sym->ts = udr->ts;
4259 sym->module = gfc_get_string ("%s", p2->u.rsym.module);
4260 associate_integer_pointer (p2, sym);
4261 sym->attr.omp_udr_artificial_var = 1;
4262 if (mio_name (0, omp_declare_reduction_stmt) == 0)
4264 ns->code = gfc_get_code (EXEC_ASSIGN);
4265 mio_expr (&ns->code->expr1);
4266 mio_expr (&ns->code->expr2);
4268 else
4270 int flag;
4271 ns->code = gfc_get_code (EXEC_CALL);
4272 mio_symtree_ref (&ns->code->symtree);
4273 mio_actual_arglist (&ns->code->ext.actual, false);
4275 mio_integer (&flag);
4276 if (flag)
4278 require_atom (ATOM_STRING);
4279 ns->code->resolved_isym = gfc_find_subroutine (atom_string);
4280 free (atom_string);
4282 else
4283 mio_symbol_ref (&ns->code->resolved_sym);
4285 ns->code->loc = gfc_current_locus;
4286 ns->omp_udr_ns = 1;
4291 /* Unlike most other routines, the address of the symbol node is already
4292 fixed on input and the name/module has already been filled in.
4293 If you update the symbol format here, don't forget to update read_module
4294 as well (look for "seek to the symbol's component list"). */
4296 static void
4297 mio_symbol (gfc_symbol *sym)
4299 int intmod = INTMOD_NONE;
4301 mio_lparen ();
4303 mio_symbol_attribute (&sym->attr);
4305 /* Note that components are always saved, even if they are supposed
4306 to be private. Component access is checked during searching. */
4307 mio_component_list (&sym->components, sym->attr.vtype);
4308 if (sym->components != NULL)
4309 sym->component_access
4310 = MIO_NAME (gfc_access) (sym->component_access, access_types);
4312 mio_typespec (&sym->ts);
4313 if (sym->ts.type == BT_CLASS)
4314 sym->attr.class_ok = 1;
4316 if (iomode == IO_OUTPUT)
4317 mio_namespace_ref (&sym->formal_ns);
4318 else
4320 mio_namespace_ref (&sym->formal_ns);
4321 if (sym->formal_ns)
4322 sym->formal_ns->proc_name = sym;
4325 /* Save/restore common block links. */
4326 mio_symbol_ref (&sym->common_next);
4328 mio_formal_arglist (&sym->formal);
4330 if (sym->attr.flavor == FL_PARAMETER)
4331 mio_expr (&sym->value);
4333 mio_array_spec (&sym->as);
4335 mio_symbol_ref (&sym->result);
4337 if (sym->attr.cray_pointee)
4338 mio_symbol_ref (&sym->cp_pointer);
4340 /* Load/save the f2k_derived namespace of a derived-type symbol. */
4341 mio_full_f2k_derived (sym);
4343 /* PDT types store the symbol specification list here. */
4344 mio_actual_arglist (&sym->param_list, true);
4346 mio_namelist (sym);
4348 /* Add the fields that say whether this is from an intrinsic module,
4349 and if so, what symbol it is within the module. */
4350 /* mio_integer (&(sym->from_intmod)); */
4351 if (iomode == IO_OUTPUT)
4353 intmod = sym->from_intmod;
4354 mio_integer (&intmod);
4356 else
4358 mio_integer (&intmod);
4359 if (current_intmod)
4360 sym->from_intmod = current_intmod;
4361 else
4362 sym->from_intmod = (intmod_id) intmod;
4365 mio_integer (&(sym->intmod_sym_id));
4367 if (gfc_fl_struct (sym->attr.flavor))
4368 mio_integer (&(sym->hash_value));
4370 if (sym->formal_ns
4371 && sym->formal_ns->proc_name == sym
4372 && sym->formal_ns->entries == NULL)
4373 mio_omp_declare_simd (sym->formal_ns, &sym->formal_ns->omp_declare_simd);
4375 mio_rparen ();
4379 /************************* Top level subroutines *************************/
4381 /* A recursive function to look for a specific symbol by name and by
4382 module. Whilst several symtrees might point to one symbol, its
4383 is sufficient for the purposes here than one exist. Note that
4384 generic interfaces are distinguished as are symbols that have been
4385 renamed in another module. */
4386 static gfc_symtree *
4387 find_symbol (gfc_symtree *st, const char *name,
4388 const char *module, int generic)
4390 int c;
4391 gfc_symtree *retval, *s;
4393 if (st == NULL || st->n.sym == NULL)
4394 return NULL;
4396 c = strcmp (name, st->n.sym->name);
4397 if (c == 0 && st->n.sym->module
4398 && strcmp (module, st->n.sym->module) == 0
4399 && !check_unique_name (st->name))
4401 s = gfc_find_symtree (gfc_current_ns->sym_root, name);
4403 /* Detect symbols that are renamed by use association in another
4404 module by the absence of a symtree and null attr.use_rename,
4405 since the latter is not transmitted in the module file. */
4406 if (((!generic && !st->n.sym->attr.generic)
4407 || (generic && st->n.sym->attr.generic))
4408 && !(s == NULL && !st->n.sym->attr.use_rename))
4409 return st;
4412 retval = find_symbol (st->left, name, module, generic);
4414 if (retval == NULL)
4415 retval = find_symbol (st->right, name, module, generic);
4417 return retval;
4421 /* Skip a list between balanced left and right parens.
4422 By setting NEST_LEVEL one assumes that a number of NEST_LEVEL opening parens
4423 have been already parsed by hand, and the remaining of the content is to be
4424 skipped here. The default value is 0 (balanced parens). */
4426 static void
4427 skip_list (int nest_level = 0)
4429 int level;
4431 level = nest_level;
4434 switch (parse_atom ())
4436 case ATOM_LPAREN:
4437 level++;
4438 break;
4440 case ATOM_RPAREN:
4441 level--;
4442 break;
4444 case ATOM_STRING:
4445 free (atom_string);
4446 break;
4448 case ATOM_NAME:
4449 case ATOM_INTEGER:
4450 break;
4453 while (level > 0);
4457 /* Load operator interfaces from the module. Interfaces are unusual
4458 in that they attach themselves to existing symbols. */
4460 static void
4461 load_operator_interfaces (void)
4463 const char *p;
4464 char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
4465 gfc_user_op *uop;
4466 pointer_info *pi = NULL;
4467 int n, i;
4469 mio_lparen ();
4471 while (peek_atom () != ATOM_RPAREN)
4473 mio_lparen ();
4475 mio_internal_string (name);
4476 mio_internal_string (module);
4478 n = number_use_names (name, true);
4479 n = n ? n : 1;
4481 for (i = 1; i <= n; i++)
4483 /* Decide if we need to load this one or not. */
4484 p = find_use_name_n (name, &i, true);
4486 if (p == NULL)
4488 while (parse_atom () != ATOM_RPAREN);
4489 continue;
4492 if (i == 1)
4494 uop = gfc_get_uop (p);
4495 pi = mio_interface_rest (&uop->op);
4497 else
4499 if (gfc_find_uop (p, NULL))
4500 continue;
4501 uop = gfc_get_uop (p);
4502 uop->op = gfc_get_interface ();
4503 uop->op->where = gfc_current_locus;
4504 add_fixup (pi->integer, &uop->op->sym);
4509 mio_rparen ();
4513 /* Load interfaces from the module. Interfaces are unusual in that
4514 they attach themselves to existing symbols. */
4516 static void
4517 load_generic_interfaces (void)
4519 const char *p;
4520 char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
4521 gfc_symbol *sym;
4522 gfc_interface *generic = NULL, *gen = NULL;
4523 int n, i, renamed;
4524 bool ambiguous_set = false;
4526 mio_lparen ();
4528 while (peek_atom () != ATOM_RPAREN)
4530 mio_lparen ();
4532 mio_internal_string (name);
4533 mio_internal_string (module);
4535 n = number_use_names (name, false);
4536 renamed = n ? 1 : 0;
4537 n = n ? n : 1;
4539 for (i = 1; i <= n; i++)
4541 gfc_symtree *st;
4542 /* Decide if we need to load this one or not. */
4543 p = find_use_name_n (name, &i, false);
4545 st = find_symbol (gfc_current_ns->sym_root,
4546 name, module_name, 1);
4548 if (!p || gfc_find_symbol (p, NULL, 0, &sym))
4550 /* Skip the specific names for these cases. */
4551 while (i == 1 && parse_atom () != ATOM_RPAREN);
4553 continue;
4556 /* If the symbol exists already and is being USEd without being
4557 in an ONLY clause, do not load a new symtree(11.3.2). */
4558 if (!only_flag && st)
4559 sym = st->n.sym;
4561 if (!sym)
4563 if (st)
4565 sym = st->n.sym;
4566 if (strcmp (st->name, p) != 0)
4568 st = gfc_new_symtree (&gfc_current_ns->sym_root, p);
4569 st->n.sym = sym;
4570 sym->refs++;
4574 /* Since we haven't found a valid generic interface, we had
4575 better make one. */
4576 if (!sym)
4578 gfc_get_symbol (p, NULL, &sym);
4579 sym->name = gfc_get_string ("%s", name);
4580 sym->module = module_name;
4581 sym->attr.flavor = FL_PROCEDURE;
4582 sym->attr.generic = 1;
4583 sym->attr.use_assoc = 1;
4586 else
4588 /* Unless sym is a generic interface, this reference
4589 is ambiguous. */
4590 if (st == NULL)
4591 st = gfc_find_symtree (gfc_current_ns->sym_root, p);
4593 sym = st->n.sym;
4595 if (st && !sym->attr.generic
4596 && !st->ambiguous
4597 && sym->module
4598 && strcmp (module, sym->module))
4600 ambiguous_set = true;
4601 st->ambiguous = 1;
4605 sym->attr.use_only = only_flag;
4606 sym->attr.use_rename = renamed;
4608 if (i == 1)
4610 mio_interface_rest (&sym->generic);
4611 generic = sym->generic;
4613 else if (!sym->generic)
4615 sym->generic = generic;
4616 sym->attr.generic_copy = 1;
4619 /* If a procedure that is not generic has generic interfaces
4620 that include itself, it is generic! We need to take care
4621 to retain symbols ambiguous that were already so. */
4622 if (sym->attr.use_assoc
4623 && !sym->attr.generic
4624 && sym->attr.flavor == FL_PROCEDURE)
4626 for (gen = generic; gen; gen = gen->next)
4628 if (gen->sym == sym)
4630 sym->attr.generic = 1;
4631 if (ambiguous_set)
4632 st->ambiguous = 0;
4633 break;
4641 mio_rparen ();
4645 /* Load common blocks. */
4647 static void
4648 load_commons (void)
4650 char name[GFC_MAX_SYMBOL_LEN + 1];
4651 gfc_common_head *p;
4653 mio_lparen ();
4655 while (peek_atom () != ATOM_RPAREN)
4657 int flags;
4658 char* label;
4659 mio_lparen ();
4660 mio_internal_string (name);
4662 p = gfc_get_common (name, 1);
4664 mio_symbol_ref (&p->head);
4665 mio_integer (&flags);
4666 if (flags & 1)
4667 p->saved = 1;
4668 if (flags & 2)
4669 p->threadprivate = 1;
4670 p->use_assoc = 1;
4672 /* Get whether this was a bind(c) common or not. */
4673 mio_integer (&p->is_bind_c);
4674 /* Get the binding label. */
4675 label = read_string ();
4676 if (strlen (label))
4677 p->binding_label = IDENTIFIER_POINTER (get_identifier (label));
4678 XDELETEVEC (label);
4680 mio_rparen ();
4683 mio_rparen ();
4687 /* Load equivalences. The flag in_load_equiv informs mio_expr_ref of this
4688 so that unused variables are not loaded and so that the expression can
4689 be safely freed. */
4691 static void
4692 load_equiv (void)
4694 gfc_equiv *head, *tail, *end, *eq, *equiv;
4695 bool duplicate;
4697 mio_lparen ();
4698 in_load_equiv = true;
4700 end = gfc_current_ns->equiv;
4701 while (end != NULL && end->next != NULL)
4702 end = end->next;
4704 while (peek_atom () != ATOM_RPAREN) {
4705 mio_lparen ();
4706 head = tail = NULL;
4708 while(peek_atom () != ATOM_RPAREN)
4710 if (head == NULL)
4711 head = tail = gfc_get_equiv ();
4712 else
4714 tail->eq = gfc_get_equiv ();
4715 tail = tail->eq;
4718 mio_pool_string (&tail->module);
4719 mio_expr (&tail->expr);
4722 /* Check for duplicate equivalences being loaded from different modules */
4723 duplicate = false;
4724 for (equiv = gfc_current_ns->equiv; equiv; equiv = equiv->next)
4726 if (equiv->module && head->module
4727 && strcmp (equiv->module, head->module) == 0)
4729 duplicate = true;
4730 break;
4734 if (duplicate)
4736 for (eq = head; eq; eq = head)
4738 head = eq->eq;
4739 gfc_free_expr (eq->expr);
4740 free (eq);
4744 if (end == NULL)
4745 gfc_current_ns->equiv = head;
4746 else
4747 end->next = head;
4749 if (head != NULL)
4750 end = head;
4752 mio_rparen ();
4755 mio_rparen ();
4756 in_load_equiv = false;
4760 /* This function loads OpenMP user defined reductions. */
4761 static void
4762 load_omp_udrs (void)
4764 mio_lparen ();
4765 while (peek_atom () != ATOM_RPAREN)
4767 const char *name = NULL, *newname;
4768 char *altname;
4769 gfc_typespec ts;
4770 gfc_symtree *st;
4771 gfc_omp_reduction_op rop = OMP_REDUCTION_USER;
4773 mio_lparen ();
4774 mio_pool_string (&name);
4775 gfc_clear_ts (&ts);
4776 mio_typespec (&ts);
4777 if (strncmp (name, "operator ", sizeof ("operator ") - 1) == 0)
4779 const char *p = name + sizeof ("operator ") - 1;
4780 if (strcmp (p, "+") == 0)
4781 rop = OMP_REDUCTION_PLUS;
4782 else if (strcmp (p, "*") == 0)
4783 rop = OMP_REDUCTION_TIMES;
4784 else if (strcmp (p, "-") == 0)
4785 rop = OMP_REDUCTION_MINUS;
4786 else if (strcmp (p, ".and.") == 0)
4787 rop = OMP_REDUCTION_AND;
4788 else if (strcmp (p, ".or.") == 0)
4789 rop = OMP_REDUCTION_OR;
4790 else if (strcmp (p, ".eqv.") == 0)
4791 rop = OMP_REDUCTION_EQV;
4792 else if (strcmp (p, ".neqv.") == 0)
4793 rop = OMP_REDUCTION_NEQV;
4795 altname = NULL;
4796 if (rop == OMP_REDUCTION_USER && name[0] == '.')
4798 size_t len = strlen (name + 1);
4799 altname = XALLOCAVEC (char, len);
4800 gcc_assert (name[len] == '.');
4801 memcpy (altname, name + 1, len - 1);
4802 altname[len - 1] = '\0';
4804 newname = name;
4805 if (rop == OMP_REDUCTION_USER)
4806 newname = find_use_name (altname ? altname : name, !!altname);
4807 else if (only_flag && find_use_operator ((gfc_intrinsic_op) rop) == NULL)
4808 newname = NULL;
4809 if (newname == NULL)
4811 skip_list (1);
4812 continue;
4814 if (altname && newname != altname)
4816 size_t len = strlen (newname);
4817 altname = XALLOCAVEC (char, len + 3);
4818 altname[0] = '.';
4819 memcpy (altname + 1, newname, len);
4820 altname[len + 1] = '.';
4821 altname[len + 2] = '\0';
4822 name = gfc_get_string ("%s", altname);
4824 st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name);
4825 gfc_omp_udr *udr = gfc_omp_udr_find (st, &ts);
4826 if (udr)
4828 require_atom (ATOM_INTEGER);
4829 pointer_info *p = get_integer (atom_int);
4830 if (strcmp (p->u.rsym.module, udr->omp_out->module))
4832 gfc_error ("Ambiguous !$OMP DECLARE REDUCTION from "
4833 "module %s at %L",
4834 p->u.rsym.module, &gfc_current_locus);
4835 gfc_error ("Previous !$OMP DECLARE REDUCTION from module "
4836 "%s at %L",
4837 udr->omp_out->module, &udr->where);
4839 skip_list (1);
4840 continue;
4842 udr = gfc_get_omp_udr ();
4843 udr->name = name;
4844 udr->rop = rop;
4845 udr->ts = ts;
4846 udr->where = gfc_current_locus;
4847 udr->combiner_ns = gfc_get_namespace (gfc_current_ns, 1);
4848 udr->combiner_ns->proc_name = gfc_current_ns->proc_name;
4849 mio_omp_udr_expr (udr, &udr->omp_out, &udr->omp_in, udr->combiner_ns,
4850 false);
4851 if (peek_atom () != ATOM_RPAREN)
4853 udr->initializer_ns = gfc_get_namespace (gfc_current_ns, 1);
4854 udr->initializer_ns->proc_name = gfc_current_ns->proc_name;
4855 mio_omp_udr_expr (udr, &udr->omp_priv, &udr->omp_orig,
4856 udr->initializer_ns, true);
4858 if (st)
4860 udr->next = st->n.omp_udr;
4861 st->n.omp_udr = udr;
4863 else
4865 st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name);
4866 st->n.omp_udr = udr;
4868 mio_rparen ();
4870 mio_rparen ();
4874 /* Recursive function to traverse the pointer_info tree and load a
4875 needed symbol. We return nonzero if we load a symbol and stop the
4876 traversal, because the act of loading can alter the tree. */
4878 static int
4879 load_needed (pointer_info *p)
4881 gfc_namespace *ns;
4882 pointer_info *q;
4883 gfc_symbol *sym;
4884 int rv;
4886 rv = 0;
4887 if (p == NULL)
4888 return rv;
4890 rv |= load_needed (p->left);
4891 rv |= load_needed (p->right);
4893 if (p->type != P_SYMBOL || p->u.rsym.state != NEEDED)
4894 return rv;
4896 p->u.rsym.state = USED;
4898 set_module_locus (&p->u.rsym.where);
4900 sym = p->u.rsym.sym;
4901 if (sym == NULL)
4903 q = get_integer (p->u.rsym.ns);
4905 ns = (gfc_namespace *) q->u.pointer;
4906 if (ns == NULL)
4908 /* Create an interface namespace if necessary. These are
4909 the namespaces that hold the formal parameters of module
4910 procedures. */
4912 ns = gfc_get_namespace (NULL, 0);
4913 associate_integer_pointer (q, ns);
4916 /* Use the module sym as 'proc_name' so that gfc_get_symbol_decl
4917 doesn't go pear-shaped if the symbol is used. */
4918 if (!ns->proc_name)
4919 gfc_find_symbol (p->u.rsym.module, gfc_current_ns,
4920 1, &ns->proc_name);
4922 sym = gfc_new_symbol (p->u.rsym.true_name, ns);
4923 sym->name = gfc_dt_lower_string (p->u.rsym.true_name);
4924 sym->module = gfc_get_string ("%s", p->u.rsym.module);
4925 if (p->u.rsym.binding_label)
4926 sym->binding_label = IDENTIFIER_POINTER (get_identifier
4927 (p->u.rsym.binding_label));
4929 associate_integer_pointer (p, sym);
4932 mio_symbol (sym);
4933 sym->attr.use_assoc = 1;
4935 /* Unliked derived types, a STRUCTURE may share names with other symbols.
4936 We greedily converted the the symbol name to lowercase before we knew its
4937 type, so now we must fix it. */
4938 if (sym->attr.flavor == FL_STRUCT)
4939 sym->name = gfc_dt_upper_string (sym->name);
4941 /* Mark as only or rename for later diagnosis for explicitly imported
4942 but not used warnings; don't mark internal symbols such as __vtab,
4943 __def_init etc. Only mark them if they have been explicitly loaded. */
4945 if (only_flag && sym->name[0] != '_' && sym->name[1] != '_')
4947 gfc_use_rename *u;
4949 /* Search the use/rename list for the variable; if the variable is
4950 found, mark it. */
4951 for (u = gfc_rename_list; u; u = u->next)
4953 if (strcmp (u->use_name, sym->name) == 0)
4955 sym->attr.use_only = 1;
4956 break;
4961 if (p->u.rsym.renamed)
4962 sym->attr.use_rename = 1;
4964 return 1;
4968 /* Recursive function for cleaning up things after a module has been read. */
4970 static void
4971 read_cleanup (pointer_info *p)
4973 gfc_symtree *st;
4974 pointer_info *q;
4976 if (p == NULL)
4977 return;
4979 read_cleanup (p->left);
4980 read_cleanup (p->right);
4982 if (p->type == P_SYMBOL && p->u.rsym.state == USED && !p->u.rsym.referenced)
4984 gfc_namespace *ns;
4985 /* Add hidden symbols to the symtree. */
4986 q = get_integer (p->u.rsym.ns);
4987 ns = (gfc_namespace *) q->u.pointer;
4989 if (!p->u.rsym.sym->attr.vtype
4990 && !p->u.rsym.sym->attr.vtab)
4991 st = gfc_get_unique_symtree (ns);
4992 else
4994 /* There is no reason to use 'unique_symtrees' for vtabs or
4995 vtypes - their name is fine for a symtree and reduces the
4996 namespace pollution. */
4997 st = gfc_find_symtree (ns->sym_root, p->u.rsym.sym->name);
4998 if (!st)
4999 st = gfc_new_symtree (&ns->sym_root, p->u.rsym.sym->name);
5002 st->n.sym = p->u.rsym.sym;
5003 st->n.sym->refs++;
5005 /* Fixup any symtree references. */
5006 p->u.rsym.symtree = st;
5007 resolve_fixups (p->u.rsym.stfixup, st);
5008 p->u.rsym.stfixup = NULL;
5011 /* Free unused symbols. */
5012 if (p->type == P_SYMBOL && p->u.rsym.state == UNUSED)
5013 gfc_free_symbol (p->u.rsym.sym);
5017 /* It is not quite enough to check for ambiguity in the symbols by
5018 the loaded symbol and the new symbol not being identical. */
5019 static bool
5020 check_for_ambiguous (gfc_symtree *st, pointer_info *info)
5022 gfc_symbol *rsym;
5023 module_locus locus;
5024 symbol_attribute attr;
5025 gfc_symbol *st_sym;
5027 if (gfc_current_ns->proc_name && st->name == gfc_current_ns->proc_name->name)
5029 gfc_error ("%qs of module %qs, imported at %C, is also the name of the "
5030 "current program unit", st->name, module_name);
5031 return true;
5034 st_sym = st->n.sym;
5035 rsym = info->u.rsym.sym;
5036 if (st_sym == rsym)
5037 return false;
5039 if (st_sym->attr.vtab || st_sym->attr.vtype)
5040 return false;
5042 /* If the existing symbol is generic from a different module and
5043 the new symbol is generic there can be no ambiguity. */
5044 if (st_sym->attr.generic
5045 && st_sym->module
5046 && st_sym->module != module_name)
5048 /* The new symbol's attributes have not yet been read. Since
5049 we need attr.generic, read it directly. */
5050 get_module_locus (&locus);
5051 set_module_locus (&info->u.rsym.where);
5052 mio_lparen ();
5053 attr.generic = 0;
5054 mio_symbol_attribute (&attr);
5055 set_module_locus (&locus);
5056 if (attr.generic)
5057 return false;
5060 return true;
5064 /* Read a module file. */
5066 static void
5067 read_module (void)
5069 module_locus operator_interfaces, user_operators, omp_udrs;
5070 const char *p;
5071 char name[GFC_MAX_SYMBOL_LEN + 1];
5072 int i;
5073 /* Workaround -Wmaybe-uninitialized false positive during
5074 profiledbootstrap by initializing them. */
5075 int ambiguous = 0, j, nuse, symbol = 0;
5076 pointer_info *info, *q;
5077 gfc_use_rename *u = NULL;
5078 gfc_symtree *st;
5079 gfc_symbol *sym;
5081 get_module_locus (&operator_interfaces); /* Skip these for now. */
5082 skip_list ();
5084 get_module_locus (&user_operators);
5085 skip_list ();
5086 skip_list ();
5088 /* Skip commons and equivalences for now. */
5089 skip_list ();
5090 skip_list ();
5092 /* Skip OpenMP UDRs. */
5093 get_module_locus (&omp_udrs);
5094 skip_list ();
5096 mio_lparen ();
5098 /* Create the fixup nodes for all the symbols. */
5100 while (peek_atom () != ATOM_RPAREN)
5102 char* bind_label;
5103 require_atom (ATOM_INTEGER);
5104 info = get_integer (atom_int);
5106 info->type = P_SYMBOL;
5107 info->u.rsym.state = UNUSED;
5109 info->u.rsym.true_name = read_string ();
5110 info->u.rsym.module = read_string ();
5111 bind_label = read_string ();
5112 if (strlen (bind_label))
5113 info->u.rsym.binding_label = bind_label;
5114 else
5115 XDELETEVEC (bind_label);
5117 require_atom (ATOM_INTEGER);
5118 info->u.rsym.ns = atom_int;
5120 get_module_locus (&info->u.rsym.where);
5122 /* See if the symbol has already been loaded by a previous module.
5123 If so, we reference the existing symbol and prevent it from
5124 being loaded again. This should not happen if the symbol being
5125 read is an index for an assumed shape dummy array (ns != 1). */
5127 sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module);
5129 if (sym == NULL
5130 || (sym->attr.flavor == FL_VARIABLE && info->u.rsym.ns !=1))
5132 skip_list ();
5133 continue;
5136 info->u.rsym.state = USED;
5137 info->u.rsym.sym = sym;
5138 /* The current symbol has already been loaded, so we can avoid loading
5139 it again. However, if it is a derived type, some of its components
5140 can be used in expressions in the module. To avoid the module loading
5141 failing, we need to associate the module's component pointer indexes
5142 with the existing symbol's component pointers. */
5143 if (gfc_fl_struct (sym->attr.flavor))
5145 gfc_component *c;
5147 /* First seek to the symbol's component list. */
5148 mio_lparen (); /* symbol opening. */
5149 skip_list (); /* skip symbol attribute. */
5151 mio_lparen (); /* component list opening. */
5152 for (c = sym->components; c; c = c->next)
5154 pointer_info *p;
5155 const char *comp_name;
5156 int n;
5158 mio_lparen (); /* component opening. */
5159 mio_integer (&n);
5160 p = get_integer (n);
5161 if (p->u.pointer == NULL)
5162 associate_integer_pointer (p, c);
5163 mio_pool_string (&comp_name);
5164 gcc_assert (comp_name == c->name);
5165 skip_list (1); /* component end. */
5167 mio_rparen (); /* component list closing. */
5169 skip_list (1); /* symbol end. */
5171 else
5172 skip_list ();
5174 /* Some symbols do not have a namespace (eg. formal arguments),
5175 so the automatic "unique symtree" mechanism must be suppressed
5176 by marking them as referenced. */
5177 q = get_integer (info->u.rsym.ns);
5178 if (q->u.pointer == NULL)
5180 info->u.rsym.referenced = 1;
5181 continue;
5185 mio_rparen ();
5187 /* Parse the symtree lists. This lets us mark which symbols need to
5188 be loaded. Renaming is also done at this point by replacing the
5189 symtree name. */
5191 mio_lparen ();
5193 while (peek_atom () != ATOM_RPAREN)
5195 mio_internal_string (name);
5196 mio_integer (&ambiguous);
5197 mio_integer (&symbol);
5199 info = get_integer (symbol);
5201 /* See how many use names there are. If none, go through the start
5202 of the loop at least once. */
5203 nuse = number_use_names (name, false);
5204 info->u.rsym.renamed = nuse ? 1 : 0;
5206 if (nuse == 0)
5207 nuse = 1;
5209 for (j = 1; j <= nuse; j++)
5211 /* Get the jth local name for this symbol. */
5212 p = find_use_name_n (name, &j, false);
5214 if (p == NULL && strcmp (name, module_name) == 0)
5215 p = name;
5217 /* Exception: Always import vtabs & vtypes. */
5218 if (p == NULL && name[0] == '_'
5219 && (strncmp (name, "__vtab_", 5) == 0
5220 || strncmp (name, "__vtype_", 6) == 0))
5221 p = name;
5223 /* Skip symtree nodes not in an ONLY clause, unless there
5224 is an existing symtree loaded from another USE statement. */
5225 if (p == NULL)
5227 st = gfc_find_symtree (gfc_current_ns->sym_root, name);
5228 if (st != NULL
5229 && strcmp (st->n.sym->name, info->u.rsym.true_name) == 0
5230 && st->n.sym->module != NULL
5231 && strcmp (st->n.sym->module, info->u.rsym.module) == 0)
5233 info->u.rsym.symtree = st;
5234 info->u.rsym.sym = st->n.sym;
5236 continue;
5239 /* If a symbol of the same name and module exists already,
5240 this symbol, which is not in an ONLY clause, must not be
5241 added to the namespace(11.3.2). Note that find_symbol
5242 only returns the first occurrence that it finds. */
5243 if (!only_flag && !info->u.rsym.renamed
5244 && strcmp (name, module_name) != 0
5245 && find_symbol (gfc_current_ns->sym_root, name,
5246 module_name, 0))
5247 continue;
5249 st = gfc_find_symtree (gfc_current_ns->sym_root, p);
5251 if (st != NULL
5252 && !(st->n.sym && st->n.sym->attr.used_in_submodule))
5254 /* Check for ambiguous symbols. */
5255 if (check_for_ambiguous (st, info))
5256 st->ambiguous = 1;
5257 else
5258 info->u.rsym.symtree = st;
5260 else
5262 if (st)
5264 /* This symbol is host associated from a module in a
5265 submodule. Hide it with a unique symtree. */
5266 gfc_symtree *s = gfc_get_unique_symtree (gfc_current_ns);
5267 s->n.sym = st->n.sym;
5268 st->n.sym = NULL;
5270 else
5272 /* Create a symtree node in the current namespace for this
5273 symbol. */
5274 st = check_unique_name (p)
5275 ? gfc_get_unique_symtree (gfc_current_ns)
5276 : gfc_new_symtree (&gfc_current_ns->sym_root, p);
5277 st->ambiguous = ambiguous;
5280 sym = info->u.rsym.sym;
5282 /* Create a symbol node if it doesn't already exist. */
5283 if (sym == NULL)
5285 info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name,
5286 gfc_current_ns);
5287 info->u.rsym.sym->name = gfc_dt_lower_string (info->u.rsym.true_name);
5288 sym = info->u.rsym.sym;
5289 sym->module = gfc_get_string ("%s", info->u.rsym.module);
5291 if (info->u.rsym.binding_label)
5293 tree id = get_identifier (info->u.rsym.binding_label);
5294 sym->binding_label = IDENTIFIER_POINTER (id);
5298 st->n.sym = sym;
5299 st->n.sym->refs++;
5301 if (strcmp (name, p) != 0)
5302 sym->attr.use_rename = 1;
5304 if (name[0] != '_'
5305 || (strncmp (name, "__vtab_", 5) != 0
5306 && strncmp (name, "__vtype_", 6) != 0))
5307 sym->attr.use_only = only_flag;
5309 /* Store the symtree pointing to this symbol. */
5310 info->u.rsym.symtree = st;
5312 if (info->u.rsym.state == UNUSED)
5313 info->u.rsym.state = NEEDED;
5314 info->u.rsym.referenced = 1;
5319 mio_rparen ();
5321 /* Load intrinsic operator interfaces. */
5322 set_module_locus (&operator_interfaces);
5323 mio_lparen ();
5325 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
5327 if (i == INTRINSIC_USER)
5328 continue;
5330 if (only_flag)
5332 u = find_use_operator ((gfc_intrinsic_op) i);
5334 if (u == NULL)
5336 skip_list ();
5337 continue;
5340 u->found = 1;
5343 mio_interface (&gfc_current_ns->op[i]);
5344 if (u && !gfc_current_ns->op[i])
5345 u->found = 0;
5348 mio_rparen ();
5350 /* Load generic and user operator interfaces. These must follow the
5351 loading of symtree because otherwise symbols can be marked as
5352 ambiguous. */
5354 set_module_locus (&user_operators);
5356 load_operator_interfaces ();
5357 load_generic_interfaces ();
5359 load_commons ();
5360 load_equiv ();
5362 /* Load OpenMP user defined reductions. */
5363 set_module_locus (&omp_udrs);
5364 load_omp_udrs ();
5366 /* At this point, we read those symbols that are needed but haven't
5367 been loaded yet. If one symbol requires another, the other gets
5368 marked as NEEDED if its previous state was UNUSED. */
5370 while (load_needed (pi_root));
5372 /* Make sure all elements of the rename-list were found in the module. */
5374 for (u = gfc_rename_list; u; u = u->next)
5376 if (u->found)
5377 continue;
5379 if (u->op == INTRINSIC_NONE)
5381 gfc_error ("Symbol %qs referenced at %L not found in module %qs",
5382 u->use_name, &u->where, module_name);
5383 continue;
5386 if (u->op == INTRINSIC_USER)
5388 gfc_error ("User operator %qs referenced at %L not found "
5389 "in module %qs", u->use_name, &u->where, module_name);
5390 continue;
5393 gfc_error ("Intrinsic operator %qs referenced at %L not found "
5394 "in module %qs", gfc_op2string (u->op), &u->where,
5395 module_name);
5398 /* Clean up symbol nodes that were never loaded, create references
5399 to hidden symbols. */
5401 read_cleanup (pi_root);
5405 /* Given an access type that is specific to an entity and the default
5406 access, return nonzero if the entity is publicly accessible. If the
5407 element is declared as PUBLIC, then it is public; if declared
5408 PRIVATE, then private, and otherwise it is public unless the default
5409 access in this context has been declared PRIVATE. */
5411 static bool dump_smod = false;
5413 static bool
5414 check_access (gfc_access specific_access, gfc_access default_access)
5416 if (dump_smod)
5417 return true;
5419 if (specific_access == ACCESS_PUBLIC)
5420 return TRUE;
5421 if (specific_access == ACCESS_PRIVATE)
5422 return FALSE;
5424 if (flag_module_private)
5425 return default_access == ACCESS_PUBLIC;
5426 else
5427 return default_access != ACCESS_PRIVATE;
5431 bool
5432 gfc_check_symbol_access (gfc_symbol *sym)
5434 if (sym->attr.vtab || sym->attr.vtype)
5435 return true;
5436 else
5437 return check_access (sym->attr.access, sym->ns->default_access);
5441 /* A structure to remember which commons we've already written. */
5443 struct written_common
5445 BBT_HEADER(written_common);
5446 const char *name, *label;
5449 static struct written_common *written_commons = NULL;
5451 /* Comparison function used for balancing the binary tree. */
5453 static int
5454 compare_written_commons (void *a1, void *b1)
5456 const char *aname = ((struct written_common *) a1)->name;
5457 const char *alabel = ((struct written_common *) a1)->label;
5458 const char *bname = ((struct written_common *) b1)->name;
5459 const char *blabel = ((struct written_common *) b1)->label;
5460 int c = strcmp (aname, bname);
5462 return (c != 0 ? c : strcmp (alabel, blabel));
5465 /* Free a list of written commons. */
5467 static void
5468 free_written_common (struct written_common *w)
5470 if (!w)
5471 return;
5473 if (w->left)
5474 free_written_common (w->left);
5475 if (w->right)
5476 free_written_common (w->right);
5478 free (w);
5481 /* Write a common block to the module -- recursive helper function. */
5483 static void
5484 write_common_0 (gfc_symtree *st, bool this_module)
5486 gfc_common_head *p;
5487 const char * name;
5488 int flags;
5489 const char *label;
5490 struct written_common *w;
5491 bool write_me = true;
5493 if (st == NULL)
5494 return;
5496 write_common_0 (st->left, this_module);
5498 /* We will write out the binding label, or "" if no label given. */
5499 name = st->n.common->name;
5500 p = st->n.common;
5501 label = (p->is_bind_c && p->binding_label) ? p->binding_label : "";
5503 /* Check if we've already output this common. */
5504 w = written_commons;
5505 while (w)
5507 int c = strcmp (name, w->name);
5508 c = (c != 0 ? c : strcmp (label, w->label));
5509 if (c == 0)
5510 write_me = false;
5512 w = (c < 0) ? w->left : w->right;
5515 if (this_module && p->use_assoc)
5516 write_me = false;
5518 if (write_me)
5520 /* Write the common to the module. */
5521 mio_lparen ();
5522 mio_pool_string (&name);
5524 mio_symbol_ref (&p->head);
5525 flags = p->saved ? 1 : 0;
5526 if (p->threadprivate)
5527 flags |= 2;
5528 mio_integer (&flags);
5530 /* Write out whether the common block is bind(c) or not. */
5531 mio_integer (&(p->is_bind_c));
5533 mio_pool_string (&label);
5534 mio_rparen ();
5536 /* Record that we have written this common. */
5537 w = XCNEW (struct written_common);
5538 w->name = p->name;
5539 w->label = label;
5540 gfc_insert_bbt (&written_commons, w, compare_written_commons);
5543 write_common_0 (st->right, this_module);
5547 /* Write a common, by initializing the list of written commons, calling
5548 the recursive function write_common_0() and cleaning up afterwards. */
5550 static void
5551 write_common (gfc_symtree *st)
5553 written_commons = NULL;
5554 write_common_0 (st, true);
5555 write_common_0 (st, false);
5556 free_written_common (written_commons);
5557 written_commons = NULL;
5561 /* Write the blank common block to the module. */
5563 static void
5564 write_blank_common (void)
5566 const char * name = BLANK_COMMON_NAME;
5567 int saved;
5568 /* TODO: Blank commons are not bind(c). The F2003 standard probably says
5569 this, but it hasn't been checked. Just making it so for now. */
5570 int is_bind_c = 0;
5572 if (gfc_current_ns->blank_common.head == NULL)
5573 return;
5575 mio_lparen ();
5577 mio_pool_string (&name);
5579 mio_symbol_ref (&gfc_current_ns->blank_common.head);
5580 saved = gfc_current_ns->blank_common.saved;
5581 mio_integer (&saved);
5583 /* Write out whether the common block is bind(c) or not. */
5584 mio_integer (&is_bind_c);
5586 /* Write out an empty binding label. */
5587 write_atom (ATOM_STRING, "");
5589 mio_rparen ();
5593 /* Write equivalences to the module. */
5595 static void
5596 write_equiv (void)
5598 gfc_equiv *eq, *e;
5599 int num;
5601 num = 0;
5602 for (eq = gfc_current_ns->equiv; eq; eq = eq->next)
5604 mio_lparen ();
5606 for (e = eq; e; e = e->eq)
5608 if (e->module == NULL)
5609 e->module = gfc_get_string ("%s.eq.%d", module_name, num);
5610 mio_allocated_string (e->module);
5611 mio_expr (&e->expr);
5614 num++;
5615 mio_rparen ();
5620 /* Write a symbol to the module. */
5622 static void
5623 write_symbol (int n, gfc_symbol *sym)
5625 const char *label;
5627 if (sym->attr.flavor == FL_UNKNOWN || sym->attr.flavor == FL_LABEL)
5628 gfc_internal_error ("write_symbol(): bad module symbol %qs", sym->name);
5630 mio_integer (&n);
5632 if (gfc_fl_struct (sym->attr.flavor))
5634 const char *name;
5635 name = gfc_dt_upper_string (sym->name);
5636 mio_pool_string (&name);
5638 else
5639 mio_pool_string (&sym->name);
5641 mio_pool_string (&sym->module);
5642 if ((sym->attr.is_bind_c || sym->attr.is_iso_c) && sym->binding_label)
5644 label = sym->binding_label;
5645 mio_pool_string (&label);
5647 else
5648 write_atom (ATOM_STRING, "");
5650 mio_pointer_ref (&sym->ns);
5652 mio_symbol (sym);
5653 write_char ('\n');
5657 /* Recursive traversal function to write the initial set of symbols to
5658 the module. We check to see if the symbol should be written
5659 according to the access specification. */
5661 static void
5662 write_symbol0 (gfc_symtree *st)
5664 gfc_symbol *sym;
5665 pointer_info *p;
5666 bool dont_write = false;
5668 if (st == NULL)
5669 return;
5671 write_symbol0 (st->left);
5673 sym = st->n.sym;
5674 if (sym->module == NULL)
5675 sym->module = module_name;
5677 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
5678 && !sym->attr.subroutine && !sym->attr.function)
5679 dont_write = true;
5681 if (!gfc_check_symbol_access (sym))
5682 dont_write = true;
5684 if (!dont_write)
5686 p = get_pointer (sym);
5687 if (p->type == P_UNKNOWN)
5688 p->type = P_SYMBOL;
5690 if (p->u.wsym.state != WRITTEN)
5692 write_symbol (p->integer, sym);
5693 p->u.wsym.state = WRITTEN;
5697 write_symbol0 (st->right);
5701 static void
5702 write_omp_udr (gfc_omp_udr *udr)
5704 switch (udr->rop)
5706 case OMP_REDUCTION_USER:
5707 /* Non-operators can't be used outside of the module. */
5708 if (udr->name[0] != '.')
5709 return;
5710 else
5712 gfc_symtree *st;
5713 size_t len = strlen (udr->name + 1);
5714 char *name = XALLOCAVEC (char, len);
5715 memcpy (name, udr->name, len - 1);
5716 name[len - 1] = '\0';
5717 st = gfc_find_symtree (gfc_current_ns->uop_root, name);
5718 /* If corresponding user operator is private, don't write
5719 the UDR. */
5720 if (st != NULL)
5722 gfc_user_op *uop = st->n.uop;
5723 if (!check_access (uop->access, uop->ns->default_access))
5724 return;
5727 break;
5728 case OMP_REDUCTION_PLUS:
5729 case OMP_REDUCTION_MINUS:
5730 case OMP_REDUCTION_TIMES:
5731 case OMP_REDUCTION_AND:
5732 case OMP_REDUCTION_OR:
5733 case OMP_REDUCTION_EQV:
5734 case OMP_REDUCTION_NEQV:
5735 /* If corresponding operator is private, don't write the UDR. */
5736 if (!check_access (gfc_current_ns->operator_access[udr->rop],
5737 gfc_current_ns->default_access))
5738 return;
5739 break;
5740 default:
5741 break;
5743 if (udr->ts.type == BT_DERIVED || udr->ts.type == BT_CLASS)
5745 /* If derived type is private, don't write the UDR. */
5746 if (!gfc_check_symbol_access (udr->ts.u.derived))
5747 return;
5750 mio_lparen ();
5751 mio_pool_string (&udr->name);
5752 mio_typespec (&udr->ts);
5753 mio_omp_udr_expr (udr, &udr->omp_out, &udr->omp_in, udr->combiner_ns, false);
5754 if (udr->initializer_ns)
5755 mio_omp_udr_expr (udr, &udr->omp_priv, &udr->omp_orig,
5756 udr->initializer_ns, true);
5757 mio_rparen ();
5761 static void
5762 write_omp_udrs (gfc_symtree *st)
5764 if (st == NULL)
5765 return;
5767 write_omp_udrs (st->left);
5768 gfc_omp_udr *udr;
5769 for (udr = st->n.omp_udr; udr; udr = udr->next)
5770 write_omp_udr (udr);
5771 write_omp_udrs (st->right);
5775 /* Type for the temporary tree used when writing secondary symbols. */
5777 struct sorted_pointer_info
5779 BBT_HEADER (sorted_pointer_info);
5781 pointer_info *p;
5784 #define gfc_get_sorted_pointer_info() XCNEW (sorted_pointer_info)
5786 /* Recursively traverse the temporary tree, free its contents. */
5788 static void
5789 free_sorted_pointer_info_tree (sorted_pointer_info *p)
5791 if (!p)
5792 return;
5794 free_sorted_pointer_info_tree (p->left);
5795 free_sorted_pointer_info_tree (p->right);
5797 free (p);
5800 /* Comparison function for the temporary tree. */
5802 static int
5803 compare_sorted_pointer_info (void *_spi1, void *_spi2)
5805 sorted_pointer_info *spi1, *spi2;
5806 spi1 = (sorted_pointer_info *)_spi1;
5807 spi2 = (sorted_pointer_info *)_spi2;
5809 if (spi1->p->integer < spi2->p->integer)
5810 return -1;
5811 if (spi1->p->integer > spi2->p->integer)
5812 return 1;
5813 return 0;
5817 /* Finds the symbols that need to be written and collects them in the
5818 sorted_pi tree so that they can be traversed in an order
5819 independent of memory addresses. */
5821 static void
5822 find_symbols_to_write(sorted_pointer_info **tree, pointer_info *p)
5824 if (!p)
5825 return;
5827 if (p->type == P_SYMBOL && p->u.wsym.state == NEEDS_WRITE)
5829 sorted_pointer_info *sp = gfc_get_sorted_pointer_info();
5830 sp->p = p;
5832 gfc_insert_bbt (tree, sp, compare_sorted_pointer_info);
5835 find_symbols_to_write (tree, p->left);
5836 find_symbols_to_write (tree, p->right);
5840 /* Recursive function that traverses the tree of symbols that need to be
5841 written and writes them in order. */
5843 static void
5844 write_symbol1_recursion (sorted_pointer_info *sp)
5846 if (!sp)
5847 return;
5849 write_symbol1_recursion (sp->left);
5851 pointer_info *p1 = sp->p;
5852 gcc_assert (p1->type == P_SYMBOL && p1->u.wsym.state == NEEDS_WRITE);
5854 p1->u.wsym.state = WRITTEN;
5855 write_symbol (p1->integer, p1->u.wsym.sym);
5856 p1->u.wsym.sym->attr.public_used = 1;
5858 write_symbol1_recursion (sp->right);
5862 /* Write the secondary set of symbols to the module file. These are
5863 symbols that were not public yet are needed by the public symbols
5864 or another dependent symbol. The act of writing a symbol can add
5865 symbols to the pointer_info tree, so we return nonzero if a symbol
5866 was written and pass that information upwards. The caller will
5867 then call this function again until nothing was written. It uses
5868 the utility functions and a temporary tree to ensure a reproducible
5869 ordering of the symbol output and thus the module file. */
5871 static int
5872 write_symbol1 (pointer_info *p)
5874 if (!p)
5875 return 0;
5877 /* Put symbols that need to be written into a tree sorted on the
5878 integer field. */
5880 sorted_pointer_info *spi_root = NULL;
5881 find_symbols_to_write (&spi_root, p);
5883 /* No symbols to write, return. */
5884 if (!spi_root)
5885 return 0;
5887 /* Otherwise, write and free the tree again. */
5888 write_symbol1_recursion (spi_root);
5889 free_sorted_pointer_info_tree (spi_root);
5891 return 1;
5895 /* Write operator interfaces associated with a symbol. */
5897 static void
5898 write_operator (gfc_user_op *uop)
5900 static char nullstring[] = "";
5901 const char *p = nullstring;
5903 if (uop->op == NULL || !check_access (uop->access, uop->ns->default_access))
5904 return;
5906 mio_symbol_interface (&uop->name, &p, &uop->op);
5910 /* Write generic interfaces from the namespace sym_root. */
5912 static void
5913 write_generic (gfc_symtree *st)
5915 gfc_symbol *sym;
5917 if (st == NULL)
5918 return;
5920 write_generic (st->left);
5922 sym = st->n.sym;
5923 if (sym && !check_unique_name (st->name)
5924 && sym->generic && gfc_check_symbol_access (sym))
5926 if (!sym->module)
5927 sym->module = module_name;
5929 mio_symbol_interface (&st->name, &sym->module, &sym->generic);
5932 write_generic (st->right);
5936 static void
5937 write_symtree (gfc_symtree *st)
5939 gfc_symbol *sym;
5940 pointer_info *p;
5942 sym = st->n.sym;
5944 /* A symbol in an interface body must not be visible in the
5945 module file. */
5946 if (sym->ns != gfc_current_ns
5947 && sym->ns->proc_name
5948 && sym->ns->proc_name->attr.if_source == IFSRC_IFBODY)
5949 return;
5951 if (!gfc_check_symbol_access (sym)
5952 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
5953 && !sym->attr.subroutine && !sym->attr.function))
5954 return;
5956 if (check_unique_name (st->name))
5957 return;
5959 p = find_pointer (sym);
5960 if (p == NULL)
5961 gfc_internal_error ("write_symtree(): Symbol not written");
5963 mio_pool_string (&st->name);
5964 mio_integer (&st->ambiguous);
5965 mio_hwi (&p->integer);
5969 static void
5970 write_module (void)
5972 int i;
5974 /* Write the operator interfaces. */
5975 mio_lparen ();
5977 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
5979 if (i == INTRINSIC_USER)
5980 continue;
5982 mio_interface (check_access (gfc_current_ns->operator_access[i],
5983 gfc_current_ns->default_access)
5984 ? &gfc_current_ns->op[i] : NULL);
5987 mio_rparen ();
5988 write_char ('\n');
5989 write_char ('\n');
5991 mio_lparen ();
5992 gfc_traverse_user_op (gfc_current_ns, write_operator);
5993 mio_rparen ();
5994 write_char ('\n');
5995 write_char ('\n');
5997 mio_lparen ();
5998 write_generic (gfc_current_ns->sym_root);
5999 mio_rparen ();
6000 write_char ('\n');
6001 write_char ('\n');
6003 mio_lparen ();
6004 write_blank_common ();
6005 write_common (gfc_current_ns->common_root);
6006 mio_rparen ();
6007 write_char ('\n');
6008 write_char ('\n');
6010 mio_lparen ();
6011 write_equiv ();
6012 mio_rparen ();
6013 write_char ('\n');
6014 write_char ('\n');
6016 mio_lparen ();
6017 write_omp_udrs (gfc_current_ns->omp_udr_root);
6018 mio_rparen ();
6019 write_char ('\n');
6020 write_char ('\n');
6022 /* Write symbol information. First we traverse all symbols in the
6023 primary namespace, writing those that need to be written.
6024 Sometimes writing one symbol will cause another to need to be
6025 written. A list of these symbols ends up on the write stack, and
6026 we end by popping the bottom of the stack and writing the symbol
6027 until the stack is empty. */
6029 mio_lparen ();
6031 write_symbol0 (gfc_current_ns->sym_root);
6032 while (write_symbol1 (pi_root))
6033 /* Nothing. */;
6035 mio_rparen ();
6037 write_char ('\n');
6038 write_char ('\n');
6040 mio_lparen ();
6041 gfc_traverse_symtree (gfc_current_ns->sym_root, write_symtree);
6042 mio_rparen ();
6046 /* Read a CRC32 sum from the gzip trailer of a module file. Returns
6047 true on success, false on failure. */
6049 static bool
6050 read_crc32_from_module_file (const char* filename, uLong* crc)
6052 FILE *file;
6053 char buf[4];
6054 unsigned int val;
6056 /* Open the file in binary mode. */
6057 if ((file = fopen (filename, "rb")) == NULL)
6058 return false;
6060 /* The gzip crc32 value is found in the [END-8, END-4] bytes of the
6061 file. See RFC 1952. */
6062 if (fseek (file, -8, SEEK_END) != 0)
6064 fclose (file);
6065 return false;
6068 /* Read the CRC32. */
6069 if (fread (buf, 1, 4, file) != 4)
6071 fclose (file);
6072 return false;
6075 /* Close the file. */
6076 fclose (file);
6078 val = (buf[0] & 0xFF) + ((buf[1] & 0xFF) << 8) + ((buf[2] & 0xFF) << 16)
6079 + ((buf[3] & 0xFF) << 24);
6080 *crc = val;
6082 /* For debugging, the CRC value printed in hexadecimal should match
6083 the CRC printed by "zcat -l -v filename".
6084 printf("CRC of file %s is %x\n", filename, val); */
6086 return true;
6090 /* Given module, dump it to disk. If there was an error while
6091 processing the module, dump_flag will be set to zero and we delete
6092 the module file, even if it was already there. */
6094 static void
6095 dump_module (const char *name, int dump_flag)
6097 int n;
6098 char *filename, *filename_tmp;
6099 uLong crc, crc_old;
6101 module_name = gfc_get_string ("%s", name);
6103 if (dump_smod)
6105 name = submodule_name;
6106 n = strlen (name) + strlen (SUBMODULE_EXTENSION) + 1;
6108 else
6109 n = strlen (name) + strlen (MODULE_EXTENSION) + 1;
6111 if (gfc_option.module_dir != NULL)
6113 n += strlen (gfc_option.module_dir);
6114 filename = (char *) alloca (n);
6115 strcpy (filename, gfc_option.module_dir);
6116 strcat (filename, name);
6118 else
6120 filename = (char *) alloca (n);
6121 strcpy (filename, name);
6124 if (dump_smod)
6125 strcat (filename, SUBMODULE_EXTENSION);
6126 else
6127 strcat (filename, MODULE_EXTENSION);
6129 /* Name of the temporary file used to write the module. */
6130 filename_tmp = (char *) alloca (n + 1);
6131 strcpy (filename_tmp, filename);
6132 strcat (filename_tmp, "0");
6134 /* There was an error while processing the module. We delete the
6135 module file, even if it was already there. */
6136 if (!dump_flag)
6138 remove (filename);
6139 return;
6142 if (gfc_cpp_makedep ())
6143 gfc_cpp_add_target (filename);
6145 /* Write the module to the temporary file. */
6146 module_fp = gzopen (filename_tmp, "w");
6147 if (module_fp == NULL)
6148 gfc_fatal_error ("Can't open module file %qs for writing at %C: %s",
6149 filename_tmp, xstrerror (errno));
6151 /* Use lbasename to ensure module files are reproducible regardless
6152 of the build path (see the reproducible builds project). */
6153 gzprintf (module_fp, "GFORTRAN module version '%s' created from %s\n",
6154 MOD_VERSION, lbasename (gfc_source_file));
6156 /* Write the module itself. */
6157 iomode = IO_OUTPUT;
6159 init_pi_tree ();
6161 write_module ();
6163 free_pi_tree (pi_root);
6164 pi_root = NULL;
6166 write_char ('\n');
6168 if (gzclose (module_fp))
6169 gfc_fatal_error ("Error writing module file %qs for writing: %s",
6170 filename_tmp, xstrerror (errno));
6172 /* Read the CRC32 from the gzip trailers of the module files and
6173 compare. */
6174 if (!read_crc32_from_module_file (filename_tmp, &crc)
6175 || !read_crc32_from_module_file (filename, &crc_old)
6176 || crc_old != crc)
6178 /* Module file have changed, replace the old one. */
6179 if (remove (filename) && errno != ENOENT)
6180 gfc_fatal_error ("Can't delete module file %qs: %s", filename,
6181 xstrerror (errno));
6182 if (rename (filename_tmp, filename))
6183 gfc_fatal_error ("Can't rename module file %qs to %qs: %s",
6184 filename_tmp, filename, xstrerror (errno));
6186 else
6188 if (remove (filename_tmp))
6189 gfc_fatal_error ("Can't delete temporary module file %qs: %s",
6190 filename_tmp, xstrerror (errno));
6195 /* Suppress the output of a .smod file by module, if no module
6196 procedures have been seen. */
6197 static bool no_module_procedures;
6199 static void
6200 check_for_module_procedures (gfc_symbol *sym)
6202 if (sym && sym->attr.module_procedure)
6203 no_module_procedures = false;
6207 void
6208 gfc_dump_module (const char *name, int dump_flag)
6210 if (gfc_state_stack->state == COMP_SUBMODULE)
6211 dump_smod = true;
6212 else
6213 dump_smod =false;
6215 no_module_procedures = true;
6216 gfc_traverse_ns (gfc_current_ns, check_for_module_procedures);
6218 dump_module (name, dump_flag);
6220 if (no_module_procedures || dump_smod)
6221 return;
6223 /* Write a submodule file from a module. The 'dump_smod' flag switches
6224 off the check for PRIVATE entities. */
6225 dump_smod = true;
6226 submodule_name = module_name;
6227 dump_module (name, dump_flag);
6228 dump_smod = false;
6231 static void
6232 create_intrinsic_function (const char *name, int id,
6233 const char *modname, intmod_id module,
6234 bool subroutine, gfc_symbol *result_type)
6236 gfc_intrinsic_sym *isym;
6237 gfc_symtree *tmp_symtree;
6238 gfc_symbol *sym;
6240 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
6241 if (tmp_symtree)
6243 if (tmp_symtree->n.sym && tmp_symtree->n.sym->module
6244 && strcmp (modname, tmp_symtree->n.sym->module) == 0)
6245 return;
6246 gfc_error ("Symbol %qs at %C already declared", name);
6247 return;
6250 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
6251 sym = tmp_symtree->n.sym;
6253 if (subroutine)
6255 gfc_isym_id isym_id = gfc_isym_id_by_intmod (module, id);
6256 isym = gfc_intrinsic_subroutine_by_id (isym_id);
6257 sym->attr.subroutine = 1;
6259 else
6261 gfc_isym_id isym_id = gfc_isym_id_by_intmod (module, id);
6262 isym = gfc_intrinsic_function_by_id (isym_id);
6264 sym->attr.function = 1;
6265 if (result_type)
6267 sym->ts.type = BT_DERIVED;
6268 sym->ts.u.derived = result_type;
6269 sym->ts.is_c_interop = 1;
6270 isym->ts.f90_type = BT_VOID;
6271 isym->ts.type = BT_DERIVED;
6272 isym->ts.f90_type = BT_VOID;
6273 isym->ts.u.derived = result_type;
6274 isym->ts.is_c_interop = 1;
6277 gcc_assert (isym);
6279 sym->attr.flavor = FL_PROCEDURE;
6280 sym->attr.intrinsic = 1;
6282 sym->module = gfc_get_string ("%s", modname);
6283 sym->attr.use_assoc = 1;
6284 sym->from_intmod = module;
6285 sym->intmod_sym_id = id;
6289 /* Import the intrinsic ISO_C_BINDING module, generating symbols in
6290 the current namespace for all named constants, pointer types, and
6291 procedures in the module unless the only clause was used or a rename
6292 list was provided. */
6294 static void
6295 import_iso_c_binding_module (void)
6297 gfc_symbol *mod_sym = NULL, *return_type;
6298 gfc_symtree *mod_symtree = NULL, *tmp_symtree;
6299 gfc_symtree *c_ptr = NULL, *c_funptr = NULL;
6300 const char *iso_c_module_name = "__iso_c_binding";
6301 gfc_use_rename *u;
6302 int i;
6303 bool want_c_ptr = false, want_c_funptr = false;
6305 /* Look only in the current namespace. */
6306 mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, iso_c_module_name);
6308 if (mod_symtree == NULL)
6310 /* symtree doesn't already exist in current namespace. */
6311 gfc_get_sym_tree (iso_c_module_name, gfc_current_ns, &mod_symtree,
6312 false);
6314 if (mod_symtree != NULL)
6315 mod_sym = mod_symtree->n.sym;
6316 else
6317 gfc_internal_error ("import_iso_c_binding_module(): Unable to "
6318 "create symbol for %s", iso_c_module_name);
6320 mod_sym->attr.flavor = FL_MODULE;
6321 mod_sym->attr.intrinsic = 1;
6322 mod_sym->module = gfc_get_string ("%s", iso_c_module_name);
6323 mod_sym->from_intmod = INTMOD_ISO_C_BINDING;
6326 /* Check whether C_PTR or C_FUNPTR are in the include list, if so, load it;
6327 check also whether C_NULL_(FUN)PTR or C_(FUN)LOC are requested, which
6328 need C_(FUN)PTR. */
6329 for (u = gfc_rename_list; u; u = u->next)
6331 if (strcmp (c_interop_kinds_table[ISOCBINDING_NULL_PTR].name,
6332 u->use_name) == 0)
6333 want_c_ptr = true;
6334 else if (strcmp (c_interop_kinds_table[ISOCBINDING_LOC].name,
6335 u->use_name) == 0)
6336 want_c_ptr = true;
6337 else if (strcmp (c_interop_kinds_table[ISOCBINDING_NULL_FUNPTR].name,
6338 u->use_name) == 0)
6339 want_c_funptr = true;
6340 else if (strcmp (c_interop_kinds_table[ISOCBINDING_FUNLOC].name,
6341 u->use_name) == 0)
6342 want_c_funptr = true;
6343 else if (strcmp (c_interop_kinds_table[ISOCBINDING_PTR].name,
6344 u->use_name) == 0)
6346 c_ptr = generate_isocbinding_symbol (iso_c_module_name,
6347 (iso_c_binding_symbol)
6348 ISOCBINDING_PTR,
6349 u->local_name[0] ? u->local_name
6350 : u->use_name,
6351 NULL, false);
6353 else if (strcmp (c_interop_kinds_table[ISOCBINDING_FUNPTR].name,
6354 u->use_name) == 0)
6356 c_funptr
6357 = generate_isocbinding_symbol (iso_c_module_name,
6358 (iso_c_binding_symbol)
6359 ISOCBINDING_FUNPTR,
6360 u->local_name[0] ? u->local_name
6361 : u->use_name,
6362 NULL, false);
6366 if ((want_c_ptr || !only_flag) && !c_ptr)
6367 c_ptr = generate_isocbinding_symbol (iso_c_module_name,
6368 (iso_c_binding_symbol)
6369 ISOCBINDING_PTR,
6370 NULL, NULL, only_flag);
6371 if ((want_c_funptr || !only_flag) && !c_funptr)
6372 c_funptr = generate_isocbinding_symbol (iso_c_module_name,
6373 (iso_c_binding_symbol)
6374 ISOCBINDING_FUNPTR,
6375 NULL, NULL, only_flag);
6377 /* Generate the symbols for the named constants representing
6378 the kinds for intrinsic data types. */
6379 for (i = 0; i < ISOCBINDING_NUMBER; i++)
6381 bool found = false;
6382 for (u = gfc_rename_list; u; u = u->next)
6383 if (strcmp (c_interop_kinds_table[i].name, u->use_name) == 0)
6385 bool not_in_std;
6386 const char *name;
6387 u->found = 1;
6388 found = true;
6390 switch (i)
6392 #define NAMED_FUNCTION(a,b,c,d) \
6393 case a: \
6394 not_in_std = (gfc_option.allow_std & d) == 0; \
6395 name = b; \
6396 break;
6397 #define NAMED_SUBROUTINE(a,b,c,d) \
6398 case a: \
6399 not_in_std = (gfc_option.allow_std & d) == 0; \
6400 name = b; \
6401 break;
6402 #define NAMED_INTCST(a,b,c,d) \
6403 case a: \
6404 not_in_std = (gfc_option.allow_std & d) == 0; \
6405 name = b; \
6406 break;
6407 #define NAMED_REALCST(a,b,c,d) \
6408 case a: \
6409 not_in_std = (gfc_option.allow_std & d) == 0; \
6410 name = b; \
6411 break;
6412 #define NAMED_CMPXCST(a,b,c,d) \
6413 case a: \
6414 not_in_std = (gfc_option.allow_std & d) == 0; \
6415 name = b; \
6416 break;
6417 #include "iso-c-binding.def"
6418 default:
6419 not_in_std = false;
6420 name = "";
6423 if (not_in_std)
6425 gfc_error ("The symbol %qs, referenced at %L, is not "
6426 "in the selected standard", name, &u->where);
6427 continue;
6430 switch (i)
6432 #define NAMED_FUNCTION(a,b,c,d) \
6433 case a: \
6434 if (a == ISOCBINDING_LOC) \
6435 return_type = c_ptr->n.sym; \
6436 else if (a == ISOCBINDING_FUNLOC) \
6437 return_type = c_funptr->n.sym; \
6438 else \
6439 return_type = NULL; \
6440 create_intrinsic_function (u->local_name[0] \
6441 ? u->local_name : u->use_name, \
6442 a, iso_c_module_name, \
6443 INTMOD_ISO_C_BINDING, false, \
6444 return_type); \
6445 break;
6446 #define NAMED_SUBROUTINE(a,b,c,d) \
6447 case a: \
6448 create_intrinsic_function (u->local_name[0] ? u->local_name \
6449 : u->use_name, \
6450 a, iso_c_module_name, \
6451 INTMOD_ISO_C_BINDING, true, NULL); \
6452 break;
6453 #include "iso-c-binding.def"
6455 case ISOCBINDING_PTR:
6456 case ISOCBINDING_FUNPTR:
6457 /* Already handled above. */
6458 break;
6459 default:
6460 if (i == ISOCBINDING_NULL_PTR)
6461 tmp_symtree = c_ptr;
6462 else if (i == ISOCBINDING_NULL_FUNPTR)
6463 tmp_symtree = c_funptr;
6464 else
6465 tmp_symtree = NULL;
6466 generate_isocbinding_symbol (iso_c_module_name,
6467 (iso_c_binding_symbol) i,
6468 u->local_name[0]
6469 ? u->local_name : u->use_name,
6470 tmp_symtree, false);
6474 if (!found && !only_flag)
6476 /* Skip, if the symbol is not in the enabled standard. */
6477 switch (i)
6479 #define NAMED_FUNCTION(a,b,c,d) \
6480 case a: \
6481 if ((gfc_option.allow_std & d) == 0) \
6482 continue; \
6483 break;
6484 #define NAMED_SUBROUTINE(a,b,c,d) \
6485 case a: \
6486 if ((gfc_option.allow_std & d) == 0) \
6487 continue; \
6488 break;
6489 #define NAMED_INTCST(a,b,c,d) \
6490 case a: \
6491 if ((gfc_option.allow_std & d) == 0) \
6492 continue; \
6493 break;
6494 #define NAMED_REALCST(a,b,c,d) \
6495 case a: \
6496 if ((gfc_option.allow_std & d) == 0) \
6497 continue; \
6498 break;
6499 #define NAMED_CMPXCST(a,b,c,d) \
6500 case a: \
6501 if ((gfc_option.allow_std & d) == 0) \
6502 continue; \
6503 break;
6504 #include "iso-c-binding.def"
6505 default:
6506 ; /* Not GFC_STD_* versioned. */
6509 switch (i)
6511 #define NAMED_FUNCTION(a,b,c,d) \
6512 case a: \
6513 if (a == ISOCBINDING_LOC) \
6514 return_type = c_ptr->n.sym; \
6515 else if (a == ISOCBINDING_FUNLOC) \
6516 return_type = c_funptr->n.sym; \
6517 else \
6518 return_type = NULL; \
6519 create_intrinsic_function (b, a, iso_c_module_name, \
6520 INTMOD_ISO_C_BINDING, false, \
6521 return_type); \
6522 break;
6523 #define NAMED_SUBROUTINE(a,b,c,d) \
6524 case a: \
6525 create_intrinsic_function (b, a, iso_c_module_name, \
6526 INTMOD_ISO_C_BINDING, true, NULL); \
6527 break;
6528 #include "iso-c-binding.def"
6530 case ISOCBINDING_PTR:
6531 case ISOCBINDING_FUNPTR:
6532 /* Already handled above. */
6533 break;
6534 default:
6535 if (i == ISOCBINDING_NULL_PTR)
6536 tmp_symtree = c_ptr;
6537 else if (i == ISOCBINDING_NULL_FUNPTR)
6538 tmp_symtree = c_funptr;
6539 else
6540 tmp_symtree = NULL;
6541 generate_isocbinding_symbol (iso_c_module_name,
6542 (iso_c_binding_symbol) i, NULL,
6543 tmp_symtree, false);
6548 for (u = gfc_rename_list; u; u = u->next)
6550 if (u->found)
6551 continue;
6553 gfc_error ("Symbol %qs referenced at %L not found in intrinsic "
6554 "module ISO_C_BINDING", u->use_name, &u->where);
6559 /* Add an integer named constant from a given module. */
6561 static void
6562 create_int_parameter (const char *name, int value, const char *modname,
6563 intmod_id module, int id)
6565 gfc_symtree *tmp_symtree;
6566 gfc_symbol *sym;
6568 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
6569 if (tmp_symtree != NULL)
6571 if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
6572 return;
6573 else
6574 gfc_error ("Symbol %qs already declared", name);
6577 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
6578 sym = tmp_symtree->n.sym;
6580 sym->module = gfc_get_string ("%s", modname);
6581 sym->attr.flavor = FL_PARAMETER;
6582 sym->ts.type = BT_INTEGER;
6583 sym->ts.kind = gfc_default_integer_kind;
6584 sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL, value);
6585 sym->attr.use_assoc = 1;
6586 sym->from_intmod = module;
6587 sym->intmod_sym_id = id;
6591 /* Value is already contained by the array constructor, but not
6592 yet the shape. */
6594 static void
6595 create_int_parameter_array (const char *name, int size, gfc_expr *value,
6596 const char *modname, intmod_id module, int id)
6598 gfc_symtree *tmp_symtree;
6599 gfc_symbol *sym;
6601 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
6602 if (tmp_symtree != NULL)
6604 if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
6605 return;
6606 else
6607 gfc_error ("Symbol %qs already declared", name);
6610 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
6611 sym = tmp_symtree->n.sym;
6613 sym->module = gfc_get_string ("%s", modname);
6614 sym->attr.flavor = FL_PARAMETER;
6615 sym->ts.type = BT_INTEGER;
6616 sym->ts.kind = gfc_default_integer_kind;
6617 sym->attr.use_assoc = 1;
6618 sym->from_intmod = module;
6619 sym->intmod_sym_id = id;
6620 sym->attr.dimension = 1;
6621 sym->as = gfc_get_array_spec ();
6622 sym->as->rank = 1;
6623 sym->as->type = AS_EXPLICIT;
6624 sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
6625 sym->as->upper[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, size);
6627 sym->value = value;
6628 sym->value->shape = gfc_get_shape (1);
6629 mpz_init_set_ui (sym->value->shape[0], size);
6633 /* Add an derived type for a given module. */
6635 static void
6636 create_derived_type (const char *name, const char *modname,
6637 intmod_id module, int id)
6639 gfc_symtree *tmp_symtree;
6640 gfc_symbol *sym, *dt_sym;
6641 gfc_interface *intr, *head;
6643 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
6644 if (tmp_symtree != NULL)
6646 if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
6647 return;
6648 else
6649 gfc_error ("Symbol %qs already declared", name);
6652 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
6653 sym = tmp_symtree->n.sym;
6654 sym->module = gfc_get_string ("%s", modname);
6655 sym->from_intmod = module;
6656 sym->intmod_sym_id = id;
6657 sym->attr.flavor = FL_PROCEDURE;
6658 sym->attr.function = 1;
6659 sym->attr.generic = 1;
6661 gfc_get_sym_tree (gfc_dt_upper_string (sym->name),
6662 gfc_current_ns, &tmp_symtree, false);
6663 dt_sym = tmp_symtree->n.sym;
6664 dt_sym->name = gfc_get_string ("%s", sym->name);
6665 dt_sym->attr.flavor = FL_DERIVED;
6666 dt_sym->attr.private_comp = 1;
6667 dt_sym->attr.zero_comp = 1;
6668 dt_sym->attr.use_assoc = 1;
6669 dt_sym->module = gfc_get_string ("%s", modname);
6670 dt_sym->from_intmod = module;
6671 dt_sym->intmod_sym_id = id;
6673 head = sym->generic;
6674 intr = gfc_get_interface ();
6675 intr->sym = dt_sym;
6676 intr->where = gfc_current_locus;
6677 intr->next = head;
6678 sym->generic = intr;
6679 sym->attr.if_source = IFSRC_DECL;
6683 /* Read the contents of the module file into a temporary buffer. */
6685 static void
6686 read_module_to_tmpbuf ()
6688 /* We don't know the uncompressed size, so enlarge the buffer as
6689 needed. */
6690 int cursz = 4096;
6691 int rsize = cursz;
6692 int len = 0;
6694 module_content = XNEWVEC (char, cursz);
6696 while (1)
6698 int nread = gzread (module_fp, module_content + len, rsize);
6699 len += nread;
6700 if (nread < rsize)
6701 break;
6702 cursz *= 2;
6703 module_content = XRESIZEVEC (char, module_content, cursz);
6704 rsize = cursz - len;
6707 module_content = XRESIZEVEC (char, module_content, len + 1);
6708 module_content[len] = '\0';
6710 module_pos = 0;
6714 /* USE the ISO_FORTRAN_ENV intrinsic module. */
6716 static void
6717 use_iso_fortran_env_module (void)
6719 static char mod[] = "iso_fortran_env";
6720 gfc_use_rename *u;
6721 gfc_symbol *mod_sym;
6722 gfc_symtree *mod_symtree;
6723 gfc_expr *expr;
6724 int i, j;
6726 intmod_sym symbol[] = {
6727 #define NAMED_INTCST(a,b,c,d) { a, b, 0, d },
6728 #define NAMED_KINDARRAY(a,b,c,d) { a, b, 0, d },
6729 #define NAMED_DERIVED_TYPE(a,b,c,d) { a, b, 0, d },
6730 #define NAMED_FUNCTION(a,b,c,d) { a, b, c, d },
6731 #define NAMED_SUBROUTINE(a,b,c,d) { a, b, c, d },
6732 #include "iso-fortran-env.def"
6733 { ISOFORTRANENV_INVALID, NULL, -1234, 0 } };
6735 i = 0;
6736 #define NAMED_INTCST(a,b,c,d) symbol[i++].value = c;
6737 #include "iso-fortran-env.def"
6739 /* Generate the symbol for the module itself. */
6740 mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, mod);
6741 if (mod_symtree == NULL)
6743 gfc_get_sym_tree (mod, gfc_current_ns, &mod_symtree, false);
6744 gcc_assert (mod_symtree);
6745 mod_sym = mod_symtree->n.sym;
6747 mod_sym->attr.flavor = FL_MODULE;
6748 mod_sym->attr.intrinsic = 1;
6749 mod_sym->module = gfc_get_string ("%s", mod);
6750 mod_sym->from_intmod = INTMOD_ISO_FORTRAN_ENV;
6752 else
6753 if (!mod_symtree->n.sym->attr.intrinsic)
6754 gfc_error ("Use of intrinsic module %qs at %C conflicts with "
6755 "non-intrinsic module name used previously", mod);
6757 /* Generate the symbols for the module integer named constants. */
6759 for (i = 0; symbol[i].name; i++)
6761 bool found = false;
6762 for (u = gfc_rename_list; u; u = u->next)
6764 if (strcmp (symbol[i].name, u->use_name) == 0)
6766 found = true;
6767 u->found = 1;
6769 if (!gfc_notify_std (symbol[i].standard, "The symbol %qs, "
6770 "referenced at %L, is not in the selected "
6771 "standard", symbol[i].name, &u->where))
6772 continue;
6774 if ((flag_default_integer || flag_default_real_8)
6775 && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
6776 gfc_warning_now (0, "Use of the NUMERIC_STORAGE_SIZE named "
6777 "constant from intrinsic module "
6778 "ISO_FORTRAN_ENV at %L is incompatible with "
6779 "option %qs", &u->where,
6780 flag_default_integer
6781 ? "-fdefault-integer-8"
6782 : "-fdefault-real-8");
6783 switch (symbol[i].id)
6785 #define NAMED_INTCST(a,b,c,d) \
6786 case a:
6787 #include "iso-fortran-env.def"
6788 create_int_parameter (u->local_name[0] ? u->local_name
6789 : u->use_name,
6790 symbol[i].value, mod,
6791 INTMOD_ISO_FORTRAN_ENV, symbol[i].id);
6792 break;
6794 #define NAMED_KINDARRAY(a,b,KINDS,d) \
6795 case a:\
6796 expr = gfc_get_array_expr (BT_INTEGER, \
6797 gfc_default_integer_kind,\
6798 NULL); \
6799 for (j = 0; KINDS[j].kind != 0; j++) \
6800 gfc_constructor_append_expr (&expr->value.constructor, \
6801 gfc_get_int_expr (gfc_default_integer_kind, NULL, \
6802 KINDS[j].kind), NULL); \
6803 create_int_parameter_array (u->local_name[0] ? u->local_name \
6804 : u->use_name, \
6805 j, expr, mod, \
6806 INTMOD_ISO_FORTRAN_ENV, \
6807 symbol[i].id); \
6808 break;
6809 #include "iso-fortran-env.def"
6811 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
6812 case a:
6813 #include "iso-fortran-env.def"
6814 create_derived_type (u->local_name[0] ? u->local_name
6815 : u->use_name,
6816 mod, INTMOD_ISO_FORTRAN_ENV,
6817 symbol[i].id);
6818 break;
6820 #define NAMED_FUNCTION(a,b,c,d) \
6821 case a:
6822 #include "iso-fortran-env.def"
6823 create_intrinsic_function (u->local_name[0] ? u->local_name
6824 : u->use_name,
6825 symbol[i].id, mod,
6826 INTMOD_ISO_FORTRAN_ENV, false,
6827 NULL);
6828 break;
6830 default:
6831 gcc_unreachable ();
6836 if (!found && !only_flag)
6838 if ((gfc_option.allow_std & symbol[i].standard) == 0)
6839 continue;
6841 if ((flag_default_integer || flag_default_real_8)
6842 && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
6843 gfc_warning_now (0,
6844 "Use of the NUMERIC_STORAGE_SIZE named constant "
6845 "from intrinsic module ISO_FORTRAN_ENV at %C is "
6846 "incompatible with option %s",
6847 flag_default_integer
6848 ? "-fdefault-integer-8" : "-fdefault-real-8");
6850 switch (symbol[i].id)
6852 #define NAMED_INTCST(a,b,c,d) \
6853 case a:
6854 #include "iso-fortran-env.def"
6855 create_int_parameter (symbol[i].name, symbol[i].value, mod,
6856 INTMOD_ISO_FORTRAN_ENV, symbol[i].id);
6857 break;
6859 #define NAMED_KINDARRAY(a,b,KINDS,d) \
6860 case a:\
6861 expr = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, \
6862 NULL); \
6863 for (j = 0; KINDS[j].kind != 0; j++) \
6864 gfc_constructor_append_expr (&expr->value.constructor, \
6865 gfc_get_int_expr (gfc_default_integer_kind, NULL, \
6866 KINDS[j].kind), NULL); \
6867 create_int_parameter_array (symbol[i].name, j, expr, mod, \
6868 INTMOD_ISO_FORTRAN_ENV, symbol[i].id);\
6869 break;
6870 #include "iso-fortran-env.def"
6872 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
6873 case a:
6874 #include "iso-fortran-env.def"
6875 create_derived_type (symbol[i].name, mod, INTMOD_ISO_FORTRAN_ENV,
6876 symbol[i].id);
6877 break;
6879 #define NAMED_FUNCTION(a,b,c,d) \
6880 case a:
6881 #include "iso-fortran-env.def"
6882 create_intrinsic_function (symbol[i].name, symbol[i].id, mod,
6883 INTMOD_ISO_FORTRAN_ENV, false,
6884 NULL);
6885 break;
6887 default:
6888 gcc_unreachable ();
6893 for (u = gfc_rename_list; u; u = u->next)
6895 if (u->found)
6896 continue;
6898 gfc_error ("Symbol %qs referenced at %L not found in intrinsic "
6899 "module ISO_FORTRAN_ENV", u->use_name, &u->where);
6904 /* Process a USE directive. */
6906 static void
6907 gfc_use_module (gfc_use_list *module)
6909 char *filename;
6910 gfc_state_data *p;
6911 int c, line, start;
6912 gfc_symtree *mod_symtree;
6913 gfc_use_list *use_stmt;
6914 locus old_locus = gfc_current_locus;
6916 gfc_current_locus = module->where;
6917 module_name = module->module_name;
6918 gfc_rename_list = module->rename;
6919 only_flag = module->only_flag;
6920 current_intmod = INTMOD_NONE;
6922 if (!only_flag)
6923 gfc_warning_now (OPT_Wuse_without_only,
6924 "USE statement at %C has no ONLY qualifier");
6926 if (gfc_state_stack->state == COMP_MODULE
6927 || module->submodule_name == NULL)
6929 filename = XALLOCAVEC (char, strlen (module_name)
6930 + strlen (MODULE_EXTENSION) + 1);
6931 strcpy (filename, module_name);
6932 strcat (filename, MODULE_EXTENSION);
6934 else
6936 filename = XALLOCAVEC (char, strlen (module->submodule_name)
6937 + strlen (SUBMODULE_EXTENSION) + 1);
6938 strcpy (filename, module->submodule_name);
6939 strcat (filename, SUBMODULE_EXTENSION);
6942 /* First, try to find an non-intrinsic module, unless the USE statement
6943 specified that the module is intrinsic. */
6944 module_fp = NULL;
6945 if (!module->intrinsic)
6946 module_fp = gzopen_included_file (filename, true, true);
6948 /* Then, see if it's an intrinsic one, unless the USE statement
6949 specified that the module is non-intrinsic. */
6950 if (module_fp == NULL && !module->non_intrinsic)
6952 if (strcmp (module_name, "iso_fortran_env") == 0
6953 && gfc_notify_std (GFC_STD_F2003, "ISO_FORTRAN_ENV "
6954 "intrinsic module at %C"))
6956 use_iso_fortran_env_module ();
6957 free_rename (module->rename);
6958 module->rename = NULL;
6959 gfc_current_locus = old_locus;
6960 module->intrinsic = true;
6961 return;
6964 if (strcmp (module_name, "iso_c_binding") == 0
6965 && gfc_notify_std (GFC_STD_F2003, "ISO_C_BINDING module at %C"))
6967 import_iso_c_binding_module();
6968 free_rename (module->rename);
6969 module->rename = NULL;
6970 gfc_current_locus = old_locus;
6971 module->intrinsic = true;
6972 return;
6975 module_fp = gzopen_intrinsic_module (filename);
6977 if (module_fp == NULL && module->intrinsic)
6978 gfc_fatal_error ("Can't find an intrinsic module named %qs at %C",
6979 module_name);
6981 /* Check for the IEEE modules, so we can mark their symbols
6982 accordingly when we read them. */
6983 if (strcmp (module_name, "ieee_features") == 0
6984 && gfc_notify_std (GFC_STD_F2003, "IEEE_FEATURES module at %C"))
6986 current_intmod = INTMOD_IEEE_FEATURES;
6988 else if (strcmp (module_name, "ieee_exceptions") == 0
6989 && gfc_notify_std (GFC_STD_F2003,
6990 "IEEE_EXCEPTIONS module at %C"))
6992 current_intmod = INTMOD_IEEE_EXCEPTIONS;
6994 else if (strcmp (module_name, "ieee_arithmetic") == 0
6995 && gfc_notify_std (GFC_STD_F2003,
6996 "IEEE_ARITHMETIC module at %C"))
6998 current_intmod = INTMOD_IEEE_ARITHMETIC;
7002 if (module_fp == NULL)
7004 if (gfc_state_stack->state != COMP_SUBMODULE
7005 && module->submodule_name == NULL)
7006 gfc_fatal_error ("Can't open module file %qs for reading at %C: %s",
7007 filename, xstrerror (errno));
7008 else
7009 gfc_fatal_error ("Module file %qs has not been generated, either "
7010 "because the module does not contain a MODULE "
7011 "PROCEDURE or there is an error in the module.",
7012 filename);
7015 /* Check that we haven't already USEd an intrinsic module with the
7016 same name. */
7018 mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, module_name);
7019 if (mod_symtree && mod_symtree->n.sym->attr.intrinsic)
7020 gfc_error ("Use of non-intrinsic module %qs at %C conflicts with "
7021 "intrinsic module name used previously", module_name);
7023 iomode = IO_INPUT;
7024 module_line = 1;
7025 module_column = 1;
7026 start = 0;
7028 read_module_to_tmpbuf ();
7029 gzclose (module_fp);
7031 /* Skip the first line of the module, after checking that this is
7032 a gfortran module file. */
7033 line = 0;
7034 while (line < 1)
7036 c = module_char ();
7037 if (c == EOF)
7038 bad_module ("Unexpected end of module");
7039 if (start++ < 3)
7040 parse_name (c);
7041 if ((start == 1 && strcmp (atom_name, "GFORTRAN") != 0)
7042 || (start == 2 && strcmp (atom_name, " module") != 0))
7043 gfc_fatal_error ("File %qs opened at %C is not a GNU Fortran"
7044 " module file", filename);
7045 if (start == 3)
7047 if (strcmp (atom_name, " version") != 0
7048 || module_char () != ' '
7049 || parse_atom () != ATOM_STRING
7050 || strcmp (atom_string, MOD_VERSION))
7051 gfc_fatal_error ("Cannot read module file %qs opened at %C,"
7052 " because it was created by a different"
7053 " version of GNU Fortran", filename);
7055 free (atom_string);
7058 if (c == '\n')
7059 line++;
7062 /* Make sure we're not reading the same module that we may be building. */
7063 for (p = gfc_state_stack; p; p = p->previous)
7064 if ((p->state == COMP_MODULE || p->state == COMP_SUBMODULE)
7065 && strcmp (p->sym->name, module_name) == 0)
7066 gfc_fatal_error ("Can't USE the same %smodule we're building",
7067 p->state == COMP_SUBMODULE ? "sub" : "");
7069 init_pi_tree ();
7070 init_true_name_tree ();
7072 read_module ();
7074 free_true_name (true_name_root);
7075 true_name_root = NULL;
7077 free_pi_tree (pi_root);
7078 pi_root = NULL;
7080 XDELETEVEC (module_content);
7081 module_content = NULL;
7083 use_stmt = gfc_get_use_list ();
7084 *use_stmt = *module;
7085 use_stmt->next = gfc_current_ns->use_stmts;
7086 gfc_current_ns->use_stmts = use_stmt;
7088 gfc_current_locus = old_locus;
7092 /* Remove duplicated intrinsic operators from the rename list. */
7094 static void
7095 rename_list_remove_duplicate (gfc_use_rename *list)
7097 gfc_use_rename *seek, *last;
7099 for (; list; list = list->next)
7100 if (list->op != INTRINSIC_USER && list->op != INTRINSIC_NONE)
7102 last = list;
7103 for (seek = list->next; seek; seek = last->next)
7105 if (list->op == seek->op)
7107 last->next = seek->next;
7108 free (seek);
7110 else
7111 last = seek;
7117 /* Process all USE directives. */
7119 void
7120 gfc_use_modules (void)
7122 gfc_use_list *next, *seek, *last;
7124 for (next = module_list; next; next = next->next)
7126 bool non_intrinsic = next->non_intrinsic;
7127 bool intrinsic = next->intrinsic;
7128 bool neither = !non_intrinsic && !intrinsic;
7130 for (seek = next->next; seek; seek = seek->next)
7132 if (next->module_name != seek->module_name)
7133 continue;
7135 if (seek->non_intrinsic)
7136 non_intrinsic = true;
7137 else if (seek->intrinsic)
7138 intrinsic = true;
7139 else
7140 neither = true;
7143 if (intrinsic && neither && !non_intrinsic)
7145 char *filename;
7146 FILE *fp;
7148 filename = XALLOCAVEC (char,
7149 strlen (next->module_name)
7150 + strlen (MODULE_EXTENSION) + 1);
7151 strcpy (filename, next->module_name);
7152 strcat (filename, MODULE_EXTENSION);
7153 fp = gfc_open_included_file (filename, true, true);
7154 if (fp != NULL)
7156 non_intrinsic = true;
7157 fclose (fp);
7161 last = next;
7162 for (seek = next->next; seek; seek = last->next)
7164 if (next->module_name != seek->module_name)
7166 last = seek;
7167 continue;
7170 if ((!next->intrinsic && !seek->intrinsic)
7171 || (next->intrinsic && seek->intrinsic)
7172 || !non_intrinsic)
7174 if (!seek->only_flag)
7175 next->only_flag = false;
7176 if (seek->rename)
7178 gfc_use_rename *r = seek->rename;
7179 while (r->next)
7180 r = r->next;
7181 r->next = next->rename;
7182 next->rename = seek->rename;
7184 last->next = seek->next;
7185 free (seek);
7187 else
7188 last = seek;
7192 for (; module_list; module_list = next)
7194 next = module_list->next;
7195 rename_list_remove_duplicate (module_list->rename);
7196 gfc_use_module (module_list);
7197 free (module_list);
7199 gfc_rename_list = NULL;
7203 void
7204 gfc_free_use_stmts (gfc_use_list *use_stmts)
7206 gfc_use_list *next;
7207 for (; use_stmts; use_stmts = next)
7209 gfc_use_rename *next_rename;
7211 for (; use_stmts->rename; use_stmts->rename = next_rename)
7213 next_rename = use_stmts->rename->next;
7214 free (use_stmts->rename);
7216 next = use_stmts->next;
7217 free (use_stmts);
7222 void
7223 gfc_module_init_2 (void)
7225 last_atom = ATOM_LPAREN;
7226 gfc_rename_list = NULL;
7227 module_list = NULL;
7231 void
7232 gfc_module_done_2 (void)
7234 free_rename (gfc_rename_list);
7235 gfc_rename_list = NULL;