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 */
76 #define MODULE_EXTENSION ".mod"
79 /* Structure that describes a position within a module file. */
91 P_UNKNOWN = 0, P_OTHER, P_NAMESPACE, P_COMPONENT, P_SYMBOL
95 /* The fixup structure lists pointers to pointers that have to
96 be updated when a pointer value becomes known. */
98 typedef struct fixup_t
101 struct fixup_t *next;
106 /* Structure for holding extra info needed for pointers being read. */
108 typedef struct pointer_info
110 BBT_HEADER (pointer_info);
114 /* The first component of each member of the union is the pointer
121 void *pointer; /* Member for doing pointer searches. */
126 char true_name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
128 { UNUSED, NEEDED, USED }
133 gfc_symtree *symtree;
141 { UNREFERENCED = 0, NEEDS_WRITE, WRITTEN }
151 #define gfc_get_pointer_info() gfc_getmem(sizeof(pointer_info))
154 /* Lists of rename info for the USE statement. */
156 typedef struct gfc_use_rename
158 char local_name[GFC_MAX_SYMBOL_LEN + 1], use_name[GFC_MAX_SYMBOL_LEN + 1];
159 struct gfc_use_rename *next;
161 gfc_intrinsic_op operator;
166 #define gfc_get_use_rename() gfc_getmem(sizeof(gfc_use_rename))
168 /* Local variables */
170 /* The FILE for the module we're reading or writing. */
171 static FILE *module_fp;
173 /* The name of the module we're reading (USE'ing) or writing. */
174 static char module_name[GFC_MAX_SYMBOL_LEN + 1];
176 /* The way the module we're reading was specified. */
177 static bool specified_nonint, specified_int;
179 static int module_line, module_column, only_flag;
181 { IO_INPUT, IO_OUTPUT }
184 static gfc_use_rename *gfc_rename_list;
185 static pointer_info *pi_root;
186 static int symbol_number; /* Counter for assigning symbol numbers */
188 /* Tells mio_expr_ref not to load unused equivalence members. */
189 static bool in_load_equiv;
193 /*****************************************************************/
195 /* Pointer/integer conversion. Pointers between structures are stored
196 as integers in the module file. The next couple of subroutines
197 handle this translation for reading and writing. */
199 /* Recursively free the tree of pointer structures. */
202 free_pi_tree (pointer_info *p)
207 if (p->fixup != NULL)
208 gfc_internal_error ("free_pi_tree(): Unresolved fixup");
210 free_pi_tree (p->left);
211 free_pi_tree (p->right);
217 /* Compare pointers when searching by pointer. Used when writing a
221 compare_pointers (void *_sn1, void *_sn2)
223 pointer_info *sn1, *sn2;
225 sn1 = (pointer_info *) _sn1;
226 sn2 = (pointer_info *) _sn2;
228 if (sn1->u.pointer < sn2->u.pointer)
230 if (sn1->u.pointer > sn2->u.pointer)
237 /* Compare integers when searching by integer. Used when reading a
241 compare_integers (void *_sn1, void *_sn2)
243 pointer_info *sn1, *sn2;
245 sn1 = (pointer_info *) _sn1;
246 sn2 = (pointer_info *) _sn2;
248 if (sn1->integer < sn2->integer)
250 if (sn1->integer > sn2->integer)
257 /* Initialize the pointer_info tree. */
266 compare = (iomode == IO_INPUT) ? compare_integers : compare_pointers;
268 /* Pointer 0 is the NULL pointer. */
269 p = gfc_get_pointer_info ();
274 gfc_insert_bbt (&pi_root, p, compare);
276 /* Pointer 1 is the current namespace. */
277 p = gfc_get_pointer_info ();
278 p->u.pointer = gfc_current_ns;
280 p->type = P_NAMESPACE;
282 gfc_insert_bbt (&pi_root, p, compare);
288 /* During module writing, call here with a pointer to something,
289 returning the pointer_info node. */
291 static pointer_info *
292 find_pointer (void *gp)
299 if (p->u.pointer == gp)
301 p = (gp < p->u.pointer) ? p->left : p->right;
308 /* Given a pointer while writing, returns the pointer_info tree node,
309 creating it if it doesn't exist. */
311 static pointer_info *
312 get_pointer (void *gp)
316 p = find_pointer (gp);
320 /* Pointer doesn't have an integer. Give it one. */
321 p = gfc_get_pointer_info ();
324 p->integer = symbol_number++;
326 gfc_insert_bbt (&pi_root, p, compare_pointers);
332 /* Given an integer during reading, find it in the pointer_info tree,
333 creating the node if not found. */
335 static pointer_info *
336 get_integer (int integer)
346 c = compare_integers (&t, p);
350 p = (c < 0) ? p->left : p->right;
356 p = gfc_get_pointer_info ();
357 p->integer = integer;
360 gfc_insert_bbt (&pi_root, p, compare_integers);
366 /* Recursive function to find a pointer within a tree by brute force. */
368 static pointer_info *
369 fp2 (pointer_info *p, const void *target)
376 if (p->u.pointer == target)
379 q = fp2 (p->left, target);
383 return fp2 (p->right, target);
387 /* During reading, find a pointer_info node from the pointer value.
388 This amounts to a brute-force search. */
390 static pointer_info *
391 find_pointer2 (void *p)
393 return fp2 (pi_root, p);
397 /* Resolve any fixups using a known pointer. */
399 resolve_fixups (fixup_t *f, void *gp)
412 /* Call here during module reading when we know what pointer to
413 associate with an integer. Any fixups that exist are resolved at
417 associate_integer_pointer (pointer_info *p, void *gp)
419 if (p->u.pointer != NULL)
420 gfc_internal_error ("associate_integer_pointer(): Already associated");
424 resolve_fixups (p->fixup, gp);
430 /* During module reading, given an integer and a pointer to a pointer,
431 either store the pointer from an already-known value or create a
432 fixup structure in order to store things later. Returns zero if
433 the reference has been actually stored, or nonzero if the reference
434 must be fixed later (ie associate_integer_pointer must be called
435 sometime later. Returns the pointer_info structure. */
437 static pointer_info *
438 add_fixup (int integer, void *gp)
444 p = get_integer (integer);
446 if (p->integer == 0 || p->u.pointer != NULL)
453 f = gfc_getmem (sizeof (fixup_t));
465 /*****************************************************************/
467 /* Parser related subroutines */
469 /* Free the rename list left behind by a USE statement. */
474 gfc_use_rename *next;
476 for (; gfc_rename_list; gfc_rename_list = next)
478 next = gfc_rename_list->next;
479 gfc_free (gfc_rename_list);
484 /* Match a USE statement. */
489 char name[GFC_MAX_SYMBOL_LEN + 1], module_nature[GFC_MAX_SYMBOL_LEN + 1];
490 gfc_use_rename *tail = NULL, *new;
491 interface_type type, type2;
492 gfc_intrinsic_op operator;
495 specified_int = false;
496 specified_nonint = false;
498 if (gfc_match (" , ") == MATCH_YES)
500 if ((m = gfc_match (" %n ::", module_nature)) == MATCH_YES)
502 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: module "
503 "nature in USE statement at %C") == FAILURE)
506 if (strcmp (module_nature, "intrinsic") == 0)
507 specified_int = true;
510 if (strcmp (module_nature, "non_intrinsic") == 0)
511 specified_nonint = true;
514 gfc_error ("Module nature in USE statement at %C shall "
515 "be either INTRINSIC or NON_INTRINSIC");
522 /* Help output a better error message than "Unclassifiable
524 gfc_match (" %n", module_nature);
525 if (strcmp (module_nature, "intrinsic") == 0
526 || strcmp (module_nature, "non_intrinsic") == 0)
527 gfc_error ("\"::\" was expected after module nature at %C "
528 "but was not found");
534 m = gfc_match (" ::");
535 if (m == MATCH_YES &&
536 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: "
537 "\"USE :: module\" at %C") == FAILURE)
542 m = gfc_match ("% ");
548 m = gfc_match_name (module_name);
555 if (gfc_match_eos () == MATCH_YES)
557 if (gfc_match_char (',') != MATCH_YES)
560 if (gfc_match (" only :") == MATCH_YES)
563 if (gfc_match_eos () == MATCH_YES)
568 /* Get a new rename struct and add it to the rename list. */
569 new = gfc_get_use_rename ();
570 new->where = gfc_current_locus;
573 if (gfc_rename_list == NULL)
574 gfc_rename_list = new;
579 /* See what kind of interface we're dealing with. Assume it is
581 new->operator = INTRINSIC_NONE;
582 if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
587 case INTERFACE_NAMELESS:
588 gfc_error ("Missing generic specification in USE statement at %C");
591 case INTERFACE_USER_OP:
592 case INTERFACE_GENERIC:
593 m = gfc_match (" =>");
595 if (type == INTERFACE_USER_OP && m == MATCH_YES
596 && (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Renaming "
597 "operators in USE statements at %C")
604 strcpy (new->use_name, name);
607 strcpy (new->local_name, name);
608 m = gfc_match_generic_spec (&type2, new->use_name, &operator);
613 if (m == MATCH_ERROR)
621 strcpy (new->local_name, name);
623 m = gfc_match_generic_spec (&type2, new->use_name, &operator);
628 if (m == MATCH_ERROR)
632 if (strcmp (new->use_name, module_name) == 0
633 || strcmp (new->local_name, module_name) == 0)
635 gfc_error ("The name '%s' at %C has already been used as "
636 "an external module name.", module_name);
640 if (type == INTERFACE_USER_OP)
641 new->operator = operator;
645 case INTERFACE_INTRINSIC_OP:
646 new->operator = operator;
650 if (gfc_match_eos () == MATCH_YES)
652 if (gfc_match_char (',') != MATCH_YES)
659 gfc_syntax_error (ST_USE);
667 /* Given a name and a number, inst, return the inst name
668 under which to load this symbol. Returns NULL if this
669 symbol shouldn't be loaded. If inst is zero, returns
670 the number of instances of this name. */
673 find_use_name_n (const char *name, int *inst)
679 for (u = gfc_rename_list; u; u = u->next)
681 if (strcmp (u->use_name, name) != 0)
694 return only_flag ? NULL : name;
698 return (u->local_name[0] != '\0') ? u->local_name : name;
702 /* Given a name, return the name under which to load this symbol.
703 Returns NULL if this symbol shouldn't be loaded. */
706 find_use_name (const char *name)
709 return find_use_name_n (name, &i);
713 /* Given a real name, return the number of use names associated with it. */
716 number_use_names (const char *name)
720 c = find_use_name_n (name, &i);
725 /* Try to find the operator in the current list. */
727 static gfc_use_rename *
728 find_use_operator (gfc_intrinsic_op operator)
732 for (u = gfc_rename_list; u; u = u->next)
733 if (u->operator == operator)
740 /*****************************************************************/
742 /* The next couple of subroutines maintain a tree used to avoid a
743 brute-force search for a combination of true name and module name.
744 While symtree names, the name that a particular symbol is known by
745 can changed with USE statements, we still have to keep track of the
746 true names to generate the correct reference, and also avoid
747 loading the same real symbol twice in a program unit.
749 When we start reading, the true name tree is built and maintained
750 as symbols are read. The tree is searched as we load new symbols
751 to see if it already exists someplace in the namespace. */
753 typedef struct true_name
755 BBT_HEADER (true_name);
760 static true_name *true_name_root;
763 /* Compare two true_name structures. */
766 compare_true_names (void *_t1, void *_t2)
771 t1 = (true_name *) _t1;
772 t2 = (true_name *) _t2;
774 c = ((t1->sym->module > t2->sym->module)
775 - (t1->sym->module < t2->sym->module));
779 return strcmp (t1->sym->name, t2->sym->name);
783 /* Given a true name, search the true name tree to see if it exists
784 within the main namespace. */
787 find_true_name (const char *name, const char *module)
793 sym.name = gfc_get_string (name);
795 sym.module = gfc_get_string (module);
803 c = compare_true_names ((void *) (&t), (void *) p);
807 p = (c < 0) ? p->left : p->right;
814 /* Given a gfc_symbol pointer that is not in the true name tree, add it. */
817 add_true_name (gfc_symbol *sym)
821 t = gfc_getmem (sizeof (true_name));
824 gfc_insert_bbt (&true_name_root, t, compare_true_names);
828 /* Recursive function to build the initial true name tree by
829 recursively traversing the current namespace. */
832 build_tnt (gfc_symtree *st)
837 build_tnt (st->left);
838 build_tnt (st->right);
840 if (find_true_name (st->n.sym->name, st->n.sym->module) != NULL)
843 add_true_name (st->n.sym);
847 /* Initialize the true name tree with the current namespace. */
850 init_true_name_tree (void)
852 true_name_root = NULL;
853 build_tnt (gfc_current_ns->sym_root);
857 /* Recursively free a true name tree node. */
860 free_true_name (true_name *t)
864 free_true_name (t->left);
865 free_true_name (t->right);
871 /*****************************************************************/
873 /* Module reading and writing. */
877 ATOM_NAME, ATOM_LPAREN, ATOM_RPAREN, ATOM_INTEGER, ATOM_STRING
881 static atom_type last_atom;
884 /* The name buffer must be at least as long as a symbol name. Right
885 now it's not clear how we're going to store numeric constants--
886 probably as a hexadecimal string, since this will allow the exact
887 number to be preserved (this can't be done by a decimal
888 representation). Worry about that later. TODO! */
890 #define MAX_ATOM_SIZE 100
893 static char *atom_string, atom_name[MAX_ATOM_SIZE];
896 /* Report problems with a module. Error reporting is not very
897 elaborate, since this sorts of errors shouldn't really happen.
898 This subroutine never returns. */
900 static void bad_module (const char *) ATTRIBUTE_NORETURN;
903 bad_module (const char *msgid)
910 gfc_fatal_error ("Reading module %s at line %d column %d: %s",
911 module_name, module_line, module_column, msgid);
914 gfc_fatal_error ("Writing module %s at line %d column %d: %s",
915 module_name, module_line, module_column, msgid);
918 gfc_fatal_error ("Module %s at line %d column %d: %s",
919 module_name, module_line, module_column, msgid);
925 /* Set the module's input pointer. */
928 set_module_locus (module_locus *m)
930 module_column = m->column;
931 module_line = m->line;
932 fsetpos (module_fp, &m->pos);
936 /* Get the module's input pointer so that we can restore it later. */
939 get_module_locus (module_locus *m)
941 m->column = module_column;
942 m->line = module_line;
943 fgetpos (module_fp, &m->pos);
947 /* Get the next character in the module, updating our reckoning of
955 c = fgetc (module_fp);
958 bad_module ("Unexpected EOF");
971 /* Parse a string constant. The delimiter is guaranteed to be a
981 get_module_locus (&start);
985 /* See how long the string is */
990 bad_module ("Unexpected end of module in string constant");
1008 set_module_locus (&start);
1010 atom_string = p = gfc_getmem (len + 1);
1012 for (; len > 0; len--)
1016 module_char (); /* Guaranteed to be another \' */
1020 module_char (); /* Terminating \' */
1021 *p = '\0'; /* C-style string for debug purposes. */
1025 /* Parse a small integer. */
1028 parse_integer (int c)
1036 get_module_locus (&m);
1042 atom_int = 10 * atom_int + c - '0';
1043 if (atom_int > 99999999)
1044 bad_module ("Integer overflow");
1047 set_module_locus (&m);
1065 get_module_locus (&m);
1070 if (!ISALNUM (c) && c != '_' && c != '-')
1074 if (++len > GFC_MAX_SYMBOL_LEN)
1075 bad_module ("Name too long");
1080 fseek (module_fp, -1, SEEK_CUR);
1081 module_column = m.column + len - 1;
1088 /* Read the next atom in the module's input stream. */
1099 while (c == ' ' || c == '\n');
1124 return ATOM_INTEGER;
1182 bad_module ("Bad name");
1189 /* Peek at the next atom on the input. */
1197 get_module_locus (&m);
1200 if (a == ATOM_STRING)
1201 gfc_free (atom_string);
1203 set_module_locus (&m);
1208 /* Read the next atom from the input, requiring that it be a
1212 require_atom (atom_type type)
1218 get_module_locus (&m);
1226 p = _("Expected name");
1229 p = _("Expected left parenthesis");
1232 p = _("Expected right parenthesis");
1235 p = _("Expected integer");
1238 p = _("Expected string");
1241 gfc_internal_error ("require_atom(): bad atom type required");
1244 set_module_locus (&m);
1250 /* Given a pointer to an mstring array, require that the current input
1251 be one of the strings in the array. We return the enum value. */
1254 find_enum (const mstring *m)
1258 i = gfc_string2code (m, atom_name);
1262 bad_module ("find_enum(): Enum not found");
1268 /**************** Module output subroutines ***************************/
1270 /* Output a character to a module file. */
1273 write_char (char out)
1275 if (fputc (out, module_fp) == EOF)
1276 gfc_fatal_error ("Error writing modules file: %s", strerror (errno));
1288 /* Write an atom to a module. The line wrapping isn't perfect, but it
1289 should work most of the time. This isn't that big of a deal, since
1290 the file really isn't meant to be read by people anyway. */
1293 write_atom (atom_type atom, const void *v)
1315 i = *((const int *) v);
1317 gfc_internal_error ("write_atom(): Writing negative integer");
1319 sprintf (buffer, "%d", i);
1324 gfc_internal_error ("write_atom(): Trying to write dab atom");
1330 if (atom != ATOM_RPAREN)
1332 if (module_column + len > 72)
1337 if (last_atom != ATOM_LPAREN && module_column != 1)
1342 if (atom == ATOM_STRING)
1347 if (atom == ATOM_STRING && *p == '\'')
1352 if (atom == ATOM_STRING)
1360 /***************** Mid-level I/O subroutines *****************/
1362 /* These subroutines let their caller read or write atoms without
1363 caring about which of the two is actually happening. This lets a
1364 subroutine concentrate on the actual format of the data being
1367 static void mio_expr (gfc_expr **);
1368 static void mio_symbol_ref (gfc_symbol **);
1369 static void mio_symtree_ref (gfc_symtree **);
1371 /* Read or write an enumerated value. On writing, we return the input
1372 value for the convenience of callers. We avoid using an integer
1373 pointer because enums are sometimes inside bitfields. */
1376 mio_name (int t, const mstring *m)
1378 if (iomode == IO_OUTPUT)
1379 write_atom (ATOM_NAME, gfc_code2string (m, t));
1382 require_atom (ATOM_NAME);
1389 /* Specialization of mio_name. */
1391 #define DECL_MIO_NAME(TYPE) \
1392 static inline TYPE \
1393 MIO_NAME(TYPE) (TYPE t, const mstring *m) \
1395 return (TYPE) mio_name ((int) t, m); \
1397 #define MIO_NAME(TYPE) mio_name_##TYPE
1402 if (iomode == IO_OUTPUT)
1403 write_atom (ATOM_LPAREN, NULL);
1405 require_atom (ATOM_LPAREN);
1412 if (iomode == IO_OUTPUT)
1413 write_atom (ATOM_RPAREN, NULL);
1415 require_atom (ATOM_RPAREN);
1420 mio_integer (int *ip)
1422 if (iomode == IO_OUTPUT)
1423 write_atom (ATOM_INTEGER, ip);
1426 require_atom (ATOM_INTEGER);
1432 /* Read or write a character pointer that points to a string on the
1436 mio_allocated_string (const char *s)
1438 if (iomode == IO_OUTPUT)
1440 write_atom (ATOM_STRING, s);
1445 require_atom (ATOM_STRING);
1451 /* Read or write a string that is in static memory. */
1454 mio_pool_string (const char **stringp)
1456 /* TODO: one could write the string only once, and refer to it via a
1459 /* As a special case we have to deal with a NULL string. This
1460 happens for the 'module' member of 'gfc_symbol's that are not in a
1461 module. We read / write these as the empty string. */
1462 if (iomode == IO_OUTPUT)
1464 const char *p = *stringp == NULL ? "" : *stringp;
1465 write_atom (ATOM_STRING, p);
1469 require_atom (ATOM_STRING);
1470 *stringp = atom_string[0] == '\0' ? NULL : gfc_get_string (atom_string);
1471 gfc_free (atom_string);
1476 /* Read or write a string that is inside of some already-allocated
1480 mio_internal_string (char *string)
1482 if (iomode == IO_OUTPUT)
1483 write_atom (ATOM_STRING, string);
1486 require_atom (ATOM_STRING);
1487 strcpy (string, atom_string);
1488 gfc_free (atom_string);
1495 { AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL,
1496 AB_POINTER, AB_SAVE, AB_TARGET, AB_DUMMY, AB_RESULT, AB_DATA,
1497 AB_IN_NAMELIST, AB_IN_COMMON, AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE,
1498 AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT,
1499 AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP,
1500 AB_VALUE, AB_VOLATILE, AB_PROTECTED
1504 static const mstring attr_bits[] =
1506 minit ("ALLOCATABLE", AB_ALLOCATABLE),
1507 minit ("DIMENSION", AB_DIMENSION),
1508 minit ("EXTERNAL", AB_EXTERNAL),
1509 minit ("INTRINSIC", AB_INTRINSIC),
1510 minit ("OPTIONAL", AB_OPTIONAL),
1511 minit ("POINTER", AB_POINTER),
1512 minit ("SAVE", AB_SAVE),
1513 minit ("VALUE", AB_VALUE),
1514 minit ("VOLATILE", AB_VOLATILE),
1515 minit ("TARGET", AB_TARGET),
1516 minit ("THREADPRIVATE", AB_THREADPRIVATE),
1517 minit ("DUMMY", AB_DUMMY),
1518 minit ("RESULT", AB_RESULT),
1519 minit ("DATA", AB_DATA),
1520 minit ("IN_NAMELIST", AB_IN_NAMELIST),
1521 minit ("IN_COMMON", AB_IN_COMMON),
1522 minit ("FUNCTION", AB_FUNCTION),
1523 minit ("SUBROUTINE", AB_SUBROUTINE),
1524 minit ("SEQUENCE", AB_SEQUENCE),
1525 minit ("ELEMENTAL", AB_ELEMENTAL),
1526 minit ("PURE", AB_PURE),
1527 minit ("RECURSIVE", AB_RECURSIVE),
1528 minit ("GENERIC", AB_GENERIC),
1529 minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT),
1530 minit ("CRAY_POINTER", AB_CRAY_POINTER),
1531 minit ("CRAY_POINTEE", AB_CRAY_POINTEE),
1532 minit ("ALLOC_COMP", AB_ALLOC_COMP),
1533 minit ("PROTECTED", AB_PROTECTED),
1537 /* Specialization of mio_name. */
1538 DECL_MIO_NAME (ab_attribute)
1539 DECL_MIO_NAME (ar_type)
1540 DECL_MIO_NAME (array_type)
1542 DECL_MIO_NAME (expr_t)
1543 DECL_MIO_NAME (gfc_access)
1544 DECL_MIO_NAME (gfc_intrinsic_op)
1545 DECL_MIO_NAME (ifsrc)
1546 DECL_MIO_NAME (procedure_type)
1547 DECL_MIO_NAME (ref_type)
1548 DECL_MIO_NAME (sym_flavor)
1549 DECL_MIO_NAME (sym_intent)
1550 #undef DECL_MIO_NAME
1552 /* Symbol attributes are stored in list with the first three elements
1553 being the enumerated fields, while the remaining elements (if any)
1554 indicate the individual attribute bits. The access field is not
1555 saved-- it controls what symbols are exported when a module is
1559 mio_symbol_attribute (symbol_attribute *attr)
1565 attr->flavor = MIO_NAME (sym_flavor) (attr->flavor, flavors);
1566 attr->intent = MIO_NAME (sym_intent) (attr->intent, intents);
1567 attr->proc = MIO_NAME (procedure_type) (attr->proc, procedures);
1568 attr->if_source = MIO_NAME (ifsrc) (attr->if_source, ifsrc_types);
1570 if (iomode == IO_OUTPUT)
1572 if (attr->allocatable)
1573 MIO_NAME (ab_attribute) (AB_ALLOCATABLE, attr_bits);
1574 if (attr->dimension)
1575 MIO_NAME (ab_attribute) (AB_DIMENSION, attr_bits);
1577 MIO_NAME (ab_attribute) (AB_EXTERNAL, attr_bits);
1578 if (attr->intrinsic)
1579 MIO_NAME (ab_attribute) (AB_INTRINSIC, attr_bits);
1581 MIO_NAME (ab_attribute) (AB_OPTIONAL, attr_bits);
1583 MIO_NAME (ab_attribute) (AB_POINTER, attr_bits);
1584 if (attr->protected)
1585 MIO_NAME (ab_attribute) (AB_PROTECTED, attr_bits);
1587 MIO_NAME (ab_attribute) (AB_SAVE, attr_bits);
1589 MIO_NAME (ab_attribute) (AB_VALUE, attr_bits);
1590 if (attr->volatile_)
1591 MIO_NAME (ab_attribute) (AB_VOLATILE, attr_bits);
1593 MIO_NAME (ab_attribute) (AB_TARGET, attr_bits);
1594 if (attr->threadprivate)
1595 MIO_NAME (ab_attribute) (AB_THREADPRIVATE, attr_bits);
1597 MIO_NAME (ab_attribute) (AB_DUMMY, attr_bits);
1599 MIO_NAME (ab_attribute) (AB_RESULT, attr_bits);
1600 /* We deliberately don't preserve the "entry" flag. */
1603 MIO_NAME (ab_attribute) (AB_DATA, attr_bits);
1604 if (attr->in_namelist)
1605 MIO_NAME (ab_attribute) (AB_IN_NAMELIST, attr_bits);
1606 if (attr->in_common)
1607 MIO_NAME (ab_attribute) (AB_IN_COMMON, attr_bits);
1610 MIO_NAME (ab_attribute) (AB_FUNCTION, attr_bits);
1611 if (attr->subroutine)
1612 MIO_NAME (ab_attribute) (AB_SUBROUTINE, attr_bits);
1614 MIO_NAME (ab_attribute) (AB_GENERIC, attr_bits);
1617 MIO_NAME (ab_attribute) (AB_SEQUENCE, attr_bits);
1618 if (attr->elemental)
1619 MIO_NAME (ab_attribute) (AB_ELEMENTAL, attr_bits);
1621 MIO_NAME (ab_attribute) (AB_PURE, attr_bits);
1622 if (attr->recursive)
1623 MIO_NAME (ab_attribute) (AB_RECURSIVE, attr_bits);
1624 if (attr->always_explicit)
1625 MIO_NAME (ab_attribute) (AB_ALWAYS_EXPLICIT, attr_bits);
1626 if (attr->cray_pointer)
1627 MIO_NAME (ab_attribute) (AB_CRAY_POINTER, attr_bits);
1628 if (attr->cray_pointee)
1629 MIO_NAME (ab_attribute) (AB_CRAY_POINTEE, attr_bits);
1630 if (attr->alloc_comp)
1631 MIO_NAME (ab_attribute) (AB_ALLOC_COMP, attr_bits);
1641 if (t == ATOM_RPAREN)
1644 bad_module ("Expected attribute bit name");
1646 switch ((ab_attribute) find_enum (attr_bits))
1648 case AB_ALLOCATABLE:
1649 attr->allocatable = 1;
1652 attr->dimension = 1;
1658 attr->intrinsic = 1;
1667 attr->protected = 1;
1676 attr->volatile_ = 1;
1681 case AB_THREADPRIVATE:
1682 attr->threadprivate = 1;
1693 case AB_IN_NAMELIST:
1694 attr->in_namelist = 1;
1697 attr->in_common = 1;
1703 attr->subroutine = 1;
1712 attr->elemental = 1;
1718 attr->recursive = 1;
1720 case AB_ALWAYS_EXPLICIT:
1721 attr->always_explicit = 1;
1723 case AB_CRAY_POINTER:
1724 attr->cray_pointer = 1;
1726 case AB_CRAY_POINTEE:
1727 attr->cray_pointee = 1;
1730 attr->alloc_comp = 1;
1738 static const mstring bt_types[] = {
1739 minit ("INTEGER", BT_INTEGER),
1740 minit ("REAL", BT_REAL),
1741 minit ("COMPLEX", BT_COMPLEX),
1742 minit ("LOGICAL", BT_LOGICAL),
1743 minit ("CHARACTER", BT_CHARACTER),
1744 minit ("DERIVED", BT_DERIVED),
1745 minit ("PROCEDURE", BT_PROCEDURE),
1746 minit ("UNKNOWN", BT_UNKNOWN),
1752 mio_charlen (gfc_charlen **clp)
1758 if (iomode == IO_OUTPUT)
1762 mio_expr (&cl->length);
1766 if (peek_atom () != ATOM_RPAREN)
1768 cl = gfc_get_charlen ();
1769 mio_expr (&cl->length);
1773 cl->next = gfc_current_ns->cl_list;
1774 gfc_current_ns->cl_list = cl;
1782 /* Return a symtree node with a name that is guaranteed to be unique
1783 within the namespace and corresponds to an illegal fortran name. */
1785 static gfc_symtree *
1786 get_unique_symtree (gfc_namespace *ns)
1788 char name[GFC_MAX_SYMBOL_LEN + 1];
1789 static int serial = 0;
1791 sprintf (name, "@%d", serial++);
1792 return gfc_new_symtree (&ns->sym_root, name);
1796 /* See if a name is a generated name. */
1799 check_unique_name (const char *name)
1801 return *name == '@';
1806 mio_typespec (gfc_typespec *ts)
1810 ts->type = MIO_NAME (bt) (ts->type, bt_types);
1812 if (ts->type != BT_DERIVED)
1813 mio_integer (&ts->kind);
1815 mio_symbol_ref (&ts->derived);
1817 mio_charlen (&ts->cl);
1823 static const mstring array_spec_types[] = {
1824 minit ("EXPLICIT", AS_EXPLICIT),
1825 minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE),
1826 minit ("DEFERRED", AS_DEFERRED),
1827 minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE),
1833 mio_array_spec (gfc_array_spec **asp)
1840 if (iomode == IO_OUTPUT)
1848 if (peek_atom () == ATOM_RPAREN)
1854 *asp = as = gfc_get_array_spec ();
1857 mio_integer (&as->rank);
1858 as->type = MIO_NAME (array_type) (as->type, array_spec_types);
1860 for (i = 0; i < as->rank; i++)
1862 mio_expr (&as->lower[i]);
1863 mio_expr (&as->upper[i]);
1871 /* Given a pointer to an array reference structure (which lives in a
1872 gfc_ref structure), find the corresponding array specification
1873 structure. Storing the pointer in the ref structure doesn't quite
1874 work when loading from a module. Generating code for an array
1875 reference also needs more information than just the array spec. */
1877 static const mstring array_ref_types[] = {
1878 minit ("FULL", AR_FULL),
1879 minit ("ELEMENT", AR_ELEMENT),
1880 minit ("SECTION", AR_SECTION),
1886 mio_array_ref (gfc_array_ref *ar)
1891 ar->type = MIO_NAME (ar_type) (ar->type, array_ref_types);
1892 mio_integer (&ar->dimen);
1900 for (i = 0; i < ar->dimen; i++)
1901 mio_expr (&ar->start[i]);
1906 for (i = 0; i < ar->dimen; i++)
1908 mio_expr (&ar->start[i]);
1909 mio_expr (&ar->end[i]);
1910 mio_expr (&ar->stride[i]);
1916 gfc_internal_error ("mio_array_ref(): Unknown array ref");
1919 /* Unfortunately, ar->dimen_type is an anonymous enumerated type so
1920 we can't call mio_integer directly. Instead loop over each element
1921 and cast it to/from an integer. */
1922 if (iomode == IO_OUTPUT)
1924 for (i = 0; i < ar->dimen; i++)
1926 int tmp = (int)ar->dimen_type[i];
1927 write_atom (ATOM_INTEGER, &tmp);
1932 for (i = 0; i < ar->dimen; i++)
1934 require_atom (ATOM_INTEGER);
1935 ar->dimen_type[i] = atom_int;
1939 if (iomode == IO_INPUT)
1941 ar->where = gfc_current_locus;
1943 for (i = 0; i < ar->dimen; i++)
1944 ar->c_where[i] = gfc_current_locus;
1951 /* Saves or restores a pointer. The pointer is converted back and
1952 forth from an integer. We return the pointer_info pointer so that
1953 the caller can take additional action based on the pointer type. */
1955 static pointer_info *
1956 mio_pointer_ref (void *gp)
1960 if (iomode == IO_OUTPUT)
1962 p = get_pointer (*((char **) gp));
1963 write_atom (ATOM_INTEGER, &p->integer);
1967 require_atom (ATOM_INTEGER);
1968 p = add_fixup (atom_int, gp);
1975 /* Save and load references to components that occur within
1976 expressions. We have to describe these references by a number and
1977 by name. The number is necessary for forward references during
1978 reading, and the name is necessary if the symbol already exists in
1979 the namespace and is not loaded again. */
1982 mio_component_ref (gfc_component **cp, gfc_symbol *sym)
1984 char name[GFC_MAX_SYMBOL_LEN + 1];
1988 p = mio_pointer_ref (cp);
1989 if (p->type == P_UNKNOWN)
1990 p->type = P_COMPONENT;
1992 if (iomode == IO_OUTPUT)
1993 mio_pool_string (&(*cp)->name);
1996 mio_internal_string (name);
1998 /* It can happen that a component reference can be read before the
1999 associated derived type symbol has been loaded. Return now and
2000 wait for a later iteration of load_needed. */
2004 if (sym->components != NULL && p->u.pointer == NULL)
2006 /* Symbol already loaded, so search by name. */
2007 for (q = sym->components; q; q = q->next)
2008 if (strcmp (q->name, name) == 0)
2012 gfc_internal_error ("mio_component_ref(): Component not found");
2014 associate_integer_pointer (p, q);
2017 /* Make sure this symbol will eventually be loaded. */
2018 p = find_pointer2 (sym);
2019 if (p->u.rsym.state == UNUSED)
2020 p->u.rsym.state = NEEDED;
2026 mio_component (gfc_component *c)
2033 if (iomode == IO_OUTPUT)
2035 p = get_pointer (c);
2036 mio_integer (&p->integer);
2041 p = get_integer (n);
2042 associate_integer_pointer (p, c);
2045 if (p->type == P_UNKNOWN)
2046 p->type = P_COMPONENT;
2048 mio_pool_string (&c->name);
2049 mio_typespec (&c->ts);
2050 mio_array_spec (&c->as);
2052 mio_integer (&c->dimension);
2053 mio_integer (&c->pointer);
2054 mio_integer (&c->allocatable);
2056 mio_expr (&c->initializer);
2062 mio_component_list (gfc_component **cp)
2064 gfc_component *c, *tail;
2068 if (iomode == IO_OUTPUT)
2070 for (c = *cp; c; c = c->next)
2080 if (peek_atom () == ATOM_RPAREN)
2083 c = gfc_get_component ();
2100 mio_actual_arg (gfc_actual_arglist *a)
2103 mio_pool_string (&a->name);
2104 mio_expr (&a->expr);
2110 mio_actual_arglist (gfc_actual_arglist **ap)
2112 gfc_actual_arglist *a, *tail;
2116 if (iomode == IO_OUTPUT)
2118 for (a = *ap; a; a = a->next)
2128 if (peek_atom () != ATOM_LPAREN)
2131 a = gfc_get_actual_arglist ();
2147 /* Read and write formal argument lists. */
2150 mio_formal_arglist (gfc_symbol *sym)
2152 gfc_formal_arglist *f, *tail;
2156 if (iomode == IO_OUTPUT)
2158 for (f = sym->formal; f; f = f->next)
2159 mio_symbol_ref (&f->sym);
2164 sym->formal = tail = NULL;
2166 while (peek_atom () != ATOM_RPAREN)
2168 f = gfc_get_formal_arglist ();
2169 mio_symbol_ref (&f->sym);
2171 if (sym->formal == NULL)
2184 /* Save or restore a reference to a symbol node. */
2187 mio_symbol_ref (gfc_symbol **symp)
2191 p = mio_pointer_ref (symp);
2192 if (p->type == P_UNKNOWN)
2195 if (iomode == IO_OUTPUT)
2197 if (p->u.wsym.state == UNREFERENCED)
2198 p->u.wsym.state = NEEDS_WRITE;
2202 if (p->u.rsym.state == UNUSED)
2203 p->u.rsym.state = NEEDED;
2208 /* Save or restore a reference to a symtree node. */
2211 mio_symtree_ref (gfc_symtree **stp)
2216 if (iomode == IO_OUTPUT)
2217 mio_symbol_ref (&(*stp)->n.sym);
2220 require_atom (ATOM_INTEGER);
2221 p = get_integer (atom_int);
2223 /* An unused equivalence member; bail out. */
2224 if (in_load_equiv && p->u.rsym.symtree == NULL)
2227 if (p->type == P_UNKNOWN)
2230 if (p->u.rsym.state == UNUSED)
2231 p->u.rsym.state = NEEDED;
2233 if (p->u.rsym.symtree != NULL)
2235 *stp = p->u.rsym.symtree;
2239 f = gfc_getmem (sizeof (fixup_t));
2241 f->next = p->u.rsym.stfixup;
2242 p->u.rsym.stfixup = f;
2244 f->pointer = (void **)stp;
2251 mio_iterator (gfc_iterator **ip)
2257 if (iomode == IO_OUTPUT)
2264 if (peek_atom () == ATOM_RPAREN)
2270 *ip = gfc_get_iterator ();
2275 mio_expr (&iter->var);
2276 mio_expr (&iter->start);
2277 mio_expr (&iter->end);
2278 mio_expr (&iter->step);
2286 mio_constructor (gfc_constructor **cp)
2288 gfc_constructor *c, *tail;
2292 if (iomode == IO_OUTPUT)
2294 for (c = *cp; c; c = c->next)
2297 mio_expr (&c->expr);
2298 mio_iterator (&c->iterator);
2307 while (peek_atom () != ATOM_RPAREN)
2309 c = gfc_get_constructor ();
2319 mio_expr (&c->expr);
2320 mio_iterator (&c->iterator);
2329 static const mstring ref_types[] = {
2330 minit ("ARRAY", REF_ARRAY),
2331 minit ("COMPONENT", REF_COMPONENT),
2332 minit ("SUBSTRING", REF_SUBSTRING),
2338 mio_ref (gfc_ref **rp)
2345 r->type = MIO_NAME (ref_type) (r->type, ref_types);
2350 mio_array_ref (&r->u.ar);
2354 mio_symbol_ref (&r->u.c.sym);
2355 mio_component_ref (&r->u.c.component, r->u.c.sym);
2359 mio_expr (&r->u.ss.start);
2360 mio_expr (&r->u.ss.end);
2361 mio_charlen (&r->u.ss.length);
2370 mio_ref_list (gfc_ref **rp)
2372 gfc_ref *ref, *head, *tail;
2376 if (iomode == IO_OUTPUT)
2378 for (ref = *rp; ref; ref = ref->next)
2385 while (peek_atom () != ATOM_RPAREN)
2388 head = tail = gfc_get_ref ();
2391 tail->next = gfc_get_ref ();
2405 /* Read and write an integer value. */
2408 mio_gmp_integer (mpz_t *integer)
2412 if (iomode == IO_INPUT)
2414 if (parse_atom () != ATOM_STRING)
2415 bad_module ("Expected integer string");
2417 mpz_init (*integer);
2418 if (mpz_set_str (*integer, atom_string, 10))
2419 bad_module ("Error converting integer");
2421 gfc_free (atom_string);
2425 p = mpz_get_str (NULL, 10, *integer);
2426 write_atom (ATOM_STRING, p);
2433 mio_gmp_real (mpfr_t *real)
2438 if (iomode == IO_INPUT)
2440 if (parse_atom () != ATOM_STRING)
2441 bad_module ("Expected real string");
2444 mpfr_set_str (*real, atom_string, 16, GFC_RND_MODE);
2445 gfc_free (atom_string);
2449 p = mpfr_get_str (NULL, &exponent, 16, 0, *real, GFC_RND_MODE);
2450 atom_string = gfc_getmem (strlen (p) + 20);
2452 sprintf (atom_string, "0.%s@%ld", p, exponent);
2454 /* Fix negative numbers. */
2455 if (atom_string[2] == '-')
2457 atom_string[0] = '-';
2458 atom_string[1] = '0';
2459 atom_string[2] = '.';
2462 write_atom (ATOM_STRING, atom_string);
2464 gfc_free (atom_string);
2470 /* Save and restore the shape of an array constructor. */
2473 mio_shape (mpz_t **pshape, int rank)
2479 /* A NULL shape is represented by (). */
2482 if (iomode == IO_OUTPUT)
2494 if (t == ATOM_RPAREN)
2501 shape = gfc_get_shape (rank);
2505 for (n = 0; n < rank; n++)
2506 mio_gmp_integer (&shape[n]);
2512 static const mstring expr_types[] = {
2513 minit ("OP", EXPR_OP),
2514 minit ("FUNCTION", EXPR_FUNCTION),
2515 minit ("CONSTANT", EXPR_CONSTANT),
2516 minit ("VARIABLE", EXPR_VARIABLE),
2517 minit ("SUBSTRING", EXPR_SUBSTRING),
2518 minit ("STRUCTURE", EXPR_STRUCTURE),
2519 minit ("ARRAY", EXPR_ARRAY),
2520 minit ("NULL", EXPR_NULL),
2524 /* INTRINSIC_ASSIGN is missing because it is used as an index for
2525 generic operators, not in expressions. INTRINSIC_USER is also
2526 replaced by the correct function name by the time we see it. */
2528 static const mstring intrinsics[] =
2530 minit ("UPLUS", INTRINSIC_UPLUS),
2531 minit ("UMINUS", INTRINSIC_UMINUS),
2532 minit ("PLUS", INTRINSIC_PLUS),
2533 minit ("MINUS", INTRINSIC_MINUS),
2534 minit ("TIMES", INTRINSIC_TIMES),
2535 minit ("DIVIDE", INTRINSIC_DIVIDE),
2536 minit ("POWER", INTRINSIC_POWER),
2537 minit ("CONCAT", INTRINSIC_CONCAT),
2538 minit ("AND", INTRINSIC_AND),
2539 minit ("OR", INTRINSIC_OR),
2540 minit ("EQV", INTRINSIC_EQV),
2541 minit ("NEQV", INTRINSIC_NEQV),
2542 minit ("EQ", INTRINSIC_EQ),
2543 minit ("NE", INTRINSIC_NE),
2544 minit ("GT", INTRINSIC_GT),
2545 minit ("GE", INTRINSIC_GE),
2546 minit ("LT", INTRINSIC_LT),
2547 minit ("LE", INTRINSIC_LE),
2548 minit ("NOT", INTRINSIC_NOT),
2549 minit ("PARENTHESES", INTRINSIC_PARENTHESES),
2554 /* Remedy a couple of situations where the gfc_expr's can be defective. */
2557 fix_mio_expr (gfc_expr *e)
2559 gfc_symtree *ns_st = NULL;
2562 if (iomode != IO_OUTPUT)
2567 /* If this is a symtree for a symbol that came from a contained module
2568 namespace, it has a unique name and we should look in the current
2569 namespace to see if the required, non-contained symbol is available
2570 yet. If so, the latter should be written. */
2571 if (e->symtree->n.sym && check_unique_name(e->symtree->name))
2572 ns_st = gfc_find_symtree (gfc_current_ns->sym_root,
2573 e->symtree->n.sym->name);
2575 /* On the other hand, if the existing symbol is the module name or the
2576 new symbol is a dummy argument, do not do the promotion. */
2577 if (ns_st && ns_st->n.sym
2578 && ns_st->n.sym->attr.flavor != FL_MODULE
2579 && !e->symtree->n.sym->attr.dummy)
2582 else if (e->expr_type == EXPR_FUNCTION && e->value.function.name)
2584 /* In some circumstances, a function used in an initialization
2585 expression, in one use associated module, can fail to be
2586 coupled to its symtree when used in a specification
2587 expression in another module. */
2588 fname = e->value.function.esym ? e->value.function.esym->name
2589 : e->value.function.isym->name;
2590 e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
2595 /* Read and write expressions. The form "()" is allowed to indicate a
2599 mio_expr (gfc_expr **ep)
2607 if (iomode == IO_OUTPUT)
2616 MIO_NAME (expr_t) (e->expr_type, expr_types);
2621 if (t == ATOM_RPAREN)
2628 bad_module ("Expected expression type");
2630 e = *ep = gfc_get_expr ();
2631 e->where = gfc_current_locus;
2632 e->expr_type = (expr_t) find_enum (expr_types);
2635 mio_typespec (&e->ts);
2636 mio_integer (&e->rank);
2640 switch (e->expr_type)
2643 e->value.op.operator
2644 = MIO_NAME (gfc_intrinsic_op) (e->value.op.operator, intrinsics);
2646 switch (e->value.op.operator)
2648 case INTRINSIC_UPLUS:
2649 case INTRINSIC_UMINUS:
2651 case INTRINSIC_PARENTHESES:
2652 mio_expr (&e->value.op.op1);
2655 case INTRINSIC_PLUS:
2656 case INTRINSIC_MINUS:
2657 case INTRINSIC_TIMES:
2658 case INTRINSIC_DIVIDE:
2659 case INTRINSIC_POWER:
2660 case INTRINSIC_CONCAT:
2664 case INTRINSIC_NEQV:
2671 mio_expr (&e->value.op.op1);
2672 mio_expr (&e->value.op.op2);
2676 bad_module ("Bad operator");
2682 mio_symtree_ref (&e->symtree);
2683 mio_actual_arglist (&e->value.function.actual);
2685 if (iomode == IO_OUTPUT)
2687 e->value.function.name
2688 = mio_allocated_string (e->value.function.name);
2689 flag = e->value.function.esym != NULL;
2690 mio_integer (&flag);
2692 mio_symbol_ref (&e->value.function.esym);
2694 write_atom (ATOM_STRING, e->value.function.isym->name);
2698 require_atom (ATOM_STRING);
2699 e->value.function.name = gfc_get_string (atom_string);
2700 gfc_free (atom_string);
2702 mio_integer (&flag);
2704 mio_symbol_ref (&e->value.function.esym);
2707 require_atom (ATOM_STRING);
2708 e->value.function.isym = gfc_find_function (atom_string);
2709 gfc_free (atom_string);
2716 mio_symtree_ref (&e->symtree);
2717 mio_ref_list (&e->ref);
2720 case EXPR_SUBSTRING:
2721 e->value.character.string
2722 = (char *) mio_allocated_string (e->value.character.string);
2723 mio_ref_list (&e->ref);
2726 case EXPR_STRUCTURE:
2728 mio_constructor (&e->value.constructor);
2729 mio_shape (&e->shape, e->rank);
2736 mio_gmp_integer (&e->value.integer);
2740 gfc_set_model_kind (e->ts.kind);
2741 mio_gmp_real (&e->value.real);
2745 gfc_set_model_kind (e->ts.kind);
2746 mio_gmp_real (&e->value.complex.r);
2747 mio_gmp_real (&e->value.complex.i);
2751 mio_integer (&e->value.logical);
2755 mio_integer (&e->value.character.length);
2756 e->value.character.string
2757 = (char *) mio_allocated_string (e->value.character.string);
2761 bad_module ("Bad type in constant expression");
2774 /* Read and write namelists */
2777 mio_namelist (gfc_symbol *sym)
2779 gfc_namelist *n, *m;
2780 const char *check_name;
2784 if (iomode == IO_OUTPUT)
2786 for (n = sym->namelist; n; n = n->next)
2787 mio_symbol_ref (&n->sym);
2791 /* This departure from the standard is flagged as an error.
2792 It does, in fact, work correctly. TODO: Allow it
2794 if (sym->attr.flavor == FL_NAMELIST)
2796 check_name = find_use_name (sym->name);
2797 if (check_name && strcmp (check_name, sym->name) != 0)
2798 gfc_error ("Namelist %s cannot be renamed by USE "
2799 "association to %s", sym->name, check_name);
2803 while (peek_atom () != ATOM_RPAREN)
2805 n = gfc_get_namelist ();
2806 mio_symbol_ref (&n->sym);
2808 if (sym->namelist == NULL)
2815 sym->namelist_tail = m;
2822 /* Save/restore lists of gfc_interface stuctures. When loading an
2823 interface, we are really appending to the existing list of
2824 interfaces. Checking for duplicate and ambiguous interfaces has to
2825 be done later when all symbols have been loaded. */
2828 mio_interface_rest (gfc_interface **ip)
2830 gfc_interface *tail, *p;
2832 if (iomode == IO_OUTPUT)
2835 for (p = *ip; p; p = p->next)
2836 mio_symbol_ref (&p->sym);
2851 if (peek_atom () == ATOM_RPAREN)
2854 p = gfc_get_interface ();
2855 p->where = gfc_current_locus;
2856 mio_symbol_ref (&p->sym);
2871 /* Save/restore a nameless operator interface. */
2874 mio_interface (gfc_interface **ip)
2877 mio_interface_rest (ip);
2881 /* Save/restore a named operator interface. */
2884 mio_symbol_interface (const char **name, const char **module,
2888 mio_pool_string (name);
2889 mio_pool_string (module);
2890 mio_interface_rest (ip);
2895 mio_namespace_ref (gfc_namespace **nsp)
2900 p = mio_pointer_ref (nsp);
2902 if (p->type == P_UNKNOWN)
2903 p->type = P_NAMESPACE;
2905 if (iomode == IO_INPUT && p->integer != 0)
2907 ns = (gfc_namespace *) p->u.pointer;
2910 ns = gfc_get_namespace (NULL, 0);
2911 associate_integer_pointer (p, ns);
2919 /* Unlike most other routines, the address of the symbol node is already
2920 fixed on input and the name/module has already been filled in. */
2923 mio_symbol (gfc_symbol *sym)
2925 gfc_formal_arglist *formal;
2929 mio_symbol_attribute (&sym->attr);
2930 mio_typespec (&sym->ts);
2932 /* Contained procedures don't have formal namespaces. Instead we output the
2933 procedure namespace. The will contain the formal arguments. */
2934 if (iomode == IO_OUTPUT)
2936 formal = sym->formal;
2937 while (formal && !formal->sym)
2938 formal = formal->next;
2941 mio_namespace_ref (&formal->sym->ns);
2943 mio_namespace_ref (&sym->formal_ns);
2947 mio_namespace_ref (&sym->formal_ns);
2950 sym->formal_ns->proc_name = sym;
2955 /* Save/restore common block links */
2956 mio_symbol_ref (&sym->common_next);
2958 mio_formal_arglist (sym);
2960 if (sym->attr.flavor == FL_PARAMETER)
2961 mio_expr (&sym->value);
2963 mio_array_spec (&sym->as);
2965 mio_symbol_ref (&sym->result);
2967 if (sym->attr.cray_pointee)
2968 mio_symbol_ref (&sym->cp_pointer);
2970 /* Note that components are always saved, even if they are supposed
2971 to be private. Component access is checked during searching. */
2973 mio_component_list (&sym->components);
2975 if (sym->components != NULL)
2976 sym->component_access
2977 = MIO_NAME (gfc_access) (sym->component_access, access_types);
2984 /************************* Top level subroutines *************************/
2986 /* Skip a list between balanced left and right parens. */
2996 switch (parse_atom ())
3007 gfc_free (atom_string);
3019 /* Load operator interfaces from the module. Interfaces are unusual
3020 in that they attach themselves to existing symbols. */
3023 load_operator_interfaces (void)
3026 char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
3031 while (peek_atom () != ATOM_RPAREN)
3035 mio_internal_string (name);
3036 mio_internal_string (module);
3038 /* Decide if we need to load this one or not. */
3039 p = find_use_name (name);
3042 while (parse_atom () != ATOM_RPAREN);
3046 uop = gfc_get_uop (p);
3047 mio_interface_rest (&uop->operator);
3055 /* Load interfaces from the module. Interfaces are unusual in that
3056 they attach themselves to existing symbols. */
3059 load_generic_interfaces (void)
3062 char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
3064 gfc_interface *generic = NULL;
3069 while (peek_atom () != ATOM_RPAREN)
3073 mio_internal_string (name);
3074 mio_internal_string (module);
3076 n = number_use_names (name);
3079 for (i = 1; i <= n; i++)
3081 /* Decide if we need to load this one or not. */
3082 p = find_use_name_n (name, &i);
3084 if (p == NULL || gfc_find_symbol (p, NULL, 0, &sym))
3086 while (parse_atom () != ATOM_RPAREN);
3092 gfc_get_symbol (p, NULL, &sym);
3094 sym->attr.flavor = FL_PROCEDURE;
3095 sym->attr.generic = 1;
3096 sym->attr.use_assoc = 1;
3100 /* Unless sym is a generic interface, this reference
3104 st = gfc_find_symtree (gfc_current_ns->sym_root, p);
3105 if (!sym->attr.generic
3106 && sym->module != NULL
3107 && strcmp(module, sym->module) != 0)
3112 mio_interface_rest (&sym->generic);
3113 generic = sym->generic;
3117 sym->generic = generic;
3118 sym->attr.generic_copy = 1;
3127 /* Load common blocks. */
3132 char name[GFC_MAX_SYMBOL_LEN + 1];
3137 while (peek_atom () != ATOM_RPAREN)
3141 mio_internal_string (name);
3143 p = gfc_get_common (name, 1);
3145 mio_symbol_ref (&p->head);
3146 mio_integer (&flags);
3150 p->threadprivate = 1;
3160 /* load_equiv()-- Load equivalences. The flag in_load_equiv informs
3161 mio_expr_ref of this so that unused variables are not loaded and
3162 so that the expression can be safely freed.*/
3167 gfc_equiv *head, *tail, *end, *eq;
3171 in_load_equiv = true;
3173 end = gfc_current_ns->equiv;
3174 while (end != NULL && end->next != NULL)
3177 while (peek_atom() != ATOM_RPAREN) {
3181 while(peek_atom () != ATOM_RPAREN)
3184 head = tail = gfc_get_equiv ();
3187 tail->eq = gfc_get_equiv ();
3191 mio_pool_string (&tail->module);
3192 mio_expr (&tail->expr);
3195 /* Unused variables have no symtree. */
3197 for (eq = head; eq; eq = eq->eq)
3199 if (!eq->expr->symtree)
3208 for (eq = head; eq; eq = head)
3211 gfc_free_expr (eq->expr);
3217 gfc_current_ns->equiv = head;
3228 in_load_equiv = false;
3231 /* Recursive function to traverse the pointer_info tree and load a
3232 needed symbol. We return nonzero if we load a symbol and stop the
3233 traversal, because the act of loading can alter the tree. */
3236 load_needed (pointer_info *p)
3247 rv |= load_needed (p->left);
3248 rv |= load_needed (p->right);
3250 if (p->type != P_SYMBOL || p->u.rsym.state != NEEDED)
3253 p->u.rsym.state = USED;
3255 set_module_locus (&p->u.rsym.where);
3257 sym = p->u.rsym.sym;
3260 q = get_integer (p->u.rsym.ns);
3262 ns = (gfc_namespace *) q->u.pointer;
3265 /* Create an interface namespace if necessary. These are
3266 the namespaces that hold the formal parameters of module
3269 ns = gfc_get_namespace (NULL, 0);
3270 associate_integer_pointer (q, ns);
3273 sym = gfc_new_symbol (p->u.rsym.true_name, ns);
3274 sym->module = gfc_get_string (p->u.rsym.module);
3276 associate_integer_pointer (p, sym);
3280 sym->attr.use_assoc = 1;
3282 sym->attr.use_only = 1;
3288 /* Recursive function for cleaning up things after a module has been
3292 read_cleanup (pointer_info *p)
3300 read_cleanup (p->left);
3301 read_cleanup (p->right);
3303 if (p->type == P_SYMBOL && p->u.rsym.state == USED && !p->u.rsym.referenced)
3305 /* Add hidden symbols to the symtree. */
3306 q = get_integer (p->u.rsym.ns);
3307 st = get_unique_symtree ((gfc_namespace *) q->u.pointer);
3309 st->n.sym = p->u.rsym.sym;
3312 /* Fixup any symtree references. */
3313 p->u.rsym.symtree = st;
3314 resolve_fixups (p->u.rsym.stfixup, st);
3315 p->u.rsym.stfixup = NULL;
3318 /* Free unused symbols. */
3319 if (p->type == P_SYMBOL && p->u.rsym.state == UNUSED)
3320 gfc_free_symbol (p->u.rsym.sym);
3324 /* Given a root symtree node and a symbol, try to find a symtree that
3325 references the symbol that is not a unique name. */
3327 static gfc_symtree *
3328 find_symtree_for_symbol (gfc_symtree *st, gfc_symbol *sym)
3330 gfc_symtree *s = NULL;
3335 s = find_symtree_for_symbol (st->right, sym);
3338 s = find_symtree_for_symbol (st->left, sym);
3342 if (st->n.sym == sym && !check_unique_name (st->name))
3349 /* Read a module file. */
3354 module_locus operator_interfaces, user_operators;
3356 char name[GFC_MAX_SYMBOL_LEN + 1];
3358 int ambiguous, j, nuse, symbol;
3359 pointer_info *info, *q;
3364 get_module_locus (&operator_interfaces); /* Skip these for now */
3367 get_module_locus (&user_operators);
3371 /* Skip commons and equivalences for now. */
3377 /* Create the fixup nodes for all the symbols. */
3379 while (peek_atom () != ATOM_RPAREN)
3381 require_atom (ATOM_INTEGER);
3382 info = get_integer (atom_int);
3384 info->type = P_SYMBOL;
3385 info->u.rsym.state = UNUSED;
3387 mio_internal_string (info->u.rsym.true_name);
3388 mio_internal_string (info->u.rsym.module);
3390 require_atom (ATOM_INTEGER);
3391 info->u.rsym.ns = atom_int;
3393 get_module_locus (&info->u.rsym.where);
3396 /* See if the symbol has already been loaded by a previous module.
3397 If so, we reference the existing symbol and prevent it from
3398 being loaded again. This should not happen if the symbol being
3399 read is an index for an assumed shape dummy array (ns != 1). */
3401 sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module);
3404 || (sym->attr.flavor == FL_VARIABLE && info->u.rsym.ns !=1))
3407 info->u.rsym.state = USED;
3408 info->u.rsym.sym = sym;
3410 /* Some symbols do not have a namespace (eg. formal arguments),
3411 so the automatic "unique symtree" mechanism must be suppressed
3412 by marking them as referenced. */
3413 q = get_integer (info->u.rsym.ns);
3414 if (q->u.pointer == NULL)
3416 info->u.rsym.referenced = 1;
3420 /* If possible recycle the symtree that references the symbol.
3421 If a symtree is not found and the module does not import one,
3422 a unique-name symtree is found by read_cleanup. */
3423 st = find_symtree_for_symbol (gfc_current_ns->sym_root, sym);
3426 info->u.rsym.symtree = st;
3427 info->u.rsym.referenced = 1;
3433 /* Parse the symtree lists. This lets us mark which symbols need to
3434 be loaded. Renaming is also done at this point by replacing the
3439 while (peek_atom () != ATOM_RPAREN)
3441 mio_internal_string (name);
3442 mio_integer (&ambiguous);
3443 mio_integer (&symbol);
3445 info = get_integer (symbol);
3447 /* See how many use names there are. If none, go through the start
3448 of the loop at least once. */
3449 nuse = number_use_names (name);
3453 for (j = 1; j <= nuse; j++)
3455 /* Get the jth local name for this symbol. */
3456 p = find_use_name_n (name, &j);
3458 if (p == NULL && strcmp (name, module_name) == 0)
3461 /* Skip symtree nodes not in an ONLY clause, unless there
3462 is an existing symtree loaded from another USE
3466 st = gfc_find_symtree (gfc_current_ns->sym_root, name);
3468 info->u.rsym.symtree = st;
3472 st = gfc_find_symtree (gfc_current_ns->sym_root, p);
3476 /* Check for ambiguous symbols. */
3477 if (st->n.sym != info->u.rsym.sym)
3479 info->u.rsym.symtree = st;
3483 /* Create a symtree node in the current namespace for this
3485 st = check_unique_name (p)
3486 ? get_unique_symtree (gfc_current_ns)
3487 : gfc_new_symtree (&gfc_current_ns->sym_root, p);
3489 st->ambiguous = ambiguous;
3491 sym = info->u.rsym.sym;
3493 /* Create a symbol node if it doesn't already exist. */
3496 info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name,
3498 sym = info->u.rsym.sym;
3499 sym->module = gfc_get_string (info->u.rsym.module);
3505 /* Store the symtree pointing to this symbol. */
3506 info->u.rsym.symtree = st;
3508 if (info->u.rsym.state == UNUSED)
3509 info->u.rsym.state = NEEDED;
3510 info->u.rsym.referenced = 1;
3517 /* Load intrinsic operator interfaces. */
3518 set_module_locus (&operator_interfaces);
3521 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3523 if (i == INTRINSIC_USER)
3528 u = find_use_operator (i);
3539 mio_interface (&gfc_current_ns->operator[i]);
3544 /* Load generic and user operator interfaces. These must follow the
3545 loading of symtree because otherwise symbols can be marked as
3548 set_module_locus (&user_operators);
3550 load_operator_interfaces ();
3551 load_generic_interfaces ();
3556 /* At this point, we read those symbols that are needed but haven't
3557 been loaded yet. If one symbol requires another, the other gets
3558 marked as NEEDED if its previous state was UNUSED. */
3560 while (load_needed (pi_root));
3562 /* Make sure all elements of the rename-list were found in the module. */
3564 for (u = gfc_rename_list; u; u = u->next)
3569 if (u->operator == INTRINSIC_NONE)
3571 gfc_error ("Symbol '%s' referenced at %L not found in module '%s'",
3572 u->use_name, &u->where, module_name);
3576 if (u->operator == INTRINSIC_USER)
3578 gfc_error ("User operator '%s' referenced at %L not found "
3579 "in module '%s'", u->use_name, &u->where, module_name);
3583 gfc_error ("Intrinsic operator '%s' referenced at %L not found "
3584 "in module '%s'", gfc_op2string (u->operator), &u->where,
3588 gfc_check_interfaces (gfc_current_ns);
3590 /* Clean up symbol nodes that were never loaded, create references
3591 to hidden symbols. */
3593 read_cleanup (pi_root);
3597 /* Given an access type that is specific to an entity and the default
3598 access, return nonzero if the entity is publicly accessible. If the
3599 element is declared as PUBLIC, then it is public; if declared
3600 PRIVATE, then private, and otherwise it is public unless the default
3601 access in this context has been declared PRIVATE. */
3604 gfc_check_access (gfc_access specific_access, gfc_access default_access)
3606 if (specific_access == ACCESS_PUBLIC)
3608 if (specific_access == ACCESS_PRIVATE)
3611 return default_access != ACCESS_PRIVATE;
3615 /* Write a common block to the module */
3618 write_common (gfc_symtree *st)
3627 write_common (st->left);
3628 write_common (st->right);
3632 /* Write the unmangled name. */
3633 name = st->n.common->name;
3635 mio_pool_string (&name);
3638 mio_symbol_ref (&p->head);
3639 flags = p->saved ? 1 : 0;
3640 if (p->threadprivate) flags |= 2;
3641 mio_integer (&flags);
3646 /* Write the blank common block to the module */
3649 write_blank_common (void)
3651 const char * name = BLANK_COMMON_NAME;
3654 if (gfc_current_ns->blank_common.head == NULL)
3659 mio_pool_string (&name);
3661 mio_symbol_ref (&gfc_current_ns->blank_common.head);
3662 saved = gfc_current_ns->blank_common.saved;
3663 mio_integer (&saved);
3669 /* Write equivalences to the module. */
3678 for (eq = gfc_current_ns->equiv; eq; eq = eq->next)
3682 for (e = eq; e; e = e->eq)
3684 if (e->module == NULL)
3685 e->module = gfc_get_string ("%s.eq.%d", module_name, num);
3686 mio_allocated_string (e->module);
3687 mio_expr (&e->expr);
3696 /* Write a symbol to the module. */
3699 write_symbol (int n, gfc_symbol *sym)
3702 if (sym->attr.flavor == FL_UNKNOWN || sym->attr.flavor == FL_LABEL)
3703 gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym->name);
3706 mio_pool_string (&sym->name);
3708 mio_pool_string (&sym->module);
3709 mio_pointer_ref (&sym->ns);
3716 /* Recursive traversal function to write the initial set of symbols to
3717 the module. We check to see if the symbol should be written
3718 according to the access specification. */
3721 write_symbol0 (gfc_symtree *st)
3729 write_symbol0 (st->left);
3730 write_symbol0 (st->right);
3733 if (sym->module == NULL)
3734 sym->module = gfc_get_string (module_name);
3736 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
3737 && !sym->attr.subroutine && !sym->attr.function)
3740 if (!gfc_check_access (sym->attr.access, sym->ns->default_access))
3743 p = get_pointer (sym);
3744 if (p->type == P_UNKNOWN)
3747 if (p->u.wsym.state == WRITTEN)
3750 write_symbol (p->integer, sym);
3751 p->u.wsym.state = WRITTEN;
3757 /* Recursive traversal function to write the secondary set of symbols
3758 to the module file. These are symbols that were not public yet are
3759 needed by the public symbols or another dependent symbol. The act
3760 of writing a symbol can modify the pointer_info tree, so we cease
3761 traversal if we find a symbol to write. We return nonzero if a
3762 symbol was written and pass that information upwards. */
3765 write_symbol1 (pointer_info *p)
3770 if (write_symbol1 (p->left))
3772 if (write_symbol1 (p->right))
3775 if (p->type != P_SYMBOL || p->u.wsym.state != NEEDS_WRITE)
3778 p->u.wsym.state = WRITTEN;
3779 write_symbol (p->integer, p->u.wsym.sym);
3785 /* Write operator interfaces associated with a symbol. */
3788 write_operator (gfc_user_op *uop)
3790 static char nullstring[] = "";
3791 const char *p = nullstring;
3793 if (uop->operator == NULL
3794 || !gfc_check_access (uop->access, uop->ns->default_access))
3797 mio_symbol_interface (&uop->name, &p, &uop->operator);
3801 /* Write generic interfaces associated with a symbol. */
3804 write_generic (gfc_symbol *sym)
3806 if (sym->generic == NULL
3807 || !gfc_check_access (sym->attr.access, sym->ns->default_access))
3810 if (sym->module == NULL)
3811 sym->module = gfc_get_string (module_name);
3813 mio_symbol_interface (&sym->name, &sym->module, &sym->generic);
3818 write_symtree (gfc_symtree *st)
3824 if (!gfc_check_access (sym->attr.access, sym->ns->default_access)
3825 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
3826 && !sym->attr.subroutine && !sym->attr.function))
3829 if (check_unique_name (st->name))
3832 p = find_pointer (sym);
3834 gfc_internal_error ("write_symtree(): Symbol not written");
3836 mio_pool_string (&st->name);
3837 mio_integer (&st->ambiguous);
3838 mio_integer (&p->integer);
3847 /* Write the operator interfaces. */
3850 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3852 if (i == INTRINSIC_USER)
3855 mio_interface (gfc_check_access (gfc_current_ns->operator_access[i],
3856 gfc_current_ns->default_access)
3857 ? &gfc_current_ns->operator[i] : NULL);
3865 gfc_traverse_user_op (gfc_current_ns, write_operator);
3871 gfc_traverse_ns (gfc_current_ns, write_generic);
3877 write_blank_common ();
3878 write_common (gfc_current_ns->common_root);
3889 /* Write symbol information. First we traverse all symbols in the
3890 primary namespace, writing those that need to be written.
3891 Sometimes writing one symbol will cause another to need to be
3892 written. A list of these symbols ends up on the write stack, and
3893 we end by popping the bottom of the stack and writing the symbol
3894 until the stack is empty. */
3898 write_symbol0 (gfc_current_ns->sym_root);
3899 while (write_symbol1 (pi_root));
3907 gfc_traverse_symtree (gfc_current_ns->sym_root, write_symtree);
3912 /* Given module, dump it to disk. If there was an error while
3913 processing the module, dump_flag will be set to zero and we delete
3914 the module file, even if it was already there. */
3917 gfc_dump_module (const char *name, int dump_flag)
3923 n = strlen (name) + strlen (MODULE_EXTENSION) + 1;
3924 if (gfc_option.module_dir != NULL)
3926 filename = (char *) alloca (n + strlen (gfc_option.module_dir));
3927 strcpy (filename, gfc_option.module_dir);
3928 strcat (filename, name);
3932 filename = (char *) alloca (n);
3933 strcpy (filename, name);
3935 strcat (filename, MODULE_EXTENSION);
3943 module_fp = fopen (filename, "w");
3944 if (module_fp == NULL)
3945 gfc_fatal_error ("Can't open module file '%s' for writing at %C: %s",
3946 filename, strerror (errno));
3951 *strchr (p, '\n') = '\0';
3953 fprintf (module_fp, "GFORTRAN module created from %s on %s\n",
3954 gfc_source_file, p);
3955 fputs ("If you edit this, you'll get what you deserve.\n\n", module_fp);
3958 strcpy (module_name, name);
3964 free_pi_tree (pi_root);
3969 if (fclose (module_fp))
3970 gfc_fatal_error ("Error writing module file '%s' for writing: %s",
3971 filename, strerror (errno));
3975 /* Add an integer named constant from a given module. */
3977 create_int_parameter (const char *name, int value, const char *modname)
3979 gfc_symtree *tmp_symtree;
3982 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
3983 if (tmp_symtree != NULL)
3985 if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
3988 gfc_error ("Symbol '%s' already declared", name);
3991 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree);
3992 sym = tmp_symtree->n.sym;
3994 sym->module = gfc_get_string (modname);
3995 sym->attr.flavor = FL_PARAMETER;
3996 sym->ts.type = BT_INTEGER;
3997 sym->ts.kind = gfc_default_integer_kind;
3998 sym->value = gfc_int_expr (value);
3999 sym->attr.use_assoc = 1;
4003 /* USE the ISO_FORTRAN_ENV intrinsic module. */
4006 use_iso_fortran_env_module (void)
4008 static char mod[] = "iso_fortran_env";
4009 const char *local_name;
4011 gfc_symbol *mod_sym;
4012 gfc_symtree *mod_symtree;
4015 mstring symbol[] = {
4016 #define NAMED_INTCST(a,b,c) minit(b,0),
4017 #include "iso-fortran-env.def"
4019 minit (NULL, -1234) };
4022 #define NAMED_INTCST(a,b,c) symbol[i++].tag = c;
4023 #include "iso-fortran-env.def"
4026 /* Generate the symbol for the module itself. */
4027 mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, mod);
4028 if (mod_symtree == NULL)
4030 gfc_get_sym_tree (mod, gfc_current_ns, &mod_symtree);
4031 gcc_assert (mod_symtree);
4032 mod_sym = mod_symtree->n.sym;
4034 mod_sym->attr.flavor = FL_MODULE;
4035 mod_sym->attr.intrinsic = 1;
4036 mod_sym->module = gfc_get_string (mod);
4039 if (!mod_symtree->n.sym->attr.intrinsic)
4040 gfc_error ("Use of intrinsic module '%s' at %C conflicts with "
4041 "non-intrinsic module name used previously", mod);
4043 /* Generate the symbols for the module integer named constants. */
4045 for (u = gfc_rename_list; u; u = u->next)
4047 for (i = 0; symbol[i].string; i++)
4048 if (strcmp (symbol[i].string, u->use_name) == 0)
4051 if (symbol[i].string == NULL)
4053 gfc_error ("Symbol '%s' referenced at %L does not exist in "
4054 "intrinsic module ISO_FORTRAN_ENV", u->use_name,
4059 if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
4060 && strcmp (symbol[i].string, "numeric_storage_size") == 0)
4061 gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
4062 "from intrinsic module ISO_FORTRAN_ENV at %L is "
4063 "incompatible with option %s", &u->where,
4064 gfc_option.flag_default_integer
4065 ? "-fdefault-integer-8" : "-fdefault-real-8");
4067 create_int_parameter (u->local_name[0] ? u->local_name
4069 symbol[i].tag, mod);
4073 for (i = 0; symbol[i].string; i++)
4076 for (u = gfc_rename_list; u; u = u->next)
4078 if (strcmp (symbol[i].string, u->use_name) == 0)
4080 local_name = u->local_name;
4086 if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
4087 && strcmp (symbol[i].string, "numeric_storage_size") == 0)
4088 gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
4089 "from intrinsic module ISO_FORTRAN_ENV at %C is "
4090 "incompatible with option %s",
4091 gfc_option.flag_default_integer
4092 ? "-fdefault-integer-8" : "-fdefault-real-8");
4094 create_int_parameter (local_name ? local_name : symbol[i].string,
4095 symbol[i].tag, mod);
4098 for (u = gfc_rename_list; u; u = u->next)
4103 gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
4104 "module ISO_FORTRAN_ENV", u->use_name, &u->where);
4110 /* Process a USE directive. */
4113 gfc_use_module (void)
4118 gfc_symtree *mod_symtree;
4120 filename = (char *) alloca (strlen (module_name) + strlen (MODULE_EXTENSION)
4122 strcpy (filename, module_name);
4123 strcat (filename, MODULE_EXTENSION);
4125 /* First, try to find an non-intrinsic module, unless the USE statement
4126 specified that the module is intrinsic. */
4129 module_fp = gfc_open_included_file (filename, true, true);
4131 /* Then, see if it's an intrinsic one, unless the USE statement
4132 specified that the module is non-intrinsic. */
4133 if (module_fp == NULL && !specified_nonint)
4135 if (strcmp (module_name, "iso_fortran_env") == 0
4136 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ISO_FORTRAN_ENV "
4137 "intrinsic module at %C") != FAILURE)
4139 use_iso_fortran_env_module ();
4143 module_fp = gfc_open_intrinsic_module (filename);
4145 if (module_fp == NULL && specified_int)
4146 gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C",
4150 if (module_fp == NULL)
4151 gfc_fatal_error ("Can't open module file '%s' for reading at %C: %s",
4152 filename, strerror (errno));
4154 /* Check that we haven't already USEd an intrinsic module with the
4157 mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, module_name);
4158 if (mod_symtree && mod_symtree->n.sym->attr.intrinsic)
4159 gfc_error ("Use of non-intrinsic module '%s' at %C conflicts with "
4160 "intrinsic module name used previously", module_name);
4167 /* Skip the first two lines of the module, after checking that this is
4168 a gfortran module file. */
4174 bad_module ("Unexpected end of module");
4177 if ((start == 1 && strcmp (atom_name, "GFORTRAN") != 0)
4178 || (start == 2 && strcmp (atom_name, " module") != 0))
4179 gfc_fatal_error ("File '%s' opened at %C is not a GFORTRAN module "
4186 /* Make sure we're not reading the same module that we may be building. */
4187 for (p = gfc_state_stack; p; p = p->previous)
4188 if (p->state == COMP_MODULE && strcmp (p->sym->name, module_name) == 0)
4189 gfc_fatal_error ("Can't USE the same module we're building!");
4192 init_true_name_tree ();
4196 free_true_name (true_name_root);
4197 true_name_root = NULL;
4199 free_pi_tree (pi_root);
4207 gfc_module_init_2 (void)
4209 last_atom = ATOM_LPAREN;
4214 gfc_module_done_2 (void)