* ggc.h (empty_string): Delete.
[official-gcc.git] / gcc / fortran / module.c
blob838e55a2b4122aadb36aec6f784b820d8f3f3cc1
1 /* Handle modules, which amounts to loading and saving symbols and
2 their attendant structures.
3 Copyright (C) 2000-2017 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 "14"
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 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 (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 (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 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 a small integer. */
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';
1295 if (atom_int > 99999999)
1296 bad_module ("Integer overflow");
1302 /* Parse a name. */
1304 static void
1305 parse_name (int c)
1307 char *p;
1308 int len;
1310 p = atom_name;
1312 *p++ = c;
1313 len = 1;
1315 for (;;)
1317 c = module_char ();
1318 if (!ISALNUM (c) && c != '_' && c != '-')
1320 module_unget_char ();
1321 break;
1324 *p++ = c;
1325 if (++len > GFC_MAX_SYMBOL_LEN)
1326 bad_module ("Name too long");
1329 *p = '\0';
1334 /* Read the next atom in the module's input stream. */
1336 static atom_type
1337 parse_atom (void)
1339 int c;
1343 c = module_char ();
1345 while (c == ' ' || c == '\r' || c == '\n');
1347 switch (c)
1349 case '(':
1350 return ATOM_LPAREN;
1352 case ')':
1353 return ATOM_RPAREN;
1355 case '\'':
1356 parse_string ();
1357 return ATOM_STRING;
1359 case '0':
1360 case '1':
1361 case '2':
1362 case '3':
1363 case '4':
1364 case '5':
1365 case '6':
1366 case '7':
1367 case '8':
1368 case '9':
1369 parse_integer (c);
1370 return ATOM_INTEGER;
1372 case 'a':
1373 case 'b':
1374 case 'c':
1375 case 'd':
1376 case 'e':
1377 case 'f':
1378 case 'g':
1379 case 'h':
1380 case 'i':
1381 case 'j':
1382 case 'k':
1383 case 'l':
1384 case 'm':
1385 case 'n':
1386 case 'o':
1387 case 'p':
1388 case 'q':
1389 case 'r':
1390 case 's':
1391 case 't':
1392 case 'u':
1393 case 'v':
1394 case 'w':
1395 case 'x':
1396 case 'y':
1397 case 'z':
1398 case 'A':
1399 case 'B':
1400 case 'C':
1401 case 'D':
1402 case 'E':
1403 case 'F':
1404 case 'G':
1405 case 'H':
1406 case 'I':
1407 case 'J':
1408 case 'K':
1409 case 'L':
1410 case 'M':
1411 case 'N':
1412 case 'O':
1413 case 'P':
1414 case 'Q':
1415 case 'R':
1416 case 'S':
1417 case 'T':
1418 case 'U':
1419 case 'V':
1420 case 'W':
1421 case 'X':
1422 case 'Y':
1423 case 'Z':
1424 parse_name (c);
1425 return ATOM_NAME;
1427 default:
1428 bad_module ("Bad name");
1431 /* Not reached. */
1435 /* Peek at the next atom on the input. */
1437 static atom_type
1438 peek_atom (void)
1440 int c;
1444 c = module_char ();
1446 while (c == ' ' || c == '\r' || c == '\n');
1448 switch (c)
1450 case '(':
1451 module_unget_char ();
1452 return ATOM_LPAREN;
1454 case ')':
1455 module_unget_char ();
1456 return ATOM_RPAREN;
1458 case '\'':
1459 module_unget_char ();
1460 return ATOM_STRING;
1462 case '0':
1463 case '1':
1464 case '2':
1465 case '3':
1466 case '4':
1467 case '5':
1468 case '6':
1469 case '7':
1470 case '8':
1471 case '9':
1472 module_unget_char ();
1473 return ATOM_INTEGER;
1475 case 'a':
1476 case 'b':
1477 case 'c':
1478 case 'd':
1479 case 'e':
1480 case 'f':
1481 case 'g':
1482 case 'h':
1483 case 'i':
1484 case 'j':
1485 case 'k':
1486 case 'l':
1487 case 'm':
1488 case 'n':
1489 case 'o':
1490 case 'p':
1491 case 'q':
1492 case 'r':
1493 case 's':
1494 case 't':
1495 case 'u':
1496 case 'v':
1497 case 'w':
1498 case 'x':
1499 case 'y':
1500 case 'z':
1501 case 'A':
1502 case 'B':
1503 case 'C':
1504 case 'D':
1505 case 'E':
1506 case 'F':
1507 case 'G':
1508 case 'H':
1509 case 'I':
1510 case 'J':
1511 case 'K':
1512 case 'L':
1513 case 'M':
1514 case 'N':
1515 case 'O':
1516 case 'P':
1517 case 'Q':
1518 case 'R':
1519 case 'S':
1520 case 'T':
1521 case 'U':
1522 case 'V':
1523 case 'W':
1524 case 'X':
1525 case 'Y':
1526 case 'Z':
1527 module_unget_char ();
1528 return ATOM_NAME;
1530 default:
1531 bad_module ("Bad name");
1536 /* Read the next atom from the input, requiring that it be a
1537 particular kind. */
1539 static void
1540 require_atom (atom_type type)
1542 atom_type t;
1543 const char *p;
1544 int column, line;
1546 column = module_column;
1547 line = module_line;
1549 t = parse_atom ();
1550 if (t != type)
1552 switch (type)
1554 case ATOM_NAME:
1555 p = _("Expected name");
1556 break;
1557 case ATOM_LPAREN:
1558 p = _("Expected left parenthesis");
1559 break;
1560 case ATOM_RPAREN:
1561 p = _("Expected right parenthesis");
1562 break;
1563 case ATOM_INTEGER:
1564 p = _("Expected integer");
1565 break;
1566 case ATOM_STRING:
1567 p = _("Expected string");
1568 break;
1569 default:
1570 gfc_internal_error ("require_atom(): bad atom type required");
1573 module_column = column;
1574 module_line = line;
1575 bad_module (p);
1580 /* Given a pointer to an mstring array, require that the current input
1581 be one of the strings in the array. We return the enum value. */
1583 static int
1584 find_enum (const mstring *m)
1586 int i;
1588 i = gfc_string2code (m, atom_name);
1589 if (i >= 0)
1590 return i;
1592 bad_module ("find_enum(): Enum not found");
1594 /* Not reached. */
1598 /* Read a string. The caller is responsible for freeing. */
1600 static char*
1601 read_string (void)
1603 char* p;
1604 require_atom (ATOM_STRING);
1605 p = atom_string;
1606 atom_string = NULL;
1607 return p;
1611 /**************** Module output subroutines ***************************/
1613 /* Output a character to a module file. */
1615 static void
1616 write_char (char out)
1618 if (gzputc (module_fp, out) == EOF)
1619 gfc_fatal_error ("Error writing modules file: %s", xstrerror (errno));
1621 if (out != '\n')
1622 module_column++;
1623 else
1625 module_column = 1;
1626 module_line++;
1631 /* Write an atom to a module. The line wrapping isn't perfect, but it
1632 should work most of the time. This isn't that big of a deal, since
1633 the file really isn't meant to be read by people anyway. */
1635 static void
1636 write_atom (atom_type atom, const void *v)
1638 char buffer[20];
1640 /* Workaround -Wmaybe-uninitialized false positive during
1641 profiledbootstrap by initializing them. */
1642 int i = 0, len;
1643 const char *p;
1645 switch (atom)
1647 case ATOM_STRING:
1648 case ATOM_NAME:
1649 p = (const char *) v;
1650 break;
1652 case ATOM_LPAREN:
1653 p = "(";
1654 break;
1656 case ATOM_RPAREN:
1657 p = ")";
1658 break;
1660 case ATOM_INTEGER:
1661 i = *((const int *) v);
1662 if (i < 0)
1663 gfc_internal_error ("write_atom(): Writing negative integer");
1665 sprintf (buffer, "%d", i);
1666 p = buffer;
1667 break;
1669 default:
1670 gfc_internal_error ("write_atom(): Trying to write dab atom");
1674 if(p == NULL || *p == '\0')
1675 len = 0;
1676 else
1677 len = strlen (p);
1679 if (atom != ATOM_RPAREN)
1681 if (module_column + len > 72)
1682 write_char ('\n');
1683 else
1686 if (last_atom != ATOM_LPAREN && module_column != 1)
1687 write_char (' ');
1691 if (atom == ATOM_STRING)
1692 write_char ('\'');
1694 while (p != NULL && *p)
1696 if (atom == ATOM_STRING && *p == '\'')
1697 write_char ('\'');
1698 write_char (*p++);
1701 if (atom == ATOM_STRING)
1702 write_char ('\'');
1704 last_atom = atom;
1709 /***************** Mid-level I/O subroutines *****************/
1711 /* These subroutines let their caller read or write atoms without
1712 caring about which of the two is actually happening. This lets a
1713 subroutine concentrate on the actual format of the data being
1714 written. */
1716 static void mio_expr (gfc_expr **);
1717 pointer_info *mio_symbol_ref (gfc_symbol **);
1718 pointer_info *mio_interface_rest (gfc_interface **);
1719 static void mio_symtree_ref (gfc_symtree **);
1721 /* Read or write an enumerated value. On writing, we return the input
1722 value for the convenience of callers. We avoid using an integer
1723 pointer because enums are sometimes inside bitfields. */
1725 static int
1726 mio_name (int t, const mstring *m)
1728 if (iomode == IO_OUTPUT)
1729 write_atom (ATOM_NAME, gfc_code2string (m, t));
1730 else
1732 require_atom (ATOM_NAME);
1733 t = find_enum (m);
1736 return t;
1739 /* Specialization of mio_name. */
1741 #define DECL_MIO_NAME(TYPE) \
1742 static inline TYPE \
1743 MIO_NAME(TYPE) (TYPE t, const mstring *m) \
1745 return (TYPE) mio_name ((int) t, m); \
1747 #define MIO_NAME(TYPE) mio_name_##TYPE
1749 static void
1750 mio_lparen (void)
1752 if (iomode == IO_OUTPUT)
1753 write_atom (ATOM_LPAREN, NULL);
1754 else
1755 require_atom (ATOM_LPAREN);
1759 static void
1760 mio_rparen (void)
1762 if (iomode == IO_OUTPUT)
1763 write_atom (ATOM_RPAREN, NULL);
1764 else
1765 require_atom (ATOM_RPAREN);
1769 static void
1770 mio_integer (int *ip)
1772 if (iomode == IO_OUTPUT)
1773 write_atom (ATOM_INTEGER, ip);
1774 else
1776 require_atom (ATOM_INTEGER);
1777 *ip = atom_int;
1782 /* Read or write a gfc_intrinsic_op value. */
1784 static void
1785 mio_intrinsic_op (gfc_intrinsic_op* op)
1787 /* FIXME: Would be nicer to do this via the operators symbolic name. */
1788 if (iomode == IO_OUTPUT)
1790 int converted = (int) *op;
1791 write_atom (ATOM_INTEGER, &converted);
1793 else
1795 require_atom (ATOM_INTEGER);
1796 *op = (gfc_intrinsic_op) atom_int;
1801 /* Read or write a character pointer that points to a string on the heap. */
1803 static const char *
1804 mio_allocated_string (const char *s)
1806 if (iomode == IO_OUTPUT)
1808 write_atom (ATOM_STRING, s);
1809 return s;
1811 else
1813 require_atom (ATOM_STRING);
1814 return atom_string;
1819 /* Functions for quoting and unquoting strings. */
1821 static char *
1822 quote_string (const gfc_char_t *s, const size_t slength)
1824 const gfc_char_t *p;
1825 char *res, *q;
1826 size_t len = 0, i;
1828 /* Calculate the length we'll need: a backslash takes two ("\\"),
1829 non-printable characters take 10 ("\Uxxxxxxxx") and others take 1. */
1830 for (p = s, i = 0; i < slength; p++, i++)
1832 if (*p == '\\')
1833 len += 2;
1834 else if (!gfc_wide_is_printable (*p))
1835 len += 10;
1836 else
1837 len++;
1840 q = res = XCNEWVEC (char, len + 1);
1841 for (p = s, i = 0; i < slength; p++, i++)
1843 if (*p == '\\')
1844 *q++ = '\\', *q++ = '\\';
1845 else if (!gfc_wide_is_printable (*p))
1847 sprintf (q, "\\U%08" HOST_WIDE_INT_PRINT "x",
1848 (unsigned HOST_WIDE_INT) *p);
1849 q += 10;
1851 else
1852 *q++ = (unsigned char) *p;
1855 res[len] = '\0';
1856 return res;
1859 static gfc_char_t *
1860 unquote_string (const char *s)
1862 size_t len, i;
1863 const char *p;
1864 gfc_char_t *res;
1866 for (p = s, len = 0; *p; p++, len++)
1868 if (*p != '\\')
1869 continue;
1871 if (p[1] == '\\')
1872 p++;
1873 else if (p[1] == 'U')
1874 p += 9; /* That is a "\U????????". */
1875 else
1876 gfc_internal_error ("unquote_string(): got bad string");
1879 res = gfc_get_wide_string (len + 1);
1880 for (i = 0, p = s; i < len; i++, p++)
1882 gcc_assert (*p);
1884 if (*p != '\\')
1885 res[i] = (unsigned char) *p;
1886 else if (p[1] == '\\')
1888 res[i] = (unsigned char) '\\';
1889 p++;
1891 else
1893 /* We read the 8-digits hexadecimal constant that follows. */
1894 int j;
1895 unsigned n;
1896 gfc_char_t c = 0;
1898 gcc_assert (p[1] == 'U');
1899 for (j = 0; j < 8; j++)
1901 c = c << 4;
1902 gcc_assert (sscanf (&p[j+2], "%01x", &n) == 1);
1903 c += n;
1906 res[i] = c;
1907 p += 9;
1911 res[len] = '\0';
1912 return res;
1916 /* Read or write a character pointer that points to a wide string on the
1917 heap, performing quoting/unquoting of nonprintable characters using the
1918 form \U???????? (where each ? is a hexadecimal digit).
1919 Length is the length of the string, only known and used in output mode. */
1921 static const gfc_char_t *
1922 mio_allocated_wide_string (const gfc_char_t *s, const size_t length)
1924 if (iomode == IO_OUTPUT)
1926 char *quoted = quote_string (s, length);
1927 write_atom (ATOM_STRING, quoted);
1928 free (quoted);
1929 return s;
1931 else
1933 gfc_char_t *unquoted;
1935 require_atom (ATOM_STRING);
1936 unquoted = unquote_string (atom_string);
1937 free (atom_string);
1938 return unquoted;
1943 /* Read or write a string that is in static memory. */
1945 static void
1946 mio_pool_string (const char **stringp)
1948 /* TODO: one could write the string only once, and refer to it via a
1949 fixup pointer. */
1951 /* As a special case we have to deal with a NULL string. This
1952 happens for the 'module' member of 'gfc_symbol's that are not in a
1953 module. We read / write these as the empty string. */
1954 if (iomode == IO_OUTPUT)
1956 const char *p = *stringp == NULL ? "" : *stringp;
1957 write_atom (ATOM_STRING, p);
1959 else
1961 require_atom (ATOM_STRING);
1962 *stringp = (atom_string[0] == '\0'
1963 ? NULL : gfc_get_string ("%s", atom_string));
1964 free (atom_string);
1969 /* Read or write a string that is inside of some already-allocated
1970 structure. */
1972 static void
1973 mio_internal_string (char *string)
1975 if (iomode == IO_OUTPUT)
1976 write_atom (ATOM_STRING, string);
1977 else
1979 require_atom (ATOM_STRING);
1980 strcpy (string, atom_string);
1981 free (atom_string);
1986 enum ab_attribute
1987 { AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL,
1988 AB_POINTER, AB_TARGET, AB_DUMMY, AB_RESULT, AB_DATA,
1989 AB_IN_NAMELIST, AB_IN_COMMON, AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE,
1990 AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT,
1991 AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE,
1992 AB_ALLOC_COMP, AB_POINTER_COMP, AB_PROC_POINTER_COMP, AB_PRIVATE_COMP,
1993 AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_LOCK_COMP, AB_EVENT_COMP,
1994 AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
1995 AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
1996 AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER,
1997 AB_IMPLICIT_PURE, AB_ARTIFICIAL, AB_UNLIMITED_POLY, AB_OMP_DECLARE_TARGET,
1998 AB_ARRAY_OUTER_DEPENDENCY, AB_MODULE_PROCEDURE, AB_OACC_DECLARE_CREATE,
1999 AB_OACC_DECLARE_COPYIN, AB_OACC_DECLARE_DEVICEPTR,
2000 AB_OACC_DECLARE_DEVICE_RESIDENT, AB_OACC_DECLARE_LINK,
2001 AB_OMP_DECLARE_TARGET_LINK
2004 static const mstring attr_bits[] =
2006 minit ("ALLOCATABLE", AB_ALLOCATABLE),
2007 minit ("ARTIFICIAL", AB_ARTIFICIAL),
2008 minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS),
2009 minit ("DIMENSION", AB_DIMENSION),
2010 minit ("CODIMENSION", AB_CODIMENSION),
2011 minit ("CONTIGUOUS", AB_CONTIGUOUS),
2012 minit ("EXTERNAL", AB_EXTERNAL),
2013 minit ("INTRINSIC", AB_INTRINSIC),
2014 minit ("OPTIONAL", AB_OPTIONAL),
2015 minit ("POINTER", AB_POINTER),
2016 minit ("VOLATILE", AB_VOLATILE),
2017 minit ("TARGET", AB_TARGET),
2018 minit ("THREADPRIVATE", AB_THREADPRIVATE),
2019 minit ("DUMMY", AB_DUMMY),
2020 minit ("RESULT", AB_RESULT),
2021 minit ("DATA", AB_DATA),
2022 minit ("IN_NAMELIST", AB_IN_NAMELIST),
2023 minit ("IN_COMMON", AB_IN_COMMON),
2024 minit ("FUNCTION", AB_FUNCTION),
2025 minit ("SUBROUTINE", AB_SUBROUTINE),
2026 minit ("SEQUENCE", AB_SEQUENCE),
2027 minit ("ELEMENTAL", AB_ELEMENTAL),
2028 minit ("PURE", AB_PURE),
2029 minit ("RECURSIVE", AB_RECURSIVE),
2030 minit ("GENERIC", AB_GENERIC),
2031 minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT),
2032 minit ("CRAY_POINTER", AB_CRAY_POINTER),
2033 minit ("CRAY_POINTEE", AB_CRAY_POINTEE),
2034 minit ("IS_BIND_C", AB_IS_BIND_C),
2035 minit ("IS_C_INTEROP", AB_IS_C_INTEROP),
2036 minit ("IS_ISO_C", AB_IS_ISO_C),
2037 minit ("VALUE", AB_VALUE),
2038 minit ("ALLOC_COMP", AB_ALLOC_COMP),
2039 minit ("COARRAY_COMP", AB_COARRAY_COMP),
2040 minit ("LOCK_COMP", AB_LOCK_COMP),
2041 minit ("EVENT_COMP", AB_EVENT_COMP),
2042 minit ("POINTER_COMP", AB_POINTER_COMP),
2043 minit ("PROC_POINTER_COMP", AB_PROC_POINTER_COMP),
2044 minit ("PRIVATE_COMP", AB_PRIVATE_COMP),
2045 minit ("ZERO_COMP", AB_ZERO_COMP),
2046 minit ("PROTECTED", AB_PROTECTED),
2047 minit ("ABSTRACT", AB_ABSTRACT),
2048 minit ("IS_CLASS", AB_IS_CLASS),
2049 minit ("PROCEDURE", AB_PROCEDURE),
2050 minit ("PROC_POINTER", AB_PROC_POINTER),
2051 minit ("VTYPE", AB_VTYPE),
2052 minit ("VTAB", AB_VTAB),
2053 minit ("CLASS_POINTER", AB_CLASS_POINTER),
2054 minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE),
2055 minit ("UNLIMITED_POLY", AB_UNLIMITED_POLY),
2056 minit ("OMP_DECLARE_TARGET", AB_OMP_DECLARE_TARGET),
2057 minit ("ARRAY_OUTER_DEPENDENCY", AB_ARRAY_OUTER_DEPENDENCY),
2058 minit ("MODULE_PROCEDURE", AB_MODULE_PROCEDURE),
2059 minit ("OACC_DECLARE_CREATE", AB_OACC_DECLARE_CREATE),
2060 minit ("OACC_DECLARE_COPYIN", AB_OACC_DECLARE_COPYIN),
2061 minit ("OACC_DECLARE_DEVICEPTR", AB_OACC_DECLARE_DEVICEPTR),
2062 minit ("OACC_DECLARE_DEVICE_RESIDENT", AB_OACC_DECLARE_DEVICE_RESIDENT),
2063 minit ("OACC_DECLARE_LINK", AB_OACC_DECLARE_LINK),
2064 minit ("OMP_DECLARE_TARGET_LINK", AB_OMP_DECLARE_TARGET_LINK),
2065 minit (NULL, -1)
2068 /* For binding attributes. */
2069 static const mstring binding_passing[] =
2071 minit ("PASS", 0),
2072 minit ("NOPASS", 1),
2073 minit (NULL, -1)
2075 static const mstring binding_overriding[] =
2077 minit ("OVERRIDABLE", 0),
2078 minit ("NON_OVERRIDABLE", 1),
2079 minit ("DEFERRED", 2),
2080 minit (NULL, -1)
2082 static const mstring binding_generic[] =
2084 minit ("SPECIFIC", 0),
2085 minit ("GENERIC", 1),
2086 minit (NULL, -1)
2088 static const mstring binding_ppc[] =
2090 minit ("NO_PPC", 0),
2091 minit ("PPC", 1),
2092 minit (NULL, -1)
2095 /* Specialization of mio_name. */
2096 DECL_MIO_NAME (ab_attribute)
2097 DECL_MIO_NAME (ar_type)
2098 DECL_MIO_NAME (array_type)
2099 DECL_MIO_NAME (bt)
2100 DECL_MIO_NAME (expr_t)
2101 DECL_MIO_NAME (gfc_access)
2102 DECL_MIO_NAME (gfc_intrinsic_op)
2103 DECL_MIO_NAME (ifsrc)
2104 DECL_MIO_NAME (save_state)
2105 DECL_MIO_NAME (procedure_type)
2106 DECL_MIO_NAME (ref_type)
2107 DECL_MIO_NAME (sym_flavor)
2108 DECL_MIO_NAME (sym_intent)
2109 #undef DECL_MIO_NAME
2111 /* Symbol attributes are stored in list with the first three elements
2112 being the enumerated fields, while the remaining elements (if any)
2113 indicate the individual attribute bits. The access field is not
2114 saved-- it controls what symbols are exported when a module is
2115 written. */
2117 static void
2118 mio_symbol_attribute (symbol_attribute *attr)
2120 atom_type t;
2121 unsigned ext_attr,extension_level;
2123 mio_lparen ();
2125 attr->flavor = MIO_NAME (sym_flavor) (attr->flavor, flavors);
2126 attr->intent = MIO_NAME (sym_intent) (attr->intent, intents);
2127 attr->proc = MIO_NAME (procedure_type) (attr->proc, procedures);
2128 attr->if_source = MIO_NAME (ifsrc) (attr->if_source, ifsrc_types);
2129 attr->save = MIO_NAME (save_state) (attr->save, save_status);
2131 ext_attr = attr->ext_attr;
2132 mio_integer ((int *) &ext_attr);
2133 attr->ext_attr = ext_attr;
2135 extension_level = attr->extension;
2136 mio_integer ((int *) &extension_level);
2137 attr->extension = extension_level;
2139 if (iomode == IO_OUTPUT)
2141 if (attr->allocatable)
2142 MIO_NAME (ab_attribute) (AB_ALLOCATABLE, attr_bits);
2143 if (attr->artificial)
2144 MIO_NAME (ab_attribute) (AB_ARTIFICIAL, attr_bits);
2145 if (attr->asynchronous)
2146 MIO_NAME (ab_attribute) (AB_ASYNCHRONOUS, attr_bits);
2147 if (attr->dimension)
2148 MIO_NAME (ab_attribute) (AB_DIMENSION, attr_bits);
2149 if (attr->codimension)
2150 MIO_NAME (ab_attribute) (AB_CODIMENSION, attr_bits);
2151 if (attr->contiguous)
2152 MIO_NAME (ab_attribute) (AB_CONTIGUOUS, attr_bits);
2153 if (attr->external)
2154 MIO_NAME (ab_attribute) (AB_EXTERNAL, attr_bits);
2155 if (attr->intrinsic)
2156 MIO_NAME (ab_attribute) (AB_INTRINSIC, attr_bits);
2157 if (attr->optional)
2158 MIO_NAME (ab_attribute) (AB_OPTIONAL, attr_bits);
2159 if (attr->pointer)
2160 MIO_NAME (ab_attribute) (AB_POINTER, attr_bits);
2161 if (attr->class_pointer)
2162 MIO_NAME (ab_attribute) (AB_CLASS_POINTER, attr_bits);
2163 if (attr->is_protected)
2164 MIO_NAME (ab_attribute) (AB_PROTECTED, attr_bits);
2165 if (attr->value)
2166 MIO_NAME (ab_attribute) (AB_VALUE, attr_bits);
2167 if (attr->volatile_)
2168 MIO_NAME (ab_attribute) (AB_VOLATILE, attr_bits);
2169 if (attr->target)
2170 MIO_NAME (ab_attribute) (AB_TARGET, attr_bits);
2171 if (attr->threadprivate)
2172 MIO_NAME (ab_attribute) (AB_THREADPRIVATE, attr_bits);
2173 if (attr->dummy)
2174 MIO_NAME (ab_attribute) (AB_DUMMY, attr_bits);
2175 if (attr->result)
2176 MIO_NAME (ab_attribute) (AB_RESULT, attr_bits);
2177 /* We deliberately don't preserve the "entry" flag. */
2179 if (attr->data)
2180 MIO_NAME (ab_attribute) (AB_DATA, attr_bits);
2181 if (attr->in_namelist)
2182 MIO_NAME (ab_attribute) (AB_IN_NAMELIST, attr_bits);
2183 if (attr->in_common)
2184 MIO_NAME (ab_attribute) (AB_IN_COMMON, attr_bits);
2186 if (attr->function)
2187 MIO_NAME (ab_attribute) (AB_FUNCTION, attr_bits);
2188 if (attr->subroutine)
2189 MIO_NAME (ab_attribute) (AB_SUBROUTINE, attr_bits);
2190 if (attr->generic)
2191 MIO_NAME (ab_attribute) (AB_GENERIC, attr_bits);
2192 if (attr->abstract)
2193 MIO_NAME (ab_attribute) (AB_ABSTRACT, attr_bits);
2195 if (attr->sequence)
2196 MIO_NAME (ab_attribute) (AB_SEQUENCE, attr_bits);
2197 if (attr->elemental)
2198 MIO_NAME (ab_attribute) (AB_ELEMENTAL, attr_bits);
2199 if (attr->pure)
2200 MIO_NAME (ab_attribute) (AB_PURE, attr_bits);
2201 if (attr->implicit_pure)
2202 MIO_NAME (ab_attribute) (AB_IMPLICIT_PURE, attr_bits);
2203 if (attr->unlimited_polymorphic)
2204 MIO_NAME (ab_attribute) (AB_UNLIMITED_POLY, attr_bits);
2205 if (attr->recursive)
2206 MIO_NAME (ab_attribute) (AB_RECURSIVE, attr_bits);
2207 if (attr->always_explicit)
2208 MIO_NAME (ab_attribute) (AB_ALWAYS_EXPLICIT, attr_bits);
2209 if (attr->cray_pointer)
2210 MIO_NAME (ab_attribute) (AB_CRAY_POINTER, attr_bits);
2211 if (attr->cray_pointee)
2212 MIO_NAME (ab_attribute) (AB_CRAY_POINTEE, attr_bits);
2213 if (attr->is_bind_c)
2214 MIO_NAME(ab_attribute) (AB_IS_BIND_C, attr_bits);
2215 if (attr->is_c_interop)
2216 MIO_NAME(ab_attribute) (AB_IS_C_INTEROP, attr_bits);
2217 if (attr->is_iso_c)
2218 MIO_NAME(ab_attribute) (AB_IS_ISO_C, attr_bits);
2219 if (attr->alloc_comp)
2220 MIO_NAME (ab_attribute) (AB_ALLOC_COMP, attr_bits);
2221 if (attr->pointer_comp)
2222 MIO_NAME (ab_attribute) (AB_POINTER_COMP, attr_bits);
2223 if (attr->proc_pointer_comp)
2224 MIO_NAME (ab_attribute) (AB_PROC_POINTER_COMP, attr_bits);
2225 if (attr->private_comp)
2226 MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits);
2227 if (attr->coarray_comp)
2228 MIO_NAME (ab_attribute) (AB_COARRAY_COMP, attr_bits);
2229 if (attr->lock_comp)
2230 MIO_NAME (ab_attribute) (AB_LOCK_COMP, attr_bits);
2231 if (attr->event_comp)
2232 MIO_NAME (ab_attribute) (AB_EVENT_COMP, attr_bits);
2233 if (attr->zero_comp)
2234 MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits);
2235 if (attr->is_class)
2236 MIO_NAME (ab_attribute) (AB_IS_CLASS, attr_bits);
2237 if (attr->procedure)
2238 MIO_NAME (ab_attribute) (AB_PROCEDURE, attr_bits);
2239 if (attr->proc_pointer)
2240 MIO_NAME (ab_attribute) (AB_PROC_POINTER, attr_bits);
2241 if (attr->vtype)
2242 MIO_NAME (ab_attribute) (AB_VTYPE, attr_bits);
2243 if (attr->vtab)
2244 MIO_NAME (ab_attribute) (AB_VTAB, attr_bits);
2245 if (attr->omp_declare_target)
2246 MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET, attr_bits);
2247 if (attr->array_outer_dependency)
2248 MIO_NAME (ab_attribute) (AB_ARRAY_OUTER_DEPENDENCY, attr_bits);
2249 if (attr->module_procedure)
2250 MIO_NAME (ab_attribute) (AB_MODULE_PROCEDURE, attr_bits);
2251 if (attr->oacc_declare_create)
2252 MIO_NAME (ab_attribute) (AB_OACC_DECLARE_CREATE, attr_bits);
2253 if (attr->oacc_declare_copyin)
2254 MIO_NAME (ab_attribute) (AB_OACC_DECLARE_COPYIN, attr_bits);
2255 if (attr->oacc_declare_deviceptr)
2256 MIO_NAME (ab_attribute) (AB_OACC_DECLARE_DEVICEPTR, attr_bits);
2257 if (attr->oacc_declare_device_resident)
2258 MIO_NAME (ab_attribute) (AB_OACC_DECLARE_DEVICE_RESIDENT, attr_bits);
2259 if (attr->oacc_declare_link)
2260 MIO_NAME (ab_attribute) (AB_OACC_DECLARE_LINK, attr_bits);
2261 if (attr->omp_declare_target_link)
2262 MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET_LINK, attr_bits);
2264 mio_rparen ();
2267 else
2269 for (;;)
2271 t = parse_atom ();
2272 if (t == ATOM_RPAREN)
2273 break;
2274 if (t != ATOM_NAME)
2275 bad_module ("Expected attribute bit name");
2277 switch ((ab_attribute) find_enum (attr_bits))
2279 case AB_ALLOCATABLE:
2280 attr->allocatable = 1;
2281 break;
2282 case AB_ARTIFICIAL:
2283 attr->artificial = 1;
2284 break;
2285 case AB_ASYNCHRONOUS:
2286 attr->asynchronous = 1;
2287 break;
2288 case AB_DIMENSION:
2289 attr->dimension = 1;
2290 break;
2291 case AB_CODIMENSION:
2292 attr->codimension = 1;
2293 break;
2294 case AB_CONTIGUOUS:
2295 attr->contiguous = 1;
2296 break;
2297 case AB_EXTERNAL:
2298 attr->external = 1;
2299 break;
2300 case AB_INTRINSIC:
2301 attr->intrinsic = 1;
2302 break;
2303 case AB_OPTIONAL:
2304 attr->optional = 1;
2305 break;
2306 case AB_POINTER:
2307 attr->pointer = 1;
2308 break;
2309 case AB_CLASS_POINTER:
2310 attr->class_pointer = 1;
2311 break;
2312 case AB_PROTECTED:
2313 attr->is_protected = 1;
2314 break;
2315 case AB_VALUE:
2316 attr->value = 1;
2317 break;
2318 case AB_VOLATILE:
2319 attr->volatile_ = 1;
2320 break;
2321 case AB_TARGET:
2322 attr->target = 1;
2323 break;
2324 case AB_THREADPRIVATE:
2325 attr->threadprivate = 1;
2326 break;
2327 case AB_DUMMY:
2328 attr->dummy = 1;
2329 break;
2330 case AB_RESULT:
2331 attr->result = 1;
2332 break;
2333 case AB_DATA:
2334 attr->data = 1;
2335 break;
2336 case AB_IN_NAMELIST:
2337 attr->in_namelist = 1;
2338 break;
2339 case AB_IN_COMMON:
2340 attr->in_common = 1;
2341 break;
2342 case AB_FUNCTION:
2343 attr->function = 1;
2344 break;
2345 case AB_SUBROUTINE:
2346 attr->subroutine = 1;
2347 break;
2348 case AB_GENERIC:
2349 attr->generic = 1;
2350 break;
2351 case AB_ABSTRACT:
2352 attr->abstract = 1;
2353 break;
2354 case AB_SEQUENCE:
2355 attr->sequence = 1;
2356 break;
2357 case AB_ELEMENTAL:
2358 attr->elemental = 1;
2359 break;
2360 case AB_PURE:
2361 attr->pure = 1;
2362 break;
2363 case AB_IMPLICIT_PURE:
2364 attr->implicit_pure = 1;
2365 break;
2366 case AB_UNLIMITED_POLY:
2367 attr->unlimited_polymorphic = 1;
2368 break;
2369 case AB_RECURSIVE:
2370 attr->recursive = 1;
2371 break;
2372 case AB_ALWAYS_EXPLICIT:
2373 attr->always_explicit = 1;
2374 break;
2375 case AB_CRAY_POINTER:
2376 attr->cray_pointer = 1;
2377 break;
2378 case AB_CRAY_POINTEE:
2379 attr->cray_pointee = 1;
2380 break;
2381 case AB_IS_BIND_C:
2382 attr->is_bind_c = 1;
2383 break;
2384 case AB_IS_C_INTEROP:
2385 attr->is_c_interop = 1;
2386 break;
2387 case AB_IS_ISO_C:
2388 attr->is_iso_c = 1;
2389 break;
2390 case AB_ALLOC_COMP:
2391 attr->alloc_comp = 1;
2392 break;
2393 case AB_COARRAY_COMP:
2394 attr->coarray_comp = 1;
2395 break;
2396 case AB_LOCK_COMP:
2397 attr->lock_comp = 1;
2398 break;
2399 case AB_EVENT_COMP:
2400 attr->event_comp = 1;
2401 break;
2402 case AB_POINTER_COMP:
2403 attr->pointer_comp = 1;
2404 break;
2405 case AB_PROC_POINTER_COMP:
2406 attr->proc_pointer_comp = 1;
2407 break;
2408 case AB_PRIVATE_COMP:
2409 attr->private_comp = 1;
2410 break;
2411 case AB_ZERO_COMP:
2412 attr->zero_comp = 1;
2413 break;
2414 case AB_IS_CLASS:
2415 attr->is_class = 1;
2416 break;
2417 case AB_PROCEDURE:
2418 attr->procedure = 1;
2419 break;
2420 case AB_PROC_POINTER:
2421 attr->proc_pointer = 1;
2422 break;
2423 case AB_VTYPE:
2424 attr->vtype = 1;
2425 break;
2426 case AB_VTAB:
2427 attr->vtab = 1;
2428 break;
2429 case AB_OMP_DECLARE_TARGET:
2430 attr->omp_declare_target = 1;
2431 break;
2432 case AB_OMP_DECLARE_TARGET_LINK:
2433 attr->omp_declare_target_link = 1;
2434 break;
2435 case AB_ARRAY_OUTER_DEPENDENCY:
2436 attr->array_outer_dependency =1;
2437 break;
2438 case AB_MODULE_PROCEDURE:
2439 attr->module_procedure =1;
2440 break;
2441 case AB_OACC_DECLARE_CREATE:
2442 attr->oacc_declare_create = 1;
2443 break;
2444 case AB_OACC_DECLARE_COPYIN:
2445 attr->oacc_declare_copyin = 1;
2446 break;
2447 case AB_OACC_DECLARE_DEVICEPTR:
2448 attr->oacc_declare_deviceptr = 1;
2449 break;
2450 case AB_OACC_DECLARE_DEVICE_RESIDENT:
2451 attr->oacc_declare_device_resident = 1;
2452 break;
2453 case AB_OACC_DECLARE_LINK:
2454 attr->oacc_declare_link = 1;
2455 break;
2462 static const mstring bt_types[] = {
2463 minit ("INTEGER", BT_INTEGER),
2464 minit ("REAL", BT_REAL),
2465 minit ("COMPLEX", BT_COMPLEX),
2466 minit ("LOGICAL", BT_LOGICAL),
2467 minit ("CHARACTER", BT_CHARACTER),
2468 minit ("UNION", BT_UNION),
2469 minit ("DERIVED", BT_DERIVED),
2470 minit ("CLASS", BT_CLASS),
2471 minit ("PROCEDURE", BT_PROCEDURE),
2472 minit ("UNKNOWN", BT_UNKNOWN),
2473 minit ("VOID", BT_VOID),
2474 minit ("ASSUMED", BT_ASSUMED),
2475 minit (NULL, -1)
2479 static void
2480 mio_charlen (gfc_charlen **clp)
2482 gfc_charlen *cl;
2484 mio_lparen ();
2486 if (iomode == IO_OUTPUT)
2488 cl = *clp;
2489 if (cl != NULL)
2490 mio_expr (&cl->length);
2492 else
2494 if (peek_atom () != ATOM_RPAREN)
2496 cl = gfc_new_charlen (gfc_current_ns, NULL);
2497 mio_expr (&cl->length);
2498 *clp = cl;
2502 mio_rparen ();
2506 /* See if a name is a generated name. */
2508 static int
2509 check_unique_name (const char *name)
2511 return *name == '@';
2515 static void
2516 mio_typespec (gfc_typespec *ts)
2518 mio_lparen ();
2520 ts->type = MIO_NAME (bt) (ts->type, bt_types);
2522 if (!gfc_bt_struct (ts->type) && ts->type != BT_CLASS)
2523 mio_integer (&ts->kind);
2524 else
2525 mio_symbol_ref (&ts->u.derived);
2527 mio_symbol_ref (&ts->interface);
2529 /* Add info for C interop and is_iso_c. */
2530 mio_integer (&ts->is_c_interop);
2531 mio_integer (&ts->is_iso_c);
2533 /* If the typespec is for an identifier either from iso_c_binding, or
2534 a constant that was initialized to an identifier from it, use the
2535 f90_type. Otherwise, use the ts->type, since it shouldn't matter. */
2536 if (ts->is_iso_c)
2537 ts->f90_type = MIO_NAME (bt) (ts->f90_type, bt_types);
2538 else
2539 ts->f90_type = MIO_NAME (bt) (ts->type, bt_types);
2541 if (ts->type != BT_CHARACTER)
2543 /* ts->u.cl is only valid for BT_CHARACTER. */
2544 mio_lparen ();
2545 mio_rparen ();
2547 else
2548 mio_charlen (&ts->u.cl);
2550 /* So as not to disturb the existing API, use an ATOM_NAME to
2551 transmit deferred characteristic for characters (F2003). */
2552 if (iomode == IO_OUTPUT)
2554 if (ts->type == BT_CHARACTER && ts->deferred)
2555 write_atom (ATOM_NAME, "DEFERRED_CL");
2557 else if (peek_atom () != ATOM_RPAREN)
2559 if (parse_atom () != ATOM_NAME)
2560 bad_module ("Expected string");
2561 ts->deferred = 1;
2564 mio_rparen ();
2568 static const mstring array_spec_types[] = {
2569 minit ("EXPLICIT", AS_EXPLICIT),
2570 minit ("ASSUMED_RANK", AS_ASSUMED_RANK),
2571 minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE),
2572 minit ("DEFERRED", AS_DEFERRED),
2573 minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE),
2574 minit (NULL, -1)
2578 static void
2579 mio_array_spec (gfc_array_spec **asp)
2581 gfc_array_spec *as;
2582 int i;
2584 mio_lparen ();
2586 if (iomode == IO_OUTPUT)
2588 int rank;
2590 if (*asp == NULL)
2591 goto done;
2592 as = *asp;
2594 /* mio_integer expects nonnegative values. */
2595 rank = as->rank > 0 ? as->rank : 0;
2596 mio_integer (&rank);
2598 else
2600 if (peek_atom () == ATOM_RPAREN)
2602 *asp = NULL;
2603 goto done;
2606 *asp = as = gfc_get_array_spec ();
2607 mio_integer (&as->rank);
2610 mio_integer (&as->corank);
2611 as->type = MIO_NAME (array_type) (as->type, array_spec_types);
2613 if (iomode == IO_INPUT && as->type == AS_ASSUMED_RANK)
2614 as->rank = -1;
2615 if (iomode == IO_INPUT && as->corank)
2616 as->cotype = (as->type == AS_DEFERRED) ? AS_DEFERRED : AS_EXPLICIT;
2618 if (as->rank + as->corank > 0)
2619 for (i = 0; i < as->rank + as->corank; i++)
2621 mio_expr (&as->lower[i]);
2622 mio_expr (&as->upper[i]);
2625 done:
2626 mio_rparen ();
2630 /* Given a pointer to an array reference structure (which lives in a
2631 gfc_ref structure), find the corresponding array specification
2632 structure. Storing the pointer in the ref structure doesn't quite
2633 work when loading from a module. Generating code for an array
2634 reference also needs more information than just the array spec. */
2636 static const mstring array_ref_types[] = {
2637 minit ("FULL", AR_FULL),
2638 minit ("ELEMENT", AR_ELEMENT),
2639 minit ("SECTION", AR_SECTION),
2640 minit (NULL, -1)
2644 static void
2645 mio_array_ref (gfc_array_ref *ar)
2647 int i;
2649 mio_lparen ();
2650 ar->type = MIO_NAME (ar_type) (ar->type, array_ref_types);
2651 mio_integer (&ar->dimen);
2653 switch (ar->type)
2655 case AR_FULL:
2656 break;
2658 case AR_ELEMENT:
2659 for (i = 0; i < ar->dimen; i++)
2660 mio_expr (&ar->start[i]);
2662 break;
2664 case AR_SECTION:
2665 for (i = 0; i < ar->dimen; i++)
2667 mio_expr (&ar->start[i]);
2668 mio_expr (&ar->end[i]);
2669 mio_expr (&ar->stride[i]);
2672 break;
2674 case AR_UNKNOWN:
2675 gfc_internal_error ("mio_array_ref(): Unknown array ref");
2678 /* Unfortunately, ar->dimen_type is an anonymous enumerated type so
2679 we can't call mio_integer directly. Instead loop over each element
2680 and cast it to/from an integer. */
2681 if (iomode == IO_OUTPUT)
2683 for (i = 0; i < ar->dimen; i++)
2685 int tmp = (int)ar->dimen_type[i];
2686 write_atom (ATOM_INTEGER, &tmp);
2689 else
2691 for (i = 0; i < ar->dimen; i++)
2693 require_atom (ATOM_INTEGER);
2694 ar->dimen_type[i] = (enum gfc_array_ref_dimen_type) atom_int;
2698 if (iomode == IO_INPUT)
2700 ar->where = gfc_current_locus;
2702 for (i = 0; i < ar->dimen; i++)
2703 ar->c_where[i] = gfc_current_locus;
2706 mio_rparen ();
2710 /* Saves or restores a pointer. The pointer is converted back and
2711 forth from an integer. We return the pointer_info pointer so that
2712 the caller can take additional action based on the pointer type. */
2714 static pointer_info *
2715 mio_pointer_ref (void *gp)
2717 pointer_info *p;
2719 if (iomode == IO_OUTPUT)
2721 p = get_pointer (*((char **) gp));
2722 write_atom (ATOM_INTEGER, &p->integer);
2724 else
2726 require_atom (ATOM_INTEGER);
2727 p = add_fixup (atom_int, gp);
2730 return p;
2734 /* Save and load references to components that occur within
2735 expressions. We have to describe these references by a number and
2736 by name. The number is necessary for forward references during
2737 reading, and the name is necessary if the symbol already exists in
2738 the namespace and is not loaded again. */
2740 static void
2741 mio_component_ref (gfc_component **cp)
2743 pointer_info *p;
2745 p = mio_pointer_ref (cp);
2746 if (p->type == P_UNKNOWN)
2747 p->type = P_COMPONENT;
2751 static void mio_namespace_ref (gfc_namespace **nsp);
2752 static void mio_formal_arglist (gfc_formal_arglist **formal);
2753 static void mio_typebound_proc (gfc_typebound_proc** proc);
2755 static void
2756 mio_component (gfc_component *c, int vtype)
2758 pointer_info *p;
2759 int n;
2761 mio_lparen ();
2763 if (iomode == IO_OUTPUT)
2765 p = get_pointer (c);
2766 mio_integer (&p->integer);
2768 else
2770 mio_integer (&n);
2771 p = get_integer (n);
2772 associate_integer_pointer (p, c);
2775 if (p->type == P_UNKNOWN)
2776 p->type = P_COMPONENT;
2778 mio_pool_string (&c->name);
2779 mio_typespec (&c->ts);
2780 mio_array_spec (&c->as);
2782 mio_symbol_attribute (&c->attr);
2783 if (c->ts.type == BT_CLASS)
2784 c->attr.class_ok = 1;
2785 c->attr.access = MIO_NAME (gfc_access) (c->attr.access, access_types);
2787 if (!vtype || strcmp (c->name, "_final") == 0
2788 || strcmp (c->name, "_hash") == 0)
2789 mio_expr (&c->initializer);
2791 if (c->attr.proc_pointer)
2792 mio_typebound_proc (&c->tb);
2794 mio_rparen ();
2798 static void
2799 mio_component_list (gfc_component **cp, int vtype)
2801 gfc_component *c, *tail;
2803 mio_lparen ();
2805 if (iomode == IO_OUTPUT)
2807 for (c = *cp; c; c = c->next)
2808 mio_component (c, vtype);
2810 else
2812 *cp = NULL;
2813 tail = NULL;
2815 for (;;)
2817 if (peek_atom () == ATOM_RPAREN)
2818 break;
2820 c = gfc_get_component ();
2821 mio_component (c, vtype);
2823 if (tail == NULL)
2824 *cp = c;
2825 else
2826 tail->next = c;
2828 tail = c;
2832 mio_rparen ();
2836 static void
2837 mio_actual_arg (gfc_actual_arglist *a)
2839 mio_lparen ();
2840 mio_pool_string (&a->name);
2841 mio_expr (&a->expr);
2842 mio_rparen ();
2846 static void
2847 mio_actual_arglist (gfc_actual_arglist **ap)
2849 gfc_actual_arglist *a, *tail;
2851 mio_lparen ();
2853 if (iomode == IO_OUTPUT)
2855 for (a = *ap; a; a = a->next)
2856 mio_actual_arg (a);
2859 else
2861 tail = NULL;
2863 for (;;)
2865 if (peek_atom () != ATOM_LPAREN)
2866 break;
2868 a = gfc_get_actual_arglist ();
2870 if (tail == NULL)
2871 *ap = a;
2872 else
2873 tail->next = a;
2875 tail = a;
2876 mio_actual_arg (a);
2880 mio_rparen ();
2884 /* Read and write formal argument lists. */
2886 static void
2887 mio_formal_arglist (gfc_formal_arglist **formal)
2889 gfc_formal_arglist *f, *tail;
2891 mio_lparen ();
2893 if (iomode == IO_OUTPUT)
2895 for (f = *formal; f; f = f->next)
2896 mio_symbol_ref (&f->sym);
2898 else
2900 *formal = tail = NULL;
2902 while (peek_atom () != ATOM_RPAREN)
2904 f = gfc_get_formal_arglist ();
2905 mio_symbol_ref (&f->sym);
2907 if (*formal == NULL)
2908 *formal = f;
2909 else
2910 tail->next = f;
2912 tail = f;
2916 mio_rparen ();
2920 /* Save or restore a reference to a symbol node. */
2922 pointer_info *
2923 mio_symbol_ref (gfc_symbol **symp)
2925 pointer_info *p;
2927 p = mio_pointer_ref (symp);
2928 if (p->type == P_UNKNOWN)
2929 p->type = P_SYMBOL;
2931 if (iomode == IO_OUTPUT)
2933 if (p->u.wsym.state == UNREFERENCED)
2934 p->u.wsym.state = NEEDS_WRITE;
2936 else
2938 if (p->u.rsym.state == UNUSED)
2939 p->u.rsym.state = NEEDED;
2941 return p;
2945 /* Save or restore a reference to a symtree node. */
2947 static void
2948 mio_symtree_ref (gfc_symtree **stp)
2950 pointer_info *p;
2951 fixup_t *f;
2953 if (iomode == IO_OUTPUT)
2954 mio_symbol_ref (&(*stp)->n.sym);
2955 else
2957 require_atom (ATOM_INTEGER);
2958 p = get_integer (atom_int);
2960 /* An unused equivalence member; make a symbol and a symtree
2961 for it. */
2962 if (in_load_equiv && p->u.rsym.symtree == NULL)
2964 /* Since this is not used, it must have a unique name. */
2965 p->u.rsym.symtree = gfc_get_unique_symtree (gfc_current_ns);
2967 /* Make the symbol. */
2968 if (p->u.rsym.sym == NULL)
2970 p->u.rsym.sym = gfc_new_symbol (p->u.rsym.true_name,
2971 gfc_current_ns);
2972 p->u.rsym.sym->module = gfc_get_string ("%s", p->u.rsym.module);
2975 p->u.rsym.symtree->n.sym = p->u.rsym.sym;
2976 p->u.rsym.symtree->n.sym->refs++;
2977 p->u.rsym.referenced = 1;
2979 /* If the symbol is PRIVATE and in COMMON, load_commons will
2980 generate a fixup symbol, which must be associated. */
2981 if (p->fixup)
2982 resolve_fixups (p->fixup, p->u.rsym.sym);
2983 p->fixup = NULL;
2986 if (p->type == P_UNKNOWN)
2987 p->type = P_SYMBOL;
2989 if (p->u.rsym.state == UNUSED)
2990 p->u.rsym.state = NEEDED;
2992 if (p->u.rsym.symtree != NULL)
2994 *stp = p->u.rsym.symtree;
2996 else
2998 f = XCNEW (fixup_t);
3000 f->next = p->u.rsym.stfixup;
3001 p->u.rsym.stfixup = f;
3003 f->pointer = (void **) stp;
3009 static void
3010 mio_iterator (gfc_iterator **ip)
3012 gfc_iterator *iter;
3014 mio_lparen ();
3016 if (iomode == IO_OUTPUT)
3018 if (*ip == NULL)
3019 goto done;
3021 else
3023 if (peek_atom () == ATOM_RPAREN)
3025 *ip = NULL;
3026 goto done;
3029 *ip = gfc_get_iterator ();
3032 iter = *ip;
3034 mio_expr (&iter->var);
3035 mio_expr (&iter->start);
3036 mio_expr (&iter->end);
3037 mio_expr (&iter->step);
3039 done:
3040 mio_rparen ();
3044 static void
3045 mio_constructor (gfc_constructor_base *cp)
3047 gfc_constructor *c;
3049 mio_lparen ();
3051 if (iomode == IO_OUTPUT)
3053 for (c = gfc_constructor_first (*cp); c; c = gfc_constructor_next (c))
3055 mio_lparen ();
3056 mio_expr (&c->expr);
3057 mio_iterator (&c->iterator);
3058 mio_rparen ();
3061 else
3063 while (peek_atom () != ATOM_RPAREN)
3065 c = gfc_constructor_append_expr (cp, NULL, NULL);
3067 mio_lparen ();
3068 mio_expr (&c->expr);
3069 mio_iterator (&c->iterator);
3070 mio_rparen ();
3074 mio_rparen ();
3078 static const mstring ref_types[] = {
3079 minit ("ARRAY", REF_ARRAY),
3080 minit ("COMPONENT", REF_COMPONENT),
3081 minit ("SUBSTRING", REF_SUBSTRING),
3082 minit (NULL, -1)
3086 static void
3087 mio_ref (gfc_ref **rp)
3089 gfc_ref *r;
3091 mio_lparen ();
3093 r = *rp;
3094 r->type = MIO_NAME (ref_type) (r->type, ref_types);
3096 switch (r->type)
3098 case REF_ARRAY:
3099 mio_array_ref (&r->u.ar);
3100 break;
3102 case REF_COMPONENT:
3103 mio_symbol_ref (&r->u.c.sym);
3104 mio_component_ref (&r->u.c.component);
3105 break;
3107 case REF_SUBSTRING:
3108 mio_expr (&r->u.ss.start);
3109 mio_expr (&r->u.ss.end);
3110 mio_charlen (&r->u.ss.length);
3111 break;
3114 mio_rparen ();
3118 static void
3119 mio_ref_list (gfc_ref **rp)
3121 gfc_ref *ref, *head, *tail;
3123 mio_lparen ();
3125 if (iomode == IO_OUTPUT)
3127 for (ref = *rp; ref; ref = ref->next)
3128 mio_ref (&ref);
3130 else
3132 head = tail = NULL;
3134 while (peek_atom () != ATOM_RPAREN)
3136 if (head == NULL)
3137 head = tail = gfc_get_ref ();
3138 else
3140 tail->next = gfc_get_ref ();
3141 tail = tail->next;
3144 mio_ref (&tail);
3147 *rp = head;
3150 mio_rparen ();
3154 /* Read and write an integer value. */
3156 static void
3157 mio_gmp_integer (mpz_t *integer)
3159 char *p;
3161 if (iomode == IO_INPUT)
3163 if (parse_atom () != ATOM_STRING)
3164 bad_module ("Expected integer string");
3166 mpz_init (*integer);
3167 if (mpz_set_str (*integer, atom_string, 10))
3168 bad_module ("Error converting integer");
3170 free (atom_string);
3172 else
3174 p = mpz_get_str (NULL, 10, *integer);
3175 write_atom (ATOM_STRING, p);
3176 free (p);
3181 static void
3182 mio_gmp_real (mpfr_t *real)
3184 mp_exp_t exponent;
3185 char *p;
3187 if (iomode == IO_INPUT)
3189 if (parse_atom () != ATOM_STRING)
3190 bad_module ("Expected real string");
3192 mpfr_init (*real);
3193 mpfr_set_str (*real, atom_string, 16, GFC_RND_MODE);
3194 free (atom_string);
3196 else
3198 p = mpfr_get_str (NULL, &exponent, 16, 0, *real, GFC_RND_MODE);
3200 if (mpfr_nan_p (*real) || mpfr_inf_p (*real))
3202 write_atom (ATOM_STRING, p);
3203 free (p);
3204 return;
3207 atom_string = XCNEWVEC (char, strlen (p) + 20);
3209 sprintf (atom_string, "0.%s@%ld", p, exponent);
3211 /* Fix negative numbers. */
3212 if (atom_string[2] == '-')
3214 atom_string[0] = '-';
3215 atom_string[1] = '0';
3216 atom_string[2] = '.';
3219 write_atom (ATOM_STRING, atom_string);
3221 free (atom_string);
3222 free (p);
3227 /* Save and restore the shape of an array constructor. */
3229 static void
3230 mio_shape (mpz_t **pshape, int rank)
3232 mpz_t *shape;
3233 atom_type t;
3234 int n;
3236 /* A NULL shape is represented by (). */
3237 mio_lparen ();
3239 if (iomode == IO_OUTPUT)
3241 shape = *pshape;
3242 if (!shape)
3244 mio_rparen ();
3245 return;
3248 else
3250 t = peek_atom ();
3251 if (t == ATOM_RPAREN)
3253 *pshape = NULL;
3254 mio_rparen ();
3255 return;
3258 shape = gfc_get_shape (rank);
3259 *pshape = shape;
3262 for (n = 0; n < rank; n++)
3263 mio_gmp_integer (&shape[n]);
3265 mio_rparen ();
3269 static const mstring expr_types[] = {
3270 minit ("OP", EXPR_OP),
3271 minit ("FUNCTION", EXPR_FUNCTION),
3272 minit ("CONSTANT", EXPR_CONSTANT),
3273 minit ("VARIABLE", EXPR_VARIABLE),
3274 minit ("SUBSTRING", EXPR_SUBSTRING),
3275 minit ("STRUCTURE", EXPR_STRUCTURE),
3276 minit ("ARRAY", EXPR_ARRAY),
3277 minit ("NULL", EXPR_NULL),
3278 minit ("COMPCALL", EXPR_COMPCALL),
3279 minit (NULL, -1)
3282 /* INTRINSIC_ASSIGN is missing because it is used as an index for
3283 generic operators, not in expressions. INTRINSIC_USER is also
3284 replaced by the correct function name by the time we see it. */
3286 static const mstring intrinsics[] =
3288 minit ("UPLUS", INTRINSIC_UPLUS),
3289 minit ("UMINUS", INTRINSIC_UMINUS),
3290 minit ("PLUS", INTRINSIC_PLUS),
3291 minit ("MINUS", INTRINSIC_MINUS),
3292 minit ("TIMES", INTRINSIC_TIMES),
3293 minit ("DIVIDE", INTRINSIC_DIVIDE),
3294 minit ("POWER", INTRINSIC_POWER),
3295 minit ("CONCAT", INTRINSIC_CONCAT),
3296 minit ("AND", INTRINSIC_AND),
3297 minit ("OR", INTRINSIC_OR),
3298 minit ("EQV", INTRINSIC_EQV),
3299 minit ("NEQV", INTRINSIC_NEQV),
3300 minit ("EQ_SIGN", INTRINSIC_EQ),
3301 minit ("EQ", INTRINSIC_EQ_OS),
3302 minit ("NE_SIGN", INTRINSIC_NE),
3303 minit ("NE", INTRINSIC_NE_OS),
3304 minit ("GT_SIGN", INTRINSIC_GT),
3305 minit ("GT", INTRINSIC_GT_OS),
3306 minit ("GE_SIGN", INTRINSIC_GE),
3307 minit ("GE", INTRINSIC_GE_OS),
3308 minit ("LT_SIGN", INTRINSIC_LT),
3309 minit ("LT", INTRINSIC_LT_OS),
3310 minit ("LE_SIGN", INTRINSIC_LE),
3311 minit ("LE", INTRINSIC_LE_OS),
3312 minit ("NOT", INTRINSIC_NOT),
3313 minit ("PARENTHESES", INTRINSIC_PARENTHESES),
3314 minit ("USER", INTRINSIC_USER),
3315 minit (NULL, -1)
3319 /* Remedy a couple of situations where the gfc_expr's can be defective. */
3321 static void
3322 fix_mio_expr (gfc_expr *e)
3324 gfc_symtree *ns_st = NULL;
3325 const char *fname;
3327 if (iomode != IO_OUTPUT)
3328 return;
3330 if (e->symtree)
3332 /* If this is a symtree for a symbol that came from a contained module
3333 namespace, it has a unique name and we should look in the current
3334 namespace to see if the required, non-contained symbol is available
3335 yet. If so, the latter should be written. */
3336 if (e->symtree->n.sym && check_unique_name (e->symtree->name))
3338 const char *name = e->symtree->n.sym->name;
3339 if (gfc_fl_struct (e->symtree->n.sym->attr.flavor))
3340 name = gfc_dt_upper_string (name);
3341 ns_st = gfc_find_symtree (gfc_current_ns->sym_root, name);
3344 /* On the other hand, if the existing symbol is the module name or the
3345 new symbol is a dummy argument, do not do the promotion. */
3346 if (ns_st && ns_st->n.sym
3347 && ns_st->n.sym->attr.flavor != FL_MODULE
3348 && !e->symtree->n.sym->attr.dummy)
3349 e->symtree = ns_st;
3351 else if (e->expr_type == EXPR_FUNCTION
3352 && (e->value.function.name || e->value.function.isym))
3354 gfc_symbol *sym;
3356 /* In some circumstances, a function used in an initialization
3357 expression, in one use associated module, can fail to be
3358 coupled to its symtree when used in a specification
3359 expression in another module. */
3360 fname = e->value.function.esym ? e->value.function.esym->name
3361 : e->value.function.isym->name;
3362 e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
3364 if (e->symtree)
3365 return;
3367 /* This is probably a reference to a private procedure from another
3368 module. To prevent a segfault, make a generic with no specific
3369 instances. If this module is used, without the required
3370 specific coming from somewhere, the appropriate error message
3371 is issued. */
3372 gfc_get_symbol (fname, gfc_current_ns, &sym);
3373 sym->attr.flavor = FL_PROCEDURE;
3374 sym->attr.generic = 1;
3375 e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
3376 gfc_commit_symbol (sym);
3381 /* Read and write expressions. The form "()" is allowed to indicate a
3382 NULL expression. */
3384 static void
3385 mio_expr (gfc_expr **ep)
3387 gfc_expr *e;
3388 atom_type t;
3389 int flag;
3391 mio_lparen ();
3393 if (iomode == IO_OUTPUT)
3395 if (*ep == NULL)
3397 mio_rparen ();
3398 return;
3401 e = *ep;
3402 MIO_NAME (expr_t) (e->expr_type, expr_types);
3404 else
3406 t = parse_atom ();
3407 if (t == ATOM_RPAREN)
3409 *ep = NULL;
3410 return;
3413 if (t != ATOM_NAME)
3414 bad_module ("Expected expression type");
3416 e = *ep = gfc_get_expr ();
3417 e->where = gfc_current_locus;
3418 e->expr_type = (expr_t) find_enum (expr_types);
3421 mio_typespec (&e->ts);
3422 mio_integer (&e->rank);
3424 fix_mio_expr (e);
3426 switch (e->expr_type)
3428 case EXPR_OP:
3429 e->value.op.op
3430 = MIO_NAME (gfc_intrinsic_op) (e->value.op.op, intrinsics);
3432 switch (e->value.op.op)
3434 case INTRINSIC_UPLUS:
3435 case INTRINSIC_UMINUS:
3436 case INTRINSIC_NOT:
3437 case INTRINSIC_PARENTHESES:
3438 mio_expr (&e->value.op.op1);
3439 break;
3441 case INTRINSIC_PLUS:
3442 case INTRINSIC_MINUS:
3443 case INTRINSIC_TIMES:
3444 case INTRINSIC_DIVIDE:
3445 case INTRINSIC_POWER:
3446 case INTRINSIC_CONCAT:
3447 case INTRINSIC_AND:
3448 case INTRINSIC_OR:
3449 case INTRINSIC_EQV:
3450 case INTRINSIC_NEQV:
3451 case INTRINSIC_EQ:
3452 case INTRINSIC_EQ_OS:
3453 case INTRINSIC_NE:
3454 case INTRINSIC_NE_OS:
3455 case INTRINSIC_GT:
3456 case INTRINSIC_GT_OS:
3457 case INTRINSIC_GE:
3458 case INTRINSIC_GE_OS:
3459 case INTRINSIC_LT:
3460 case INTRINSIC_LT_OS:
3461 case INTRINSIC_LE:
3462 case INTRINSIC_LE_OS:
3463 mio_expr (&e->value.op.op1);
3464 mio_expr (&e->value.op.op2);
3465 break;
3467 case INTRINSIC_USER:
3468 /* INTRINSIC_USER should not appear in resolved expressions,
3469 though for UDRs we need to stream unresolved ones. */
3470 if (iomode == IO_OUTPUT)
3471 write_atom (ATOM_STRING, e->value.op.uop->name);
3472 else
3474 char *name = read_string ();
3475 const char *uop_name = find_use_name (name, true);
3476 if (uop_name == NULL)
3478 size_t len = strlen (name);
3479 char *name2 = XCNEWVEC (char, len + 2);
3480 memcpy (name2, name, len);
3481 name2[len] = ' ';
3482 name2[len + 1] = '\0';
3483 free (name);
3484 uop_name = name = name2;
3486 e->value.op.uop = gfc_get_uop (uop_name);
3487 free (name);
3489 mio_expr (&e->value.op.op1);
3490 mio_expr (&e->value.op.op2);
3491 break;
3493 default:
3494 bad_module ("Bad operator");
3497 break;
3499 case EXPR_FUNCTION:
3500 mio_symtree_ref (&e->symtree);
3501 mio_actual_arglist (&e->value.function.actual);
3503 if (iomode == IO_OUTPUT)
3505 e->value.function.name
3506 = mio_allocated_string (e->value.function.name);
3507 if (e->value.function.esym)
3508 flag = 1;
3509 else if (e->ref)
3510 flag = 2;
3511 else if (e->value.function.isym == NULL)
3512 flag = 3;
3513 else
3514 flag = 0;
3515 mio_integer (&flag);
3516 switch (flag)
3518 case 1:
3519 mio_symbol_ref (&e->value.function.esym);
3520 break;
3521 case 2:
3522 mio_ref_list (&e->ref);
3523 break;
3524 case 3:
3525 break;
3526 default:
3527 write_atom (ATOM_STRING, e->value.function.isym->name);
3530 else
3532 require_atom (ATOM_STRING);
3533 if (atom_string[0] == '\0')
3534 e->value.function.name = NULL;
3535 else
3536 e->value.function.name = gfc_get_string ("%s", atom_string);
3537 free (atom_string);
3539 mio_integer (&flag);
3540 switch (flag)
3542 case 1:
3543 mio_symbol_ref (&e->value.function.esym);
3544 break;
3545 case 2:
3546 mio_ref_list (&e->ref);
3547 break;
3548 case 3:
3549 break;
3550 default:
3551 require_atom (ATOM_STRING);
3552 e->value.function.isym = gfc_find_function (atom_string);
3553 free (atom_string);
3557 break;
3559 case EXPR_VARIABLE:
3560 mio_symtree_ref (&e->symtree);
3561 mio_ref_list (&e->ref);
3562 break;
3564 case EXPR_SUBSTRING:
3565 e->value.character.string
3566 = CONST_CAST (gfc_char_t *,
3567 mio_allocated_wide_string (e->value.character.string,
3568 e->value.character.length));
3569 mio_ref_list (&e->ref);
3570 break;
3572 case EXPR_STRUCTURE:
3573 case EXPR_ARRAY:
3574 mio_constructor (&e->value.constructor);
3575 mio_shape (&e->shape, e->rank);
3576 break;
3578 case EXPR_CONSTANT:
3579 switch (e->ts.type)
3581 case BT_INTEGER:
3582 mio_gmp_integer (&e->value.integer);
3583 break;
3585 case BT_REAL:
3586 gfc_set_model_kind (e->ts.kind);
3587 mio_gmp_real (&e->value.real);
3588 break;
3590 case BT_COMPLEX:
3591 gfc_set_model_kind (e->ts.kind);
3592 mio_gmp_real (&mpc_realref (e->value.complex));
3593 mio_gmp_real (&mpc_imagref (e->value.complex));
3594 break;
3596 case BT_LOGICAL:
3597 mio_integer (&e->value.logical);
3598 break;
3600 case BT_CHARACTER:
3601 mio_integer (&e->value.character.length);
3602 e->value.character.string
3603 = CONST_CAST (gfc_char_t *,
3604 mio_allocated_wide_string (e->value.character.string,
3605 e->value.character.length));
3606 break;
3608 default:
3609 bad_module ("Bad type in constant expression");
3612 break;
3614 case EXPR_NULL:
3615 break;
3617 case EXPR_COMPCALL:
3618 case EXPR_PPC:
3619 gcc_unreachable ();
3620 break;
3623 mio_rparen ();
3627 /* Read and write namelists. */
3629 static void
3630 mio_namelist (gfc_symbol *sym)
3632 gfc_namelist *n, *m;
3633 const char *check_name;
3635 mio_lparen ();
3637 if (iomode == IO_OUTPUT)
3639 for (n = sym->namelist; n; n = n->next)
3640 mio_symbol_ref (&n->sym);
3642 else
3644 /* This departure from the standard is flagged as an error.
3645 It does, in fact, work correctly. TODO: Allow it
3646 conditionally? */
3647 if (sym->attr.flavor == FL_NAMELIST)
3649 check_name = find_use_name (sym->name, false);
3650 if (check_name && strcmp (check_name, sym->name) != 0)
3651 gfc_error ("Namelist %s cannot be renamed by USE "
3652 "association to %s", sym->name, check_name);
3655 m = NULL;
3656 while (peek_atom () != ATOM_RPAREN)
3658 n = gfc_get_namelist ();
3659 mio_symbol_ref (&n->sym);
3661 if (sym->namelist == NULL)
3662 sym->namelist = n;
3663 else
3664 m->next = n;
3666 m = n;
3668 sym->namelist_tail = m;
3671 mio_rparen ();
3675 /* Save/restore lists of gfc_interface structures. When loading an
3676 interface, we are really appending to the existing list of
3677 interfaces. Checking for duplicate and ambiguous interfaces has to
3678 be done later when all symbols have been loaded. */
3680 pointer_info *
3681 mio_interface_rest (gfc_interface **ip)
3683 gfc_interface *tail, *p;
3684 pointer_info *pi = NULL;
3686 if (iomode == IO_OUTPUT)
3688 if (ip != NULL)
3689 for (p = *ip; p; p = p->next)
3690 mio_symbol_ref (&p->sym);
3692 else
3694 if (*ip == NULL)
3695 tail = NULL;
3696 else
3698 tail = *ip;
3699 while (tail->next)
3700 tail = tail->next;
3703 for (;;)
3705 if (peek_atom () == ATOM_RPAREN)
3706 break;
3708 p = gfc_get_interface ();
3709 p->where = gfc_current_locus;
3710 pi = mio_symbol_ref (&p->sym);
3712 if (tail == NULL)
3713 *ip = p;
3714 else
3715 tail->next = p;
3717 tail = p;
3721 mio_rparen ();
3722 return pi;
3726 /* Save/restore a nameless operator interface. */
3728 static void
3729 mio_interface (gfc_interface **ip)
3731 mio_lparen ();
3732 mio_interface_rest (ip);
3736 /* Save/restore a named operator interface. */
3738 static void
3739 mio_symbol_interface (const char **name, const char **module,
3740 gfc_interface **ip)
3742 mio_lparen ();
3743 mio_pool_string (name);
3744 mio_pool_string (module);
3745 mio_interface_rest (ip);
3749 static void
3750 mio_namespace_ref (gfc_namespace **nsp)
3752 gfc_namespace *ns;
3753 pointer_info *p;
3755 p = mio_pointer_ref (nsp);
3757 if (p->type == P_UNKNOWN)
3758 p->type = P_NAMESPACE;
3760 if (iomode == IO_INPUT && p->integer != 0)
3762 ns = (gfc_namespace *) p->u.pointer;
3763 if (ns == NULL)
3765 ns = gfc_get_namespace (NULL, 0);
3766 associate_integer_pointer (p, ns);
3768 else
3769 ns->refs++;
3774 /* Save/restore the f2k_derived namespace of a derived-type symbol. */
3776 static gfc_namespace* current_f2k_derived;
3778 static void
3779 mio_typebound_proc (gfc_typebound_proc** proc)
3781 int flag;
3782 int overriding_flag;
3784 if (iomode == IO_INPUT)
3786 *proc = gfc_get_typebound_proc (NULL);
3787 (*proc)->where = gfc_current_locus;
3789 gcc_assert (*proc);
3791 mio_lparen ();
3793 (*proc)->access = MIO_NAME (gfc_access) ((*proc)->access, access_types);
3795 /* IO the NON_OVERRIDABLE/DEFERRED combination. */
3796 gcc_assert (!((*proc)->deferred && (*proc)->non_overridable));
3797 overriding_flag = ((*proc)->deferred << 1) | (*proc)->non_overridable;
3798 overriding_flag = mio_name (overriding_flag, binding_overriding);
3799 (*proc)->deferred = ((overriding_flag & 2) != 0);
3800 (*proc)->non_overridable = ((overriding_flag & 1) != 0);
3801 gcc_assert (!((*proc)->deferred && (*proc)->non_overridable));
3803 (*proc)->nopass = mio_name ((*proc)->nopass, binding_passing);
3804 (*proc)->is_generic = mio_name ((*proc)->is_generic, binding_generic);
3805 (*proc)->ppc = mio_name((*proc)->ppc, binding_ppc);
3807 mio_pool_string (&((*proc)->pass_arg));
3809 flag = (int) (*proc)->pass_arg_num;
3810 mio_integer (&flag);
3811 (*proc)->pass_arg_num = (unsigned) flag;
3813 if ((*proc)->is_generic)
3815 gfc_tbp_generic* g;
3816 int iop;
3818 mio_lparen ();
3820 if (iomode == IO_OUTPUT)
3821 for (g = (*proc)->u.generic; g; g = g->next)
3823 iop = (int) g->is_operator;
3824 mio_integer (&iop);
3825 mio_allocated_string (g->specific_st->name);
3827 else
3829 (*proc)->u.generic = NULL;
3830 while (peek_atom () != ATOM_RPAREN)
3832 gfc_symtree** sym_root;
3834 g = gfc_get_tbp_generic ();
3835 g->specific = NULL;
3837 mio_integer (&iop);
3838 g->is_operator = (bool) iop;
3840 require_atom (ATOM_STRING);
3841 sym_root = &current_f2k_derived->tb_sym_root;
3842 g->specific_st = gfc_get_tbp_symtree (sym_root, atom_string);
3843 free (atom_string);
3845 g->next = (*proc)->u.generic;
3846 (*proc)->u.generic = g;
3850 mio_rparen ();
3852 else if (!(*proc)->ppc)
3853 mio_symtree_ref (&(*proc)->u.specific);
3855 mio_rparen ();
3858 /* Walker-callback function for this purpose. */
3859 static void
3860 mio_typebound_symtree (gfc_symtree* st)
3862 if (iomode == IO_OUTPUT && !st->n.tb)
3863 return;
3865 if (iomode == IO_OUTPUT)
3867 mio_lparen ();
3868 mio_allocated_string (st->name);
3870 /* For IO_INPUT, the above is done in mio_f2k_derived. */
3872 mio_typebound_proc (&st->n.tb);
3873 mio_rparen ();
3876 /* IO a full symtree (in all depth). */
3877 static void
3878 mio_full_typebound_tree (gfc_symtree** root)
3880 mio_lparen ();
3882 if (iomode == IO_OUTPUT)
3883 gfc_traverse_symtree (*root, &mio_typebound_symtree);
3884 else
3886 while (peek_atom () == ATOM_LPAREN)
3888 gfc_symtree* st;
3890 mio_lparen ();
3892 require_atom (ATOM_STRING);
3893 st = gfc_get_tbp_symtree (root, atom_string);
3894 free (atom_string);
3896 mio_typebound_symtree (st);
3900 mio_rparen ();
3903 static void
3904 mio_finalizer (gfc_finalizer **f)
3906 if (iomode == IO_OUTPUT)
3908 gcc_assert (*f);
3909 gcc_assert ((*f)->proc_tree); /* Should already be resolved. */
3910 mio_symtree_ref (&(*f)->proc_tree);
3912 else
3914 *f = gfc_get_finalizer ();
3915 (*f)->where = gfc_current_locus; /* Value should not matter. */
3916 (*f)->next = NULL;
3918 mio_symtree_ref (&(*f)->proc_tree);
3919 (*f)->proc_sym = NULL;
3923 static void
3924 mio_f2k_derived (gfc_namespace *f2k)
3926 current_f2k_derived = f2k;
3928 /* Handle the list of finalizer procedures. */
3929 mio_lparen ();
3930 if (iomode == IO_OUTPUT)
3932 gfc_finalizer *f;
3933 for (f = f2k->finalizers; f; f = f->next)
3934 mio_finalizer (&f);
3936 else
3938 f2k->finalizers = NULL;
3939 while (peek_atom () != ATOM_RPAREN)
3941 gfc_finalizer *cur = NULL;
3942 mio_finalizer (&cur);
3943 cur->next = f2k->finalizers;
3944 f2k->finalizers = cur;
3947 mio_rparen ();
3949 /* Handle type-bound procedures. */
3950 mio_full_typebound_tree (&f2k->tb_sym_root);
3952 /* Type-bound user operators. */
3953 mio_full_typebound_tree (&f2k->tb_uop_root);
3955 /* Type-bound intrinsic operators. */
3956 mio_lparen ();
3957 if (iomode == IO_OUTPUT)
3959 int op;
3960 for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; ++op)
3962 gfc_intrinsic_op realop;
3964 if (op == INTRINSIC_USER || !f2k->tb_op[op])
3965 continue;
3967 mio_lparen ();
3968 realop = (gfc_intrinsic_op) op;
3969 mio_intrinsic_op (&realop);
3970 mio_typebound_proc (&f2k->tb_op[op]);
3971 mio_rparen ();
3974 else
3975 while (peek_atom () != ATOM_RPAREN)
3977 gfc_intrinsic_op op = GFC_INTRINSIC_BEGIN; /* Silence GCC. */
3979 mio_lparen ();
3980 mio_intrinsic_op (&op);
3981 mio_typebound_proc (&f2k->tb_op[op]);
3982 mio_rparen ();
3984 mio_rparen ();
3987 static void
3988 mio_full_f2k_derived (gfc_symbol *sym)
3990 mio_lparen ();
3992 if (iomode == IO_OUTPUT)
3994 if (sym->f2k_derived)
3995 mio_f2k_derived (sym->f2k_derived);
3997 else
3999 if (peek_atom () != ATOM_RPAREN)
4001 sym->f2k_derived = gfc_get_namespace (NULL, 0);
4002 mio_f2k_derived (sym->f2k_derived);
4004 else
4005 gcc_assert (!sym->f2k_derived);
4008 mio_rparen ();
4011 static const mstring omp_declare_simd_clauses[] =
4013 minit ("INBRANCH", 0),
4014 minit ("NOTINBRANCH", 1),
4015 minit ("SIMDLEN", 2),
4016 minit ("UNIFORM", 3),
4017 minit ("LINEAR", 4),
4018 minit ("ALIGNED", 5),
4019 minit (NULL, -1)
4022 /* Handle !$omp declare simd. */
4024 static void
4025 mio_omp_declare_simd (gfc_namespace *ns, gfc_omp_declare_simd **odsp)
4027 if (iomode == IO_OUTPUT)
4029 if (*odsp == NULL)
4030 return;
4032 else if (peek_atom () != ATOM_LPAREN)
4033 return;
4035 gfc_omp_declare_simd *ods = *odsp;
4037 mio_lparen ();
4038 if (iomode == IO_OUTPUT)
4040 write_atom (ATOM_NAME, "OMP_DECLARE_SIMD");
4041 if (ods->clauses)
4043 gfc_omp_namelist *n;
4045 if (ods->clauses->inbranch)
4046 mio_name (0, omp_declare_simd_clauses);
4047 if (ods->clauses->notinbranch)
4048 mio_name (1, omp_declare_simd_clauses);
4049 if (ods->clauses->simdlen_expr)
4051 mio_name (2, omp_declare_simd_clauses);
4052 mio_expr (&ods->clauses->simdlen_expr);
4054 for (n = ods->clauses->lists[OMP_LIST_UNIFORM]; n; n = n->next)
4056 mio_name (3, omp_declare_simd_clauses);
4057 mio_symbol_ref (&n->sym);
4059 for (n = ods->clauses->lists[OMP_LIST_LINEAR]; n; n = n->next)
4061 mio_name (4, omp_declare_simd_clauses);
4062 mio_symbol_ref (&n->sym);
4063 mio_expr (&n->expr);
4065 for (n = ods->clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
4067 mio_name (5, omp_declare_simd_clauses);
4068 mio_symbol_ref (&n->sym);
4069 mio_expr (&n->expr);
4073 else
4075 gfc_omp_namelist **ptrs[3] = { NULL, NULL, NULL };
4077 require_atom (ATOM_NAME);
4078 *odsp = ods = gfc_get_omp_declare_simd ();
4079 ods->where = gfc_current_locus;
4080 ods->proc_name = ns->proc_name;
4081 if (peek_atom () == ATOM_NAME)
4083 ods->clauses = gfc_get_omp_clauses ();
4084 ptrs[0] = &ods->clauses->lists[OMP_LIST_UNIFORM];
4085 ptrs[1] = &ods->clauses->lists[OMP_LIST_LINEAR];
4086 ptrs[2] = &ods->clauses->lists[OMP_LIST_ALIGNED];
4088 while (peek_atom () == ATOM_NAME)
4090 gfc_omp_namelist *n;
4091 int t = mio_name (0, omp_declare_simd_clauses);
4093 switch (t)
4095 case 0: ods->clauses->inbranch = true; break;
4096 case 1: ods->clauses->notinbranch = true; break;
4097 case 2: mio_expr (&ods->clauses->simdlen_expr); break;
4098 case 3:
4099 case 4:
4100 case 5:
4101 *ptrs[t - 3] = n = gfc_get_omp_namelist ();
4102 ptrs[t - 3] = &n->next;
4103 mio_symbol_ref (&n->sym);
4104 if (t != 3)
4105 mio_expr (&n->expr);
4106 break;
4111 mio_omp_declare_simd (ns, &ods->next);
4113 mio_rparen ();
4117 static const mstring omp_declare_reduction_stmt[] =
4119 minit ("ASSIGN", 0),
4120 minit ("CALL", 1),
4121 minit (NULL, -1)
4125 static void
4126 mio_omp_udr_expr (gfc_omp_udr *udr, gfc_symbol **sym1, gfc_symbol **sym2,
4127 gfc_namespace *ns, bool is_initializer)
4129 if (iomode == IO_OUTPUT)
4131 if ((*sym1)->module == NULL)
4133 (*sym1)->module = module_name;
4134 (*sym2)->module = module_name;
4136 mio_symbol_ref (sym1);
4137 mio_symbol_ref (sym2);
4138 if (ns->code->op == EXEC_ASSIGN)
4140 mio_name (0, omp_declare_reduction_stmt);
4141 mio_expr (&ns->code->expr1);
4142 mio_expr (&ns->code->expr2);
4144 else
4146 int flag;
4147 mio_name (1, omp_declare_reduction_stmt);
4148 mio_symtree_ref (&ns->code->symtree);
4149 mio_actual_arglist (&ns->code->ext.actual);
4151 flag = ns->code->resolved_isym != NULL;
4152 mio_integer (&flag);
4153 if (flag)
4154 write_atom (ATOM_STRING, ns->code->resolved_isym->name);
4155 else
4156 mio_symbol_ref (&ns->code->resolved_sym);
4159 else
4161 pointer_info *p1 = mio_symbol_ref (sym1);
4162 pointer_info *p2 = mio_symbol_ref (sym2);
4163 gfc_symbol *sym;
4164 gcc_assert (p1->u.rsym.ns == p2->u.rsym.ns);
4165 gcc_assert (p1->u.rsym.sym == NULL);
4166 /* Add hidden symbols to the symtree. */
4167 pointer_info *q = get_integer (p1->u.rsym.ns);
4168 q->u.pointer = (void *) ns;
4169 sym = gfc_new_symbol (is_initializer ? "omp_priv" : "omp_out", ns);
4170 sym->ts = udr->ts;
4171 sym->module = gfc_get_string ("%s", p1->u.rsym.module);
4172 associate_integer_pointer (p1, sym);
4173 sym->attr.omp_udr_artificial_var = 1;
4174 gcc_assert (p2->u.rsym.sym == NULL);
4175 sym = gfc_new_symbol (is_initializer ? "omp_orig" : "omp_in", ns);
4176 sym->ts = udr->ts;
4177 sym->module = gfc_get_string ("%s", p2->u.rsym.module);
4178 associate_integer_pointer (p2, sym);
4179 sym->attr.omp_udr_artificial_var = 1;
4180 if (mio_name (0, omp_declare_reduction_stmt) == 0)
4182 ns->code = gfc_get_code (EXEC_ASSIGN);
4183 mio_expr (&ns->code->expr1);
4184 mio_expr (&ns->code->expr2);
4186 else
4188 int flag;
4189 ns->code = gfc_get_code (EXEC_CALL);
4190 mio_symtree_ref (&ns->code->symtree);
4191 mio_actual_arglist (&ns->code->ext.actual);
4193 mio_integer (&flag);
4194 if (flag)
4196 require_atom (ATOM_STRING);
4197 ns->code->resolved_isym = gfc_find_subroutine (atom_string);
4198 free (atom_string);
4200 else
4201 mio_symbol_ref (&ns->code->resolved_sym);
4203 ns->code->loc = gfc_current_locus;
4204 ns->omp_udr_ns = 1;
4209 /* Unlike most other routines, the address of the symbol node is already
4210 fixed on input and the name/module has already been filled in.
4211 If you update the symbol format here, don't forget to update read_module
4212 as well (look for "seek to the symbol's component list"). */
4214 static void
4215 mio_symbol (gfc_symbol *sym)
4217 int intmod = INTMOD_NONE;
4219 mio_lparen ();
4221 mio_symbol_attribute (&sym->attr);
4223 /* Note that components are always saved, even if they are supposed
4224 to be private. Component access is checked during searching. */
4225 mio_component_list (&sym->components, sym->attr.vtype);
4226 if (sym->components != NULL)
4227 sym->component_access
4228 = MIO_NAME (gfc_access) (sym->component_access, access_types);
4230 mio_typespec (&sym->ts);
4231 if (sym->ts.type == BT_CLASS)
4232 sym->attr.class_ok = 1;
4234 if (iomode == IO_OUTPUT)
4235 mio_namespace_ref (&sym->formal_ns);
4236 else
4238 mio_namespace_ref (&sym->formal_ns);
4239 if (sym->formal_ns)
4240 sym->formal_ns->proc_name = sym;
4243 /* Save/restore common block links. */
4244 mio_symbol_ref (&sym->common_next);
4246 mio_formal_arglist (&sym->formal);
4248 if (sym->attr.flavor == FL_PARAMETER)
4249 mio_expr (&sym->value);
4251 mio_array_spec (&sym->as);
4253 mio_symbol_ref (&sym->result);
4255 if (sym->attr.cray_pointee)
4256 mio_symbol_ref (&sym->cp_pointer);
4258 /* Load/save the f2k_derived namespace of a derived-type symbol. */
4259 mio_full_f2k_derived (sym);
4261 mio_namelist (sym);
4263 /* Add the fields that say whether this is from an intrinsic module,
4264 and if so, what symbol it is within the module. */
4265 /* mio_integer (&(sym->from_intmod)); */
4266 if (iomode == IO_OUTPUT)
4268 intmod = sym->from_intmod;
4269 mio_integer (&intmod);
4271 else
4273 mio_integer (&intmod);
4274 if (current_intmod)
4275 sym->from_intmod = current_intmod;
4276 else
4277 sym->from_intmod = (intmod_id) intmod;
4280 mio_integer (&(sym->intmod_sym_id));
4282 if (gfc_fl_struct (sym->attr.flavor))
4283 mio_integer (&(sym->hash_value));
4285 if (sym->formal_ns
4286 && sym->formal_ns->proc_name == sym
4287 && sym->formal_ns->entries == NULL)
4288 mio_omp_declare_simd (sym->formal_ns, &sym->formal_ns->omp_declare_simd);
4290 mio_rparen ();
4294 /************************* Top level subroutines *************************/
4296 /* A recursive function to look for a specific symbol by name and by
4297 module. Whilst several symtrees might point to one symbol, its
4298 is sufficient for the purposes here than one exist. Note that
4299 generic interfaces are distinguished as are symbols that have been
4300 renamed in another module. */
4301 static gfc_symtree *
4302 find_symbol (gfc_symtree *st, const char *name,
4303 const char *module, int generic)
4305 int c;
4306 gfc_symtree *retval, *s;
4308 if (st == NULL || st->n.sym == NULL)
4309 return NULL;
4311 c = strcmp (name, st->n.sym->name);
4312 if (c == 0 && st->n.sym->module
4313 && strcmp (module, st->n.sym->module) == 0
4314 && !check_unique_name (st->name))
4316 s = gfc_find_symtree (gfc_current_ns->sym_root, name);
4318 /* Detect symbols that are renamed by use association in another
4319 module by the absence of a symtree and null attr.use_rename,
4320 since the latter is not transmitted in the module file. */
4321 if (((!generic && !st->n.sym->attr.generic)
4322 || (generic && st->n.sym->attr.generic))
4323 && !(s == NULL && !st->n.sym->attr.use_rename))
4324 return st;
4327 retval = find_symbol (st->left, name, module, generic);
4329 if (retval == NULL)
4330 retval = find_symbol (st->right, name, module, generic);
4332 return retval;
4336 /* Skip a list between balanced left and right parens.
4337 By setting NEST_LEVEL one assumes that a number of NEST_LEVEL opening parens
4338 have been already parsed by hand, and the remaining of the content is to be
4339 skipped here. The default value is 0 (balanced parens). */
4341 static void
4342 skip_list (int nest_level = 0)
4344 int level;
4346 level = nest_level;
4349 switch (parse_atom ())
4351 case ATOM_LPAREN:
4352 level++;
4353 break;
4355 case ATOM_RPAREN:
4356 level--;
4357 break;
4359 case ATOM_STRING:
4360 free (atom_string);
4361 break;
4363 case ATOM_NAME:
4364 case ATOM_INTEGER:
4365 break;
4368 while (level > 0);
4372 /* Load operator interfaces from the module. Interfaces are unusual
4373 in that they attach themselves to existing symbols. */
4375 static void
4376 load_operator_interfaces (void)
4378 const char *p;
4379 char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
4380 gfc_user_op *uop;
4381 pointer_info *pi = NULL;
4382 int n, i;
4384 mio_lparen ();
4386 while (peek_atom () != ATOM_RPAREN)
4388 mio_lparen ();
4390 mio_internal_string (name);
4391 mio_internal_string (module);
4393 n = number_use_names (name, true);
4394 n = n ? n : 1;
4396 for (i = 1; i <= n; i++)
4398 /* Decide if we need to load this one or not. */
4399 p = find_use_name_n (name, &i, true);
4401 if (p == NULL)
4403 while (parse_atom () != ATOM_RPAREN);
4404 continue;
4407 if (i == 1)
4409 uop = gfc_get_uop (p);
4410 pi = mio_interface_rest (&uop->op);
4412 else
4414 if (gfc_find_uop (p, NULL))
4415 continue;
4416 uop = gfc_get_uop (p);
4417 uop->op = gfc_get_interface ();
4418 uop->op->where = gfc_current_locus;
4419 add_fixup (pi->integer, &uop->op->sym);
4424 mio_rparen ();
4428 /* Load interfaces from the module. Interfaces are unusual in that
4429 they attach themselves to existing symbols. */
4431 static void
4432 load_generic_interfaces (void)
4434 const char *p;
4435 char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
4436 gfc_symbol *sym;
4437 gfc_interface *generic = NULL, *gen = NULL;
4438 int n, i, renamed;
4439 bool ambiguous_set = false;
4441 mio_lparen ();
4443 while (peek_atom () != ATOM_RPAREN)
4445 mio_lparen ();
4447 mio_internal_string (name);
4448 mio_internal_string (module);
4450 n = number_use_names (name, false);
4451 renamed = n ? 1 : 0;
4452 n = n ? n : 1;
4454 for (i = 1; i <= n; i++)
4456 gfc_symtree *st;
4457 /* Decide if we need to load this one or not. */
4458 p = find_use_name_n (name, &i, false);
4460 st = find_symbol (gfc_current_ns->sym_root,
4461 name, module_name, 1);
4463 if (!p || gfc_find_symbol (p, NULL, 0, &sym))
4465 /* Skip the specific names for these cases. */
4466 while (i == 1 && parse_atom () != ATOM_RPAREN);
4468 continue;
4471 /* If the symbol exists already and is being USEd without being
4472 in an ONLY clause, do not load a new symtree(11.3.2). */
4473 if (!only_flag && st)
4474 sym = st->n.sym;
4476 if (!sym)
4478 if (st)
4480 sym = st->n.sym;
4481 if (strcmp (st->name, p) != 0)
4483 st = gfc_new_symtree (&gfc_current_ns->sym_root, p);
4484 st->n.sym = sym;
4485 sym->refs++;
4489 /* Since we haven't found a valid generic interface, we had
4490 better make one. */
4491 if (!sym)
4493 gfc_get_symbol (p, NULL, &sym);
4494 sym->name = gfc_get_string ("%s", name);
4495 sym->module = module_name;
4496 sym->attr.flavor = FL_PROCEDURE;
4497 sym->attr.generic = 1;
4498 sym->attr.use_assoc = 1;
4501 else
4503 /* Unless sym is a generic interface, this reference
4504 is ambiguous. */
4505 if (st == NULL)
4506 st = gfc_find_symtree (gfc_current_ns->sym_root, p);
4508 sym = st->n.sym;
4510 if (st && !sym->attr.generic
4511 && !st->ambiguous
4512 && sym->module
4513 && strcmp (module, sym->module))
4515 ambiguous_set = true;
4516 st->ambiguous = 1;
4520 sym->attr.use_only = only_flag;
4521 sym->attr.use_rename = renamed;
4523 if (i == 1)
4525 mio_interface_rest (&sym->generic);
4526 generic = sym->generic;
4528 else if (!sym->generic)
4530 sym->generic = generic;
4531 sym->attr.generic_copy = 1;
4534 /* If a procedure that is not generic has generic interfaces
4535 that include itself, it is generic! We need to take care
4536 to retain symbols ambiguous that were already so. */
4537 if (sym->attr.use_assoc
4538 && !sym->attr.generic
4539 && sym->attr.flavor == FL_PROCEDURE)
4541 for (gen = generic; gen; gen = gen->next)
4543 if (gen->sym == sym)
4545 sym->attr.generic = 1;
4546 if (ambiguous_set)
4547 st->ambiguous = 0;
4548 break;
4556 mio_rparen ();
4560 /* Load common blocks. */
4562 static void
4563 load_commons (void)
4565 char name[GFC_MAX_SYMBOL_LEN + 1];
4566 gfc_common_head *p;
4568 mio_lparen ();
4570 while (peek_atom () != ATOM_RPAREN)
4572 int flags;
4573 char* label;
4574 mio_lparen ();
4575 mio_internal_string (name);
4577 p = gfc_get_common (name, 1);
4579 mio_symbol_ref (&p->head);
4580 mio_integer (&flags);
4581 if (flags & 1)
4582 p->saved = 1;
4583 if (flags & 2)
4584 p->threadprivate = 1;
4585 p->use_assoc = 1;
4587 /* Get whether this was a bind(c) common or not. */
4588 mio_integer (&p->is_bind_c);
4589 /* Get the binding label. */
4590 label = read_string ();
4591 if (strlen (label))
4592 p->binding_label = IDENTIFIER_POINTER (get_identifier (label));
4593 XDELETEVEC (label);
4595 mio_rparen ();
4598 mio_rparen ();
4602 /* Load equivalences. The flag in_load_equiv informs mio_expr_ref of this
4603 so that unused variables are not loaded and so that the expression can
4604 be safely freed. */
4606 static void
4607 load_equiv (void)
4609 gfc_equiv *head, *tail, *end, *eq, *equiv;
4610 bool duplicate;
4612 mio_lparen ();
4613 in_load_equiv = true;
4615 end = gfc_current_ns->equiv;
4616 while (end != NULL && end->next != NULL)
4617 end = end->next;
4619 while (peek_atom () != ATOM_RPAREN) {
4620 mio_lparen ();
4621 head = tail = NULL;
4623 while(peek_atom () != ATOM_RPAREN)
4625 if (head == NULL)
4626 head = tail = gfc_get_equiv ();
4627 else
4629 tail->eq = gfc_get_equiv ();
4630 tail = tail->eq;
4633 mio_pool_string (&tail->module);
4634 mio_expr (&tail->expr);
4637 /* Check for duplicate equivalences being loaded from different modules */
4638 duplicate = false;
4639 for (equiv = gfc_current_ns->equiv; equiv; equiv = equiv->next)
4641 if (equiv->module && head->module
4642 && strcmp (equiv->module, head->module) == 0)
4644 duplicate = true;
4645 break;
4649 if (duplicate)
4651 for (eq = head; eq; eq = head)
4653 head = eq->eq;
4654 gfc_free_expr (eq->expr);
4655 free (eq);
4659 if (end == NULL)
4660 gfc_current_ns->equiv = head;
4661 else
4662 end->next = head;
4664 if (head != NULL)
4665 end = head;
4667 mio_rparen ();
4670 mio_rparen ();
4671 in_load_equiv = false;
4675 /* This function loads OpenMP user defined reductions. */
4676 static void
4677 load_omp_udrs (void)
4679 mio_lparen ();
4680 while (peek_atom () != ATOM_RPAREN)
4682 const char *name = NULL, *newname;
4683 char *altname;
4684 gfc_typespec ts;
4685 gfc_symtree *st;
4686 gfc_omp_reduction_op rop = OMP_REDUCTION_USER;
4688 mio_lparen ();
4689 mio_pool_string (&name);
4690 gfc_clear_ts (&ts);
4691 mio_typespec (&ts);
4692 if (strncmp (name, "operator ", sizeof ("operator ") - 1) == 0)
4694 const char *p = name + sizeof ("operator ") - 1;
4695 if (strcmp (p, "+") == 0)
4696 rop = OMP_REDUCTION_PLUS;
4697 else if (strcmp (p, "*") == 0)
4698 rop = OMP_REDUCTION_TIMES;
4699 else if (strcmp (p, "-") == 0)
4700 rop = OMP_REDUCTION_MINUS;
4701 else if (strcmp (p, ".and.") == 0)
4702 rop = OMP_REDUCTION_AND;
4703 else if (strcmp (p, ".or.") == 0)
4704 rop = OMP_REDUCTION_OR;
4705 else if (strcmp (p, ".eqv.") == 0)
4706 rop = OMP_REDUCTION_EQV;
4707 else if (strcmp (p, ".neqv.") == 0)
4708 rop = OMP_REDUCTION_NEQV;
4710 altname = NULL;
4711 if (rop == OMP_REDUCTION_USER && name[0] == '.')
4713 size_t len = strlen (name + 1);
4714 altname = XALLOCAVEC (char, len);
4715 gcc_assert (name[len] == '.');
4716 memcpy (altname, name + 1, len - 1);
4717 altname[len - 1] = '\0';
4719 newname = name;
4720 if (rop == OMP_REDUCTION_USER)
4721 newname = find_use_name (altname ? altname : name, !!altname);
4722 else if (only_flag && find_use_operator ((gfc_intrinsic_op) rop) == NULL)
4723 newname = NULL;
4724 if (newname == NULL)
4726 skip_list (1);
4727 continue;
4729 if (altname && newname != altname)
4731 size_t len = strlen (newname);
4732 altname = XALLOCAVEC (char, len + 3);
4733 altname[0] = '.';
4734 memcpy (altname + 1, newname, len);
4735 altname[len + 1] = '.';
4736 altname[len + 2] = '\0';
4737 name = gfc_get_string ("%s", altname);
4739 st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name);
4740 gfc_omp_udr *udr = gfc_omp_udr_find (st, &ts);
4741 if (udr)
4743 require_atom (ATOM_INTEGER);
4744 pointer_info *p = get_integer (atom_int);
4745 if (strcmp (p->u.rsym.module, udr->omp_out->module))
4747 gfc_error ("Ambiguous !$OMP DECLARE REDUCTION from "
4748 "module %s at %L",
4749 p->u.rsym.module, &gfc_current_locus);
4750 gfc_error ("Previous !$OMP DECLARE REDUCTION from module "
4751 "%s at %L",
4752 udr->omp_out->module, &udr->where);
4754 skip_list (1);
4755 continue;
4757 udr = gfc_get_omp_udr ();
4758 udr->name = name;
4759 udr->rop = rop;
4760 udr->ts = ts;
4761 udr->where = gfc_current_locus;
4762 udr->combiner_ns = gfc_get_namespace (gfc_current_ns, 1);
4763 udr->combiner_ns->proc_name = gfc_current_ns->proc_name;
4764 mio_omp_udr_expr (udr, &udr->omp_out, &udr->omp_in, udr->combiner_ns,
4765 false);
4766 if (peek_atom () != ATOM_RPAREN)
4768 udr->initializer_ns = gfc_get_namespace (gfc_current_ns, 1);
4769 udr->initializer_ns->proc_name = gfc_current_ns->proc_name;
4770 mio_omp_udr_expr (udr, &udr->omp_priv, &udr->omp_orig,
4771 udr->initializer_ns, true);
4773 if (st)
4775 udr->next = st->n.omp_udr;
4776 st->n.omp_udr = udr;
4778 else
4780 st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name);
4781 st->n.omp_udr = udr;
4783 mio_rparen ();
4785 mio_rparen ();
4789 /* Recursive function to traverse the pointer_info tree and load a
4790 needed symbol. We return nonzero if we load a symbol and stop the
4791 traversal, because the act of loading can alter the tree. */
4793 static int
4794 load_needed (pointer_info *p)
4796 gfc_namespace *ns;
4797 pointer_info *q;
4798 gfc_symbol *sym;
4799 int rv;
4801 rv = 0;
4802 if (p == NULL)
4803 return rv;
4805 rv |= load_needed (p->left);
4806 rv |= load_needed (p->right);
4808 if (p->type != P_SYMBOL || p->u.rsym.state != NEEDED)
4809 return rv;
4811 p->u.rsym.state = USED;
4813 set_module_locus (&p->u.rsym.where);
4815 sym = p->u.rsym.sym;
4816 if (sym == NULL)
4818 q = get_integer (p->u.rsym.ns);
4820 ns = (gfc_namespace *) q->u.pointer;
4821 if (ns == NULL)
4823 /* Create an interface namespace if necessary. These are
4824 the namespaces that hold the formal parameters of module
4825 procedures. */
4827 ns = gfc_get_namespace (NULL, 0);
4828 associate_integer_pointer (q, ns);
4831 /* Use the module sym as 'proc_name' so that gfc_get_symbol_decl
4832 doesn't go pear-shaped if the symbol is used. */
4833 if (!ns->proc_name)
4834 gfc_find_symbol (p->u.rsym.module, gfc_current_ns,
4835 1, &ns->proc_name);
4837 sym = gfc_new_symbol (p->u.rsym.true_name, ns);
4838 sym->name = gfc_dt_lower_string (p->u.rsym.true_name);
4839 sym->module = gfc_get_string ("%s", p->u.rsym.module);
4840 if (p->u.rsym.binding_label)
4841 sym->binding_label = IDENTIFIER_POINTER (get_identifier
4842 (p->u.rsym.binding_label));
4844 associate_integer_pointer (p, sym);
4847 mio_symbol (sym);
4848 sym->attr.use_assoc = 1;
4850 /* Unliked derived types, a STRUCTURE may share names with other symbols.
4851 We greedily converted the the symbol name to lowercase before we knew its
4852 type, so now we must fix it. */
4853 if (sym->attr.flavor == FL_STRUCT)
4854 sym->name = gfc_dt_upper_string (sym->name);
4856 /* Mark as only or rename for later diagnosis for explicitly imported
4857 but not used warnings; don't mark internal symbols such as __vtab,
4858 __def_init etc. Only mark them if they have been explicitly loaded. */
4860 if (only_flag && sym->name[0] != '_' && sym->name[1] != '_')
4862 gfc_use_rename *u;
4864 /* Search the use/rename list for the variable; if the variable is
4865 found, mark it. */
4866 for (u = gfc_rename_list; u; u = u->next)
4868 if (strcmp (u->use_name, sym->name) == 0)
4870 sym->attr.use_only = 1;
4871 break;
4876 if (p->u.rsym.renamed)
4877 sym->attr.use_rename = 1;
4879 return 1;
4883 /* Recursive function for cleaning up things after a module has been read. */
4885 static void
4886 read_cleanup (pointer_info *p)
4888 gfc_symtree *st;
4889 pointer_info *q;
4891 if (p == NULL)
4892 return;
4894 read_cleanup (p->left);
4895 read_cleanup (p->right);
4897 if (p->type == P_SYMBOL && p->u.rsym.state == USED && !p->u.rsym.referenced)
4899 gfc_namespace *ns;
4900 /* Add hidden symbols to the symtree. */
4901 q = get_integer (p->u.rsym.ns);
4902 ns = (gfc_namespace *) q->u.pointer;
4904 if (!p->u.rsym.sym->attr.vtype
4905 && !p->u.rsym.sym->attr.vtab)
4906 st = gfc_get_unique_symtree (ns);
4907 else
4909 /* There is no reason to use 'unique_symtrees' for vtabs or
4910 vtypes - their name is fine for a symtree and reduces the
4911 namespace pollution. */
4912 st = gfc_find_symtree (ns->sym_root, p->u.rsym.sym->name);
4913 if (!st)
4914 st = gfc_new_symtree (&ns->sym_root, p->u.rsym.sym->name);
4917 st->n.sym = p->u.rsym.sym;
4918 st->n.sym->refs++;
4920 /* Fixup any symtree references. */
4921 p->u.rsym.symtree = st;
4922 resolve_fixups (p->u.rsym.stfixup, st);
4923 p->u.rsym.stfixup = NULL;
4926 /* Free unused symbols. */
4927 if (p->type == P_SYMBOL && p->u.rsym.state == UNUSED)
4928 gfc_free_symbol (p->u.rsym.sym);
4932 /* It is not quite enough to check for ambiguity in the symbols by
4933 the loaded symbol and the new symbol not being identical. */
4934 static bool
4935 check_for_ambiguous (gfc_symtree *st, pointer_info *info)
4937 gfc_symbol *rsym;
4938 module_locus locus;
4939 symbol_attribute attr;
4940 gfc_symbol *st_sym;
4942 if (gfc_current_ns->proc_name && st->name == gfc_current_ns->proc_name->name)
4944 gfc_error ("%qs of module %qs, imported at %C, is also the name of the "
4945 "current program unit", st->name, module_name);
4946 return true;
4949 st_sym = st->n.sym;
4950 rsym = info->u.rsym.sym;
4951 if (st_sym == rsym)
4952 return false;
4954 if (st_sym->attr.vtab || st_sym->attr.vtype)
4955 return false;
4957 /* If the existing symbol is generic from a different module and
4958 the new symbol is generic there can be no ambiguity. */
4959 if (st_sym->attr.generic
4960 && st_sym->module
4961 && st_sym->module != module_name)
4963 /* The new symbol's attributes have not yet been read. Since
4964 we need attr.generic, read it directly. */
4965 get_module_locus (&locus);
4966 set_module_locus (&info->u.rsym.where);
4967 mio_lparen ();
4968 attr.generic = 0;
4969 mio_symbol_attribute (&attr);
4970 set_module_locus (&locus);
4971 if (attr.generic)
4972 return false;
4975 return true;
4979 /* Read a module file. */
4981 static void
4982 read_module (void)
4984 module_locus operator_interfaces, user_operators, omp_udrs;
4985 const char *p;
4986 char name[GFC_MAX_SYMBOL_LEN + 1];
4987 int i;
4988 /* Workaround -Wmaybe-uninitialized false positive during
4989 profiledbootstrap by initializing them. */
4990 int ambiguous = 0, j, nuse, symbol = 0;
4991 pointer_info *info, *q;
4992 gfc_use_rename *u = NULL;
4993 gfc_symtree *st;
4994 gfc_symbol *sym;
4996 get_module_locus (&operator_interfaces); /* Skip these for now. */
4997 skip_list ();
4999 get_module_locus (&user_operators);
5000 skip_list ();
5001 skip_list ();
5003 /* Skip commons and equivalences for now. */
5004 skip_list ();
5005 skip_list ();
5007 /* Skip OpenMP UDRs. */
5008 get_module_locus (&omp_udrs);
5009 skip_list ();
5011 mio_lparen ();
5013 /* Create the fixup nodes for all the symbols. */
5015 while (peek_atom () != ATOM_RPAREN)
5017 char* bind_label;
5018 require_atom (ATOM_INTEGER);
5019 info = get_integer (atom_int);
5021 info->type = P_SYMBOL;
5022 info->u.rsym.state = UNUSED;
5024 info->u.rsym.true_name = read_string ();
5025 info->u.rsym.module = read_string ();
5026 bind_label = read_string ();
5027 if (strlen (bind_label))
5028 info->u.rsym.binding_label = bind_label;
5029 else
5030 XDELETEVEC (bind_label);
5032 require_atom (ATOM_INTEGER);
5033 info->u.rsym.ns = atom_int;
5035 get_module_locus (&info->u.rsym.where);
5037 /* See if the symbol has already been loaded by a previous module.
5038 If so, we reference the existing symbol and prevent it from
5039 being loaded again. This should not happen if the symbol being
5040 read is an index for an assumed shape dummy array (ns != 1). */
5042 sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module);
5044 if (sym == NULL
5045 || (sym->attr.flavor == FL_VARIABLE && info->u.rsym.ns !=1))
5047 skip_list ();
5048 continue;
5051 info->u.rsym.state = USED;
5052 info->u.rsym.sym = sym;
5053 /* The current symbol has already been loaded, so we can avoid loading
5054 it again. However, if it is a derived type, some of its components
5055 can be used in expressions in the module. To avoid the module loading
5056 failing, we need to associate the module's component pointer indexes
5057 with the existing symbol's component pointers. */
5058 if (gfc_fl_struct (sym->attr.flavor))
5060 gfc_component *c;
5062 /* First seek to the symbol's component list. */
5063 mio_lparen (); /* symbol opening. */
5064 skip_list (); /* skip symbol attribute. */
5066 mio_lparen (); /* component list opening. */
5067 for (c = sym->components; c; c = c->next)
5069 pointer_info *p;
5070 const char *comp_name;
5071 int n;
5073 mio_lparen (); /* component opening. */
5074 mio_integer (&n);
5075 p = get_integer (n);
5076 if (p->u.pointer == NULL)
5077 associate_integer_pointer (p, c);
5078 mio_pool_string (&comp_name);
5079 gcc_assert (comp_name == c->name);
5080 skip_list (1); /* component end. */
5082 mio_rparen (); /* component list closing. */
5084 skip_list (1); /* symbol end. */
5086 else
5087 skip_list ();
5089 /* Some symbols do not have a namespace (eg. formal arguments),
5090 so the automatic "unique symtree" mechanism must be suppressed
5091 by marking them as referenced. */
5092 q = get_integer (info->u.rsym.ns);
5093 if (q->u.pointer == NULL)
5095 info->u.rsym.referenced = 1;
5096 continue;
5100 mio_rparen ();
5102 /* Parse the symtree lists. This lets us mark which symbols need to
5103 be loaded. Renaming is also done at this point by replacing the
5104 symtree name. */
5106 mio_lparen ();
5108 while (peek_atom () != ATOM_RPAREN)
5110 mio_internal_string (name);
5111 mio_integer (&ambiguous);
5112 mio_integer (&symbol);
5114 info = get_integer (symbol);
5116 /* See how many use names there are. If none, go through the start
5117 of the loop at least once. */
5118 nuse = number_use_names (name, false);
5119 info->u.rsym.renamed = nuse ? 1 : 0;
5121 if (nuse == 0)
5122 nuse = 1;
5124 for (j = 1; j <= nuse; j++)
5126 /* Get the jth local name for this symbol. */
5127 p = find_use_name_n (name, &j, false);
5129 if (p == NULL && strcmp (name, module_name) == 0)
5130 p = name;
5132 /* Exception: Always import vtabs & vtypes. */
5133 if (p == NULL && name[0] == '_'
5134 && (strncmp (name, "__vtab_", 5) == 0
5135 || strncmp (name, "__vtype_", 6) == 0))
5136 p = name;
5138 /* Skip symtree nodes not in an ONLY clause, unless there
5139 is an existing symtree loaded from another USE statement. */
5140 if (p == NULL)
5142 st = gfc_find_symtree (gfc_current_ns->sym_root, name);
5143 if (st != NULL
5144 && strcmp (st->n.sym->name, info->u.rsym.true_name) == 0
5145 && st->n.sym->module != NULL
5146 && strcmp (st->n.sym->module, info->u.rsym.module) == 0)
5148 info->u.rsym.symtree = st;
5149 info->u.rsym.sym = st->n.sym;
5151 continue;
5154 /* If a symbol of the same name and module exists already,
5155 this symbol, which is not in an ONLY clause, must not be
5156 added to the namespace(11.3.2). Note that find_symbol
5157 only returns the first occurrence that it finds. */
5158 if (!only_flag && !info->u.rsym.renamed
5159 && strcmp (name, module_name) != 0
5160 && find_symbol (gfc_current_ns->sym_root, name,
5161 module_name, 0))
5162 continue;
5164 st = gfc_find_symtree (gfc_current_ns->sym_root, p);
5166 if (st != NULL
5167 && !(st->n.sym && st->n.sym->attr.used_in_submodule))
5169 /* Check for ambiguous symbols. */
5170 if (check_for_ambiguous (st, info))
5171 st->ambiguous = 1;
5172 else
5173 info->u.rsym.symtree = st;
5175 else
5177 if (st)
5179 /* This symbol is host associated from a module in a
5180 submodule. Hide it with a unique symtree. */
5181 gfc_symtree *s = gfc_get_unique_symtree (gfc_current_ns);
5182 s->n.sym = st->n.sym;
5183 st->n.sym = NULL;
5185 else
5187 /* Create a symtree node in the current namespace for this
5188 symbol. */
5189 st = check_unique_name (p)
5190 ? gfc_get_unique_symtree (gfc_current_ns)
5191 : gfc_new_symtree (&gfc_current_ns->sym_root, p);
5192 st->ambiguous = ambiguous;
5195 sym = info->u.rsym.sym;
5197 /* Create a symbol node if it doesn't already exist. */
5198 if (sym == NULL)
5200 info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name,
5201 gfc_current_ns);
5202 info->u.rsym.sym->name = gfc_dt_lower_string (info->u.rsym.true_name);
5203 sym = info->u.rsym.sym;
5204 sym->module = gfc_get_string ("%s", info->u.rsym.module);
5206 if (info->u.rsym.binding_label)
5208 tree id = get_identifier (info->u.rsym.binding_label);
5209 sym->binding_label = IDENTIFIER_POINTER (id);
5213 st->n.sym = sym;
5214 st->n.sym->refs++;
5216 if (strcmp (name, p) != 0)
5217 sym->attr.use_rename = 1;
5219 if (name[0] != '_'
5220 || (strncmp (name, "__vtab_", 5) != 0
5221 && strncmp (name, "__vtype_", 6) != 0))
5222 sym->attr.use_only = only_flag;
5224 /* Store the symtree pointing to this symbol. */
5225 info->u.rsym.symtree = st;
5227 if (info->u.rsym.state == UNUSED)
5228 info->u.rsym.state = NEEDED;
5229 info->u.rsym.referenced = 1;
5234 mio_rparen ();
5236 /* Load intrinsic operator interfaces. */
5237 set_module_locus (&operator_interfaces);
5238 mio_lparen ();
5240 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
5242 if (i == INTRINSIC_USER)
5243 continue;
5245 if (only_flag)
5247 u = find_use_operator ((gfc_intrinsic_op) i);
5249 if (u == NULL)
5251 skip_list ();
5252 continue;
5255 u->found = 1;
5258 mio_interface (&gfc_current_ns->op[i]);
5259 if (u && !gfc_current_ns->op[i])
5260 u->found = 0;
5263 mio_rparen ();
5265 /* Load generic and user operator interfaces. These must follow the
5266 loading of symtree because otherwise symbols can be marked as
5267 ambiguous. */
5269 set_module_locus (&user_operators);
5271 load_operator_interfaces ();
5272 load_generic_interfaces ();
5274 load_commons ();
5275 load_equiv ();
5277 /* Load OpenMP user defined reductions. */
5278 set_module_locus (&omp_udrs);
5279 load_omp_udrs ();
5281 /* At this point, we read those symbols that are needed but haven't
5282 been loaded yet. If one symbol requires another, the other gets
5283 marked as NEEDED if its previous state was UNUSED. */
5285 while (load_needed (pi_root));
5287 /* Make sure all elements of the rename-list were found in the module. */
5289 for (u = gfc_rename_list; u; u = u->next)
5291 if (u->found)
5292 continue;
5294 if (u->op == INTRINSIC_NONE)
5296 gfc_error ("Symbol %qs referenced at %L not found in module %qs",
5297 u->use_name, &u->where, module_name);
5298 continue;
5301 if (u->op == INTRINSIC_USER)
5303 gfc_error ("User operator %qs referenced at %L not found "
5304 "in module %qs", u->use_name, &u->where, module_name);
5305 continue;
5308 gfc_error ("Intrinsic operator %qs referenced at %L not found "
5309 "in module %qs", gfc_op2string (u->op), &u->where,
5310 module_name);
5313 /* Clean up symbol nodes that were never loaded, create references
5314 to hidden symbols. */
5316 read_cleanup (pi_root);
5320 /* Given an access type that is specific to an entity and the default
5321 access, return nonzero if the entity is publicly accessible. If the
5322 element is declared as PUBLIC, then it is public; if declared
5323 PRIVATE, then private, and otherwise it is public unless the default
5324 access in this context has been declared PRIVATE. */
5326 static bool dump_smod = false;
5328 static bool
5329 check_access (gfc_access specific_access, gfc_access default_access)
5331 if (dump_smod)
5332 return true;
5334 if (specific_access == ACCESS_PUBLIC)
5335 return TRUE;
5336 if (specific_access == ACCESS_PRIVATE)
5337 return FALSE;
5339 if (flag_module_private)
5340 return default_access == ACCESS_PUBLIC;
5341 else
5342 return default_access != ACCESS_PRIVATE;
5346 bool
5347 gfc_check_symbol_access (gfc_symbol *sym)
5349 if (sym->attr.vtab || sym->attr.vtype)
5350 return true;
5351 else
5352 return check_access (sym->attr.access, sym->ns->default_access);
5356 /* A structure to remember which commons we've already written. */
5358 struct written_common
5360 BBT_HEADER(written_common);
5361 const char *name, *label;
5364 static struct written_common *written_commons = NULL;
5366 /* Comparison function used for balancing the binary tree. */
5368 static int
5369 compare_written_commons (void *a1, void *b1)
5371 const char *aname = ((struct written_common *) a1)->name;
5372 const char *alabel = ((struct written_common *) a1)->label;
5373 const char *bname = ((struct written_common *) b1)->name;
5374 const char *blabel = ((struct written_common *) b1)->label;
5375 int c = strcmp (aname, bname);
5377 return (c != 0 ? c : strcmp (alabel, blabel));
5380 /* Free a list of written commons. */
5382 static void
5383 free_written_common (struct written_common *w)
5385 if (!w)
5386 return;
5388 if (w->left)
5389 free_written_common (w->left);
5390 if (w->right)
5391 free_written_common (w->right);
5393 free (w);
5396 /* Write a common block to the module -- recursive helper function. */
5398 static void
5399 write_common_0 (gfc_symtree *st, bool this_module)
5401 gfc_common_head *p;
5402 const char * name;
5403 int flags;
5404 const char *label;
5405 struct written_common *w;
5406 bool write_me = true;
5408 if (st == NULL)
5409 return;
5411 write_common_0 (st->left, this_module);
5413 /* We will write out the binding label, or "" if no label given. */
5414 name = st->n.common->name;
5415 p = st->n.common;
5416 label = (p->is_bind_c && p->binding_label) ? p->binding_label : "";
5418 /* Check if we've already output this common. */
5419 w = written_commons;
5420 while (w)
5422 int c = strcmp (name, w->name);
5423 c = (c != 0 ? c : strcmp (label, w->label));
5424 if (c == 0)
5425 write_me = false;
5427 w = (c < 0) ? w->left : w->right;
5430 if (this_module && p->use_assoc)
5431 write_me = false;
5433 if (write_me)
5435 /* Write the common to the module. */
5436 mio_lparen ();
5437 mio_pool_string (&name);
5439 mio_symbol_ref (&p->head);
5440 flags = p->saved ? 1 : 0;
5441 if (p->threadprivate)
5442 flags |= 2;
5443 mio_integer (&flags);
5445 /* Write out whether the common block is bind(c) or not. */
5446 mio_integer (&(p->is_bind_c));
5448 mio_pool_string (&label);
5449 mio_rparen ();
5451 /* Record that we have written this common. */
5452 w = XCNEW (struct written_common);
5453 w->name = p->name;
5454 w->label = label;
5455 gfc_insert_bbt (&written_commons, w, compare_written_commons);
5458 write_common_0 (st->right, this_module);
5462 /* Write a common, by initializing the list of written commons, calling
5463 the recursive function write_common_0() and cleaning up afterwards. */
5465 static void
5466 write_common (gfc_symtree *st)
5468 written_commons = NULL;
5469 write_common_0 (st, true);
5470 write_common_0 (st, false);
5471 free_written_common (written_commons);
5472 written_commons = NULL;
5476 /* Write the blank common block to the module. */
5478 static void
5479 write_blank_common (void)
5481 const char * name = BLANK_COMMON_NAME;
5482 int saved;
5483 /* TODO: Blank commons are not bind(c). The F2003 standard probably says
5484 this, but it hasn't been checked. Just making it so for now. */
5485 int is_bind_c = 0;
5487 if (gfc_current_ns->blank_common.head == NULL)
5488 return;
5490 mio_lparen ();
5492 mio_pool_string (&name);
5494 mio_symbol_ref (&gfc_current_ns->blank_common.head);
5495 saved = gfc_current_ns->blank_common.saved;
5496 mio_integer (&saved);
5498 /* Write out whether the common block is bind(c) or not. */
5499 mio_integer (&is_bind_c);
5501 /* Write out an empty binding label. */
5502 write_atom (ATOM_STRING, "");
5504 mio_rparen ();
5508 /* Write equivalences to the module. */
5510 static void
5511 write_equiv (void)
5513 gfc_equiv *eq, *e;
5514 int num;
5516 num = 0;
5517 for (eq = gfc_current_ns->equiv; eq; eq = eq->next)
5519 mio_lparen ();
5521 for (e = eq; e; e = e->eq)
5523 if (e->module == NULL)
5524 e->module = gfc_get_string ("%s.eq.%d", module_name, num);
5525 mio_allocated_string (e->module);
5526 mio_expr (&e->expr);
5529 num++;
5530 mio_rparen ();
5535 /* Write a symbol to the module. */
5537 static void
5538 write_symbol (int n, gfc_symbol *sym)
5540 const char *label;
5542 if (sym->attr.flavor == FL_UNKNOWN || sym->attr.flavor == FL_LABEL)
5543 gfc_internal_error ("write_symbol(): bad module symbol %qs", sym->name);
5545 mio_integer (&n);
5547 if (gfc_fl_struct (sym->attr.flavor))
5549 const char *name;
5550 name = gfc_dt_upper_string (sym->name);
5551 mio_pool_string (&name);
5553 else
5554 mio_pool_string (&sym->name);
5556 mio_pool_string (&sym->module);
5557 if ((sym->attr.is_bind_c || sym->attr.is_iso_c) && sym->binding_label)
5559 label = sym->binding_label;
5560 mio_pool_string (&label);
5562 else
5563 write_atom (ATOM_STRING, "");
5565 mio_pointer_ref (&sym->ns);
5567 mio_symbol (sym);
5568 write_char ('\n');
5572 /* Recursive traversal function to write the initial set of symbols to
5573 the module. We check to see if the symbol should be written
5574 according to the access specification. */
5576 static void
5577 write_symbol0 (gfc_symtree *st)
5579 gfc_symbol *sym;
5580 pointer_info *p;
5581 bool dont_write = false;
5583 if (st == NULL)
5584 return;
5586 write_symbol0 (st->left);
5588 sym = st->n.sym;
5589 if (sym->module == NULL)
5590 sym->module = module_name;
5592 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
5593 && !sym->attr.subroutine && !sym->attr.function)
5594 dont_write = true;
5596 if (!gfc_check_symbol_access (sym))
5597 dont_write = true;
5599 if (!dont_write)
5601 p = get_pointer (sym);
5602 if (p->type == P_UNKNOWN)
5603 p->type = P_SYMBOL;
5605 if (p->u.wsym.state != WRITTEN)
5607 write_symbol (p->integer, sym);
5608 p->u.wsym.state = WRITTEN;
5612 write_symbol0 (st->right);
5616 static void
5617 write_omp_udr (gfc_omp_udr *udr)
5619 switch (udr->rop)
5621 case OMP_REDUCTION_USER:
5622 /* Non-operators can't be used outside of the module. */
5623 if (udr->name[0] != '.')
5624 return;
5625 else
5627 gfc_symtree *st;
5628 size_t len = strlen (udr->name + 1);
5629 char *name = XALLOCAVEC (char, len);
5630 memcpy (name, udr->name, len - 1);
5631 name[len - 1] = '\0';
5632 st = gfc_find_symtree (gfc_current_ns->uop_root, name);
5633 /* If corresponding user operator is private, don't write
5634 the UDR. */
5635 if (st != NULL)
5637 gfc_user_op *uop = st->n.uop;
5638 if (!check_access (uop->access, uop->ns->default_access))
5639 return;
5642 break;
5643 case OMP_REDUCTION_PLUS:
5644 case OMP_REDUCTION_MINUS:
5645 case OMP_REDUCTION_TIMES:
5646 case OMP_REDUCTION_AND:
5647 case OMP_REDUCTION_OR:
5648 case OMP_REDUCTION_EQV:
5649 case OMP_REDUCTION_NEQV:
5650 /* If corresponding operator is private, don't write the UDR. */
5651 if (!check_access (gfc_current_ns->operator_access[udr->rop],
5652 gfc_current_ns->default_access))
5653 return;
5654 break;
5655 default:
5656 break;
5658 if (udr->ts.type == BT_DERIVED || udr->ts.type == BT_CLASS)
5660 /* If derived type is private, don't write the UDR. */
5661 if (!gfc_check_symbol_access (udr->ts.u.derived))
5662 return;
5665 mio_lparen ();
5666 mio_pool_string (&udr->name);
5667 mio_typespec (&udr->ts);
5668 mio_omp_udr_expr (udr, &udr->omp_out, &udr->omp_in, udr->combiner_ns, false);
5669 if (udr->initializer_ns)
5670 mio_omp_udr_expr (udr, &udr->omp_priv, &udr->omp_orig,
5671 udr->initializer_ns, true);
5672 mio_rparen ();
5676 static void
5677 write_omp_udrs (gfc_symtree *st)
5679 if (st == NULL)
5680 return;
5682 write_omp_udrs (st->left);
5683 gfc_omp_udr *udr;
5684 for (udr = st->n.omp_udr; udr; udr = udr->next)
5685 write_omp_udr (udr);
5686 write_omp_udrs (st->right);
5690 /* Type for the temporary tree used when writing secondary symbols. */
5692 struct sorted_pointer_info
5694 BBT_HEADER (sorted_pointer_info);
5696 pointer_info *p;
5699 #define gfc_get_sorted_pointer_info() XCNEW (sorted_pointer_info)
5701 /* Recursively traverse the temporary tree, free its contents. */
5703 static void
5704 free_sorted_pointer_info_tree (sorted_pointer_info *p)
5706 if (!p)
5707 return;
5709 free_sorted_pointer_info_tree (p->left);
5710 free_sorted_pointer_info_tree (p->right);
5712 free (p);
5715 /* Comparison function for the temporary tree. */
5717 static int
5718 compare_sorted_pointer_info (void *_spi1, void *_spi2)
5720 sorted_pointer_info *spi1, *spi2;
5721 spi1 = (sorted_pointer_info *)_spi1;
5722 spi2 = (sorted_pointer_info *)_spi2;
5724 if (spi1->p->integer < spi2->p->integer)
5725 return -1;
5726 if (spi1->p->integer > spi2->p->integer)
5727 return 1;
5728 return 0;
5732 /* Finds the symbols that need to be written and collects them in the
5733 sorted_pi tree so that they can be traversed in an order
5734 independent of memory addresses. */
5736 static void
5737 find_symbols_to_write(sorted_pointer_info **tree, pointer_info *p)
5739 if (!p)
5740 return;
5742 if (p->type == P_SYMBOL && p->u.wsym.state == NEEDS_WRITE)
5744 sorted_pointer_info *sp = gfc_get_sorted_pointer_info();
5745 sp->p = p;
5747 gfc_insert_bbt (tree, sp, compare_sorted_pointer_info);
5750 find_symbols_to_write (tree, p->left);
5751 find_symbols_to_write (tree, p->right);
5755 /* Recursive function that traverses the tree of symbols that need to be
5756 written and writes them in order. */
5758 static void
5759 write_symbol1_recursion (sorted_pointer_info *sp)
5761 if (!sp)
5762 return;
5764 write_symbol1_recursion (sp->left);
5766 pointer_info *p1 = sp->p;
5767 gcc_assert (p1->type == P_SYMBOL && p1->u.wsym.state == NEEDS_WRITE);
5769 p1->u.wsym.state = WRITTEN;
5770 write_symbol (p1->integer, p1->u.wsym.sym);
5771 p1->u.wsym.sym->attr.public_used = 1;
5773 write_symbol1_recursion (sp->right);
5777 /* Write the secondary set of symbols to the module file. These are
5778 symbols that were not public yet are needed by the public symbols
5779 or another dependent symbol. The act of writing a symbol can add
5780 symbols to the pointer_info tree, so we return nonzero if a symbol
5781 was written and pass that information upwards. The caller will
5782 then call this function again until nothing was written. It uses
5783 the utility functions and a temporary tree to ensure a reproducible
5784 ordering of the symbol output and thus the module file. */
5786 static int
5787 write_symbol1 (pointer_info *p)
5789 if (!p)
5790 return 0;
5792 /* Put symbols that need to be written into a tree sorted on the
5793 integer field. */
5795 sorted_pointer_info *spi_root = NULL;
5796 find_symbols_to_write (&spi_root, p);
5798 /* No symbols to write, return. */
5799 if (!spi_root)
5800 return 0;
5802 /* Otherwise, write and free the tree again. */
5803 write_symbol1_recursion (spi_root);
5804 free_sorted_pointer_info_tree (spi_root);
5806 return 1;
5810 /* Write operator interfaces associated with a symbol. */
5812 static void
5813 write_operator (gfc_user_op *uop)
5815 static char nullstring[] = "";
5816 const char *p = nullstring;
5818 if (uop->op == NULL || !check_access (uop->access, uop->ns->default_access))
5819 return;
5821 mio_symbol_interface (&uop->name, &p, &uop->op);
5825 /* Write generic interfaces from the namespace sym_root. */
5827 static void
5828 write_generic (gfc_symtree *st)
5830 gfc_symbol *sym;
5832 if (st == NULL)
5833 return;
5835 write_generic (st->left);
5837 sym = st->n.sym;
5838 if (sym && !check_unique_name (st->name)
5839 && sym->generic && gfc_check_symbol_access (sym))
5841 if (!sym->module)
5842 sym->module = module_name;
5844 mio_symbol_interface (&st->name, &sym->module, &sym->generic);
5847 write_generic (st->right);
5851 static void
5852 write_symtree (gfc_symtree *st)
5854 gfc_symbol *sym;
5855 pointer_info *p;
5857 sym = st->n.sym;
5859 /* A symbol in an interface body must not be visible in the
5860 module file. */
5861 if (sym->ns != gfc_current_ns
5862 && sym->ns->proc_name
5863 && sym->ns->proc_name->attr.if_source == IFSRC_IFBODY)
5864 return;
5866 if (!gfc_check_symbol_access (sym)
5867 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
5868 && !sym->attr.subroutine && !sym->attr.function))
5869 return;
5871 if (check_unique_name (st->name))
5872 return;
5874 p = find_pointer (sym);
5875 if (p == NULL)
5876 gfc_internal_error ("write_symtree(): Symbol not written");
5878 mio_pool_string (&st->name);
5879 mio_integer (&st->ambiguous);
5880 mio_integer (&p->integer);
5884 static void
5885 write_module (void)
5887 int i;
5889 /* Write the operator interfaces. */
5890 mio_lparen ();
5892 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
5894 if (i == INTRINSIC_USER)
5895 continue;
5897 mio_interface (check_access (gfc_current_ns->operator_access[i],
5898 gfc_current_ns->default_access)
5899 ? &gfc_current_ns->op[i] : NULL);
5902 mio_rparen ();
5903 write_char ('\n');
5904 write_char ('\n');
5906 mio_lparen ();
5907 gfc_traverse_user_op (gfc_current_ns, write_operator);
5908 mio_rparen ();
5909 write_char ('\n');
5910 write_char ('\n');
5912 mio_lparen ();
5913 write_generic (gfc_current_ns->sym_root);
5914 mio_rparen ();
5915 write_char ('\n');
5916 write_char ('\n');
5918 mio_lparen ();
5919 write_blank_common ();
5920 write_common (gfc_current_ns->common_root);
5921 mio_rparen ();
5922 write_char ('\n');
5923 write_char ('\n');
5925 mio_lparen ();
5926 write_equiv ();
5927 mio_rparen ();
5928 write_char ('\n');
5929 write_char ('\n');
5931 mio_lparen ();
5932 write_omp_udrs (gfc_current_ns->omp_udr_root);
5933 mio_rparen ();
5934 write_char ('\n');
5935 write_char ('\n');
5937 /* Write symbol information. First we traverse all symbols in the
5938 primary namespace, writing those that need to be written.
5939 Sometimes writing one symbol will cause another to need to be
5940 written. A list of these symbols ends up on the write stack, and
5941 we end by popping the bottom of the stack and writing the symbol
5942 until the stack is empty. */
5944 mio_lparen ();
5946 write_symbol0 (gfc_current_ns->sym_root);
5947 while (write_symbol1 (pi_root))
5948 /* Nothing. */;
5950 mio_rparen ();
5952 write_char ('\n');
5953 write_char ('\n');
5955 mio_lparen ();
5956 gfc_traverse_symtree (gfc_current_ns->sym_root, write_symtree);
5957 mio_rparen ();
5961 /* Read a CRC32 sum from the gzip trailer of a module file. Returns
5962 true on success, false on failure. */
5964 static bool
5965 read_crc32_from_module_file (const char* filename, uLong* crc)
5967 FILE *file;
5968 char buf[4];
5969 unsigned int val;
5971 /* Open the file in binary mode. */
5972 if ((file = fopen (filename, "rb")) == NULL)
5973 return false;
5975 /* The gzip crc32 value is found in the [END-8, END-4] bytes of the
5976 file. See RFC 1952. */
5977 if (fseek (file, -8, SEEK_END) != 0)
5979 fclose (file);
5980 return false;
5983 /* Read the CRC32. */
5984 if (fread (buf, 1, 4, file) != 4)
5986 fclose (file);
5987 return false;
5990 /* Close the file. */
5991 fclose (file);
5993 val = (buf[0] & 0xFF) + ((buf[1] & 0xFF) << 8) + ((buf[2] & 0xFF) << 16)
5994 + ((buf[3] & 0xFF) << 24);
5995 *crc = val;
5997 /* For debugging, the CRC value printed in hexadecimal should match
5998 the CRC printed by "zcat -l -v filename".
5999 printf("CRC of file %s is %x\n", filename, val); */
6001 return true;
6005 /* Given module, dump it to disk. If there was an error while
6006 processing the module, dump_flag will be set to zero and we delete
6007 the module file, even if it was already there. */
6009 static void
6010 dump_module (const char *name, int dump_flag)
6012 int n;
6013 char *filename, *filename_tmp;
6014 uLong crc, crc_old;
6016 module_name = gfc_get_string ("%s", name);
6018 if (dump_smod)
6020 name = submodule_name;
6021 n = strlen (name) + strlen (SUBMODULE_EXTENSION) + 1;
6023 else
6024 n = strlen (name) + strlen (MODULE_EXTENSION) + 1;
6026 if (gfc_option.module_dir != NULL)
6028 n += strlen (gfc_option.module_dir);
6029 filename = (char *) alloca (n);
6030 strcpy (filename, gfc_option.module_dir);
6031 strcat (filename, name);
6033 else
6035 filename = (char *) alloca (n);
6036 strcpy (filename, name);
6039 if (dump_smod)
6040 strcat (filename, SUBMODULE_EXTENSION);
6041 else
6042 strcat (filename, MODULE_EXTENSION);
6044 /* Name of the temporary file used to write the module. */
6045 filename_tmp = (char *) alloca (n + 1);
6046 strcpy (filename_tmp, filename);
6047 strcat (filename_tmp, "0");
6049 /* There was an error while processing the module. We delete the
6050 module file, even if it was already there. */
6051 if (!dump_flag)
6053 remove (filename);
6054 return;
6057 if (gfc_cpp_makedep ())
6058 gfc_cpp_add_target (filename);
6060 /* Write the module to the temporary file. */
6061 module_fp = gzopen (filename_tmp, "w");
6062 if (module_fp == NULL)
6063 gfc_fatal_error ("Can't open module file %qs for writing at %C: %s",
6064 filename_tmp, xstrerror (errno));
6066 gzprintf (module_fp, "GFORTRAN module version '%s' created from %s\n",
6067 MOD_VERSION, gfc_source_file);
6069 /* Write the module itself. */
6070 iomode = IO_OUTPUT;
6072 init_pi_tree ();
6074 write_module ();
6076 free_pi_tree (pi_root);
6077 pi_root = NULL;
6079 write_char ('\n');
6081 if (gzclose (module_fp))
6082 gfc_fatal_error ("Error writing module file %qs for writing: %s",
6083 filename_tmp, xstrerror (errno));
6085 /* Read the CRC32 from the gzip trailers of the module files and
6086 compare. */
6087 if (!read_crc32_from_module_file (filename_tmp, &crc)
6088 || !read_crc32_from_module_file (filename, &crc_old)
6089 || crc_old != crc)
6091 /* Module file have changed, replace the old one. */
6092 if (remove (filename) && errno != ENOENT)
6093 gfc_fatal_error ("Can't delete module file %qs: %s", filename,
6094 xstrerror (errno));
6095 if (rename (filename_tmp, filename))
6096 gfc_fatal_error ("Can't rename module file %qs to %qs: %s",
6097 filename_tmp, filename, xstrerror (errno));
6099 else
6101 if (remove (filename_tmp))
6102 gfc_fatal_error ("Can't delete temporary module file %qs: %s",
6103 filename_tmp, xstrerror (errno));
6108 /* Suppress the output of a .smod file by module, if no module
6109 procedures have been seen. */
6110 static bool no_module_procedures;
6112 static void
6113 check_for_module_procedures (gfc_symbol *sym)
6115 if (sym && sym->attr.module_procedure)
6116 no_module_procedures = false;
6120 void
6121 gfc_dump_module (const char *name, int dump_flag)
6123 if (gfc_state_stack->state == COMP_SUBMODULE)
6124 dump_smod = true;
6125 else
6126 dump_smod =false;
6128 no_module_procedures = true;
6129 gfc_traverse_ns (gfc_current_ns, check_for_module_procedures);
6131 dump_module (name, dump_flag);
6133 if (no_module_procedures || dump_smod)
6134 return;
6136 /* Write a submodule file from a module. The 'dump_smod' flag switches
6137 off the check for PRIVATE entities. */
6138 dump_smod = true;
6139 submodule_name = module_name;
6140 dump_module (name, dump_flag);
6141 dump_smod = false;
6144 static void
6145 create_intrinsic_function (const char *name, int id,
6146 const char *modname, intmod_id module,
6147 bool subroutine, gfc_symbol *result_type)
6149 gfc_intrinsic_sym *isym;
6150 gfc_symtree *tmp_symtree;
6151 gfc_symbol *sym;
6153 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
6154 if (tmp_symtree)
6156 if (tmp_symtree->n.sym && tmp_symtree->n.sym->module
6157 && strcmp (modname, tmp_symtree->n.sym->module) == 0)
6158 return;
6159 gfc_error ("Symbol %qs at %C already declared", name);
6160 return;
6163 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
6164 sym = tmp_symtree->n.sym;
6166 if (subroutine)
6168 gfc_isym_id isym_id = gfc_isym_id_by_intmod (module, id);
6169 isym = gfc_intrinsic_subroutine_by_id (isym_id);
6170 sym->attr.subroutine = 1;
6172 else
6174 gfc_isym_id isym_id = gfc_isym_id_by_intmod (module, id);
6175 isym = gfc_intrinsic_function_by_id (isym_id);
6177 sym->attr.function = 1;
6178 if (result_type)
6180 sym->ts.type = BT_DERIVED;
6181 sym->ts.u.derived = result_type;
6182 sym->ts.is_c_interop = 1;
6183 isym->ts.f90_type = BT_VOID;
6184 isym->ts.type = BT_DERIVED;
6185 isym->ts.f90_type = BT_VOID;
6186 isym->ts.u.derived = result_type;
6187 isym->ts.is_c_interop = 1;
6190 gcc_assert (isym);
6192 sym->attr.flavor = FL_PROCEDURE;
6193 sym->attr.intrinsic = 1;
6195 sym->module = gfc_get_string ("%s", modname);
6196 sym->attr.use_assoc = 1;
6197 sym->from_intmod = module;
6198 sym->intmod_sym_id = id;
6202 /* Import the intrinsic ISO_C_BINDING module, generating symbols in
6203 the current namespace for all named constants, pointer types, and
6204 procedures in the module unless the only clause was used or a rename
6205 list was provided. */
6207 static void
6208 import_iso_c_binding_module (void)
6210 gfc_symbol *mod_sym = NULL, *return_type;
6211 gfc_symtree *mod_symtree = NULL, *tmp_symtree;
6212 gfc_symtree *c_ptr = NULL, *c_funptr = NULL;
6213 const char *iso_c_module_name = "__iso_c_binding";
6214 gfc_use_rename *u;
6215 int i;
6216 bool want_c_ptr = false, want_c_funptr = false;
6218 /* Look only in the current namespace. */
6219 mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, iso_c_module_name);
6221 if (mod_symtree == NULL)
6223 /* symtree doesn't already exist in current namespace. */
6224 gfc_get_sym_tree (iso_c_module_name, gfc_current_ns, &mod_symtree,
6225 false);
6227 if (mod_symtree != NULL)
6228 mod_sym = mod_symtree->n.sym;
6229 else
6230 gfc_internal_error ("import_iso_c_binding_module(): Unable to "
6231 "create symbol for %s", iso_c_module_name);
6233 mod_sym->attr.flavor = FL_MODULE;
6234 mod_sym->attr.intrinsic = 1;
6235 mod_sym->module = gfc_get_string ("%s", iso_c_module_name);
6236 mod_sym->from_intmod = INTMOD_ISO_C_BINDING;
6239 /* Check whether C_PTR or C_FUNPTR are in the include list, if so, load it;
6240 check also whether C_NULL_(FUN)PTR or C_(FUN)LOC are requested, which
6241 need C_(FUN)PTR. */
6242 for (u = gfc_rename_list; u; u = u->next)
6244 if (strcmp (c_interop_kinds_table[ISOCBINDING_NULL_PTR].name,
6245 u->use_name) == 0)
6246 want_c_ptr = true;
6247 else if (strcmp (c_interop_kinds_table[ISOCBINDING_LOC].name,
6248 u->use_name) == 0)
6249 want_c_ptr = true;
6250 else if (strcmp (c_interop_kinds_table[ISOCBINDING_NULL_FUNPTR].name,
6251 u->use_name) == 0)
6252 want_c_funptr = true;
6253 else if (strcmp (c_interop_kinds_table[ISOCBINDING_FUNLOC].name,
6254 u->use_name) == 0)
6255 want_c_funptr = true;
6256 else if (strcmp (c_interop_kinds_table[ISOCBINDING_PTR].name,
6257 u->use_name) == 0)
6259 c_ptr = generate_isocbinding_symbol (iso_c_module_name,
6260 (iso_c_binding_symbol)
6261 ISOCBINDING_PTR,
6262 u->local_name[0] ? u->local_name
6263 : u->use_name,
6264 NULL, false);
6266 else if (strcmp (c_interop_kinds_table[ISOCBINDING_FUNPTR].name,
6267 u->use_name) == 0)
6269 c_funptr
6270 = generate_isocbinding_symbol (iso_c_module_name,
6271 (iso_c_binding_symbol)
6272 ISOCBINDING_FUNPTR,
6273 u->local_name[0] ? u->local_name
6274 : u->use_name,
6275 NULL, false);
6279 if ((want_c_ptr || !only_flag) && !c_ptr)
6280 c_ptr = generate_isocbinding_symbol (iso_c_module_name,
6281 (iso_c_binding_symbol)
6282 ISOCBINDING_PTR,
6283 NULL, NULL, only_flag);
6284 if ((want_c_funptr || !only_flag) && !c_funptr)
6285 c_funptr = generate_isocbinding_symbol (iso_c_module_name,
6286 (iso_c_binding_symbol)
6287 ISOCBINDING_FUNPTR,
6288 NULL, NULL, only_flag);
6290 /* Generate the symbols for the named constants representing
6291 the kinds for intrinsic data types. */
6292 for (i = 0; i < ISOCBINDING_NUMBER; i++)
6294 bool found = false;
6295 for (u = gfc_rename_list; u; u = u->next)
6296 if (strcmp (c_interop_kinds_table[i].name, u->use_name) == 0)
6298 bool not_in_std;
6299 const char *name;
6300 u->found = 1;
6301 found = true;
6303 switch (i)
6305 #define NAMED_FUNCTION(a,b,c,d) \
6306 case a: \
6307 not_in_std = (gfc_option.allow_std & d) == 0; \
6308 name = b; \
6309 break;
6310 #define NAMED_SUBROUTINE(a,b,c,d) \
6311 case a: \
6312 not_in_std = (gfc_option.allow_std & d) == 0; \
6313 name = b; \
6314 break;
6315 #define NAMED_INTCST(a,b,c,d) \
6316 case a: \
6317 not_in_std = (gfc_option.allow_std & d) == 0; \
6318 name = b; \
6319 break;
6320 #define NAMED_REALCST(a,b,c,d) \
6321 case a: \
6322 not_in_std = (gfc_option.allow_std & d) == 0; \
6323 name = b; \
6324 break;
6325 #define NAMED_CMPXCST(a,b,c,d) \
6326 case a: \
6327 not_in_std = (gfc_option.allow_std & d) == 0; \
6328 name = b; \
6329 break;
6330 #include "iso-c-binding.def"
6331 default:
6332 not_in_std = false;
6333 name = "";
6336 if (not_in_std)
6338 gfc_error ("The symbol %qs, referenced at %L, is not "
6339 "in the selected standard", name, &u->where);
6340 continue;
6343 switch (i)
6345 #define NAMED_FUNCTION(a,b,c,d) \
6346 case a: \
6347 if (a == ISOCBINDING_LOC) \
6348 return_type = c_ptr->n.sym; \
6349 else if (a == ISOCBINDING_FUNLOC) \
6350 return_type = c_funptr->n.sym; \
6351 else \
6352 return_type = NULL; \
6353 create_intrinsic_function (u->local_name[0] \
6354 ? u->local_name : u->use_name, \
6355 a, iso_c_module_name, \
6356 INTMOD_ISO_C_BINDING, false, \
6357 return_type); \
6358 break;
6359 #define NAMED_SUBROUTINE(a,b,c,d) \
6360 case a: \
6361 create_intrinsic_function (u->local_name[0] ? u->local_name \
6362 : u->use_name, \
6363 a, iso_c_module_name, \
6364 INTMOD_ISO_C_BINDING, true, NULL); \
6365 break;
6366 #include "iso-c-binding.def"
6368 case ISOCBINDING_PTR:
6369 case ISOCBINDING_FUNPTR:
6370 /* Already handled above. */
6371 break;
6372 default:
6373 if (i == ISOCBINDING_NULL_PTR)
6374 tmp_symtree = c_ptr;
6375 else if (i == ISOCBINDING_NULL_FUNPTR)
6376 tmp_symtree = c_funptr;
6377 else
6378 tmp_symtree = NULL;
6379 generate_isocbinding_symbol (iso_c_module_name,
6380 (iso_c_binding_symbol) i,
6381 u->local_name[0]
6382 ? u->local_name : u->use_name,
6383 tmp_symtree, false);
6387 if (!found && !only_flag)
6389 /* Skip, if the symbol is not in the enabled standard. */
6390 switch (i)
6392 #define NAMED_FUNCTION(a,b,c,d) \
6393 case a: \
6394 if ((gfc_option.allow_std & d) == 0) \
6395 continue; \
6396 break;
6397 #define NAMED_SUBROUTINE(a,b,c,d) \
6398 case a: \
6399 if ((gfc_option.allow_std & d) == 0) \
6400 continue; \
6401 break;
6402 #define NAMED_INTCST(a,b,c,d) \
6403 case a: \
6404 if ((gfc_option.allow_std & d) == 0) \
6405 continue; \
6406 break;
6407 #define NAMED_REALCST(a,b,c,d) \
6408 case a: \
6409 if ((gfc_option.allow_std & d) == 0) \
6410 continue; \
6411 break;
6412 #define NAMED_CMPXCST(a,b,c,d) \
6413 case a: \
6414 if ((gfc_option.allow_std & d) == 0) \
6415 continue; \
6416 break;
6417 #include "iso-c-binding.def"
6418 default:
6419 ; /* Not GFC_STD_* versioned. */
6422 switch (i)
6424 #define NAMED_FUNCTION(a,b,c,d) \
6425 case a: \
6426 if (a == ISOCBINDING_LOC) \
6427 return_type = c_ptr->n.sym; \
6428 else if (a == ISOCBINDING_FUNLOC) \
6429 return_type = c_funptr->n.sym; \
6430 else \
6431 return_type = NULL; \
6432 create_intrinsic_function (b, a, iso_c_module_name, \
6433 INTMOD_ISO_C_BINDING, false, \
6434 return_type); \
6435 break;
6436 #define NAMED_SUBROUTINE(a,b,c,d) \
6437 case a: \
6438 create_intrinsic_function (b, a, iso_c_module_name, \
6439 INTMOD_ISO_C_BINDING, true, NULL); \
6440 break;
6441 #include "iso-c-binding.def"
6443 case ISOCBINDING_PTR:
6444 case ISOCBINDING_FUNPTR:
6445 /* Already handled above. */
6446 break;
6447 default:
6448 if (i == ISOCBINDING_NULL_PTR)
6449 tmp_symtree = c_ptr;
6450 else if (i == ISOCBINDING_NULL_FUNPTR)
6451 tmp_symtree = c_funptr;
6452 else
6453 tmp_symtree = NULL;
6454 generate_isocbinding_symbol (iso_c_module_name,
6455 (iso_c_binding_symbol) i, NULL,
6456 tmp_symtree, false);
6461 for (u = gfc_rename_list; u; u = u->next)
6463 if (u->found)
6464 continue;
6466 gfc_error ("Symbol %qs referenced at %L not found in intrinsic "
6467 "module ISO_C_BINDING", u->use_name, &u->where);
6472 /* Add an integer named constant from a given module. */
6474 static void
6475 create_int_parameter (const char *name, int value, const char *modname,
6476 intmod_id module, int id)
6478 gfc_symtree *tmp_symtree;
6479 gfc_symbol *sym;
6481 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
6482 if (tmp_symtree != NULL)
6484 if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
6485 return;
6486 else
6487 gfc_error ("Symbol %qs already declared", name);
6490 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
6491 sym = tmp_symtree->n.sym;
6493 sym->module = gfc_get_string ("%s", modname);
6494 sym->attr.flavor = FL_PARAMETER;
6495 sym->ts.type = BT_INTEGER;
6496 sym->ts.kind = gfc_default_integer_kind;
6497 sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL, value);
6498 sym->attr.use_assoc = 1;
6499 sym->from_intmod = module;
6500 sym->intmod_sym_id = id;
6504 /* Value is already contained by the array constructor, but not
6505 yet the shape. */
6507 static void
6508 create_int_parameter_array (const char *name, int size, gfc_expr *value,
6509 const char *modname, intmod_id module, int id)
6511 gfc_symtree *tmp_symtree;
6512 gfc_symbol *sym;
6514 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
6515 if (tmp_symtree != NULL)
6517 if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
6518 return;
6519 else
6520 gfc_error ("Symbol %qs already declared", name);
6523 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
6524 sym = tmp_symtree->n.sym;
6526 sym->module = gfc_get_string ("%s", modname);
6527 sym->attr.flavor = FL_PARAMETER;
6528 sym->ts.type = BT_INTEGER;
6529 sym->ts.kind = gfc_default_integer_kind;
6530 sym->attr.use_assoc = 1;
6531 sym->from_intmod = module;
6532 sym->intmod_sym_id = id;
6533 sym->attr.dimension = 1;
6534 sym->as = gfc_get_array_spec ();
6535 sym->as->rank = 1;
6536 sym->as->type = AS_EXPLICIT;
6537 sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
6538 sym->as->upper[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, size);
6540 sym->value = value;
6541 sym->value->shape = gfc_get_shape (1);
6542 mpz_init_set_ui (sym->value->shape[0], size);
6546 /* Add an derived type for a given module. */
6548 static void
6549 create_derived_type (const char *name, const char *modname,
6550 intmod_id module, int id)
6552 gfc_symtree *tmp_symtree;
6553 gfc_symbol *sym, *dt_sym;
6554 gfc_interface *intr, *head;
6556 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
6557 if (tmp_symtree != NULL)
6559 if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
6560 return;
6561 else
6562 gfc_error ("Symbol %qs already declared", name);
6565 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
6566 sym = tmp_symtree->n.sym;
6567 sym->module = gfc_get_string ("%s", modname);
6568 sym->from_intmod = module;
6569 sym->intmod_sym_id = id;
6570 sym->attr.flavor = FL_PROCEDURE;
6571 sym->attr.function = 1;
6572 sym->attr.generic = 1;
6574 gfc_get_sym_tree (gfc_dt_upper_string (sym->name),
6575 gfc_current_ns, &tmp_symtree, false);
6576 dt_sym = tmp_symtree->n.sym;
6577 dt_sym->name = gfc_get_string ("%s", sym->name);
6578 dt_sym->attr.flavor = FL_DERIVED;
6579 dt_sym->attr.private_comp = 1;
6580 dt_sym->attr.zero_comp = 1;
6581 dt_sym->attr.use_assoc = 1;
6582 dt_sym->module = gfc_get_string ("%s", modname);
6583 dt_sym->from_intmod = module;
6584 dt_sym->intmod_sym_id = id;
6586 head = sym->generic;
6587 intr = gfc_get_interface ();
6588 intr->sym = dt_sym;
6589 intr->where = gfc_current_locus;
6590 intr->next = head;
6591 sym->generic = intr;
6592 sym->attr.if_source = IFSRC_DECL;
6596 /* Read the contents of the module file into a temporary buffer. */
6598 static void
6599 read_module_to_tmpbuf ()
6601 /* We don't know the uncompressed size, so enlarge the buffer as
6602 needed. */
6603 int cursz = 4096;
6604 int rsize = cursz;
6605 int len = 0;
6607 module_content = XNEWVEC (char, cursz);
6609 while (1)
6611 int nread = gzread (module_fp, module_content + len, rsize);
6612 len += nread;
6613 if (nread < rsize)
6614 break;
6615 cursz *= 2;
6616 module_content = XRESIZEVEC (char, module_content, cursz);
6617 rsize = cursz - len;
6620 module_content = XRESIZEVEC (char, module_content, len + 1);
6621 module_content[len] = '\0';
6623 module_pos = 0;
6627 /* USE the ISO_FORTRAN_ENV intrinsic module. */
6629 static void
6630 use_iso_fortran_env_module (void)
6632 static char mod[] = "iso_fortran_env";
6633 gfc_use_rename *u;
6634 gfc_symbol *mod_sym;
6635 gfc_symtree *mod_symtree;
6636 gfc_expr *expr;
6637 int i, j;
6639 intmod_sym symbol[] = {
6640 #define NAMED_INTCST(a,b,c,d) { a, b, 0, d },
6641 #define NAMED_KINDARRAY(a,b,c,d) { a, b, 0, d },
6642 #define NAMED_DERIVED_TYPE(a,b,c,d) { a, b, 0, d },
6643 #define NAMED_FUNCTION(a,b,c,d) { a, b, c, d },
6644 #define NAMED_SUBROUTINE(a,b,c,d) { a, b, c, d },
6645 #include "iso-fortran-env.def"
6646 { ISOFORTRANENV_INVALID, NULL, -1234, 0 } };
6648 i = 0;
6649 #define NAMED_INTCST(a,b,c,d) symbol[i++].value = c;
6650 #include "iso-fortran-env.def"
6652 /* Generate the symbol for the module itself. */
6653 mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, mod);
6654 if (mod_symtree == NULL)
6656 gfc_get_sym_tree (mod, gfc_current_ns, &mod_symtree, false);
6657 gcc_assert (mod_symtree);
6658 mod_sym = mod_symtree->n.sym;
6660 mod_sym->attr.flavor = FL_MODULE;
6661 mod_sym->attr.intrinsic = 1;
6662 mod_sym->module = gfc_get_string ("%s", mod);
6663 mod_sym->from_intmod = INTMOD_ISO_FORTRAN_ENV;
6665 else
6666 if (!mod_symtree->n.sym->attr.intrinsic)
6667 gfc_error ("Use of intrinsic module %qs at %C conflicts with "
6668 "non-intrinsic module name used previously", mod);
6670 /* Generate the symbols for the module integer named constants. */
6672 for (i = 0; symbol[i].name; i++)
6674 bool found = false;
6675 for (u = gfc_rename_list; u; u = u->next)
6677 if (strcmp (symbol[i].name, u->use_name) == 0)
6679 found = true;
6680 u->found = 1;
6682 if (!gfc_notify_std (symbol[i].standard, "The symbol %qs, "
6683 "referenced at %L, is not in the selected "
6684 "standard", symbol[i].name, &u->where))
6685 continue;
6687 if ((flag_default_integer || flag_default_real)
6688 && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
6689 gfc_warning_now (0, "Use of the NUMERIC_STORAGE_SIZE named "
6690 "constant from intrinsic module "
6691 "ISO_FORTRAN_ENV at %L is incompatible with "
6692 "option %qs", &u->where,
6693 flag_default_integer
6694 ? "-fdefault-integer-8"
6695 : "-fdefault-real-8");
6696 switch (symbol[i].id)
6698 #define NAMED_INTCST(a,b,c,d) \
6699 case a:
6700 #include "iso-fortran-env.def"
6701 create_int_parameter (u->local_name[0] ? u->local_name
6702 : u->use_name,
6703 symbol[i].value, mod,
6704 INTMOD_ISO_FORTRAN_ENV, symbol[i].id);
6705 break;
6707 #define NAMED_KINDARRAY(a,b,KINDS,d) \
6708 case a:\
6709 expr = gfc_get_array_expr (BT_INTEGER, \
6710 gfc_default_integer_kind,\
6711 NULL); \
6712 for (j = 0; KINDS[j].kind != 0; j++) \
6713 gfc_constructor_append_expr (&expr->value.constructor, \
6714 gfc_get_int_expr (gfc_default_integer_kind, NULL, \
6715 KINDS[j].kind), NULL); \
6716 create_int_parameter_array (u->local_name[0] ? u->local_name \
6717 : u->use_name, \
6718 j, expr, mod, \
6719 INTMOD_ISO_FORTRAN_ENV, \
6720 symbol[i].id); \
6721 break;
6722 #include "iso-fortran-env.def"
6724 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
6725 case a:
6726 #include "iso-fortran-env.def"
6727 create_derived_type (u->local_name[0] ? u->local_name
6728 : u->use_name,
6729 mod, INTMOD_ISO_FORTRAN_ENV,
6730 symbol[i].id);
6731 break;
6733 #define NAMED_FUNCTION(a,b,c,d) \
6734 case a:
6735 #include "iso-fortran-env.def"
6736 create_intrinsic_function (u->local_name[0] ? u->local_name
6737 : u->use_name,
6738 symbol[i].id, mod,
6739 INTMOD_ISO_FORTRAN_ENV, false,
6740 NULL);
6741 break;
6743 default:
6744 gcc_unreachable ();
6749 if (!found && !only_flag)
6751 if ((gfc_option.allow_std & symbol[i].standard) == 0)
6752 continue;
6754 if ((flag_default_integer || flag_default_real)
6755 && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
6756 gfc_warning_now (0,
6757 "Use of the NUMERIC_STORAGE_SIZE named constant "
6758 "from intrinsic module ISO_FORTRAN_ENV at %C is "
6759 "incompatible with option %s",
6760 flag_default_integer
6761 ? "-fdefault-integer-8" : "-fdefault-real-8");
6763 switch (symbol[i].id)
6765 #define NAMED_INTCST(a,b,c,d) \
6766 case a:
6767 #include "iso-fortran-env.def"
6768 create_int_parameter (symbol[i].name, symbol[i].value, mod,
6769 INTMOD_ISO_FORTRAN_ENV, symbol[i].id);
6770 break;
6772 #define NAMED_KINDARRAY(a,b,KINDS,d) \
6773 case a:\
6774 expr = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, \
6775 NULL); \
6776 for (j = 0; KINDS[j].kind != 0; j++) \
6777 gfc_constructor_append_expr (&expr->value.constructor, \
6778 gfc_get_int_expr (gfc_default_integer_kind, NULL, \
6779 KINDS[j].kind), NULL); \
6780 create_int_parameter_array (symbol[i].name, j, expr, mod, \
6781 INTMOD_ISO_FORTRAN_ENV, symbol[i].id);\
6782 break;
6783 #include "iso-fortran-env.def"
6785 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
6786 case a:
6787 #include "iso-fortran-env.def"
6788 create_derived_type (symbol[i].name, mod, INTMOD_ISO_FORTRAN_ENV,
6789 symbol[i].id);
6790 break;
6792 #define NAMED_FUNCTION(a,b,c,d) \
6793 case a:
6794 #include "iso-fortran-env.def"
6795 create_intrinsic_function (symbol[i].name, symbol[i].id, mod,
6796 INTMOD_ISO_FORTRAN_ENV, false,
6797 NULL);
6798 break;
6800 default:
6801 gcc_unreachable ();
6806 for (u = gfc_rename_list; u; u = u->next)
6808 if (u->found)
6809 continue;
6811 gfc_error ("Symbol %qs referenced at %L not found in intrinsic "
6812 "module ISO_FORTRAN_ENV", u->use_name, &u->where);
6817 /* Process a USE directive. */
6819 static void
6820 gfc_use_module (gfc_use_list *module)
6822 char *filename;
6823 gfc_state_data *p;
6824 int c, line, start;
6825 gfc_symtree *mod_symtree;
6826 gfc_use_list *use_stmt;
6827 locus old_locus = gfc_current_locus;
6829 gfc_current_locus = module->where;
6830 module_name = module->module_name;
6831 gfc_rename_list = module->rename;
6832 only_flag = module->only_flag;
6833 current_intmod = INTMOD_NONE;
6835 if (!only_flag)
6836 gfc_warning_now (OPT_Wuse_without_only,
6837 "USE statement at %C has no ONLY qualifier");
6839 if (gfc_state_stack->state == COMP_MODULE
6840 || module->submodule_name == NULL)
6842 filename = XALLOCAVEC (char, strlen (module_name)
6843 + strlen (MODULE_EXTENSION) + 1);
6844 strcpy (filename, module_name);
6845 strcat (filename, MODULE_EXTENSION);
6847 else
6849 filename = XALLOCAVEC (char, strlen (module->submodule_name)
6850 + strlen (SUBMODULE_EXTENSION) + 1);
6851 strcpy (filename, module->submodule_name);
6852 strcat (filename, SUBMODULE_EXTENSION);
6855 /* First, try to find an non-intrinsic module, unless the USE statement
6856 specified that the module is intrinsic. */
6857 module_fp = NULL;
6858 if (!module->intrinsic)
6859 module_fp = gzopen_included_file (filename, true, true);
6861 /* Then, see if it's an intrinsic one, unless the USE statement
6862 specified that the module is non-intrinsic. */
6863 if (module_fp == NULL && !module->non_intrinsic)
6865 if (strcmp (module_name, "iso_fortran_env") == 0
6866 && gfc_notify_std (GFC_STD_F2003, "ISO_FORTRAN_ENV "
6867 "intrinsic module at %C"))
6869 use_iso_fortran_env_module ();
6870 free_rename (module->rename);
6871 module->rename = NULL;
6872 gfc_current_locus = old_locus;
6873 module->intrinsic = true;
6874 return;
6877 if (strcmp (module_name, "iso_c_binding") == 0
6878 && gfc_notify_std (GFC_STD_F2003, "ISO_C_BINDING module at %C"))
6880 import_iso_c_binding_module();
6881 free_rename (module->rename);
6882 module->rename = NULL;
6883 gfc_current_locus = old_locus;
6884 module->intrinsic = true;
6885 return;
6888 module_fp = gzopen_intrinsic_module (filename);
6890 if (module_fp == NULL && module->intrinsic)
6891 gfc_fatal_error ("Can't find an intrinsic module named %qs at %C",
6892 module_name);
6894 /* Check for the IEEE modules, so we can mark their symbols
6895 accordingly when we read them. */
6896 if (strcmp (module_name, "ieee_features") == 0
6897 && gfc_notify_std (GFC_STD_F2003, "IEEE_FEATURES module at %C"))
6899 current_intmod = INTMOD_IEEE_FEATURES;
6901 else if (strcmp (module_name, "ieee_exceptions") == 0
6902 && gfc_notify_std (GFC_STD_F2003,
6903 "IEEE_EXCEPTIONS module at %C"))
6905 current_intmod = INTMOD_IEEE_EXCEPTIONS;
6907 else if (strcmp (module_name, "ieee_arithmetic") == 0
6908 && gfc_notify_std (GFC_STD_F2003,
6909 "IEEE_ARITHMETIC module at %C"))
6911 current_intmod = INTMOD_IEEE_ARITHMETIC;
6915 if (module_fp == NULL)
6917 if (gfc_state_stack->state != COMP_SUBMODULE
6918 && module->submodule_name == NULL)
6919 gfc_fatal_error ("Can't open module file %qs for reading at %C: %s",
6920 filename, xstrerror (errno));
6921 else
6922 gfc_fatal_error ("Module file %qs has not been generated, either "
6923 "because the module does not contain a MODULE "
6924 "PROCEDURE or there is an error in the module.",
6925 filename);
6928 /* Check that we haven't already USEd an intrinsic module with the
6929 same name. */
6931 mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, module_name);
6932 if (mod_symtree && mod_symtree->n.sym->attr.intrinsic)
6933 gfc_error ("Use of non-intrinsic module %qs at %C conflicts with "
6934 "intrinsic module name used previously", module_name);
6936 iomode = IO_INPUT;
6937 module_line = 1;
6938 module_column = 1;
6939 start = 0;
6941 read_module_to_tmpbuf ();
6942 gzclose (module_fp);
6944 /* Skip the first line of the module, after checking that this is
6945 a gfortran module file. */
6946 line = 0;
6947 while (line < 1)
6949 c = module_char ();
6950 if (c == EOF)
6951 bad_module ("Unexpected end of module");
6952 if (start++ < 3)
6953 parse_name (c);
6954 if ((start == 1 && strcmp (atom_name, "GFORTRAN") != 0)
6955 || (start == 2 && strcmp (atom_name, " module") != 0))
6956 gfc_fatal_error ("File %qs opened at %C is not a GNU Fortran"
6957 " module file", filename);
6958 if (start == 3)
6960 if (strcmp (atom_name, " version") != 0
6961 || module_char () != ' '
6962 || parse_atom () != ATOM_STRING
6963 || strcmp (atom_string, MOD_VERSION))
6964 gfc_fatal_error ("Cannot read module file %qs opened at %C,"
6965 " because it was created by a different"
6966 " version of GNU Fortran", filename);
6968 free (atom_string);
6971 if (c == '\n')
6972 line++;
6975 /* Make sure we're not reading the same module that we may be building. */
6976 for (p = gfc_state_stack; p; p = p->previous)
6977 if ((p->state == COMP_MODULE || p->state == COMP_SUBMODULE)
6978 && strcmp (p->sym->name, module_name) == 0)
6979 gfc_fatal_error ("Can't USE the same %smodule we're building",
6980 p->state == COMP_SUBMODULE ? "sub" : "");
6982 init_pi_tree ();
6983 init_true_name_tree ();
6985 read_module ();
6987 free_true_name (true_name_root);
6988 true_name_root = NULL;
6990 free_pi_tree (pi_root);
6991 pi_root = NULL;
6993 XDELETEVEC (module_content);
6994 module_content = NULL;
6996 use_stmt = gfc_get_use_list ();
6997 *use_stmt = *module;
6998 use_stmt->next = gfc_current_ns->use_stmts;
6999 gfc_current_ns->use_stmts = use_stmt;
7001 gfc_current_locus = old_locus;
7005 /* Remove duplicated intrinsic operators from the rename list. */
7007 static void
7008 rename_list_remove_duplicate (gfc_use_rename *list)
7010 gfc_use_rename *seek, *last;
7012 for (; list; list = list->next)
7013 if (list->op != INTRINSIC_USER && list->op != INTRINSIC_NONE)
7015 last = list;
7016 for (seek = list->next; seek; seek = last->next)
7018 if (list->op == seek->op)
7020 last->next = seek->next;
7021 free (seek);
7023 else
7024 last = seek;
7030 /* Process all USE directives. */
7032 void
7033 gfc_use_modules (void)
7035 gfc_use_list *next, *seek, *last;
7037 for (next = module_list; next; next = next->next)
7039 bool non_intrinsic = next->non_intrinsic;
7040 bool intrinsic = next->intrinsic;
7041 bool neither = !non_intrinsic && !intrinsic;
7043 for (seek = next->next; seek; seek = seek->next)
7045 if (next->module_name != seek->module_name)
7046 continue;
7048 if (seek->non_intrinsic)
7049 non_intrinsic = true;
7050 else if (seek->intrinsic)
7051 intrinsic = true;
7052 else
7053 neither = true;
7056 if (intrinsic && neither && !non_intrinsic)
7058 char *filename;
7059 FILE *fp;
7061 filename = XALLOCAVEC (char,
7062 strlen (next->module_name)
7063 + strlen (MODULE_EXTENSION) + 1);
7064 strcpy (filename, next->module_name);
7065 strcat (filename, MODULE_EXTENSION);
7066 fp = gfc_open_included_file (filename, true, true);
7067 if (fp != NULL)
7069 non_intrinsic = true;
7070 fclose (fp);
7074 last = next;
7075 for (seek = next->next; seek; seek = last->next)
7077 if (next->module_name != seek->module_name)
7079 last = seek;
7080 continue;
7083 if ((!next->intrinsic && !seek->intrinsic)
7084 || (next->intrinsic && seek->intrinsic)
7085 || !non_intrinsic)
7087 if (!seek->only_flag)
7088 next->only_flag = false;
7089 if (seek->rename)
7091 gfc_use_rename *r = seek->rename;
7092 while (r->next)
7093 r = r->next;
7094 r->next = next->rename;
7095 next->rename = seek->rename;
7097 last->next = seek->next;
7098 free (seek);
7100 else
7101 last = seek;
7105 for (; module_list; module_list = next)
7107 next = module_list->next;
7108 rename_list_remove_duplicate (module_list->rename);
7109 gfc_use_module (module_list);
7110 free (module_list);
7112 gfc_rename_list = NULL;
7116 void
7117 gfc_free_use_stmts (gfc_use_list *use_stmts)
7119 gfc_use_list *next;
7120 for (; use_stmts; use_stmts = next)
7122 gfc_use_rename *next_rename;
7124 for (; use_stmts->rename; use_stmts->rename = next_rename)
7126 next_rename = use_stmts->rename->next;
7127 free (use_stmts->rename);
7129 next = use_stmts->next;
7130 free (use_stmts);
7135 void
7136 gfc_module_init_2 (void)
7138 last_atom = ATOM_LPAREN;
7139 gfc_rename_list = NULL;
7140 module_list = NULL;
7144 void
7145 gfc_module_done_2 (void)
7147 free_rename (gfc_rename_list);
7148 gfc_rename_list = NULL;