Merge from trunk rev 172662.
[official-gcc.git] / gcc / fortran / module.c
blob0d81029ec7fe659916def5d274df1bc068335173
1 /* Handle modules, which amounts to loading and saving symbols and
2 their attendant structures.
3 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
4 2009, 2010, 2011
5 Free Software Foundation, Inc.
6 Contributed by Andy Vaught
8 This file is part of GCC.
10 GCC is free software; you can redistribute it and/or modify it under
11 the terms of the GNU General Public License as published by the Free
12 Software Foundation; either version 3, or (at your option) any later
13 version.
15 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
16 WARRANTY; without even the implied warranty of MERCHANTABILITY or
17 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 for more details.
20 You should have received a copy of the GNU General Public License
21 along with GCC; see the file COPYING3. If not see
22 <http://www.gnu.org/licenses/>. */
24 /* The syntax of gfortran modules resembles that of lisp lists, i.e. a
25 sequence of atoms, which can be left or right parenthesis, names,
26 integers or strings. Parenthesis are always matched which allows
27 us to skip over sections at high speed without having to know
28 anything about the internal structure of the lists. A "name" is
29 usually a fortran 95 identifier, but can also start with '@' in
30 order to reference a hidden symbol.
32 The first line of a module is an informational message about what
33 created the module, the file it came from and when it was created.
34 The second line is a warning for people not to edit the module.
35 The rest of the module looks like:
37 ( ( <Interface info for UPLUS> )
38 ( <Interface info for UMINUS> )
39 ...
41 ( ( <name of operator interface> <module of op interface> <i/f1> ... )
42 ...
44 ( ( <name of generic interface> <module of generic interface> <i/f1> ... )
45 ...
47 ( ( <common name> <symbol> <saved flag>)
48 ...
51 ( equivalence list )
53 ( <Symbol Number (in no particular order)>
54 <True name of symbol>
55 <Module name of symbol>
56 ( <symbol information> )
57 ...
59 ( <Symtree name>
60 <Ambiguous flag>
61 <Symbol number>
62 ...
65 In general, symbols refer to other symbols by their symbol number,
66 which are zero based. Symbols are written to the module in no
67 particular order. */
69 #include "config.h"
70 #include "system.h"
71 #include "gfortran.h"
72 #include "arith.h"
73 #include "match.h"
74 #include "parse.h" /* FIXME */
75 #include "md5.h"
76 #include "constructor.h"
77 #include "cpp.h"
79 #define MODULE_EXTENSION ".mod"
81 /* Don't put any single quote (') in MOD_VERSION,
82 if yout want it to be recognized. */
83 #define MOD_VERSION "7"
86 /* Structure that describes a position within a module file. */
88 typedef struct
90 int column, line;
91 fpos_t pos;
93 module_locus;
95 /* Structure for list of symbols of intrinsic modules. */
96 typedef struct
98 int id;
99 const char *name;
100 int value;
101 int standard;
103 intmod_sym;
106 typedef enum
108 P_UNKNOWN = 0, P_OTHER, P_NAMESPACE, P_COMPONENT, P_SYMBOL
110 pointer_t;
112 /* The fixup structure lists pointers to pointers that have to
113 be updated when a pointer value becomes known. */
115 typedef struct fixup_t
117 void **pointer;
118 struct fixup_t *next;
120 fixup_t;
123 /* Structure for holding extra info needed for pointers being read. */
125 enum gfc_rsym_state
127 UNUSED,
128 NEEDED,
129 USED
132 enum gfc_wsym_state
134 UNREFERENCED = 0,
135 NEEDS_WRITE,
136 WRITTEN
139 typedef struct pointer_info
141 BBT_HEADER (pointer_info);
142 int integer;
143 pointer_t type;
145 /* The first component of each member of the union is the pointer
146 being stored. */
148 fixup_t *fixup;
150 union
152 void *pointer; /* Member for doing pointer searches. */
154 struct
156 gfc_symbol *sym;
157 char true_name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
158 enum gfc_rsym_state state;
159 int ns, referenced, renamed;
160 module_locus where;
161 fixup_t *stfixup;
162 gfc_symtree *symtree;
163 char binding_label[GFC_MAX_SYMBOL_LEN + 1];
165 rsym;
167 struct
169 gfc_symbol *sym;
170 enum gfc_wsym_state state;
172 wsym;
177 pointer_info;
179 #define gfc_get_pointer_info() XCNEW (pointer_info)
182 /* Local variables */
184 /* The FILE for the module we're reading or writing. */
185 static FILE *module_fp;
187 /* MD5 context structure. */
188 static struct md5_ctx ctx;
190 /* The name of the module we're reading (USE'ing) or writing. */
191 static char module_name[GFC_MAX_SYMBOL_LEN + 1];
193 /* The way the module we're reading was specified. */
194 static bool specified_nonint, specified_int;
196 static int module_line, module_column, only_flag;
197 static enum
198 { IO_INPUT, IO_OUTPUT }
199 iomode;
201 static gfc_use_rename *gfc_rename_list;
202 static pointer_info *pi_root;
203 static int symbol_number; /* Counter for assigning symbol numbers */
205 /* Tells mio_expr_ref to make symbols for unused equivalence members. */
206 static bool in_load_equiv;
208 static locus use_locus;
212 /*****************************************************************/
214 /* Pointer/integer conversion. Pointers between structures are stored
215 as integers in the module file. The next couple of subroutines
216 handle this translation for reading and writing. */
218 /* Recursively free the tree of pointer structures. */
220 static void
221 free_pi_tree (pointer_info *p)
223 if (p == NULL)
224 return;
226 if (p->fixup != NULL)
227 gfc_internal_error ("free_pi_tree(): Unresolved fixup");
229 free_pi_tree (p->left);
230 free_pi_tree (p->right);
232 gfc_free (p);
236 /* Compare pointers when searching by pointer. Used when writing a
237 module. */
239 static int
240 compare_pointers (void *_sn1, void *_sn2)
242 pointer_info *sn1, *sn2;
244 sn1 = (pointer_info *) _sn1;
245 sn2 = (pointer_info *) _sn2;
247 if (sn1->u.pointer < sn2->u.pointer)
248 return -1;
249 if (sn1->u.pointer > sn2->u.pointer)
250 return 1;
252 return 0;
256 /* Compare integers when searching by integer. Used when reading a
257 module. */
259 static int
260 compare_integers (void *_sn1, void *_sn2)
262 pointer_info *sn1, *sn2;
264 sn1 = (pointer_info *) _sn1;
265 sn2 = (pointer_info *) _sn2;
267 if (sn1->integer < sn2->integer)
268 return -1;
269 if (sn1->integer > sn2->integer)
270 return 1;
272 return 0;
276 /* Initialize the pointer_info tree. */
278 static void
279 init_pi_tree (void)
281 compare_fn compare;
282 pointer_info *p;
284 pi_root = NULL;
285 compare = (iomode == IO_INPUT) ? compare_integers : compare_pointers;
287 /* Pointer 0 is the NULL pointer. */
288 p = gfc_get_pointer_info ();
289 p->u.pointer = NULL;
290 p->integer = 0;
291 p->type = P_OTHER;
293 gfc_insert_bbt (&pi_root, p, compare);
295 /* Pointer 1 is the current namespace. */
296 p = gfc_get_pointer_info ();
297 p->u.pointer = gfc_current_ns;
298 p->integer = 1;
299 p->type = P_NAMESPACE;
301 gfc_insert_bbt (&pi_root, p, compare);
303 symbol_number = 2;
307 /* During module writing, call here with a pointer to something,
308 returning the pointer_info node. */
310 static pointer_info *
311 find_pointer (void *gp)
313 pointer_info *p;
315 p = pi_root;
316 while (p != NULL)
318 if (p->u.pointer == gp)
319 break;
320 p = (gp < p->u.pointer) ? p->left : p->right;
323 return p;
327 /* Given a pointer while writing, returns the pointer_info tree node,
328 creating it if it doesn't exist. */
330 static pointer_info *
331 get_pointer (void *gp)
333 pointer_info *p;
335 p = find_pointer (gp);
336 if (p != NULL)
337 return p;
339 /* Pointer doesn't have an integer. Give it one. */
340 p = gfc_get_pointer_info ();
342 p->u.pointer = gp;
343 p->integer = symbol_number++;
345 gfc_insert_bbt (&pi_root, p, compare_pointers);
347 return p;
351 /* Given an integer during reading, find it in the pointer_info tree,
352 creating the node if not found. */
354 static pointer_info *
355 get_integer (int integer)
357 pointer_info *p, t;
358 int c;
360 t.integer = integer;
362 p = pi_root;
363 while (p != NULL)
365 c = compare_integers (&t, p);
366 if (c == 0)
367 break;
369 p = (c < 0) ? p->left : p->right;
372 if (p != NULL)
373 return p;
375 p = gfc_get_pointer_info ();
376 p->integer = integer;
377 p->u.pointer = NULL;
379 gfc_insert_bbt (&pi_root, p, compare_integers);
381 return p;
385 /* Recursive function to find a pointer within a tree by brute force. */
387 static pointer_info *
388 fp2 (pointer_info *p, const void *target)
390 pointer_info *q;
392 if (p == NULL)
393 return NULL;
395 if (p->u.pointer == target)
396 return p;
398 q = fp2 (p->left, target);
399 if (q != NULL)
400 return q;
402 return fp2 (p->right, target);
406 /* During reading, find a pointer_info node from the pointer value.
407 This amounts to a brute-force search. */
409 static pointer_info *
410 find_pointer2 (void *p)
412 return fp2 (pi_root, p);
416 /* Resolve any fixups using a known pointer. */
418 static void
419 resolve_fixups (fixup_t *f, void *gp)
421 fixup_t *next;
423 for (; f; f = next)
425 next = f->next;
426 *(f->pointer) = gp;
427 gfc_free (f);
432 /* Call here during module reading when we know what pointer to
433 associate with an integer. Any fixups that exist are resolved at
434 this time. */
436 static void
437 associate_integer_pointer (pointer_info *p, void *gp)
439 if (p->u.pointer != NULL)
440 gfc_internal_error ("associate_integer_pointer(): Already associated");
442 p->u.pointer = gp;
444 resolve_fixups (p->fixup, gp);
446 p->fixup = NULL;
450 /* During module reading, given an integer and a pointer to a pointer,
451 either store the pointer from an already-known value or create a
452 fixup structure in order to store things later. Returns zero if
453 the reference has been actually stored, or nonzero if the reference
454 must be fixed later (i.e., associate_integer_pointer must be called
455 sometime later. Returns the pointer_info structure. */
457 static pointer_info *
458 add_fixup (int integer, void *gp)
460 pointer_info *p;
461 fixup_t *f;
462 char **cp;
464 p = get_integer (integer);
466 if (p->integer == 0 || p->u.pointer != NULL)
468 cp = (char **) gp;
469 *cp = (char *) p->u.pointer;
471 else
473 f = XCNEW (fixup_t);
475 f->next = p->fixup;
476 p->fixup = f;
478 f->pointer = (void **) gp;
481 return p;
485 /*****************************************************************/
487 /* Parser related subroutines */
489 /* Free the rename list left behind by a USE statement. */
491 static void
492 free_rename (void)
494 gfc_use_rename *next;
496 for (; gfc_rename_list; gfc_rename_list = next)
498 next = gfc_rename_list->next;
499 gfc_free (gfc_rename_list);
504 /* Match a USE statement. */
506 match
507 gfc_match_use (void)
509 char name[GFC_MAX_SYMBOL_LEN + 1], module_nature[GFC_MAX_SYMBOL_LEN + 1];
510 gfc_use_rename *tail = NULL, *new_use;
511 interface_type type, type2;
512 gfc_intrinsic_op op;
513 match m;
515 specified_int = false;
516 specified_nonint = false;
518 if (gfc_match (" , ") == MATCH_YES)
520 if ((m = gfc_match (" %n ::", module_nature)) == MATCH_YES)
522 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: module "
523 "nature in USE statement at %C") == FAILURE)
524 return MATCH_ERROR;
526 if (strcmp (module_nature, "intrinsic") == 0)
527 specified_int = true;
528 else
530 if (strcmp (module_nature, "non_intrinsic") == 0)
531 specified_nonint = true;
532 else
534 gfc_error ("Module nature in USE statement at %C shall "
535 "be either INTRINSIC or NON_INTRINSIC");
536 return MATCH_ERROR;
540 else
542 /* Help output a better error message than "Unclassifiable
543 statement". */
544 gfc_match (" %n", module_nature);
545 if (strcmp (module_nature, "intrinsic") == 0
546 || strcmp (module_nature, "non_intrinsic") == 0)
547 gfc_error ("\"::\" was expected after module nature at %C "
548 "but was not found");
549 return m;
552 else
554 m = gfc_match (" ::");
555 if (m == MATCH_YES &&
556 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: "
557 "\"USE :: module\" at %C") == FAILURE)
558 return MATCH_ERROR;
560 if (m != MATCH_YES)
562 m = gfc_match ("% ");
563 if (m != MATCH_YES)
564 return m;
568 use_locus = gfc_current_locus;
570 m = gfc_match_name (module_name);
571 if (m != MATCH_YES)
572 return m;
574 free_rename ();
575 only_flag = 0;
577 if (gfc_match_eos () == MATCH_YES)
578 return MATCH_YES;
579 if (gfc_match_char (',') != MATCH_YES)
580 goto syntax;
582 if (gfc_match (" only :") == MATCH_YES)
583 only_flag = 1;
585 if (gfc_match_eos () == MATCH_YES)
586 return MATCH_YES;
588 for (;;)
590 /* Get a new rename struct and add it to the rename list. */
591 new_use = gfc_get_use_rename ();
592 new_use->where = gfc_current_locus;
593 new_use->found = 0;
595 if (gfc_rename_list == NULL)
596 gfc_rename_list = new_use;
597 else
598 tail->next = new_use;
599 tail = new_use;
601 /* See what kind of interface we're dealing with. Assume it is
602 not an operator. */
603 new_use->op = INTRINSIC_NONE;
604 if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR)
605 goto cleanup;
607 switch (type)
609 case INTERFACE_NAMELESS:
610 gfc_error ("Missing generic specification in USE statement at %C");
611 goto cleanup;
613 case INTERFACE_USER_OP:
614 case INTERFACE_GENERIC:
615 m = gfc_match (" =>");
617 if (type == INTERFACE_USER_OP && m == MATCH_YES
618 && (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Renaming "
619 "operators in USE statements at %C")
620 == FAILURE))
621 goto cleanup;
623 if (type == INTERFACE_USER_OP)
624 new_use->op = INTRINSIC_USER;
626 if (only_flag)
628 if (m != MATCH_YES)
629 strcpy (new_use->use_name, name);
630 else
632 strcpy (new_use->local_name, name);
633 m = gfc_match_generic_spec (&type2, new_use->use_name, &op);
634 if (type != type2)
635 goto syntax;
636 if (m == MATCH_NO)
637 goto syntax;
638 if (m == MATCH_ERROR)
639 goto cleanup;
642 else
644 if (m != MATCH_YES)
645 goto syntax;
646 strcpy (new_use->local_name, name);
648 m = gfc_match_generic_spec (&type2, new_use->use_name, &op);
649 if (type != type2)
650 goto syntax;
651 if (m == MATCH_NO)
652 goto syntax;
653 if (m == MATCH_ERROR)
654 goto cleanup;
657 if (strcmp (new_use->use_name, module_name) == 0
658 || strcmp (new_use->local_name, module_name) == 0)
660 gfc_error ("The name '%s' at %C has already been used as "
661 "an external module name.", module_name);
662 goto cleanup;
664 break;
666 case INTERFACE_INTRINSIC_OP:
667 new_use->op = op;
668 break;
670 default:
671 gcc_unreachable ();
674 if (gfc_match_eos () == MATCH_YES)
675 break;
676 if (gfc_match_char (',') != MATCH_YES)
677 goto syntax;
680 return MATCH_YES;
682 syntax:
683 gfc_syntax_error (ST_USE);
685 cleanup:
686 free_rename ();
687 return MATCH_ERROR;
691 /* Given a name and a number, inst, return the inst name
692 under which to load this symbol. Returns NULL if this
693 symbol shouldn't be loaded. If inst is zero, returns
694 the number of instances of this name. If interface is
695 true, a user-defined operator is sought, otherwise only
696 non-operators are sought. */
698 static const char *
699 find_use_name_n (const char *name, int *inst, bool interface)
701 gfc_use_rename *u;
702 int i;
704 i = 0;
705 for (u = gfc_rename_list; u; u = u->next)
707 if (strcmp (u->use_name, name) != 0
708 || (u->op == INTRINSIC_USER && !interface)
709 || (u->op != INTRINSIC_USER && interface))
710 continue;
711 if (++i == *inst)
712 break;
715 if (!*inst)
717 *inst = i;
718 return NULL;
721 if (u == NULL)
722 return only_flag ? NULL : name;
724 u->found = 1;
726 return (u->local_name[0] != '\0') ? u->local_name : name;
730 /* Given a name, return the name under which to load this symbol.
731 Returns NULL if this symbol shouldn't be loaded. */
733 static const char *
734 find_use_name (const char *name, bool interface)
736 int i = 1;
737 return find_use_name_n (name, &i, interface);
741 /* Given a real name, return the number of use names associated with it. */
743 static int
744 number_use_names (const char *name, bool interface)
746 int i = 0;
747 find_use_name_n (name, &i, interface);
748 return i;
752 /* Try to find the operator in the current list. */
754 static gfc_use_rename *
755 find_use_operator (gfc_intrinsic_op op)
757 gfc_use_rename *u;
759 for (u = gfc_rename_list; u; u = u->next)
760 if (u->op == op)
761 return u;
763 return NULL;
767 /*****************************************************************/
769 /* The next couple of subroutines maintain a tree used to avoid a
770 brute-force search for a combination of true name and module name.
771 While symtree names, the name that a particular symbol is known by
772 can changed with USE statements, we still have to keep track of the
773 true names to generate the correct reference, and also avoid
774 loading the same real symbol twice in a program unit.
776 When we start reading, the true name tree is built and maintained
777 as symbols are read. The tree is searched as we load new symbols
778 to see if it already exists someplace in the namespace. */
780 typedef struct true_name
782 BBT_HEADER (true_name);
783 gfc_symbol *sym;
785 true_name;
787 static true_name *true_name_root;
790 /* Compare two true_name structures. */
792 static int
793 compare_true_names (void *_t1, void *_t2)
795 true_name *t1, *t2;
796 int c;
798 t1 = (true_name *) _t1;
799 t2 = (true_name *) _t2;
801 c = ((t1->sym->module > t2->sym->module)
802 - (t1->sym->module < t2->sym->module));
803 if (c != 0)
804 return c;
806 return strcmp (t1->sym->name, t2->sym->name);
810 /* Given a true name, search the true name tree to see if it exists
811 within the main namespace. */
813 static gfc_symbol *
814 find_true_name (const char *name, const char *module)
816 true_name t, *p;
817 gfc_symbol sym;
818 int c;
820 sym.name = gfc_get_string (name);
821 if (module != NULL)
822 sym.module = gfc_get_string (module);
823 else
824 sym.module = NULL;
825 t.sym = &sym;
827 p = true_name_root;
828 while (p != NULL)
830 c = compare_true_names ((void *) (&t), (void *) p);
831 if (c == 0)
832 return p->sym;
834 p = (c < 0) ? p->left : p->right;
837 return NULL;
841 /* Given a gfc_symbol pointer that is not in the true name tree, add it. */
843 static void
844 add_true_name (gfc_symbol *sym)
846 true_name *t;
848 t = XCNEW (true_name);
849 t->sym = sym;
851 gfc_insert_bbt (&true_name_root, t, compare_true_names);
855 /* Recursive function to build the initial true name tree by
856 recursively traversing the current namespace. */
858 static void
859 build_tnt (gfc_symtree *st)
861 if (st == NULL)
862 return;
864 build_tnt (st->left);
865 build_tnt (st->right);
867 if (find_true_name (st->n.sym->name, st->n.sym->module) != NULL)
868 return;
870 add_true_name (st->n.sym);
874 /* Initialize the true name tree with the current namespace. */
876 static void
877 init_true_name_tree (void)
879 true_name_root = NULL;
880 build_tnt (gfc_current_ns->sym_root);
884 /* Recursively free a true name tree node. */
886 static void
887 free_true_name (true_name *t)
889 if (t == NULL)
890 return;
891 free_true_name (t->left);
892 free_true_name (t->right);
894 gfc_free (t);
898 /*****************************************************************/
900 /* Module reading and writing. */
902 typedef enum
904 ATOM_NAME, ATOM_LPAREN, ATOM_RPAREN, ATOM_INTEGER, ATOM_STRING
906 atom_type;
908 static atom_type last_atom;
911 /* The name buffer must be at least as long as a symbol name. Right
912 now it's not clear how we're going to store numeric constants--
913 probably as a hexadecimal string, since this will allow the exact
914 number to be preserved (this can't be done by a decimal
915 representation). Worry about that later. TODO! */
917 #define MAX_ATOM_SIZE 100
919 static int atom_int;
920 static char *atom_string, atom_name[MAX_ATOM_SIZE];
923 /* Report problems with a module. Error reporting is not very
924 elaborate, since this sorts of errors shouldn't really happen.
925 This subroutine never returns. */
927 static void bad_module (const char *) ATTRIBUTE_NORETURN;
929 static void
930 bad_module (const char *msgid)
932 fclose (module_fp);
934 switch (iomode)
936 case IO_INPUT:
937 gfc_fatal_error ("Reading module %s at line %d column %d: %s",
938 module_name, module_line, module_column, msgid);
939 break;
940 case IO_OUTPUT:
941 gfc_fatal_error ("Writing module %s at line %d column %d: %s",
942 module_name, module_line, module_column, msgid);
943 break;
944 default:
945 gfc_fatal_error ("Module %s at line %d column %d: %s",
946 module_name, module_line, module_column, msgid);
947 break;
952 /* Set the module's input pointer. */
954 static void
955 set_module_locus (module_locus *m)
957 module_column = m->column;
958 module_line = m->line;
959 fsetpos (module_fp, &m->pos);
963 /* Get the module's input pointer so that we can restore it later. */
965 static void
966 get_module_locus (module_locus *m)
968 m->column = module_column;
969 m->line = module_line;
970 fgetpos (module_fp, &m->pos);
974 /* Get the next character in the module, updating our reckoning of
975 where we are. */
977 static int
978 module_char (void)
980 int c;
982 c = getc (module_fp);
984 if (c == EOF)
985 bad_module ("Unexpected EOF");
987 if (c == '\n')
989 module_line++;
990 module_column = 0;
993 module_column++;
994 return c;
998 /* Parse a string constant. The delimiter is guaranteed to be a
999 single quote. */
1001 static void
1002 parse_string (void)
1004 module_locus start;
1005 int len, c;
1006 char *p;
1008 get_module_locus (&start);
1010 len = 0;
1012 /* See how long the string is. */
1013 for ( ; ; )
1015 c = module_char ();
1016 if (c == EOF)
1017 bad_module ("Unexpected end of module in string constant");
1019 if (c != '\'')
1021 len++;
1022 continue;
1025 c = module_char ();
1026 if (c == '\'')
1028 len++;
1029 continue;
1032 break;
1035 set_module_locus (&start);
1037 atom_string = p = XCNEWVEC (char, len + 1);
1039 for (; len > 0; len--)
1041 c = module_char ();
1042 if (c == '\'')
1043 module_char (); /* Guaranteed to be another \'. */
1044 *p++ = c;
1047 module_char (); /* Terminating \'. */
1048 *p = '\0'; /* C-style string for debug purposes. */
1052 /* Parse a small integer. */
1054 static void
1055 parse_integer (int c)
1057 module_locus m;
1059 atom_int = c - '0';
1061 for (;;)
1063 get_module_locus (&m);
1065 c = module_char ();
1066 if (!ISDIGIT (c))
1067 break;
1069 atom_int = 10 * atom_int + c - '0';
1070 if (atom_int > 99999999)
1071 bad_module ("Integer overflow");
1074 set_module_locus (&m);
1078 /* Parse a name. */
1080 static void
1081 parse_name (int c)
1083 module_locus m;
1084 char *p;
1085 int len;
1087 p = atom_name;
1089 *p++ = c;
1090 len = 1;
1092 get_module_locus (&m);
1094 for (;;)
1096 c = module_char ();
1097 if (!ISALNUM (c) && c != '_' && c != '-')
1098 break;
1100 *p++ = c;
1101 if (++len > GFC_MAX_SYMBOL_LEN)
1102 bad_module ("Name too long");
1105 *p = '\0';
1107 fseek (module_fp, -1, SEEK_CUR);
1108 module_column = m.column + len - 1;
1110 if (c == '\n')
1111 module_line--;
1115 /* Read the next atom in the module's input stream. */
1117 static atom_type
1118 parse_atom (void)
1120 int c;
1124 c = module_char ();
1126 while (c == ' ' || c == '\r' || c == '\n');
1128 switch (c)
1130 case '(':
1131 return ATOM_LPAREN;
1133 case ')':
1134 return ATOM_RPAREN;
1136 case '\'':
1137 parse_string ();
1138 return ATOM_STRING;
1140 case '0':
1141 case '1':
1142 case '2':
1143 case '3':
1144 case '4':
1145 case '5':
1146 case '6':
1147 case '7':
1148 case '8':
1149 case '9':
1150 parse_integer (c);
1151 return ATOM_INTEGER;
1153 case 'a':
1154 case 'b':
1155 case 'c':
1156 case 'd':
1157 case 'e':
1158 case 'f':
1159 case 'g':
1160 case 'h':
1161 case 'i':
1162 case 'j':
1163 case 'k':
1164 case 'l':
1165 case 'm':
1166 case 'n':
1167 case 'o':
1168 case 'p':
1169 case 'q':
1170 case 'r':
1171 case 's':
1172 case 't':
1173 case 'u':
1174 case 'v':
1175 case 'w':
1176 case 'x':
1177 case 'y':
1178 case 'z':
1179 case 'A':
1180 case 'B':
1181 case 'C':
1182 case 'D':
1183 case 'E':
1184 case 'F':
1185 case 'G':
1186 case 'H':
1187 case 'I':
1188 case 'J':
1189 case 'K':
1190 case 'L':
1191 case 'M':
1192 case 'N':
1193 case 'O':
1194 case 'P':
1195 case 'Q':
1196 case 'R':
1197 case 'S':
1198 case 'T':
1199 case 'U':
1200 case 'V':
1201 case 'W':
1202 case 'X':
1203 case 'Y':
1204 case 'Z':
1205 parse_name (c);
1206 return ATOM_NAME;
1208 default:
1209 bad_module ("Bad name");
1212 /* Not reached. */
1216 /* Peek at the next atom on the input. */
1218 static atom_type
1219 peek_atom (void)
1221 module_locus m;
1222 atom_type a;
1224 get_module_locus (&m);
1226 a = parse_atom ();
1227 if (a == ATOM_STRING)
1228 gfc_free (atom_string);
1230 set_module_locus (&m);
1231 return a;
1235 /* Read the next atom from the input, requiring that it be a
1236 particular kind. */
1238 static void
1239 require_atom (atom_type type)
1241 module_locus m;
1242 atom_type t;
1243 const char *p;
1245 get_module_locus (&m);
1247 t = parse_atom ();
1248 if (t != type)
1250 switch (type)
1252 case ATOM_NAME:
1253 p = _("Expected name");
1254 break;
1255 case ATOM_LPAREN:
1256 p = _("Expected left parenthesis");
1257 break;
1258 case ATOM_RPAREN:
1259 p = _("Expected right parenthesis");
1260 break;
1261 case ATOM_INTEGER:
1262 p = _("Expected integer");
1263 break;
1264 case ATOM_STRING:
1265 p = _("Expected string");
1266 break;
1267 default:
1268 gfc_internal_error ("require_atom(): bad atom type required");
1271 set_module_locus (&m);
1272 bad_module (p);
1277 /* Given a pointer to an mstring array, require that the current input
1278 be one of the strings in the array. We return the enum value. */
1280 static int
1281 find_enum (const mstring *m)
1283 int i;
1285 i = gfc_string2code (m, atom_name);
1286 if (i >= 0)
1287 return i;
1289 bad_module ("find_enum(): Enum not found");
1291 /* Not reached. */
1295 /**************** Module output subroutines ***************************/
1297 /* Output a character to a module file. */
1299 static void
1300 write_char (char out)
1302 if (putc (out, module_fp) == EOF)
1303 gfc_fatal_error ("Error writing modules file: %s", xstrerror (errno));
1305 /* Add this to our MD5. */
1306 md5_process_bytes (&out, sizeof (out), &ctx);
1308 if (out != '\n')
1309 module_column++;
1310 else
1312 module_column = 1;
1313 module_line++;
1318 /* Write an atom to a module. The line wrapping isn't perfect, but it
1319 should work most of the time. This isn't that big of a deal, since
1320 the file really isn't meant to be read by people anyway. */
1322 static void
1323 write_atom (atom_type atom, const void *v)
1325 char buffer[20];
1326 int i, len;
1327 const char *p;
1329 switch (atom)
1331 case ATOM_STRING:
1332 case ATOM_NAME:
1333 p = (const char *) v;
1334 break;
1336 case ATOM_LPAREN:
1337 p = "(";
1338 break;
1340 case ATOM_RPAREN:
1341 p = ")";
1342 break;
1344 case ATOM_INTEGER:
1345 i = *((const int *) v);
1346 if (i < 0)
1347 gfc_internal_error ("write_atom(): Writing negative integer");
1349 sprintf (buffer, "%d", i);
1350 p = buffer;
1351 break;
1353 default:
1354 gfc_internal_error ("write_atom(): Trying to write dab atom");
1358 if(p == NULL || *p == '\0')
1359 len = 0;
1360 else
1361 len = strlen (p);
1363 if (atom != ATOM_RPAREN)
1365 if (module_column + len > 72)
1366 write_char ('\n');
1367 else
1370 if (last_atom != ATOM_LPAREN && module_column != 1)
1371 write_char (' ');
1375 if (atom == ATOM_STRING)
1376 write_char ('\'');
1378 while (p != NULL && *p)
1380 if (atom == ATOM_STRING && *p == '\'')
1381 write_char ('\'');
1382 write_char (*p++);
1385 if (atom == ATOM_STRING)
1386 write_char ('\'');
1388 last_atom = atom;
1393 /***************** Mid-level I/O subroutines *****************/
1395 /* These subroutines let their caller read or write atoms without
1396 caring about which of the two is actually happening. This lets a
1397 subroutine concentrate on the actual format of the data being
1398 written. */
1400 static void mio_expr (gfc_expr **);
1401 pointer_info *mio_symbol_ref (gfc_symbol **);
1402 pointer_info *mio_interface_rest (gfc_interface **);
1403 static void mio_symtree_ref (gfc_symtree **);
1405 /* Read or write an enumerated value. On writing, we return the input
1406 value for the convenience of callers. We avoid using an integer
1407 pointer because enums are sometimes inside bitfields. */
1409 static int
1410 mio_name (int t, const mstring *m)
1412 if (iomode == IO_OUTPUT)
1413 write_atom (ATOM_NAME, gfc_code2string (m, t));
1414 else
1416 require_atom (ATOM_NAME);
1417 t = find_enum (m);
1420 return t;
1423 /* Specialization of mio_name. */
1425 #define DECL_MIO_NAME(TYPE) \
1426 static inline TYPE \
1427 MIO_NAME(TYPE) (TYPE t, const mstring *m) \
1429 return (TYPE) mio_name ((int) t, m); \
1431 #define MIO_NAME(TYPE) mio_name_##TYPE
1433 static void
1434 mio_lparen (void)
1436 if (iomode == IO_OUTPUT)
1437 write_atom (ATOM_LPAREN, NULL);
1438 else
1439 require_atom (ATOM_LPAREN);
1443 static void
1444 mio_rparen (void)
1446 if (iomode == IO_OUTPUT)
1447 write_atom (ATOM_RPAREN, NULL);
1448 else
1449 require_atom (ATOM_RPAREN);
1453 static void
1454 mio_integer (int *ip)
1456 if (iomode == IO_OUTPUT)
1457 write_atom (ATOM_INTEGER, ip);
1458 else
1460 require_atom (ATOM_INTEGER);
1461 *ip = atom_int;
1466 /* Read or write a gfc_intrinsic_op value. */
1468 static void
1469 mio_intrinsic_op (gfc_intrinsic_op* op)
1471 /* FIXME: Would be nicer to do this via the operators symbolic name. */
1472 if (iomode == IO_OUTPUT)
1474 int converted = (int) *op;
1475 write_atom (ATOM_INTEGER, &converted);
1477 else
1479 require_atom (ATOM_INTEGER);
1480 *op = (gfc_intrinsic_op) atom_int;
1485 /* Read or write a character pointer that points to a string on the heap. */
1487 static const char *
1488 mio_allocated_string (const char *s)
1490 if (iomode == IO_OUTPUT)
1492 write_atom (ATOM_STRING, s);
1493 return s;
1495 else
1497 require_atom (ATOM_STRING);
1498 return atom_string;
1503 /* Functions for quoting and unquoting strings. */
1505 static char *
1506 quote_string (const gfc_char_t *s, const size_t slength)
1508 const gfc_char_t *p;
1509 char *res, *q;
1510 size_t len = 0, i;
1512 /* Calculate the length we'll need: a backslash takes two ("\\"),
1513 non-printable characters take 10 ("\Uxxxxxxxx") and others take 1. */
1514 for (p = s, i = 0; i < slength; p++, i++)
1516 if (*p == '\\')
1517 len += 2;
1518 else if (!gfc_wide_is_printable (*p))
1519 len += 10;
1520 else
1521 len++;
1524 q = res = XCNEWVEC (char, len + 1);
1525 for (p = s, i = 0; i < slength; p++, i++)
1527 if (*p == '\\')
1528 *q++ = '\\', *q++ = '\\';
1529 else if (!gfc_wide_is_printable (*p))
1531 sprintf (q, "\\U%08" HOST_WIDE_INT_PRINT "x",
1532 (unsigned HOST_WIDE_INT) *p);
1533 q += 10;
1535 else
1536 *q++ = (unsigned char) *p;
1539 res[len] = '\0';
1540 return res;
1543 static gfc_char_t *
1544 unquote_string (const char *s)
1546 size_t len, i;
1547 const char *p;
1548 gfc_char_t *res;
1550 for (p = s, len = 0; *p; p++, len++)
1552 if (*p != '\\')
1553 continue;
1555 if (p[1] == '\\')
1556 p++;
1557 else if (p[1] == 'U')
1558 p += 9; /* That is a "\U????????". */
1559 else
1560 gfc_internal_error ("unquote_string(): got bad string");
1563 res = gfc_get_wide_string (len + 1);
1564 for (i = 0, p = s; i < len; i++, p++)
1566 gcc_assert (*p);
1568 if (*p != '\\')
1569 res[i] = (unsigned char) *p;
1570 else if (p[1] == '\\')
1572 res[i] = (unsigned char) '\\';
1573 p++;
1575 else
1577 /* We read the 8-digits hexadecimal constant that follows. */
1578 int j;
1579 unsigned n;
1580 gfc_char_t c = 0;
1582 gcc_assert (p[1] == 'U');
1583 for (j = 0; j < 8; j++)
1585 c = c << 4;
1586 gcc_assert (sscanf (&p[j+2], "%01x", &n) == 1);
1587 c += n;
1590 res[i] = c;
1591 p += 9;
1595 res[len] = '\0';
1596 return res;
1600 /* Read or write a character pointer that points to a wide string on the
1601 heap, performing quoting/unquoting of nonprintable characters using the
1602 form \U???????? (where each ? is a hexadecimal digit).
1603 Length is the length of the string, only known and used in output mode. */
1605 static const gfc_char_t *
1606 mio_allocated_wide_string (const gfc_char_t *s, const size_t length)
1608 if (iomode == IO_OUTPUT)
1610 char *quoted = quote_string (s, length);
1611 write_atom (ATOM_STRING, quoted);
1612 gfc_free (quoted);
1613 return s;
1615 else
1617 gfc_char_t *unquoted;
1619 require_atom (ATOM_STRING);
1620 unquoted = unquote_string (atom_string);
1621 gfc_free (atom_string);
1622 return unquoted;
1627 /* Read or write a string that is in static memory. */
1629 static void
1630 mio_pool_string (const char **stringp)
1632 /* TODO: one could write the string only once, and refer to it via a
1633 fixup pointer. */
1635 /* As a special case we have to deal with a NULL string. This
1636 happens for the 'module' member of 'gfc_symbol's that are not in a
1637 module. We read / write these as the empty string. */
1638 if (iomode == IO_OUTPUT)
1640 const char *p = *stringp == NULL ? "" : *stringp;
1641 write_atom (ATOM_STRING, p);
1643 else
1645 require_atom (ATOM_STRING);
1646 *stringp = atom_string[0] == '\0' ? NULL : gfc_get_string (atom_string);
1647 gfc_free (atom_string);
1652 /* Read or write a string that is inside of some already-allocated
1653 structure. */
1655 static void
1656 mio_internal_string (char *string)
1658 if (iomode == IO_OUTPUT)
1659 write_atom (ATOM_STRING, string);
1660 else
1662 require_atom (ATOM_STRING);
1663 strcpy (string, atom_string);
1664 gfc_free (atom_string);
1669 typedef enum
1670 { AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL,
1671 AB_POINTER, AB_TARGET, AB_DUMMY, AB_RESULT, AB_DATA,
1672 AB_IN_NAMELIST, AB_IN_COMMON, AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE,
1673 AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT,
1674 AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE,
1675 AB_ALLOC_COMP, AB_POINTER_COMP, AB_PROC_POINTER_COMP, AB_PRIVATE_COMP,
1676 AB_VALUE, AB_VOLATILE, AB_PROTECTED,
1677 AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
1678 AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
1679 AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER,
1680 AB_IMPLICIT_PURE
1682 ab_attribute;
1684 static const mstring attr_bits[] =
1686 minit ("ALLOCATABLE", AB_ALLOCATABLE),
1687 minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS),
1688 minit ("DIMENSION", AB_DIMENSION),
1689 minit ("CODIMENSION", AB_CODIMENSION),
1690 minit ("CONTIGUOUS", AB_CONTIGUOUS),
1691 minit ("EXTERNAL", AB_EXTERNAL),
1692 minit ("INTRINSIC", AB_INTRINSIC),
1693 minit ("OPTIONAL", AB_OPTIONAL),
1694 minit ("POINTER", AB_POINTER),
1695 minit ("VOLATILE", AB_VOLATILE),
1696 minit ("TARGET", AB_TARGET),
1697 minit ("THREADPRIVATE", AB_THREADPRIVATE),
1698 minit ("DUMMY", AB_DUMMY),
1699 minit ("RESULT", AB_RESULT),
1700 minit ("DATA", AB_DATA),
1701 minit ("IN_NAMELIST", AB_IN_NAMELIST),
1702 minit ("IN_COMMON", AB_IN_COMMON),
1703 minit ("FUNCTION", AB_FUNCTION),
1704 minit ("SUBROUTINE", AB_SUBROUTINE),
1705 minit ("SEQUENCE", AB_SEQUENCE),
1706 minit ("ELEMENTAL", AB_ELEMENTAL),
1707 minit ("PURE", AB_PURE),
1708 minit ("RECURSIVE", AB_RECURSIVE),
1709 minit ("GENERIC", AB_GENERIC),
1710 minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT),
1711 minit ("CRAY_POINTER", AB_CRAY_POINTER),
1712 minit ("CRAY_POINTEE", AB_CRAY_POINTEE),
1713 minit ("IS_BIND_C", AB_IS_BIND_C),
1714 minit ("IS_C_INTEROP", AB_IS_C_INTEROP),
1715 minit ("IS_ISO_C", AB_IS_ISO_C),
1716 minit ("VALUE", AB_VALUE),
1717 minit ("ALLOC_COMP", AB_ALLOC_COMP),
1718 minit ("COARRAY_COMP", AB_COARRAY_COMP),
1719 minit ("POINTER_COMP", AB_POINTER_COMP),
1720 minit ("PROC_POINTER_COMP", AB_PROC_POINTER_COMP),
1721 minit ("PRIVATE_COMP", AB_PRIVATE_COMP),
1722 minit ("ZERO_COMP", AB_ZERO_COMP),
1723 minit ("PROTECTED", AB_PROTECTED),
1724 minit ("ABSTRACT", AB_ABSTRACT),
1725 minit ("IS_CLASS", AB_IS_CLASS),
1726 minit ("PROCEDURE", AB_PROCEDURE),
1727 minit ("PROC_POINTER", AB_PROC_POINTER),
1728 minit ("VTYPE", AB_VTYPE),
1729 minit ("VTAB", AB_VTAB),
1730 minit ("CLASS_POINTER", AB_CLASS_POINTER),
1731 minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE),
1732 minit (NULL, -1)
1735 /* For binding attributes. */
1736 static const mstring binding_passing[] =
1738 minit ("PASS", 0),
1739 minit ("NOPASS", 1),
1740 minit (NULL, -1)
1742 static const mstring binding_overriding[] =
1744 minit ("OVERRIDABLE", 0),
1745 minit ("NON_OVERRIDABLE", 1),
1746 minit ("DEFERRED", 2),
1747 minit (NULL, -1)
1749 static const mstring binding_generic[] =
1751 minit ("SPECIFIC", 0),
1752 minit ("GENERIC", 1),
1753 minit (NULL, -1)
1755 static const mstring binding_ppc[] =
1757 minit ("NO_PPC", 0),
1758 minit ("PPC", 1),
1759 minit (NULL, -1)
1762 /* Specialization of mio_name. */
1763 DECL_MIO_NAME (ab_attribute)
1764 DECL_MIO_NAME (ar_type)
1765 DECL_MIO_NAME (array_type)
1766 DECL_MIO_NAME (bt)
1767 DECL_MIO_NAME (expr_t)
1768 DECL_MIO_NAME (gfc_access)
1769 DECL_MIO_NAME (gfc_intrinsic_op)
1770 DECL_MIO_NAME (ifsrc)
1771 DECL_MIO_NAME (save_state)
1772 DECL_MIO_NAME (procedure_type)
1773 DECL_MIO_NAME (ref_type)
1774 DECL_MIO_NAME (sym_flavor)
1775 DECL_MIO_NAME (sym_intent)
1776 #undef DECL_MIO_NAME
1778 /* Symbol attributes are stored in list with the first three elements
1779 being the enumerated fields, while the remaining elements (if any)
1780 indicate the individual attribute bits. The access field is not
1781 saved-- it controls what symbols are exported when a module is
1782 written. */
1784 static void
1785 mio_symbol_attribute (symbol_attribute *attr)
1787 atom_type t;
1788 unsigned ext_attr,extension_level;
1790 mio_lparen ();
1792 attr->flavor = MIO_NAME (sym_flavor) (attr->flavor, flavors);
1793 attr->intent = MIO_NAME (sym_intent) (attr->intent, intents);
1794 attr->proc = MIO_NAME (procedure_type) (attr->proc, procedures);
1795 attr->if_source = MIO_NAME (ifsrc) (attr->if_source, ifsrc_types);
1796 attr->save = MIO_NAME (save_state) (attr->save, save_status);
1798 ext_attr = attr->ext_attr;
1799 mio_integer ((int *) &ext_attr);
1800 attr->ext_attr = ext_attr;
1802 extension_level = attr->extension;
1803 mio_integer ((int *) &extension_level);
1804 attr->extension = extension_level;
1806 if (iomode == IO_OUTPUT)
1808 if (attr->allocatable)
1809 MIO_NAME (ab_attribute) (AB_ALLOCATABLE, attr_bits);
1810 if (attr->asynchronous)
1811 MIO_NAME (ab_attribute) (AB_ASYNCHRONOUS, attr_bits);
1812 if (attr->dimension)
1813 MIO_NAME (ab_attribute) (AB_DIMENSION, attr_bits);
1814 if (attr->codimension)
1815 MIO_NAME (ab_attribute) (AB_CODIMENSION, attr_bits);
1816 if (attr->contiguous)
1817 MIO_NAME (ab_attribute) (AB_CONTIGUOUS, attr_bits);
1818 if (attr->external)
1819 MIO_NAME (ab_attribute) (AB_EXTERNAL, attr_bits);
1820 if (attr->intrinsic)
1821 MIO_NAME (ab_attribute) (AB_INTRINSIC, attr_bits);
1822 if (attr->optional)
1823 MIO_NAME (ab_attribute) (AB_OPTIONAL, attr_bits);
1824 if (attr->pointer)
1825 MIO_NAME (ab_attribute) (AB_POINTER, attr_bits);
1826 if (attr->class_pointer)
1827 MIO_NAME (ab_attribute) (AB_CLASS_POINTER, attr_bits);
1828 if (attr->is_protected)
1829 MIO_NAME (ab_attribute) (AB_PROTECTED, attr_bits);
1830 if (attr->value)
1831 MIO_NAME (ab_attribute) (AB_VALUE, attr_bits);
1832 if (attr->volatile_)
1833 MIO_NAME (ab_attribute) (AB_VOLATILE, attr_bits);
1834 if (attr->target)
1835 MIO_NAME (ab_attribute) (AB_TARGET, attr_bits);
1836 if (attr->threadprivate)
1837 MIO_NAME (ab_attribute) (AB_THREADPRIVATE, attr_bits);
1838 if (attr->dummy)
1839 MIO_NAME (ab_attribute) (AB_DUMMY, attr_bits);
1840 if (attr->result)
1841 MIO_NAME (ab_attribute) (AB_RESULT, attr_bits);
1842 /* We deliberately don't preserve the "entry" flag. */
1844 if (attr->data)
1845 MIO_NAME (ab_attribute) (AB_DATA, attr_bits);
1846 if (attr->in_namelist)
1847 MIO_NAME (ab_attribute) (AB_IN_NAMELIST, attr_bits);
1848 if (attr->in_common)
1849 MIO_NAME (ab_attribute) (AB_IN_COMMON, attr_bits);
1851 if (attr->function)
1852 MIO_NAME (ab_attribute) (AB_FUNCTION, attr_bits);
1853 if (attr->subroutine)
1854 MIO_NAME (ab_attribute) (AB_SUBROUTINE, attr_bits);
1855 if (attr->generic)
1856 MIO_NAME (ab_attribute) (AB_GENERIC, attr_bits);
1857 if (attr->abstract)
1858 MIO_NAME (ab_attribute) (AB_ABSTRACT, attr_bits);
1860 if (attr->sequence)
1861 MIO_NAME (ab_attribute) (AB_SEQUENCE, attr_bits);
1862 if (attr->elemental)
1863 MIO_NAME (ab_attribute) (AB_ELEMENTAL, attr_bits);
1864 if (attr->pure)
1865 MIO_NAME (ab_attribute) (AB_PURE, attr_bits);
1866 if (attr->implicit_pure)
1867 MIO_NAME (ab_attribute) (AB_IMPLICIT_PURE, attr_bits);
1868 if (attr->recursive)
1869 MIO_NAME (ab_attribute) (AB_RECURSIVE, attr_bits);
1870 if (attr->always_explicit)
1871 MIO_NAME (ab_attribute) (AB_ALWAYS_EXPLICIT, attr_bits);
1872 if (attr->cray_pointer)
1873 MIO_NAME (ab_attribute) (AB_CRAY_POINTER, attr_bits);
1874 if (attr->cray_pointee)
1875 MIO_NAME (ab_attribute) (AB_CRAY_POINTEE, attr_bits);
1876 if (attr->is_bind_c)
1877 MIO_NAME(ab_attribute) (AB_IS_BIND_C, attr_bits);
1878 if (attr->is_c_interop)
1879 MIO_NAME(ab_attribute) (AB_IS_C_INTEROP, attr_bits);
1880 if (attr->is_iso_c)
1881 MIO_NAME(ab_attribute) (AB_IS_ISO_C, attr_bits);
1882 if (attr->alloc_comp)
1883 MIO_NAME (ab_attribute) (AB_ALLOC_COMP, attr_bits);
1884 if (attr->pointer_comp)
1885 MIO_NAME (ab_attribute) (AB_POINTER_COMP, attr_bits);
1886 if (attr->proc_pointer_comp)
1887 MIO_NAME (ab_attribute) (AB_PROC_POINTER_COMP, attr_bits);
1888 if (attr->private_comp)
1889 MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits);
1890 if (attr->coarray_comp)
1891 MIO_NAME (ab_attribute) (AB_COARRAY_COMP, attr_bits);
1892 if (attr->zero_comp)
1893 MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits);
1894 if (attr->is_class)
1895 MIO_NAME (ab_attribute) (AB_IS_CLASS, attr_bits);
1896 if (attr->procedure)
1897 MIO_NAME (ab_attribute) (AB_PROCEDURE, attr_bits);
1898 if (attr->proc_pointer)
1899 MIO_NAME (ab_attribute) (AB_PROC_POINTER, attr_bits);
1900 if (attr->vtype)
1901 MIO_NAME (ab_attribute) (AB_VTYPE, attr_bits);
1902 if (attr->vtab)
1903 MIO_NAME (ab_attribute) (AB_VTAB, attr_bits);
1905 mio_rparen ();
1908 else
1910 for (;;)
1912 t = parse_atom ();
1913 if (t == ATOM_RPAREN)
1914 break;
1915 if (t != ATOM_NAME)
1916 bad_module ("Expected attribute bit name");
1918 switch ((ab_attribute) find_enum (attr_bits))
1920 case AB_ALLOCATABLE:
1921 attr->allocatable = 1;
1922 break;
1923 case AB_ASYNCHRONOUS:
1924 attr->asynchronous = 1;
1925 break;
1926 case AB_DIMENSION:
1927 attr->dimension = 1;
1928 break;
1929 case AB_CODIMENSION:
1930 attr->codimension = 1;
1931 break;
1932 case AB_CONTIGUOUS:
1933 attr->contiguous = 1;
1934 break;
1935 case AB_EXTERNAL:
1936 attr->external = 1;
1937 break;
1938 case AB_INTRINSIC:
1939 attr->intrinsic = 1;
1940 break;
1941 case AB_OPTIONAL:
1942 attr->optional = 1;
1943 break;
1944 case AB_POINTER:
1945 attr->pointer = 1;
1946 break;
1947 case AB_CLASS_POINTER:
1948 attr->class_pointer = 1;
1949 break;
1950 case AB_PROTECTED:
1951 attr->is_protected = 1;
1952 break;
1953 case AB_VALUE:
1954 attr->value = 1;
1955 break;
1956 case AB_VOLATILE:
1957 attr->volatile_ = 1;
1958 break;
1959 case AB_TARGET:
1960 attr->target = 1;
1961 break;
1962 case AB_THREADPRIVATE:
1963 attr->threadprivate = 1;
1964 break;
1965 case AB_DUMMY:
1966 attr->dummy = 1;
1967 break;
1968 case AB_RESULT:
1969 attr->result = 1;
1970 break;
1971 case AB_DATA:
1972 attr->data = 1;
1973 break;
1974 case AB_IN_NAMELIST:
1975 attr->in_namelist = 1;
1976 break;
1977 case AB_IN_COMMON:
1978 attr->in_common = 1;
1979 break;
1980 case AB_FUNCTION:
1981 attr->function = 1;
1982 break;
1983 case AB_SUBROUTINE:
1984 attr->subroutine = 1;
1985 break;
1986 case AB_GENERIC:
1987 attr->generic = 1;
1988 break;
1989 case AB_ABSTRACT:
1990 attr->abstract = 1;
1991 break;
1992 case AB_SEQUENCE:
1993 attr->sequence = 1;
1994 break;
1995 case AB_ELEMENTAL:
1996 attr->elemental = 1;
1997 break;
1998 case AB_PURE:
1999 attr->pure = 1;
2000 break;
2001 case AB_IMPLICIT_PURE:
2002 attr->implicit_pure = 1;
2003 break;
2004 case AB_RECURSIVE:
2005 attr->recursive = 1;
2006 break;
2007 case AB_ALWAYS_EXPLICIT:
2008 attr->always_explicit = 1;
2009 break;
2010 case AB_CRAY_POINTER:
2011 attr->cray_pointer = 1;
2012 break;
2013 case AB_CRAY_POINTEE:
2014 attr->cray_pointee = 1;
2015 break;
2016 case AB_IS_BIND_C:
2017 attr->is_bind_c = 1;
2018 break;
2019 case AB_IS_C_INTEROP:
2020 attr->is_c_interop = 1;
2021 break;
2022 case AB_IS_ISO_C:
2023 attr->is_iso_c = 1;
2024 break;
2025 case AB_ALLOC_COMP:
2026 attr->alloc_comp = 1;
2027 break;
2028 case AB_COARRAY_COMP:
2029 attr->coarray_comp = 1;
2030 break;
2031 case AB_POINTER_COMP:
2032 attr->pointer_comp = 1;
2033 break;
2034 case AB_PROC_POINTER_COMP:
2035 attr->proc_pointer_comp = 1;
2036 break;
2037 case AB_PRIVATE_COMP:
2038 attr->private_comp = 1;
2039 break;
2040 case AB_ZERO_COMP:
2041 attr->zero_comp = 1;
2042 break;
2043 case AB_IS_CLASS:
2044 attr->is_class = 1;
2045 break;
2046 case AB_PROCEDURE:
2047 attr->procedure = 1;
2048 break;
2049 case AB_PROC_POINTER:
2050 attr->proc_pointer = 1;
2051 break;
2052 case AB_VTYPE:
2053 attr->vtype = 1;
2054 break;
2055 case AB_VTAB:
2056 attr->vtab = 1;
2057 break;
2064 static const mstring bt_types[] = {
2065 minit ("INTEGER", BT_INTEGER),
2066 minit ("REAL", BT_REAL),
2067 minit ("COMPLEX", BT_COMPLEX),
2068 minit ("LOGICAL", BT_LOGICAL),
2069 minit ("CHARACTER", BT_CHARACTER),
2070 minit ("DERIVED", BT_DERIVED),
2071 minit ("CLASS", BT_CLASS),
2072 minit ("PROCEDURE", BT_PROCEDURE),
2073 minit ("UNKNOWN", BT_UNKNOWN),
2074 minit ("VOID", BT_VOID),
2075 minit (NULL, -1)
2079 static void
2080 mio_charlen (gfc_charlen **clp)
2082 gfc_charlen *cl;
2084 mio_lparen ();
2086 if (iomode == IO_OUTPUT)
2088 cl = *clp;
2089 if (cl != NULL)
2090 mio_expr (&cl->length);
2092 else
2094 if (peek_atom () != ATOM_RPAREN)
2096 cl = gfc_new_charlen (gfc_current_ns, NULL);
2097 mio_expr (&cl->length);
2098 *clp = cl;
2102 mio_rparen ();
2106 /* See if a name is a generated name. */
2108 static int
2109 check_unique_name (const char *name)
2111 return *name == '@';
2115 static void
2116 mio_typespec (gfc_typespec *ts)
2118 mio_lparen ();
2120 ts->type = MIO_NAME (bt) (ts->type, bt_types);
2122 if (ts->type != BT_DERIVED && ts->type != BT_CLASS)
2123 mio_integer (&ts->kind);
2124 else
2125 mio_symbol_ref (&ts->u.derived);
2127 mio_symbol_ref (&ts->interface);
2129 /* Add info for C interop and is_iso_c. */
2130 mio_integer (&ts->is_c_interop);
2131 mio_integer (&ts->is_iso_c);
2133 /* If the typespec is for an identifier either from iso_c_binding, or
2134 a constant that was initialized to an identifier from it, use the
2135 f90_type. Otherwise, use the ts->type, since it shouldn't matter. */
2136 if (ts->is_iso_c)
2137 ts->f90_type = MIO_NAME (bt) (ts->f90_type, bt_types);
2138 else
2139 ts->f90_type = MIO_NAME (bt) (ts->type, bt_types);
2141 if (ts->type != BT_CHARACTER)
2143 /* ts->u.cl is only valid for BT_CHARACTER. */
2144 mio_lparen ();
2145 mio_rparen ();
2147 else
2148 mio_charlen (&ts->u.cl);
2150 /* So as not to disturb the existing API, use an ATOM_NAME to
2151 transmit deferred characteristic for characters (F2003). */
2152 if (iomode == IO_OUTPUT)
2154 if (ts->type == BT_CHARACTER && ts->deferred)
2155 write_atom (ATOM_NAME, "DEFERRED_CL");
2157 else if (peek_atom () != ATOM_RPAREN)
2159 if (parse_atom () != ATOM_NAME)
2160 bad_module ("Expected string");
2161 ts->deferred = 1;
2164 mio_rparen ();
2168 static const mstring array_spec_types[] = {
2169 minit ("EXPLICIT", AS_EXPLICIT),
2170 minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE),
2171 minit ("DEFERRED", AS_DEFERRED),
2172 minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE),
2173 minit (NULL, -1)
2177 static void
2178 mio_array_spec (gfc_array_spec **asp)
2180 gfc_array_spec *as;
2181 int i;
2183 mio_lparen ();
2185 if (iomode == IO_OUTPUT)
2187 if (*asp == NULL)
2188 goto done;
2189 as = *asp;
2191 else
2193 if (peek_atom () == ATOM_RPAREN)
2195 *asp = NULL;
2196 goto done;
2199 *asp = as = gfc_get_array_spec ();
2202 mio_integer (&as->rank);
2203 mio_integer (&as->corank);
2204 as->type = MIO_NAME (array_type) (as->type, array_spec_types);
2206 for (i = 0; i < as->rank + as->corank; i++)
2208 mio_expr (&as->lower[i]);
2209 mio_expr (&as->upper[i]);
2212 done:
2213 mio_rparen ();
2217 /* Given a pointer to an array reference structure (which lives in a
2218 gfc_ref structure), find the corresponding array specification
2219 structure. Storing the pointer in the ref structure doesn't quite
2220 work when loading from a module. Generating code for an array
2221 reference also needs more information than just the array spec. */
2223 static const mstring array_ref_types[] = {
2224 minit ("FULL", AR_FULL),
2225 minit ("ELEMENT", AR_ELEMENT),
2226 minit ("SECTION", AR_SECTION),
2227 minit (NULL, -1)
2231 static void
2232 mio_array_ref (gfc_array_ref *ar)
2234 int i;
2236 mio_lparen ();
2237 ar->type = MIO_NAME (ar_type) (ar->type, array_ref_types);
2238 mio_integer (&ar->dimen);
2240 switch (ar->type)
2242 case AR_FULL:
2243 break;
2245 case AR_ELEMENT:
2246 for (i = 0; i < ar->dimen; i++)
2247 mio_expr (&ar->start[i]);
2249 break;
2251 case AR_SECTION:
2252 for (i = 0; i < ar->dimen; i++)
2254 mio_expr (&ar->start[i]);
2255 mio_expr (&ar->end[i]);
2256 mio_expr (&ar->stride[i]);
2259 break;
2261 case AR_UNKNOWN:
2262 gfc_internal_error ("mio_array_ref(): Unknown array ref");
2265 /* Unfortunately, ar->dimen_type is an anonymous enumerated type so
2266 we can't call mio_integer directly. Instead loop over each element
2267 and cast it to/from an integer. */
2268 if (iomode == IO_OUTPUT)
2270 for (i = 0; i < ar->dimen; i++)
2272 int tmp = (int)ar->dimen_type[i];
2273 write_atom (ATOM_INTEGER, &tmp);
2276 else
2278 for (i = 0; i < ar->dimen; i++)
2280 require_atom (ATOM_INTEGER);
2281 ar->dimen_type[i] = (enum gfc_array_ref_dimen_type) atom_int;
2285 if (iomode == IO_INPUT)
2287 ar->where = gfc_current_locus;
2289 for (i = 0; i < ar->dimen; i++)
2290 ar->c_where[i] = gfc_current_locus;
2293 mio_rparen ();
2297 /* Saves or restores a pointer. The pointer is converted back and
2298 forth from an integer. We return the pointer_info pointer so that
2299 the caller can take additional action based on the pointer type. */
2301 static pointer_info *
2302 mio_pointer_ref (void *gp)
2304 pointer_info *p;
2306 if (iomode == IO_OUTPUT)
2308 p = get_pointer (*((char **) gp));
2309 write_atom (ATOM_INTEGER, &p->integer);
2311 else
2313 require_atom (ATOM_INTEGER);
2314 p = add_fixup (atom_int, gp);
2317 return p;
2321 /* Save and load references to components that occur within
2322 expressions. We have to describe these references by a number and
2323 by name. The number is necessary for forward references during
2324 reading, and the name is necessary if the symbol already exists in
2325 the namespace and is not loaded again. */
2327 static void
2328 mio_component_ref (gfc_component **cp, gfc_symbol *sym)
2330 char name[GFC_MAX_SYMBOL_LEN + 1];
2331 gfc_component *q;
2332 pointer_info *p;
2334 p = mio_pointer_ref (cp);
2335 if (p->type == P_UNKNOWN)
2336 p->type = P_COMPONENT;
2338 if (iomode == IO_OUTPUT)
2339 mio_pool_string (&(*cp)->name);
2340 else
2342 mio_internal_string (name);
2344 if (sym && sym->attr.is_class)
2345 sym = sym->components->ts.u.derived;
2347 /* It can happen that a component reference can be read before the
2348 associated derived type symbol has been loaded. Return now and
2349 wait for a later iteration of load_needed. */
2350 if (sym == NULL)
2351 return;
2353 if (sym->components != NULL && p->u.pointer == NULL)
2355 /* Symbol already loaded, so search by name. */
2356 for (q = sym->components; q; q = q->next)
2357 if (strcmp (q->name, name) == 0)
2358 break;
2360 if (q == NULL)
2361 gfc_internal_error ("mio_component_ref(): Component not found");
2363 associate_integer_pointer (p, q);
2366 /* Make sure this symbol will eventually be loaded. */
2367 p = find_pointer2 (sym);
2368 if (p->u.rsym.state == UNUSED)
2369 p->u.rsym.state = NEEDED;
2374 static void mio_namespace_ref (gfc_namespace **nsp);
2375 static void mio_formal_arglist (gfc_formal_arglist **formal);
2376 static void mio_typebound_proc (gfc_typebound_proc** proc);
2378 static void
2379 mio_component (gfc_component *c, int vtype)
2381 pointer_info *p;
2382 int n;
2383 gfc_formal_arglist *formal;
2385 mio_lparen ();
2387 if (iomode == IO_OUTPUT)
2389 p = get_pointer (c);
2390 mio_integer (&p->integer);
2392 else
2394 mio_integer (&n);
2395 p = get_integer (n);
2396 associate_integer_pointer (p, c);
2399 if (p->type == P_UNKNOWN)
2400 p->type = P_COMPONENT;
2402 mio_pool_string (&c->name);
2403 mio_typespec (&c->ts);
2404 mio_array_spec (&c->as);
2406 mio_symbol_attribute (&c->attr);
2407 c->attr.access = MIO_NAME (gfc_access) (c->attr.access, access_types);
2409 if (!vtype)
2410 mio_expr (&c->initializer);
2412 if (c->attr.proc_pointer)
2414 if (iomode == IO_OUTPUT)
2416 formal = c->formal;
2417 while (formal && !formal->sym)
2418 formal = formal->next;
2420 if (formal)
2421 mio_namespace_ref (&formal->sym->ns);
2422 else
2423 mio_namespace_ref (&c->formal_ns);
2425 else
2427 mio_namespace_ref (&c->formal_ns);
2428 /* TODO: if (c->formal_ns)
2430 c->formal_ns->proc_name = c;
2431 c->refs++;
2435 mio_formal_arglist (&c->formal);
2437 mio_typebound_proc (&c->tb);
2440 mio_rparen ();
2444 static void
2445 mio_component_list (gfc_component **cp, int vtype)
2447 gfc_component *c, *tail;
2449 mio_lparen ();
2451 if (iomode == IO_OUTPUT)
2453 for (c = *cp; c; c = c->next)
2454 mio_component (c, vtype);
2456 else
2458 *cp = NULL;
2459 tail = NULL;
2461 for (;;)
2463 if (peek_atom () == ATOM_RPAREN)
2464 break;
2466 c = gfc_get_component ();
2467 mio_component (c, vtype);
2469 if (tail == NULL)
2470 *cp = c;
2471 else
2472 tail->next = c;
2474 tail = c;
2478 mio_rparen ();
2482 static void
2483 mio_actual_arg (gfc_actual_arglist *a)
2485 mio_lparen ();
2486 mio_pool_string (&a->name);
2487 mio_expr (&a->expr);
2488 mio_rparen ();
2492 static void
2493 mio_actual_arglist (gfc_actual_arglist **ap)
2495 gfc_actual_arglist *a, *tail;
2497 mio_lparen ();
2499 if (iomode == IO_OUTPUT)
2501 for (a = *ap; a; a = a->next)
2502 mio_actual_arg (a);
2505 else
2507 tail = NULL;
2509 for (;;)
2511 if (peek_atom () != ATOM_LPAREN)
2512 break;
2514 a = gfc_get_actual_arglist ();
2516 if (tail == NULL)
2517 *ap = a;
2518 else
2519 tail->next = a;
2521 tail = a;
2522 mio_actual_arg (a);
2526 mio_rparen ();
2530 /* Read and write formal argument lists. */
2532 static void
2533 mio_formal_arglist (gfc_formal_arglist **formal)
2535 gfc_formal_arglist *f, *tail;
2537 mio_lparen ();
2539 if (iomode == IO_OUTPUT)
2541 for (f = *formal; f; f = f->next)
2542 mio_symbol_ref (&f->sym);
2544 else
2546 *formal = tail = NULL;
2548 while (peek_atom () != ATOM_RPAREN)
2550 f = gfc_get_formal_arglist ();
2551 mio_symbol_ref (&f->sym);
2553 if (*formal == NULL)
2554 *formal = f;
2555 else
2556 tail->next = f;
2558 tail = f;
2562 mio_rparen ();
2566 /* Save or restore a reference to a symbol node. */
2568 pointer_info *
2569 mio_symbol_ref (gfc_symbol **symp)
2571 pointer_info *p;
2573 p = mio_pointer_ref (symp);
2574 if (p->type == P_UNKNOWN)
2575 p->type = P_SYMBOL;
2577 if (iomode == IO_OUTPUT)
2579 if (p->u.wsym.state == UNREFERENCED)
2580 p->u.wsym.state = NEEDS_WRITE;
2582 else
2584 if (p->u.rsym.state == UNUSED)
2585 p->u.rsym.state = NEEDED;
2587 return p;
2591 /* Save or restore a reference to a symtree node. */
2593 static void
2594 mio_symtree_ref (gfc_symtree **stp)
2596 pointer_info *p;
2597 fixup_t *f;
2599 if (iomode == IO_OUTPUT)
2600 mio_symbol_ref (&(*stp)->n.sym);
2601 else
2603 require_atom (ATOM_INTEGER);
2604 p = get_integer (atom_int);
2606 /* An unused equivalence member; make a symbol and a symtree
2607 for it. */
2608 if (in_load_equiv && p->u.rsym.symtree == NULL)
2610 /* Since this is not used, it must have a unique name. */
2611 p->u.rsym.symtree = gfc_get_unique_symtree (gfc_current_ns);
2613 /* Make the symbol. */
2614 if (p->u.rsym.sym == NULL)
2616 p->u.rsym.sym = gfc_new_symbol (p->u.rsym.true_name,
2617 gfc_current_ns);
2618 p->u.rsym.sym->module = gfc_get_string (p->u.rsym.module);
2621 p->u.rsym.symtree->n.sym = p->u.rsym.sym;
2622 p->u.rsym.symtree->n.sym->refs++;
2623 p->u.rsym.referenced = 1;
2625 /* If the symbol is PRIVATE and in COMMON, load_commons will
2626 generate a fixup symbol, which must be associated. */
2627 if (p->fixup)
2628 resolve_fixups (p->fixup, p->u.rsym.sym);
2629 p->fixup = NULL;
2632 if (p->type == P_UNKNOWN)
2633 p->type = P_SYMBOL;
2635 if (p->u.rsym.state == UNUSED)
2636 p->u.rsym.state = NEEDED;
2638 if (p->u.rsym.symtree != NULL)
2640 *stp = p->u.rsym.symtree;
2642 else
2644 f = XCNEW (fixup_t);
2646 f->next = p->u.rsym.stfixup;
2647 p->u.rsym.stfixup = f;
2649 f->pointer = (void **) stp;
2655 static void
2656 mio_iterator (gfc_iterator **ip)
2658 gfc_iterator *iter;
2660 mio_lparen ();
2662 if (iomode == IO_OUTPUT)
2664 if (*ip == NULL)
2665 goto done;
2667 else
2669 if (peek_atom () == ATOM_RPAREN)
2671 *ip = NULL;
2672 goto done;
2675 *ip = gfc_get_iterator ();
2678 iter = *ip;
2680 mio_expr (&iter->var);
2681 mio_expr (&iter->start);
2682 mio_expr (&iter->end);
2683 mio_expr (&iter->step);
2685 done:
2686 mio_rparen ();
2690 static void
2691 mio_constructor (gfc_constructor_base *cp)
2693 gfc_constructor *c;
2695 mio_lparen ();
2697 if (iomode == IO_OUTPUT)
2699 for (c = gfc_constructor_first (*cp); c; c = gfc_constructor_next (c))
2701 mio_lparen ();
2702 mio_expr (&c->expr);
2703 mio_iterator (&c->iterator);
2704 mio_rparen ();
2707 else
2709 while (peek_atom () != ATOM_RPAREN)
2711 c = gfc_constructor_append_expr (cp, NULL, NULL);
2713 mio_lparen ();
2714 mio_expr (&c->expr);
2715 mio_iterator (&c->iterator);
2716 mio_rparen ();
2720 mio_rparen ();
2724 static const mstring ref_types[] = {
2725 minit ("ARRAY", REF_ARRAY),
2726 minit ("COMPONENT", REF_COMPONENT),
2727 minit ("SUBSTRING", REF_SUBSTRING),
2728 minit (NULL, -1)
2732 static void
2733 mio_ref (gfc_ref **rp)
2735 gfc_ref *r;
2737 mio_lparen ();
2739 r = *rp;
2740 r->type = MIO_NAME (ref_type) (r->type, ref_types);
2742 switch (r->type)
2744 case REF_ARRAY:
2745 mio_array_ref (&r->u.ar);
2746 break;
2748 case REF_COMPONENT:
2749 mio_symbol_ref (&r->u.c.sym);
2750 mio_component_ref (&r->u.c.component, r->u.c.sym);
2751 break;
2753 case REF_SUBSTRING:
2754 mio_expr (&r->u.ss.start);
2755 mio_expr (&r->u.ss.end);
2756 mio_charlen (&r->u.ss.length);
2757 break;
2760 mio_rparen ();
2764 static void
2765 mio_ref_list (gfc_ref **rp)
2767 gfc_ref *ref, *head, *tail;
2769 mio_lparen ();
2771 if (iomode == IO_OUTPUT)
2773 for (ref = *rp; ref; ref = ref->next)
2774 mio_ref (&ref);
2776 else
2778 head = tail = NULL;
2780 while (peek_atom () != ATOM_RPAREN)
2782 if (head == NULL)
2783 head = tail = gfc_get_ref ();
2784 else
2786 tail->next = gfc_get_ref ();
2787 tail = tail->next;
2790 mio_ref (&tail);
2793 *rp = head;
2796 mio_rparen ();
2800 /* Read and write an integer value. */
2802 static void
2803 mio_gmp_integer (mpz_t *integer)
2805 char *p;
2807 if (iomode == IO_INPUT)
2809 if (parse_atom () != ATOM_STRING)
2810 bad_module ("Expected integer string");
2812 mpz_init (*integer);
2813 if (mpz_set_str (*integer, atom_string, 10))
2814 bad_module ("Error converting integer");
2816 gfc_free (atom_string);
2818 else
2820 p = mpz_get_str (NULL, 10, *integer);
2821 write_atom (ATOM_STRING, p);
2822 gfc_free (p);
2827 static void
2828 mio_gmp_real (mpfr_t *real)
2830 mp_exp_t exponent;
2831 char *p;
2833 if (iomode == IO_INPUT)
2835 if (parse_atom () != ATOM_STRING)
2836 bad_module ("Expected real string");
2838 mpfr_init (*real);
2839 mpfr_set_str (*real, atom_string, 16, GFC_RND_MODE);
2840 gfc_free (atom_string);
2842 else
2844 p = mpfr_get_str (NULL, &exponent, 16, 0, *real, GFC_RND_MODE);
2846 if (mpfr_nan_p (*real) || mpfr_inf_p (*real))
2848 write_atom (ATOM_STRING, p);
2849 gfc_free (p);
2850 return;
2853 atom_string = XCNEWVEC (char, strlen (p) + 20);
2855 sprintf (atom_string, "0.%s@%ld", p, exponent);
2857 /* Fix negative numbers. */
2858 if (atom_string[2] == '-')
2860 atom_string[0] = '-';
2861 atom_string[1] = '0';
2862 atom_string[2] = '.';
2865 write_atom (ATOM_STRING, atom_string);
2867 gfc_free (atom_string);
2868 gfc_free (p);
2873 /* Save and restore the shape of an array constructor. */
2875 static void
2876 mio_shape (mpz_t **pshape, int rank)
2878 mpz_t *shape;
2879 atom_type t;
2880 int n;
2882 /* A NULL shape is represented by (). */
2883 mio_lparen ();
2885 if (iomode == IO_OUTPUT)
2887 shape = *pshape;
2888 if (!shape)
2890 mio_rparen ();
2891 return;
2894 else
2896 t = peek_atom ();
2897 if (t == ATOM_RPAREN)
2899 *pshape = NULL;
2900 mio_rparen ();
2901 return;
2904 shape = gfc_get_shape (rank);
2905 *pshape = shape;
2908 for (n = 0; n < rank; n++)
2909 mio_gmp_integer (&shape[n]);
2911 mio_rparen ();
2915 static const mstring expr_types[] = {
2916 minit ("OP", EXPR_OP),
2917 minit ("FUNCTION", EXPR_FUNCTION),
2918 minit ("CONSTANT", EXPR_CONSTANT),
2919 minit ("VARIABLE", EXPR_VARIABLE),
2920 minit ("SUBSTRING", EXPR_SUBSTRING),
2921 minit ("STRUCTURE", EXPR_STRUCTURE),
2922 minit ("ARRAY", EXPR_ARRAY),
2923 minit ("NULL", EXPR_NULL),
2924 minit ("COMPCALL", EXPR_COMPCALL),
2925 minit (NULL, -1)
2928 /* INTRINSIC_ASSIGN is missing because it is used as an index for
2929 generic operators, not in expressions. INTRINSIC_USER is also
2930 replaced by the correct function name by the time we see it. */
2932 static const mstring intrinsics[] =
2934 minit ("UPLUS", INTRINSIC_UPLUS),
2935 minit ("UMINUS", INTRINSIC_UMINUS),
2936 minit ("PLUS", INTRINSIC_PLUS),
2937 minit ("MINUS", INTRINSIC_MINUS),
2938 minit ("TIMES", INTRINSIC_TIMES),
2939 minit ("DIVIDE", INTRINSIC_DIVIDE),
2940 minit ("POWER", INTRINSIC_POWER),
2941 minit ("CONCAT", INTRINSIC_CONCAT),
2942 minit ("AND", INTRINSIC_AND),
2943 minit ("OR", INTRINSIC_OR),
2944 minit ("EQV", INTRINSIC_EQV),
2945 minit ("NEQV", INTRINSIC_NEQV),
2946 minit ("EQ_SIGN", INTRINSIC_EQ),
2947 minit ("EQ", INTRINSIC_EQ_OS),
2948 minit ("NE_SIGN", INTRINSIC_NE),
2949 minit ("NE", INTRINSIC_NE_OS),
2950 minit ("GT_SIGN", INTRINSIC_GT),
2951 minit ("GT", INTRINSIC_GT_OS),
2952 minit ("GE_SIGN", INTRINSIC_GE),
2953 minit ("GE", INTRINSIC_GE_OS),
2954 minit ("LT_SIGN", INTRINSIC_LT),
2955 minit ("LT", INTRINSIC_LT_OS),
2956 minit ("LE_SIGN", INTRINSIC_LE),
2957 minit ("LE", INTRINSIC_LE_OS),
2958 minit ("NOT", INTRINSIC_NOT),
2959 minit ("PARENTHESES", INTRINSIC_PARENTHESES),
2960 minit (NULL, -1)
2964 /* Remedy a couple of situations where the gfc_expr's can be defective. */
2966 static void
2967 fix_mio_expr (gfc_expr *e)
2969 gfc_symtree *ns_st = NULL;
2970 const char *fname;
2972 if (iomode != IO_OUTPUT)
2973 return;
2975 if (e->symtree)
2977 /* If this is a symtree for a symbol that came from a contained module
2978 namespace, it has a unique name and we should look in the current
2979 namespace to see if the required, non-contained symbol is available
2980 yet. If so, the latter should be written. */
2981 if (e->symtree->n.sym && check_unique_name (e->symtree->name))
2982 ns_st = gfc_find_symtree (gfc_current_ns->sym_root,
2983 e->symtree->n.sym->name);
2985 /* On the other hand, if the existing symbol is the module name or the
2986 new symbol is a dummy argument, do not do the promotion. */
2987 if (ns_st && ns_st->n.sym
2988 && ns_st->n.sym->attr.flavor != FL_MODULE
2989 && !e->symtree->n.sym->attr.dummy)
2990 e->symtree = ns_st;
2992 else if (e->expr_type == EXPR_FUNCTION && e->value.function.name)
2994 gfc_symbol *sym;
2996 /* In some circumstances, a function used in an initialization
2997 expression, in one use associated module, can fail to be
2998 coupled to its symtree when used in a specification
2999 expression in another module. */
3000 fname = e->value.function.esym ? e->value.function.esym->name
3001 : e->value.function.isym->name;
3002 e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
3004 if (e->symtree)
3005 return;
3007 /* This is probably a reference to a private procedure from another
3008 module. To prevent a segfault, make a generic with no specific
3009 instances. If this module is used, without the required
3010 specific coming from somewhere, the appropriate error message
3011 is issued. */
3012 gfc_get_symbol (fname, gfc_current_ns, &sym);
3013 sym->attr.flavor = FL_PROCEDURE;
3014 sym->attr.generic = 1;
3015 e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
3020 /* Read and write expressions. The form "()" is allowed to indicate a
3021 NULL expression. */
3023 static void
3024 mio_expr (gfc_expr **ep)
3026 gfc_expr *e;
3027 atom_type t;
3028 int flag;
3030 mio_lparen ();
3032 if (iomode == IO_OUTPUT)
3034 if (*ep == NULL)
3036 mio_rparen ();
3037 return;
3040 e = *ep;
3041 MIO_NAME (expr_t) (e->expr_type, expr_types);
3043 else
3045 t = parse_atom ();
3046 if (t == ATOM_RPAREN)
3048 *ep = NULL;
3049 return;
3052 if (t != ATOM_NAME)
3053 bad_module ("Expected expression type");
3055 e = *ep = gfc_get_expr ();
3056 e->where = gfc_current_locus;
3057 e->expr_type = (expr_t) find_enum (expr_types);
3060 mio_typespec (&e->ts);
3061 mio_integer (&e->rank);
3063 fix_mio_expr (e);
3065 switch (e->expr_type)
3067 case EXPR_OP:
3068 e->value.op.op
3069 = MIO_NAME (gfc_intrinsic_op) (e->value.op.op, intrinsics);
3071 switch (e->value.op.op)
3073 case INTRINSIC_UPLUS:
3074 case INTRINSIC_UMINUS:
3075 case INTRINSIC_NOT:
3076 case INTRINSIC_PARENTHESES:
3077 mio_expr (&e->value.op.op1);
3078 break;
3080 case INTRINSIC_PLUS:
3081 case INTRINSIC_MINUS:
3082 case INTRINSIC_TIMES:
3083 case INTRINSIC_DIVIDE:
3084 case INTRINSIC_POWER:
3085 case INTRINSIC_CONCAT:
3086 case INTRINSIC_AND:
3087 case INTRINSIC_OR:
3088 case INTRINSIC_EQV:
3089 case INTRINSIC_NEQV:
3090 case INTRINSIC_EQ:
3091 case INTRINSIC_EQ_OS:
3092 case INTRINSIC_NE:
3093 case INTRINSIC_NE_OS:
3094 case INTRINSIC_GT:
3095 case INTRINSIC_GT_OS:
3096 case INTRINSIC_GE:
3097 case INTRINSIC_GE_OS:
3098 case INTRINSIC_LT:
3099 case INTRINSIC_LT_OS:
3100 case INTRINSIC_LE:
3101 case INTRINSIC_LE_OS:
3102 mio_expr (&e->value.op.op1);
3103 mio_expr (&e->value.op.op2);
3104 break;
3106 default:
3107 bad_module ("Bad operator");
3110 break;
3112 case EXPR_FUNCTION:
3113 mio_symtree_ref (&e->symtree);
3114 mio_actual_arglist (&e->value.function.actual);
3116 if (iomode == IO_OUTPUT)
3118 e->value.function.name
3119 = mio_allocated_string (e->value.function.name);
3120 flag = e->value.function.esym != NULL;
3121 mio_integer (&flag);
3122 if (flag)
3123 mio_symbol_ref (&e->value.function.esym);
3124 else
3125 write_atom (ATOM_STRING, e->value.function.isym->name);
3127 else
3129 require_atom (ATOM_STRING);
3130 e->value.function.name = gfc_get_string (atom_string);
3131 gfc_free (atom_string);
3133 mio_integer (&flag);
3134 if (flag)
3135 mio_symbol_ref (&e->value.function.esym);
3136 else
3138 require_atom (ATOM_STRING);
3139 e->value.function.isym = gfc_find_function (atom_string);
3140 gfc_free (atom_string);
3144 break;
3146 case EXPR_VARIABLE:
3147 mio_symtree_ref (&e->symtree);
3148 mio_ref_list (&e->ref);
3149 break;
3151 case EXPR_SUBSTRING:
3152 e->value.character.string
3153 = CONST_CAST (gfc_char_t *,
3154 mio_allocated_wide_string (e->value.character.string,
3155 e->value.character.length));
3156 mio_ref_list (&e->ref);
3157 break;
3159 case EXPR_STRUCTURE:
3160 case EXPR_ARRAY:
3161 mio_constructor (&e->value.constructor);
3162 mio_shape (&e->shape, e->rank);
3163 break;
3165 case EXPR_CONSTANT:
3166 switch (e->ts.type)
3168 case BT_INTEGER:
3169 mio_gmp_integer (&e->value.integer);
3170 break;
3172 case BT_REAL:
3173 gfc_set_model_kind (e->ts.kind);
3174 mio_gmp_real (&e->value.real);
3175 break;
3177 case BT_COMPLEX:
3178 gfc_set_model_kind (e->ts.kind);
3179 mio_gmp_real (&mpc_realref (e->value.complex));
3180 mio_gmp_real (&mpc_imagref (e->value.complex));
3181 break;
3183 case BT_LOGICAL:
3184 mio_integer (&e->value.logical);
3185 break;
3187 case BT_CHARACTER:
3188 mio_integer (&e->value.character.length);
3189 e->value.character.string
3190 = CONST_CAST (gfc_char_t *,
3191 mio_allocated_wide_string (e->value.character.string,
3192 e->value.character.length));
3193 break;
3195 default:
3196 bad_module ("Bad type in constant expression");
3199 break;
3201 case EXPR_NULL:
3202 break;
3204 case EXPR_COMPCALL:
3205 case EXPR_PPC:
3206 gcc_unreachable ();
3207 break;
3210 mio_rparen ();
3214 /* Read and write namelists. */
3216 static void
3217 mio_namelist (gfc_symbol *sym)
3219 gfc_namelist *n, *m;
3220 const char *check_name;
3222 mio_lparen ();
3224 if (iomode == IO_OUTPUT)
3226 for (n = sym->namelist; n; n = n->next)
3227 mio_symbol_ref (&n->sym);
3229 else
3231 /* This departure from the standard is flagged as an error.
3232 It does, in fact, work correctly. TODO: Allow it
3233 conditionally? */
3234 if (sym->attr.flavor == FL_NAMELIST)
3236 check_name = find_use_name (sym->name, false);
3237 if (check_name && strcmp (check_name, sym->name) != 0)
3238 gfc_error ("Namelist %s cannot be renamed by USE "
3239 "association to %s", sym->name, check_name);
3242 m = NULL;
3243 while (peek_atom () != ATOM_RPAREN)
3245 n = gfc_get_namelist ();
3246 mio_symbol_ref (&n->sym);
3248 if (sym->namelist == NULL)
3249 sym->namelist = n;
3250 else
3251 m->next = n;
3253 m = n;
3255 sym->namelist_tail = m;
3258 mio_rparen ();
3262 /* Save/restore lists of gfc_interface structures. When loading an
3263 interface, we are really appending to the existing list of
3264 interfaces. Checking for duplicate and ambiguous interfaces has to
3265 be done later when all symbols have been loaded. */
3267 pointer_info *
3268 mio_interface_rest (gfc_interface **ip)
3270 gfc_interface *tail, *p;
3271 pointer_info *pi = NULL;
3273 if (iomode == IO_OUTPUT)
3275 if (ip != NULL)
3276 for (p = *ip; p; p = p->next)
3277 mio_symbol_ref (&p->sym);
3279 else
3281 if (*ip == NULL)
3282 tail = NULL;
3283 else
3285 tail = *ip;
3286 while (tail->next)
3287 tail = tail->next;
3290 for (;;)
3292 if (peek_atom () == ATOM_RPAREN)
3293 break;
3295 p = gfc_get_interface ();
3296 p->where = gfc_current_locus;
3297 pi = mio_symbol_ref (&p->sym);
3299 if (tail == NULL)
3300 *ip = p;
3301 else
3302 tail->next = p;
3304 tail = p;
3308 mio_rparen ();
3309 return pi;
3313 /* Save/restore a nameless operator interface. */
3315 static void
3316 mio_interface (gfc_interface **ip)
3318 mio_lparen ();
3319 mio_interface_rest (ip);
3323 /* Save/restore a named operator interface. */
3325 static void
3326 mio_symbol_interface (const char **name, const char **module,
3327 gfc_interface **ip)
3329 mio_lparen ();
3330 mio_pool_string (name);
3331 mio_pool_string (module);
3332 mio_interface_rest (ip);
3336 static void
3337 mio_namespace_ref (gfc_namespace **nsp)
3339 gfc_namespace *ns;
3340 pointer_info *p;
3342 p = mio_pointer_ref (nsp);
3344 if (p->type == P_UNKNOWN)
3345 p->type = P_NAMESPACE;
3347 if (iomode == IO_INPUT && p->integer != 0)
3349 ns = (gfc_namespace *) p->u.pointer;
3350 if (ns == NULL)
3352 ns = gfc_get_namespace (NULL, 0);
3353 associate_integer_pointer (p, ns);
3355 else
3356 ns->refs++;
3361 /* Save/restore the f2k_derived namespace of a derived-type symbol. */
3363 static gfc_namespace* current_f2k_derived;
3365 static void
3366 mio_typebound_proc (gfc_typebound_proc** proc)
3368 int flag;
3369 int overriding_flag;
3371 if (iomode == IO_INPUT)
3373 *proc = gfc_get_typebound_proc (NULL);
3374 (*proc)->where = gfc_current_locus;
3376 gcc_assert (*proc);
3378 mio_lparen ();
3380 (*proc)->access = MIO_NAME (gfc_access) ((*proc)->access, access_types);
3382 /* IO the NON_OVERRIDABLE/DEFERRED combination. */
3383 gcc_assert (!((*proc)->deferred && (*proc)->non_overridable));
3384 overriding_flag = ((*proc)->deferred << 1) | (*proc)->non_overridable;
3385 overriding_flag = mio_name (overriding_flag, binding_overriding);
3386 (*proc)->deferred = ((overriding_flag & 2) != 0);
3387 (*proc)->non_overridable = ((overriding_flag & 1) != 0);
3388 gcc_assert (!((*proc)->deferred && (*proc)->non_overridable));
3390 (*proc)->nopass = mio_name ((*proc)->nopass, binding_passing);
3391 (*proc)->is_generic = mio_name ((*proc)->is_generic, binding_generic);
3392 (*proc)->ppc = mio_name((*proc)->ppc, binding_ppc);
3394 mio_pool_string (&((*proc)->pass_arg));
3396 flag = (int) (*proc)->pass_arg_num;
3397 mio_integer (&flag);
3398 (*proc)->pass_arg_num = (unsigned) flag;
3400 if ((*proc)->is_generic)
3402 gfc_tbp_generic* g;
3404 mio_lparen ();
3406 if (iomode == IO_OUTPUT)
3407 for (g = (*proc)->u.generic; g; g = g->next)
3408 mio_allocated_string (g->specific_st->name);
3409 else
3411 (*proc)->u.generic = NULL;
3412 while (peek_atom () != ATOM_RPAREN)
3414 gfc_symtree** sym_root;
3416 g = gfc_get_tbp_generic ();
3417 g->specific = NULL;
3419 require_atom (ATOM_STRING);
3420 sym_root = &current_f2k_derived->tb_sym_root;
3421 g->specific_st = gfc_get_tbp_symtree (sym_root, atom_string);
3422 gfc_free (atom_string);
3424 g->next = (*proc)->u.generic;
3425 (*proc)->u.generic = g;
3429 mio_rparen ();
3431 else if (!(*proc)->ppc)
3432 mio_symtree_ref (&(*proc)->u.specific);
3434 mio_rparen ();
3437 /* Walker-callback function for this purpose. */
3438 static void
3439 mio_typebound_symtree (gfc_symtree* st)
3441 if (iomode == IO_OUTPUT && !st->n.tb)
3442 return;
3444 if (iomode == IO_OUTPUT)
3446 mio_lparen ();
3447 mio_allocated_string (st->name);
3449 /* For IO_INPUT, the above is done in mio_f2k_derived. */
3451 mio_typebound_proc (&st->n.tb);
3452 mio_rparen ();
3455 /* IO a full symtree (in all depth). */
3456 static void
3457 mio_full_typebound_tree (gfc_symtree** root)
3459 mio_lparen ();
3461 if (iomode == IO_OUTPUT)
3462 gfc_traverse_symtree (*root, &mio_typebound_symtree);
3463 else
3465 while (peek_atom () == ATOM_LPAREN)
3467 gfc_symtree* st;
3469 mio_lparen ();
3471 require_atom (ATOM_STRING);
3472 st = gfc_get_tbp_symtree (root, atom_string);
3473 gfc_free (atom_string);
3475 mio_typebound_symtree (st);
3479 mio_rparen ();
3482 static void
3483 mio_finalizer (gfc_finalizer **f)
3485 if (iomode == IO_OUTPUT)
3487 gcc_assert (*f);
3488 gcc_assert ((*f)->proc_tree); /* Should already be resolved. */
3489 mio_symtree_ref (&(*f)->proc_tree);
3491 else
3493 *f = gfc_get_finalizer ();
3494 (*f)->where = gfc_current_locus; /* Value should not matter. */
3495 (*f)->next = NULL;
3497 mio_symtree_ref (&(*f)->proc_tree);
3498 (*f)->proc_sym = NULL;
3502 static void
3503 mio_f2k_derived (gfc_namespace *f2k)
3505 current_f2k_derived = f2k;
3507 /* Handle the list of finalizer procedures. */
3508 mio_lparen ();
3509 if (iomode == IO_OUTPUT)
3511 gfc_finalizer *f;
3512 for (f = f2k->finalizers; f; f = f->next)
3513 mio_finalizer (&f);
3515 else
3517 f2k->finalizers = NULL;
3518 while (peek_atom () != ATOM_RPAREN)
3520 gfc_finalizer *cur = NULL;
3521 mio_finalizer (&cur);
3522 cur->next = f2k->finalizers;
3523 f2k->finalizers = cur;
3526 mio_rparen ();
3528 /* Handle type-bound procedures. */
3529 mio_full_typebound_tree (&f2k->tb_sym_root);
3531 /* Type-bound user operators. */
3532 mio_full_typebound_tree (&f2k->tb_uop_root);
3534 /* Type-bound intrinsic operators. */
3535 mio_lparen ();
3536 if (iomode == IO_OUTPUT)
3538 int op;
3539 for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; ++op)
3541 gfc_intrinsic_op realop;
3543 if (op == INTRINSIC_USER || !f2k->tb_op[op])
3544 continue;
3546 mio_lparen ();
3547 realop = (gfc_intrinsic_op) op;
3548 mio_intrinsic_op (&realop);
3549 mio_typebound_proc (&f2k->tb_op[op]);
3550 mio_rparen ();
3553 else
3554 while (peek_atom () != ATOM_RPAREN)
3556 gfc_intrinsic_op op = GFC_INTRINSIC_BEGIN; /* Silence GCC. */
3558 mio_lparen ();
3559 mio_intrinsic_op (&op);
3560 mio_typebound_proc (&f2k->tb_op[op]);
3561 mio_rparen ();
3563 mio_rparen ();
3566 static void
3567 mio_full_f2k_derived (gfc_symbol *sym)
3569 mio_lparen ();
3571 if (iomode == IO_OUTPUT)
3573 if (sym->f2k_derived)
3574 mio_f2k_derived (sym->f2k_derived);
3576 else
3578 if (peek_atom () != ATOM_RPAREN)
3580 sym->f2k_derived = gfc_get_namespace (NULL, 0);
3581 mio_f2k_derived (sym->f2k_derived);
3583 else
3584 gcc_assert (!sym->f2k_derived);
3587 mio_rparen ();
3591 /* Unlike most other routines, the address of the symbol node is already
3592 fixed on input and the name/module has already been filled in. */
3594 static void
3595 mio_symbol (gfc_symbol *sym)
3597 int intmod = INTMOD_NONE;
3599 mio_lparen ();
3601 mio_symbol_attribute (&sym->attr);
3602 mio_typespec (&sym->ts);
3604 if (iomode == IO_OUTPUT)
3605 mio_namespace_ref (&sym->formal_ns);
3606 else
3608 mio_namespace_ref (&sym->formal_ns);
3609 if (sym->formal_ns)
3611 sym->formal_ns->proc_name = sym;
3612 sym->refs++;
3616 /* Save/restore common block links. */
3617 mio_symbol_ref (&sym->common_next);
3619 mio_formal_arglist (&sym->formal);
3621 if (sym->attr.flavor == FL_PARAMETER)
3622 mio_expr (&sym->value);
3624 mio_array_spec (&sym->as);
3626 mio_symbol_ref (&sym->result);
3628 if (sym->attr.cray_pointee)
3629 mio_symbol_ref (&sym->cp_pointer);
3631 /* Note that components are always saved, even if they are supposed
3632 to be private. Component access is checked during searching. */
3634 mio_component_list (&sym->components, sym->attr.vtype);
3636 if (sym->components != NULL)
3637 sym->component_access
3638 = MIO_NAME (gfc_access) (sym->component_access, access_types);
3640 /* Load/save the f2k_derived namespace of a derived-type symbol. */
3641 mio_full_f2k_derived (sym);
3643 mio_namelist (sym);
3645 /* Add the fields that say whether this is from an intrinsic module,
3646 and if so, what symbol it is within the module. */
3647 /* mio_integer (&(sym->from_intmod)); */
3648 if (iomode == IO_OUTPUT)
3650 intmod = sym->from_intmod;
3651 mio_integer (&intmod);
3653 else
3655 mio_integer (&intmod);
3656 sym->from_intmod = (intmod_id) intmod;
3659 mio_integer (&(sym->intmod_sym_id));
3661 if (sym->attr.flavor == FL_DERIVED)
3662 mio_integer (&(sym->hash_value));
3664 mio_rparen ();
3668 /************************* Top level subroutines *************************/
3670 /* Given a root symtree node and a symbol, try to find a symtree that
3671 references the symbol that is not a unique name. */
3673 static gfc_symtree *
3674 find_symtree_for_symbol (gfc_symtree *st, gfc_symbol *sym)
3676 gfc_symtree *s = NULL;
3678 if (st == NULL)
3679 return s;
3681 s = find_symtree_for_symbol (st->right, sym);
3682 if (s != NULL)
3683 return s;
3684 s = find_symtree_for_symbol (st->left, sym);
3685 if (s != NULL)
3686 return s;
3688 if (st->n.sym == sym && !check_unique_name (st->name))
3689 return st;
3691 return s;
3695 /* A recursive function to look for a specific symbol by name and by
3696 module. Whilst several symtrees might point to one symbol, its
3697 is sufficient for the purposes here than one exist. Note that
3698 generic interfaces are distinguished as are symbols that have been
3699 renamed in another module. */
3700 static gfc_symtree *
3701 find_symbol (gfc_symtree *st, const char *name,
3702 const char *module, int generic)
3704 int c;
3705 gfc_symtree *retval, *s;
3707 if (st == NULL || st->n.sym == NULL)
3708 return NULL;
3710 c = strcmp (name, st->n.sym->name);
3711 if (c == 0 && st->n.sym->module
3712 && strcmp (module, st->n.sym->module) == 0
3713 && !check_unique_name (st->name))
3715 s = gfc_find_symtree (gfc_current_ns->sym_root, name);
3717 /* Detect symbols that are renamed by use association in another
3718 module by the absence of a symtree and null attr.use_rename,
3719 since the latter is not transmitted in the module file. */
3720 if (((!generic && !st->n.sym->attr.generic)
3721 || (generic && st->n.sym->attr.generic))
3722 && !(s == NULL && !st->n.sym->attr.use_rename))
3723 return st;
3726 retval = find_symbol (st->left, name, module, generic);
3728 if (retval == NULL)
3729 retval = find_symbol (st->right, name, module, generic);
3731 return retval;
3735 /* Skip a list between balanced left and right parens. */
3737 static void
3738 skip_list (void)
3740 int level;
3742 level = 0;
3745 switch (parse_atom ())
3747 case ATOM_LPAREN:
3748 level++;
3749 break;
3751 case ATOM_RPAREN:
3752 level--;
3753 break;
3755 case ATOM_STRING:
3756 gfc_free (atom_string);
3757 break;
3759 case ATOM_NAME:
3760 case ATOM_INTEGER:
3761 break;
3764 while (level > 0);
3768 /* Load operator interfaces from the module. Interfaces are unusual
3769 in that they attach themselves to existing symbols. */
3771 static void
3772 load_operator_interfaces (void)
3774 const char *p;
3775 char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
3776 gfc_user_op *uop;
3777 pointer_info *pi = NULL;
3778 int n, i;
3780 mio_lparen ();
3782 while (peek_atom () != ATOM_RPAREN)
3784 mio_lparen ();
3786 mio_internal_string (name);
3787 mio_internal_string (module);
3789 n = number_use_names (name, true);
3790 n = n ? n : 1;
3792 for (i = 1; i <= n; i++)
3794 /* Decide if we need to load this one or not. */
3795 p = find_use_name_n (name, &i, true);
3797 if (p == NULL)
3799 while (parse_atom () != ATOM_RPAREN);
3800 continue;
3803 if (i == 1)
3805 uop = gfc_get_uop (p);
3806 pi = mio_interface_rest (&uop->op);
3808 else
3810 if (gfc_find_uop (p, NULL))
3811 continue;
3812 uop = gfc_get_uop (p);
3813 uop->op = gfc_get_interface ();
3814 uop->op->where = gfc_current_locus;
3815 add_fixup (pi->integer, &uop->op->sym);
3820 mio_rparen ();
3824 /* Load interfaces from the module. Interfaces are unusual in that
3825 they attach themselves to existing symbols. */
3827 static void
3828 load_generic_interfaces (void)
3830 const char *p;
3831 char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
3832 gfc_symbol *sym;
3833 gfc_interface *generic = NULL, *gen = NULL;
3834 int n, i, renamed;
3835 bool ambiguous_set = false;
3837 mio_lparen ();
3839 while (peek_atom () != ATOM_RPAREN)
3841 mio_lparen ();
3843 mio_internal_string (name);
3844 mio_internal_string (module);
3846 n = number_use_names (name, false);
3847 renamed = n ? 1 : 0;
3848 n = n ? n : 1;
3850 for (i = 1; i <= n; i++)
3852 gfc_symtree *st;
3853 /* Decide if we need to load this one or not. */
3854 p = find_use_name_n (name, &i, false);
3856 st = find_symbol (gfc_current_ns->sym_root,
3857 name, module_name, 1);
3859 if (!p || gfc_find_symbol (p, NULL, 0, &sym))
3861 /* Skip the specific names for these cases. */
3862 while (i == 1 && parse_atom () != ATOM_RPAREN);
3864 continue;
3867 /* If the symbol exists already and is being USEd without being
3868 in an ONLY clause, do not load a new symtree(11.3.2). */
3869 if (!only_flag && st)
3870 sym = st->n.sym;
3872 if (!sym)
3874 /* Make the symbol inaccessible if it has been added by a USE
3875 statement without an ONLY(11.3.2). */
3876 if (st && only_flag
3877 && !st->n.sym->attr.use_only
3878 && !st->n.sym->attr.use_rename
3879 && strcmp (st->n.sym->module, module_name) == 0)
3881 sym = st->n.sym;
3882 gfc_delete_symtree (&gfc_current_ns->sym_root, name);
3883 st = gfc_get_unique_symtree (gfc_current_ns);
3884 st->n.sym = sym;
3885 sym = NULL;
3887 else if (st)
3889 sym = st->n.sym;
3890 if (strcmp (st->name, p) != 0)
3892 st = gfc_new_symtree (&gfc_current_ns->sym_root, p);
3893 st->n.sym = sym;
3894 sym->refs++;
3898 /* Since we haven't found a valid generic interface, we had
3899 better make one. */
3900 if (!sym)
3902 gfc_get_symbol (p, NULL, &sym);
3903 sym->name = gfc_get_string (name);
3904 sym->module = gfc_get_string (module_name);
3905 sym->attr.flavor = FL_PROCEDURE;
3906 sym->attr.generic = 1;
3907 sym->attr.use_assoc = 1;
3910 else
3912 /* Unless sym is a generic interface, this reference
3913 is ambiguous. */
3914 if (st == NULL)
3915 st = gfc_find_symtree (gfc_current_ns->sym_root, p);
3917 sym = st->n.sym;
3919 if (st && !sym->attr.generic
3920 && !st->ambiguous
3921 && sym->module
3922 && strcmp(module, sym->module))
3924 ambiguous_set = true;
3925 st->ambiguous = 1;
3929 sym->attr.use_only = only_flag;
3930 sym->attr.use_rename = renamed;
3932 if (i == 1)
3934 mio_interface_rest (&sym->generic);
3935 generic = sym->generic;
3937 else if (!sym->generic)
3939 sym->generic = generic;
3940 sym->attr.generic_copy = 1;
3943 /* If a procedure that is not generic has generic interfaces
3944 that include itself, it is generic! We need to take care
3945 to retain symbols ambiguous that were already so. */
3946 if (sym->attr.use_assoc
3947 && !sym->attr.generic
3948 && sym->attr.flavor == FL_PROCEDURE)
3950 for (gen = generic; gen; gen = gen->next)
3952 if (gen->sym == sym)
3954 sym->attr.generic = 1;
3955 if (ambiguous_set)
3956 st->ambiguous = 0;
3957 break;
3965 mio_rparen ();
3969 /* Load common blocks. */
3971 static void
3972 load_commons (void)
3974 char name[GFC_MAX_SYMBOL_LEN + 1];
3975 gfc_common_head *p;
3977 mio_lparen ();
3979 while (peek_atom () != ATOM_RPAREN)
3981 int flags;
3982 mio_lparen ();
3983 mio_internal_string (name);
3985 p = gfc_get_common (name, 1);
3987 mio_symbol_ref (&p->head);
3988 mio_integer (&flags);
3989 if (flags & 1)
3990 p->saved = 1;
3991 if (flags & 2)
3992 p->threadprivate = 1;
3993 p->use_assoc = 1;
3995 /* Get whether this was a bind(c) common or not. */
3996 mio_integer (&p->is_bind_c);
3997 /* Get the binding label. */
3998 mio_internal_string (p->binding_label);
4000 mio_rparen ();
4003 mio_rparen ();
4007 /* Load equivalences. The flag in_load_equiv informs mio_expr_ref of this
4008 so that unused variables are not loaded and so that the expression can
4009 be safely freed. */
4011 static void
4012 load_equiv (void)
4014 gfc_equiv *head, *tail, *end, *eq;
4015 bool unused;
4017 mio_lparen ();
4018 in_load_equiv = true;
4020 end = gfc_current_ns->equiv;
4021 while (end != NULL && end->next != NULL)
4022 end = end->next;
4024 while (peek_atom () != ATOM_RPAREN) {
4025 mio_lparen ();
4026 head = tail = NULL;
4028 while(peek_atom () != ATOM_RPAREN)
4030 if (head == NULL)
4031 head = tail = gfc_get_equiv ();
4032 else
4034 tail->eq = gfc_get_equiv ();
4035 tail = tail->eq;
4038 mio_pool_string (&tail->module);
4039 mio_expr (&tail->expr);
4042 /* Unused equivalence members have a unique name. In addition, it
4043 must be checked that the symbols are from the same module. */
4044 unused = true;
4045 for (eq = head; eq; eq = eq->eq)
4047 if (eq->expr->symtree->n.sym->module
4048 && head->expr->symtree->n.sym->module
4049 && strcmp (head->expr->symtree->n.sym->module,
4050 eq->expr->symtree->n.sym->module) == 0
4051 && !check_unique_name (eq->expr->symtree->name))
4053 unused = false;
4054 break;
4058 if (unused)
4060 for (eq = head; eq; eq = head)
4062 head = eq->eq;
4063 gfc_free_expr (eq->expr);
4064 gfc_free (eq);
4068 if (end == NULL)
4069 gfc_current_ns->equiv = head;
4070 else
4071 end->next = head;
4073 if (head != NULL)
4074 end = head;
4076 mio_rparen ();
4079 mio_rparen ();
4080 in_load_equiv = false;
4084 /* This function loads the sym_root of f2k_derived with the extensions to
4085 the derived type. */
4086 static void
4087 load_derived_extensions (void)
4089 int symbol, j;
4090 gfc_symbol *derived;
4091 gfc_symbol *dt;
4092 gfc_symtree *st;
4093 pointer_info *info;
4094 char name[GFC_MAX_SYMBOL_LEN + 1];
4095 char module[GFC_MAX_SYMBOL_LEN + 1];
4096 const char *p;
4098 mio_lparen ();
4099 while (peek_atom () != ATOM_RPAREN)
4101 mio_lparen ();
4102 mio_integer (&symbol);
4103 info = get_integer (symbol);
4104 derived = info->u.rsym.sym;
4106 /* This one is not being loaded. */
4107 if (!info || !derived)
4109 while (peek_atom () != ATOM_RPAREN)
4110 skip_list ();
4111 continue;
4114 gcc_assert (derived->attr.flavor == FL_DERIVED);
4115 if (derived->f2k_derived == NULL)
4116 derived->f2k_derived = gfc_get_namespace (NULL, 0);
4118 while (peek_atom () != ATOM_RPAREN)
4120 mio_lparen ();
4121 mio_internal_string (name);
4122 mio_internal_string (module);
4124 /* Only use one use name to find the symbol. */
4125 j = 1;
4126 p = find_use_name_n (name, &j, false);
4127 if (p)
4129 st = gfc_find_symtree (gfc_current_ns->sym_root, p);
4130 dt = st->n.sym;
4131 st = gfc_find_symtree (derived->f2k_derived->sym_root, name);
4132 if (st == NULL)
4134 /* Only use the real name in f2k_derived to ensure a single
4135 symtree. */
4136 st = gfc_new_symtree (&derived->f2k_derived->sym_root, name);
4137 st->n.sym = dt;
4138 st->n.sym->refs++;
4141 mio_rparen ();
4143 mio_rparen ();
4145 mio_rparen ();
4149 /* Recursive function to traverse the pointer_info tree and load a
4150 needed symbol. We return nonzero if we load a symbol and stop the
4151 traversal, because the act of loading can alter the tree. */
4153 static int
4154 load_needed (pointer_info *p)
4156 gfc_namespace *ns;
4157 pointer_info *q;
4158 gfc_symbol *sym;
4159 int rv;
4161 rv = 0;
4162 if (p == NULL)
4163 return rv;
4165 rv |= load_needed (p->left);
4166 rv |= load_needed (p->right);
4168 if (p->type != P_SYMBOL || p->u.rsym.state != NEEDED)
4169 return rv;
4171 p->u.rsym.state = USED;
4173 set_module_locus (&p->u.rsym.where);
4175 sym = p->u.rsym.sym;
4176 if (sym == NULL)
4178 q = get_integer (p->u.rsym.ns);
4180 ns = (gfc_namespace *) q->u.pointer;
4181 if (ns == NULL)
4183 /* Create an interface namespace if necessary. These are
4184 the namespaces that hold the formal parameters of module
4185 procedures. */
4187 ns = gfc_get_namespace (NULL, 0);
4188 associate_integer_pointer (q, ns);
4191 /* Use the module sym as 'proc_name' so that gfc_get_symbol_decl
4192 doesn't go pear-shaped if the symbol is used. */
4193 if (!ns->proc_name)
4194 gfc_find_symbol (p->u.rsym.module, gfc_current_ns,
4195 1, &ns->proc_name);
4197 sym = gfc_new_symbol (p->u.rsym.true_name, ns);
4198 sym->module = gfc_get_string (p->u.rsym.module);
4199 strcpy (sym->binding_label, p->u.rsym.binding_label);
4201 associate_integer_pointer (p, sym);
4204 mio_symbol (sym);
4205 sym->attr.use_assoc = 1;
4206 if (only_flag)
4207 sym->attr.use_only = 1;
4208 if (p->u.rsym.renamed)
4209 sym->attr.use_rename = 1;
4211 return 1;
4215 /* Recursive function for cleaning up things after a module has been read. */
4217 static void
4218 read_cleanup (pointer_info *p)
4220 gfc_symtree *st;
4221 pointer_info *q;
4223 if (p == NULL)
4224 return;
4226 read_cleanup (p->left);
4227 read_cleanup (p->right);
4229 if (p->type == P_SYMBOL && p->u.rsym.state == USED && !p->u.rsym.referenced)
4231 gfc_namespace *ns;
4232 /* Add hidden symbols to the symtree. */
4233 q = get_integer (p->u.rsym.ns);
4234 ns = (gfc_namespace *) q->u.pointer;
4236 if (!p->u.rsym.sym->attr.vtype
4237 && !p->u.rsym.sym->attr.vtab)
4238 st = gfc_get_unique_symtree (ns);
4239 else
4241 /* There is no reason to use 'unique_symtrees' for vtabs or
4242 vtypes - their name is fine for a symtree and reduces the
4243 namespace pollution. */
4244 st = gfc_find_symtree (ns->sym_root, p->u.rsym.sym->name);
4245 if (!st)
4246 st = gfc_new_symtree (&ns->sym_root, p->u.rsym.sym->name);
4249 st->n.sym = p->u.rsym.sym;
4250 st->n.sym->refs++;
4252 /* Fixup any symtree references. */
4253 p->u.rsym.symtree = st;
4254 resolve_fixups (p->u.rsym.stfixup, st);
4255 p->u.rsym.stfixup = NULL;
4258 /* Free unused symbols. */
4259 if (p->type == P_SYMBOL && p->u.rsym.state == UNUSED)
4260 gfc_free_symbol (p->u.rsym.sym);
4264 /* It is not quite enough to check for ambiguity in the symbols by
4265 the loaded symbol and the new symbol not being identical. */
4266 static bool
4267 check_for_ambiguous (gfc_symbol *st_sym, pointer_info *info)
4269 gfc_symbol *rsym;
4270 module_locus locus;
4271 symbol_attribute attr;
4273 rsym = info->u.rsym.sym;
4274 if (st_sym == rsym)
4275 return false;
4277 if (st_sym->attr.vtab || st_sym->attr.vtype)
4278 return false;
4280 /* If the existing symbol is generic from a different module and
4281 the new symbol is generic there can be no ambiguity. */
4282 if (st_sym->attr.generic
4283 && st_sym->module
4284 && strcmp (st_sym->module, module_name))
4286 /* The new symbol's attributes have not yet been read. Since
4287 we need attr.generic, read it directly. */
4288 get_module_locus (&locus);
4289 set_module_locus (&info->u.rsym.where);
4290 mio_lparen ();
4291 attr.generic = 0;
4292 mio_symbol_attribute (&attr);
4293 set_module_locus (&locus);
4294 if (attr.generic)
4295 return false;
4298 return true;
4302 /* Read a module file. */
4304 static void
4305 read_module (void)
4307 module_locus operator_interfaces, user_operators, extensions;
4308 const char *p;
4309 char name[GFC_MAX_SYMBOL_LEN + 1];
4310 int i;
4311 int ambiguous, j, nuse, symbol;
4312 pointer_info *info, *q;
4313 gfc_use_rename *u;
4314 gfc_symtree *st;
4315 gfc_symbol *sym;
4317 get_module_locus (&operator_interfaces); /* Skip these for now. */
4318 skip_list ();
4320 get_module_locus (&user_operators);
4321 skip_list ();
4322 skip_list ();
4324 /* Skip commons, equivalences and derived type extensions for now. */
4325 skip_list ();
4326 skip_list ();
4328 get_module_locus (&extensions);
4329 skip_list ();
4331 mio_lparen ();
4333 /* Create the fixup nodes for all the symbols. */
4335 while (peek_atom () != ATOM_RPAREN)
4337 require_atom (ATOM_INTEGER);
4338 info = get_integer (atom_int);
4340 info->type = P_SYMBOL;
4341 info->u.rsym.state = UNUSED;
4343 mio_internal_string (info->u.rsym.true_name);
4344 mio_internal_string (info->u.rsym.module);
4345 mio_internal_string (info->u.rsym.binding_label);
4348 require_atom (ATOM_INTEGER);
4349 info->u.rsym.ns = atom_int;
4351 get_module_locus (&info->u.rsym.where);
4352 skip_list ();
4354 /* See if the symbol has already been loaded by a previous module.
4355 If so, we reference the existing symbol and prevent it from
4356 being loaded again. This should not happen if the symbol being
4357 read is an index for an assumed shape dummy array (ns != 1). */
4359 sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module);
4361 if (sym == NULL
4362 || (sym->attr.flavor == FL_VARIABLE && info->u.rsym.ns !=1))
4363 continue;
4365 info->u.rsym.state = USED;
4366 info->u.rsym.sym = sym;
4368 /* Some symbols do not have a namespace (eg. formal arguments),
4369 so the automatic "unique symtree" mechanism must be suppressed
4370 by marking them as referenced. */
4371 q = get_integer (info->u.rsym.ns);
4372 if (q->u.pointer == NULL)
4374 info->u.rsym.referenced = 1;
4375 continue;
4378 /* If possible recycle the symtree that references the symbol.
4379 If a symtree is not found and the module does not import one,
4380 a unique-name symtree is found by read_cleanup. */
4381 st = find_symtree_for_symbol (gfc_current_ns->sym_root, sym);
4382 if (st != NULL)
4384 info->u.rsym.symtree = st;
4385 info->u.rsym.referenced = 1;
4389 mio_rparen ();
4391 /* Parse the symtree lists. This lets us mark which symbols need to
4392 be loaded. Renaming is also done at this point by replacing the
4393 symtree name. */
4395 mio_lparen ();
4397 while (peek_atom () != ATOM_RPAREN)
4399 mio_internal_string (name);
4400 mio_integer (&ambiguous);
4401 mio_integer (&symbol);
4403 info = get_integer (symbol);
4405 /* See how many use names there are. If none, go through the start
4406 of the loop at least once. */
4407 nuse = number_use_names (name, false);
4408 info->u.rsym.renamed = nuse ? 1 : 0;
4410 if (nuse == 0)
4411 nuse = 1;
4413 for (j = 1; j <= nuse; j++)
4415 /* Get the jth local name for this symbol. */
4416 p = find_use_name_n (name, &j, false);
4418 if (p == NULL && strcmp (name, module_name) == 0)
4419 p = name;
4421 /* Exception: Always import vtabs & vtypes. */
4422 if (p == NULL && (strncmp (name, "__vtab_", 5) == 0
4423 || strncmp (name, "__vtype_", 6) == 0))
4424 p = name;
4426 /* Skip symtree nodes not in an ONLY clause, unless there
4427 is an existing symtree loaded from another USE statement. */
4428 if (p == NULL)
4430 st = gfc_find_symtree (gfc_current_ns->sym_root, name);
4431 if (st != NULL)
4432 info->u.rsym.symtree = st;
4433 continue;
4436 /* If a symbol of the same name and module exists already,
4437 this symbol, which is not in an ONLY clause, must not be
4438 added to the namespace(11.3.2). Note that find_symbol
4439 only returns the first occurrence that it finds. */
4440 if (!only_flag && !info->u.rsym.renamed
4441 && strcmp (name, module_name) != 0
4442 && find_symbol (gfc_current_ns->sym_root, name,
4443 module_name, 0))
4444 continue;
4446 st = gfc_find_symtree (gfc_current_ns->sym_root, p);
4448 if (st != NULL)
4450 /* Check for ambiguous symbols. */
4451 if (check_for_ambiguous (st->n.sym, info))
4452 st->ambiguous = 1;
4453 info->u.rsym.symtree = st;
4455 else
4457 st = gfc_find_symtree (gfc_current_ns->sym_root, name);
4459 /* Delete the symtree if the symbol has been added by a USE
4460 statement without an ONLY(11.3.2). Remember that the rsym
4461 will be the same as the symbol found in the symtree, for
4462 this case. */
4463 if (st && (only_flag || info->u.rsym.renamed)
4464 && !st->n.sym->attr.use_only
4465 && !st->n.sym->attr.use_rename
4466 && info->u.rsym.sym == st->n.sym)
4467 gfc_delete_symtree (&gfc_current_ns->sym_root, name);
4469 /* Create a symtree node in the current namespace for this
4470 symbol. */
4471 st = check_unique_name (p)
4472 ? gfc_get_unique_symtree (gfc_current_ns)
4473 : gfc_new_symtree (&gfc_current_ns->sym_root, p);
4474 st->ambiguous = ambiguous;
4476 sym = info->u.rsym.sym;
4478 /* Create a symbol node if it doesn't already exist. */
4479 if (sym == NULL)
4481 info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name,
4482 gfc_current_ns);
4483 sym = info->u.rsym.sym;
4484 sym->module = gfc_get_string (info->u.rsym.module);
4486 /* TODO: hmm, can we test this? Do we know it will be
4487 initialized to zeros? */
4488 if (info->u.rsym.binding_label[0] != '\0')
4489 strcpy (sym->binding_label, info->u.rsym.binding_label);
4492 st->n.sym = sym;
4493 st->n.sym->refs++;
4495 if (strcmp (name, p) != 0)
4496 sym->attr.use_rename = 1;
4498 /* We need to set the only_flag here so that symbols from the
4499 same USE...ONLY but earlier are not deleted from the tree in
4500 the gfc_delete_symtree above. */
4501 sym->attr.use_only = only_flag;
4503 /* Store the symtree pointing to this symbol. */
4504 info->u.rsym.symtree = st;
4506 if (info->u.rsym.state == UNUSED)
4507 info->u.rsym.state = NEEDED;
4508 info->u.rsym.referenced = 1;
4513 mio_rparen ();
4515 /* Load intrinsic operator interfaces. */
4516 set_module_locus (&operator_interfaces);
4517 mio_lparen ();
4519 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
4521 if (i == INTRINSIC_USER)
4522 continue;
4524 if (only_flag)
4526 u = find_use_operator ((gfc_intrinsic_op) i);
4528 if (u == NULL)
4530 skip_list ();
4531 continue;
4534 u->found = 1;
4537 mio_interface (&gfc_current_ns->op[i]);
4540 mio_rparen ();
4542 /* Load generic and user operator interfaces. These must follow the
4543 loading of symtree because otherwise symbols can be marked as
4544 ambiguous. */
4546 set_module_locus (&user_operators);
4548 load_operator_interfaces ();
4549 load_generic_interfaces ();
4551 load_commons ();
4552 load_equiv ();
4554 /* At this point, we read those symbols that are needed but haven't
4555 been loaded yet. If one symbol requires another, the other gets
4556 marked as NEEDED if its previous state was UNUSED. */
4558 while (load_needed (pi_root));
4560 /* Make sure all elements of the rename-list were found in the module. */
4562 for (u = gfc_rename_list; u; u = u->next)
4564 if (u->found)
4565 continue;
4567 if (u->op == INTRINSIC_NONE)
4569 gfc_error ("Symbol '%s' referenced at %L not found in module '%s'",
4570 u->use_name, &u->where, module_name);
4571 continue;
4574 if (u->op == INTRINSIC_USER)
4576 gfc_error ("User operator '%s' referenced at %L not found "
4577 "in module '%s'", u->use_name, &u->where, module_name);
4578 continue;
4581 gfc_error ("Intrinsic operator '%s' referenced at %L not found "
4582 "in module '%s'", gfc_op2string (u->op), &u->where,
4583 module_name);
4586 /* Now we should be in a position to fill f2k_derived with derived type
4587 extensions, since everything has been loaded. */
4588 set_module_locus (&extensions);
4589 load_derived_extensions ();
4591 /* Clean up symbol nodes that were never loaded, create references
4592 to hidden symbols. */
4594 read_cleanup (pi_root);
4598 /* Given an access type that is specific to an entity and the default
4599 access, return nonzero if the entity is publicly accessible. If the
4600 element is declared as PUBLIC, then it is public; if declared
4601 PRIVATE, then private, and otherwise it is public unless the default
4602 access in this context has been declared PRIVATE. */
4604 static bool
4605 check_access (gfc_access specific_access, gfc_access default_access)
4607 if (specific_access == ACCESS_PUBLIC)
4608 return TRUE;
4609 if (specific_access == ACCESS_PRIVATE)
4610 return FALSE;
4612 if (gfc_option.flag_module_private)
4613 return default_access == ACCESS_PUBLIC;
4614 else
4615 return default_access != ACCESS_PRIVATE;
4619 bool
4620 gfc_check_symbol_access (gfc_symbol *sym)
4622 if (sym->attr.vtab || sym->attr.vtype)
4623 return true;
4624 else
4625 return check_access (sym->attr.access, sym->ns->default_access);
4629 /* A structure to remember which commons we've already written. */
4631 struct written_common
4633 BBT_HEADER(written_common);
4634 const char *name, *label;
4637 static struct written_common *written_commons = NULL;
4639 /* Comparison function used for balancing the binary tree. */
4641 static int
4642 compare_written_commons (void *a1, void *b1)
4644 const char *aname = ((struct written_common *) a1)->name;
4645 const char *alabel = ((struct written_common *) a1)->label;
4646 const char *bname = ((struct written_common *) b1)->name;
4647 const char *blabel = ((struct written_common *) b1)->label;
4648 int c = strcmp (aname, bname);
4650 return (c != 0 ? c : strcmp (alabel, blabel));
4653 /* Free a list of written commons. */
4655 static void
4656 free_written_common (struct written_common *w)
4658 if (!w)
4659 return;
4661 if (w->left)
4662 free_written_common (w->left);
4663 if (w->right)
4664 free_written_common (w->right);
4666 gfc_free (w);
4669 /* Write a common block to the module -- recursive helper function. */
4671 static void
4672 write_common_0 (gfc_symtree *st, bool this_module)
4674 gfc_common_head *p;
4675 const char * name;
4676 int flags;
4677 const char *label;
4678 struct written_common *w;
4679 bool write_me = true;
4681 if (st == NULL)
4682 return;
4684 write_common_0 (st->left, this_module);
4686 /* We will write out the binding label, or the name if no label given. */
4687 name = st->n.common->name;
4688 p = st->n.common;
4689 label = p->is_bind_c ? p->binding_label : p->name;
4691 /* Check if we've already output this common. */
4692 w = written_commons;
4693 while (w)
4695 int c = strcmp (name, w->name);
4696 c = (c != 0 ? c : strcmp (label, w->label));
4697 if (c == 0)
4698 write_me = false;
4700 w = (c < 0) ? w->left : w->right;
4703 if (this_module && p->use_assoc)
4704 write_me = false;
4706 if (write_me)
4708 /* Write the common to the module. */
4709 mio_lparen ();
4710 mio_pool_string (&name);
4712 mio_symbol_ref (&p->head);
4713 flags = p->saved ? 1 : 0;
4714 if (p->threadprivate)
4715 flags |= 2;
4716 mio_integer (&flags);
4718 /* Write out whether the common block is bind(c) or not. */
4719 mio_integer (&(p->is_bind_c));
4721 mio_pool_string (&label);
4722 mio_rparen ();
4724 /* Record that we have written this common. */
4725 w = XCNEW (struct written_common);
4726 w->name = p->name;
4727 w->label = label;
4728 gfc_insert_bbt (&written_commons, w, compare_written_commons);
4731 write_common_0 (st->right, this_module);
4735 /* Write a common, by initializing the list of written commons, calling
4736 the recursive function write_common_0() and cleaning up afterwards. */
4738 static void
4739 write_common (gfc_symtree *st)
4741 written_commons = NULL;
4742 write_common_0 (st, true);
4743 write_common_0 (st, false);
4744 free_written_common (written_commons);
4745 written_commons = NULL;
4749 /* Write the blank common block to the module. */
4751 static void
4752 write_blank_common (void)
4754 const char * name = BLANK_COMMON_NAME;
4755 int saved;
4756 /* TODO: Blank commons are not bind(c). The F2003 standard probably says
4757 this, but it hasn't been checked. Just making it so for now. */
4758 int is_bind_c = 0;
4760 if (gfc_current_ns->blank_common.head == NULL)
4761 return;
4763 mio_lparen ();
4765 mio_pool_string (&name);
4767 mio_symbol_ref (&gfc_current_ns->blank_common.head);
4768 saved = gfc_current_ns->blank_common.saved;
4769 mio_integer (&saved);
4771 /* Write out whether the common block is bind(c) or not. */
4772 mio_integer (&is_bind_c);
4774 /* Write out the binding label, which is BLANK_COMMON_NAME, though
4775 it doesn't matter because the label isn't used. */
4776 mio_pool_string (&name);
4778 mio_rparen ();
4782 /* Write equivalences to the module. */
4784 static void
4785 write_equiv (void)
4787 gfc_equiv *eq, *e;
4788 int num;
4790 num = 0;
4791 for (eq = gfc_current_ns->equiv; eq; eq = eq->next)
4793 mio_lparen ();
4795 for (e = eq; e; e = e->eq)
4797 if (e->module == NULL)
4798 e->module = gfc_get_string ("%s.eq.%d", module_name, num);
4799 mio_allocated_string (e->module);
4800 mio_expr (&e->expr);
4803 num++;
4804 mio_rparen ();
4809 /* Write derived type extensions to the module. */
4811 static void
4812 write_dt_extensions (gfc_symtree *st)
4814 if (!gfc_check_symbol_access (st->n.sym))
4815 return;
4817 mio_lparen ();
4818 mio_pool_string (&st->n.sym->name);
4819 if (st->n.sym->module != NULL)
4820 mio_pool_string (&st->n.sym->module);
4821 else
4822 mio_internal_string (module_name);
4823 mio_rparen ();
4826 static void
4827 write_derived_extensions (gfc_symtree *st)
4829 if (!((st->n.sym->attr.flavor == FL_DERIVED)
4830 && (st->n.sym->f2k_derived != NULL)
4831 && (st->n.sym->f2k_derived->sym_root != NULL)))
4832 return;
4834 mio_lparen ();
4835 mio_symbol_ref (&(st->n.sym));
4836 gfc_traverse_symtree (st->n.sym->f2k_derived->sym_root,
4837 write_dt_extensions);
4838 mio_rparen ();
4842 /* Write a symbol to the module. */
4844 static void
4845 write_symbol (int n, gfc_symbol *sym)
4847 const char *label;
4849 if (sym->attr.flavor == FL_UNKNOWN || sym->attr.flavor == FL_LABEL)
4850 gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym->name);
4852 mio_integer (&n);
4853 mio_pool_string (&sym->name);
4855 mio_pool_string (&sym->module);
4856 if (sym->attr.is_bind_c || sym->attr.is_iso_c)
4858 label = sym->binding_label;
4859 mio_pool_string (&label);
4861 else
4862 mio_pool_string (&sym->name);
4864 mio_pointer_ref (&sym->ns);
4866 mio_symbol (sym);
4867 write_char ('\n');
4871 /* Recursive traversal function to write the initial set of symbols to
4872 the module. We check to see if the symbol should be written
4873 according to the access specification. */
4875 static void
4876 write_symbol0 (gfc_symtree *st)
4878 gfc_symbol *sym;
4879 pointer_info *p;
4880 bool dont_write = false;
4882 if (st == NULL)
4883 return;
4885 write_symbol0 (st->left);
4887 sym = st->n.sym;
4888 if (sym->module == NULL)
4889 sym->module = gfc_get_string (module_name);
4891 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
4892 && !sym->attr.subroutine && !sym->attr.function)
4893 dont_write = true;
4895 if (!gfc_check_symbol_access (sym))
4896 dont_write = true;
4898 if (!dont_write)
4900 p = get_pointer (sym);
4901 if (p->type == P_UNKNOWN)
4902 p->type = P_SYMBOL;
4904 if (p->u.wsym.state != WRITTEN)
4906 write_symbol (p->integer, sym);
4907 p->u.wsym.state = WRITTEN;
4911 write_symbol0 (st->right);
4915 /* Recursive traversal function to write the secondary set of symbols
4916 to the module file. These are symbols that were not public yet are
4917 needed by the public symbols or another dependent symbol. The act
4918 of writing a symbol can modify the pointer_info tree, so we cease
4919 traversal if we find a symbol to write. We return nonzero if a
4920 symbol was written and pass that information upwards. */
4922 static int
4923 write_symbol1 (pointer_info *p)
4925 int result;
4927 if (!p)
4928 return 0;
4930 result = write_symbol1 (p->left);
4932 if (!(p->type != P_SYMBOL || p->u.wsym.state != NEEDS_WRITE))
4934 p->u.wsym.state = WRITTEN;
4935 write_symbol (p->integer, p->u.wsym.sym);
4936 result = 1;
4939 result |= write_symbol1 (p->right);
4940 return result;
4944 /* Write operator interfaces associated with a symbol. */
4946 static void
4947 write_operator (gfc_user_op *uop)
4949 static char nullstring[] = "";
4950 const char *p = nullstring;
4952 if (uop->op == NULL || !check_access (uop->access, uop->ns->default_access))
4953 return;
4955 mio_symbol_interface (&uop->name, &p, &uop->op);
4959 /* Write generic interfaces from the namespace sym_root. */
4961 static void
4962 write_generic (gfc_symtree *st)
4964 gfc_symbol *sym;
4966 if (st == NULL)
4967 return;
4969 write_generic (st->left);
4970 write_generic (st->right);
4972 sym = st->n.sym;
4973 if (!sym || check_unique_name (st->name))
4974 return;
4976 if (sym->generic == NULL || !gfc_check_symbol_access (sym))
4977 return;
4979 if (sym->module == NULL)
4980 sym->module = gfc_get_string (module_name);
4982 mio_symbol_interface (&st->name, &sym->module, &sym->generic);
4986 static void
4987 write_symtree (gfc_symtree *st)
4989 gfc_symbol *sym;
4990 pointer_info *p;
4992 sym = st->n.sym;
4994 /* A symbol in an interface body must not be visible in the
4995 module file. */
4996 if (sym->ns != gfc_current_ns
4997 && sym->ns->proc_name
4998 && sym->ns->proc_name->attr.if_source == IFSRC_IFBODY)
4999 return;
5001 if (!gfc_check_symbol_access (sym)
5002 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
5003 && !sym->attr.subroutine && !sym->attr.function))
5004 return;
5006 if (check_unique_name (st->name))
5007 return;
5009 p = find_pointer (sym);
5010 if (p == NULL)
5011 gfc_internal_error ("write_symtree(): Symbol not written");
5013 mio_pool_string (&st->name);
5014 mio_integer (&st->ambiguous);
5015 mio_integer (&p->integer);
5019 static void
5020 write_module (void)
5022 int i;
5024 /* Write the operator interfaces. */
5025 mio_lparen ();
5027 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
5029 if (i == INTRINSIC_USER)
5030 continue;
5032 mio_interface (check_access (gfc_current_ns->operator_access[i],
5033 gfc_current_ns->default_access)
5034 ? &gfc_current_ns->op[i] : NULL);
5037 mio_rparen ();
5038 write_char ('\n');
5039 write_char ('\n');
5041 mio_lparen ();
5042 gfc_traverse_user_op (gfc_current_ns, write_operator);
5043 mio_rparen ();
5044 write_char ('\n');
5045 write_char ('\n');
5047 mio_lparen ();
5048 write_generic (gfc_current_ns->sym_root);
5049 mio_rparen ();
5050 write_char ('\n');
5051 write_char ('\n');
5053 mio_lparen ();
5054 write_blank_common ();
5055 write_common (gfc_current_ns->common_root);
5056 mio_rparen ();
5057 write_char ('\n');
5058 write_char ('\n');
5060 mio_lparen ();
5061 write_equiv ();
5062 mio_rparen ();
5063 write_char ('\n');
5064 write_char ('\n');
5066 mio_lparen ();
5067 gfc_traverse_symtree (gfc_current_ns->sym_root,
5068 write_derived_extensions);
5069 mio_rparen ();
5070 write_char ('\n');
5071 write_char ('\n');
5073 /* Write symbol information. First we traverse all symbols in the
5074 primary namespace, writing those that need to be written.
5075 Sometimes writing one symbol will cause another to need to be
5076 written. A list of these symbols ends up on the write stack, and
5077 we end by popping the bottom of the stack and writing the symbol
5078 until the stack is empty. */
5080 mio_lparen ();
5082 write_symbol0 (gfc_current_ns->sym_root);
5083 while (write_symbol1 (pi_root))
5084 /* Nothing. */;
5086 mio_rparen ();
5088 write_char ('\n');
5089 write_char ('\n');
5091 mio_lparen ();
5092 gfc_traverse_symtree (gfc_current_ns->sym_root, write_symtree);
5093 mio_rparen ();
5097 /* Read a MD5 sum from the header of a module file. If the file cannot
5098 be opened, or we have any other error, we return -1. */
5100 static int
5101 read_md5_from_module_file (const char * filename, unsigned char md5[16])
5103 FILE *file;
5104 char buf[1024];
5105 int n;
5107 /* Open the file. */
5108 if ((file = fopen (filename, "r")) == NULL)
5109 return -1;
5111 /* Read the first line. */
5112 if (fgets (buf, sizeof (buf) - 1, file) == NULL)
5114 fclose (file);
5115 return -1;
5118 /* The file also needs to be overwritten if the version number changed. */
5119 n = strlen ("GFORTRAN module version '" MOD_VERSION "' created");
5120 if (strncmp (buf, "GFORTRAN module version '" MOD_VERSION "' created", n) != 0)
5122 fclose (file);
5123 return -1;
5126 /* Read a second line. */
5127 if (fgets (buf, sizeof (buf) - 1, file) == NULL)
5129 fclose (file);
5130 return -1;
5133 /* Close the file. */
5134 fclose (file);
5136 /* If the header is not what we expect, or is too short, bail out. */
5137 if (strncmp (buf, "MD5:", 4) != 0 || strlen (buf) < 4 + 16)
5138 return -1;
5140 /* Now, we have a real MD5, read it into the array. */
5141 for (n = 0; n < 16; n++)
5143 unsigned int x;
5145 if (sscanf (&(buf[4+2*n]), "%02x", &x) != 1)
5146 return -1;
5148 md5[n] = x;
5151 return 0;
5155 /* Given module, dump it to disk. If there was an error while
5156 processing the module, dump_flag will be set to zero and we delete
5157 the module file, even if it was already there. */
5159 void
5160 gfc_dump_module (const char *name, int dump_flag)
5162 int n;
5163 char *filename, *filename_tmp;
5164 fpos_t md5_pos;
5165 unsigned char md5_new[16], md5_old[16];
5167 n = strlen (name) + strlen (MODULE_EXTENSION) + 1;
5168 if (gfc_option.module_dir != NULL)
5170 n += strlen (gfc_option.module_dir);
5171 filename = (char *) alloca (n);
5172 strcpy (filename, gfc_option.module_dir);
5173 strcat (filename, name);
5175 else
5177 filename = (char *) alloca (n);
5178 strcpy (filename, name);
5180 strcat (filename, MODULE_EXTENSION);
5182 /* Name of the temporary file used to write the module. */
5183 filename_tmp = (char *) alloca (n + 1);
5184 strcpy (filename_tmp, filename);
5185 strcat (filename_tmp, "0");
5187 /* There was an error while processing the module. We delete the
5188 module file, even if it was already there. */
5189 if (!dump_flag)
5191 unlink (filename);
5192 return;
5195 if (gfc_cpp_makedep ())
5196 gfc_cpp_add_target (filename);
5198 /* Write the module to the temporary file. */
5199 module_fp = fopen (filename_tmp, "w");
5200 if (module_fp == NULL)
5201 gfc_fatal_error ("Can't open module file '%s' for writing at %C: %s",
5202 filename_tmp, xstrerror (errno));
5204 /* Write the header, including space reserved for the MD5 sum. */
5205 fprintf (module_fp, "GFORTRAN module version '%s' created from %s\n"
5206 "MD5:", MOD_VERSION, gfc_source_file);
5207 fgetpos (module_fp, &md5_pos);
5208 fputs ("00000000000000000000000000000000 -- "
5209 "If you edit this, you'll get what you deserve.\n\n", module_fp);
5211 /* Initialize the MD5 context that will be used for output. */
5212 md5_init_ctx (&ctx);
5214 /* Write the module itself. */
5215 iomode = IO_OUTPUT;
5216 strcpy (module_name, name);
5218 init_pi_tree ();
5220 write_module ();
5222 free_pi_tree (pi_root);
5223 pi_root = NULL;
5225 write_char ('\n');
5227 /* Write the MD5 sum to the header of the module file. */
5228 md5_finish_ctx (&ctx, md5_new);
5229 fsetpos (module_fp, &md5_pos);
5230 for (n = 0; n < 16; n++)
5231 fprintf (module_fp, "%02x", md5_new[n]);
5233 if (fclose (module_fp))
5234 gfc_fatal_error ("Error writing module file '%s' for writing: %s",
5235 filename_tmp, xstrerror (errno));
5237 /* Read the MD5 from the header of the old module file and compare. */
5238 if (read_md5_from_module_file (filename, md5_old) != 0
5239 || memcmp (md5_old, md5_new, sizeof (md5_old)) != 0)
5241 /* Module file have changed, replace the old one. */
5242 if (unlink (filename) && errno != ENOENT)
5243 gfc_fatal_error ("Can't delete module file '%s': %s", filename,
5244 xstrerror (errno));
5245 if (rename (filename_tmp, filename))
5246 gfc_fatal_error ("Can't rename module file '%s' to '%s': %s",
5247 filename_tmp, filename, xstrerror (errno));
5249 else
5251 if (unlink (filename_tmp))
5252 gfc_fatal_error ("Can't delete temporary module file '%s': %s",
5253 filename_tmp, xstrerror (errno));
5258 static void
5259 create_intrinsic_function (const char *name, gfc_isym_id id,
5260 const char *modname, intmod_id module)
5262 gfc_intrinsic_sym *isym;
5263 gfc_symtree *tmp_symtree;
5264 gfc_symbol *sym;
5266 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
5267 if (tmp_symtree)
5269 if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
5270 return;
5271 gfc_error ("Symbol '%s' already declared", name);
5274 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
5275 sym = tmp_symtree->n.sym;
5277 isym = gfc_intrinsic_function_by_id (id);
5278 gcc_assert (isym);
5280 sym->attr.flavor = FL_PROCEDURE;
5281 sym->attr.intrinsic = 1;
5283 sym->module = gfc_get_string (modname);
5284 sym->attr.use_assoc = 1;
5285 sym->from_intmod = module;
5286 sym->intmod_sym_id = id;
5290 /* Import the intrinsic ISO_C_BINDING module, generating symbols in
5291 the current namespace for all named constants, pointer types, and
5292 procedures in the module unless the only clause was used or a rename
5293 list was provided. */
5295 static void
5296 import_iso_c_binding_module (void)
5298 gfc_symbol *mod_sym = NULL;
5299 gfc_symtree *mod_symtree = NULL;
5300 const char *iso_c_module_name = "__iso_c_binding";
5301 gfc_use_rename *u;
5302 int i;
5304 /* Look only in the current namespace. */
5305 mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, iso_c_module_name);
5307 if (mod_symtree == NULL)
5309 /* symtree doesn't already exist in current namespace. */
5310 gfc_get_sym_tree (iso_c_module_name, gfc_current_ns, &mod_symtree,
5311 false);
5313 if (mod_symtree != NULL)
5314 mod_sym = mod_symtree->n.sym;
5315 else
5316 gfc_internal_error ("import_iso_c_binding_module(): Unable to "
5317 "create symbol for %s", iso_c_module_name);
5319 mod_sym->attr.flavor = FL_MODULE;
5320 mod_sym->attr.intrinsic = 1;
5321 mod_sym->module = gfc_get_string (iso_c_module_name);
5322 mod_sym->from_intmod = INTMOD_ISO_C_BINDING;
5325 /* Generate the symbols for the named constants representing
5326 the kinds for intrinsic data types. */
5327 for (i = 0; i < ISOCBINDING_NUMBER; i++)
5329 bool found = false;
5330 for (u = gfc_rename_list; u; u = u->next)
5331 if (strcmp (c_interop_kinds_table[i].name, u->use_name) == 0)
5333 u->found = 1;
5334 found = true;
5335 switch (i)
5337 #define NAMED_FUNCTION(a,b,c,d) \
5338 case a: \
5339 create_intrinsic_function (u->local_name[0] ? u->local_name \
5340 : u->use_name, \
5341 (gfc_isym_id) c, \
5342 iso_c_module_name, \
5343 INTMOD_ISO_C_BINDING); \
5344 break;
5345 #include "iso-c-binding.def"
5346 #undef NAMED_FUNCTION
5348 default:
5349 generate_isocbinding_symbol (iso_c_module_name,
5350 (iso_c_binding_symbol) i,
5351 u->local_name[0] ? u->local_name
5352 : u->use_name);
5356 if (!found && !only_flag)
5357 switch (i)
5359 #define NAMED_FUNCTION(a,b,c,d) \
5360 case a: \
5361 if ((gfc_option.allow_std & d) == 0) \
5362 continue; \
5363 create_intrinsic_function (b, (gfc_isym_id) c, \
5364 iso_c_module_name, \
5365 INTMOD_ISO_C_BINDING); \
5366 break;
5367 #include "iso-c-binding.def"
5368 #undef NAMED_FUNCTION
5370 default:
5371 generate_isocbinding_symbol (iso_c_module_name,
5372 (iso_c_binding_symbol) i, NULL);
5376 for (u = gfc_rename_list; u; u = u->next)
5378 if (u->found)
5379 continue;
5381 gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
5382 "module ISO_C_BINDING", u->use_name, &u->where);
5387 /* Add an integer named constant from a given module. */
5389 static void
5390 create_int_parameter (const char *name, int value, const char *modname,
5391 intmod_id module, int id)
5393 gfc_symtree *tmp_symtree;
5394 gfc_symbol *sym;
5396 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
5397 if (tmp_symtree != NULL)
5399 if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
5400 return;
5401 else
5402 gfc_error ("Symbol '%s' already declared", name);
5405 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
5406 sym = tmp_symtree->n.sym;
5408 sym->module = gfc_get_string (modname);
5409 sym->attr.flavor = FL_PARAMETER;
5410 sym->ts.type = BT_INTEGER;
5411 sym->ts.kind = gfc_default_integer_kind;
5412 sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL, value);
5413 sym->attr.use_assoc = 1;
5414 sym->from_intmod = module;
5415 sym->intmod_sym_id = id;
5419 /* Value is already contained by the array constructor, but not
5420 yet the shape. */
5422 static void
5423 create_int_parameter_array (const char *name, int size, gfc_expr *value,
5424 const char *modname, intmod_id module, int id)
5426 gfc_symtree *tmp_symtree;
5427 gfc_symbol *sym;
5429 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
5430 if (tmp_symtree != NULL)
5432 if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
5433 return;
5434 else
5435 gfc_error ("Symbol '%s' already declared", name);
5438 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
5439 sym = tmp_symtree->n.sym;
5441 sym->module = gfc_get_string (modname);
5442 sym->attr.flavor = FL_PARAMETER;
5443 sym->ts.type = BT_INTEGER;
5444 sym->ts.kind = gfc_default_integer_kind;
5445 sym->attr.use_assoc = 1;
5446 sym->from_intmod = module;
5447 sym->intmod_sym_id = id;
5448 sym->attr.dimension = 1;
5449 sym->as = gfc_get_array_spec ();
5450 sym->as->rank = 1;
5451 sym->as->type = AS_EXPLICIT;
5452 sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
5453 sym->as->upper[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, size);
5455 sym->value = value;
5456 sym->value->shape = gfc_get_shape (1);
5457 mpz_init_set_ui (sym->value->shape[0], size);
5462 /* USE the ISO_FORTRAN_ENV intrinsic module. */
5464 static void
5465 use_iso_fortran_env_module (void)
5467 static char mod[] = "iso_fortran_env";
5468 gfc_use_rename *u;
5469 gfc_symbol *mod_sym;
5470 gfc_symtree *mod_symtree;
5471 gfc_expr *expr;
5472 int i, j;
5474 intmod_sym symbol[] = {
5475 #define NAMED_INTCST(a,b,c,d) { a, b, 0, d },
5476 #include "iso-fortran-env.def"
5477 #undef NAMED_INTCST
5478 #define NAMED_KINDARRAY(a,b,c,d) { a, b, 0, d },
5479 #include "iso-fortran-env.def"
5480 #undef NAMED_KINDARRAY
5481 #define NAMED_FUNCTION(a,b,c,d) { a, b, c, d },
5482 #include "iso-fortran-env.def"
5483 #undef NAMED_FUNCTION
5484 { ISOFORTRANENV_INVALID, NULL, -1234, 0 } };
5486 i = 0;
5487 #define NAMED_INTCST(a,b,c,d) symbol[i++].value = c;
5488 #include "iso-fortran-env.def"
5489 #undef NAMED_INTCST
5491 /* Generate the symbol for the module itself. */
5492 mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, mod);
5493 if (mod_symtree == NULL)
5495 gfc_get_sym_tree (mod, gfc_current_ns, &mod_symtree, false);
5496 gcc_assert (mod_symtree);
5497 mod_sym = mod_symtree->n.sym;
5499 mod_sym->attr.flavor = FL_MODULE;
5500 mod_sym->attr.intrinsic = 1;
5501 mod_sym->module = gfc_get_string (mod);
5502 mod_sym->from_intmod = INTMOD_ISO_FORTRAN_ENV;
5504 else
5505 if (!mod_symtree->n.sym->attr.intrinsic)
5506 gfc_error ("Use of intrinsic module '%s' at %C conflicts with "
5507 "non-intrinsic module name used previously", mod);
5509 /* Generate the symbols for the module integer named constants. */
5511 for (i = 0; symbol[i].name; i++)
5513 bool found = false;
5514 for (u = gfc_rename_list; u; u = u->next)
5516 if (strcmp (symbol[i].name, u->use_name) == 0)
5518 found = true;
5519 u->found = 1;
5521 if (gfc_notify_std (symbol[i].standard, "The symbol '%s', "
5522 "referrenced at %C, is not in the selected "
5523 "standard", symbol[i].name) == FAILURE)
5524 continue;
5526 if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
5527 && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
5528 gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named "
5529 "constant from intrinsic module "
5530 "ISO_FORTRAN_ENV at %C is incompatible with "
5531 "option %s",
5532 gfc_option.flag_default_integer
5533 ? "-fdefault-integer-8"
5534 : "-fdefault-real-8");
5535 switch (symbol[i].id)
5537 #define NAMED_INTCST(a,b,c,d) \
5538 case a:
5539 #include "iso-fortran-env.def"
5540 #undef NAMED_INTCST
5541 create_int_parameter (u->local_name[0] ? u->local_name
5542 : u->use_name,
5543 symbol[i].value, mod,
5544 INTMOD_ISO_FORTRAN_ENV, symbol[i].id);
5545 break;
5547 #define NAMED_KINDARRAY(a,b,KINDS,d) \
5548 case a:\
5549 expr = gfc_get_array_expr (BT_INTEGER, \
5550 gfc_default_integer_kind,\
5551 NULL); \
5552 for (j = 0; KINDS[j].kind != 0; j++) \
5553 gfc_constructor_append_expr (&expr->value.constructor, \
5554 gfc_get_int_expr (gfc_default_integer_kind, NULL, \
5555 KINDS[j].kind), NULL); \
5556 create_int_parameter_array (u->local_name[0] ? u->local_name \
5557 : u->use_name, \
5558 j, expr, mod, \
5559 INTMOD_ISO_FORTRAN_ENV, \
5560 symbol[i].id); \
5561 break;
5562 #include "iso-fortran-env.def"
5563 #undef NAMED_KINDARRAY
5565 #define NAMED_FUNCTION(a,b,c,d) \
5566 case a:
5567 #include "iso-fortran-env.def"
5568 #undef NAMED_FUNCTION
5569 create_intrinsic_function (u->local_name[0] ? u->local_name
5570 : u->use_name,
5571 (gfc_isym_id) symbol[i].value, mod,
5572 INTMOD_ISO_FORTRAN_ENV);
5573 break;
5575 default:
5576 gcc_unreachable ();
5581 if (!found && !only_flag)
5583 if ((gfc_option.allow_std & symbol[i].standard) == 0)
5584 continue;
5586 if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
5587 && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
5588 gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
5589 "from intrinsic module ISO_FORTRAN_ENV at %C is "
5590 "incompatible with option %s",
5591 gfc_option.flag_default_integer
5592 ? "-fdefault-integer-8" : "-fdefault-real-8");
5594 switch (symbol[i].id)
5596 #define NAMED_INTCST(a,b,c,d) \
5597 case a:
5598 #include "iso-fortran-env.def"
5599 #undef NAMED_INTCST
5600 create_int_parameter (symbol[i].name, symbol[i].value, mod,
5601 INTMOD_ISO_FORTRAN_ENV, symbol[i].id);
5602 break;
5604 #define NAMED_KINDARRAY(a,b,KINDS,d) \
5605 case a:\
5606 expr = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, \
5607 NULL); \
5608 for (j = 0; KINDS[j].kind != 0; j++) \
5609 gfc_constructor_append_expr (&expr->value.constructor, \
5610 gfc_get_int_expr (gfc_default_integer_kind, NULL, \
5611 KINDS[j].kind), NULL); \
5612 create_int_parameter_array (symbol[i].name, j, expr, mod, \
5613 INTMOD_ISO_FORTRAN_ENV, symbol[i].id);\
5614 break;
5615 #include "iso-fortran-env.def"
5616 #undef NAMED_KINDARRAY
5618 #define NAMED_FUNCTION(a,b,c,d) \
5619 case a:
5620 #include "iso-fortran-env.def"
5621 #undef NAMED_FUNCTION
5622 create_intrinsic_function (symbol[i].name,
5623 (gfc_isym_id) symbol[i].value, mod,
5624 INTMOD_ISO_FORTRAN_ENV);
5625 break;
5627 default:
5628 gcc_unreachable ();
5633 for (u = gfc_rename_list; u; u = u->next)
5635 if (u->found)
5636 continue;
5638 gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
5639 "module ISO_FORTRAN_ENV", u->use_name, &u->where);
5644 /* Process a USE directive. */
5646 void
5647 gfc_use_module (void)
5649 char *filename;
5650 gfc_state_data *p;
5651 int c, line, start;
5652 gfc_symtree *mod_symtree;
5653 gfc_use_list *use_stmt;
5655 filename = (char *) alloca (strlen (module_name) + strlen (MODULE_EXTENSION)
5656 + 1);
5657 strcpy (filename, module_name);
5658 strcat (filename, MODULE_EXTENSION);
5660 /* First, try to find an non-intrinsic module, unless the USE statement
5661 specified that the module is intrinsic. */
5662 module_fp = NULL;
5663 if (!specified_int)
5664 module_fp = gfc_open_included_file (filename, true, true);
5666 /* Then, see if it's an intrinsic one, unless the USE statement
5667 specified that the module is non-intrinsic. */
5668 if (module_fp == NULL && !specified_nonint)
5670 if (strcmp (module_name, "iso_fortran_env") == 0
5671 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ISO_FORTRAN_ENV "
5672 "intrinsic module at %C") != FAILURE)
5674 use_iso_fortran_env_module ();
5675 return;
5678 if (strcmp (module_name, "iso_c_binding") == 0
5679 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: "
5680 "ISO_C_BINDING module at %C") != FAILURE)
5682 import_iso_c_binding_module();
5683 return;
5686 module_fp = gfc_open_intrinsic_module (filename);
5688 if (module_fp == NULL && specified_int)
5689 gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C",
5690 module_name);
5693 if (module_fp == NULL)
5694 gfc_fatal_error ("Can't open module file '%s' for reading at %C: %s",
5695 filename, xstrerror (errno));
5697 /* Check that we haven't already USEd an intrinsic module with the
5698 same name. */
5700 mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, module_name);
5701 if (mod_symtree && mod_symtree->n.sym->attr.intrinsic)
5702 gfc_error ("Use of non-intrinsic module '%s' at %C conflicts with "
5703 "intrinsic module name used previously", module_name);
5705 iomode = IO_INPUT;
5706 module_line = 1;
5707 module_column = 1;
5708 start = 0;
5710 /* Skip the first two lines of the module, after checking that this is
5711 a gfortran module file. */
5712 line = 0;
5713 while (line < 2)
5715 c = module_char ();
5716 if (c == EOF)
5717 bad_module ("Unexpected end of module");
5718 if (start++ < 3)
5719 parse_name (c);
5720 if ((start == 1 && strcmp (atom_name, "GFORTRAN") != 0)
5721 || (start == 2 && strcmp (atom_name, " module") != 0))
5722 gfc_fatal_error ("File '%s' opened at %C is not a GFORTRAN module "
5723 "file", filename);
5724 if (start == 3)
5726 if (strcmp (atom_name, " version") != 0
5727 || module_char () != ' '
5728 || parse_atom () != ATOM_STRING)
5729 gfc_fatal_error ("Parse error when checking module version"
5730 " for file '%s' opened at %C", filename);
5732 if (strcmp (atom_string, MOD_VERSION))
5734 gfc_fatal_error ("Wrong module version '%s' (expected '%s') "
5735 "for file '%s' opened at %C", atom_string,
5736 MOD_VERSION, filename);
5739 gfc_free (atom_string);
5742 if (c == '\n')
5743 line++;
5746 /* Make sure we're not reading the same module that we may be building. */
5747 for (p = gfc_state_stack; p; p = p->previous)
5748 if (p->state == COMP_MODULE && strcmp (p->sym->name, module_name) == 0)
5749 gfc_fatal_error ("Can't USE the same module we're building!");
5751 init_pi_tree ();
5752 init_true_name_tree ();
5754 read_module ();
5756 free_true_name (true_name_root);
5757 true_name_root = NULL;
5759 free_pi_tree (pi_root);
5760 pi_root = NULL;
5762 fclose (module_fp);
5764 use_stmt = gfc_get_use_list ();
5765 use_stmt->module_name = gfc_get_string (module_name);
5766 use_stmt->only_flag = only_flag;
5767 use_stmt->rename = gfc_rename_list;
5768 use_stmt->where = use_locus;
5769 gfc_rename_list = NULL;
5770 use_stmt->next = gfc_current_ns->use_stmts;
5771 gfc_current_ns->use_stmts = use_stmt;
5775 void
5776 gfc_free_use_stmts (gfc_use_list *use_stmts)
5778 gfc_use_list *next;
5779 for (; use_stmts; use_stmts = next)
5781 gfc_use_rename *next_rename;
5783 for (; use_stmts->rename; use_stmts->rename = next_rename)
5785 next_rename = use_stmts->rename->next;
5786 gfc_free (use_stmts->rename);
5788 next = use_stmts->next;
5789 gfc_free (use_stmts);
5794 void
5795 gfc_module_init_2 (void)
5797 last_atom = ATOM_LPAREN;
5801 void
5802 gfc_module_done_2 (void)
5804 free_rename ();