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
4 Free Software Foundation, Inc.
5 Contributed by Andy Vaught
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* The syntax of gfortran modules resembles that of lisp lists, ie a
24 sequence of atoms, which can be left or right parenthesis, names,
25 integers or strings. Parenthesis are always matched which allows
26 us to skip over sections at high speed without having to know
27 anything about the internal structure of the lists. A "name" is
28 usually a fortran 95 identifier, but can also start with '@' in
29 order to reference a hidden symbol.
31 The first line of a module is an informational message about what
32 created the module, the file it came from and when it was created.
33 The second line is a warning for people not to edit the module.
34 The rest of the module looks like:
36 ( ( <Interface info for UPLUS> )
37 ( <Interface info for UMINUS> )
40 ( ( <name of operator interface> <module of op interface> <i/f1> ... )
43 ( ( <name of generic interface> <module of generic interface> <i/f1> ... )
46 ( ( <common name> <symbol> <saved flag>)
52 ( <Symbol Number (in no particular order)>
54 <Module name of symbol>
55 ( <symbol information> )
64 In general, symbols refer to other symbols by their symbol number,
65 which are zero based. Symbols are written to the module in no
73 #include "parse.h" /* FIXME */
76 #define MODULE_EXTENSION ".mod"
79 /* Structure that describes a position within a module file. */
88 /* Structure for list of symbols of intrinsic modules. */
100 P_UNKNOWN = 0, P_OTHER, P_NAMESPACE, P_COMPONENT, P_SYMBOL
104 /* The fixup structure lists pointers to pointers that have to
105 be updated when a pointer value becomes known. */
107 typedef struct fixup_t
110 struct fixup_t *next;
115 /* Structure for holding extra info needed for pointers being read. */
117 typedef struct pointer_info
119 BBT_HEADER (pointer_info);
123 /* The first component of each member of the union is the pointer
130 void *pointer; /* Member for doing pointer searches. */
135 char true_name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
137 { UNUSED, NEEDED, USED }
142 gfc_symtree *symtree;
143 char binding_label[GFC_MAX_SYMBOL_LEN + 1];
151 { UNREFERENCED = 0, NEEDS_WRITE, WRITTEN }
161 #define gfc_get_pointer_info() gfc_getmem(sizeof(pointer_info))
164 /* Lists of rename info for the USE statement. */
166 typedef struct gfc_use_rename
168 char local_name[GFC_MAX_SYMBOL_LEN + 1], use_name[GFC_MAX_SYMBOL_LEN + 1];
169 struct gfc_use_rename *next;
171 gfc_intrinsic_op operator;
176 #define gfc_get_use_rename() gfc_getmem(sizeof(gfc_use_rename))
178 /* Local variables */
180 /* The FILE for the module we're reading or writing. */
181 static FILE *module_fp;
183 /* MD5 context structure. */
184 static struct md5_ctx ctx;
186 /* The name of the module we're reading (USE'ing) or writing. */
187 static char module_name[GFC_MAX_SYMBOL_LEN + 1];
189 /* The way the module we're reading was specified. */
190 static bool specified_nonint, specified_int;
192 static int module_line, module_column, only_flag;
194 { IO_INPUT, IO_OUTPUT }
197 static gfc_use_rename *gfc_rename_list;
198 static pointer_info *pi_root;
199 static int symbol_number; /* Counter for assigning symbol numbers */
201 /* Tells mio_expr_ref to make symbols for unused equivalence members. */
202 static bool in_load_equiv;
206 /*****************************************************************/
208 /* Pointer/integer conversion. Pointers between structures are stored
209 as integers in the module file. The next couple of subroutines
210 handle this translation for reading and writing. */
212 /* Recursively free the tree of pointer structures. */
215 free_pi_tree (pointer_info *p)
220 if (p->fixup != NULL)
221 gfc_internal_error ("free_pi_tree(): Unresolved fixup");
223 free_pi_tree (p->left);
224 free_pi_tree (p->right);
230 /* Compare pointers when searching by pointer. Used when writing a
234 compare_pointers (void *_sn1, void *_sn2)
236 pointer_info *sn1, *sn2;
238 sn1 = (pointer_info *) _sn1;
239 sn2 = (pointer_info *) _sn2;
241 if (sn1->u.pointer < sn2->u.pointer)
243 if (sn1->u.pointer > sn2->u.pointer)
250 /* Compare integers when searching by integer. Used when reading a
254 compare_integers (void *_sn1, void *_sn2)
256 pointer_info *sn1, *sn2;
258 sn1 = (pointer_info *) _sn1;
259 sn2 = (pointer_info *) _sn2;
261 if (sn1->integer < sn2->integer)
263 if (sn1->integer > sn2->integer)
270 /* Initialize the pointer_info tree. */
279 compare = (iomode == IO_INPUT) ? compare_integers : compare_pointers;
281 /* Pointer 0 is the NULL pointer. */
282 p = gfc_get_pointer_info ();
287 gfc_insert_bbt (&pi_root, p, compare);
289 /* Pointer 1 is the current namespace. */
290 p = gfc_get_pointer_info ();
291 p->u.pointer = gfc_current_ns;
293 p->type = P_NAMESPACE;
295 gfc_insert_bbt (&pi_root, p, compare);
301 /* During module writing, call here with a pointer to something,
302 returning the pointer_info node. */
304 static pointer_info *
305 find_pointer (void *gp)
312 if (p->u.pointer == gp)
314 p = (gp < p->u.pointer) ? p->left : p->right;
321 /* Given a pointer while writing, returns the pointer_info tree node,
322 creating it if it doesn't exist. */
324 static pointer_info *
325 get_pointer (void *gp)
329 p = find_pointer (gp);
333 /* Pointer doesn't have an integer. Give it one. */
334 p = gfc_get_pointer_info ();
337 p->integer = symbol_number++;
339 gfc_insert_bbt (&pi_root, p, compare_pointers);
345 /* Given an integer during reading, find it in the pointer_info tree,
346 creating the node if not found. */
348 static pointer_info *
349 get_integer (int integer)
359 c = compare_integers (&t, p);
363 p = (c < 0) ? p->left : p->right;
369 p = gfc_get_pointer_info ();
370 p->integer = integer;
373 gfc_insert_bbt (&pi_root, p, compare_integers);
379 /* Recursive function to find a pointer within a tree by brute force. */
381 static pointer_info *
382 fp2 (pointer_info *p, const void *target)
389 if (p->u.pointer == target)
392 q = fp2 (p->left, target);
396 return fp2 (p->right, target);
400 /* During reading, find a pointer_info node from the pointer value.
401 This amounts to a brute-force search. */
403 static pointer_info *
404 find_pointer2 (void *p)
406 return fp2 (pi_root, p);
410 /* Resolve any fixups using a known pointer. */
413 resolve_fixups (fixup_t *f, void *gp)
426 /* Call here during module reading when we know what pointer to
427 associate with an integer. Any fixups that exist are resolved at
431 associate_integer_pointer (pointer_info *p, void *gp)
433 if (p->u.pointer != NULL)
434 gfc_internal_error ("associate_integer_pointer(): Already associated");
438 resolve_fixups (p->fixup, gp);
444 /* During module reading, given an integer and a pointer to a pointer,
445 either store the pointer from an already-known value or create a
446 fixup structure in order to store things later. Returns zero if
447 the reference has been actually stored, or nonzero if the reference
448 must be fixed later (ie associate_integer_pointer must be called
449 sometime later. Returns the pointer_info structure. */
451 static pointer_info *
452 add_fixup (int integer, void *gp)
458 p = get_integer (integer);
460 if (p->integer == 0 || p->u.pointer != NULL)
467 f = gfc_getmem (sizeof (fixup_t));
479 /*****************************************************************/
481 /* Parser related subroutines */
483 /* Free the rename list left behind by a USE statement. */
488 gfc_use_rename *next;
490 for (; gfc_rename_list; gfc_rename_list = next)
492 next = gfc_rename_list->next;
493 gfc_free (gfc_rename_list);
498 /* Match a USE statement. */
503 char name[GFC_MAX_SYMBOL_LEN + 1], module_nature[GFC_MAX_SYMBOL_LEN + 1];
504 gfc_use_rename *tail = NULL, *new;
505 interface_type type, type2;
506 gfc_intrinsic_op operator;
509 specified_int = false;
510 specified_nonint = false;
512 if (gfc_match (" , ") == MATCH_YES)
514 if ((m = gfc_match (" %n ::", module_nature)) == MATCH_YES)
516 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: module "
517 "nature in USE statement at %C") == FAILURE)
520 if (strcmp (module_nature, "intrinsic") == 0)
521 specified_int = true;
524 if (strcmp (module_nature, "non_intrinsic") == 0)
525 specified_nonint = true;
528 gfc_error ("Module nature in USE statement at %C shall "
529 "be either INTRINSIC or NON_INTRINSIC");
536 /* Help output a better error message than "Unclassifiable
538 gfc_match (" %n", module_nature);
539 if (strcmp (module_nature, "intrinsic") == 0
540 || strcmp (module_nature, "non_intrinsic") == 0)
541 gfc_error ("\"::\" was expected after module nature at %C "
542 "but was not found");
548 m = gfc_match (" ::");
549 if (m == MATCH_YES &&
550 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: "
551 "\"USE :: module\" at %C") == FAILURE)
556 m = gfc_match ("% ");
562 m = gfc_match_name (module_name);
569 if (gfc_match_eos () == MATCH_YES)
571 if (gfc_match_char (',') != MATCH_YES)
574 if (gfc_match (" only :") == MATCH_YES)
577 if (gfc_match_eos () == MATCH_YES)
582 /* Get a new rename struct and add it to the rename list. */
583 new = gfc_get_use_rename ();
584 new->where = gfc_current_locus;
587 if (gfc_rename_list == NULL)
588 gfc_rename_list = new;
593 /* See what kind of interface we're dealing with. Assume it is
595 new->operator = INTRINSIC_NONE;
596 if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
601 case INTERFACE_NAMELESS:
602 case INTERFACE_ABSTRACT:
603 gfc_error ("Missing generic specification in USE statement at %C");
606 case INTERFACE_USER_OP:
607 case INTERFACE_GENERIC:
608 m = gfc_match (" =>");
610 if (type == INTERFACE_USER_OP && m == MATCH_YES
611 && (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Renaming "
612 "operators in USE statements at %C")
616 if (type == INTERFACE_USER_OP)
617 new->operator = INTRINSIC_USER;
622 strcpy (new->use_name, name);
625 strcpy (new->local_name, name);
626 m = gfc_match_generic_spec (&type2, new->use_name, &operator);
631 if (m == MATCH_ERROR)
639 strcpy (new->local_name, name);
641 m = gfc_match_generic_spec (&type2, new->use_name, &operator);
646 if (m == MATCH_ERROR)
650 if (strcmp (new->use_name, module_name) == 0
651 || strcmp (new->local_name, module_name) == 0)
653 gfc_error ("The name '%s' at %C has already been used as "
654 "an external module name.", module_name);
659 case INTERFACE_INTRINSIC_OP:
660 new->operator = operator;
664 if (gfc_match_eos () == MATCH_YES)
666 if (gfc_match_char (',') != MATCH_YES)
673 gfc_syntax_error (ST_USE);
681 /* Given a name and a number, inst, return the inst name
682 under which to load this symbol. Returns NULL if this
683 symbol shouldn't be loaded. If inst is zero, returns
684 the number of instances of this name. If interface is
685 true, a user-defined operator is sought, otherwise only
686 non-operators are sought. */
689 find_use_name_n (const char *name, int *inst, bool interface)
695 for (u = gfc_rename_list; u; u = u->next)
697 if (strcmp (u->use_name, name) != 0
698 || (u->operator == INTRINSIC_USER && !interface)
699 || (u->operator != INTRINSIC_USER && interface))
712 return only_flag ? NULL : name;
716 return (u->local_name[0] != '\0') ? u->local_name : name;
720 /* Given a name, return the name under which to load this symbol.
721 Returns NULL if this symbol shouldn't be loaded. */
724 find_use_name (const char *name, bool interface)
727 return find_use_name_n (name, &i, interface);
731 /* Given a real name, return the number of use names associated with it. */
734 number_use_names (const char *name, bool interface)
738 c = find_use_name_n (name, &i, interface);
743 /* Try to find the operator in the current list. */
745 static gfc_use_rename *
746 find_use_operator (gfc_intrinsic_op operator)
750 for (u = gfc_rename_list; u; u = u->next)
751 if (u->operator == operator)
758 /*****************************************************************/
760 /* The next couple of subroutines maintain a tree used to avoid a
761 brute-force search for a combination of true name and module name.
762 While symtree names, the name that a particular symbol is known by
763 can changed with USE statements, we still have to keep track of the
764 true names to generate the correct reference, and also avoid
765 loading the same real symbol twice in a program unit.
767 When we start reading, the true name tree is built and maintained
768 as symbols are read. The tree is searched as we load new symbols
769 to see if it already exists someplace in the namespace. */
771 typedef struct true_name
773 BBT_HEADER (true_name);
778 static true_name *true_name_root;
781 /* Compare two true_name structures. */
784 compare_true_names (void *_t1, void *_t2)
789 t1 = (true_name *) _t1;
790 t2 = (true_name *) _t2;
792 c = ((t1->sym->module > t2->sym->module)
793 - (t1->sym->module < t2->sym->module));
797 return strcmp (t1->sym->name, t2->sym->name);
801 /* Given a true name, search the true name tree to see if it exists
802 within the main namespace. */
805 find_true_name (const char *name, const char *module)
811 sym.name = gfc_get_string (name);
813 sym.module = gfc_get_string (module);
821 c = compare_true_names ((void *) (&t), (void *) p);
825 p = (c < 0) ? p->left : p->right;
832 /* Given a gfc_symbol pointer that is not in the true name tree, add it. */
835 add_true_name (gfc_symbol *sym)
839 t = gfc_getmem (sizeof (true_name));
842 gfc_insert_bbt (&true_name_root, t, compare_true_names);
846 /* Recursive function to build the initial true name tree by
847 recursively traversing the current namespace. */
850 build_tnt (gfc_symtree *st)
855 build_tnt (st->left);
856 build_tnt (st->right);
858 if (find_true_name (st->n.sym->name, st->n.sym->module) != NULL)
861 add_true_name (st->n.sym);
865 /* Initialize the true name tree with the current namespace. */
868 init_true_name_tree (void)
870 true_name_root = NULL;
871 build_tnt (gfc_current_ns->sym_root);
875 /* Recursively free a true name tree node. */
878 free_true_name (true_name *t)
882 free_true_name (t->left);
883 free_true_name (t->right);
889 /*****************************************************************/
891 /* Module reading and writing. */
895 ATOM_NAME, ATOM_LPAREN, ATOM_RPAREN, ATOM_INTEGER, ATOM_STRING
899 static atom_type last_atom;
902 /* The name buffer must be at least as long as a symbol name. Right
903 now it's not clear how we're going to store numeric constants--
904 probably as a hexadecimal string, since this will allow the exact
905 number to be preserved (this can't be done by a decimal
906 representation). Worry about that later. TODO! */
908 #define MAX_ATOM_SIZE 100
911 static char *atom_string, atom_name[MAX_ATOM_SIZE];
914 /* Report problems with a module. Error reporting is not very
915 elaborate, since this sorts of errors shouldn't really happen.
916 This subroutine never returns. */
918 static void bad_module (const char *) ATTRIBUTE_NORETURN;
921 bad_module (const char *msgid)
928 gfc_fatal_error ("Reading module %s at line %d column %d: %s",
929 module_name, module_line, module_column, msgid);
932 gfc_fatal_error ("Writing module %s at line %d column %d: %s",
933 module_name, module_line, module_column, msgid);
936 gfc_fatal_error ("Module %s at line %d column %d: %s",
937 module_name, module_line, module_column, msgid);
943 /* Set the module's input pointer. */
946 set_module_locus (module_locus *m)
948 module_column = m->column;
949 module_line = m->line;
950 fsetpos (module_fp, &m->pos);
954 /* Get the module's input pointer so that we can restore it later. */
957 get_module_locus (module_locus *m)
959 m->column = module_column;
960 m->line = module_line;
961 fgetpos (module_fp, &m->pos);
965 /* Get the next character in the module, updating our reckoning of
973 c = getc (module_fp);
976 bad_module ("Unexpected EOF");
989 /* Parse a string constant. The delimiter is guaranteed to be a
999 get_module_locus (&start);
1003 /* See how long the string is. */
1008 bad_module ("Unexpected end of module in string constant");
1026 set_module_locus (&start);
1028 atom_string = p = gfc_getmem (len + 1);
1030 for (; len > 0; len--)
1034 module_char (); /* Guaranteed to be another \'. */
1038 module_char (); /* Terminating \'. */
1039 *p = '\0'; /* C-style string for debug purposes. */
1043 /* Parse a small integer. */
1046 parse_integer (int c)
1054 get_module_locus (&m);
1060 atom_int = 10 * atom_int + c - '0';
1061 if (atom_int > 99999999)
1062 bad_module ("Integer overflow");
1065 set_module_locus (&m);
1083 get_module_locus (&m);
1088 if (!ISALNUM (c) && c != '_' && c != '-')
1092 if (++len > GFC_MAX_SYMBOL_LEN)
1093 bad_module ("Name too long");
1098 fseek (module_fp, -1, SEEK_CUR);
1099 module_column = m.column + len - 1;
1106 /* Read the next atom in the module's input stream. */
1117 while (c == ' ' || c == '\n');
1142 return ATOM_INTEGER;
1200 bad_module ("Bad name");
1207 /* Peek at the next atom on the input. */
1215 get_module_locus (&m);
1218 if (a == ATOM_STRING)
1219 gfc_free (atom_string);
1221 set_module_locus (&m);
1226 /* Read the next atom from the input, requiring that it be a
1230 require_atom (atom_type type)
1236 get_module_locus (&m);
1244 p = _("Expected name");
1247 p = _("Expected left parenthesis");
1250 p = _("Expected right parenthesis");
1253 p = _("Expected integer");
1256 p = _("Expected string");
1259 gfc_internal_error ("require_atom(): bad atom type required");
1262 set_module_locus (&m);
1268 /* Given a pointer to an mstring array, require that the current input
1269 be one of the strings in the array. We return the enum value. */
1272 find_enum (const mstring *m)
1276 i = gfc_string2code (m, atom_name);
1280 bad_module ("find_enum(): Enum not found");
1286 /**************** Module output subroutines ***************************/
1288 /* Output a character to a module file. */
1291 write_char (char out)
1293 if (putc (out, module_fp) == EOF)
1294 gfc_fatal_error ("Error writing modules file: %s", strerror (errno));
1296 /* Add this to our MD5. */
1297 md5_process_bytes (&out, sizeof (out), &ctx);
1309 /* Write an atom to a module. The line wrapping isn't perfect, but it
1310 should work most of the time. This isn't that big of a deal, since
1311 the file really isn't meant to be read by people anyway. */
1314 write_atom (atom_type atom, const void *v)
1336 i = *((const int *) v);
1338 gfc_internal_error ("write_atom(): Writing negative integer");
1340 sprintf (buffer, "%d", i);
1345 gfc_internal_error ("write_atom(): Trying to write dab atom");
1349 if(p == NULL || *p == '\0')
1354 if (atom != ATOM_RPAREN)
1356 if (module_column + len > 72)
1361 if (last_atom != ATOM_LPAREN && module_column != 1)
1366 if (atom == ATOM_STRING)
1369 while (p != NULL && *p)
1371 if (atom == ATOM_STRING && *p == '\'')
1376 if (atom == ATOM_STRING)
1384 /***************** Mid-level I/O subroutines *****************/
1386 /* These subroutines let their caller read or write atoms without
1387 caring about which of the two is actually happening. This lets a
1388 subroutine concentrate on the actual format of the data being
1391 static void mio_expr (gfc_expr **);
1392 static void mio_symbol_ref (gfc_symbol **);
1393 static void mio_symtree_ref (gfc_symtree **);
1395 /* Read or write an enumerated value. On writing, we return the input
1396 value for the convenience of callers. We avoid using an integer
1397 pointer because enums are sometimes inside bitfields. */
1400 mio_name (int t, const mstring *m)
1402 if (iomode == IO_OUTPUT)
1403 write_atom (ATOM_NAME, gfc_code2string (m, t));
1406 require_atom (ATOM_NAME);
1413 /* Specialization of mio_name. */
1415 #define DECL_MIO_NAME(TYPE) \
1416 static inline TYPE \
1417 MIO_NAME(TYPE) (TYPE t, const mstring *m) \
1419 return (TYPE) mio_name ((int) t, m); \
1421 #define MIO_NAME(TYPE) mio_name_##TYPE
1426 if (iomode == IO_OUTPUT)
1427 write_atom (ATOM_LPAREN, NULL);
1429 require_atom (ATOM_LPAREN);
1436 if (iomode == IO_OUTPUT)
1437 write_atom (ATOM_RPAREN, NULL);
1439 require_atom (ATOM_RPAREN);
1444 mio_integer (int *ip)
1446 if (iomode == IO_OUTPUT)
1447 write_atom (ATOM_INTEGER, ip);
1450 require_atom (ATOM_INTEGER);
1456 /* Read or write a character pointer that points to a string on the heap. */
1459 mio_allocated_string (const char *s)
1461 if (iomode == IO_OUTPUT)
1463 write_atom (ATOM_STRING, s);
1468 require_atom (ATOM_STRING);
1474 /* Read or write a string that is in static memory. */
1477 mio_pool_string (const char **stringp)
1479 /* TODO: one could write the string only once, and refer to it via a
1482 /* As a special case we have to deal with a NULL string. This
1483 happens for the 'module' member of 'gfc_symbol's that are not in a
1484 module. We read / write these as the empty string. */
1485 if (iomode == IO_OUTPUT)
1487 const char *p = *stringp == NULL ? "" : *stringp;
1488 write_atom (ATOM_STRING, p);
1492 require_atom (ATOM_STRING);
1493 *stringp = atom_string[0] == '\0' ? NULL : gfc_get_string (atom_string);
1494 gfc_free (atom_string);
1499 /* Read or write a string that is inside of some already-allocated
1503 mio_internal_string (char *string)
1505 if (iomode == IO_OUTPUT)
1506 write_atom (ATOM_STRING, string);
1509 require_atom (ATOM_STRING);
1510 strcpy (string, atom_string);
1511 gfc_free (atom_string);
1517 { AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL,
1518 AB_POINTER, AB_TARGET, AB_DUMMY, AB_RESULT, AB_DATA,
1519 AB_IN_NAMELIST, AB_IN_COMMON, AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE,
1520 AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT,
1521 AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP,
1522 AB_POINTER_COMP, AB_PRIVATE_COMP, AB_VALUE, AB_VOLATILE, AB_PROTECTED,
1523 AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT
1527 static const mstring attr_bits[] =
1529 minit ("ALLOCATABLE", AB_ALLOCATABLE),
1530 minit ("DIMENSION", AB_DIMENSION),
1531 minit ("EXTERNAL", AB_EXTERNAL),
1532 minit ("INTRINSIC", AB_INTRINSIC),
1533 minit ("OPTIONAL", AB_OPTIONAL),
1534 minit ("POINTER", AB_POINTER),
1535 minit ("VOLATILE", AB_VOLATILE),
1536 minit ("TARGET", AB_TARGET),
1537 minit ("THREADPRIVATE", AB_THREADPRIVATE),
1538 minit ("DUMMY", AB_DUMMY),
1539 minit ("RESULT", AB_RESULT),
1540 minit ("DATA", AB_DATA),
1541 minit ("IN_NAMELIST", AB_IN_NAMELIST),
1542 minit ("IN_COMMON", AB_IN_COMMON),
1543 minit ("FUNCTION", AB_FUNCTION),
1544 minit ("SUBROUTINE", AB_SUBROUTINE),
1545 minit ("SEQUENCE", AB_SEQUENCE),
1546 minit ("ELEMENTAL", AB_ELEMENTAL),
1547 minit ("PURE", AB_PURE),
1548 minit ("RECURSIVE", AB_RECURSIVE),
1549 minit ("GENERIC", AB_GENERIC),
1550 minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT),
1551 minit ("CRAY_POINTER", AB_CRAY_POINTER),
1552 minit ("CRAY_POINTEE", AB_CRAY_POINTEE),
1553 minit ("IS_BIND_C", AB_IS_BIND_C),
1554 minit ("IS_C_INTEROP", AB_IS_C_INTEROP),
1555 minit ("IS_ISO_C", AB_IS_ISO_C),
1556 minit ("VALUE", AB_VALUE),
1557 minit ("ALLOC_COMP", AB_ALLOC_COMP),
1558 minit ("POINTER_COMP", AB_POINTER_COMP),
1559 minit ("PRIVATE_COMP", AB_PRIVATE_COMP),
1560 minit ("PROTECTED", AB_PROTECTED),
1561 minit ("ABSTRACT", AB_ABSTRACT),
1566 /* Specialization of mio_name. */
1567 DECL_MIO_NAME (ab_attribute)
1568 DECL_MIO_NAME (ar_type)
1569 DECL_MIO_NAME (array_type)
1571 DECL_MIO_NAME (expr_t)
1572 DECL_MIO_NAME (gfc_access)
1573 DECL_MIO_NAME (gfc_intrinsic_op)
1574 DECL_MIO_NAME (ifsrc)
1575 DECL_MIO_NAME (save_state)
1576 DECL_MIO_NAME (procedure_type)
1577 DECL_MIO_NAME (ref_type)
1578 DECL_MIO_NAME (sym_flavor)
1579 DECL_MIO_NAME (sym_intent)
1580 #undef DECL_MIO_NAME
1582 /* Symbol attributes are stored in list with the first three elements
1583 being the enumerated fields, while the remaining elements (if any)
1584 indicate the individual attribute bits. The access field is not
1585 saved-- it controls what symbols are exported when a module is
1589 mio_symbol_attribute (symbol_attribute *attr)
1595 attr->flavor = MIO_NAME (sym_flavor) (attr->flavor, flavors);
1596 attr->intent = MIO_NAME (sym_intent) (attr->intent, intents);
1597 attr->proc = MIO_NAME (procedure_type) (attr->proc, procedures);
1598 attr->if_source = MIO_NAME (ifsrc) (attr->if_source, ifsrc_types);
1599 attr->save = MIO_NAME (save_state) (attr->save, save_status);
1601 if (iomode == IO_OUTPUT)
1603 if (attr->allocatable)
1604 MIO_NAME (ab_attribute) (AB_ALLOCATABLE, attr_bits);
1605 if (attr->dimension)
1606 MIO_NAME (ab_attribute) (AB_DIMENSION, attr_bits);
1608 MIO_NAME (ab_attribute) (AB_EXTERNAL, attr_bits);
1609 if (attr->intrinsic)
1610 MIO_NAME (ab_attribute) (AB_INTRINSIC, attr_bits);
1612 MIO_NAME (ab_attribute) (AB_OPTIONAL, attr_bits);
1614 MIO_NAME (ab_attribute) (AB_POINTER, attr_bits);
1615 if (attr->protected)
1616 MIO_NAME (ab_attribute) (AB_PROTECTED, attr_bits);
1618 MIO_NAME (ab_attribute) (AB_VALUE, attr_bits);
1619 if (attr->volatile_)
1620 MIO_NAME (ab_attribute) (AB_VOLATILE, attr_bits);
1622 MIO_NAME (ab_attribute) (AB_TARGET, attr_bits);
1623 if (attr->threadprivate)
1624 MIO_NAME (ab_attribute) (AB_THREADPRIVATE, attr_bits);
1626 MIO_NAME (ab_attribute) (AB_DUMMY, attr_bits);
1628 MIO_NAME (ab_attribute) (AB_RESULT, attr_bits);
1629 /* We deliberately don't preserve the "entry" flag. */
1632 MIO_NAME (ab_attribute) (AB_DATA, attr_bits);
1633 if (attr->in_namelist)
1634 MIO_NAME (ab_attribute) (AB_IN_NAMELIST, attr_bits);
1635 if (attr->in_common)
1636 MIO_NAME (ab_attribute) (AB_IN_COMMON, attr_bits);
1639 MIO_NAME (ab_attribute) (AB_FUNCTION, attr_bits);
1640 if (attr->subroutine)
1641 MIO_NAME (ab_attribute) (AB_SUBROUTINE, attr_bits);
1643 MIO_NAME (ab_attribute) (AB_GENERIC, attr_bits);
1645 MIO_NAME (ab_attribute) (AB_ABSTRACT, attr_bits);
1648 MIO_NAME (ab_attribute) (AB_SEQUENCE, attr_bits);
1649 if (attr->elemental)
1650 MIO_NAME (ab_attribute) (AB_ELEMENTAL, attr_bits);
1652 MIO_NAME (ab_attribute) (AB_PURE, attr_bits);
1653 if (attr->recursive)
1654 MIO_NAME (ab_attribute) (AB_RECURSIVE, attr_bits);
1655 if (attr->always_explicit)
1656 MIO_NAME (ab_attribute) (AB_ALWAYS_EXPLICIT, attr_bits);
1657 if (attr->cray_pointer)
1658 MIO_NAME (ab_attribute) (AB_CRAY_POINTER, attr_bits);
1659 if (attr->cray_pointee)
1660 MIO_NAME (ab_attribute) (AB_CRAY_POINTEE, attr_bits);
1661 if (attr->is_bind_c)
1662 MIO_NAME(ab_attribute) (AB_IS_BIND_C, attr_bits);
1663 if (attr->is_c_interop)
1664 MIO_NAME(ab_attribute) (AB_IS_C_INTEROP, attr_bits);
1666 MIO_NAME(ab_attribute) (AB_IS_ISO_C, attr_bits);
1667 if (attr->alloc_comp)
1668 MIO_NAME (ab_attribute) (AB_ALLOC_COMP, attr_bits);
1669 if (attr->pointer_comp)
1670 MIO_NAME (ab_attribute) (AB_POINTER_COMP, attr_bits);
1671 if (attr->private_comp)
1672 MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits);
1682 if (t == ATOM_RPAREN)
1685 bad_module ("Expected attribute bit name");
1687 switch ((ab_attribute) find_enum (attr_bits))
1689 case AB_ALLOCATABLE:
1690 attr->allocatable = 1;
1693 attr->dimension = 1;
1699 attr->intrinsic = 1;
1708 attr->protected = 1;
1714 attr->volatile_ = 1;
1719 case AB_THREADPRIVATE:
1720 attr->threadprivate = 1;
1731 case AB_IN_NAMELIST:
1732 attr->in_namelist = 1;
1735 attr->in_common = 1;
1741 attr->subroutine = 1;
1753 attr->elemental = 1;
1759 attr->recursive = 1;
1761 case AB_ALWAYS_EXPLICIT:
1762 attr->always_explicit = 1;
1764 case AB_CRAY_POINTER:
1765 attr->cray_pointer = 1;
1767 case AB_CRAY_POINTEE:
1768 attr->cray_pointee = 1;
1771 attr->is_bind_c = 1;
1773 case AB_IS_C_INTEROP:
1774 attr->is_c_interop = 1;
1780 attr->alloc_comp = 1;
1782 case AB_POINTER_COMP:
1783 attr->pointer_comp = 1;
1785 case AB_PRIVATE_COMP:
1786 attr->private_comp = 1;
1794 static const mstring bt_types[] = {
1795 minit ("INTEGER", BT_INTEGER),
1796 minit ("REAL", BT_REAL),
1797 minit ("COMPLEX", BT_COMPLEX),
1798 minit ("LOGICAL", BT_LOGICAL),
1799 minit ("CHARACTER", BT_CHARACTER),
1800 minit ("DERIVED", BT_DERIVED),
1801 minit ("PROCEDURE", BT_PROCEDURE),
1802 minit ("UNKNOWN", BT_UNKNOWN),
1803 minit ("VOID", BT_VOID),
1809 mio_charlen (gfc_charlen **clp)
1815 if (iomode == IO_OUTPUT)
1819 mio_expr (&cl->length);
1823 if (peek_atom () != ATOM_RPAREN)
1825 cl = gfc_get_charlen ();
1826 mio_expr (&cl->length);
1830 cl->next = gfc_current_ns->cl_list;
1831 gfc_current_ns->cl_list = cl;
1839 /* See if a name is a generated name. */
1842 check_unique_name (const char *name)
1844 return *name == '@';
1849 mio_typespec (gfc_typespec *ts)
1853 ts->type = MIO_NAME (bt) (ts->type, bt_types);
1855 if (ts->type != BT_DERIVED)
1856 mio_integer (&ts->kind);
1858 mio_symbol_ref (&ts->derived);
1860 /* Add info for C interop and is_iso_c. */
1861 mio_integer (&ts->is_c_interop);
1862 mio_integer (&ts->is_iso_c);
1864 /* If the typespec is for an identifier either from iso_c_binding, or
1865 a constant that was initialized to an identifier from it, use the
1866 f90_type. Otherwise, use the ts->type, since it shouldn't matter. */
1868 ts->f90_type = MIO_NAME (bt) (ts->f90_type, bt_types);
1870 ts->f90_type = MIO_NAME (bt) (ts->type, bt_types);
1872 if (ts->type != BT_CHARACTER)
1874 /* ts->cl is only valid for BT_CHARACTER. */
1879 mio_charlen (&ts->cl);
1885 static const mstring array_spec_types[] = {
1886 minit ("EXPLICIT", AS_EXPLICIT),
1887 minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE),
1888 minit ("DEFERRED", AS_DEFERRED),
1889 minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE),
1895 mio_array_spec (gfc_array_spec **asp)
1902 if (iomode == IO_OUTPUT)
1910 if (peek_atom () == ATOM_RPAREN)
1916 *asp = as = gfc_get_array_spec ();
1919 mio_integer (&as->rank);
1920 as->type = MIO_NAME (array_type) (as->type, array_spec_types);
1922 for (i = 0; i < as->rank; i++)
1924 mio_expr (&as->lower[i]);
1925 mio_expr (&as->upper[i]);
1933 /* Given a pointer to an array reference structure (which lives in a
1934 gfc_ref structure), find the corresponding array specification
1935 structure. Storing the pointer in the ref structure doesn't quite
1936 work when loading from a module. Generating code for an array
1937 reference also needs more information than just the array spec. */
1939 static const mstring array_ref_types[] = {
1940 minit ("FULL", AR_FULL),
1941 minit ("ELEMENT", AR_ELEMENT),
1942 minit ("SECTION", AR_SECTION),
1948 mio_array_ref (gfc_array_ref *ar)
1953 ar->type = MIO_NAME (ar_type) (ar->type, array_ref_types);
1954 mio_integer (&ar->dimen);
1962 for (i = 0; i < ar->dimen; i++)
1963 mio_expr (&ar->start[i]);
1968 for (i = 0; i < ar->dimen; i++)
1970 mio_expr (&ar->start[i]);
1971 mio_expr (&ar->end[i]);
1972 mio_expr (&ar->stride[i]);
1978 gfc_internal_error ("mio_array_ref(): Unknown array ref");
1981 /* Unfortunately, ar->dimen_type is an anonymous enumerated type so
1982 we can't call mio_integer directly. Instead loop over each element
1983 and cast it to/from an integer. */
1984 if (iomode == IO_OUTPUT)
1986 for (i = 0; i < ar->dimen; i++)
1988 int tmp = (int)ar->dimen_type[i];
1989 write_atom (ATOM_INTEGER, &tmp);
1994 for (i = 0; i < ar->dimen; i++)
1996 require_atom (ATOM_INTEGER);
1997 ar->dimen_type[i] = atom_int;
2001 if (iomode == IO_INPUT)
2003 ar->where = gfc_current_locus;
2005 for (i = 0; i < ar->dimen; i++)
2006 ar->c_where[i] = gfc_current_locus;
2013 /* Saves or restores a pointer. The pointer is converted back and
2014 forth from an integer. We return the pointer_info pointer so that
2015 the caller can take additional action based on the pointer type. */
2017 static pointer_info *
2018 mio_pointer_ref (void *gp)
2022 if (iomode == IO_OUTPUT)
2024 p = get_pointer (*((char **) gp));
2025 write_atom (ATOM_INTEGER, &p->integer);
2029 require_atom (ATOM_INTEGER);
2030 p = add_fixup (atom_int, gp);
2037 /* Save and load references to components that occur within
2038 expressions. We have to describe these references by a number and
2039 by name. The number is necessary for forward references during
2040 reading, and the name is necessary if the symbol already exists in
2041 the namespace and is not loaded again. */
2044 mio_component_ref (gfc_component **cp, gfc_symbol *sym)
2046 char name[GFC_MAX_SYMBOL_LEN + 1];
2050 p = mio_pointer_ref (cp);
2051 if (p->type == P_UNKNOWN)
2052 p->type = P_COMPONENT;
2054 if (iomode == IO_OUTPUT)
2055 mio_pool_string (&(*cp)->name);
2058 mio_internal_string (name);
2060 /* It can happen that a component reference can be read before the
2061 associated derived type symbol has been loaded. Return now and
2062 wait for a later iteration of load_needed. */
2066 if (sym->components != NULL && p->u.pointer == NULL)
2068 /* Symbol already loaded, so search by name. */
2069 for (q = sym->components; q; q = q->next)
2070 if (strcmp (q->name, name) == 0)
2074 gfc_internal_error ("mio_component_ref(): Component not found");
2076 associate_integer_pointer (p, q);
2079 /* Make sure this symbol will eventually be loaded. */
2080 p = find_pointer2 (sym);
2081 if (p->u.rsym.state == UNUSED)
2082 p->u.rsym.state = NEEDED;
2088 mio_component (gfc_component *c)
2095 if (iomode == IO_OUTPUT)
2097 p = get_pointer (c);
2098 mio_integer (&p->integer);
2103 p = get_integer (n);
2104 associate_integer_pointer (p, c);
2107 if (p->type == P_UNKNOWN)
2108 p->type = P_COMPONENT;
2110 mio_pool_string (&c->name);
2111 mio_typespec (&c->ts);
2112 mio_array_spec (&c->as);
2114 mio_integer (&c->dimension);
2115 mio_integer (&c->pointer);
2116 mio_integer (&c->allocatable);
2117 c->access = MIO_NAME (gfc_access) (c->access, access_types);
2119 mio_expr (&c->initializer);
2125 mio_component_list (gfc_component **cp)
2127 gfc_component *c, *tail;
2131 if (iomode == IO_OUTPUT)
2133 for (c = *cp; c; c = c->next)
2143 if (peek_atom () == ATOM_RPAREN)
2146 c = gfc_get_component ();
2163 mio_actual_arg (gfc_actual_arglist *a)
2166 mio_pool_string (&a->name);
2167 mio_expr (&a->expr);
2173 mio_actual_arglist (gfc_actual_arglist **ap)
2175 gfc_actual_arglist *a, *tail;
2179 if (iomode == IO_OUTPUT)
2181 for (a = *ap; a; a = a->next)
2191 if (peek_atom () != ATOM_LPAREN)
2194 a = gfc_get_actual_arglist ();
2210 /* Read and write formal argument lists. */
2213 mio_formal_arglist (gfc_symbol *sym)
2215 gfc_formal_arglist *f, *tail;
2219 if (iomode == IO_OUTPUT)
2221 for (f = sym->formal; f; f = f->next)
2222 mio_symbol_ref (&f->sym);
2226 sym->formal = tail = NULL;
2228 while (peek_atom () != ATOM_RPAREN)
2230 f = gfc_get_formal_arglist ();
2231 mio_symbol_ref (&f->sym);
2233 if (sym->formal == NULL)
2246 /* Save or restore a reference to a symbol node. */
2249 mio_symbol_ref (gfc_symbol **symp)
2253 p = mio_pointer_ref (symp);
2254 if (p->type == P_UNKNOWN)
2257 if (iomode == IO_OUTPUT)
2259 if (p->u.wsym.state == UNREFERENCED)
2260 p->u.wsym.state = NEEDS_WRITE;
2264 if (p->u.rsym.state == UNUSED)
2265 p->u.rsym.state = NEEDED;
2270 /* Save or restore a reference to a symtree node. */
2273 mio_symtree_ref (gfc_symtree **stp)
2278 if (iomode == IO_OUTPUT)
2279 mio_symbol_ref (&(*stp)->n.sym);
2282 require_atom (ATOM_INTEGER);
2283 p = get_integer (atom_int);
2285 /* An unused equivalence member; make a symbol and a symtree
2287 if (in_load_equiv && p->u.rsym.symtree == NULL)
2289 /* Since this is not used, it must have a unique name. */
2290 p->u.rsym.symtree = gfc_get_unique_symtree (gfc_current_ns);
2292 /* Make the symbol. */
2293 if (p->u.rsym.sym == NULL)
2295 p->u.rsym.sym = gfc_new_symbol (p->u.rsym.true_name,
2297 p->u.rsym.sym->module = gfc_get_string (p->u.rsym.module);
2300 p->u.rsym.symtree->n.sym = p->u.rsym.sym;
2301 p->u.rsym.symtree->n.sym->refs++;
2302 p->u.rsym.referenced = 1;
2305 if (p->type == P_UNKNOWN)
2308 if (p->u.rsym.state == UNUSED)
2309 p->u.rsym.state = NEEDED;
2311 if (p->u.rsym.symtree != NULL)
2313 *stp = p->u.rsym.symtree;
2317 f = gfc_getmem (sizeof (fixup_t));
2319 f->next = p->u.rsym.stfixup;
2320 p->u.rsym.stfixup = f;
2322 f->pointer = (void **) stp;
2329 mio_iterator (gfc_iterator **ip)
2335 if (iomode == IO_OUTPUT)
2342 if (peek_atom () == ATOM_RPAREN)
2348 *ip = gfc_get_iterator ();
2353 mio_expr (&iter->var);
2354 mio_expr (&iter->start);
2355 mio_expr (&iter->end);
2356 mio_expr (&iter->step);
2364 mio_constructor (gfc_constructor **cp)
2366 gfc_constructor *c, *tail;
2370 if (iomode == IO_OUTPUT)
2372 for (c = *cp; c; c = c->next)
2375 mio_expr (&c->expr);
2376 mio_iterator (&c->iterator);
2385 while (peek_atom () != ATOM_RPAREN)
2387 c = gfc_get_constructor ();
2397 mio_expr (&c->expr);
2398 mio_iterator (&c->iterator);
2407 static const mstring ref_types[] = {
2408 minit ("ARRAY", REF_ARRAY),
2409 minit ("COMPONENT", REF_COMPONENT),
2410 minit ("SUBSTRING", REF_SUBSTRING),
2416 mio_ref (gfc_ref **rp)
2423 r->type = MIO_NAME (ref_type) (r->type, ref_types);
2428 mio_array_ref (&r->u.ar);
2432 mio_symbol_ref (&r->u.c.sym);
2433 mio_component_ref (&r->u.c.component, r->u.c.sym);
2437 mio_expr (&r->u.ss.start);
2438 mio_expr (&r->u.ss.end);
2439 mio_charlen (&r->u.ss.length);
2448 mio_ref_list (gfc_ref **rp)
2450 gfc_ref *ref, *head, *tail;
2454 if (iomode == IO_OUTPUT)
2456 for (ref = *rp; ref; ref = ref->next)
2463 while (peek_atom () != ATOM_RPAREN)
2466 head = tail = gfc_get_ref ();
2469 tail->next = gfc_get_ref ();
2483 /* Read and write an integer value. */
2486 mio_gmp_integer (mpz_t *integer)
2490 if (iomode == IO_INPUT)
2492 if (parse_atom () != ATOM_STRING)
2493 bad_module ("Expected integer string");
2495 mpz_init (*integer);
2496 if (mpz_set_str (*integer, atom_string, 10))
2497 bad_module ("Error converting integer");
2499 gfc_free (atom_string);
2503 p = mpz_get_str (NULL, 10, *integer);
2504 write_atom (ATOM_STRING, p);
2511 mio_gmp_real (mpfr_t *real)
2516 if (iomode == IO_INPUT)
2518 if (parse_atom () != ATOM_STRING)
2519 bad_module ("Expected real string");
2522 mpfr_set_str (*real, atom_string, 16, GFC_RND_MODE);
2523 gfc_free (atom_string);
2527 p = mpfr_get_str (NULL, &exponent, 16, 0, *real, GFC_RND_MODE);
2528 atom_string = gfc_getmem (strlen (p) + 20);
2530 sprintf (atom_string, "0.%s@%ld", p, exponent);
2532 /* Fix negative numbers. */
2533 if (atom_string[2] == '-')
2535 atom_string[0] = '-';
2536 atom_string[1] = '0';
2537 atom_string[2] = '.';
2540 write_atom (ATOM_STRING, atom_string);
2542 gfc_free (atom_string);
2548 /* Save and restore the shape of an array constructor. */
2551 mio_shape (mpz_t **pshape, int rank)
2557 /* A NULL shape is represented by (). */
2560 if (iomode == IO_OUTPUT)
2572 if (t == ATOM_RPAREN)
2579 shape = gfc_get_shape (rank);
2583 for (n = 0; n < rank; n++)
2584 mio_gmp_integer (&shape[n]);
2590 static const mstring expr_types[] = {
2591 minit ("OP", EXPR_OP),
2592 minit ("FUNCTION", EXPR_FUNCTION),
2593 minit ("CONSTANT", EXPR_CONSTANT),
2594 minit ("VARIABLE", EXPR_VARIABLE),
2595 minit ("SUBSTRING", EXPR_SUBSTRING),
2596 minit ("STRUCTURE", EXPR_STRUCTURE),
2597 minit ("ARRAY", EXPR_ARRAY),
2598 minit ("NULL", EXPR_NULL),
2602 /* INTRINSIC_ASSIGN is missing because it is used as an index for
2603 generic operators, not in expressions. INTRINSIC_USER is also
2604 replaced by the correct function name by the time we see it. */
2606 static const mstring intrinsics[] =
2608 minit ("UPLUS", INTRINSIC_UPLUS),
2609 minit ("UMINUS", INTRINSIC_UMINUS),
2610 minit ("PLUS", INTRINSIC_PLUS),
2611 minit ("MINUS", INTRINSIC_MINUS),
2612 minit ("TIMES", INTRINSIC_TIMES),
2613 minit ("DIVIDE", INTRINSIC_DIVIDE),
2614 minit ("POWER", INTRINSIC_POWER),
2615 minit ("CONCAT", INTRINSIC_CONCAT),
2616 minit ("AND", INTRINSIC_AND),
2617 minit ("OR", INTRINSIC_OR),
2618 minit ("EQV", INTRINSIC_EQV),
2619 minit ("NEQV", INTRINSIC_NEQV),
2620 minit ("==", INTRINSIC_EQ),
2621 minit ("EQ", INTRINSIC_EQ_OS),
2622 minit ("/=", INTRINSIC_NE),
2623 minit ("NE", INTRINSIC_NE_OS),
2624 minit (">", INTRINSIC_GT),
2625 minit ("GT", INTRINSIC_GT_OS),
2626 minit (">=", INTRINSIC_GE),
2627 minit ("GE", INTRINSIC_GE_OS),
2628 minit ("<", INTRINSIC_LT),
2629 minit ("LT", INTRINSIC_LT_OS),
2630 minit ("<=", INTRINSIC_LE),
2631 minit ("LE", INTRINSIC_LE_OS),
2632 minit ("NOT", INTRINSIC_NOT),
2633 minit ("PARENTHESES", INTRINSIC_PARENTHESES),
2638 /* Remedy a couple of situations where the gfc_expr's can be defective. */
2641 fix_mio_expr (gfc_expr *e)
2643 gfc_symtree *ns_st = NULL;
2646 if (iomode != IO_OUTPUT)
2651 /* If this is a symtree for a symbol that came from a contained module
2652 namespace, it has a unique name and we should look in the current
2653 namespace to see if the required, non-contained symbol is available
2654 yet. If so, the latter should be written. */
2655 if (e->symtree->n.sym && check_unique_name (e->symtree->name))
2656 ns_st = gfc_find_symtree (gfc_current_ns->sym_root,
2657 e->symtree->n.sym->name);
2659 /* On the other hand, if the existing symbol is the module name or the
2660 new symbol is a dummy argument, do not do the promotion. */
2661 if (ns_st && ns_st->n.sym
2662 && ns_st->n.sym->attr.flavor != FL_MODULE
2663 && !e->symtree->n.sym->attr.dummy)
2666 else if (e->expr_type == EXPR_FUNCTION && e->value.function.name)
2668 /* In some circumstances, a function used in an initialization
2669 expression, in one use associated module, can fail to be
2670 coupled to its symtree when used in a specification
2671 expression in another module. */
2672 fname = e->value.function.esym ? e->value.function.esym->name
2673 : e->value.function.isym->name;
2674 e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
2679 /* Read and write expressions. The form "()" is allowed to indicate a
2683 mio_expr (gfc_expr **ep)
2691 if (iomode == IO_OUTPUT)
2700 MIO_NAME (expr_t) (e->expr_type, expr_types);
2705 if (t == ATOM_RPAREN)
2712 bad_module ("Expected expression type");
2714 e = *ep = gfc_get_expr ();
2715 e->where = gfc_current_locus;
2716 e->expr_type = (expr_t) find_enum (expr_types);
2719 mio_typespec (&e->ts);
2720 mio_integer (&e->rank);
2724 switch (e->expr_type)
2727 e->value.op.operator
2728 = MIO_NAME (gfc_intrinsic_op) (e->value.op.operator, intrinsics);
2730 switch (e->value.op.operator)
2732 case INTRINSIC_UPLUS:
2733 case INTRINSIC_UMINUS:
2735 case INTRINSIC_PARENTHESES:
2736 mio_expr (&e->value.op.op1);
2739 case INTRINSIC_PLUS:
2740 case INTRINSIC_MINUS:
2741 case INTRINSIC_TIMES:
2742 case INTRINSIC_DIVIDE:
2743 case INTRINSIC_POWER:
2744 case INTRINSIC_CONCAT:
2748 case INTRINSIC_NEQV:
2750 case INTRINSIC_EQ_OS:
2752 case INTRINSIC_NE_OS:
2754 case INTRINSIC_GT_OS:
2756 case INTRINSIC_GE_OS:
2758 case INTRINSIC_LT_OS:
2760 case INTRINSIC_LE_OS:
2761 mio_expr (&e->value.op.op1);
2762 mio_expr (&e->value.op.op2);
2766 bad_module ("Bad operator");
2772 mio_symtree_ref (&e->symtree);
2773 mio_actual_arglist (&e->value.function.actual);
2775 if (iomode == IO_OUTPUT)
2777 e->value.function.name
2778 = mio_allocated_string (e->value.function.name);
2779 flag = e->value.function.esym != NULL;
2780 mio_integer (&flag);
2782 mio_symbol_ref (&e->value.function.esym);
2784 write_atom (ATOM_STRING, e->value.function.isym->name);
2788 require_atom (ATOM_STRING);
2789 e->value.function.name = gfc_get_string (atom_string);
2790 gfc_free (atom_string);
2792 mio_integer (&flag);
2794 mio_symbol_ref (&e->value.function.esym);
2797 require_atom (ATOM_STRING);
2798 e->value.function.isym = gfc_find_function (atom_string);
2799 gfc_free (atom_string);
2806 mio_symtree_ref (&e->symtree);
2807 mio_ref_list (&e->ref);
2810 case EXPR_SUBSTRING:
2811 e->value.character.string
2812 = (char *) mio_allocated_string (e->value.character.string);
2813 mio_ref_list (&e->ref);
2816 case EXPR_STRUCTURE:
2818 mio_constructor (&e->value.constructor);
2819 mio_shape (&e->shape, e->rank);
2826 mio_gmp_integer (&e->value.integer);
2830 gfc_set_model_kind (e->ts.kind);
2831 mio_gmp_real (&e->value.real);
2835 gfc_set_model_kind (e->ts.kind);
2836 mio_gmp_real (&e->value.complex.r);
2837 mio_gmp_real (&e->value.complex.i);
2841 mio_integer (&e->value.logical);
2845 mio_integer (&e->value.character.length);
2846 e->value.character.string
2847 = (char *) mio_allocated_string (e->value.character.string);
2851 bad_module ("Bad type in constant expression");
2864 /* Read and write namelists. */
2867 mio_namelist (gfc_symbol *sym)
2869 gfc_namelist *n, *m;
2870 const char *check_name;
2874 if (iomode == IO_OUTPUT)
2876 for (n = sym->namelist; n; n = n->next)
2877 mio_symbol_ref (&n->sym);
2881 /* This departure from the standard is flagged as an error.
2882 It does, in fact, work correctly. TODO: Allow it
2884 if (sym->attr.flavor == FL_NAMELIST)
2886 check_name = find_use_name (sym->name, false);
2887 if (check_name && strcmp (check_name, sym->name) != 0)
2888 gfc_error ("Namelist %s cannot be renamed by USE "
2889 "association to %s", sym->name, check_name);
2893 while (peek_atom () != ATOM_RPAREN)
2895 n = gfc_get_namelist ();
2896 mio_symbol_ref (&n->sym);
2898 if (sym->namelist == NULL)
2905 sym->namelist_tail = m;
2912 /* Save/restore lists of gfc_interface stuctures. When loading an
2913 interface, we are really appending to the existing list of
2914 interfaces. Checking for duplicate and ambiguous interfaces has to
2915 be done later when all symbols have been loaded. */
2918 mio_interface_rest (gfc_interface **ip)
2920 gfc_interface *tail, *p;
2922 if (iomode == IO_OUTPUT)
2925 for (p = *ip; p; p = p->next)
2926 mio_symbol_ref (&p->sym);
2941 if (peek_atom () == ATOM_RPAREN)
2944 p = gfc_get_interface ();
2945 p->where = gfc_current_locus;
2946 mio_symbol_ref (&p->sym);
2961 /* Save/restore a nameless operator interface. */
2964 mio_interface (gfc_interface **ip)
2967 mio_interface_rest (ip);
2971 /* Save/restore a named operator interface. */
2974 mio_symbol_interface (const char **name, const char **module,
2978 mio_pool_string (name);
2979 mio_pool_string (module);
2980 mio_interface_rest (ip);
2985 mio_namespace_ref (gfc_namespace **nsp)
2990 p = mio_pointer_ref (nsp);
2992 if (p->type == P_UNKNOWN)
2993 p->type = P_NAMESPACE;
2995 if (iomode == IO_INPUT && p->integer != 0)
2997 ns = (gfc_namespace *) p->u.pointer;
3000 ns = gfc_get_namespace (NULL, 0);
3001 associate_integer_pointer (p, ns);
3009 /* Unlike most other routines, the address of the symbol node is already
3010 fixed on input and the name/module has already been filled in. */
3013 mio_symbol (gfc_symbol *sym)
3015 int intmod = INTMOD_NONE;
3017 gfc_formal_arglist *formal;
3021 mio_symbol_attribute (&sym->attr);
3022 mio_typespec (&sym->ts);
3024 /* Contained procedures don't have formal namespaces. Instead we output the
3025 procedure namespace. The will contain the formal arguments. */
3026 if (iomode == IO_OUTPUT)
3028 formal = sym->formal;
3029 while (formal && !formal->sym)
3030 formal = formal->next;
3033 mio_namespace_ref (&formal->sym->ns);
3035 mio_namespace_ref (&sym->formal_ns);
3039 mio_namespace_ref (&sym->formal_ns);
3042 sym->formal_ns->proc_name = sym;
3047 /* Save/restore common block links. */
3048 mio_symbol_ref (&sym->common_next);
3050 mio_formal_arglist (sym);
3052 if (sym->attr.flavor == FL_PARAMETER)
3053 mio_expr (&sym->value);
3055 mio_array_spec (&sym->as);
3057 mio_symbol_ref (&sym->result);
3059 if (sym->attr.cray_pointee)
3060 mio_symbol_ref (&sym->cp_pointer);
3062 /* Note that components are always saved, even if they are supposed
3063 to be private. Component access is checked during searching. */
3065 mio_component_list (&sym->components);
3067 if (sym->components != NULL)
3068 sym->component_access
3069 = MIO_NAME (gfc_access) (sym->component_access, access_types);
3073 /* Add the fields that say whether this is from an intrinsic module,
3074 and if so, what symbol it is within the module. */
3075 /* mio_integer (&(sym->from_intmod)); */
3076 if (iomode == IO_OUTPUT)
3078 intmod = sym->from_intmod;
3079 mio_integer (&intmod);
3083 mio_integer (&intmod);
3084 sym->from_intmod = intmod;
3087 mio_integer (&(sym->intmod_sym_id));
3093 /************************* Top level subroutines *************************/
3095 /* Skip a list between balanced left and right parens. */
3105 switch (parse_atom ())
3116 gfc_free (atom_string);
3128 /* Load operator interfaces from the module. Interfaces are unusual
3129 in that they attach themselves to existing symbols. */
3132 load_operator_interfaces (void)
3135 char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
3140 while (peek_atom () != ATOM_RPAREN)
3144 mio_internal_string (name);
3145 mio_internal_string (module);
3147 /* Decide if we need to load this one or not. */
3148 p = find_use_name (name, true);
3151 while (parse_atom () != ATOM_RPAREN);
3155 uop = gfc_get_uop (p);
3156 mio_interface_rest (&uop->operator);
3164 /* Load interfaces from the module. Interfaces are unusual in that
3165 they attach themselves to existing symbols. */
3168 load_generic_interfaces (void)
3171 char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
3173 gfc_interface *generic = NULL;
3178 while (peek_atom () != ATOM_RPAREN)
3182 mio_internal_string (name);
3183 mio_internal_string (module);
3185 n = number_use_names (name, false);
3188 for (i = 1; i <= n; i++)
3190 /* Decide if we need to load this one or not. */
3191 p = find_use_name_n (name, &i, false);
3193 if (p == NULL || gfc_find_symbol (p, NULL, 0, &sym))
3195 while (parse_atom () != ATOM_RPAREN);
3201 gfc_get_symbol (p, NULL, &sym);
3203 sym->attr.flavor = FL_PROCEDURE;
3204 sym->attr.generic = 1;
3205 sym->attr.use_assoc = 1;
3209 /* Unless sym is a generic interface, this reference
3213 st = gfc_find_symtree (gfc_current_ns->sym_root, p);
3214 if (!sym->attr.generic
3215 && sym->module != NULL
3216 && strcmp(module, sym->module) != 0)
3221 mio_interface_rest (&sym->generic);
3222 generic = sym->generic;
3226 sym->generic = generic;
3227 sym->attr.generic_copy = 1;
3236 /* Load common blocks. */
3241 char name[GFC_MAX_SYMBOL_LEN + 1];
3246 while (peek_atom () != ATOM_RPAREN)
3250 mio_internal_string (name);
3252 p = gfc_get_common (name, 1);
3254 mio_symbol_ref (&p->head);
3255 mio_integer (&flags);
3259 p->threadprivate = 1;
3262 /* Get whether this was a bind(c) common or not. */
3263 mio_integer (&p->is_bind_c);
3264 /* Get the binding label. */
3265 mio_internal_string (p->binding_label);
3274 /* Load equivalences. The flag in_load_equiv informs mio_expr_ref of this
3275 so that unused variables are not loaded and so that the expression can
3281 gfc_equiv *head, *tail, *end, *eq;
3285 in_load_equiv = true;
3287 end = gfc_current_ns->equiv;
3288 while (end != NULL && end->next != NULL)
3291 while (peek_atom () != ATOM_RPAREN) {
3295 while(peek_atom () != ATOM_RPAREN)
3298 head = tail = gfc_get_equiv ();
3301 tail->eq = gfc_get_equiv ();
3305 mio_pool_string (&tail->module);
3306 mio_expr (&tail->expr);
3309 /* Unused equivalence members have a unique name. */
3311 for (eq = head; eq; eq = eq->eq)
3313 if (!check_unique_name (eq->expr->symtree->name))
3322 for (eq = head; eq; eq = head)
3325 gfc_free_expr (eq->expr);
3331 gfc_current_ns->equiv = head;
3342 in_load_equiv = false;
3346 /* Recursive function to traverse the pointer_info tree and load a
3347 needed symbol. We return nonzero if we load a symbol and stop the
3348 traversal, because the act of loading can alter the tree. */
3351 load_needed (pointer_info *p)
3362 rv |= load_needed (p->left);
3363 rv |= load_needed (p->right);
3365 if (p->type != P_SYMBOL || p->u.rsym.state != NEEDED)
3368 p->u.rsym.state = USED;
3370 set_module_locus (&p->u.rsym.where);
3372 sym = p->u.rsym.sym;
3375 q = get_integer (p->u.rsym.ns);
3377 ns = (gfc_namespace *) q->u.pointer;
3380 /* Create an interface namespace if necessary. These are
3381 the namespaces that hold the formal parameters of module
3384 ns = gfc_get_namespace (NULL, 0);
3385 associate_integer_pointer (q, ns);
3388 sym = gfc_new_symbol (p->u.rsym.true_name, ns);
3389 sym->module = gfc_get_string (p->u.rsym.module);
3391 associate_integer_pointer (p, sym);
3395 sym->attr.use_assoc = 1;
3397 sym->attr.use_only = 1;
3403 /* Recursive function for cleaning up things after a module has been read. */
3406 read_cleanup (pointer_info *p)
3414 read_cleanup (p->left);
3415 read_cleanup (p->right);
3417 if (p->type == P_SYMBOL && p->u.rsym.state == USED && !p->u.rsym.referenced)
3419 /* Add hidden symbols to the symtree. */
3420 q = get_integer (p->u.rsym.ns);
3421 st = gfc_get_unique_symtree ((gfc_namespace *) q->u.pointer);
3423 st->n.sym = p->u.rsym.sym;
3426 /* Fixup any symtree references. */
3427 p->u.rsym.symtree = st;
3428 resolve_fixups (p->u.rsym.stfixup, st);
3429 p->u.rsym.stfixup = NULL;
3432 /* Free unused symbols. */
3433 if (p->type == P_SYMBOL && p->u.rsym.state == UNUSED)
3434 gfc_free_symbol (p->u.rsym.sym);
3438 /* Given a root symtree node and a symbol, try to find a symtree that
3439 references the symbol that is not a unique name. */
3441 static gfc_symtree *
3442 find_symtree_for_symbol (gfc_symtree *st, gfc_symbol *sym)
3444 gfc_symtree *s = NULL;
3449 s = find_symtree_for_symbol (st->right, sym);
3452 s = find_symtree_for_symbol (st->left, sym);
3456 if (st->n.sym == sym && !check_unique_name (st->name))
3463 /* Read a module file. */
3468 module_locus operator_interfaces, user_operators;
3470 char name[GFC_MAX_SYMBOL_LEN + 1];
3472 int ambiguous, j, nuse, symbol;
3473 pointer_info *info, *q;
3478 get_module_locus (&operator_interfaces); /* Skip these for now. */
3481 get_module_locus (&user_operators);
3485 /* Skip commons and equivalences for now. */
3491 /* Create the fixup nodes for all the symbols. */
3493 while (peek_atom () != ATOM_RPAREN)
3495 require_atom (ATOM_INTEGER);
3496 info = get_integer (atom_int);
3498 info->type = P_SYMBOL;
3499 info->u.rsym.state = UNUSED;
3501 mio_internal_string (info->u.rsym.true_name);
3502 mio_internal_string (info->u.rsym.module);
3503 mio_internal_string (info->u.rsym.binding_label);
3506 require_atom (ATOM_INTEGER);
3507 info->u.rsym.ns = atom_int;
3509 get_module_locus (&info->u.rsym.where);
3512 /* See if the symbol has already been loaded by a previous module.
3513 If so, we reference the existing symbol and prevent it from
3514 being loaded again. This should not happen if the symbol being
3515 read is an index for an assumed shape dummy array (ns != 1). */
3517 sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module);
3520 || (sym->attr.flavor == FL_VARIABLE && info->u.rsym.ns !=1))
3523 info->u.rsym.state = USED;
3524 info->u.rsym.sym = sym;
3526 /* Some symbols do not have a namespace (eg. formal arguments),
3527 so the automatic "unique symtree" mechanism must be suppressed
3528 by marking them as referenced. */
3529 q = get_integer (info->u.rsym.ns);
3530 if (q->u.pointer == NULL)
3532 info->u.rsym.referenced = 1;
3536 /* If possible recycle the symtree that references the symbol.
3537 If a symtree is not found and the module does not import one,
3538 a unique-name symtree is found by read_cleanup. */
3539 st = find_symtree_for_symbol (gfc_current_ns->sym_root, sym);
3542 info->u.rsym.symtree = st;
3543 info->u.rsym.referenced = 1;
3549 /* Parse the symtree lists. This lets us mark which symbols need to
3550 be loaded. Renaming is also done at this point by replacing the
3555 while (peek_atom () != ATOM_RPAREN)
3557 mio_internal_string (name);
3558 mio_integer (&ambiguous);
3559 mio_integer (&symbol);
3561 info = get_integer (symbol);
3563 /* See how many use names there are. If none, go through the start
3564 of the loop at least once. */
3565 nuse = number_use_names (name, false);
3569 for (j = 1; j <= nuse; j++)
3571 /* Get the jth local name for this symbol. */
3572 p = find_use_name_n (name, &j, false);
3574 if (p == NULL && strcmp (name, module_name) == 0)
3577 /* Skip symtree nodes not in an ONLY clause, unless there
3578 is an existing symtree loaded from another USE statement. */
3581 st = gfc_find_symtree (gfc_current_ns->sym_root, name);
3583 info->u.rsym.symtree = st;
3587 st = gfc_find_symtree (gfc_current_ns->sym_root, p);
3591 /* Check for ambiguous symbols. */
3592 if (st->n.sym != info->u.rsym.sym)
3594 info->u.rsym.symtree = st;
3598 /* Create a symtree node in the current namespace for this
3600 st = check_unique_name (p)
3601 ? gfc_get_unique_symtree (gfc_current_ns)
3602 : gfc_new_symtree (&gfc_current_ns->sym_root, p);
3604 st->ambiguous = ambiguous;
3606 sym = info->u.rsym.sym;
3608 /* Create a symbol node if it doesn't already exist. */
3611 info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name,
3613 sym = info->u.rsym.sym;
3614 sym->module = gfc_get_string (info->u.rsym.module);
3616 /* TODO: hmm, can we test this? Do we know it will be
3617 initialized to zeros? */
3618 if (info->u.rsym.binding_label[0] != '\0')
3619 strcpy (sym->binding_label, info->u.rsym.binding_label);
3625 /* Store the symtree pointing to this symbol. */
3626 info->u.rsym.symtree = st;
3628 if (info->u.rsym.state == UNUSED)
3629 info->u.rsym.state = NEEDED;
3630 info->u.rsym.referenced = 1;
3637 /* Load intrinsic operator interfaces. */
3638 set_module_locus (&operator_interfaces);
3641 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3643 if (i == INTRINSIC_USER)
3648 u = find_use_operator (i);
3659 mio_interface (&gfc_current_ns->operator[i]);
3664 /* Load generic and user operator interfaces. These must follow the
3665 loading of symtree because otherwise symbols can be marked as
3668 set_module_locus (&user_operators);
3670 load_operator_interfaces ();
3671 load_generic_interfaces ();
3676 /* At this point, we read those symbols that are needed but haven't
3677 been loaded yet. If one symbol requires another, the other gets
3678 marked as NEEDED if its previous state was UNUSED. */
3680 while (load_needed (pi_root));
3682 /* Make sure all elements of the rename-list were found in the module. */
3684 for (u = gfc_rename_list; u; u = u->next)
3689 if (u->operator == INTRINSIC_NONE)
3691 gfc_error ("Symbol '%s' referenced at %L not found in module '%s'",
3692 u->use_name, &u->where, module_name);
3696 if (u->operator == INTRINSIC_USER)
3698 gfc_error ("User operator '%s' referenced at %L not found "
3699 "in module '%s'", u->use_name, &u->where, module_name);
3703 gfc_error ("Intrinsic operator '%s' referenced at %L not found "
3704 "in module '%s'", gfc_op2string (u->operator), &u->where,
3708 gfc_check_interfaces (gfc_current_ns);
3710 /* Clean up symbol nodes that were never loaded, create references
3711 to hidden symbols. */
3713 read_cleanup (pi_root);
3717 /* Given an access type that is specific to an entity and the default
3718 access, return nonzero if the entity is publicly accessible. If the
3719 element is declared as PUBLIC, then it is public; if declared
3720 PRIVATE, then private, and otherwise it is public unless the default
3721 access in this context has been declared PRIVATE. */
3724 gfc_check_access (gfc_access specific_access, gfc_access default_access)
3726 if (specific_access == ACCESS_PUBLIC)
3728 if (specific_access == ACCESS_PRIVATE)
3731 if (gfc_option.flag_module_private)
3732 return default_access == ACCESS_PUBLIC;
3734 return default_access != ACCESS_PRIVATE;
3738 /* Write a common block to the module. */
3741 write_common (gfc_symtree *st)
3751 write_common (st->left);
3752 write_common (st->right);
3756 /* Write the unmangled name. */
3757 name = st->n.common->name;
3759 mio_pool_string (&name);
3762 mio_symbol_ref (&p->head);
3763 flags = p->saved ? 1 : 0;
3764 if (p->threadprivate) flags |= 2;
3765 mio_integer (&flags);
3767 /* Write out whether the common block is bind(c) or not. */
3768 mio_integer (&(p->is_bind_c));
3770 /* Write out the binding label, or the com name if no label given. */
3773 label = p->binding_label;
3774 mio_pool_string (&label);
3779 mio_pool_string (&label);
3786 /* Write the blank common block to the module. */
3789 write_blank_common (void)
3791 const char * name = BLANK_COMMON_NAME;
3793 /* TODO: Blank commons are not bind(c). The F2003 standard probably says
3794 this, but it hasn't been checked. Just making it so for now. */
3797 if (gfc_current_ns->blank_common.head == NULL)
3802 mio_pool_string (&name);
3804 mio_symbol_ref (&gfc_current_ns->blank_common.head);
3805 saved = gfc_current_ns->blank_common.saved;
3806 mio_integer (&saved);
3808 /* Write out whether the common block is bind(c) or not. */
3809 mio_integer (&is_bind_c);
3811 /* Write out the binding label, which is BLANK_COMMON_NAME, though
3812 it doesn't matter because the label isn't used. */
3813 mio_pool_string (&name);
3819 /* Write equivalences to the module. */
3828 for (eq = gfc_current_ns->equiv; eq; eq = eq->next)
3832 for (e = eq; e; e = e->eq)
3834 if (e->module == NULL)
3835 e->module = gfc_get_string ("%s.eq.%d", module_name, num);
3836 mio_allocated_string (e->module);
3837 mio_expr (&e->expr);
3846 /* Write a symbol to the module. */
3849 write_symbol (int n, gfc_symbol *sym)
3853 if (sym->attr.flavor == FL_UNKNOWN || sym->attr.flavor == FL_LABEL)
3854 gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym->name);
3857 mio_pool_string (&sym->name);
3859 mio_pool_string (&sym->module);
3860 if (sym->attr.is_bind_c || sym->attr.is_iso_c)
3862 label = sym->binding_label;
3863 mio_pool_string (&label);
3866 mio_pool_string (&sym->name);
3868 mio_pointer_ref (&sym->ns);
3875 /* Recursive traversal function to write the initial set of symbols to
3876 the module. We check to see if the symbol should be written
3877 according to the access specification. */
3880 write_symbol0 (gfc_symtree *st)
3888 write_symbol0 (st->left);
3889 write_symbol0 (st->right);
3892 if (sym->module == NULL)
3893 sym->module = gfc_get_string (module_name);
3895 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
3896 && !sym->attr.subroutine && !sym->attr.function)
3899 if (!gfc_check_access (sym->attr.access, sym->ns->default_access))
3902 p = get_pointer (sym);
3903 if (p->type == P_UNKNOWN)
3906 if (p->u.wsym.state == WRITTEN)
3909 write_symbol (p->integer, sym);
3910 p->u.wsym.state = WRITTEN;
3914 /* Recursive traversal function to write the secondary set of symbols
3915 to the module file. These are symbols that were not public yet are
3916 needed by the public symbols or another dependent symbol. The act
3917 of writing a symbol can modify the pointer_info tree, so we cease
3918 traversal if we find a symbol to write. We return nonzero if a
3919 symbol was written and pass that information upwards. */
3922 write_symbol1 (pointer_info *p)
3928 if (write_symbol1 (p->left))
3930 if (write_symbol1 (p->right))
3933 if (p->type != P_SYMBOL || p->u.wsym.state != NEEDS_WRITE)
3936 p->u.wsym.state = WRITTEN;
3937 write_symbol (p->integer, p->u.wsym.sym);
3943 /* Write operator interfaces associated with a symbol. */
3946 write_operator (gfc_user_op *uop)
3948 static char nullstring[] = "";
3949 const char *p = nullstring;
3951 if (uop->operator == NULL
3952 || !gfc_check_access (uop->access, uop->ns->default_access))
3955 mio_symbol_interface (&uop->name, &p, &uop->operator);
3959 /* Write generic interfaces associated with a symbol. */
3962 write_generic (gfc_symbol *sym)
3967 if (sym->generic == NULL
3968 || !gfc_check_access (sym->attr.access, sym->ns->default_access))
3971 if (sym->module == NULL)
3972 sym->module = gfc_get_string (module_name);
3974 /* See how many use names there are. If none, use the symbol name. */
3975 nuse = number_use_names (sym->name, false);
3978 mio_symbol_interface (&sym->name, &sym->module, &sym->generic);
3982 for (j = 1; j <= nuse; j++)
3984 /* Get the jth local name for this symbol. */
3985 p = find_use_name_n (sym->name, &j, false);
3987 mio_symbol_interface (&p, &sym->module, &sym->generic);
3993 write_symtree (gfc_symtree *st)
3999 if (!gfc_check_access (sym->attr.access, sym->ns->default_access)
4000 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
4001 && !sym->attr.subroutine && !sym->attr.function))
4004 if (check_unique_name (st->name))
4007 p = find_pointer (sym);
4009 gfc_internal_error ("write_symtree(): Symbol not written");
4011 mio_pool_string (&st->name);
4012 mio_integer (&st->ambiguous);
4013 mio_integer (&p->integer);
4022 /* Write the operator interfaces. */
4025 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
4027 if (i == INTRINSIC_USER)
4030 mio_interface (gfc_check_access (gfc_current_ns->operator_access[i],
4031 gfc_current_ns->default_access)
4032 ? &gfc_current_ns->operator[i] : NULL);
4040 gfc_traverse_user_op (gfc_current_ns, write_operator);
4046 gfc_traverse_ns (gfc_current_ns, write_generic);
4052 write_blank_common ();
4053 write_common (gfc_current_ns->common_root);
4064 /* Write symbol information. First we traverse all symbols in the
4065 primary namespace, writing those that need to be written.
4066 Sometimes writing one symbol will cause another to need to be
4067 written. A list of these symbols ends up on the write stack, and
4068 we end by popping the bottom of the stack and writing the symbol
4069 until the stack is empty. */
4073 write_symbol0 (gfc_current_ns->sym_root);
4074 while (write_symbol1 (pi_root));
4082 gfc_traverse_symtree (gfc_current_ns->sym_root, write_symtree);
4087 /* Read a MD5 sum from the header of a module file. If the file cannot
4088 be opened, or we have any other error, we return -1. */
4091 read_md5_from_module_file (const char * filename, unsigned char md5[16])
4097 /* Open the file. */
4098 if ((file = fopen (filename, "r")) == NULL)
4101 /* Read two lines. */
4102 if (fgets (buf, sizeof (buf) - 1, file) == NULL
4103 || fgets (buf, sizeof (buf) - 1, file) == NULL)
4109 /* Close the file. */
4112 /* If the header is not what we expect, or is too short, bail out. */
4113 if (strncmp (buf, "MD5:", 4) != 0 || strlen (buf) < 4 + 16)
4116 /* Now, we have a real MD5, read it into the array. */
4117 for (n = 0; n < 16; n++)
4121 if (sscanf (&(buf[4+2*n]), "%02x", &x) != 1)
4131 /* Given module, dump it to disk. If there was an error while
4132 processing the module, dump_flag will be set to zero and we delete
4133 the module file, even if it was already there. */
4136 gfc_dump_module (const char *name, int dump_flag)
4139 char *filename, *filename_tmp, *p;
4142 unsigned char md5_new[16], md5_old[16];
4144 n = strlen (name) + strlen (MODULE_EXTENSION) + 1;
4145 if (gfc_option.module_dir != NULL)
4147 n += strlen (gfc_option.module_dir);
4148 filename = (char *) alloca (n);
4149 strcpy (filename, gfc_option.module_dir);
4150 strcat (filename, name);
4154 filename = (char *) alloca (n);
4155 strcpy (filename, name);
4157 strcat (filename, MODULE_EXTENSION);
4159 /* Name of the temporary file used to write the module. */
4160 filename_tmp = (char *) alloca (n + 1);
4161 strcpy (filename_tmp, filename);
4162 strcat (filename_tmp, "0");
4164 /* There was an error while processing the module. We delete the
4165 module file, even if it was already there. */
4172 /* Write the module to the temporary file. */
4173 module_fp = fopen (filename_tmp, "w");
4174 if (module_fp == NULL)
4175 gfc_fatal_error ("Can't open module file '%s' for writing at %C: %s",
4176 filename_tmp, strerror (errno));
4178 /* Write the header, including space reserved for the MD5 sum. */
4182 *strchr (p, '\n') = '\0';
4184 fprintf (module_fp, "GFORTRAN module created from %s on %s\nMD5:",
4185 gfc_source_file, p);
4186 fgetpos (module_fp, &md5_pos);
4187 fputs ("00000000000000000000000000000000 -- "
4188 "If you edit this, you'll get what you deserve.\n\n", module_fp);
4190 /* Initialize the MD5 context that will be used for output. */
4191 md5_init_ctx (&ctx);
4193 /* Write the module itself. */
4195 strcpy (module_name, name);
4201 free_pi_tree (pi_root);
4206 /* Write the MD5 sum to the header of the module file. */
4207 md5_finish_ctx (&ctx, md5_new);
4208 fsetpos (module_fp, &md5_pos);
4209 for (n = 0; n < 16; n++)
4210 fprintf (module_fp, "%02x", md5_new[n]);
4212 if (fclose (module_fp))
4213 gfc_fatal_error ("Error writing module file '%s' for writing: %s",
4214 filename_tmp, strerror (errno));
4216 /* Read the MD5 from the header of the old module file and compare. */
4217 if (read_md5_from_module_file (filename, md5_old) != 0
4218 || memcmp (md5_old, md5_new, sizeof (md5_old)) != 0)
4220 /* Module file have changed, replace the old one. */
4222 rename (filename_tmp, filename);
4225 unlink (filename_tmp);
4230 sort_iso_c_rename_list (void)
4232 gfc_use_rename *tmp_list = NULL;
4233 gfc_use_rename *curr;
4234 gfc_use_rename *kinds_used[ISOCBINDING_NUMBER] = {NULL};
4238 for (curr = gfc_rename_list; curr; curr = curr->next)
4240 c_kind = get_c_kind (curr->use_name, c_interop_kinds_table);
4241 if (c_kind == ISOCBINDING_INVALID || c_kind == ISOCBINDING_LAST)
4243 gfc_error ("Symbol '%s' referenced at %L does not exist in "
4244 "intrinsic module ISO_C_BINDING.", curr->use_name,
4248 /* Put it in the list. */
4249 kinds_used[c_kind] = curr;
4252 /* Make a new (sorted) rename list. */
4254 while (i < ISOCBINDING_NUMBER && kinds_used[i] == NULL)
4257 if (i < ISOCBINDING_NUMBER)
4259 tmp_list = kinds_used[i];
4263 for (; i < ISOCBINDING_NUMBER; i++)
4264 if (kinds_used[i] != NULL)
4266 curr->next = kinds_used[i];
4272 gfc_rename_list = tmp_list;
4276 /* Import the intrinsic ISO_C_BINDING module, generating symbols in
4277 the current namespace for all named constants, pointer types, and
4278 procedures in the module unless the only clause was used or a rename
4279 list was provided. */
4282 import_iso_c_binding_module (void)
4284 gfc_symbol *mod_sym = NULL;
4285 gfc_symtree *mod_symtree = NULL;
4286 const char *iso_c_module_name = "__iso_c_binding";
4291 /* Look only in the current namespace. */
4292 mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, iso_c_module_name);
4294 if (mod_symtree == NULL)
4296 /* symtree doesn't already exist in current namespace. */
4297 gfc_get_sym_tree (iso_c_module_name, gfc_current_ns, &mod_symtree);
4299 if (mod_symtree != NULL)
4300 mod_sym = mod_symtree->n.sym;
4302 gfc_internal_error ("import_iso_c_binding_module(): Unable to "
4303 "create symbol for %s", iso_c_module_name);
4305 mod_sym->attr.flavor = FL_MODULE;
4306 mod_sym->attr.intrinsic = 1;
4307 mod_sym->module = gfc_get_string (iso_c_module_name);
4308 mod_sym->from_intmod = INTMOD_ISO_C_BINDING;
4311 /* Generate the symbols for the named constants representing
4312 the kinds for intrinsic data types. */
4315 /* Sort the rename list because there are dependencies between types
4316 and procedures (e.g., c_loc needs c_ptr). */
4317 sort_iso_c_rename_list ();
4319 for (u = gfc_rename_list; u; u = u->next)
4321 i = get_c_kind (u->use_name, c_interop_kinds_table);
4323 if (i == ISOCBINDING_INVALID || i == ISOCBINDING_LAST)
4325 gfc_error ("Symbol '%s' referenced at %L does not exist in "
4326 "intrinsic module ISO_C_BINDING.", u->use_name,
4331 generate_isocbinding_symbol (iso_c_module_name, i, u->local_name);
4336 for (i = 0; i < ISOCBINDING_NUMBER; i++)
4339 for (u = gfc_rename_list; u; u = u->next)
4341 if (strcmp (c_interop_kinds_table[i].name, u->use_name) == 0)
4343 local_name = u->local_name;
4348 generate_isocbinding_symbol (iso_c_module_name, i, local_name);
4351 for (u = gfc_rename_list; u; u = u->next)
4356 gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
4357 "module ISO_C_BINDING", u->use_name, &u->where);
4363 /* Add an integer named constant from a given module. */
4366 create_int_parameter (const char *name, int value, const char *modname,
4367 intmod_id module, int id)
4369 gfc_symtree *tmp_symtree;
4372 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
4373 if (tmp_symtree != NULL)
4375 if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
4378 gfc_error ("Symbol '%s' already declared", name);
4381 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree);
4382 sym = tmp_symtree->n.sym;
4384 sym->module = gfc_get_string (modname);
4385 sym->attr.flavor = FL_PARAMETER;
4386 sym->ts.type = BT_INTEGER;
4387 sym->ts.kind = gfc_default_integer_kind;
4388 sym->value = gfc_int_expr (value);
4389 sym->attr.use_assoc = 1;
4390 sym->from_intmod = module;
4391 sym->intmod_sym_id = id;
4395 /* USE the ISO_FORTRAN_ENV intrinsic module. */
4398 use_iso_fortran_env_module (void)
4400 static char mod[] = "iso_fortran_env";
4401 const char *local_name;
4403 gfc_symbol *mod_sym;
4404 gfc_symtree *mod_symtree;
4407 intmod_sym symbol[] = {
4408 #define NAMED_INTCST(a,b,c) { a, b, 0 },
4409 #include "iso-fortran-env.def"
4411 { ISOFORTRANENV_INVALID, NULL, -1234 } };
4414 #define NAMED_INTCST(a,b,c) symbol[i++].value = c;
4415 #include "iso-fortran-env.def"
4418 /* Generate the symbol for the module itself. */
4419 mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, mod);
4420 if (mod_symtree == NULL)
4422 gfc_get_sym_tree (mod, gfc_current_ns, &mod_symtree);
4423 gcc_assert (mod_symtree);
4424 mod_sym = mod_symtree->n.sym;
4426 mod_sym->attr.flavor = FL_MODULE;
4427 mod_sym->attr.intrinsic = 1;
4428 mod_sym->module = gfc_get_string (mod);
4429 mod_sym->from_intmod = INTMOD_ISO_FORTRAN_ENV;
4432 if (!mod_symtree->n.sym->attr.intrinsic)
4433 gfc_error ("Use of intrinsic module '%s' at %C conflicts with "
4434 "non-intrinsic module name used previously", mod);
4436 /* Generate the symbols for the module integer named constants. */
4438 for (u = gfc_rename_list; u; u = u->next)
4440 for (i = 0; symbol[i].name; i++)
4441 if (strcmp (symbol[i].name, u->use_name) == 0)
4444 if (symbol[i].name == NULL)
4446 gfc_error ("Symbol '%s' referenced at %L does not exist in "
4447 "intrinsic module ISO_FORTRAN_ENV", u->use_name,
4452 if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
4453 && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
4454 gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
4455 "from intrinsic module ISO_FORTRAN_ENV at %L is "
4456 "incompatible with option %s", &u->where,
4457 gfc_option.flag_default_integer
4458 ? "-fdefault-integer-8" : "-fdefault-real-8");
4460 create_int_parameter (u->local_name[0] ? u->local_name
4462 symbol[i].value, mod, INTMOD_ISO_FORTRAN_ENV,
4467 for (i = 0; symbol[i].name; i++)
4470 for (u = gfc_rename_list; u; u = u->next)
4472 if (strcmp (symbol[i].name, u->use_name) == 0)
4474 local_name = u->local_name;
4480 if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
4481 && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
4482 gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
4483 "from intrinsic module ISO_FORTRAN_ENV at %C is "
4484 "incompatible with option %s",
4485 gfc_option.flag_default_integer
4486 ? "-fdefault-integer-8" : "-fdefault-real-8");
4488 create_int_parameter (local_name ? local_name : symbol[i].name,
4489 symbol[i].value, mod, INTMOD_ISO_FORTRAN_ENV,
4493 for (u = gfc_rename_list; u; u = u->next)
4498 gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
4499 "module ISO_FORTRAN_ENV", u->use_name, &u->where);
4505 /* Process a USE directive. */
4508 gfc_use_module (void)
4513 gfc_symtree *mod_symtree;
4515 filename = (char *) alloca (strlen (module_name) + strlen (MODULE_EXTENSION)
4517 strcpy (filename, module_name);
4518 strcat (filename, MODULE_EXTENSION);
4520 /* First, try to find an non-intrinsic module, unless the USE statement
4521 specified that the module is intrinsic. */
4524 module_fp = gfc_open_included_file (filename, true, true);
4526 /* Then, see if it's an intrinsic one, unless the USE statement
4527 specified that the module is non-intrinsic. */
4528 if (module_fp == NULL && !specified_nonint)
4530 if (strcmp (module_name, "iso_fortran_env") == 0
4531 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ISO_FORTRAN_ENV "
4532 "intrinsic module at %C") != FAILURE)
4534 use_iso_fortran_env_module ();
4538 if (strcmp (module_name, "iso_c_binding") == 0
4539 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: "
4540 "ISO_C_BINDING module at %C") != FAILURE)
4542 import_iso_c_binding_module();
4546 module_fp = gfc_open_intrinsic_module (filename);
4548 if (module_fp == NULL && specified_int)
4549 gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C",
4553 if (module_fp == NULL)
4554 gfc_fatal_error ("Can't open module file '%s' for reading at %C: %s",
4555 filename, strerror (errno));
4557 /* Check that we haven't already USEd an intrinsic module with the
4560 mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, module_name);
4561 if (mod_symtree && mod_symtree->n.sym->attr.intrinsic)
4562 gfc_error ("Use of non-intrinsic module '%s' at %C conflicts with "
4563 "intrinsic module name used previously", module_name);
4570 /* Skip the first two lines of the module, after checking that this is
4571 a gfortran module file. */
4577 bad_module ("Unexpected end of module");
4580 if ((start == 1 && strcmp (atom_name, "GFORTRAN") != 0)
4581 || (start == 2 && strcmp (atom_name, " module") != 0))
4582 gfc_fatal_error ("File '%s' opened at %C is not a GFORTRAN module "
4589 /* Make sure we're not reading the same module that we may be building. */
4590 for (p = gfc_state_stack; p; p = p->previous)
4591 if (p->state == COMP_MODULE && strcmp (p->sym->name, module_name) == 0)
4592 gfc_fatal_error ("Can't USE the same module we're building!");
4595 init_true_name_tree ();
4599 free_true_name (true_name_root);
4600 true_name_root = NULL;
4602 free_pi_tree (pi_root);
4610 gfc_module_init_2 (void)
4612 last_atom = ATOM_LPAREN;
4617 gfc_module_done_2 (void)