1 /* Handle modules, which amounts to loading and saving symbols and
2 their attendant structures.
3 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
4 Free Software Foundation, Inc.
5 Contributed by Andy Vaught
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* The syntax of gfortran modules resembles that of lisp lists, ie a
24 sequence of atoms, which can be left or right parenthesis, names,
25 integers or strings. Parenthesis are always matched which allows
26 us to skip over sections at high speed without having to know
27 anything about the internal structure of the lists. A "name" is
28 usually a fortran 95 identifier, but can also start with '@' in
29 order to reference a hidden symbol.
31 The first line of a module is an informational message about what
32 created the module, the file it came from and when it was created.
33 The second line is a warning for people not to edit the module.
34 The rest of the module looks like:
36 ( ( <Interface info for UPLUS> )
37 ( <Interface info for UMINUS> )
40 ( ( <name of operator interface> <module of op interface> <i/f1> ... )
43 ( ( <name of generic interface> <module of generic interface> <i/f1> ... )
46 ( ( <common name> <symbol> <saved flag>)
52 ( <Symbol Number (in no particular order)>
54 <Module name of symbol>
55 ( <symbol information> )
64 In general, symbols refer to other symbols by their symbol number,
65 which are zero based. Symbols are written to the module in no
73 #include "parse.h" /* FIXME */
76 #define MODULE_EXTENSION ".mod"
79 /* Structure that describes a position within a module file. */
88 /* Structure for list of symbols of intrinsic modules. */
100 P_UNKNOWN = 0, P_OTHER, P_NAMESPACE, P_COMPONENT, P_SYMBOL
104 /* The fixup structure lists pointers to pointers that have to
105 be updated when a pointer value becomes known. */
107 typedef struct fixup_t
110 struct fixup_t *next;
115 /* Structure for holding extra info needed for pointers being read. */
117 typedef struct pointer_info
119 BBT_HEADER (pointer_info);
123 /* The first component of each member of the union is the pointer
130 void *pointer; /* Member for doing pointer searches. */
135 char true_name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
137 { UNUSED, NEEDED, USED }
142 gfc_symtree *symtree;
143 char binding_label[GFC_MAX_SYMBOL_LEN + 1];
151 { UNREFERENCED = 0, NEEDS_WRITE, WRITTEN }
161 #define gfc_get_pointer_info() gfc_getmem(sizeof(pointer_info))
164 /* Lists of rename info for the USE statement. */
166 typedef struct gfc_use_rename
168 char local_name[GFC_MAX_SYMBOL_LEN + 1], use_name[GFC_MAX_SYMBOL_LEN + 1];
169 struct gfc_use_rename *next;
171 gfc_intrinsic_op operator;
176 #define gfc_get_use_rename() gfc_getmem(sizeof(gfc_use_rename))
178 /* Local variables */
180 /* The FILE for the module we're reading or writing. */
181 static FILE *module_fp;
183 /* MD5 context structure. */
184 static struct md5_ctx ctx;
186 /* The name of the module we're reading (USE'ing) or writing. */
187 static char module_name[GFC_MAX_SYMBOL_LEN + 1];
189 /* The way the module we're reading was specified. */
190 static bool specified_nonint, specified_int;
192 static int module_line, module_column, only_flag;
194 { IO_INPUT, IO_OUTPUT }
197 static gfc_use_rename *gfc_rename_list;
198 static pointer_info *pi_root;
199 static int symbol_number; /* Counter for assigning symbol numbers */
201 /* Tells mio_expr_ref to make symbols for unused equivalence members. */
202 static bool in_load_equiv;
206 /*****************************************************************/
208 /* Pointer/integer conversion. Pointers between structures are stored
209 as integers in the module file. The next couple of subroutines
210 handle this translation for reading and writing. */
212 /* Recursively free the tree of pointer structures. */
215 free_pi_tree (pointer_info *p)
220 if (p->fixup != NULL)
221 gfc_internal_error ("free_pi_tree(): Unresolved fixup");
223 free_pi_tree (p->left);
224 free_pi_tree (p->right);
230 /* Compare pointers when searching by pointer. Used when writing a
234 compare_pointers (void *_sn1, void *_sn2)
236 pointer_info *sn1, *sn2;
238 sn1 = (pointer_info *) _sn1;
239 sn2 = (pointer_info *) _sn2;
241 if (sn1->u.pointer < sn2->u.pointer)
243 if (sn1->u.pointer > sn2->u.pointer)
250 /* Compare integers when searching by integer. Used when reading a
254 compare_integers (void *_sn1, void *_sn2)
256 pointer_info *sn1, *sn2;
258 sn1 = (pointer_info *) _sn1;
259 sn2 = (pointer_info *) _sn2;
261 if (sn1->integer < sn2->integer)
263 if (sn1->integer > sn2->integer)
270 /* Initialize the pointer_info tree. */
279 compare = (iomode == IO_INPUT) ? compare_integers : compare_pointers;
281 /* Pointer 0 is the NULL pointer. */
282 p = gfc_get_pointer_info ();
287 gfc_insert_bbt (&pi_root, p, compare);
289 /* Pointer 1 is the current namespace. */
290 p = gfc_get_pointer_info ();
291 p->u.pointer = gfc_current_ns;
293 p->type = P_NAMESPACE;
295 gfc_insert_bbt (&pi_root, p, compare);
301 /* During module writing, call here with a pointer to something,
302 returning the pointer_info node. */
304 static pointer_info *
305 find_pointer (void *gp)
312 if (p->u.pointer == gp)
314 p = (gp < p->u.pointer) ? p->left : p->right;
321 /* Given a pointer while writing, returns the pointer_info tree node,
322 creating it if it doesn't exist. */
324 static pointer_info *
325 get_pointer (void *gp)
329 p = find_pointer (gp);
333 /* Pointer doesn't have an integer. Give it one. */
334 p = gfc_get_pointer_info ();
337 p->integer = symbol_number++;
339 gfc_insert_bbt (&pi_root, p, compare_pointers);
345 /* Given an integer during reading, find it in the pointer_info tree,
346 creating the node if not found. */
348 static pointer_info *
349 get_integer (int integer)
359 c = compare_integers (&t, p);
363 p = (c < 0) ? p->left : p->right;
369 p = gfc_get_pointer_info ();
370 p->integer = integer;
373 gfc_insert_bbt (&pi_root, p, compare_integers);
379 /* Recursive function to find a pointer within a tree by brute force. */
381 static pointer_info *
382 fp2 (pointer_info *p, const void *target)
389 if (p->u.pointer == target)
392 q = fp2 (p->left, target);
396 return fp2 (p->right, target);
400 /* During reading, find a pointer_info node from the pointer value.
401 This amounts to a brute-force search. */
403 static pointer_info *
404 find_pointer2 (void *p)
406 return fp2 (pi_root, p);
410 /* Resolve any fixups using a known pointer. */
413 resolve_fixups (fixup_t *f, void *gp)
426 /* Call here during module reading when we know what pointer to
427 associate with an integer. Any fixups that exist are resolved at
431 associate_integer_pointer (pointer_info *p, void *gp)
433 if (p->u.pointer != NULL)
434 gfc_internal_error ("associate_integer_pointer(): Already associated");
438 resolve_fixups (p->fixup, gp);
444 /* During module reading, given an integer and a pointer to a pointer,
445 either store the pointer from an already-known value or create a
446 fixup structure in order to store things later. Returns zero if
447 the reference has been actually stored, or nonzero if the reference
448 must be fixed later (ie associate_integer_pointer must be called
449 sometime later. Returns the pointer_info structure. */
451 static pointer_info *
452 add_fixup (int integer, void *gp)
458 p = get_integer (integer);
460 if (p->integer == 0 || p->u.pointer != NULL)
467 f = gfc_getmem (sizeof (fixup_t));
479 /*****************************************************************/
481 /* Parser related subroutines */
483 /* Free the rename list left behind by a USE statement. */
488 gfc_use_rename *next;
490 for (; gfc_rename_list; gfc_rename_list = next)
492 next = gfc_rename_list->next;
493 gfc_free (gfc_rename_list);
498 /* Match a USE statement. */
503 char name[GFC_MAX_SYMBOL_LEN + 1], module_nature[GFC_MAX_SYMBOL_LEN + 1];
504 gfc_use_rename *tail = NULL, *new;
505 interface_type type, type2;
506 gfc_intrinsic_op operator;
509 specified_int = false;
510 specified_nonint = false;
512 if (gfc_match (" , ") == MATCH_YES)
514 if ((m = gfc_match (" %n ::", module_nature)) == MATCH_YES)
516 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: module "
517 "nature in USE statement at %C") == FAILURE)
520 if (strcmp (module_nature, "intrinsic") == 0)
521 specified_int = true;
524 if (strcmp (module_nature, "non_intrinsic") == 0)
525 specified_nonint = true;
528 gfc_error ("Module nature in USE statement at %C shall "
529 "be either INTRINSIC or NON_INTRINSIC");
536 /* Help output a better error message than "Unclassifiable
538 gfc_match (" %n", module_nature);
539 if (strcmp (module_nature, "intrinsic") == 0
540 || strcmp (module_nature, "non_intrinsic") == 0)
541 gfc_error ("\"::\" was expected after module nature at %C "
542 "but was not found");
548 m = gfc_match (" ::");
549 if (m == MATCH_YES &&
550 gfc_notify_std (GFC_STD_F2003, "Fortran 2003: "
551 "\"USE :: module\" at %C") == FAILURE)
556 m = gfc_match ("% ");
562 m = gfc_match_name (module_name);
569 if (gfc_match_eos () == MATCH_YES)
571 if (gfc_match_char (',') != MATCH_YES)
574 if (gfc_match (" only :") == MATCH_YES)
577 if (gfc_match_eos () == MATCH_YES)
582 /* Get a new rename struct and add it to the rename list. */
583 new = gfc_get_use_rename ();
584 new->where = gfc_current_locus;
587 if (gfc_rename_list == NULL)
588 gfc_rename_list = new;
593 /* See what kind of interface we're dealing with. Assume it is
595 new->operator = INTRINSIC_NONE;
596 if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
601 case INTERFACE_NAMELESS:
602 gfc_error ("Missing generic specification in USE statement at %C");
605 case INTERFACE_USER_OP:
606 case INTERFACE_GENERIC:
607 m = gfc_match (" =>");
609 if (type == INTERFACE_USER_OP && m == MATCH_YES
610 && (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Renaming "
611 "operators in USE statements at %C")
618 strcpy (new->use_name, name);
621 strcpy (new->local_name, name);
622 m = gfc_match_generic_spec (&type2, new->use_name, &operator);
627 if (m == MATCH_ERROR)
635 strcpy (new->local_name, name);
637 m = gfc_match_generic_spec (&type2, new->use_name, &operator);
642 if (m == MATCH_ERROR)
646 if (strcmp (new->use_name, module_name) == 0
647 || strcmp (new->local_name, module_name) == 0)
649 gfc_error ("The name '%s' at %C has already been used as "
650 "an external module name.", module_name);
655 case INTERFACE_INTRINSIC_OP:
656 new->operator = operator;
660 if (gfc_match_eos () == MATCH_YES)
662 if (gfc_match_char (',') != MATCH_YES)
669 gfc_syntax_error (ST_USE);
677 /* Given a name and a number, inst, return the inst name
678 under which to load this symbol. Returns NULL if this
679 symbol shouldn't be loaded. If inst is zero, returns
680 the number of instances of this name. */
683 find_use_name_n (const char *name, int *inst)
689 for (u = gfc_rename_list; u; u = u->next)
691 if (strcmp (u->use_name, name) != 0)
704 return only_flag ? NULL : name;
708 return (u->local_name[0] != '\0') ? u->local_name : name;
712 /* Given a name, return the name under which to load this symbol.
713 Returns NULL if this symbol shouldn't be loaded. */
716 find_use_name (const char *name)
719 return find_use_name_n (name, &i);
723 /* Given a real name, return the number of use names associated with it. */
726 number_use_names (const char *name)
730 c = find_use_name_n (name, &i);
735 /* Try to find the operator in the current list. */
737 static gfc_use_rename *
738 find_use_operator (gfc_intrinsic_op operator)
742 for (u = gfc_rename_list; u; u = u->next)
743 if (u->operator == operator)
750 /*****************************************************************/
752 /* The next couple of subroutines maintain a tree used to avoid a
753 brute-force search for a combination of true name and module name.
754 While symtree names, the name that a particular symbol is known by
755 can changed with USE statements, we still have to keep track of the
756 true names to generate the correct reference, and also avoid
757 loading the same real symbol twice in a program unit.
759 When we start reading, the true name tree is built and maintained
760 as symbols are read. The tree is searched as we load new symbols
761 to see if it already exists someplace in the namespace. */
763 typedef struct true_name
765 BBT_HEADER (true_name);
770 static true_name *true_name_root;
773 /* Compare two true_name structures. */
776 compare_true_names (void *_t1, void *_t2)
781 t1 = (true_name *) _t1;
782 t2 = (true_name *) _t2;
784 c = ((t1->sym->module > t2->sym->module)
785 - (t1->sym->module < t2->sym->module));
789 return strcmp (t1->sym->name, t2->sym->name);
793 /* Given a true name, search the true name tree to see if it exists
794 within the main namespace. */
797 find_true_name (const char *name, const char *module)
803 sym.name = gfc_get_string (name);
805 sym.module = gfc_get_string (module);
813 c = compare_true_names ((void *) (&t), (void *) p);
817 p = (c < 0) ? p->left : p->right;
824 /* Given a gfc_symbol pointer that is not in the true name tree, add it. */
827 add_true_name (gfc_symbol *sym)
831 t = gfc_getmem (sizeof (true_name));
834 gfc_insert_bbt (&true_name_root, t, compare_true_names);
838 /* Recursive function to build the initial true name tree by
839 recursively traversing the current namespace. */
842 build_tnt (gfc_symtree *st)
847 build_tnt (st->left);
848 build_tnt (st->right);
850 if (find_true_name (st->n.sym->name, st->n.sym->module) != NULL)
853 add_true_name (st->n.sym);
857 /* Initialize the true name tree with the current namespace. */
860 init_true_name_tree (void)
862 true_name_root = NULL;
863 build_tnt (gfc_current_ns->sym_root);
867 /* Recursively free a true name tree node. */
870 free_true_name (true_name *t)
874 free_true_name (t->left);
875 free_true_name (t->right);
881 /*****************************************************************/
883 /* Module reading and writing. */
887 ATOM_NAME, ATOM_LPAREN, ATOM_RPAREN, ATOM_INTEGER, ATOM_STRING
891 static atom_type last_atom;
894 /* The name buffer must be at least as long as a symbol name. Right
895 now it's not clear how we're going to store numeric constants--
896 probably as a hexadecimal string, since this will allow the exact
897 number to be preserved (this can't be done by a decimal
898 representation). Worry about that later. TODO! */
900 #define MAX_ATOM_SIZE 100
903 static char *atom_string, atom_name[MAX_ATOM_SIZE];
906 /* Report problems with a module. Error reporting is not very
907 elaborate, since this sorts of errors shouldn't really happen.
908 This subroutine never returns. */
910 static void bad_module (const char *) ATTRIBUTE_NORETURN;
913 bad_module (const char *msgid)
920 gfc_fatal_error ("Reading module %s at line %d column %d: %s",
921 module_name, module_line, module_column, msgid);
924 gfc_fatal_error ("Writing module %s at line %d column %d: %s",
925 module_name, module_line, module_column, msgid);
928 gfc_fatal_error ("Module %s at line %d column %d: %s",
929 module_name, module_line, module_column, msgid);
935 /* Set the module's input pointer. */
938 set_module_locus (module_locus *m)
940 module_column = m->column;
941 module_line = m->line;
942 fsetpos (module_fp, &m->pos);
946 /* Get the module's input pointer so that we can restore it later. */
949 get_module_locus (module_locus *m)
951 m->column = module_column;
952 m->line = module_line;
953 fgetpos (module_fp, &m->pos);
957 /* Get the next character in the module, updating our reckoning of
965 c = getc (module_fp);
968 bad_module ("Unexpected EOF");
981 /* Parse a string constant. The delimiter is guaranteed to be a
991 get_module_locus (&start);
995 /* See how long the string is. */
1000 bad_module ("Unexpected end of module in string constant");
1018 set_module_locus (&start);
1020 atom_string = p = gfc_getmem (len + 1);
1022 for (; len > 0; len--)
1026 module_char (); /* Guaranteed to be another \'. */
1030 module_char (); /* Terminating \'. */
1031 *p = '\0'; /* C-style string for debug purposes. */
1035 /* Parse a small integer. */
1038 parse_integer (int c)
1046 get_module_locus (&m);
1052 atom_int = 10 * atom_int + c - '0';
1053 if (atom_int > 99999999)
1054 bad_module ("Integer overflow");
1057 set_module_locus (&m);
1075 get_module_locus (&m);
1080 if (!ISALNUM (c) && c != '_' && c != '-')
1084 if (++len > GFC_MAX_SYMBOL_LEN)
1085 bad_module ("Name too long");
1090 fseek (module_fp, -1, SEEK_CUR);
1091 module_column = m.column + len - 1;
1098 /* Read the next atom in the module's input stream. */
1109 while (c == ' ' || c == '\n');
1134 return ATOM_INTEGER;
1192 bad_module ("Bad name");
1199 /* Peek at the next atom on the input. */
1207 get_module_locus (&m);
1210 if (a == ATOM_STRING)
1211 gfc_free (atom_string);
1213 set_module_locus (&m);
1218 /* Read the next atom from the input, requiring that it be a
1222 require_atom (atom_type type)
1228 get_module_locus (&m);
1236 p = _("Expected name");
1239 p = _("Expected left parenthesis");
1242 p = _("Expected right parenthesis");
1245 p = _("Expected integer");
1248 p = _("Expected string");
1251 gfc_internal_error ("require_atom(): bad atom type required");
1254 set_module_locus (&m);
1260 /* Given a pointer to an mstring array, require that the current input
1261 be one of the strings in the array. We return the enum value. */
1264 find_enum (const mstring *m)
1268 i = gfc_string2code (m, atom_name);
1272 bad_module ("find_enum(): Enum not found");
1278 /**************** Module output subroutines ***************************/
1280 /* Output a character to a module file. */
1283 write_char (char out)
1285 if (putc (out, module_fp) == EOF)
1286 gfc_fatal_error ("Error writing modules file: %s", strerror (errno));
1288 /* Add this to our MD5. */
1289 md5_process_bytes (&out, sizeof (out), &ctx);
1301 /* Write an atom to a module. The line wrapping isn't perfect, but it
1302 should work most of the time. This isn't that big of a deal, since
1303 the file really isn't meant to be read by people anyway. */
1306 write_atom (atom_type atom, const void *v)
1328 i = *((const int *) v);
1330 gfc_internal_error ("write_atom(): Writing negative integer");
1332 sprintf (buffer, "%d", i);
1337 gfc_internal_error ("write_atom(): Trying to write dab atom");
1341 if(p == NULL || *p == '\0')
1346 if (atom != ATOM_RPAREN)
1348 if (module_column + len > 72)
1353 if (last_atom != ATOM_LPAREN && module_column != 1)
1358 if (atom == ATOM_STRING)
1361 while (p != NULL && *p)
1363 if (atom == ATOM_STRING && *p == '\'')
1368 if (atom == ATOM_STRING)
1376 /***************** Mid-level I/O subroutines *****************/
1378 /* These subroutines let their caller read or write atoms without
1379 caring about which of the two is actually happening. This lets a
1380 subroutine concentrate on the actual format of the data being
1383 static void mio_expr (gfc_expr **);
1384 static void mio_symbol_ref (gfc_symbol **);
1385 static void mio_symtree_ref (gfc_symtree **);
1387 /* Read or write an enumerated value. On writing, we return the input
1388 value for the convenience of callers. We avoid using an integer
1389 pointer because enums are sometimes inside bitfields. */
1392 mio_name (int t, const mstring *m)
1394 if (iomode == IO_OUTPUT)
1395 write_atom (ATOM_NAME, gfc_code2string (m, t));
1398 require_atom (ATOM_NAME);
1405 /* Specialization of mio_name. */
1407 #define DECL_MIO_NAME(TYPE) \
1408 static inline TYPE \
1409 MIO_NAME(TYPE) (TYPE t, const mstring *m) \
1411 return (TYPE) mio_name ((int) t, m); \
1413 #define MIO_NAME(TYPE) mio_name_##TYPE
1418 if (iomode == IO_OUTPUT)
1419 write_atom (ATOM_LPAREN, NULL);
1421 require_atom (ATOM_LPAREN);
1428 if (iomode == IO_OUTPUT)
1429 write_atom (ATOM_RPAREN, NULL);
1431 require_atom (ATOM_RPAREN);
1436 mio_integer (int *ip)
1438 if (iomode == IO_OUTPUT)
1439 write_atom (ATOM_INTEGER, ip);
1442 require_atom (ATOM_INTEGER);
1448 /* Read or write a character pointer that points to a string on the heap. */
1451 mio_allocated_string (const char *s)
1453 if (iomode == IO_OUTPUT)
1455 write_atom (ATOM_STRING, s);
1460 require_atom (ATOM_STRING);
1466 /* Read or write a string that is in static memory. */
1469 mio_pool_string (const char **stringp)
1471 /* TODO: one could write the string only once, and refer to it via a
1474 /* As a special case we have to deal with a NULL string. This
1475 happens for the 'module' member of 'gfc_symbol's that are not in a
1476 module. We read / write these as the empty string. */
1477 if (iomode == IO_OUTPUT)
1479 const char *p = *stringp == NULL ? "" : *stringp;
1480 write_atom (ATOM_STRING, p);
1484 require_atom (ATOM_STRING);
1485 *stringp = atom_string[0] == '\0' ? NULL : gfc_get_string (atom_string);
1486 gfc_free (atom_string);
1491 /* Read or write a string that is inside of some already-allocated
1495 mio_internal_string (char *string)
1497 if (iomode == IO_OUTPUT)
1498 write_atom (ATOM_STRING, string);
1501 require_atom (ATOM_STRING);
1502 strcpy (string, atom_string);
1503 gfc_free (atom_string);
1509 { AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL,
1510 AB_POINTER, AB_TARGET, AB_DUMMY, AB_RESULT, AB_DATA,
1511 AB_IN_NAMELIST, AB_IN_COMMON, AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE,
1512 AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT,
1513 AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP,
1514 AB_POINTER_COMP, AB_PRIVATE_COMP, AB_VALUE, AB_VOLATILE, AB_PROTECTED,
1515 AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C
1519 static const mstring attr_bits[] =
1521 minit ("ALLOCATABLE", AB_ALLOCATABLE),
1522 minit ("DIMENSION", AB_DIMENSION),
1523 minit ("EXTERNAL", AB_EXTERNAL),
1524 minit ("INTRINSIC", AB_INTRINSIC),
1525 minit ("OPTIONAL", AB_OPTIONAL),
1526 minit ("POINTER", AB_POINTER),
1527 minit ("VOLATILE", AB_VOLATILE),
1528 minit ("TARGET", AB_TARGET),
1529 minit ("THREADPRIVATE", AB_THREADPRIVATE),
1530 minit ("DUMMY", AB_DUMMY),
1531 minit ("RESULT", AB_RESULT),
1532 minit ("DATA", AB_DATA),
1533 minit ("IN_NAMELIST", AB_IN_NAMELIST),
1534 minit ("IN_COMMON", AB_IN_COMMON),
1535 minit ("FUNCTION", AB_FUNCTION),
1536 minit ("SUBROUTINE", AB_SUBROUTINE),
1537 minit ("SEQUENCE", AB_SEQUENCE),
1538 minit ("ELEMENTAL", AB_ELEMENTAL),
1539 minit ("PURE", AB_PURE),
1540 minit ("RECURSIVE", AB_RECURSIVE),
1541 minit ("GENERIC", AB_GENERIC),
1542 minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT),
1543 minit ("CRAY_POINTER", AB_CRAY_POINTER),
1544 minit ("CRAY_POINTEE", AB_CRAY_POINTEE),
1545 minit ("IS_BIND_C", AB_IS_BIND_C),
1546 minit ("IS_C_INTEROP", AB_IS_C_INTEROP),
1547 minit ("IS_ISO_C", AB_IS_ISO_C),
1548 minit ("VALUE", AB_VALUE),
1549 minit ("ALLOC_COMP", AB_ALLOC_COMP),
1550 minit ("POINTER_COMP", AB_POINTER_COMP),
1551 minit ("PRIVATE_COMP", AB_PRIVATE_COMP),
1552 minit ("PROTECTED", AB_PROTECTED),
1557 /* Specialization of mio_name. */
1558 DECL_MIO_NAME (ab_attribute)
1559 DECL_MIO_NAME (ar_type)
1560 DECL_MIO_NAME (array_type)
1562 DECL_MIO_NAME (expr_t)
1563 DECL_MIO_NAME (gfc_access)
1564 DECL_MIO_NAME (gfc_intrinsic_op)
1565 DECL_MIO_NAME (ifsrc)
1566 DECL_MIO_NAME (save_state)
1567 DECL_MIO_NAME (procedure_type)
1568 DECL_MIO_NAME (ref_type)
1569 DECL_MIO_NAME (sym_flavor)
1570 DECL_MIO_NAME (sym_intent)
1571 #undef DECL_MIO_NAME
1573 /* Symbol attributes are stored in list with the first three elements
1574 being the enumerated fields, while the remaining elements (if any)
1575 indicate the individual attribute bits. The access field is not
1576 saved-- it controls what symbols are exported when a module is
1580 mio_symbol_attribute (symbol_attribute *attr)
1586 attr->flavor = MIO_NAME (sym_flavor) (attr->flavor, flavors);
1587 attr->intent = MIO_NAME (sym_intent) (attr->intent, intents);
1588 attr->proc = MIO_NAME (procedure_type) (attr->proc, procedures);
1589 attr->if_source = MIO_NAME (ifsrc) (attr->if_source, ifsrc_types);
1590 attr->save = MIO_NAME (save_state) (attr->save, save_status);
1592 if (iomode == IO_OUTPUT)
1594 if (attr->allocatable)
1595 MIO_NAME (ab_attribute) (AB_ALLOCATABLE, attr_bits);
1596 if (attr->dimension)
1597 MIO_NAME (ab_attribute) (AB_DIMENSION, attr_bits);
1599 MIO_NAME (ab_attribute) (AB_EXTERNAL, attr_bits);
1600 if (attr->intrinsic)
1601 MIO_NAME (ab_attribute) (AB_INTRINSIC, attr_bits);
1603 MIO_NAME (ab_attribute) (AB_OPTIONAL, attr_bits);
1605 MIO_NAME (ab_attribute) (AB_POINTER, attr_bits);
1606 if (attr->protected)
1607 MIO_NAME (ab_attribute) (AB_PROTECTED, attr_bits);
1609 MIO_NAME (ab_attribute) (AB_VALUE, attr_bits);
1610 if (attr->volatile_)
1611 MIO_NAME (ab_attribute) (AB_VOLATILE, attr_bits);
1613 MIO_NAME (ab_attribute) (AB_TARGET, attr_bits);
1614 if (attr->threadprivate)
1615 MIO_NAME (ab_attribute) (AB_THREADPRIVATE, attr_bits);
1617 MIO_NAME (ab_attribute) (AB_DUMMY, attr_bits);
1619 MIO_NAME (ab_attribute) (AB_RESULT, attr_bits);
1620 /* We deliberately don't preserve the "entry" flag. */
1623 MIO_NAME (ab_attribute) (AB_DATA, attr_bits);
1624 if (attr->in_namelist)
1625 MIO_NAME (ab_attribute) (AB_IN_NAMELIST, attr_bits);
1626 if (attr->in_common)
1627 MIO_NAME (ab_attribute) (AB_IN_COMMON, attr_bits);
1630 MIO_NAME (ab_attribute) (AB_FUNCTION, attr_bits);
1631 if (attr->subroutine)
1632 MIO_NAME (ab_attribute) (AB_SUBROUTINE, attr_bits);
1634 MIO_NAME (ab_attribute) (AB_GENERIC, attr_bits);
1637 MIO_NAME (ab_attribute) (AB_SEQUENCE, attr_bits);
1638 if (attr->elemental)
1639 MIO_NAME (ab_attribute) (AB_ELEMENTAL, attr_bits);
1641 MIO_NAME (ab_attribute) (AB_PURE, attr_bits);
1642 if (attr->recursive)
1643 MIO_NAME (ab_attribute) (AB_RECURSIVE, attr_bits);
1644 if (attr->always_explicit)
1645 MIO_NAME (ab_attribute) (AB_ALWAYS_EXPLICIT, attr_bits);
1646 if (attr->cray_pointer)
1647 MIO_NAME (ab_attribute) (AB_CRAY_POINTER, attr_bits);
1648 if (attr->cray_pointee)
1649 MIO_NAME (ab_attribute) (AB_CRAY_POINTEE, attr_bits);
1650 if (attr->is_bind_c)
1651 MIO_NAME(ab_attribute) (AB_IS_BIND_C, attr_bits);
1652 if (attr->is_c_interop)
1653 MIO_NAME(ab_attribute) (AB_IS_C_INTEROP, attr_bits);
1655 MIO_NAME(ab_attribute) (AB_IS_ISO_C, attr_bits);
1656 if (attr->alloc_comp)
1657 MIO_NAME (ab_attribute) (AB_ALLOC_COMP, attr_bits);
1658 if (attr->pointer_comp)
1659 MIO_NAME (ab_attribute) (AB_POINTER_COMP, attr_bits);
1660 if (attr->private_comp)
1661 MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits);
1671 if (t == ATOM_RPAREN)
1674 bad_module ("Expected attribute bit name");
1676 switch ((ab_attribute) find_enum (attr_bits))
1678 case AB_ALLOCATABLE:
1679 attr->allocatable = 1;
1682 attr->dimension = 1;
1688 attr->intrinsic = 1;
1697 attr->protected = 1;
1703 attr->volatile_ = 1;
1708 case AB_THREADPRIVATE:
1709 attr->threadprivate = 1;
1720 case AB_IN_NAMELIST:
1721 attr->in_namelist = 1;
1724 attr->in_common = 1;
1730 attr->subroutine = 1;
1739 attr->elemental = 1;
1745 attr->recursive = 1;
1747 case AB_ALWAYS_EXPLICIT:
1748 attr->always_explicit = 1;
1750 case AB_CRAY_POINTER:
1751 attr->cray_pointer = 1;
1753 case AB_CRAY_POINTEE:
1754 attr->cray_pointee = 1;
1757 attr->is_bind_c = 1;
1759 case AB_IS_C_INTEROP:
1760 attr->is_c_interop = 1;
1766 attr->alloc_comp = 1;
1768 case AB_POINTER_COMP:
1769 attr->pointer_comp = 1;
1771 case AB_PRIVATE_COMP:
1772 attr->private_comp = 1;
1780 static const mstring bt_types[] = {
1781 minit ("INTEGER", BT_INTEGER),
1782 minit ("REAL", BT_REAL),
1783 minit ("COMPLEX", BT_COMPLEX),
1784 minit ("LOGICAL", BT_LOGICAL),
1785 minit ("CHARACTER", BT_CHARACTER),
1786 minit ("DERIVED", BT_DERIVED),
1787 minit ("PROCEDURE", BT_PROCEDURE),
1788 minit ("UNKNOWN", BT_UNKNOWN),
1789 minit ("VOID", BT_VOID),
1795 mio_charlen (gfc_charlen **clp)
1801 if (iomode == IO_OUTPUT)
1805 mio_expr (&cl->length);
1809 if (peek_atom () != ATOM_RPAREN)
1811 cl = gfc_get_charlen ();
1812 mio_expr (&cl->length);
1816 cl->next = gfc_current_ns->cl_list;
1817 gfc_current_ns->cl_list = cl;
1825 /* See if a name is a generated name. */
1828 check_unique_name (const char *name)
1830 return *name == '@';
1835 mio_typespec (gfc_typespec *ts)
1839 ts->type = MIO_NAME (bt) (ts->type, bt_types);
1841 if (ts->type != BT_DERIVED)
1842 mio_integer (&ts->kind);
1844 mio_symbol_ref (&ts->derived);
1846 /* Add info for C interop and is_iso_c. */
1847 mio_integer (&ts->is_c_interop);
1848 mio_integer (&ts->is_iso_c);
1850 /* If the typespec is for an identifier either from iso_c_binding, or
1851 a constant that was initialized to an identifier from it, use the
1852 f90_type. Otherwise, use the ts->type, since it shouldn't matter. */
1854 ts->f90_type = MIO_NAME (bt) (ts->f90_type, bt_types);
1856 ts->f90_type = MIO_NAME (bt) (ts->type, bt_types);
1858 if (ts->type != BT_CHARACTER)
1860 /* ts->cl is only valid for BT_CHARACTER. */
1865 mio_charlen (&ts->cl);
1871 static const mstring array_spec_types[] = {
1872 minit ("EXPLICIT", AS_EXPLICIT),
1873 minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE),
1874 minit ("DEFERRED", AS_DEFERRED),
1875 minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE),
1881 mio_array_spec (gfc_array_spec **asp)
1888 if (iomode == IO_OUTPUT)
1896 if (peek_atom () == ATOM_RPAREN)
1902 *asp = as = gfc_get_array_spec ();
1905 mio_integer (&as->rank);
1906 as->type = MIO_NAME (array_type) (as->type, array_spec_types);
1908 for (i = 0; i < as->rank; i++)
1910 mio_expr (&as->lower[i]);
1911 mio_expr (&as->upper[i]);
1919 /* Given a pointer to an array reference structure (which lives in a
1920 gfc_ref structure), find the corresponding array specification
1921 structure. Storing the pointer in the ref structure doesn't quite
1922 work when loading from a module. Generating code for an array
1923 reference also needs more information than just the array spec. */
1925 static const mstring array_ref_types[] = {
1926 minit ("FULL", AR_FULL),
1927 minit ("ELEMENT", AR_ELEMENT),
1928 minit ("SECTION", AR_SECTION),
1934 mio_array_ref (gfc_array_ref *ar)
1939 ar->type = MIO_NAME (ar_type) (ar->type, array_ref_types);
1940 mio_integer (&ar->dimen);
1948 for (i = 0; i < ar->dimen; i++)
1949 mio_expr (&ar->start[i]);
1954 for (i = 0; i < ar->dimen; i++)
1956 mio_expr (&ar->start[i]);
1957 mio_expr (&ar->end[i]);
1958 mio_expr (&ar->stride[i]);
1964 gfc_internal_error ("mio_array_ref(): Unknown array ref");
1967 /* Unfortunately, ar->dimen_type is an anonymous enumerated type so
1968 we can't call mio_integer directly. Instead loop over each element
1969 and cast it to/from an integer. */
1970 if (iomode == IO_OUTPUT)
1972 for (i = 0; i < ar->dimen; i++)
1974 int tmp = (int)ar->dimen_type[i];
1975 write_atom (ATOM_INTEGER, &tmp);
1980 for (i = 0; i < ar->dimen; i++)
1982 require_atom (ATOM_INTEGER);
1983 ar->dimen_type[i] = atom_int;
1987 if (iomode == IO_INPUT)
1989 ar->where = gfc_current_locus;
1991 for (i = 0; i < ar->dimen; i++)
1992 ar->c_where[i] = gfc_current_locus;
1999 /* Saves or restores a pointer. The pointer is converted back and
2000 forth from an integer. We return the pointer_info pointer so that
2001 the caller can take additional action based on the pointer type. */
2003 static pointer_info *
2004 mio_pointer_ref (void *gp)
2008 if (iomode == IO_OUTPUT)
2010 p = get_pointer (*((char **) gp));
2011 write_atom (ATOM_INTEGER, &p->integer);
2015 require_atom (ATOM_INTEGER);
2016 p = add_fixup (atom_int, gp);
2023 /* Save and load references to components that occur within
2024 expressions. We have to describe these references by a number and
2025 by name. The number is necessary for forward references during
2026 reading, and the name is necessary if the symbol already exists in
2027 the namespace and is not loaded again. */
2030 mio_component_ref (gfc_component **cp, gfc_symbol *sym)
2032 char name[GFC_MAX_SYMBOL_LEN + 1];
2036 p = mio_pointer_ref (cp);
2037 if (p->type == P_UNKNOWN)
2038 p->type = P_COMPONENT;
2040 if (iomode == IO_OUTPUT)
2041 mio_pool_string (&(*cp)->name);
2044 mio_internal_string (name);
2046 /* It can happen that a component reference can be read before the
2047 associated derived type symbol has been loaded. Return now and
2048 wait for a later iteration of load_needed. */
2052 if (sym->components != NULL && p->u.pointer == NULL)
2054 /* Symbol already loaded, so search by name. */
2055 for (q = sym->components; q; q = q->next)
2056 if (strcmp (q->name, name) == 0)
2060 gfc_internal_error ("mio_component_ref(): Component not found");
2062 associate_integer_pointer (p, q);
2065 /* Make sure this symbol will eventually be loaded. */
2066 p = find_pointer2 (sym);
2067 if (p->u.rsym.state == UNUSED)
2068 p->u.rsym.state = NEEDED;
2074 mio_component (gfc_component *c)
2081 if (iomode == IO_OUTPUT)
2083 p = get_pointer (c);
2084 mio_integer (&p->integer);
2089 p = get_integer (n);
2090 associate_integer_pointer (p, c);
2093 if (p->type == P_UNKNOWN)
2094 p->type = P_COMPONENT;
2096 mio_pool_string (&c->name);
2097 mio_typespec (&c->ts);
2098 mio_array_spec (&c->as);
2100 mio_integer (&c->dimension);
2101 mio_integer (&c->pointer);
2102 mio_integer (&c->allocatable);
2103 c->access = MIO_NAME (gfc_access) (c->access, access_types);
2105 mio_expr (&c->initializer);
2111 mio_component_list (gfc_component **cp)
2113 gfc_component *c, *tail;
2117 if (iomode == IO_OUTPUT)
2119 for (c = *cp; c; c = c->next)
2129 if (peek_atom () == ATOM_RPAREN)
2132 c = gfc_get_component ();
2149 mio_actual_arg (gfc_actual_arglist *a)
2152 mio_pool_string (&a->name);
2153 mio_expr (&a->expr);
2159 mio_actual_arglist (gfc_actual_arglist **ap)
2161 gfc_actual_arglist *a, *tail;
2165 if (iomode == IO_OUTPUT)
2167 for (a = *ap; a; a = a->next)
2177 if (peek_atom () != ATOM_LPAREN)
2180 a = gfc_get_actual_arglist ();
2196 /* Read and write formal argument lists. */
2199 mio_formal_arglist (gfc_symbol *sym)
2201 gfc_formal_arglist *f, *tail;
2205 if (iomode == IO_OUTPUT)
2207 for (f = sym->formal; f; f = f->next)
2208 mio_symbol_ref (&f->sym);
2212 sym->formal = tail = NULL;
2214 while (peek_atom () != ATOM_RPAREN)
2216 f = gfc_get_formal_arglist ();
2217 mio_symbol_ref (&f->sym);
2219 if (sym->formal == NULL)
2232 /* Save or restore a reference to a symbol node. */
2235 mio_symbol_ref (gfc_symbol **symp)
2239 p = mio_pointer_ref (symp);
2240 if (p->type == P_UNKNOWN)
2243 if (iomode == IO_OUTPUT)
2245 if (p->u.wsym.state == UNREFERENCED)
2246 p->u.wsym.state = NEEDS_WRITE;
2250 if (p->u.rsym.state == UNUSED)
2251 p->u.rsym.state = NEEDED;
2256 /* Save or restore a reference to a symtree node. */
2259 mio_symtree_ref (gfc_symtree **stp)
2264 if (iomode == IO_OUTPUT)
2265 mio_symbol_ref (&(*stp)->n.sym);
2268 require_atom (ATOM_INTEGER);
2269 p = get_integer (atom_int);
2271 /* An unused equivalence member; make a symbol and a symtree
2273 if (in_load_equiv && p->u.rsym.symtree == NULL)
2275 /* Since this is not used, it must have a unique name. */
2276 p->u.rsym.symtree = gfc_get_unique_symtree (gfc_current_ns);
2278 /* Make the symbol. */
2279 if (p->u.rsym.sym == NULL)
2281 p->u.rsym.sym = gfc_new_symbol (p->u.rsym.true_name,
2283 p->u.rsym.sym->module = gfc_get_string (p->u.rsym.module);
2286 p->u.rsym.symtree->n.sym = p->u.rsym.sym;
2287 p->u.rsym.symtree->n.sym->refs++;
2288 p->u.rsym.referenced = 1;
2291 if (p->type == P_UNKNOWN)
2294 if (p->u.rsym.state == UNUSED)
2295 p->u.rsym.state = NEEDED;
2297 if (p->u.rsym.symtree != NULL)
2299 *stp = p->u.rsym.symtree;
2303 f = gfc_getmem (sizeof (fixup_t));
2305 f->next = p->u.rsym.stfixup;
2306 p->u.rsym.stfixup = f;
2308 f->pointer = (void **) stp;
2315 mio_iterator (gfc_iterator **ip)
2321 if (iomode == IO_OUTPUT)
2328 if (peek_atom () == ATOM_RPAREN)
2334 *ip = gfc_get_iterator ();
2339 mio_expr (&iter->var);
2340 mio_expr (&iter->start);
2341 mio_expr (&iter->end);
2342 mio_expr (&iter->step);
2350 mio_constructor (gfc_constructor **cp)
2352 gfc_constructor *c, *tail;
2356 if (iomode == IO_OUTPUT)
2358 for (c = *cp; c; c = c->next)
2361 mio_expr (&c->expr);
2362 mio_iterator (&c->iterator);
2371 while (peek_atom () != ATOM_RPAREN)
2373 c = gfc_get_constructor ();
2383 mio_expr (&c->expr);
2384 mio_iterator (&c->iterator);
2393 static const mstring ref_types[] = {
2394 minit ("ARRAY", REF_ARRAY),
2395 minit ("COMPONENT", REF_COMPONENT),
2396 minit ("SUBSTRING", REF_SUBSTRING),
2402 mio_ref (gfc_ref **rp)
2409 r->type = MIO_NAME (ref_type) (r->type, ref_types);
2414 mio_array_ref (&r->u.ar);
2418 mio_symbol_ref (&r->u.c.sym);
2419 mio_component_ref (&r->u.c.component, r->u.c.sym);
2423 mio_expr (&r->u.ss.start);
2424 mio_expr (&r->u.ss.end);
2425 mio_charlen (&r->u.ss.length);
2434 mio_ref_list (gfc_ref **rp)
2436 gfc_ref *ref, *head, *tail;
2440 if (iomode == IO_OUTPUT)
2442 for (ref = *rp; ref; ref = ref->next)
2449 while (peek_atom () != ATOM_RPAREN)
2452 head = tail = gfc_get_ref ();
2455 tail->next = gfc_get_ref ();
2469 /* Read and write an integer value. */
2472 mio_gmp_integer (mpz_t *integer)
2476 if (iomode == IO_INPUT)
2478 if (parse_atom () != ATOM_STRING)
2479 bad_module ("Expected integer string");
2481 mpz_init (*integer);
2482 if (mpz_set_str (*integer, atom_string, 10))
2483 bad_module ("Error converting integer");
2485 gfc_free (atom_string);
2489 p = mpz_get_str (NULL, 10, *integer);
2490 write_atom (ATOM_STRING, p);
2497 mio_gmp_real (mpfr_t *real)
2502 if (iomode == IO_INPUT)
2504 if (parse_atom () != ATOM_STRING)
2505 bad_module ("Expected real string");
2508 mpfr_set_str (*real, atom_string, 16, GFC_RND_MODE);
2509 gfc_free (atom_string);
2513 p = mpfr_get_str (NULL, &exponent, 16, 0, *real, GFC_RND_MODE);
2514 atom_string = gfc_getmem (strlen (p) + 20);
2516 sprintf (atom_string, "0.%s@%ld", p, exponent);
2518 /* Fix negative numbers. */
2519 if (atom_string[2] == '-')
2521 atom_string[0] = '-';
2522 atom_string[1] = '0';
2523 atom_string[2] = '.';
2526 write_atom (ATOM_STRING, atom_string);
2528 gfc_free (atom_string);
2534 /* Save and restore the shape of an array constructor. */
2537 mio_shape (mpz_t **pshape, int rank)
2543 /* A NULL shape is represented by (). */
2546 if (iomode == IO_OUTPUT)
2558 if (t == ATOM_RPAREN)
2565 shape = gfc_get_shape (rank);
2569 for (n = 0; n < rank; n++)
2570 mio_gmp_integer (&shape[n]);
2576 static const mstring expr_types[] = {
2577 minit ("OP", EXPR_OP),
2578 minit ("FUNCTION", EXPR_FUNCTION),
2579 minit ("CONSTANT", EXPR_CONSTANT),
2580 minit ("VARIABLE", EXPR_VARIABLE),
2581 minit ("SUBSTRING", EXPR_SUBSTRING),
2582 minit ("STRUCTURE", EXPR_STRUCTURE),
2583 minit ("ARRAY", EXPR_ARRAY),
2584 minit ("NULL", EXPR_NULL),
2588 /* INTRINSIC_ASSIGN is missing because it is used as an index for
2589 generic operators, not in expressions. INTRINSIC_USER is also
2590 replaced by the correct function name by the time we see it. */
2592 static const mstring intrinsics[] =
2594 minit ("UPLUS", INTRINSIC_UPLUS),
2595 minit ("UMINUS", INTRINSIC_UMINUS),
2596 minit ("PLUS", INTRINSIC_PLUS),
2597 minit ("MINUS", INTRINSIC_MINUS),
2598 minit ("TIMES", INTRINSIC_TIMES),
2599 minit ("DIVIDE", INTRINSIC_DIVIDE),
2600 minit ("POWER", INTRINSIC_POWER),
2601 minit ("CONCAT", INTRINSIC_CONCAT),
2602 minit ("AND", INTRINSIC_AND),
2603 minit ("OR", INTRINSIC_OR),
2604 minit ("EQV", INTRINSIC_EQV),
2605 minit ("NEQV", INTRINSIC_NEQV),
2606 minit ("==", INTRINSIC_EQ),
2607 minit ("EQ", INTRINSIC_EQ_OS),
2608 minit ("/=", INTRINSIC_NE),
2609 minit ("NE", INTRINSIC_NE_OS),
2610 minit (">", INTRINSIC_GT),
2611 minit ("GT", INTRINSIC_GT_OS),
2612 minit (">=", INTRINSIC_GE),
2613 minit ("GE", INTRINSIC_GE_OS),
2614 minit ("<", INTRINSIC_LT),
2615 minit ("LT", INTRINSIC_LT_OS),
2616 minit ("<=", INTRINSIC_LE),
2617 minit ("LE", INTRINSIC_LE_OS),
2618 minit ("NOT", INTRINSIC_NOT),
2619 minit ("PARENTHESES", INTRINSIC_PARENTHESES),
2624 /* Remedy a couple of situations where the gfc_expr's can be defective. */
2627 fix_mio_expr (gfc_expr *e)
2629 gfc_symtree *ns_st = NULL;
2632 if (iomode != IO_OUTPUT)
2637 /* If this is a symtree for a symbol that came from a contained module
2638 namespace, it has a unique name and we should look in the current
2639 namespace to see if the required, non-contained symbol is available
2640 yet. If so, the latter should be written. */
2641 if (e->symtree->n.sym && check_unique_name (e->symtree->name))
2642 ns_st = gfc_find_symtree (gfc_current_ns->sym_root,
2643 e->symtree->n.sym->name);
2645 /* On the other hand, if the existing symbol is the module name or the
2646 new symbol is a dummy argument, do not do the promotion. */
2647 if (ns_st && ns_st->n.sym
2648 && ns_st->n.sym->attr.flavor != FL_MODULE
2649 && !e->symtree->n.sym->attr.dummy)
2652 else if (e->expr_type == EXPR_FUNCTION && e->value.function.name)
2654 /* In some circumstances, a function used in an initialization
2655 expression, in one use associated module, can fail to be
2656 coupled to its symtree when used in a specification
2657 expression in another module. */
2658 fname = e->value.function.esym ? e->value.function.esym->name
2659 : e->value.function.isym->name;
2660 e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
2665 /* Read and write expressions. The form "()" is allowed to indicate a
2669 mio_expr (gfc_expr **ep)
2677 if (iomode == IO_OUTPUT)
2686 MIO_NAME (expr_t) (e->expr_type, expr_types);
2691 if (t == ATOM_RPAREN)
2698 bad_module ("Expected expression type");
2700 e = *ep = gfc_get_expr ();
2701 e->where = gfc_current_locus;
2702 e->expr_type = (expr_t) find_enum (expr_types);
2705 mio_typespec (&e->ts);
2706 mio_integer (&e->rank);
2710 switch (e->expr_type)
2713 e->value.op.operator
2714 = MIO_NAME (gfc_intrinsic_op) (e->value.op.operator, intrinsics);
2716 switch (e->value.op.operator)
2718 case INTRINSIC_UPLUS:
2719 case INTRINSIC_UMINUS:
2721 case INTRINSIC_PARENTHESES:
2722 mio_expr (&e->value.op.op1);
2725 case INTRINSIC_PLUS:
2726 case INTRINSIC_MINUS:
2727 case INTRINSIC_TIMES:
2728 case INTRINSIC_DIVIDE:
2729 case INTRINSIC_POWER:
2730 case INTRINSIC_CONCAT:
2734 case INTRINSIC_NEQV:
2736 case INTRINSIC_EQ_OS:
2738 case INTRINSIC_NE_OS:
2740 case INTRINSIC_GT_OS:
2742 case INTRINSIC_GE_OS:
2744 case INTRINSIC_LT_OS:
2746 case INTRINSIC_LE_OS:
2747 mio_expr (&e->value.op.op1);
2748 mio_expr (&e->value.op.op2);
2752 bad_module ("Bad operator");
2758 mio_symtree_ref (&e->symtree);
2759 mio_actual_arglist (&e->value.function.actual);
2761 if (iomode == IO_OUTPUT)
2763 e->value.function.name
2764 = mio_allocated_string (e->value.function.name);
2765 flag = e->value.function.esym != NULL;
2766 mio_integer (&flag);
2768 mio_symbol_ref (&e->value.function.esym);
2770 write_atom (ATOM_STRING, e->value.function.isym->name);
2774 require_atom (ATOM_STRING);
2775 e->value.function.name = gfc_get_string (atom_string);
2776 gfc_free (atom_string);
2778 mio_integer (&flag);
2780 mio_symbol_ref (&e->value.function.esym);
2783 require_atom (ATOM_STRING);
2784 e->value.function.isym = gfc_find_function (atom_string);
2785 gfc_free (atom_string);
2792 mio_symtree_ref (&e->symtree);
2793 mio_ref_list (&e->ref);
2796 case EXPR_SUBSTRING:
2797 e->value.character.string
2798 = (char *) mio_allocated_string (e->value.character.string);
2799 mio_ref_list (&e->ref);
2802 case EXPR_STRUCTURE:
2804 mio_constructor (&e->value.constructor);
2805 mio_shape (&e->shape, e->rank);
2812 mio_gmp_integer (&e->value.integer);
2816 gfc_set_model_kind (e->ts.kind);
2817 mio_gmp_real (&e->value.real);
2821 gfc_set_model_kind (e->ts.kind);
2822 mio_gmp_real (&e->value.complex.r);
2823 mio_gmp_real (&e->value.complex.i);
2827 mio_integer (&e->value.logical);
2831 mio_integer (&e->value.character.length);
2832 e->value.character.string
2833 = (char *) mio_allocated_string (e->value.character.string);
2837 bad_module ("Bad type in constant expression");
2850 /* Read and write namelists. */
2853 mio_namelist (gfc_symbol *sym)
2855 gfc_namelist *n, *m;
2856 const char *check_name;
2860 if (iomode == IO_OUTPUT)
2862 for (n = sym->namelist; n; n = n->next)
2863 mio_symbol_ref (&n->sym);
2867 /* This departure from the standard is flagged as an error.
2868 It does, in fact, work correctly. TODO: Allow it
2870 if (sym->attr.flavor == FL_NAMELIST)
2872 check_name = find_use_name (sym->name);
2873 if (check_name && strcmp (check_name, sym->name) != 0)
2874 gfc_error ("Namelist %s cannot be renamed by USE "
2875 "association to %s", sym->name, check_name);
2879 while (peek_atom () != ATOM_RPAREN)
2881 n = gfc_get_namelist ();
2882 mio_symbol_ref (&n->sym);
2884 if (sym->namelist == NULL)
2891 sym->namelist_tail = m;
2898 /* Save/restore lists of gfc_interface stuctures. When loading an
2899 interface, we are really appending to the existing list of
2900 interfaces. Checking for duplicate and ambiguous interfaces has to
2901 be done later when all symbols have been loaded. */
2904 mio_interface_rest (gfc_interface **ip)
2906 gfc_interface *tail, *p;
2908 if (iomode == IO_OUTPUT)
2911 for (p = *ip; p; p = p->next)
2912 mio_symbol_ref (&p->sym);
2927 if (peek_atom () == ATOM_RPAREN)
2930 p = gfc_get_interface ();
2931 p->where = gfc_current_locus;
2932 mio_symbol_ref (&p->sym);
2947 /* Save/restore a nameless operator interface. */
2950 mio_interface (gfc_interface **ip)
2953 mio_interface_rest (ip);
2957 /* Save/restore a named operator interface. */
2960 mio_symbol_interface (const char **name, const char **module,
2964 mio_pool_string (name);
2965 mio_pool_string (module);
2966 mio_interface_rest (ip);
2971 mio_namespace_ref (gfc_namespace **nsp)
2976 p = mio_pointer_ref (nsp);
2978 if (p->type == P_UNKNOWN)
2979 p->type = P_NAMESPACE;
2981 if (iomode == IO_INPUT && p->integer != 0)
2983 ns = (gfc_namespace *) p->u.pointer;
2986 ns = gfc_get_namespace (NULL, 0);
2987 associate_integer_pointer (p, ns);
2995 /* Unlike most other routines, the address of the symbol node is already
2996 fixed on input and the name/module has already been filled in. */
2999 mio_symbol (gfc_symbol *sym)
3001 int intmod = INTMOD_NONE;
3003 gfc_formal_arglist *formal;
3007 mio_symbol_attribute (&sym->attr);
3008 mio_typespec (&sym->ts);
3010 /* Contained procedures don't have formal namespaces. Instead we output the
3011 procedure namespace. The will contain the formal arguments. */
3012 if (iomode == IO_OUTPUT)
3014 formal = sym->formal;
3015 while (formal && !formal->sym)
3016 formal = formal->next;
3019 mio_namespace_ref (&formal->sym->ns);
3021 mio_namespace_ref (&sym->formal_ns);
3025 mio_namespace_ref (&sym->formal_ns);
3028 sym->formal_ns->proc_name = sym;
3033 /* Save/restore common block links. */
3034 mio_symbol_ref (&sym->common_next);
3036 mio_formal_arglist (sym);
3038 if (sym->attr.flavor == FL_PARAMETER)
3039 mio_expr (&sym->value);
3041 mio_array_spec (&sym->as);
3043 mio_symbol_ref (&sym->result);
3045 if (sym->attr.cray_pointee)
3046 mio_symbol_ref (&sym->cp_pointer);
3048 /* Note that components are always saved, even if they are supposed
3049 to be private. Component access is checked during searching. */
3051 mio_component_list (&sym->components);
3053 if (sym->components != NULL)
3054 sym->component_access
3055 = MIO_NAME (gfc_access) (sym->component_access, access_types);
3059 /* Add the fields that say whether this is from an intrinsic module,
3060 and if so, what symbol it is within the module. */
3061 /* mio_integer (&(sym->from_intmod)); */
3062 if (iomode == IO_OUTPUT)
3064 intmod = sym->from_intmod;
3065 mio_integer (&intmod);
3069 mio_integer (&intmod);
3070 sym->from_intmod = intmod;
3073 mio_integer (&(sym->intmod_sym_id));
3079 /************************* Top level subroutines *************************/
3081 /* Skip a list between balanced left and right parens. */
3091 switch (parse_atom ())
3102 gfc_free (atom_string);
3114 /* Load operator interfaces from the module. Interfaces are unusual
3115 in that they attach themselves to existing symbols. */
3118 load_operator_interfaces (void)
3121 char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
3126 while (peek_atom () != ATOM_RPAREN)
3130 mio_internal_string (name);
3131 mio_internal_string (module);
3133 /* Decide if we need to load this one or not. */
3134 p = find_use_name (name);
3137 while (parse_atom () != ATOM_RPAREN);
3141 uop = gfc_get_uop (p);
3142 mio_interface_rest (&uop->operator);
3150 /* Load interfaces from the module. Interfaces are unusual in that
3151 they attach themselves to existing symbols. */
3154 load_generic_interfaces (void)
3157 char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
3159 gfc_interface *generic = NULL;
3164 while (peek_atom () != ATOM_RPAREN)
3168 mio_internal_string (name);
3169 mio_internal_string (module);
3171 n = number_use_names (name);
3174 for (i = 1; i <= n; i++)
3176 /* Decide if we need to load this one or not. */
3177 p = find_use_name_n (name, &i);
3179 if (p == NULL || gfc_find_symbol (p, NULL, 0, &sym))
3181 while (parse_atom () != ATOM_RPAREN);
3187 gfc_get_symbol (p, NULL, &sym);
3189 sym->attr.flavor = FL_PROCEDURE;
3190 sym->attr.generic = 1;
3191 sym->attr.use_assoc = 1;
3195 /* Unless sym is a generic interface, this reference
3199 st = gfc_find_symtree (gfc_current_ns->sym_root, p);
3200 if (!sym->attr.generic
3201 && sym->module != NULL
3202 && strcmp(module, sym->module) != 0)
3207 mio_interface_rest (&sym->generic);
3208 generic = sym->generic;
3212 sym->generic = generic;
3213 sym->attr.generic_copy = 1;
3222 /* Load common blocks. */
3227 char name[GFC_MAX_SYMBOL_LEN + 1];
3232 while (peek_atom () != ATOM_RPAREN)
3236 mio_internal_string (name);
3238 p = gfc_get_common (name, 1);
3240 mio_symbol_ref (&p->head);
3241 mio_integer (&flags);
3245 p->threadprivate = 1;
3248 /* Get whether this was a bind(c) common or not. */
3249 mio_integer (&p->is_bind_c);
3250 /* Get the binding label. */
3251 mio_internal_string (p->binding_label);
3260 /* Load equivalences. The flag in_load_equiv informs mio_expr_ref of this
3261 so that unused variables are not loaded and so that the expression can
3267 gfc_equiv *head, *tail, *end, *eq;
3271 in_load_equiv = true;
3273 end = gfc_current_ns->equiv;
3274 while (end != NULL && end->next != NULL)
3277 while (peek_atom () != ATOM_RPAREN) {
3281 while(peek_atom () != ATOM_RPAREN)
3284 head = tail = gfc_get_equiv ();
3287 tail->eq = gfc_get_equiv ();
3291 mio_pool_string (&tail->module);
3292 mio_expr (&tail->expr);
3295 /* Unused equivalence members have a unique name. */
3297 for (eq = head; eq; eq = eq->eq)
3299 if (!check_unique_name (eq->expr->symtree->name))
3308 for (eq = head; eq; eq = head)
3311 gfc_free_expr (eq->expr);
3317 gfc_current_ns->equiv = head;
3328 in_load_equiv = false;
3332 /* Recursive function to traverse the pointer_info tree and load a
3333 needed symbol. We return nonzero if we load a symbol and stop the
3334 traversal, because the act of loading can alter the tree. */
3337 load_needed (pointer_info *p)
3348 rv |= load_needed (p->left);
3349 rv |= load_needed (p->right);
3351 if (p->type != P_SYMBOL || p->u.rsym.state != NEEDED)
3354 p->u.rsym.state = USED;
3356 set_module_locus (&p->u.rsym.where);
3358 sym = p->u.rsym.sym;
3361 q = get_integer (p->u.rsym.ns);
3363 ns = (gfc_namespace *) q->u.pointer;
3366 /* Create an interface namespace if necessary. These are
3367 the namespaces that hold the formal parameters of module
3370 ns = gfc_get_namespace (NULL, 0);
3371 associate_integer_pointer (q, ns);
3374 sym = gfc_new_symbol (p->u.rsym.true_name, ns);
3375 sym->module = gfc_get_string (p->u.rsym.module);
3377 associate_integer_pointer (p, sym);
3381 sym->attr.use_assoc = 1;
3383 sym->attr.use_only = 1;
3389 /* Recursive function for cleaning up things after a module has been read. */
3392 read_cleanup (pointer_info *p)
3400 read_cleanup (p->left);
3401 read_cleanup (p->right);
3403 if (p->type == P_SYMBOL && p->u.rsym.state == USED && !p->u.rsym.referenced)
3405 /* Add hidden symbols to the symtree. */
3406 q = get_integer (p->u.rsym.ns);
3407 st = gfc_get_unique_symtree ((gfc_namespace *) q->u.pointer);
3409 st->n.sym = p->u.rsym.sym;
3412 /* Fixup any symtree references. */
3413 p->u.rsym.symtree = st;
3414 resolve_fixups (p->u.rsym.stfixup, st);
3415 p->u.rsym.stfixup = NULL;
3418 /* Free unused symbols. */
3419 if (p->type == P_SYMBOL && p->u.rsym.state == UNUSED)
3420 gfc_free_symbol (p->u.rsym.sym);
3424 /* Given a root symtree node and a symbol, try to find a symtree that
3425 references the symbol that is not a unique name. */
3427 static gfc_symtree *
3428 find_symtree_for_symbol (gfc_symtree *st, gfc_symbol *sym)
3430 gfc_symtree *s = NULL;
3435 s = find_symtree_for_symbol (st->right, sym);
3438 s = find_symtree_for_symbol (st->left, sym);
3442 if (st->n.sym == sym && !check_unique_name (st->name))
3449 /* Read a module file. */
3454 module_locus operator_interfaces, user_operators;
3456 char name[GFC_MAX_SYMBOL_LEN + 1];
3458 int ambiguous, j, nuse, symbol;
3459 pointer_info *info, *q;
3464 get_module_locus (&operator_interfaces); /* Skip these for now. */
3467 get_module_locus (&user_operators);
3471 /* Skip commons and equivalences for now. */
3477 /* Create the fixup nodes for all the symbols. */
3479 while (peek_atom () != ATOM_RPAREN)
3481 require_atom (ATOM_INTEGER);
3482 info = get_integer (atom_int);
3484 info->type = P_SYMBOL;
3485 info->u.rsym.state = UNUSED;
3487 mio_internal_string (info->u.rsym.true_name);
3488 mio_internal_string (info->u.rsym.module);
3489 mio_internal_string (info->u.rsym.binding_label);
3492 require_atom (ATOM_INTEGER);
3493 info->u.rsym.ns = atom_int;
3495 get_module_locus (&info->u.rsym.where);
3498 /* See if the symbol has already been loaded by a previous module.
3499 If so, we reference the existing symbol and prevent it from
3500 being loaded again. This should not happen if the symbol being
3501 read is an index for an assumed shape dummy array (ns != 1). */
3503 sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module);
3506 || (sym->attr.flavor == FL_VARIABLE && info->u.rsym.ns !=1))
3509 info->u.rsym.state = USED;
3510 info->u.rsym.sym = sym;
3512 /* Some symbols do not have a namespace (eg. formal arguments),
3513 so the automatic "unique symtree" mechanism must be suppressed
3514 by marking them as referenced. */
3515 q = get_integer (info->u.rsym.ns);
3516 if (q->u.pointer == NULL)
3518 info->u.rsym.referenced = 1;
3522 /* If possible recycle the symtree that references the symbol.
3523 If a symtree is not found and the module does not import one,
3524 a unique-name symtree is found by read_cleanup. */
3525 st = find_symtree_for_symbol (gfc_current_ns->sym_root, sym);
3528 info->u.rsym.symtree = st;
3529 info->u.rsym.referenced = 1;
3535 /* Parse the symtree lists. This lets us mark which symbols need to
3536 be loaded. Renaming is also done at this point by replacing the
3541 while (peek_atom () != ATOM_RPAREN)
3543 mio_internal_string (name);
3544 mio_integer (&ambiguous);
3545 mio_integer (&symbol);
3547 info = get_integer (symbol);
3549 /* See how many use names there are. If none, go through the start
3550 of the loop at least once. */
3551 nuse = number_use_names (name);
3555 for (j = 1; j <= nuse; j++)
3557 /* Get the jth local name for this symbol. */
3558 p = find_use_name_n (name, &j);
3560 if (p == NULL && strcmp (name, module_name) == 0)
3563 /* Skip symtree nodes not in an ONLY clause, unless there
3564 is an existing symtree loaded from another USE statement. */
3567 st = gfc_find_symtree (gfc_current_ns->sym_root, name);
3569 info->u.rsym.symtree = st;
3573 st = gfc_find_symtree (gfc_current_ns->sym_root, p);
3577 /* Check for ambiguous symbols. */
3578 if (st->n.sym != info->u.rsym.sym)
3580 info->u.rsym.symtree = st;
3584 /* Create a symtree node in the current namespace for this
3586 st = check_unique_name (p)
3587 ? gfc_get_unique_symtree (gfc_current_ns)
3588 : gfc_new_symtree (&gfc_current_ns->sym_root, p);
3590 st->ambiguous = ambiguous;
3592 sym = info->u.rsym.sym;
3594 /* Create a symbol node if it doesn't already exist. */
3597 info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name,
3599 sym = info->u.rsym.sym;
3600 sym->module = gfc_get_string (info->u.rsym.module);
3602 /* TODO: hmm, can we test this? Do we know it will be
3603 initialized to zeros? */
3604 if (info->u.rsym.binding_label[0] != '\0')
3605 strcpy (sym->binding_label, info->u.rsym.binding_label);
3611 /* Store the symtree pointing to this symbol. */
3612 info->u.rsym.symtree = st;
3614 if (info->u.rsym.state == UNUSED)
3615 info->u.rsym.state = NEEDED;
3616 info->u.rsym.referenced = 1;
3623 /* Load intrinsic operator interfaces. */
3624 set_module_locus (&operator_interfaces);
3627 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3629 if (i == INTRINSIC_USER)
3634 u = find_use_operator (i);
3645 mio_interface (&gfc_current_ns->operator[i]);
3650 /* Load generic and user operator interfaces. These must follow the
3651 loading of symtree because otherwise symbols can be marked as
3654 set_module_locus (&user_operators);
3656 load_operator_interfaces ();
3657 load_generic_interfaces ();
3662 /* At this point, we read those symbols that are needed but haven't
3663 been loaded yet. If one symbol requires another, the other gets
3664 marked as NEEDED if its previous state was UNUSED. */
3666 while (load_needed (pi_root));
3668 /* Make sure all elements of the rename-list were found in the module. */
3670 for (u = gfc_rename_list; u; u = u->next)
3675 if (u->operator == INTRINSIC_NONE)
3677 gfc_error ("Symbol '%s' referenced at %L not found in module '%s'",
3678 u->use_name, &u->where, module_name);
3682 if (u->operator == INTRINSIC_USER)
3684 gfc_error ("User operator '%s' referenced at %L not found "
3685 "in module '%s'", u->use_name, &u->where, module_name);
3689 gfc_error ("Intrinsic operator '%s' referenced at %L not found "
3690 "in module '%s'", gfc_op2string (u->operator), &u->where,
3694 gfc_check_interfaces (gfc_current_ns);
3696 /* Clean up symbol nodes that were never loaded, create references
3697 to hidden symbols. */
3699 read_cleanup (pi_root);
3703 /* Given an access type that is specific to an entity and the default
3704 access, return nonzero if the entity is publicly accessible. If the
3705 element is declared as PUBLIC, then it is public; if declared
3706 PRIVATE, then private, and otherwise it is public unless the default
3707 access in this context has been declared PRIVATE. */
3710 gfc_check_access (gfc_access specific_access, gfc_access default_access)
3712 if (specific_access == ACCESS_PUBLIC)
3714 if (specific_access == ACCESS_PRIVATE)
3717 return default_access != ACCESS_PRIVATE;
3721 /* Write a common block to the module. */
3724 write_common (gfc_symtree *st)
3734 write_common (st->left);
3735 write_common (st->right);
3739 /* Write the unmangled name. */
3740 name = st->n.common->name;
3742 mio_pool_string (&name);
3745 mio_symbol_ref (&p->head);
3746 flags = p->saved ? 1 : 0;
3747 if (p->threadprivate) flags |= 2;
3748 mio_integer (&flags);
3750 /* Write out whether the common block is bind(c) or not. */
3751 mio_integer (&(p->is_bind_c));
3753 /* Write out the binding label, or the com name if no label given. */
3756 label = p->binding_label;
3757 mio_pool_string (&label);
3762 mio_pool_string (&label);
3769 /* Write the blank common block to the module. */
3772 write_blank_common (void)
3774 const char * name = BLANK_COMMON_NAME;
3776 /* TODO: Blank commons are not bind(c). The F2003 standard probably says
3777 this, but it hasn't been checked. Just making it so for now. */
3780 if (gfc_current_ns->blank_common.head == NULL)
3785 mio_pool_string (&name);
3787 mio_symbol_ref (&gfc_current_ns->blank_common.head);
3788 saved = gfc_current_ns->blank_common.saved;
3789 mio_integer (&saved);
3791 /* Write out whether the common block is bind(c) or not. */
3792 mio_integer (&is_bind_c);
3794 /* Write out the binding label, which is BLANK_COMMON_NAME, though
3795 it doesn't matter because the label isn't used. */
3796 mio_pool_string (&name);
3802 /* Write equivalences to the module. */
3811 for (eq = gfc_current_ns->equiv; eq; eq = eq->next)
3815 for (e = eq; e; e = e->eq)
3817 if (e->module == NULL)
3818 e->module = gfc_get_string ("%s.eq.%d", module_name, num);
3819 mio_allocated_string (e->module);
3820 mio_expr (&e->expr);
3829 /* Write a symbol to the module. */
3832 write_symbol (int n, gfc_symbol *sym)
3836 if (sym->attr.flavor == FL_UNKNOWN || sym->attr.flavor == FL_LABEL)
3837 gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym->name);
3840 mio_pool_string (&sym->name);
3842 mio_pool_string (&sym->module);
3843 if (sym->attr.is_bind_c || sym->attr.is_iso_c)
3845 label = sym->binding_label;
3846 mio_pool_string (&label);
3849 mio_pool_string (&sym->name);
3851 mio_pointer_ref (&sym->ns);
3858 /* Recursive traversal function to write the initial set of symbols to
3859 the module. We check to see if the symbol should be written
3860 according to the access specification. */
3863 write_symbol0 (gfc_symtree *st)
3871 write_symbol0 (st->left);
3872 write_symbol0 (st->right);
3875 if (sym->module == NULL)
3876 sym->module = gfc_get_string (module_name);
3878 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
3879 && !sym->attr.subroutine && !sym->attr.function)
3882 if (!gfc_check_access (sym->attr.access, sym->ns->default_access))
3885 p = get_pointer (sym);
3886 if (p->type == P_UNKNOWN)
3889 if (p->u.wsym.state == WRITTEN)
3892 write_symbol (p->integer, sym);
3893 p->u.wsym.state = WRITTEN;
3897 /* Recursive traversal function to write the secondary set of symbols
3898 to the module file. These are symbols that were not public yet are
3899 needed by the public symbols or another dependent symbol. The act
3900 of writing a symbol can modify the pointer_info tree, so we cease
3901 traversal if we find a symbol to write. We return nonzero if a
3902 symbol was written and pass that information upwards. */
3905 write_symbol1 (pointer_info *p)
3911 if (write_symbol1 (p->left))
3913 if (write_symbol1 (p->right))
3916 if (p->type != P_SYMBOL || p->u.wsym.state != NEEDS_WRITE)
3919 p->u.wsym.state = WRITTEN;
3920 write_symbol (p->integer, p->u.wsym.sym);
3926 /* Write operator interfaces associated with a symbol. */
3929 write_operator (gfc_user_op *uop)
3931 static char nullstring[] = "";
3932 const char *p = nullstring;
3934 if (uop->operator == NULL
3935 || !gfc_check_access (uop->access, uop->ns->default_access))
3938 mio_symbol_interface (&uop->name, &p, &uop->operator);
3942 /* Write generic interfaces associated with a symbol. */
3945 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 /* See how many use names there are. If none, use the symbol name. */
3958 nuse = number_use_names (sym->name);
3961 mio_symbol_interface (&sym->name, &sym->module, &sym->generic);
3965 for (j = 1; j <= nuse; j++)
3967 /* Get the jth local name for this symbol. */
3968 p = find_use_name_n (sym->name, &j);
3970 mio_symbol_interface (&p, &sym->module, &sym->generic);
3976 write_symtree (gfc_symtree *st)
3982 if (!gfc_check_access (sym->attr.access, sym->ns->default_access)
3983 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
3984 && !sym->attr.subroutine && !sym->attr.function))
3987 if (check_unique_name (st->name))
3990 p = find_pointer (sym);
3992 gfc_internal_error ("write_symtree(): Symbol not written");
3994 mio_pool_string (&st->name);
3995 mio_integer (&st->ambiguous);
3996 mio_integer (&p->integer);
4005 /* Write the operator interfaces. */
4008 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
4010 if (i == INTRINSIC_USER)
4013 mio_interface (gfc_check_access (gfc_current_ns->operator_access[i],
4014 gfc_current_ns->default_access)
4015 ? &gfc_current_ns->operator[i] : NULL);
4023 gfc_traverse_user_op (gfc_current_ns, write_operator);
4029 gfc_traverse_ns (gfc_current_ns, write_generic);
4035 write_blank_common ();
4036 write_common (gfc_current_ns->common_root);
4047 /* Write symbol information. First we traverse all symbols in the
4048 primary namespace, writing those that need to be written.
4049 Sometimes writing one symbol will cause another to need to be
4050 written. A list of these symbols ends up on the write stack, and
4051 we end by popping the bottom of the stack and writing the symbol
4052 until the stack is empty. */
4056 write_symbol0 (gfc_current_ns->sym_root);
4057 while (write_symbol1 (pi_root));
4065 gfc_traverse_symtree (gfc_current_ns->sym_root, write_symtree);
4070 /* Read a MD5 sum from the header of a module file. If the file cannot
4071 be opened, or we have any other error, we return -1. */
4074 read_md5_from_module_file (const char * filename, unsigned char md5[16])
4080 /* Open the file. */
4081 if ((file = fopen (filename, "r")) == NULL)
4084 /* Read two lines. */
4085 if (fgets (buf, sizeof (buf) - 1, file) == NULL
4086 || fgets (buf, sizeof (buf) - 1, file) == NULL)
4092 /* Close the file. */
4095 /* If the header is not what we expect, or is too short, bail out. */
4096 if (strncmp (buf, "MD5:", 4) != 0 || strlen (buf) < 4 + 16)
4099 /* Now, we have a real MD5, read it into the array. */
4100 for (n = 0; n < 16; n++)
4104 if (sscanf (&(buf[4+2*n]), "%02x", &x) != 1)
4114 /* Given module, dump it to disk. If there was an error while
4115 processing the module, dump_flag will be set to zero and we delete
4116 the module file, even if it was already there. */
4119 gfc_dump_module (const char *name, int dump_flag)
4122 char *filename, *filename_tmp, *p;
4125 unsigned char md5_new[16], md5_old[16];
4127 n = strlen (name) + strlen (MODULE_EXTENSION) + 1;
4128 if (gfc_option.module_dir != NULL)
4130 n += strlen (gfc_option.module_dir);
4131 filename = (char *) alloca (n);
4132 strcpy (filename, gfc_option.module_dir);
4133 strcat (filename, name);
4137 filename = (char *) alloca (n);
4138 strcpy (filename, name);
4140 strcat (filename, MODULE_EXTENSION);
4142 /* Name of the temporary file used to write the module. */
4143 filename_tmp = (char *) alloca (n + 1);
4144 strcpy (filename_tmp, filename);
4145 strcat (filename_tmp, "0");
4147 /* There was an error while processing the module. We delete the
4148 module file, even if it was already there. */
4155 /* Write the module to the temporary file. */
4156 module_fp = fopen (filename_tmp, "w");
4157 if (module_fp == NULL)
4158 gfc_fatal_error ("Can't open module file '%s' for writing at %C: %s",
4159 filename_tmp, strerror (errno));
4161 /* Write the header, including space reserved for the MD5 sum. */
4165 *strchr (p, '\n') = '\0';
4167 fprintf (module_fp, "GFORTRAN module created from %s on %s\nMD5:",
4168 gfc_source_file, p);
4169 fgetpos (module_fp, &md5_pos);
4170 fputs ("00000000000000000000000000000000 -- "
4171 "If you edit this, you'll get what you deserve.\n\n", module_fp);
4173 /* Initialize the MD5 context that will be used for output. */
4174 md5_init_ctx (&ctx);
4176 /* Write the module itself. */
4178 strcpy (module_name, name);
4184 free_pi_tree (pi_root);
4189 /* Write the MD5 sum to the header of the module file. */
4190 md5_finish_ctx (&ctx, md5_new);
4191 fsetpos (module_fp, &md5_pos);
4192 for (n = 0; n < 16; n++)
4193 fprintf (module_fp, "%02x", md5_new[n]);
4195 if (fclose (module_fp))
4196 gfc_fatal_error ("Error writing module file '%s' for writing: %s",
4197 filename_tmp, strerror (errno));
4199 /* Read the MD5 from the header of the old module file and compare. */
4200 if (read_md5_from_module_file (filename, md5_old) != 0
4201 || memcmp (md5_old, md5_new, sizeof (md5_old)) != 0)
4203 /* Module file have changed, replace the old one. */
4205 rename (filename_tmp, filename);
4208 unlink (filename_tmp);
4213 sort_iso_c_rename_list (void)
4215 gfc_use_rename *tmp_list = NULL;
4216 gfc_use_rename *curr;
4217 gfc_use_rename *kinds_used[ISOCBINDING_NUMBER] = {NULL};
4221 for (curr = gfc_rename_list; curr; curr = curr->next)
4223 c_kind = get_c_kind (curr->use_name, c_interop_kinds_table);
4224 if (c_kind == ISOCBINDING_INVALID || c_kind == ISOCBINDING_LAST)
4226 gfc_error ("Symbol '%s' referenced at %L does not exist in "
4227 "intrinsic module ISO_C_BINDING.", curr->use_name,
4231 /* Put it in the list. */
4232 kinds_used[c_kind] = curr;
4235 /* Make a new (sorted) rename list. */
4237 while (i < ISOCBINDING_NUMBER && kinds_used[i] == NULL)
4240 if (i < ISOCBINDING_NUMBER)
4242 tmp_list = kinds_used[i];
4246 for (; i < ISOCBINDING_NUMBER; i++)
4247 if (kinds_used[i] != NULL)
4249 curr->next = kinds_used[i];
4255 gfc_rename_list = tmp_list;
4259 /* Import the intrinsic ISO_C_BINDING module, generating symbols in
4260 the current namespace for all named constants, pointer types, and
4261 procedures in the module unless the only clause was used or a rename
4262 list was provided. */
4265 import_iso_c_binding_module (void)
4267 gfc_symbol *mod_sym = NULL;
4268 gfc_symtree *mod_symtree = NULL;
4269 const char *iso_c_module_name = "__iso_c_binding";
4274 /* Look only in the current namespace. */
4275 mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, iso_c_module_name);
4277 if (mod_symtree == NULL)
4279 /* symtree doesn't already exist in current namespace. */
4280 gfc_get_sym_tree (iso_c_module_name, gfc_current_ns, &mod_symtree);
4282 if (mod_symtree != NULL)
4283 mod_sym = mod_symtree->n.sym;
4285 gfc_internal_error ("import_iso_c_binding_module(): Unable to "
4286 "create symbol for %s", iso_c_module_name);
4288 mod_sym->attr.flavor = FL_MODULE;
4289 mod_sym->attr.intrinsic = 1;
4290 mod_sym->module = gfc_get_string (iso_c_module_name);
4291 mod_sym->from_intmod = INTMOD_ISO_C_BINDING;
4294 /* Generate the symbols for the named constants representing
4295 the kinds for intrinsic data types. */
4298 /* Sort the rename list because there are dependencies between types
4299 and procedures (e.g., c_loc needs c_ptr). */
4300 sort_iso_c_rename_list ();
4302 for (u = gfc_rename_list; u; u = u->next)
4304 i = get_c_kind (u->use_name, c_interop_kinds_table);
4306 if (i == ISOCBINDING_INVALID || i == ISOCBINDING_LAST)
4308 gfc_error ("Symbol '%s' referenced at %L does not exist in "
4309 "intrinsic module ISO_C_BINDING.", u->use_name,
4314 generate_isocbinding_symbol (iso_c_module_name, i, u->local_name);
4319 for (i = 0; i < ISOCBINDING_NUMBER; i++)
4322 for (u = gfc_rename_list; u; u = u->next)
4324 if (strcmp (c_interop_kinds_table[i].name, u->use_name) == 0)
4326 local_name = u->local_name;
4331 generate_isocbinding_symbol (iso_c_module_name, i, local_name);
4334 for (u = gfc_rename_list; u; u = u->next)
4339 gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
4340 "module ISO_C_BINDING", u->use_name, &u->where);
4346 /* Add an integer named constant from a given module. */
4349 create_int_parameter (const char *name, int value, const char *modname,
4350 intmod_id module, int id)
4352 gfc_symtree *tmp_symtree;
4355 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
4356 if (tmp_symtree != NULL)
4358 if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
4361 gfc_error ("Symbol '%s' already declared", name);
4364 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree);
4365 sym = tmp_symtree->n.sym;
4367 sym->module = gfc_get_string (modname);
4368 sym->attr.flavor = FL_PARAMETER;
4369 sym->ts.type = BT_INTEGER;
4370 sym->ts.kind = gfc_default_integer_kind;
4371 sym->value = gfc_int_expr (value);
4372 sym->attr.use_assoc = 1;
4373 sym->from_intmod = module;
4374 sym->intmod_sym_id = id;
4378 /* USE the ISO_FORTRAN_ENV intrinsic module. */
4381 use_iso_fortran_env_module (void)
4383 static char mod[] = "iso_fortran_env";
4384 const char *local_name;
4386 gfc_symbol *mod_sym;
4387 gfc_symtree *mod_symtree;
4390 intmod_sym symbol[] = {
4391 #define NAMED_INTCST(a,b,c) { a, b, 0 },
4392 #include "iso-fortran-env.def"
4394 { ISOFORTRANENV_INVALID, NULL, -1234 } };
4397 #define NAMED_INTCST(a,b,c) symbol[i++].value = c;
4398 #include "iso-fortran-env.def"
4401 /* Generate the symbol for the module itself. */
4402 mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, mod);
4403 if (mod_symtree == NULL)
4405 gfc_get_sym_tree (mod, gfc_current_ns, &mod_symtree);
4406 gcc_assert (mod_symtree);
4407 mod_sym = mod_symtree->n.sym;
4409 mod_sym->attr.flavor = FL_MODULE;
4410 mod_sym->attr.intrinsic = 1;
4411 mod_sym->module = gfc_get_string (mod);
4412 mod_sym->from_intmod = INTMOD_ISO_FORTRAN_ENV;
4415 if (!mod_symtree->n.sym->attr.intrinsic)
4416 gfc_error ("Use of intrinsic module '%s' at %C conflicts with "
4417 "non-intrinsic module name used previously", mod);
4419 /* Generate the symbols for the module integer named constants. */
4421 for (u = gfc_rename_list; u; u = u->next)
4423 for (i = 0; symbol[i].name; i++)
4424 if (strcmp (symbol[i].name, u->use_name) == 0)
4427 if (symbol[i].name == NULL)
4429 gfc_error ("Symbol '%s' referenced at %L does not exist in "
4430 "intrinsic module ISO_FORTRAN_ENV", u->use_name,
4435 if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
4436 && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
4437 gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
4438 "from intrinsic module ISO_FORTRAN_ENV at %L is "
4439 "incompatible with option %s", &u->where,
4440 gfc_option.flag_default_integer
4441 ? "-fdefault-integer-8" : "-fdefault-real-8");
4443 create_int_parameter (u->local_name[0] ? u->local_name
4445 symbol[i].value, mod, INTMOD_ISO_FORTRAN_ENV,
4450 for (i = 0; symbol[i].name; i++)
4453 for (u = gfc_rename_list; u; u = u->next)
4455 if (strcmp (symbol[i].name, u->use_name) == 0)
4457 local_name = u->local_name;
4463 if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
4464 && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
4465 gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
4466 "from intrinsic module ISO_FORTRAN_ENV at %C is "
4467 "incompatible with option %s",
4468 gfc_option.flag_default_integer
4469 ? "-fdefault-integer-8" : "-fdefault-real-8");
4471 create_int_parameter (local_name ? local_name : symbol[i].name,
4472 symbol[i].value, mod, INTMOD_ISO_FORTRAN_ENV,
4476 for (u = gfc_rename_list; u; u = u->next)
4481 gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
4482 "module ISO_FORTRAN_ENV", u->use_name, &u->where);
4488 /* Process a USE directive. */
4491 gfc_use_module (void)
4496 gfc_symtree *mod_symtree;
4498 filename = (char *) alloca (strlen (module_name) + strlen (MODULE_EXTENSION)
4500 strcpy (filename, module_name);
4501 strcat (filename, MODULE_EXTENSION);
4503 /* First, try to find an non-intrinsic module, unless the USE statement
4504 specified that the module is intrinsic. */
4507 module_fp = gfc_open_included_file (filename, true, true);
4509 /* Then, see if it's an intrinsic one, unless the USE statement
4510 specified that the module is non-intrinsic. */
4511 if (module_fp == NULL && !specified_nonint)
4513 if (strcmp (module_name, "iso_fortran_env") == 0
4514 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ISO_FORTRAN_ENV "
4515 "intrinsic module at %C") != FAILURE)
4517 use_iso_fortran_env_module ();
4521 if (strcmp (module_name, "iso_c_binding") == 0
4522 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: "
4523 "ISO_C_BINDING module at %C") != FAILURE)
4525 import_iso_c_binding_module();
4529 module_fp = gfc_open_intrinsic_module (filename);
4531 if (module_fp == NULL && specified_int)
4532 gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C",
4536 if (module_fp == NULL)
4537 gfc_fatal_error ("Can't open module file '%s' for reading at %C: %s",
4538 filename, strerror (errno));
4540 /* Check that we haven't already USEd an intrinsic module with the
4543 mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, module_name);
4544 if (mod_symtree && mod_symtree->n.sym->attr.intrinsic)
4545 gfc_error ("Use of non-intrinsic module '%s' at %C conflicts with "
4546 "intrinsic module name used previously", module_name);
4553 /* Skip the first two lines of the module, after checking that this is
4554 a gfortran module file. */
4560 bad_module ("Unexpected end of module");
4563 if ((start == 1 && strcmp (atom_name, "GFORTRAN") != 0)
4564 || (start == 2 && strcmp (atom_name, " module") != 0))
4565 gfc_fatal_error ("File '%s' opened at %C is not a GFORTRAN module "
4572 /* Make sure we're not reading the same module that we may be building. */
4573 for (p = gfc_state_stack; p; p = p->previous)
4574 if (p->state == COMP_MODULE && strcmp (p->sym->name, module_name) == 0)
4575 gfc_fatal_error ("Can't USE the same module we're building!");
4578 init_true_name_tree ();
4582 free_true_name (true_name_root);
4583 true_name_root = NULL;
4585 free_pi_tree (pi_root);
4593 gfc_module_init_2 (void)
4595 last_atom = ATOM_LPAREN;
4600 gfc_module_done_2 (void)