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 2, 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 COPYING. If not, write to the Free
21 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
24 /* The syntax of gfortran modules resembles that of lisp lists, ie 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> )
41 ( ( <name of operator interface> <module of op interface> <i/f1> ... )
44 ( ( <name of generic interface> <module of generic interface> <i/f1> ... )
47 ( ( <common name> <symbol> <saved flag>)
53 ( <Symbol Number (in no particular order)>
55 <Module name of symbol>
56 ( <symbol information> )
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
74 #include "parse.h" /* FIXME */
77 #define MODULE_EXTENSION ".mod"
80 /* Structure that describes a position within a module file. */
89 /* Structure for list of symbols of intrinsic modules. */
101 P_UNKNOWN = 0, P_OTHER, P_NAMESPACE, P_COMPONENT, P_SYMBOL
105 /* The fixup structure lists pointers to pointers that have to
106 be updated when a pointer value becomes known. */
108 typedef struct fixup_t
111 struct fixup_t *next;
116 /* Structure for holding extra info needed for pointers being read. */
118 typedef struct pointer_info
120 BBT_HEADER (pointer_info);
124 /* The first component of each member of the union is the pointer
131 void *pointer; /* Member for doing pointer searches. */
136 char true_name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
138 { UNUSED, NEEDED, USED }
143 gfc_symtree *symtree;
144 char binding_label[GFC_MAX_SYMBOL_LEN + 1];
152 { UNREFERENCED = 0, NEEDS_WRITE, WRITTEN }
162 #define gfc_get_pointer_info() gfc_getmem(sizeof(pointer_info))
165 /* Lists of rename info for the USE statement. */
167 typedef struct gfc_use_rename
169 char local_name[GFC_MAX_SYMBOL_LEN + 1], use_name[GFC_MAX_SYMBOL_LEN + 1];
170 struct gfc_use_rename *next;
172 gfc_intrinsic_op operator;
177 #define gfc_get_use_rename() gfc_getmem(sizeof(gfc_use_rename))
179 /* Local variables */
181 /* The FILE for the module we're reading or writing. */
182 static FILE *module_fp;
184 /* MD5 context structure. */
185 static struct md5_ctx ctx;
187 /* The name of the module we're reading (USE'ing) or writing. */
188 static char module_name[GFC_MAX_SYMBOL_LEN + 1];
190 /* The way the module we're reading was specified. */
191 static bool specified_nonint, specified_int;
193 static int module_line, module_column, only_flag;
195 { IO_INPUT, IO_OUTPUT }
198 static gfc_use_rename *gfc_rename_list;
199 static pointer_info *pi_root;
200 static int symbol_number; /* Counter for assigning symbol numbers */
202 /* Tells mio_expr_ref to make symbols for unused equivalence members. */
203 static bool in_load_equiv;
207 /*****************************************************************/
209 /* Pointer/integer conversion. Pointers between structures are stored
210 as integers in the module file. The next couple of subroutines
211 handle this translation for reading and writing. */
213 /* Recursively free the tree of pointer structures. */
216 free_pi_tree (pointer_info *p)
221 if (p->fixup != NULL)
222 gfc_internal_error ("free_pi_tree(): Unresolved fixup");
224 free_pi_tree (p->left);
225 free_pi_tree (p->right);
231 /* Compare pointers when searching by pointer. Used when writing a
235 compare_pointers (void *_sn1, void *_sn2)
237 pointer_info *sn1, *sn2;
239 sn1 = (pointer_info *) _sn1;
240 sn2 = (pointer_info *) _sn2;
242 if (sn1->u.pointer < sn2->u.pointer)
244 if (sn1->u.pointer > sn2->u.pointer)
251 /* Compare integers when searching by integer. Used when reading a
255 compare_integers (void *_sn1, void *_sn2)
257 pointer_info *sn1, *sn2;
259 sn1 = (pointer_info *) _sn1;
260 sn2 = (pointer_info *) _sn2;
262 if (sn1->integer < sn2->integer)
264 if (sn1->integer > sn2->integer)
271 /* Initialize the pointer_info tree. */
280 compare = (iomode == IO_INPUT) ? compare_integers : compare_pointers;
282 /* Pointer 0 is the NULL pointer. */
283 p = gfc_get_pointer_info ();
288 gfc_insert_bbt (&pi_root, p, compare);
290 /* Pointer 1 is the current namespace. */
291 p = gfc_get_pointer_info ();
292 p->u.pointer = gfc_current_ns;
294 p->type = P_NAMESPACE;
296 gfc_insert_bbt (&pi_root, p, compare);
302 /* During module writing, call here with a pointer to something,
303 returning the pointer_info node. */
305 static pointer_info *
306 find_pointer (void *gp)
313 if (p->u.pointer == gp)
315 p = (gp < p->u.pointer) ? p->left : p->right;
322 /* Given a pointer while writing, returns the pointer_info tree node,
323 creating it if it doesn't exist. */
325 static pointer_info *
326 get_pointer (void *gp)
330 p = find_pointer (gp);
334 /* Pointer doesn't have an integer. Give it one. */
335 p = gfc_get_pointer_info ();
338 p->integer = symbol_number++;
340 gfc_insert_bbt (&pi_root, p, compare_pointers);
346 /* Given an integer during reading, find it in the pointer_info tree,
347 creating the node if not found. */
349 static pointer_info *
350 get_integer (int integer)
360 c = compare_integers (&t, p);
364 p = (c < 0) ? p->left : p->right;
370 p = gfc_get_pointer_info ();
371 p->integer = integer;
374 gfc_insert_bbt (&pi_root, p, compare_integers);
380 /* Recursive function to find a pointer within a tree by brute force. */
382 static pointer_info *
383 fp2 (pointer_info *p, const void *target)
390 if (p->u.pointer == target)
393 q = fp2 (p->left, target);
397 return fp2 (p->right, target);
401 /* During reading, find a pointer_info node from the pointer value.
402 This amounts to a brute-force search. */
404 static pointer_info *
405 find_pointer2 (void *p)
407 return fp2 (pi_root, p);
411 /* Resolve any fixups using a known pointer. */
414 resolve_fixups (fixup_t *f, void *gp)
427 /* Call here during module reading when we know what pointer to
428 associate with an integer. Any fixups that exist are resolved at
432 associate_integer_pointer (pointer_info *p, void *gp)
434 if (p->u.pointer != NULL)
435 gfc_internal_error ("associate_integer_pointer(): Already associated");
439 resolve_fixups (p->fixup, gp);
445 /* During module reading, given an integer and a pointer to a pointer,
446 either store the pointer from an already-known value or create a
447 fixup structure in order to store things later. Returns zero if
448 the reference has been actually stored, or nonzero if the reference
449 must be fixed later (ie associate_integer_pointer must be called
450 sometime later. Returns the pointer_info structure. */
452 static pointer_info *
453 add_fixup (int integer, void *gp)
459 p = get_integer (integer);
461 if (p->integer == 0 || p->u.pointer != NULL)
468 f = gfc_getmem (sizeof (fixup_t));
480 /*****************************************************************/
482 /* Parser related subroutines */
484 /* Free the rename list left behind by a USE statement. */
489 gfc_use_rename *next;
491 for (; gfc_rename_list; gfc_rename_list = next)
493 next = gfc_rename_list->next;
494 gfc_free (gfc_rename_list);
499 /* Match a USE statement. */
504 char name[GFC_MAX_SYMBOL_LEN + 1], module_nature[GFC_MAX_SYMBOL_LEN + 1];
505 gfc_use_rename *tail = NULL, *new;
506 interface_type type, type2;
507 gfc_intrinsic_op operator;
510 specified_int = false;
511 specified_nonint = false;
513 if (gfc_match (" , ") == MATCH_YES)
515 if ((m = gfc_match (" %n ::", module_nature)) == MATCH_YES)
517 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: module "
518 "nature in USE statement at %C") == FAILURE)
521 if (strcmp (module_nature, "intrinsic") == 0)
522 specified_int = true;
525 if (strcmp (module_nature, "non_intrinsic") == 0)
526 specified_nonint = true;
529 gfc_error ("Module nature in USE statement at %C shall "
530 "be either INTRINSIC or NON_INTRINSIC");
537 /* Help output a better error message than "Unclassifiable
539 gfc_match (" %n", module_nature);
540 if (strcmp (module_nature, "intrinsic") == 0
541 || strcmp (module_nature, "non_intrinsic") == 0)
542 gfc_error ("\"::\" was expected after module nature at %C "
543 "but was not found");
549 m = gfc_match (" ::");
550 if (m == MATCH_YES &&
551 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: "
552 "\"USE :: module\" at %C") == FAILURE)
557 m = gfc_match ("% ");
563 m = gfc_match_name (module_name);
570 if (gfc_match_eos () == MATCH_YES)
572 if (gfc_match_char (',') != MATCH_YES)
575 if (gfc_match (" only :") == MATCH_YES)
578 if (gfc_match_eos () == MATCH_YES)
583 /* Get a new rename struct and add it to the rename list. */
584 new = gfc_get_use_rename ();
585 new->where = gfc_current_locus;
588 if (gfc_rename_list == NULL)
589 gfc_rename_list = new;
594 /* See what kind of interface we're dealing with. Assume it is
596 new->operator = INTRINSIC_NONE;
597 if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
602 case INTERFACE_NAMELESS:
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")
619 strcpy (new->use_name, name);
622 strcpy (new->local_name, name);
623 m = gfc_match_generic_spec (&type2, new->use_name, &operator);
628 if (m == MATCH_ERROR)
636 strcpy (new->local_name, name);
638 m = gfc_match_generic_spec (&type2, new->use_name, &operator);
643 if (m == MATCH_ERROR)
647 if (strcmp (new->use_name, module_name) == 0
648 || strcmp (new->local_name, module_name) == 0)
650 gfc_error ("The name '%s' at %C has already been used as "
651 "an external module name.", module_name);
656 case INTERFACE_INTRINSIC_OP:
657 new->operator = operator;
661 if (gfc_match_eos () == MATCH_YES)
663 if (gfc_match_char (',') != MATCH_YES)
670 gfc_syntax_error (ST_USE);
678 /* Given a name and a number, inst, return the inst name
679 under which to load this symbol. Returns NULL if this
680 symbol shouldn't be loaded. If inst is zero, returns
681 the number of instances of this name. */
684 find_use_name_n (const char *name, int *inst)
690 for (u = gfc_rename_list; u; u = u->next)
692 if (strcmp (u->use_name, name) != 0)
705 return only_flag ? NULL : name;
709 return (u->local_name[0] != '\0') ? u->local_name : name;
713 /* Given a name, return the name under which to load this symbol.
714 Returns NULL if this symbol shouldn't be loaded. */
717 find_use_name (const char *name)
720 return find_use_name_n (name, &i);
724 /* Given a real name, return the number of use names associated with it. */
727 number_use_names (const char *name)
731 c = find_use_name_n (name, &i);
736 /* Try to find the operator in the current list. */
738 static gfc_use_rename *
739 find_use_operator (gfc_intrinsic_op operator)
743 for (u = gfc_rename_list; u; u = u->next)
744 if (u->operator == operator)
751 /*****************************************************************/
753 /* The next couple of subroutines maintain a tree used to avoid a
754 brute-force search for a combination of true name and module name.
755 While symtree names, the name that a particular symbol is known by
756 can changed with USE statements, we still have to keep track of the
757 true names to generate the correct reference, and also avoid
758 loading the same real symbol twice in a program unit.
760 When we start reading, the true name tree is built and maintained
761 as symbols are read. The tree is searched as we load new symbols
762 to see if it already exists someplace in the namespace. */
764 typedef struct true_name
766 BBT_HEADER (true_name);
771 static true_name *true_name_root;
774 /* Compare two true_name structures. */
777 compare_true_names (void *_t1, void *_t2)
782 t1 = (true_name *) _t1;
783 t2 = (true_name *) _t2;
785 c = ((t1->sym->module > t2->sym->module)
786 - (t1->sym->module < t2->sym->module));
790 return strcmp (t1->sym->name, t2->sym->name);
794 /* Given a true name, search the true name tree to see if it exists
795 within the main namespace. */
798 find_true_name (const char *name, const char *module)
804 sym.name = gfc_get_string (name);
806 sym.module = gfc_get_string (module);
814 c = compare_true_names ((void *) (&t), (void *) p);
818 p = (c < 0) ? p->left : p->right;
825 /* Given a gfc_symbol pointer that is not in the true name tree, add it. */
828 add_true_name (gfc_symbol *sym)
832 t = gfc_getmem (sizeof (true_name));
835 gfc_insert_bbt (&true_name_root, t, compare_true_names);
839 /* Recursive function to build the initial true name tree by
840 recursively traversing the current namespace. */
843 build_tnt (gfc_symtree *st)
848 build_tnt (st->left);
849 build_tnt (st->right);
851 if (find_true_name (st->n.sym->name, st->n.sym->module) != NULL)
854 add_true_name (st->n.sym);
858 /* Initialize the true name tree with the current namespace. */
861 init_true_name_tree (void)
863 true_name_root = NULL;
864 build_tnt (gfc_current_ns->sym_root);
868 /* Recursively free a true name tree node. */
871 free_true_name (true_name *t)
875 free_true_name (t->left);
876 free_true_name (t->right);
882 /*****************************************************************/
884 /* Module reading and writing. */
888 ATOM_NAME, ATOM_LPAREN, ATOM_RPAREN, ATOM_INTEGER, ATOM_STRING
892 static atom_type last_atom;
895 /* The name buffer must be at least as long as a symbol name. Right
896 now it's not clear how we're going to store numeric constants--
897 probably as a hexadecimal string, since this will allow the exact
898 number to be preserved (this can't be done by a decimal
899 representation). Worry about that later. TODO! */
901 #define MAX_ATOM_SIZE 100
904 static char *atom_string, atom_name[MAX_ATOM_SIZE];
907 /* Report problems with a module. Error reporting is not very
908 elaborate, since this sorts of errors shouldn't really happen.
909 This subroutine never returns. */
911 static void bad_module (const char *) ATTRIBUTE_NORETURN;
914 bad_module (const char *msgid)
921 gfc_fatal_error ("Reading module %s at line %d column %d: %s",
922 module_name, module_line, module_column, msgid);
925 gfc_fatal_error ("Writing module %s at line %d column %d: %s",
926 module_name, module_line, module_column, msgid);
929 gfc_fatal_error ("Module %s at line %d column %d: %s",
930 module_name, module_line, module_column, msgid);
936 /* Set the module's input pointer. */
939 set_module_locus (module_locus *m)
941 module_column = m->column;
942 module_line = m->line;
943 fsetpos (module_fp, &m->pos);
947 /* Get the module's input pointer so that we can restore it later. */
950 get_module_locus (module_locus *m)
952 m->column = module_column;
953 m->line = module_line;
954 fgetpos (module_fp, &m->pos);
958 /* Get the next character in the module, updating our reckoning of
966 c = getc (module_fp);
969 bad_module ("Unexpected EOF");
982 /* Parse a string constant. The delimiter is guaranteed to be a
992 get_module_locus (&start);
996 /* See how long the string is. */
1001 bad_module ("Unexpected end of module in string constant");
1019 set_module_locus (&start);
1021 atom_string = p = gfc_getmem (len + 1);
1023 for (; len > 0; len--)
1027 module_char (); /* Guaranteed to be another \'. */
1031 module_char (); /* Terminating \'. */
1032 *p = '\0'; /* C-style string for debug purposes. */
1036 /* Parse a small integer. */
1039 parse_integer (int c)
1047 get_module_locus (&m);
1053 atom_int = 10 * atom_int + c - '0';
1054 if (atom_int > 99999999)
1055 bad_module ("Integer overflow");
1058 set_module_locus (&m);
1076 get_module_locus (&m);
1081 if (!ISALNUM (c) && c != '_' && c != '-')
1085 if (++len > GFC_MAX_SYMBOL_LEN)
1086 bad_module ("Name too long");
1091 fseek (module_fp, -1, SEEK_CUR);
1092 module_column = m.column + len - 1;
1099 /* Read the next atom in the module's input stream. */
1110 while (c == ' ' || c == '\n');
1135 return ATOM_INTEGER;
1193 bad_module ("Bad name");
1200 /* Peek at the next atom on the input. */
1208 get_module_locus (&m);
1211 if (a == ATOM_STRING)
1212 gfc_free (atom_string);
1214 set_module_locus (&m);
1219 /* Read the next atom from the input, requiring that it be a
1223 require_atom (atom_type type)
1229 get_module_locus (&m);
1237 p = _("Expected name");
1240 p = _("Expected left parenthesis");
1243 p = _("Expected right parenthesis");
1246 p = _("Expected integer");
1249 p = _("Expected string");
1252 gfc_internal_error ("require_atom(): bad atom type required");
1255 set_module_locus (&m);
1261 /* Given a pointer to an mstring array, require that the current input
1262 be one of the strings in the array. We return the enum value. */
1265 find_enum (const mstring *m)
1269 i = gfc_string2code (m, atom_name);
1273 bad_module ("find_enum(): Enum not found");
1279 /**************** Module output subroutines ***************************/
1281 /* Output a character to a module file. */
1284 write_char (char out)
1286 if (putc (out, module_fp) == EOF)
1287 gfc_fatal_error ("Error writing modules file: %s", strerror (errno));
1289 /* Add this to our MD5. */
1290 md5_process_bytes (&out, sizeof (out), &ctx);
1302 /* Write an atom to a module. The line wrapping isn't perfect, but it
1303 should work most of the time. This isn't that big of a deal, since
1304 the file really isn't meant to be read by people anyway. */
1307 write_atom (atom_type atom, const void *v)
1329 i = *((const int *) v);
1331 gfc_internal_error ("write_atom(): Writing negative integer");
1333 sprintf (buffer, "%d", i);
1338 gfc_internal_error ("write_atom(): Trying to write dab atom");
1342 if(p == NULL || *p == '\0')
1347 if (atom != ATOM_RPAREN)
1349 if (module_column + len > 72)
1354 if (last_atom != ATOM_LPAREN && module_column != 1)
1359 if (atom == ATOM_STRING)
1362 while (p != NULL && *p)
1364 if (atom == ATOM_STRING && *p == '\'')
1369 if (atom == ATOM_STRING)
1377 /***************** Mid-level I/O subroutines *****************/
1379 /* These subroutines let their caller read or write atoms without
1380 caring about which of the two is actually happening. This lets a
1381 subroutine concentrate on the actual format of the data being
1384 static void mio_expr (gfc_expr **);
1385 static void mio_symbol_ref (gfc_symbol **);
1386 static void mio_symtree_ref (gfc_symtree **);
1388 /* Read or write an enumerated value. On writing, we return the input
1389 value for the convenience of callers. We avoid using an integer
1390 pointer because enums are sometimes inside bitfields. */
1393 mio_name (int t, const mstring *m)
1395 if (iomode == IO_OUTPUT)
1396 write_atom (ATOM_NAME, gfc_code2string (m, t));
1399 require_atom (ATOM_NAME);
1406 /* Specialization of mio_name. */
1408 #define DECL_MIO_NAME(TYPE) \
1409 static inline TYPE \
1410 MIO_NAME(TYPE) (TYPE t, const mstring *m) \
1412 return (TYPE) mio_name ((int) t, m); \
1414 #define MIO_NAME(TYPE) mio_name_##TYPE
1419 if (iomode == IO_OUTPUT)
1420 write_atom (ATOM_LPAREN, NULL);
1422 require_atom (ATOM_LPAREN);
1429 if (iomode == IO_OUTPUT)
1430 write_atom (ATOM_RPAREN, NULL);
1432 require_atom (ATOM_RPAREN);
1437 mio_integer (int *ip)
1439 if (iomode == IO_OUTPUT)
1440 write_atom (ATOM_INTEGER, ip);
1443 require_atom (ATOM_INTEGER);
1449 /* Read or write a character pointer that points to a string on the heap. */
1452 mio_allocated_string (const char *s)
1454 if (iomode == IO_OUTPUT)
1456 write_atom (ATOM_STRING, s);
1461 require_atom (ATOM_STRING);
1467 /* Read or write a string that is in static memory. */
1470 mio_pool_string (const char **stringp)
1472 /* TODO: one could write the string only once, and refer to it via a
1475 /* As a special case we have to deal with a NULL string. This
1476 happens for the 'module' member of 'gfc_symbol's that are not in a
1477 module. We read / write these as the empty string. */
1478 if (iomode == IO_OUTPUT)
1480 const char *p = *stringp == NULL ? "" : *stringp;
1481 write_atom (ATOM_STRING, p);
1485 require_atom (ATOM_STRING);
1486 *stringp = atom_string[0] == '\0' ? NULL : gfc_get_string (atom_string);
1487 gfc_free (atom_string);
1492 /* Read or write a string that is inside of some already-allocated
1496 mio_internal_string (char *string)
1498 if (iomode == IO_OUTPUT)
1499 write_atom (ATOM_STRING, string);
1502 require_atom (ATOM_STRING);
1503 strcpy (string, atom_string);
1504 gfc_free (atom_string);
1510 { AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL,
1511 AB_POINTER, AB_TARGET, AB_DUMMY, AB_RESULT, AB_DATA,
1512 AB_IN_NAMELIST, AB_IN_COMMON, AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE,
1513 AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT,
1514 AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP,
1515 AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_IS_BIND_C, AB_IS_C_INTEROP,
1520 static const mstring attr_bits[] =
1522 minit ("ALLOCATABLE", AB_ALLOCATABLE),
1523 minit ("DIMENSION", AB_DIMENSION),
1524 minit ("EXTERNAL", AB_EXTERNAL),
1525 minit ("INTRINSIC", AB_INTRINSIC),
1526 minit ("OPTIONAL", AB_OPTIONAL),
1527 minit ("POINTER", AB_POINTER),
1528 minit ("VOLATILE", AB_VOLATILE),
1529 minit ("TARGET", AB_TARGET),
1530 minit ("THREADPRIVATE", AB_THREADPRIVATE),
1531 minit ("DUMMY", AB_DUMMY),
1532 minit ("RESULT", AB_RESULT),
1533 minit ("DATA", AB_DATA),
1534 minit ("IN_NAMELIST", AB_IN_NAMELIST),
1535 minit ("IN_COMMON", AB_IN_COMMON),
1536 minit ("FUNCTION", AB_FUNCTION),
1537 minit ("SUBROUTINE", AB_SUBROUTINE),
1538 minit ("SEQUENCE", AB_SEQUENCE),
1539 minit ("ELEMENTAL", AB_ELEMENTAL),
1540 minit ("PURE", AB_PURE),
1541 minit ("RECURSIVE", AB_RECURSIVE),
1542 minit ("GENERIC", AB_GENERIC),
1543 minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT),
1544 minit ("CRAY_POINTER", AB_CRAY_POINTER),
1545 minit ("CRAY_POINTEE", AB_CRAY_POINTEE),
1546 minit ("IS_BIND_C", AB_IS_BIND_C),
1547 minit ("IS_C_INTEROP", AB_IS_C_INTEROP),
1548 minit ("IS_ISO_C", AB_IS_ISO_C),
1549 minit ("VALUE", AB_VALUE),
1550 minit ("ALLOC_COMP", AB_ALLOC_COMP),
1551 minit ("PROTECTED", AB_PROTECTED),
1556 /* Specialization of mio_name. */
1557 DECL_MIO_NAME (ab_attribute)
1558 DECL_MIO_NAME (ar_type)
1559 DECL_MIO_NAME (array_type)
1561 DECL_MIO_NAME (expr_t)
1562 DECL_MIO_NAME (gfc_access)
1563 DECL_MIO_NAME (gfc_intrinsic_op)
1564 DECL_MIO_NAME (ifsrc)
1565 DECL_MIO_NAME (save_state)
1566 DECL_MIO_NAME (procedure_type)
1567 DECL_MIO_NAME (ref_type)
1568 DECL_MIO_NAME (sym_flavor)
1569 DECL_MIO_NAME (sym_intent)
1570 #undef DECL_MIO_NAME
1572 /* Symbol attributes are stored in list with the first three elements
1573 being the enumerated fields, while the remaining elements (if any)
1574 indicate the individual attribute bits. The access field is not
1575 saved-- it controls what symbols are exported when a module is
1579 mio_symbol_attribute (symbol_attribute *attr)
1585 attr->flavor = MIO_NAME (sym_flavor) (attr->flavor, flavors);
1586 attr->intent = MIO_NAME (sym_intent) (attr->intent, intents);
1587 attr->proc = MIO_NAME (procedure_type) (attr->proc, procedures);
1588 attr->if_source = MIO_NAME (ifsrc) (attr->if_source, ifsrc_types);
1589 attr->save = MIO_NAME (save_state) (attr->save, save_status);
1591 if (iomode == IO_OUTPUT)
1593 if (attr->allocatable)
1594 MIO_NAME (ab_attribute) (AB_ALLOCATABLE, attr_bits);
1595 if (attr->dimension)
1596 MIO_NAME (ab_attribute) (AB_DIMENSION, attr_bits);
1598 MIO_NAME (ab_attribute) (AB_EXTERNAL, attr_bits);
1599 if (attr->intrinsic)
1600 MIO_NAME (ab_attribute) (AB_INTRINSIC, attr_bits);
1602 MIO_NAME (ab_attribute) (AB_OPTIONAL, attr_bits);
1604 MIO_NAME (ab_attribute) (AB_POINTER, attr_bits);
1605 if (attr->protected)
1606 MIO_NAME (ab_attribute) (AB_PROTECTED, attr_bits);
1608 MIO_NAME (ab_attribute) (AB_VALUE, attr_bits);
1609 if (attr->volatile_)
1610 MIO_NAME (ab_attribute) (AB_VOLATILE, attr_bits);
1612 MIO_NAME (ab_attribute) (AB_TARGET, attr_bits);
1613 if (attr->threadprivate)
1614 MIO_NAME (ab_attribute) (AB_THREADPRIVATE, attr_bits);
1616 MIO_NAME (ab_attribute) (AB_DUMMY, attr_bits);
1618 MIO_NAME (ab_attribute) (AB_RESULT, attr_bits);
1619 /* We deliberately don't preserve the "entry" flag. */
1622 MIO_NAME (ab_attribute) (AB_DATA, attr_bits);
1623 if (attr->in_namelist)
1624 MIO_NAME (ab_attribute) (AB_IN_NAMELIST, attr_bits);
1625 if (attr->in_common)
1626 MIO_NAME (ab_attribute) (AB_IN_COMMON, attr_bits);
1629 MIO_NAME (ab_attribute) (AB_FUNCTION, attr_bits);
1630 if (attr->subroutine)
1631 MIO_NAME (ab_attribute) (AB_SUBROUTINE, attr_bits);
1633 MIO_NAME (ab_attribute) (AB_GENERIC, attr_bits);
1636 MIO_NAME (ab_attribute) (AB_SEQUENCE, attr_bits);
1637 if (attr->elemental)
1638 MIO_NAME (ab_attribute) (AB_ELEMENTAL, attr_bits);
1640 MIO_NAME (ab_attribute) (AB_PURE, attr_bits);
1641 if (attr->recursive)
1642 MIO_NAME (ab_attribute) (AB_RECURSIVE, attr_bits);
1643 if (attr->always_explicit)
1644 MIO_NAME (ab_attribute) (AB_ALWAYS_EXPLICIT, attr_bits);
1645 if (attr->cray_pointer)
1646 MIO_NAME (ab_attribute) (AB_CRAY_POINTER, attr_bits);
1647 if (attr->cray_pointee)
1648 MIO_NAME (ab_attribute) (AB_CRAY_POINTEE, attr_bits);
1649 if (attr->is_bind_c)
1650 MIO_NAME(ab_attribute) (AB_IS_BIND_C, attr_bits);
1651 if (attr->is_c_interop)
1652 MIO_NAME(ab_attribute) (AB_IS_C_INTEROP, attr_bits);
1654 MIO_NAME(ab_attribute) (AB_IS_ISO_C, attr_bits);
1655 if (attr->alloc_comp)
1656 MIO_NAME (ab_attribute) (AB_ALLOC_COMP, attr_bits);
1666 if (t == ATOM_RPAREN)
1669 bad_module ("Expected attribute bit name");
1671 switch ((ab_attribute) find_enum (attr_bits))
1673 case AB_ALLOCATABLE:
1674 attr->allocatable = 1;
1677 attr->dimension = 1;
1683 attr->intrinsic = 1;
1692 attr->protected = 1;
1698 attr->volatile_ = 1;
1703 case AB_THREADPRIVATE:
1704 attr->threadprivate = 1;
1715 case AB_IN_NAMELIST:
1716 attr->in_namelist = 1;
1719 attr->in_common = 1;
1725 attr->subroutine = 1;
1734 attr->elemental = 1;
1740 attr->recursive = 1;
1742 case AB_ALWAYS_EXPLICIT:
1743 attr->always_explicit = 1;
1745 case AB_CRAY_POINTER:
1746 attr->cray_pointer = 1;
1748 case AB_CRAY_POINTEE:
1749 attr->cray_pointee = 1;
1752 attr->is_bind_c = 1;
1754 case AB_IS_C_INTEROP:
1755 attr->is_c_interop = 1;
1761 attr->alloc_comp = 1;
1769 static const mstring bt_types[] = {
1770 minit ("INTEGER", BT_INTEGER),
1771 minit ("REAL", BT_REAL),
1772 minit ("COMPLEX", BT_COMPLEX),
1773 minit ("LOGICAL", BT_LOGICAL),
1774 minit ("CHARACTER", BT_CHARACTER),
1775 minit ("DERIVED", BT_DERIVED),
1776 minit ("PROCEDURE", BT_PROCEDURE),
1777 minit ("UNKNOWN", BT_UNKNOWN),
1778 minit ("VOID", BT_VOID),
1784 mio_charlen (gfc_charlen **clp)
1790 if (iomode == IO_OUTPUT)
1794 mio_expr (&cl->length);
1798 if (peek_atom () != ATOM_RPAREN)
1800 cl = gfc_get_charlen ();
1801 mio_expr (&cl->length);
1805 cl->next = gfc_current_ns->cl_list;
1806 gfc_current_ns->cl_list = cl;
1814 /* Return a symtree node with a name that is guaranteed to be unique
1815 within the namespace and corresponds to an illegal fortran name. */
1817 static gfc_symtree *
1818 get_unique_symtree (gfc_namespace *ns)
1820 char name[GFC_MAX_SYMBOL_LEN + 1];
1821 static int serial = 0;
1823 sprintf (name, "@%d", serial++);
1824 return gfc_new_symtree (&ns->sym_root, name);
1828 /* See if a name is a generated name. */
1831 check_unique_name (const char *name)
1833 return *name == '@';
1838 mio_typespec (gfc_typespec *ts)
1842 ts->type = MIO_NAME (bt) (ts->type, bt_types);
1844 if (ts->type != BT_DERIVED)
1845 mio_integer (&ts->kind);
1847 mio_symbol_ref (&ts->derived);
1849 /* Add info for C interop and is_iso_c. */
1850 mio_integer (&ts->is_c_interop);
1851 mio_integer (&ts->is_iso_c);
1853 /* If the typespec is for an identifier either from iso_c_binding, or
1854 a constant that was initialized to an identifier from it, use the
1855 f90_type. Otherwise, use the ts->type, since it shouldn't matter. */
1857 ts->f90_type = MIO_NAME (bt) (ts->f90_type, bt_types);
1859 ts->f90_type = MIO_NAME (bt) (ts->type, bt_types);
1861 if (ts->type != BT_CHARACTER)
1863 /* ts->cl is only valid for BT_CHARACTER. */
1868 mio_charlen (&ts->cl);
1874 static const mstring array_spec_types[] = {
1875 minit ("EXPLICIT", AS_EXPLICIT),
1876 minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE),
1877 minit ("DEFERRED", AS_DEFERRED),
1878 minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE),
1884 mio_array_spec (gfc_array_spec **asp)
1891 if (iomode == IO_OUTPUT)
1899 if (peek_atom () == ATOM_RPAREN)
1905 *asp = as = gfc_get_array_spec ();
1908 mio_integer (&as->rank);
1909 as->type = MIO_NAME (array_type) (as->type, array_spec_types);
1911 for (i = 0; i < as->rank; i++)
1913 mio_expr (&as->lower[i]);
1914 mio_expr (&as->upper[i]);
1922 /* Given a pointer to an array reference structure (which lives in a
1923 gfc_ref structure), find the corresponding array specification
1924 structure. Storing the pointer in the ref structure doesn't quite
1925 work when loading from a module. Generating code for an array
1926 reference also needs more information than just the array spec. */
1928 static const mstring array_ref_types[] = {
1929 minit ("FULL", AR_FULL),
1930 minit ("ELEMENT", AR_ELEMENT),
1931 minit ("SECTION", AR_SECTION),
1937 mio_array_ref (gfc_array_ref *ar)
1942 ar->type = MIO_NAME (ar_type) (ar->type, array_ref_types);
1943 mio_integer (&ar->dimen);
1951 for (i = 0; i < ar->dimen; i++)
1952 mio_expr (&ar->start[i]);
1957 for (i = 0; i < ar->dimen; i++)
1959 mio_expr (&ar->start[i]);
1960 mio_expr (&ar->end[i]);
1961 mio_expr (&ar->stride[i]);
1967 gfc_internal_error ("mio_array_ref(): Unknown array ref");
1970 /* Unfortunately, ar->dimen_type is an anonymous enumerated type so
1971 we can't call mio_integer directly. Instead loop over each element
1972 and cast it to/from an integer. */
1973 if (iomode == IO_OUTPUT)
1975 for (i = 0; i < ar->dimen; i++)
1977 int tmp = (int)ar->dimen_type[i];
1978 write_atom (ATOM_INTEGER, &tmp);
1983 for (i = 0; i < ar->dimen; i++)
1985 require_atom (ATOM_INTEGER);
1986 ar->dimen_type[i] = atom_int;
1990 if (iomode == IO_INPUT)
1992 ar->where = gfc_current_locus;
1994 for (i = 0; i < ar->dimen; i++)
1995 ar->c_where[i] = gfc_current_locus;
2002 /* Saves or restores a pointer. The pointer is converted back and
2003 forth from an integer. We return the pointer_info pointer so that
2004 the caller can take additional action based on the pointer type. */
2006 static pointer_info *
2007 mio_pointer_ref (void *gp)
2011 if (iomode == IO_OUTPUT)
2013 p = get_pointer (*((char **) gp));
2014 write_atom (ATOM_INTEGER, &p->integer);
2018 require_atom (ATOM_INTEGER);
2019 p = add_fixup (atom_int, gp);
2026 /* Save and load references to components that occur within
2027 expressions. We have to describe these references by a number and
2028 by name. The number is necessary for forward references during
2029 reading, and the name is necessary if the symbol already exists in
2030 the namespace and is not loaded again. */
2033 mio_component_ref (gfc_component **cp, gfc_symbol *sym)
2035 char name[GFC_MAX_SYMBOL_LEN + 1];
2039 p = mio_pointer_ref (cp);
2040 if (p->type == P_UNKNOWN)
2041 p->type = P_COMPONENT;
2043 if (iomode == IO_OUTPUT)
2044 mio_pool_string (&(*cp)->name);
2047 mio_internal_string (name);
2049 /* It can happen that a component reference can be read before the
2050 associated derived type symbol has been loaded. Return now and
2051 wait for a later iteration of load_needed. */
2055 if (sym->components != NULL && p->u.pointer == NULL)
2057 /* Symbol already loaded, so search by name. */
2058 for (q = sym->components; q; q = q->next)
2059 if (strcmp (q->name, name) == 0)
2063 gfc_internal_error ("mio_component_ref(): Component not found");
2065 associate_integer_pointer (p, q);
2068 /* Make sure this symbol will eventually be loaded. */
2069 p = find_pointer2 (sym);
2070 if (p->u.rsym.state == UNUSED)
2071 p->u.rsym.state = NEEDED;
2077 mio_component (gfc_component *c)
2084 if (iomode == IO_OUTPUT)
2086 p = get_pointer (c);
2087 mio_integer (&p->integer);
2092 p = get_integer (n);
2093 associate_integer_pointer (p, c);
2096 if (p->type == P_UNKNOWN)
2097 p->type = P_COMPONENT;
2099 mio_pool_string (&c->name);
2100 mio_typespec (&c->ts);
2101 mio_array_spec (&c->as);
2103 mio_integer (&c->dimension);
2104 mio_integer (&c->pointer);
2105 mio_integer (&c->allocatable);
2106 c->access = MIO_NAME (gfc_access) (c->access, access_types);
2108 mio_expr (&c->initializer);
2114 mio_component_list (gfc_component **cp)
2116 gfc_component *c, *tail;
2120 if (iomode == IO_OUTPUT)
2122 for (c = *cp; c; c = c->next)
2132 if (peek_atom () == ATOM_RPAREN)
2135 c = gfc_get_component ();
2152 mio_actual_arg (gfc_actual_arglist *a)
2155 mio_pool_string (&a->name);
2156 mio_expr (&a->expr);
2162 mio_actual_arglist (gfc_actual_arglist **ap)
2164 gfc_actual_arglist *a, *tail;
2168 if (iomode == IO_OUTPUT)
2170 for (a = *ap; a; a = a->next)
2180 if (peek_atom () != ATOM_LPAREN)
2183 a = gfc_get_actual_arglist ();
2199 /* Read and write formal argument lists. */
2202 mio_formal_arglist (gfc_symbol *sym)
2204 gfc_formal_arglist *f, *tail;
2208 if (iomode == IO_OUTPUT)
2210 for (f = sym->formal; f; f = f->next)
2211 mio_symbol_ref (&f->sym);
2215 sym->formal = tail = NULL;
2217 while (peek_atom () != ATOM_RPAREN)
2219 f = gfc_get_formal_arglist ();
2220 mio_symbol_ref (&f->sym);
2222 if (sym->formal == NULL)
2235 /* Save or restore a reference to a symbol node. */
2238 mio_symbol_ref (gfc_symbol **symp)
2242 p = mio_pointer_ref (symp);
2243 if (p->type == P_UNKNOWN)
2246 if (iomode == IO_OUTPUT)
2248 if (p->u.wsym.state == UNREFERENCED)
2249 p->u.wsym.state = NEEDS_WRITE;
2253 if (p->u.rsym.state == UNUSED)
2254 p->u.rsym.state = NEEDED;
2259 /* Save or restore a reference to a symtree node. */
2262 mio_symtree_ref (gfc_symtree **stp)
2267 if (iomode == IO_OUTPUT)
2268 mio_symbol_ref (&(*stp)->n.sym);
2271 require_atom (ATOM_INTEGER);
2272 p = get_integer (atom_int);
2274 /* An unused equivalence member; make a symbol and a symtree
2276 if (in_load_equiv && p->u.rsym.symtree == NULL)
2278 /* Since this is not used, it must have a unique name. */
2279 p->u.rsym.symtree = get_unique_symtree (gfc_current_ns);
2281 /* Make the symbol. */
2282 if (p->u.rsym.sym == NULL)
2284 p->u.rsym.sym = gfc_new_symbol (p->u.rsym.true_name,
2286 p->u.rsym.sym->module = gfc_get_string (p->u.rsym.module);
2289 p->u.rsym.symtree->n.sym = p->u.rsym.sym;
2290 p->u.rsym.symtree->n.sym->refs++;
2291 p->u.rsym.referenced = 1;
2294 if (p->type == P_UNKNOWN)
2297 if (p->u.rsym.state == UNUSED)
2298 p->u.rsym.state = NEEDED;
2300 if (p->u.rsym.symtree != NULL)
2302 *stp = p->u.rsym.symtree;
2306 f = gfc_getmem (sizeof (fixup_t));
2308 f->next = p->u.rsym.stfixup;
2309 p->u.rsym.stfixup = f;
2311 f->pointer = (void **) stp;
2318 mio_iterator (gfc_iterator **ip)
2324 if (iomode == IO_OUTPUT)
2331 if (peek_atom () == ATOM_RPAREN)
2337 *ip = gfc_get_iterator ();
2342 mio_expr (&iter->var);
2343 mio_expr (&iter->start);
2344 mio_expr (&iter->end);
2345 mio_expr (&iter->step);
2353 mio_constructor (gfc_constructor **cp)
2355 gfc_constructor *c, *tail;
2359 if (iomode == IO_OUTPUT)
2361 for (c = *cp; c; c = c->next)
2364 mio_expr (&c->expr);
2365 mio_iterator (&c->iterator);
2374 while (peek_atom () != ATOM_RPAREN)
2376 c = gfc_get_constructor ();
2386 mio_expr (&c->expr);
2387 mio_iterator (&c->iterator);
2396 static const mstring ref_types[] = {
2397 minit ("ARRAY", REF_ARRAY),
2398 minit ("COMPONENT", REF_COMPONENT),
2399 minit ("SUBSTRING", REF_SUBSTRING),
2405 mio_ref (gfc_ref **rp)
2412 r->type = MIO_NAME (ref_type) (r->type, ref_types);
2417 mio_array_ref (&r->u.ar);
2421 mio_symbol_ref (&r->u.c.sym);
2422 mio_component_ref (&r->u.c.component, r->u.c.sym);
2426 mio_expr (&r->u.ss.start);
2427 mio_expr (&r->u.ss.end);
2428 mio_charlen (&r->u.ss.length);
2437 mio_ref_list (gfc_ref **rp)
2439 gfc_ref *ref, *head, *tail;
2443 if (iomode == IO_OUTPUT)
2445 for (ref = *rp; ref; ref = ref->next)
2452 while (peek_atom () != ATOM_RPAREN)
2455 head = tail = gfc_get_ref ();
2458 tail->next = gfc_get_ref ();
2472 /* Read and write an integer value. */
2475 mio_gmp_integer (mpz_t *integer)
2479 if (iomode == IO_INPUT)
2481 if (parse_atom () != ATOM_STRING)
2482 bad_module ("Expected integer string");
2484 mpz_init (*integer);
2485 if (mpz_set_str (*integer, atom_string, 10))
2486 bad_module ("Error converting integer");
2488 gfc_free (atom_string);
2492 p = mpz_get_str (NULL, 10, *integer);
2493 write_atom (ATOM_STRING, p);
2500 mio_gmp_real (mpfr_t *real)
2505 if (iomode == IO_INPUT)
2507 if (parse_atom () != ATOM_STRING)
2508 bad_module ("Expected real string");
2511 mpfr_set_str (*real, atom_string, 16, GFC_RND_MODE);
2512 gfc_free (atom_string);
2516 p = mpfr_get_str (NULL, &exponent, 16, 0, *real, GFC_RND_MODE);
2517 atom_string = gfc_getmem (strlen (p) + 20);
2519 sprintf (atom_string, "0.%s@%ld", p, exponent);
2521 /* Fix negative numbers. */
2522 if (atom_string[2] == '-')
2524 atom_string[0] = '-';
2525 atom_string[1] = '0';
2526 atom_string[2] = '.';
2529 write_atom (ATOM_STRING, atom_string);
2531 gfc_free (atom_string);
2537 /* Save and restore the shape of an array constructor. */
2540 mio_shape (mpz_t **pshape, int rank)
2546 /* A NULL shape is represented by (). */
2549 if (iomode == IO_OUTPUT)
2561 if (t == ATOM_RPAREN)
2568 shape = gfc_get_shape (rank);
2572 for (n = 0; n < rank; n++)
2573 mio_gmp_integer (&shape[n]);
2579 static const mstring expr_types[] = {
2580 minit ("OP", EXPR_OP),
2581 minit ("FUNCTION", EXPR_FUNCTION),
2582 minit ("CONSTANT", EXPR_CONSTANT),
2583 minit ("VARIABLE", EXPR_VARIABLE),
2584 minit ("SUBSTRING", EXPR_SUBSTRING),
2585 minit ("STRUCTURE", EXPR_STRUCTURE),
2586 minit ("ARRAY", EXPR_ARRAY),
2587 minit ("NULL", EXPR_NULL),
2591 /* INTRINSIC_ASSIGN is missing because it is used as an index for
2592 generic operators, not in expressions. INTRINSIC_USER is also
2593 replaced by the correct function name by the time we see it. */
2595 static const mstring intrinsics[] =
2597 minit ("UPLUS", INTRINSIC_UPLUS),
2598 minit ("UMINUS", INTRINSIC_UMINUS),
2599 minit ("PLUS", INTRINSIC_PLUS),
2600 minit ("MINUS", INTRINSIC_MINUS),
2601 minit ("TIMES", INTRINSIC_TIMES),
2602 minit ("DIVIDE", INTRINSIC_DIVIDE),
2603 minit ("POWER", INTRINSIC_POWER),
2604 minit ("CONCAT", INTRINSIC_CONCAT),
2605 minit ("AND", INTRINSIC_AND),
2606 minit ("OR", INTRINSIC_OR),
2607 minit ("EQV", INTRINSIC_EQV),
2608 minit ("NEQV", INTRINSIC_NEQV),
2609 minit ("==", INTRINSIC_EQ),
2610 minit ("EQ", INTRINSIC_EQ_OS),
2611 minit ("/=", INTRINSIC_NE),
2612 minit ("NE", INTRINSIC_NE_OS),
2613 minit (">", INTRINSIC_GT),
2614 minit ("GT", INTRINSIC_GT_OS),
2615 minit (">=", INTRINSIC_GE),
2616 minit ("GE", INTRINSIC_GE_OS),
2617 minit ("<", INTRINSIC_LT),
2618 minit ("LT", INTRINSIC_LT_OS),
2619 minit ("<=", INTRINSIC_LE),
2620 minit ("LE", INTRINSIC_LE_OS),
2621 minit ("NOT", INTRINSIC_NOT),
2622 minit ("PARENTHESES", INTRINSIC_PARENTHESES),
2627 /* Remedy a couple of situations where the gfc_expr's can be defective. */
2630 fix_mio_expr (gfc_expr *e)
2632 gfc_symtree *ns_st = NULL;
2635 if (iomode != IO_OUTPUT)
2640 /* If this is a symtree for a symbol that came from a contained module
2641 namespace, it has a unique name and we should look in the current
2642 namespace to see if the required, non-contained symbol is available
2643 yet. If so, the latter should be written. */
2644 if (e->symtree->n.sym && check_unique_name (e->symtree->name))
2645 ns_st = gfc_find_symtree (gfc_current_ns->sym_root,
2646 e->symtree->n.sym->name);
2648 /* On the other hand, if the existing symbol is the module name or the
2649 new symbol is a dummy argument, do not do the promotion. */
2650 if (ns_st && ns_st->n.sym
2651 && ns_st->n.sym->attr.flavor != FL_MODULE
2652 && !e->symtree->n.sym->attr.dummy)
2655 else if (e->expr_type == EXPR_FUNCTION && e->value.function.name)
2657 /* In some circumstances, a function used in an initialization
2658 expression, in one use associated module, can fail to be
2659 coupled to its symtree when used in a specification
2660 expression in another module. */
2661 fname = e->value.function.esym ? e->value.function.esym->name
2662 : e->value.function.isym->name;
2663 e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
2668 /* Read and write expressions. The form "()" is allowed to indicate a
2672 mio_expr (gfc_expr **ep)
2680 if (iomode == IO_OUTPUT)
2689 MIO_NAME (expr_t) (e->expr_type, expr_types);
2694 if (t == ATOM_RPAREN)
2701 bad_module ("Expected expression type");
2703 e = *ep = gfc_get_expr ();
2704 e->where = gfc_current_locus;
2705 e->expr_type = (expr_t) find_enum (expr_types);
2708 mio_typespec (&e->ts);
2709 mio_integer (&e->rank);
2713 switch (e->expr_type)
2716 e->value.op.operator
2717 = MIO_NAME (gfc_intrinsic_op) (e->value.op.operator, intrinsics);
2719 switch (e->value.op.operator)
2721 case INTRINSIC_UPLUS:
2722 case INTRINSIC_UMINUS:
2724 case INTRINSIC_PARENTHESES:
2725 mio_expr (&e->value.op.op1);
2728 case INTRINSIC_PLUS:
2729 case INTRINSIC_MINUS:
2730 case INTRINSIC_TIMES:
2731 case INTRINSIC_DIVIDE:
2732 case INTRINSIC_POWER:
2733 case INTRINSIC_CONCAT:
2737 case INTRINSIC_NEQV:
2739 case INTRINSIC_EQ_OS:
2741 case INTRINSIC_NE_OS:
2743 case INTRINSIC_GT_OS:
2745 case INTRINSIC_GE_OS:
2747 case INTRINSIC_LT_OS:
2749 case INTRINSIC_LE_OS:
2750 mio_expr (&e->value.op.op1);
2751 mio_expr (&e->value.op.op2);
2755 bad_module ("Bad operator");
2761 mio_symtree_ref (&e->symtree);
2762 mio_actual_arglist (&e->value.function.actual);
2764 if (iomode == IO_OUTPUT)
2766 e->value.function.name
2767 = mio_allocated_string (e->value.function.name);
2768 flag = e->value.function.esym != NULL;
2769 mio_integer (&flag);
2771 mio_symbol_ref (&e->value.function.esym);
2773 write_atom (ATOM_STRING, e->value.function.isym->name);
2777 require_atom (ATOM_STRING);
2778 e->value.function.name = gfc_get_string (atom_string);
2779 gfc_free (atom_string);
2781 mio_integer (&flag);
2783 mio_symbol_ref (&e->value.function.esym);
2786 require_atom (ATOM_STRING);
2787 e->value.function.isym = gfc_find_function (atom_string);
2788 gfc_free (atom_string);
2795 mio_symtree_ref (&e->symtree);
2796 mio_ref_list (&e->ref);
2799 case EXPR_SUBSTRING:
2800 e->value.character.string
2801 = (char *) mio_allocated_string (e->value.character.string);
2802 mio_ref_list (&e->ref);
2805 case EXPR_STRUCTURE:
2807 mio_constructor (&e->value.constructor);
2808 mio_shape (&e->shape, e->rank);
2815 mio_gmp_integer (&e->value.integer);
2819 gfc_set_model_kind (e->ts.kind);
2820 mio_gmp_real (&e->value.real);
2824 gfc_set_model_kind (e->ts.kind);
2825 mio_gmp_real (&e->value.complex.r);
2826 mio_gmp_real (&e->value.complex.i);
2830 mio_integer (&e->value.logical);
2834 mio_integer (&e->value.character.length);
2835 e->value.character.string
2836 = (char *) mio_allocated_string (e->value.character.string);
2840 bad_module ("Bad type in constant expression");
2853 /* Read and write namelists. */
2856 mio_namelist (gfc_symbol *sym)
2858 gfc_namelist *n, *m;
2859 const char *check_name;
2863 if (iomode == IO_OUTPUT)
2865 for (n = sym->namelist; n; n = n->next)
2866 mio_symbol_ref (&n->sym);
2870 /* This departure from the standard is flagged as an error.
2871 It does, in fact, work correctly. TODO: Allow it
2873 if (sym->attr.flavor == FL_NAMELIST)
2875 check_name = find_use_name (sym->name);
2876 if (check_name && strcmp (check_name, sym->name) != 0)
2877 gfc_error ("Namelist %s cannot be renamed by USE "
2878 "association to %s", sym->name, check_name);
2882 while (peek_atom () != ATOM_RPAREN)
2884 n = gfc_get_namelist ();
2885 mio_symbol_ref (&n->sym);
2887 if (sym->namelist == NULL)
2894 sym->namelist_tail = m;
2901 /* Save/restore lists of gfc_interface stuctures. When loading an
2902 interface, we are really appending to the existing list of
2903 interfaces. Checking for duplicate and ambiguous interfaces has to
2904 be done later when all symbols have been loaded. */
2907 mio_interface_rest (gfc_interface **ip)
2909 gfc_interface *tail, *p;
2911 if (iomode == IO_OUTPUT)
2914 for (p = *ip; p; p = p->next)
2915 mio_symbol_ref (&p->sym);
2930 if (peek_atom () == ATOM_RPAREN)
2933 p = gfc_get_interface ();
2934 p->where = gfc_current_locus;
2935 mio_symbol_ref (&p->sym);
2950 /* Save/restore a nameless operator interface. */
2953 mio_interface (gfc_interface **ip)
2956 mio_interface_rest (ip);
2960 /* Save/restore a named operator interface. */
2963 mio_symbol_interface (const char **name, const char **module,
2967 mio_pool_string (name);
2968 mio_pool_string (module);
2969 mio_interface_rest (ip);
2974 mio_namespace_ref (gfc_namespace **nsp)
2979 p = mio_pointer_ref (nsp);
2981 if (p->type == P_UNKNOWN)
2982 p->type = P_NAMESPACE;
2984 if (iomode == IO_INPUT && p->integer != 0)
2986 ns = (gfc_namespace *) p->u.pointer;
2989 ns = gfc_get_namespace (NULL, 0);
2990 associate_integer_pointer (p, ns);
2998 /* Unlike most other routines, the address of the symbol node is already
2999 fixed on input and the name/module has already been filled in. */
3002 mio_symbol (gfc_symbol *sym)
3004 int intmod = INTMOD_NONE;
3006 gfc_formal_arglist *formal;
3010 mio_symbol_attribute (&sym->attr);
3011 mio_typespec (&sym->ts);
3013 /* Contained procedures don't have formal namespaces. Instead we output the
3014 procedure namespace. The will contain the formal arguments. */
3015 if (iomode == IO_OUTPUT)
3017 formal = sym->formal;
3018 while (formal && !formal->sym)
3019 formal = formal->next;
3022 mio_namespace_ref (&formal->sym->ns);
3024 mio_namespace_ref (&sym->formal_ns);
3028 mio_namespace_ref (&sym->formal_ns);
3031 sym->formal_ns->proc_name = sym;
3036 /* Save/restore common block links. */
3037 mio_symbol_ref (&sym->common_next);
3039 mio_formal_arglist (sym);
3041 if (sym->attr.flavor == FL_PARAMETER)
3042 mio_expr (&sym->value);
3044 mio_array_spec (&sym->as);
3046 mio_symbol_ref (&sym->result);
3048 if (sym->attr.cray_pointee)
3049 mio_symbol_ref (&sym->cp_pointer);
3051 /* Note that components are always saved, even if they are supposed
3052 to be private. Component access is checked during searching. */
3054 mio_component_list (&sym->components);
3056 if (sym->components != NULL)
3057 sym->component_access
3058 = MIO_NAME (gfc_access) (sym->component_access, access_types);
3062 /* Add the fields that say whether this is from an intrinsic module,
3063 and if so, what symbol it is within the module. */
3064 /* mio_integer (&(sym->from_intmod)); */
3065 if (iomode == IO_OUTPUT)
3067 intmod = sym->from_intmod;
3068 mio_integer (&intmod);
3072 mio_integer (&intmod);
3073 sym->from_intmod = intmod;
3076 mio_integer (&(sym->intmod_sym_id));
3082 /************************* Top level subroutines *************************/
3084 /* Skip a list between balanced left and right parens. */
3094 switch (parse_atom ())
3105 gfc_free (atom_string);
3117 /* Load operator interfaces from the module. Interfaces are unusual
3118 in that they attach themselves to existing symbols. */
3121 load_operator_interfaces (void)
3124 char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
3129 while (peek_atom () != ATOM_RPAREN)
3133 mio_internal_string (name);
3134 mio_internal_string (module);
3136 /* Decide if we need to load this one or not. */
3137 p = find_use_name (name);
3140 while (parse_atom () != ATOM_RPAREN);
3144 uop = gfc_get_uop (p);
3145 mio_interface_rest (&uop->operator);
3153 /* Load interfaces from the module. Interfaces are unusual in that
3154 they attach themselves to existing symbols. */
3157 load_generic_interfaces (void)
3160 char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
3162 gfc_interface *generic = NULL;
3167 while (peek_atom () != ATOM_RPAREN)
3171 mio_internal_string (name);
3172 mio_internal_string (module);
3174 n = number_use_names (name);
3177 for (i = 1; i <= n; i++)
3179 /* Decide if we need to load this one or not. */
3180 p = find_use_name_n (name, &i);
3182 if (p == NULL || gfc_find_symbol (p, NULL, 0, &sym))
3184 while (parse_atom () != ATOM_RPAREN);
3190 gfc_get_symbol (p, NULL, &sym);
3192 sym->attr.flavor = FL_PROCEDURE;
3193 sym->attr.generic = 1;
3194 sym->attr.use_assoc = 1;
3198 /* Unless sym is a generic interface, this reference
3202 st = gfc_find_symtree (gfc_current_ns->sym_root, p);
3203 if (!sym->attr.generic
3204 && sym->module != NULL
3205 && strcmp(module, sym->module) != 0)
3210 mio_interface_rest (&sym->generic);
3211 generic = sym->generic;
3215 sym->generic = generic;
3216 sym->attr.generic_copy = 1;
3225 /* Load common blocks. */
3230 char name[GFC_MAX_SYMBOL_LEN + 1];
3235 while (peek_atom () != ATOM_RPAREN)
3239 mio_internal_string (name);
3241 p = gfc_get_common (name, 1);
3243 mio_symbol_ref (&p->head);
3244 mio_integer (&flags);
3248 p->threadprivate = 1;
3251 /* Get whether this was a bind(c) common or not. */
3252 mio_integer (&p->is_bind_c);
3253 /* Get the binding label. */
3254 mio_internal_string (p->binding_label);
3263 /* Load equivalences. The flag in_load_equiv informs mio_expr_ref of this
3264 so that unused variables are not loaded and so that the expression can
3270 gfc_equiv *head, *tail, *end, *eq;
3274 in_load_equiv = true;
3276 end = gfc_current_ns->equiv;
3277 while (end != NULL && end->next != NULL)
3280 while (peek_atom () != ATOM_RPAREN) {
3284 while(peek_atom () != ATOM_RPAREN)
3287 head = tail = gfc_get_equiv ();
3290 tail->eq = gfc_get_equiv ();
3294 mio_pool_string (&tail->module);
3295 mio_expr (&tail->expr);
3298 /* Unused equivalence members have a unique name. */
3300 for (eq = head; eq; eq = eq->eq)
3302 if (!check_unique_name (eq->expr->symtree->name))
3311 for (eq = head; eq; eq = head)
3314 gfc_free_expr (eq->expr);
3320 gfc_current_ns->equiv = head;
3331 in_load_equiv = false;
3335 /* Recursive function to traverse the pointer_info tree and load a
3336 needed symbol. We return nonzero if we load a symbol and stop the
3337 traversal, because the act of loading can alter the tree. */
3340 load_needed (pointer_info *p)
3351 rv |= load_needed (p->left);
3352 rv |= load_needed (p->right);
3354 if (p->type != P_SYMBOL || p->u.rsym.state != NEEDED)
3357 p->u.rsym.state = USED;
3359 set_module_locus (&p->u.rsym.where);
3361 sym = p->u.rsym.sym;
3364 q = get_integer (p->u.rsym.ns);
3366 ns = (gfc_namespace *) q->u.pointer;
3369 /* Create an interface namespace if necessary. These are
3370 the namespaces that hold the formal parameters of module
3373 ns = gfc_get_namespace (NULL, 0);
3374 associate_integer_pointer (q, ns);
3377 sym = gfc_new_symbol (p->u.rsym.true_name, ns);
3378 sym->module = gfc_get_string (p->u.rsym.module);
3380 associate_integer_pointer (p, sym);
3384 sym->attr.use_assoc = 1;
3386 sym->attr.use_only = 1;
3392 /* Recursive function for cleaning up things after a module has been read. */
3395 read_cleanup (pointer_info *p)
3403 read_cleanup (p->left);
3404 read_cleanup (p->right);
3406 if (p->type == P_SYMBOL && p->u.rsym.state == USED && !p->u.rsym.referenced)
3408 /* Add hidden symbols to the symtree. */
3409 q = get_integer (p->u.rsym.ns);
3410 st = get_unique_symtree ((gfc_namespace *) q->u.pointer);
3412 st->n.sym = p->u.rsym.sym;
3415 /* Fixup any symtree references. */
3416 p->u.rsym.symtree = st;
3417 resolve_fixups (p->u.rsym.stfixup, st);
3418 p->u.rsym.stfixup = NULL;
3421 /* Free unused symbols. */
3422 if (p->type == P_SYMBOL && p->u.rsym.state == UNUSED)
3423 gfc_free_symbol (p->u.rsym.sym);
3427 /* Given a root symtree node and a symbol, try to find a symtree that
3428 references the symbol that is not a unique name. */
3430 static gfc_symtree *
3431 find_symtree_for_symbol (gfc_symtree *st, gfc_symbol *sym)
3433 gfc_symtree *s = NULL;
3438 s = find_symtree_for_symbol (st->right, sym);
3441 s = find_symtree_for_symbol (st->left, sym);
3445 if (st->n.sym == sym && !check_unique_name (st->name))
3452 /* Read a module file. */
3457 module_locus operator_interfaces, user_operators;
3459 char name[GFC_MAX_SYMBOL_LEN + 1];
3461 int ambiguous, j, nuse, symbol;
3462 pointer_info *info, *q;
3467 get_module_locus (&operator_interfaces); /* Skip these for now. */
3470 get_module_locus (&user_operators);
3474 /* Skip commons and equivalences for now. */
3480 /* Create the fixup nodes for all the symbols. */
3482 while (peek_atom () != ATOM_RPAREN)
3484 require_atom (ATOM_INTEGER);
3485 info = get_integer (atom_int);
3487 info->type = P_SYMBOL;
3488 info->u.rsym.state = UNUSED;
3490 mio_internal_string (info->u.rsym.true_name);
3491 mio_internal_string (info->u.rsym.module);
3492 mio_internal_string (info->u.rsym.binding_label);
3495 require_atom (ATOM_INTEGER);
3496 info->u.rsym.ns = atom_int;
3498 get_module_locus (&info->u.rsym.where);
3501 /* See if the symbol has already been loaded by a previous module.
3502 If so, we reference the existing symbol and prevent it from
3503 being loaded again. This should not happen if the symbol being
3504 read is an index for an assumed shape dummy array (ns != 1). */
3506 sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module);
3509 || (sym->attr.flavor == FL_VARIABLE && info->u.rsym.ns !=1))
3512 info->u.rsym.state = USED;
3513 info->u.rsym.sym = sym;
3515 /* Some symbols do not have a namespace (eg. formal arguments),
3516 so the automatic "unique symtree" mechanism must be suppressed
3517 by marking them as referenced. */
3518 q = get_integer (info->u.rsym.ns);
3519 if (q->u.pointer == NULL)
3521 info->u.rsym.referenced = 1;
3525 /* If possible recycle the symtree that references the symbol.
3526 If a symtree is not found and the module does not import one,
3527 a unique-name symtree is found by read_cleanup. */
3528 st = find_symtree_for_symbol (gfc_current_ns->sym_root, sym);
3531 info->u.rsym.symtree = st;
3532 info->u.rsym.referenced = 1;
3538 /* Parse the symtree lists. This lets us mark which symbols need to
3539 be loaded. Renaming is also done at this point by replacing the
3544 while (peek_atom () != ATOM_RPAREN)
3546 mio_internal_string (name);
3547 mio_integer (&ambiguous);
3548 mio_integer (&symbol);
3550 info = get_integer (symbol);
3552 /* See how many use names there are. If none, go through the start
3553 of the loop at least once. */
3554 nuse = number_use_names (name);
3558 for (j = 1; j <= nuse; j++)
3560 /* Get the jth local name for this symbol. */
3561 p = find_use_name_n (name, &j);
3563 if (p == NULL && strcmp (name, module_name) == 0)
3566 /* Skip symtree nodes not in an ONLY clause, unless there
3567 is an existing symtree loaded from another USE statement. */
3570 st = gfc_find_symtree (gfc_current_ns->sym_root, name);
3572 info->u.rsym.symtree = st;
3576 st = gfc_find_symtree (gfc_current_ns->sym_root, p);
3580 /* Check for ambiguous symbols. */
3581 if (st->n.sym != info->u.rsym.sym)
3583 info->u.rsym.symtree = st;
3587 /* Create a symtree node in the current namespace for this
3589 st = check_unique_name (p)
3590 ? get_unique_symtree (gfc_current_ns)
3591 : gfc_new_symtree (&gfc_current_ns->sym_root, p);
3593 st->ambiguous = ambiguous;
3595 sym = info->u.rsym.sym;
3597 /* Create a symbol node if it doesn't already exist. */
3600 info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name,
3602 sym = info->u.rsym.sym;
3603 sym->module = gfc_get_string (info->u.rsym.module);
3605 /* TODO: hmm, can we test this? Do we know it will be
3606 initialized to zeros? */
3607 if (info->u.rsym.binding_label[0] != '\0')
3608 strcpy (sym->binding_label, info->u.rsym.binding_label);
3614 /* Store the symtree pointing to this symbol. */
3615 info->u.rsym.symtree = st;
3617 if (info->u.rsym.state == UNUSED)
3618 info->u.rsym.state = NEEDED;
3619 info->u.rsym.referenced = 1;
3626 /* Load intrinsic operator interfaces. */
3627 set_module_locus (&operator_interfaces);
3630 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3632 if (i == INTRINSIC_USER)
3637 u = find_use_operator (i);
3648 mio_interface (&gfc_current_ns->operator[i]);
3653 /* Load generic and user operator interfaces. These must follow the
3654 loading of symtree because otherwise symbols can be marked as
3657 set_module_locus (&user_operators);
3659 load_operator_interfaces ();
3660 load_generic_interfaces ();
3665 /* At this point, we read those symbols that are needed but haven't
3666 been loaded yet. If one symbol requires another, the other gets
3667 marked as NEEDED if its previous state was UNUSED. */
3669 while (load_needed (pi_root));
3671 /* Make sure all elements of the rename-list were found in the module. */
3673 for (u = gfc_rename_list; u; u = u->next)
3678 if (u->operator == INTRINSIC_NONE)
3680 gfc_error ("Symbol '%s' referenced at %L not found in module '%s'",
3681 u->use_name, &u->where, module_name);
3685 if (u->operator == INTRINSIC_USER)
3687 gfc_error ("User operator '%s' referenced at %L not found "
3688 "in module '%s'", u->use_name, &u->where, module_name);
3692 gfc_error ("Intrinsic operator '%s' referenced at %L not found "
3693 "in module '%s'", gfc_op2string (u->operator), &u->where,
3697 gfc_check_interfaces (gfc_current_ns);
3699 /* Clean up symbol nodes that were never loaded, create references
3700 to hidden symbols. */
3702 read_cleanup (pi_root);
3706 /* Given an access type that is specific to an entity and the default
3707 access, return nonzero if the entity is publicly accessible. If the
3708 element is declared as PUBLIC, then it is public; if declared
3709 PRIVATE, then private, and otherwise it is public unless the default
3710 access in this context has been declared PRIVATE. */
3713 gfc_check_access (gfc_access specific_access, gfc_access default_access)
3715 if (specific_access == ACCESS_PUBLIC)
3717 if (specific_access == ACCESS_PRIVATE)
3720 return default_access != ACCESS_PRIVATE;
3724 /* Write a common block to the module. */
3727 write_common (gfc_symtree *st)
3737 write_common (st->left);
3738 write_common (st->right);
3742 /* Write the unmangled name. */
3743 name = st->n.common->name;
3745 mio_pool_string (&name);
3748 mio_symbol_ref (&p->head);
3749 flags = p->saved ? 1 : 0;
3750 if (p->threadprivate) flags |= 2;
3751 mio_integer (&flags);
3753 /* Write out whether the common block is bind(c) or not. */
3754 mio_integer (&(p->is_bind_c));
3756 /* Write out the binding label, or the com name if no label given. */
3759 label = p->binding_label;
3760 mio_pool_string (&label);
3765 mio_pool_string (&label);
3772 /* Write the blank common block to the module. */
3775 write_blank_common (void)
3777 const char * name = BLANK_COMMON_NAME;
3779 /* TODO: Blank commons are not bind(c). The F2003 standard probably says
3780 this, but it hasn't been checked. Just making it so for now. */
3783 if (gfc_current_ns->blank_common.head == NULL)
3788 mio_pool_string (&name);
3790 mio_symbol_ref (&gfc_current_ns->blank_common.head);
3791 saved = gfc_current_ns->blank_common.saved;
3792 mio_integer (&saved);
3794 /* Write out whether the common block is bind(c) or not. */
3795 mio_integer (&is_bind_c);
3797 /* Write out the binding label, which is BLANK_COMMON_NAME, though
3798 it doesn't matter because the label isn't used. */
3799 mio_pool_string (&name);
3805 /* Write equivalences to the module. */
3814 for (eq = gfc_current_ns->equiv; eq; eq = eq->next)
3818 for (e = eq; e; e = e->eq)
3820 if (e->module == NULL)
3821 e->module = gfc_get_string ("%s.eq.%d", module_name, num);
3822 mio_allocated_string (e->module);
3823 mio_expr (&e->expr);
3832 /* Write a symbol to the module. */
3835 write_symbol (int n, gfc_symbol *sym)
3839 if (sym->attr.flavor == FL_UNKNOWN || sym->attr.flavor == FL_LABEL)
3840 gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym->name);
3843 mio_pool_string (&sym->name);
3845 mio_pool_string (&sym->module);
3846 if (sym->attr.is_bind_c || sym->attr.is_iso_c)
3848 label = sym->binding_label;
3849 mio_pool_string (&label);
3852 mio_pool_string (&sym->name);
3854 mio_pointer_ref (&sym->ns);
3861 /* Recursive traversal function to write the initial set of symbols to
3862 the module. We check to see if the symbol should be written
3863 according to the access specification. */
3866 write_symbol0 (gfc_symtree *st)
3874 write_symbol0 (st->left);
3875 write_symbol0 (st->right);
3878 if (sym->module == NULL)
3879 sym->module = gfc_get_string (module_name);
3881 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
3882 && !sym->attr.subroutine && !sym->attr.function)
3885 if (!gfc_check_access (sym->attr.access, sym->ns->default_access))
3888 p = get_pointer (sym);
3889 if (p->type == P_UNKNOWN)
3892 if (p->u.wsym.state == WRITTEN)
3895 write_symbol (p->integer, sym);
3896 p->u.wsym.state = WRITTEN;
3900 /* Recursive traversal function to write the secondary set of symbols
3901 to the module file. These are symbols that were not public yet are
3902 needed by the public symbols or another dependent symbol. The act
3903 of writing a symbol can modify the pointer_info tree, so we cease
3904 traversal if we find a symbol to write. We return nonzero if a
3905 symbol was written and pass that information upwards. */
3908 write_symbol1 (pointer_info *p)
3914 if (write_symbol1 (p->left))
3916 if (write_symbol1 (p->right))
3919 if (p->type != P_SYMBOL || p->u.wsym.state != NEEDS_WRITE)
3922 p->u.wsym.state = WRITTEN;
3923 write_symbol (p->integer, p->u.wsym.sym);
3929 /* Write operator interfaces associated with a symbol. */
3932 write_operator (gfc_user_op *uop)
3934 static char nullstring[] = "";
3935 const char *p = nullstring;
3937 if (uop->operator == NULL
3938 || !gfc_check_access (uop->access, uop->ns->default_access))
3941 mio_symbol_interface (&uop->name, &p, &uop->operator);
3945 /* Write generic interfaces associated with a symbol. */
3948 write_generic (gfc_symbol *sym)
3950 if (sym->generic == NULL
3951 || !gfc_check_access (sym->attr.access, sym->ns->default_access))
3954 if (sym->module == NULL)
3955 sym->module = gfc_get_string (module_name);
3957 mio_symbol_interface (&sym->name, &sym->module, &sym->generic);
3962 write_symtree (gfc_symtree *st)
3968 if (!gfc_check_access (sym->attr.access, sym->ns->default_access)
3969 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
3970 && !sym->attr.subroutine && !sym->attr.function))
3973 if (check_unique_name (st->name))
3976 p = find_pointer (sym);
3978 gfc_internal_error ("write_symtree(): Symbol not written");
3980 mio_pool_string (&st->name);
3981 mio_integer (&st->ambiguous);
3982 mio_integer (&p->integer);
3991 /* Write the operator interfaces. */
3994 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3996 if (i == INTRINSIC_USER)
3999 mio_interface (gfc_check_access (gfc_current_ns->operator_access[i],
4000 gfc_current_ns->default_access)
4001 ? &gfc_current_ns->operator[i] : NULL);
4009 gfc_traverse_user_op (gfc_current_ns, write_operator);
4015 gfc_traverse_ns (gfc_current_ns, write_generic);
4021 write_blank_common ();
4022 write_common (gfc_current_ns->common_root);
4033 /* Write symbol information. First we traverse all symbols in the
4034 primary namespace, writing those that need to be written.
4035 Sometimes writing one symbol will cause another to need to be
4036 written. A list of these symbols ends up on the write stack, and
4037 we end by popping the bottom of the stack and writing the symbol
4038 until the stack is empty. */
4042 write_symbol0 (gfc_current_ns->sym_root);
4043 while (write_symbol1 (pi_root));
4051 gfc_traverse_symtree (gfc_current_ns->sym_root, write_symtree);
4056 /* Read a MD5 sum from the header of a module file. If the file cannot
4057 be opened, or we have any other error, we return -1. */
4060 read_md5_from_module_file (const char * filename, unsigned char md5[16])
4066 /* Open the file. */
4067 if ((file = fopen (filename, "r")) == NULL)
4070 /* Read two lines. */
4071 if (fgets (buf, sizeof (buf) - 1, file) == NULL
4072 || fgets (buf, sizeof (buf) - 1, file) == NULL)
4078 /* Close the file. */
4081 /* If the header is not what we expect, or is too short, bail out. */
4082 if (strncmp (buf, "MD5:", 4) != 0 || strlen (buf) < 4 + 16)
4085 /* Now, we have a real MD5, read it into the array. */
4086 for (n = 0; n < 16; n++)
4090 if (sscanf (&(buf[4+2*n]), "%02x", &x) != 1)
4100 /* Given module, dump it to disk. If there was an error while
4101 processing the module, dump_flag will be set to zero and we delete
4102 the module file, even if it was already there. */
4105 gfc_dump_module (const char *name, int dump_flag)
4108 char *filename, *filename_tmp, *p;
4111 unsigned char md5_new[16], md5_old[16];
4113 n = strlen (name) + strlen (MODULE_EXTENSION) + 1;
4114 if (gfc_option.module_dir != NULL)
4116 n += strlen (gfc_option.module_dir);
4117 filename = (char *) alloca (n);
4118 strcpy (filename, gfc_option.module_dir);
4119 strcat (filename, name);
4123 filename = (char *) alloca (n);
4124 strcpy (filename, name);
4126 strcat (filename, MODULE_EXTENSION);
4128 /* Name of the temporary file used to write the module. */
4129 filename_tmp = (char *) alloca (n + 1);
4130 strcpy (filename_tmp, filename);
4131 strcat (filename_tmp, "0");
4133 /* There was an error while processing the module. We delete the
4134 module file, even if it was already there. */
4141 /* Write the module to the temporary file. */
4142 module_fp = fopen (filename_tmp, "w");
4143 if (module_fp == NULL)
4144 gfc_fatal_error ("Can't open module file '%s' for writing at %C: %s",
4145 filename_tmp, strerror (errno));
4147 /* Write the header, including space reserved for the MD5 sum. */
4151 *strchr (p, '\n') = '\0';
4153 fprintf (module_fp, "GFORTRAN module created from %s on %s\nMD5:",
4154 gfc_source_file, p);
4155 fgetpos (module_fp, &md5_pos);
4156 fputs ("00000000000000000000000000000000 -- "
4157 "If you edit this, you'll get what you deserve.\n\n", module_fp);
4159 /* Initialize the MD5 context that will be used for output. */
4160 md5_init_ctx (&ctx);
4162 /* Write the module itself. */
4164 strcpy (module_name, name);
4170 free_pi_tree (pi_root);
4175 /* Write the MD5 sum to the header of the module file. */
4176 md5_finish_ctx (&ctx, md5_new);
4177 fsetpos (module_fp, &md5_pos);
4178 for (n = 0; n < 16; n++)
4179 fprintf (module_fp, "%02x", md5_new[n]);
4181 if (fclose (module_fp))
4182 gfc_fatal_error ("Error writing module file '%s' for writing: %s",
4183 filename_tmp, strerror (errno));
4185 /* Read the MD5 from the header of the old module file and compare. */
4186 if (read_md5_from_module_file (filename, md5_old) != 0
4187 || memcmp (md5_old, md5_new, sizeof (md5_old)) != 0)
4189 /* Module file have changed, replace the old one. */
4191 rename (filename_tmp, filename);
4194 unlink (filename_tmp);
4199 sort_iso_c_rename_list (void)
4201 gfc_use_rename *tmp_list = NULL;
4202 gfc_use_rename *curr;
4203 gfc_use_rename *kinds_used[ISOCBINDING_NUMBER] = {NULL};
4207 for (curr = gfc_rename_list; curr; curr = curr->next)
4209 c_kind = get_c_kind (curr->use_name, c_interop_kinds_table);
4210 if (c_kind == ISOCBINDING_INVALID || c_kind == ISOCBINDING_LAST)
4212 gfc_error ("Symbol '%s' referenced at %L does not exist in "
4213 "intrinsic module ISO_C_BINDING.", curr->use_name,
4217 /* Put it in the list. */
4218 kinds_used[c_kind] = curr;
4221 /* Make a new (sorted) rename list. */
4223 while (i < ISOCBINDING_NUMBER && kinds_used[i] == NULL)
4226 if (i < ISOCBINDING_NUMBER)
4228 tmp_list = kinds_used[i];
4232 for (; i < ISOCBINDING_NUMBER; i++)
4233 if (kinds_used[i] != NULL)
4235 curr->next = kinds_used[i];
4241 gfc_rename_list = tmp_list;
4245 /* Import the intrinsic ISO_C_BINDING module, generating symbols in
4246 the current namespace for all named constants, pointer types, and
4247 procedures in the module unless the only clause was used or a rename
4248 list was provided. */
4251 import_iso_c_binding_module (void)
4253 gfc_symbol *mod_sym = NULL;
4254 gfc_symtree *mod_symtree = NULL;
4255 const char *iso_c_module_name = "__iso_c_binding";
4260 /* Look only in the current namespace. */
4261 mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, iso_c_module_name);
4263 if (mod_symtree == NULL)
4265 /* symtree doesn't already exist in current namespace. */
4266 gfc_get_sym_tree (iso_c_module_name, gfc_current_ns, &mod_symtree);
4268 if (mod_symtree != NULL)
4269 mod_sym = mod_symtree->n.sym;
4271 gfc_internal_error ("import_iso_c_binding_module(): Unable to "
4272 "create symbol for %s", iso_c_module_name);
4274 mod_sym->attr.flavor = FL_MODULE;
4275 mod_sym->attr.intrinsic = 1;
4276 mod_sym->module = gfc_get_string (iso_c_module_name);
4277 mod_sym->from_intmod = INTMOD_ISO_C_BINDING;
4280 /* Generate the symbols for the named constants representing
4281 the kinds for intrinsic data types. */
4284 /* Sort the rename list because there are dependencies between types
4285 and procedures (e.g., c_loc needs c_ptr). */
4286 sort_iso_c_rename_list ();
4288 for (u = gfc_rename_list; u; u = u->next)
4290 i = get_c_kind (u->use_name, c_interop_kinds_table);
4292 if (i == ISOCBINDING_INVALID || i == ISOCBINDING_LAST)
4294 gfc_error ("Symbol '%s' referenced at %L does not exist in "
4295 "intrinsic module ISO_C_BINDING.", u->use_name,
4300 generate_isocbinding_symbol (iso_c_module_name, i, u->local_name);
4305 for (i = 0; i < ISOCBINDING_NUMBER; i++)
4308 for (u = gfc_rename_list; u; u = u->next)
4310 if (strcmp (c_interop_kinds_table[i].name, u->use_name) == 0)
4312 local_name = u->local_name;
4317 generate_isocbinding_symbol (iso_c_module_name, i, local_name);
4320 for (u = gfc_rename_list; u; u = u->next)
4325 gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
4326 "module ISO_C_BINDING", u->use_name, &u->where);
4332 /* Add an integer named constant from a given module. */
4335 create_int_parameter (const char *name, int value, const char *modname,
4336 intmod_id module, int id)
4338 gfc_symtree *tmp_symtree;
4341 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
4342 if (tmp_symtree != NULL)
4344 if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
4347 gfc_error ("Symbol '%s' already declared", name);
4350 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree);
4351 sym = tmp_symtree->n.sym;
4353 sym->module = gfc_get_string (modname);
4354 sym->attr.flavor = FL_PARAMETER;
4355 sym->ts.type = BT_INTEGER;
4356 sym->ts.kind = gfc_default_integer_kind;
4357 sym->value = gfc_int_expr (value);
4358 sym->attr.use_assoc = 1;
4359 sym->from_intmod = module;
4360 sym->intmod_sym_id = id;
4364 /* USE the ISO_FORTRAN_ENV intrinsic module. */
4367 use_iso_fortran_env_module (void)
4369 static char mod[] = "iso_fortran_env";
4370 const char *local_name;
4372 gfc_symbol *mod_sym;
4373 gfc_symtree *mod_symtree;
4376 intmod_sym symbol[] = {
4377 #define NAMED_INTCST(a,b,c) { a, b, 0 },
4378 #include "iso-fortran-env.def"
4380 { ISOFORTRANENV_INVALID, NULL, -1234 } };
4383 #define NAMED_INTCST(a,b,c) symbol[i++].value = c;
4384 #include "iso-fortran-env.def"
4387 /* Generate the symbol for the module itself. */
4388 mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, mod);
4389 if (mod_symtree == NULL)
4391 gfc_get_sym_tree (mod, gfc_current_ns, &mod_symtree);
4392 gcc_assert (mod_symtree);
4393 mod_sym = mod_symtree->n.sym;
4395 mod_sym->attr.flavor = FL_MODULE;
4396 mod_sym->attr.intrinsic = 1;
4397 mod_sym->module = gfc_get_string (mod);
4398 mod_sym->from_intmod = INTMOD_ISO_FORTRAN_ENV;
4401 if (!mod_symtree->n.sym->attr.intrinsic)
4402 gfc_error ("Use of intrinsic module '%s' at %C conflicts with "
4403 "non-intrinsic module name used previously", mod);
4405 /* Generate the symbols for the module integer named constants. */
4407 for (u = gfc_rename_list; u; u = u->next)
4409 for (i = 0; symbol[i].name; i++)
4410 if (strcmp (symbol[i].name, u->use_name) == 0)
4413 if (symbol[i].name == NULL)
4415 gfc_error ("Symbol '%s' referenced at %L does not exist in "
4416 "intrinsic module ISO_FORTRAN_ENV", u->use_name,
4421 if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
4422 && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
4423 gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
4424 "from intrinsic module ISO_FORTRAN_ENV at %L is "
4425 "incompatible with option %s", &u->where,
4426 gfc_option.flag_default_integer
4427 ? "-fdefault-integer-8" : "-fdefault-real-8");
4429 create_int_parameter (u->local_name[0] ? u->local_name
4431 symbol[i].value, mod, INTMOD_ISO_FORTRAN_ENV,
4436 for (i = 0; symbol[i].name; i++)
4439 for (u = gfc_rename_list; u; u = u->next)
4441 if (strcmp (symbol[i].name, u->use_name) == 0)
4443 local_name = u->local_name;
4449 if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
4450 && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
4451 gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
4452 "from intrinsic module ISO_FORTRAN_ENV at %C is "
4453 "incompatible with option %s",
4454 gfc_option.flag_default_integer
4455 ? "-fdefault-integer-8" : "-fdefault-real-8");
4457 create_int_parameter (local_name ? local_name : symbol[i].name,
4458 symbol[i].value, mod, INTMOD_ISO_FORTRAN_ENV,
4462 for (u = gfc_rename_list; u; u = u->next)
4467 gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
4468 "module ISO_FORTRAN_ENV", u->use_name, &u->where);
4474 /* Process a USE directive. */
4477 gfc_use_module (void)
4482 gfc_symtree *mod_symtree;
4484 filename = (char *) alloca (strlen (module_name) + strlen (MODULE_EXTENSION)
4486 strcpy (filename, module_name);
4487 strcat (filename, MODULE_EXTENSION);
4489 /* First, try to find an non-intrinsic module, unless the USE statement
4490 specified that the module is intrinsic. */
4493 module_fp = gfc_open_included_file (filename, true, true);
4495 /* Then, see if it's an intrinsic one, unless the USE statement
4496 specified that the module is non-intrinsic. */
4497 if (module_fp == NULL && !specified_nonint)
4499 if (strcmp (module_name, "iso_fortran_env") == 0
4500 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ISO_FORTRAN_ENV "
4501 "intrinsic module at %C") != FAILURE)
4503 use_iso_fortran_env_module ();
4507 if (strcmp (module_name, "iso_c_binding") == 0
4508 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: "
4509 "ISO_C_BINDING module at %C") != FAILURE)
4511 import_iso_c_binding_module();
4515 module_fp = gfc_open_intrinsic_module (filename);
4517 if (module_fp == NULL && specified_int)
4518 gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C",
4522 if (module_fp == NULL)
4523 gfc_fatal_error ("Can't open module file '%s' for reading at %C: %s",
4524 filename, strerror (errno));
4526 /* Check that we haven't already USEd an intrinsic module with the
4529 mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, module_name);
4530 if (mod_symtree && mod_symtree->n.sym->attr.intrinsic)
4531 gfc_error ("Use of non-intrinsic module '%s' at %C conflicts with "
4532 "intrinsic module name used previously", module_name);
4539 /* Skip the first two lines of the module, after checking that this is
4540 a gfortran module file. */
4546 bad_module ("Unexpected end of module");
4549 if ((start == 1 && strcmp (atom_name, "GFORTRAN") != 0)
4550 || (start == 2 && strcmp (atom_name, " module") != 0))
4551 gfc_fatal_error ("File '%s' opened at %C is not a GFORTRAN module "
4558 /* Make sure we're not reading the same module that we may be building. */
4559 for (p = gfc_state_stack; p; p = p->previous)
4560 if (p->state == COMP_MODULE && strcmp (p->sym->name, module_name) == 0)
4561 gfc_fatal_error ("Can't USE the same module we're building!");
4564 init_true_name_tree ();
4568 free_true_name (true_name_root);
4569 true_name_root = NULL;
4571 free_pi_tree (pi_root);
4579 gfc_module_init_2 (void)
4581 last_atom = ATOM_LPAREN;
4586 gfc_module_done_2 (void)