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")
615 if (type == INTERFACE_USER_OP)
616 new->operator = INTRINSIC_USER;
621 strcpy (new->use_name, name);
624 strcpy (new->local_name, name);
625 m = gfc_match_generic_spec (&type2, new->use_name, &operator);
630 if (m == MATCH_ERROR)
638 strcpy (new->local_name, name);
640 m = gfc_match_generic_spec (&type2, new->use_name, &operator);
645 if (m == MATCH_ERROR)
649 if (strcmp (new->use_name, module_name) == 0
650 || strcmp (new->local_name, module_name) == 0)
652 gfc_error ("The name '%s' at %C has already been used as "
653 "an external module name.", module_name);
658 case INTERFACE_INTRINSIC_OP:
659 new->operator = operator;
666 if (gfc_match_eos () == MATCH_YES)
668 if (gfc_match_char (',') != MATCH_YES)
675 gfc_syntax_error (ST_USE);
683 /* Given a name and a number, inst, return the inst name
684 under which to load this symbol. Returns NULL if this
685 symbol shouldn't be loaded. If inst is zero, returns
686 the number of instances of this name. If interface is
687 true, a user-defined operator is sought, otherwise only
688 non-operators are sought. */
691 find_use_name_n (const char *name, int *inst, bool interface)
697 for (u = gfc_rename_list; u; u = u->next)
699 if (strcmp (u->use_name, name) != 0
700 || (u->operator == INTRINSIC_USER && !interface)
701 || (u->operator != INTRINSIC_USER && interface))
714 return only_flag ? NULL : name;
718 return (u->local_name[0] != '\0') ? u->local_name : name;
722 /* Given a name, return the name under which to load this symbol.
723 Returns NULL if this symbol shouldn't be loaded. */
726 find_use_name (const char *name, bool interface)
729 return find_use_name_n (name, &i, interface);
733 /* Given a real name, return the number of use names associated with it. */
736 number_use_names (const char *name, bool interface)
740 c = find_use_name_n (name, &i, interface);
745 /* Try to find the operator in the current list. */
747 static gfc_use_rename *
748 find_use_operator (gfc_intrinsic_op operator)
752 for (u = gfc_rename_list; u; u = u->next)
753 if (u->operator == operator)
760 /*****************************************************************/
762 /* The next couple of subroutines maintain a tree used to avoid a
763 brute-force search for a combination of true name and module name.
764 While symtree names, the name that a particular symbol is known by
765 can changed with USE statements, we still have to keep track of the
766 true names to generate the correct reference, and also avoid
767 loading the same real symbol twice in a program unit.
769 When we start reading, the true name tree is built and maintained
770 as symbols are read. The tree is searched as we load new symbols
771 to see if it already exists someplace in the namespace. */
773 typedef struct true_name
775 BBT_HEADER (true_name);
780 static true_name *true_name_root;
783 /* Compare two true_name structures. */
786 compare_true_names (void *_t1, void *_t2)
791 t1 = (true_name *) _t1;
792 t2 = (true_name *) _t2;
794 c = ((t1->sym->module > t2->sym->module)
795 - (t1->sym->module < t2->sym->module));
799 return strcmp (t1->sym->name, t2->sym->name);
803 /* Given a true name, search the true name tree to see if it exists
804 within the main namespace. */
807 find_true_name (const char *name, const char *module)
813 sym.name = gfc_get_string (name);
815 sym.module = gfc_get_string (module);
823 c = compare_true_names ((void *) (&t), (void *) p);
827 p = (c < 0) ? p->left : p->right;
834 /* Given a gfc_symbol pointer that is not in the true name tree, add it. */
837 add_true_name (gfc_symbol *sym)
841 t = gfc_getmem (sizeof (true_name));
844 gfc_insert_bbt (&true_name_root, t, compare_true_names);
848 /* Recursive function to build the initial true name tree by
849 recursively traversing the current namespace. */
852 build_tnt (gfc_symtree *st)
857 build_tnt (st->left);
858 build_tnt (st->right);
860 if (find_true_name (st->n.sym->name, st->n.sym->module) != NULL)
863 add_true_name (st->n.sym);
867 /* Initialize the true name tree with the current namespace. */
870 init_true_name_tree (void)
872 true_name_root = NULL;
873 build_tnt (gfc_current_ns->sym_root);
877 /* Recursively free a true name tree node. */
880 free_true_name (true_name *t)
884 free_true_name (t->left);
885 free_true_name (t->right);
891 /*****************************************************************/
893 /* Module reading and writing. */
897 ATOM_NAME, ATOM_LPAREN, ATOM_RPAREN, ATOM_INTEGER, ATOM_STRING
901 static atom_type last_atom;
904 /* The name buffer must be at least as long as a symbol name. Right
905 now it's not clear how we're going to store numeric constants--
906 probably as a hexadecimal string, since this will allow the exact
907 number to be preserved (this can't be done by a decimal
908 representation). Worry about that later. TODO! */
910 #define MAX_ATOM_SIZE 100
913 static char *atom_string, atom_name[MAX_ATOM_SIZE];
916 /* Report problems with a module. Error reporting is not very
917 elaborate, since this sorts of errors shouldn't really happen.
918 This subroutine never returns. */
920 static void bad_module (const char *) ATTRIBUTE_NORETURN;
923 bad_module (const char *msgid)
930 gfc_fatal_error ("Reading module %s at line %d column %d: %s",
931 module_name, module_line, module_column, msgid);
934 gfc_fatal_error ("Writing module %s at line %d column %d: %s",
935 module_name, module_line, module_column, msgid);
938 gfc_fatal_error ("Module %s at line %d column %d: %s",
939 module_name, module_line, module_column, msgid);
945 /* Set the module's input pointer. */
948 set_module_locus (module_locus *m)
950 module_column = m->column;
951 module_line = m->line;
952 fsetpos (module_fp, &m->pos);
956 /* Get the module's input pointer so that we can restore it later. */
959 get_module_locus (module_locus *m)
961 m->column = module_column;
962 m->line = module_line;
963 fgetpos (module_fp, &m->pos);
967 /* Get the next character in the module, updating our reckoning of
975 c = getc (module_fp);
978 bad_module ("Unexpected EOF");
991 /* Parse a string constant. The delimiter is guaranteed to be a
1001 get_module_locus (&start);
1005 /* See how long the string is. */
1010 bad_module ("Unexpected end of module in string constant");
1028 set_module_locus (&start);
1030 atom_string = p = gfc_getmem (len + 1);
1032 for (; len > 0; len--)
1036 module_char (); /* Guaranteed to be another \'. */
1040 module_char (); /* Terminating \'. */
1041 *p = '\0'; /* C-style string for debug purposes. */
1045 /* Parse a small integer. */
1048 parse_integer (int c)
1056 get_module_locus (&m);
1062 atom_int = 10 * atom_int + c - '0';
1063 if (atom_int > 99999999)
1064 bad_module ("Integer overflow");
1067 set_module_locus (&m);
1085 get_module_locus (&m);
1090 if (!ISALNUM (c) && c != '_' && c != '-')
1094 if (++len > GFC_MAX_SYMBOL_LEN)
1095 bad_module ("Name too long");
1100 fseek (module_fp, -1, SEEK_CUR);
1101 module_column = m.column + len - 1;
1108 /* Read the next atom in the module's input stream. */
1119 while (c == ' ' || c == '\n');
1144 return ATOM_INTEGER;
1202 bad_module ("Bad name");
1209 /* Peek at the next atom on the input. */
1217 get_module_locus (&m);
1220 if (a == ATOM_STRING)
1221 gfc_free (atom_string);
1223 set_module_locus (&m);
1228 /* Read the next atom from the input, requiring that it be a
1232 require_atom (atom_type type)
1238 get_module_locus (&m);
1246 p = _("Expected name");
1249 p = _("Expected left parenthesis");
1252 p = _("Expected right parenthesis");
1255 p = _("Expected integer");
1258 p = _("Expected string");
1261 gfc_internal_error ("require_atom(): bad atom type required");
1264 set_module_locus (&m);
1270 /* Given a pointer to an mstring array, require that the current input
1271 be one of the strings in the array. We return the enum value. */
1274 find_enum (const mstring *m)
1278 i = gfc_string2code (m, atom_name);
1282 bad_module ("find_enum(): Enum not found");
1288 /**************** Module output subroutines ***************************/
1290 /* Output a character to a module file. */
1293 write_char (char out)
1295 if (putc (out, module_fp) == EOF)
1296 gfc_fatal_error ("Error writing modules file: %s", strerror (errno));
1298 /* Add this to our MD5. */
1299 md5_process_bytes (&out, sizeof (out), &ctx);
1311 /* Write an atom to a module. The line wrapping isn't perfect, but it
1312 should work most of the time. This isn't that big of a deal, since
1313 the file really isn't meant to be read by people anyway. */
1316 write_atom (atom_type atom, const void *v)
1338 i = *((const int *) v);
1340 gfc_internal_error ("write_atom(): Writing negative integer");
1342 sprintf (buffer, "%d", i);
1347 gfc_internal_error ("write_atom(): Trying to write dab atom");
1351 if(p == NULL || *p == '\0')
1356 if (atom != ATOM_RPAREN)
1358 if (module_column + len > 72)
1363 if (last_atom != ATOM_LPAREN && module_column != 1)
1368 if (atom == ATOM_STRING)
1371 while (p != NULL && *p)
1373 if (atom == ATOM_STRING && *p == '\'')
1378 if (atom == ATOM_STRING)
1386 /***************** Mid-level I/O subroutines *****************/
1388 /* These subroutines let their caller read or write atoms without
1389 caring about which of the two is actually happening. This lets a
1390 subroutine concentrate on the actual format of the data being
1393 static void mio_expr (gfc_expr **);
1394 pointer_info *mio_symbol_ref (gfc_symbol **);
1395 pointer_info *mio_interface_rest (gfc_interface **);
1396 static void mio_symtree_ref (gfc_symtree **);
1398 /* Read or write an enumerated value. On writing, we return the input
1399 value for the convenience of callers. We avoid using an integer
1400 pointer because enums are sometimes inside bitfields. */
1403 mio_name (int t, const mstring *m)
1405 if (iomode == IO_OUTPUT)
1406 write_atom (ATOM_NAME, gfc_code2string (m, t));
1409 require_atom (ATOM_NAME);
1416 /* Specialization of mio_name. */
1418 #define DECL_MIO_NAME(TYPE) \
1419 static inline TYPE \
1420 MIO_NAME(TYPE) (TYPE t, const mstring *m) \
1422 return (TYPE) mio_name ((int) t, m); \
1424 #define MIO_NAME(TYPE) mio_name_##TYPE
1429 if (iomode == IO_OUTPUT)
1430 write_atom (ATOM_LPAREN, NULL);
1432 require_atom (ATOM_LPAREN);
1439 if (iomode == IO_OUTPUT)
1440 write_atom (ATOM_RPAREN, NULL);
1442 require_atom (ATOM_RPAREN);
1447 mio_integer (int *ip)
1449 if (iomode == IO_OUTPUT)
1450 write_atom (ATOM_INTEGER, ip);
1453 require_atom (ATOM_INTEGER);
1459 /* Read or write a character pointer that points to a string on the heap. */
1462 mio_allocated_string (const char *s)
1464 if (iomode == IO_OUTPUT)
1466 write_atom (ATOM_STRING, s);
1471 require_atom (ATOM_STRING);
1477 /* Read or write a string that is in static memory. */
1480 mio_pool_string (const char **stringp)
1482 /* TODO: one could write the string only once, and refer to it via a
1485 /* As a special case we have to deal with a NULL string. This
1486 happens for the 'module' member of 'gfc_symbol's that are not in a
1487 module. We read / write these as the empty string. */
1488 if (iomode == IO_OUTPUT)
1490 const char *p = *stringp == NULL ? "" : *stringp;
1491 write_atom (ATOM_STRING, p);
1495 require_atom (ATOM_STRING);
1496 *stringp = atom_string[0] == '\0' ? NULL : gfc_get_string (atom_string);
1497 gfc_free (atom_string);
1502 /* Read or write a string that is inside of some already-allocated
1506 mio_internal_string (char *string)
1508 if (iomode == IO_OUTPUT)
1509 write_atom (ATOM_STRING, string);
1512 require_atom (ATOM_STRING);
1513 strcpy (string, atom_string);
1514 gfc_free (atom_string);
1520 { AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL,
1521 AB_POINTER, AB_TARGET, AB_DUMMY, AB_RESULT, AB_DATA,
1522 AB_IN_NAMELIST, AB_IN_COMMON, AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE,
1523 AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT,
1524 AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP,
1525 AB_POINTER_COMP, AB_PRIVATE_COMP, AB_VALUE, AB_VOLATILE, AB_PROTECTED,
1526 AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT
1530 static const mstring attr_bits[] =
1532 minit ("ALLOCATABLE", AB_ALLOCATABLE),
1533 minit ("DIMENSION", AB_DIMENSION),
1534 minit ("EXTERNAL", AB_EXTERNAL),
1535 minit ("INTRINSIC", AB_INTRINSIC),
1536 minit ("OPTIONAL", AB_OPTIONAL),
1537 minit ("POINTER", AB_POINTER),
1538 minit ("VOLATILE", AB_VOLATILE),
1539 minit ("TARGET", AB_TARGET),
1540 minit ("THREADPRIVATE", AB_THREADPRIVATE),
1541 minit ("DUMMY", AB_DUMMY),
1542 minit ("RESULT", AB_RESULT),
1543 minit ("DATA", AB_DATA),
1544 minit ("IN_NAMELIST", AB_IN_NAMELIST),
1545 minit ("IN_COMMON", AB_IN_COMMON),
1546 minit ("FUNCTION", AB_FUNCTION),
1547 minit ("SUBROUTINE", AB_SUBROUTINE),
1548 minit ("SEQUENCE", AB_SEQUENCE),
1549 minit ("ELEMENTAL", AB_ELEMENTAL),
1550 minit ("PURE", AB_PURE),
1551 minit ("RECURSIVE", AB_RECURSIVE),
1552 minit ("GENERIC", AB_GENERIC),
1553 minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT),
1554 minit ("CRAY_POINTER", AB_CRAY_POINTER),
1555 minit ("CRAY_POINTEE", AB_CRAY_POINTEE),
1556 minit ("IS_BIND_C", AB_IS_BIND_C),
1557 minit ("IS_C_INTEROP", AB_IS_C_INTEROP),
1558 minit ("IS_ISO_C", AB_IS_ISO_C),
1559 minit ("VALUE", AB_VALUE),
1560 minit ("ALLOC_COMP", AB_ALLOC_COMP),
1561 minit ("POINTER_COMP", AB_POINTER_COMP),
1562 minit ("PRIVATE_COMP", AB_PRIVATE_COMP),
1563 minit ("PROTECTED", AB_PROTECTED),
1564 minit ("ABSTRACT", AB_ABSTRACT),
1569 /* Specialization of mio_name. */
1570 DECL_MIO_NAME (ab_attribute)
1571 DECL_MIO_NAME (ar_type)
1572 DECL_MIO_NAME (array_type)
1574 DECL_MIO_NAME (expr_t)
1575 DECL_MIO_NAME (gfc_access)
1576 DECL_MIO_NAME (gfc_intrinsic_op)
1577 DECL_MIO_NAME (ifsrc)
1578 DECL_MIO_NAME (save_state)
1579 DECL_MIO_NAME (procedure_type)
1580 DECL_MIO_NAME (ref_type)
1581 DECL_MIO_NAME (sym_flavor)
1582 DECL_MIO_NAME (sym_intent)
1583 #undef DECL_MIO_NAME
1585 /* Symbol attributes are stored in list with the first three elements
1586 being the enumerated fields, while the remaining elements (if any)
1587 indicate the individual attribute bits. The access field is not
1588 saved-- it controls what symbols are exported when a module is
1592 mio_symbol_attribute (symbol_attribute *attr)
1598 attr->flavor = MIO_NAME (sym_flavor) (attr->flavor, flavors);
1599 attr->intent = MIO_NAME (sym_intent) (attr->intent, intents);
1600 attr->proc = MIO_NAME (procedure_type) (attr->proc, procedures);
1601 attr->if_source = MIO_NAME (ifsrc) (attr->if_source, ifsrc_types);
1602 attr->save = MIO_NAME (save_state) (attr->save, save_status);
1604 if (iomode == IO_OUTPUT)
1606 if (attr->allocatable)
1607 MIO_NAME (ab_attribute) (AB_ALLOCATABLE, attr_bits);
1608 if (attr->dimension)
1609 MIO_NAME (ab_attribute) (AB_DIMENSION, attr_bits);
1611 MIO_NAME (ab_attribute) (AB_EXTERNAL, attr_bits);
1612 if (attr->intrinsic)
1613 MIO_NAME (ab_attribute) (AB_INTRINSIC, attr_bits);
1615 MIO_NAME (ab_attribute) (AB_OPTIONAL, attr_bits);
1617 MIO_NAME (ab_attribute) (AB_POINTER, attr_bits);
1618 if (attr->protected)
1619 MIO_NAME (ab_attribute) (AB_PROTECTED, attr_bits);
1621 MIO_NAME (ab_attribute) (AB_VALUE, attr_bits);
1622 if (attr->volatile_)
1623 MIO_NAME (ab_attribute) (AB_VOLATILE, attr_bits);
1625 MIO_NAME (ab_attribute) (AB_TARGET, attr_bits);
1626 if (attr->threadprivate)
1627 MIO_NAME (ab_attribute) (AB_THREADPRIVATE, attr_bits);
1629 MIO_NAME (ab_attribute) (AB_DUMMY, attr_bits);
1631 MIO_NAME (ab_attribute) (AB_RESULT, attr_bits);
1632 /* We deliberately don't preserve the "entry" flag. */
1635 MIO_NAME (ab_attribute) (AB_DATA, attr_bits);
1636 if (attr->in_namelist)
1637 MIO_NAME (ab_attribute) (AB_IN_NAMELIST, attr_bits);
1638 if (attr->in_common)
1639 MIO_NAME (ab_attribute) (AB_IN_COMMON, attr_bits);
1642 MIO_NAME (ab_attribute) (AB_FUNCTION, attr_bits);
1643 if (attr->subroutine)
1644 MIO_NAME (ab_attribute) (AB_SUBROUTINE, attr_bits);
1646 MIO_NAME (ab_attribute) (AB_GENERIC, attr_bits);
1648 MIO_NAME (ab_attribute) (AB_ABSTRACT, attr_bits);
1651 MIO_NAME (ab_attribute) (AB_SEQUENCE, attr_bits);
1652 if (attr->elemental)
1653 MIO_NAME (ab_attribute) (AB_ELEMENTAL, attr_bits);
1655 MIO_NAME (ab_attribute) (AB_PURE, attr_bits);
1656 if (attr->recursive)
1657 MIO_NAME (ab_attribute) (AB_RECURSIVE, attr_bits);
1658 if (attr->always_explicit)
1659 MIO_NAME (ab_attribute) (AB_ALWAYS_EXPLICIT, attr_bits);
1660 if (attr->cray_pointer)
1661 MIO_NAME (ab_attribute) (AB_CRAY_POINTER, attr_bits);
1662 if (attr->cray_pointee)
1663 MIO_NAME (ab_attribute) (AB_CRAY_POINTEE, attr_bits);
1664 if (attr->is_bind_c)
1665 MIO_NAME(ab_attribute) (AB_IS_BIND_C, attr_bits);
1666 if (attr->is_c_interop)
1667 MIO_NAME(ab_attribute) (AB_IS_C_INTEROP, attr_bits);
1669 MIO_NAME(ab_attribute) (AB_IS_ISO_C, attr_bits);
1670 if (attr->alloc_comp)
1671 MIO_NAME (ab_attribute) (AB_ALLOC_COMP, attr_bits);
1672 if (attr->pointer_comp)
1673 MIO_NAME (ab_attribute) (AB_POINTER_COMP, attr_bits);
1674 if (attr->private_comp)
1675 MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits);
1685 if (t == ATOM_RPAREN)
1688 bad_module ("Expected attribute bit name");
1690 switch ((ab_attribute) find_enum (attr_bits))
1692 case AB_ALLOCATABLE:
1693 attr->allocatable = 1;
1696 attr->dimension = 1;
1702 attr->intrinsic = 1;
1711 attr->protected = 1;
1717 attr->volatile_ = 1;
1722 case AB_THREADPRIVATE:
1723 attr->threadprivate = 1;
1734 case AB_IN_NAMELIST:
1735 attr->in_namelist = 1;
1738 attr->in_common = 1;
1744 attr->subroutine = 1;
1756 attr->elemental = 1;
1762 attr->recursive = 1;
1764 case AB_ALWAYS_EXPLICIT:
1765 attr->always_explicit = 1;
1767 case AB_CRAY_POINTER:
1768 attr->cray_pointer = 1;
1770 case AB_CRAY_POINTEE:
1771 attr->cray_pointee = 1;
1774 attr->is_bind_c = 1;
1776 case AB_IS_C_INTEROP:
1777 attr->is_c_interop = 1;
1783 attr->alloc_comp = 1;
1785 case AB_POINTER_COMP:
1786 attr->pointer_comp = 1;
1788 case AB_PRIVATE_COMP:
1789 attr->private_comp = 1;
1797 static const mstring bt_types[] = {
1798 minit ("INTEGER", BT_INTEGER),
1799 minit ("REAL", BT_REAL),
1800 minit ("COMPLEX", BT_COMPLEX),
1801 minit ("LOGICAL", BT_LOGICAL),
1802 minit ("CHARACTER", BT_CHARACTER),
1803 minit ("DERIVED", BT_DERIVED),
1804 minit ("PROCEDURE", BT_PROCEDURE),
1805 minit ("UNKNOWN", BT_UNKNOWN),
1806 minit ("VOID", BT_VOID),
1812 mio_charlen (gfc_charlen **clp)
1818 if (iomode == IO_OUTPUT)
1822 mio_expr (&cl->length);
1826 if (peek_atom () != ATOM_RPAREN)
1828 cl = gfc_get_charlen ();
1829 mio_expr (&cl->length);
1833 cl->next = gfc_current_ns->cl_list;
1834 gfc_current_ns->cl_list = cl;
1842 /* See if a name is a generated name. */
1845 check_unique_name (const char *name)
1847 return *name == '@';
1852 mio_typespec (gfc_typespec *ts)
1856 ts->type = MIO_NAME (bt) (ts->type, bt_types);
1858 if (ts->type != BT_DERIVED)
1859 mio_integer (&ts->kind);
1861 mio_symbol_ref (&ts->derived);
1863 /* Add info for C interop and is_iso_c. */
1864 mio_integer (&ts->is_c_interop);
1865 mio_integer (&ts->is_iso_c);
1867 /* If the typespec is for an identifier either from iso_c_binding, or
1868 a constant that was initialized to an identifier from it, use the
1869 f90_type. Otherwise, use the ts->type, since it shouldn't matter. */
1871 ts->f90_type = MIO_NAME (bt) (ts->f90_type, bt_types);
1873 ts->f90_type = MIO_NAME (bt) (ts->type, bt_types);
1875 if (ts->type != BT_CHARACTER)
1877 /* ts->cl is only valid for BT_CHARACTER. */
1882 mio_charlen (&ts->cl);
1888 static const mstring array_spec_types[] = {
1889 minit ("EXPLICIT", AS_EXPLICIT),
1890 minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE),
1891 minit ("DEFERRED", AS_DEFERRED),
1892 minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE),
1898 mio_array_spec (gfc_array_spec **asp)
1905 if (iomode == IO_OUTPUT)
1913 if (peek_atom () == ATOM_RPAREN)
1919 *asp = as = gfc_get_array_spec ();
1922 mio_integer (&as->rank);
1923 as->type = MIO_NAME (array_type) (as->type, array_spec_types);
1925 for (i = 0; i < as->rank; i++)
1927 mio_expr (&as->lower[i]);
1928 mio_expr (&as->upper[i]);
1936 /* Given a pointer to an array reference structure (which lives in a
1937 gfc_ref structure), find the corresponding array specification
1938 structure. Storing the pointer in the ref structure doesn't quite
1939 work when loading from a module. Generating code for an array
1940 reference also needs more information than just the array spec. */
1942 static const mstring array_ref_types[] = {
1943 minit ("FULL", AR_FULL),
1944 minit ("ELEMENT", AR_ELEMENT),
1945 minit ("SECTION", AR_SECTION),
1951 mio_array_ref (gfc_array_ref *ar)
1956 ar->type = MIO_NAME (ar_type) (ar->type, array_ref_types);
1957 mio_integer (&ar->dimen);
1965 for (i = 0; i < ar->dimen; i++)
1966 mio_expr (&ar->start[i]);
1971 for (i = 0; i < ar->dimen; i++)
1973 mio_expr (&ar->start[i]);
1974 mio_expr (&ar->end[i]);
1975 mio_expr (&ar->stride[i]);
1981 gfc_internal_error ("mio_array_ref(): Unknown array ref");
1984 /* Unfortunately, ar->dimen_type is an anonymous enumerated type so
1985 we can't call mio_integer directly. Instead loop over each element
1986 and cast it to/from an integer. */
1987 if (iomode == IO_OUTPUT)
1989 for (i = 0; i < ar->dimen; i++)
1991 int tmp = (int)ar->dimen_type[i];
1992 write_atom (ATOM_INTEGER, &tmp);
1997 for (i = 0; i < ar->dimen; i++)
1999 require_atom (ATOM_INTEGER);
2000 ar->dimen_type[i] = atom_int;
2004 if (iomode == IO_INPUT)
2006 ar->where = gfc_current_locus;
2008 for (i = 0; i < ar->dimen; i++)
2009 ar->c_where[i] = gfc_current_locus;
2016 /* Saves or restores a pointer. The pointer is converted back and
2017 forth from an integer. We return the pointer_info pointer so that
2018 the caller can take additional action based on the pointer type. */
2020 static pointer_info *
2021 mio_pointer_ref (void *gp)
2025 if (iomode == IO_OUTPUT)
2027 p = get_pointer (*((char **) gp));
2028 write_atom (ATOM_INTEGER, &p->integer);
2032 require_atom (ATOM_INTEGER);
2033 p = add_fixup (atom_int, gp);
2040 /* Save and load references to components that occur within
2041 expressions. We have to describe these references by a number and
2042 by name. The number is necessary for forward references during
2043 reading, and the name is necessary if the symbol already exists in
2044 the namespace and is not loaded again. */
2047 mio_component_ref (gfc_component **cp, gfc_symbol *sym)
2049 char name[GFC_MAX_SYMBOL_LEN + 1];
2053 p = mio_pointer_ref (cp);
2054 if (p->type == P_UNKNOWN)
2055 p->type = P_COMPONENT;
2057 if (iomode == IO_OUTPUT)
2058 mio_pool_string (&(*cp)->name);
2061 mio_internal_string (name);
2063 /* It can happen that a component reference can be read before the
2064 associated derived type symbol has been loaded. Return now and
2065 wait for a later iteration of load_needed. */
2069 if (sym->components != NULL && p->u.pointer == NULL)
2071 /* Symbol already loaded, so search by name. */
2072 for (q = sym->components; q; q = q->next)
2073 if (strcmp (q->name, name) == 0)
2077 gfc_internal_error ("mio_component_ref(): Component not found");
2079 associate_integer_pointer (p, q);
2082 /* Make sure this symbol will eventually be loaded. */
2083 p = find_pointer2 (sym);
2084 if (p->u.rsym.state == UNUSED)
2085 p->u.rsym.state = NEEDED;
2091 mio_component (gfc_component *c)
2098 if (iomode == IO_OUTPUT)
2100 p = get_pointer (c);
2101 mio_integer (&p->integer);
2106 p = get_integer (n);
2107 associate_integer_pointer (p, c);
2110 if (p->type == P_UNKNOWN)
2111 p->type = P_COMPONENT;
2113 mio_pool_string (&c->name);
2114 mio_typespec (&c->ts);
2115 mio_array_spec (&c->as);
2117 mio_integer (&c->dimension);
2118 mio_integer (&c->pointer);
2119 mio_integer (&c->allocatable);
2120 c->access = MIO_NAME (gfc_access) (c->access, access_types);
2122 mio_expr (&c->initializer);
2128 mio_component_list (gfc_component **cp)
2130 gfc_component *c, *tail;
2134 if (iomode == IO_OUTPUT)
2136 for (c = *cp; c; c = c->next)
2146 if (peek_atom () == ATOM_RPAREN)
2149 c = gfc_get_component ();
2166 mio_actual_arg (gfc_actual_arglist *a)
2169 mio_pool_string (&a->name);
2170 mio_expr (&a->expr);
2176 mio_actual_arglist (gfc_actual_arglist **ap)
2178 gfc_actual_arglist *a, *tail;
2182 if (iomode == IO_OUTPUT)
2184 for (a = *ap; a; a = a->next)
2194 if (peek_atom () != ATOM_LPAREN)
2197 a = gfc_get_actual_arglist ();
2213 /* Read and write formal argument lists. */
2216 mio_formal_arglist (gfc_symbol *sym)
2218 gfc_formal_arglist *f, *tail;
2222 if (iomode == IO_OUTPUT)
2224 for (f = sym->formal; f; f = f->next)
2225 mio_symbol_ref (&f->sym);
2229 sym->formal = tail = NULL;
2231 while (peek_atom () != ATOM_RPAREN)
2233 f = gfc_get_formal_arglist ();
2234 mio_symbol_ref (&f->sym);
2236 if (sym->formal == NULL)
2249 /* Save or restore a reference to a symbol node. */
2252 mio_symbol_ref (gfc_symbol **symp)
2256 p = mio_pointer_ref (symp);
2257 if (p->type == P_UNKNOWN)
2260 if (iomode == IO_OUTPUT)
2262 if (p->u.wsym.state == UNREFERENCED)
2263 p->u.wsym.state = NEEDS_WRITE;
2267 if (p->u.rsym.state == UNUSED)
2268 p->u.rsym.state = NEEDED;
2274 /* Save or restore a reference to a symtree node. */
2277 mio_symtree_ref (gfc_symtree **stp)
2282 if (iomode == IO_OUTPUT)
2283 mio_symbol_ref (&(*stp)->n.sym);
2286 require_atom (ATOM_INTEGER);
2287 p = get_integer (atom_int);
2289 /* An unused equivalence member; make a symbol and a symtree
2291 if (in_load_equiv && p->u.rsym.symtree == NULL)
2293 /* Since this is not used, it must have a unique name. */
2294 p->u.rsym.symtree = gfc_get_unique_symtree (gfc_current_ns);
2296 /* Make the symbol. */
2297 if (p->u.rsym.sym == NULL)
2299 p->u.rsym.sym = gfc_new_symbol (p->u.rsym.true_name,
2301 p->u.rsym.sym->module = gfc_get_string (p->u.rsym.module);
2304 p->u.rsym.symtree->n.sym = p->u.rsym.sym;
2305 p->u.rsym.symtree->n.sym->refs++;
2306 p->u.rsym.referenced = 1;
2309 if (p->type == P_UNKNOWN)
2312 if (p->u.rsym.state == UNUSED)
2313 p->u.rsym.state = NEEDED;
2315 if (p->u.rsym.symtree != NULL)
2317 *stp = p->u.rsym.symtree;
2321 f = gfc_getmem (sizeof (fixup_t));
2323 f->next = p->u.rsym.stfixup;
2324 p->u.rsym.stfixup = f;
2326 f->pointer = (void **) stp;
2333 mio_iterator (gfc_iterator **ip)
2339 if (iomode == IO_OUTPUT)
2346 if (peek_atom () == ATOM_RPAREN)
2352 *ip = gfc_get_iterator ();
2357 mio_expr (&iter->var);
2358 mio_expr (&iter->start);
2359 mio_expr (&iter->end);
2360 mio_expr (&iter->step);
2368 mio_constructor (gfc_constructor **cp)
2370 gfc_constructor *c, *tail;
2374 if (iomode == IO_OUTPUT)
2376 for (c = *cp; c; c = c->next)
2379 mio_expr (&c->expr);
2380 mio_iterator (&c->iterator);
2389 while (peek_atom () != ATOM_RPAREN)
2391 c = gfc_get_constructor ();
2401 mio_expr (&c->expr);
2402 mio_iterator (&c->iterator);
2411 static const mstring ref_types[] = {
2412 minit ("ARRAY", REF_ARRAY),
2413 minit ("COMPONENT", REF_COMPONENT),
2414 minit ("SUBSTRING", REF_SUBSTRING),
2420 mio_ref (gfc_ref **rp)
2427 r->type = MIO_NAME (ref_type) (r->type, ref_types);
2432 mio_array_ref (&r->u.ar);
2436 mio_symbol_ref (&r->u.c.sym);
2437 mio_component_ref (&r->u.c.component, r->u.c.sym);
2441 mio_expr (&r->u.ss.start);
2442 mio_expr (&r->u.ss.end);
2443 mio_charlen (&r->u.ss.length);
2452 mio_ref_list (gfc_ref **rp)
2454 gfc_ref *ref, *head, *tail;
2458 if (iomode == IO_OUTPUT)
2460 for (ref = *rp; ref; ref = ref->next)
2467 while (peek_atom () != ATOM_RPAREN)
2470 head = tail = gfc_get_ref ();
2473 tail->next = gfc_get_ref ();
2487 /* Read and write an integer value. */
2490 mio_gmp_integer (mpz_t *integer)
2494 if (iomode == IO_INPUT)
2496 if (parse_atom () != ATOM_STRING)
2497 bad_module ("Expected integer string");
2499 mpz_init (*integer);
2500 if (mpz_set_str (*integer, atom_string, 10))
2501 bad_module ("Error converting integer");
2503 gfc_free (atom_string);
2507 p = mpz_get_str (NULL, 10, *integer);
2508 write_atom (ATOM_STRING, p);
2515 mio_gmp_real (mpfr_t *real)
2520 if (iomode == IO_INPUT)
2522 if (parse_atom () != ATOM_STRING)
2523 bad_module ("Expected real string");
2526 mpfr_set_str (*real, atom_string, 16, GFC_RND_MODE);
2527 gfc_free (atom_string);
2531 p = mpfr_get_str (NULL, &exponent, 16, 0, *real, GFC_RND_MODE);
2532 atom_string = gfc_getmem (strlen (p) + 20);
2534 sprintf (atom_string, "0.%s@%ld", p, exponent);
2536 /* Fix negative numbers. */
2537 if (atom_string[2] == '-')
2539 atom_string[0] = '-';
2540 atom_string[1] = '0';
2541 atom_string[2] = '.';
2544 write_atom (ATOM_STRING, atom_string);
2546 gfc_free (atom_string);
2552 /* Save and restore the shape of an array constructor. */
2555 mio_shape (mpz_t **pshape, int rank)
2561 /* A NULL shape is represented by (). */
2564 if (iomode == IO_OUTPUT)
2576 if (t == ATOM_RPAREN)
2583 shape = gfc_get_shape (rank);
2587 for (n = 0; n < rank; n++)
2588 mio_gmp_integer (&shape[n]);
2594 static const mstring expr_types[] = {
2595 minit ("OP", EXPR_OP),
2596 minit ("FUNCTION", EXPR_FUNCTION),
2597 minit ("CONSTANT", EXPR_CONSTANT),
2598 minit ("VARIABLE", EXPR_VARIABLE),
2599 minit ("SUBSTRING", EXPR_SUBSTRING),
2600 minit ("STRUCTURE", EXPR_STRUCTURE),
2601 minit ("ARRAY", EXPR_ARRAY),
2602 minit ("NULL", EXPR_NULL),
2606 /* INTRINSIC_ASSIGN is missing because it is used as an index for
2607 generic operators, not in expressions. INTRINSIC_USER is also
2608 replaced by the correct function name by the time we see it. */
2610 static const mstring intrinsics[] =
2612 minit ("UPLUS", INTRINSIC_UPLUS),
2613 minit ("UMINUS", INTRINSIC_UMINUS),
2614 minit ("PLUS", INTRINSIC_PLUS),
2615 minit ("MINUS", INTRINSIC_MINUS),
2616 minit ("TIMES", INTRINSIC_TIMES),
2617 minit ("DIVIDE", INTRINSIC_DIVIDE),
2618 minit ("POWER", INTRINSIC_POWER),
2619 minit ("CONCAT", INTRINSIC_CONCAT),
2620 minit ("AND", INTRINSIC_AND),
2621 minit ("OR", INTRINSIC_OR),
2622 minit ("EQV", INTRINSIC_EQV),
2623 minit ("NEQV", INTRINSIC_NEQV),
2624 minit ("==", INTRINSIC_EQ),
2625 minit ("EQ", INTRINSIC_EQ_OS),
2626 minit ("/=", INTRINSIC_NE),
2627 minit ("NE", INTRINSIC_NE_OS),
2628 minit (">", INTRINSIC_GT),
2629 minit ("GT", INTRINSIC_GT_OS),
2630 minit (">=", INTRINSIC_GE),
2631 minit ("GE", INTRINSIC_GE_OS),
2632 minit ("<", INTRINSIC_LT),
2633 minit ("LT", INTRINSIC_LT_OS),
2634 minit ("<=", INTRINSIC_LE),
2635 minit ("LE", INTRINSIC_LE_OS),
2636 minit ("NOT", INTRINSIC_NOT),
2637 minit ("PARENTHESES", INTRINSIC_PARENTHESES),
2642 /* Remedy a couple of situations where the gfc_expr's can be defective. */
2645 fix_mio_expr (gfc_expr *e)
2647 gfc_symtree *ns_st = NULL;
2650 if (iomode != IO_OUTPUT)
2655 /* If this is a symtree for a symbol that came from a contained module
2656 namespace, it has a unique name and we should look in the current
2657 namespace to see if the required, non-contained symbol is available
2658 yet. If so, the latter should be written. */
2659 if (e->symtree->n.sym && check_unique_name (e->symtree->name))
2660 ns_st = gfc_find_symtree (gfc_current_ns->sym_root,
2661 e->symtree->n.sym->name);
2663 /* On the other hand, if the existing symbol is the module name or the
2664 new symbol is a dummy argument, do not do the promotion. */
2665 if (ns_st && ns_st->n.sym
2666 && ns_st->n.sym->attr.flavor != FL_MODULE
2667 && !e->symtree->n.sym->attr.dummy)
2670 else if (e->expr_type == EXPR_FUNCTION && e->value.function.name)
2672 /* In some circumstances, a function used in an initialization
2673 expression, in one use associated module, can fail to be
2674 coupled to its symtree when used in a specification
2675 expression in another module. */
2676 fname = e->value.function.esym ? e->value.function.esym->name
2677 : e->value.function.isym->name;
2678 e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
2683 /* Read and write expressions. The form "()" is allowed to indicate a
2687 mio_expr (gfc_expr **ep)
2695 if (iomode == IO_OUTPUT)
2704 MIO_NAME (expr_t) (e->expr_type, expr_types);
2709 if (t == ATOM_RPAREN)
2716 bad_module ("Expected expression type");
2718 e = *ep = gfc_get_expr ();
2719 e->where = gfc_current_locus;
2720 e->expr_type = (expr_t) find_enum (expr_types);
2723 mio_typespec (&e->ts);
2724 mio_integer (&e->rank);
2728 switch (e->expr_type)
2731 e->value.op.operator
2732 = MIO_NAME (gfc_intrinsic_op) (e->value.op.operator, intrinsics);
2734 switch (e->value.op.operator)
2736 case INTRINSIC_UPLUS:
2737 case INTRINSIC_UMINUS:
2739 case INTRINSIC_PARENTHESES:
2740 mio_expr (&e->value.op.op1);
2743 case INTRINSIC_PLUS:
2744 case INTRINSIC_MINUS:
2745 case INTRINSIC_TIMES:
2746 case INTRINSIC_DIVIDE:
2747 case INTRINSIC_POWER:
2748 case INTRINSIC_CONCAT:
2752 case INTRINSIC_NEQV:
2754 case INTRINSIC_EQ_OS:
2756 case INTRINSIC_NE_OS:
2758 case INTRINSIC_GT_OS:
2760 case INTRINSIC_GE_OS:
2762 case INTRINSIC_LT_OS:
2764 case INTRINSIC_LE_OS:
2765 mio_expr (&e->value.op.op1);
2766 mio_expr (&e->value.op.op2);
2770 bad_module ("Bad operator");
2776 mio_symtree_ref (&e->symtree);
2777 mio_actual_arglist (&e->value.function.actual);
2779 if (iomode == IO_OUTPUT)
2781 e->value.function.name
2782 = mio_allocated_string (e->value.function.name);
2783 flag = e->value.function.esym != NULL;
2784 mio_integer (&flag);
2786 mio_symbol_ref (&e->value.function.esym);
2788 write_atom (ATOM_STRING, e->value.function.isym->name);
2792 require_atom (ATOM_STRING);
2793 e->value.function.name = gfc_get_string (atom_string);
2794 gfc_free (atom_string);
2796 mio_integer (&flag);
2798 mio_symbol_ref (&e->value.function.esym);
2801 require_atom (ATOM_STRING);
2802 e->value.function.isym = gfc_find_function (atom_string);
2803 gfc_free (atom_string);
2810 mio_symtree_ref (&e->symtree);
2811 mio_ref_list (&e->ref);
2814 case EXPR_SUBSTRING:
2815 e->value.character.string
2816 = (char *) mio_allocated_string (e->value.character.string);
2817 mio_ref_list (&e->ref);
2820 case EXPR_STRUCTURE:
2822 mio_constructor (&e->value.constructor);
2823 mio_shape (&e->shape, e->rank);
2830 mio_gmp_integer (&e->value.integer);
2834 gfc_set_model_kind (e->ts.kind);
2835 mio_gmp_real (&e->value.real);
2839 gfc_set_model_kind (e->ts.kind);
2840 mio_gmp_real (&e->value.complex.r);
2841 mio_gmp_real (&e->value.complex.i);
2845 mio_integer (&e->value.logical);
2849 mio_integer (&e->value.character.length);
2850 e->value.character.string
2851 = (char *) mio_allocated_string (e->value.character.string);
2855 bad_module ("Bad type in constant expression");
2868 /* Read and write namelists. */
2871 mio_namelist (gfc_symbol *sym)
2873 gfc_namelist *n, *m;
2874 const char *check_name;
2878 if (iomode == IO_OUTPUT)
2880 for (n = sym->namelist; n; n = n->next)
2881 mio_symbol_ref (&n->sym);
2885 /* This departure from the standard is flagged as an error.
2886 It does, in fact, work correctly. TODO: Allow it
2888 if (sym->attr.flavor == FL_NAMELIST)
2890 check_name = find_use_name (sym->name, false);
2891 if (check_name && strcmp (check_name, sym->name) != 0)
2892 gfc_error ("Namelist %s cannot be renamed by USE "
2893 "association to %s", sym->name, check_name);
2897 while (peek_atom () != ATOM_RPAREN)
2899 n = gfc_get_namelist ();
2900 mio_symbol_ref (&n->sym);
2902 if (sym->namelist == NULL)
2909 sym->namelist_tail = m;
2916 /* Save/restore lists of gfc_interface stuctures. When loading an
2917 interface, we are really appending to the existing list of
2918 interfaces. Checking for duplicate and ambiguous interfaces has to
2919 be done later when all symbols have been loaded. */
2922 mio_interface_rest (gfc_interface **ip)
2924 gfc_interface *tail, *p;
2925 pointer_info *pi = NULL;
2927 if (iomode == IO_OUTPUT)
2930 for (p = *ip; p; p = p->next)
2931 mio_symbol_ref (&p->sym);
2946 if (peek_atom () == ATOM_RPAREN)
2949 p = gfc_get_interface ();
2950 p->where = gfc_current_locus;
2951 pi = mio_symbol_ref (&p->sym);
2967 /* Save/restore a nameless operator interface. */
2970 mio_interface (gfc_interface **ip)
2973 mio_interface_rest (ip);
2977 /* Save/restore a named operator interface. */
2980 mio_symbol_interface (const char **name, const char **module,
2984 mio_pool_string (name);
2985 mio_pool_string (module);
2986 mio_interface_rest (ip);
2991 mio_namespace_ref (gfc_namespace **nsp)
2996 p = mio_pointer_ref (nsp);
2998 if (p->type == P_UNKNOWN)
2999 p->type = P_NAMESPACE;
3001 if (iomode == IO_INPUT && p->integer != 0)
3003 ns = (gfc_namespace *) p->u.pointer;
3006 ns = gfc_get_namespace (NULL, 0);
3007 associate_integer_pointer (p, ns);
3015 /* Unlike most other routines, the address of the symbol node is already
3016 fixed on input and the name/module has already been filled in. */
3019 mio_symbol (gfc_symbol *sym)
3021 int intmod = INTMOD_NONE;
3023 gfc_formal_arglist *formal;
3027 mio_symbol_attribute (&sym->attr);
3028 mio_typespec (&sym->ts);
3030 /* Contained procedures don't have formal namespaces. Instead we output the
3031 procedure namespace. The will contain the formal arguments. */
3032 if (iomode == IO_OUTPUT)
3034 formal = sym->formal;
3035 while (formal && !formal->sym)
3036 formal = formal->next;
3039 mio_namespace_ref (&formal->sym->ns);
3041 mio_namespace_ref (&sym->formal_ns);
3045 mio_namespace_ref (&sym->formal_ns);
3048 sym->formal_ns->proc_name = sym;
3053 /* Save/restore common block links. */
3054 mio_symbol_ref (&sym->common_next);
3056 mio_formal_arglist (sym);
3058 if (sym->attr.flavor == FL_PARAMETER)
3059 mio_expr (&sym->value);
3061 mio_array_spec (&sym->as);
3063 mio_symbol_ref (&sym->result);
3065 if (sym->attr.cray_pointee)
3066 mio_symbol_ref (&sym->cp_pointer);
3068 /* Note that components are always saved, even if they are supposed
3069 to be private. Component access is checked during searching. */
3071 mio_component_list (&sym->components);
3073 if (sym->components != NULL)
3074 sym->component_access
3075 = MIO_NAME (gfc_access) (sym->component_access, access_types);
3079 /* Add the fields that say whether this is from an intrinsic module,
3080 and if so, what symbol it is within the module. */
3081 /* mio_integer (&(sym->from_intmod)); */
3082 if (iomode == IO_OUTPUT)
3084 intmod = sym->from_intmod;
3085 mio_integer (&intmod);
3089 mio_integer (&intmod);
3090 sym->from_intmod = intmod;
3093 mio_integer (&(sym->intmod_sym_id));
3099 /************************* Top level subroutines *************************/
3101 /* Skip a list between balanced left and right parens. */
3111 switch (parse_atom ())
3122 gfc_free (atom_string);
3134 /* Load operator interfaces from the module. Interfaces are unusual
3135 in that they attach themselves to existing symbols. */
3138 load_operator_interfaces (void)
3141 char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
3143 pointer_info *pi = NULL;
3148 while (peek_atom () != ATOM_RPAREN)
3152 mio_internal_string (name);
3153 mio_internal_string (module);
3155 n = number_use_names (name, true);
3158 for (i = 1; i <= n; i++)
3160 /* Decide if we need to load this one or not. */
3161 p = find_use_name_n (name, &i, true);
3165 while (parse_atom () != ATOM_RPAREN);
3171 uop = gfc_get_uop (p);
3172 pi = mio_interface_rest (&uop->operator);
3176 if (gfc_find_uop (p, NULL))
3178 uop = gfc_get_uop (p);
3179 uop->operator = gfc_get_interface ();
3180 uop->operator->where = gfc_current_locus;
3181 add_fixup (pi->integer, &uop->operator->sym);
3190 /* Load interfaces from the module. Interfaces are unusual in that
3191 they attach themselves to existing symbols. */
3194 load_generic_interfaces (void)
3197 char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
3199 gfc_interface *generic = NULL;
3204 while (peek_atom () != ATOM_RPAREN)
3208 mio_internal_string (name);
3209 mio_internal_string (module);
3211 n = number_use_names (name, false);
3214 for (i = 1; i <= n; i++)
3216 /* Decide if we need to load this one or not. */
3217 p = find_use_name_n (name, &i, false);
3219 if (p == NULL || gfc_find_symbol (p, NULL, 0, &sym))
3221 while (parse_atom () != ATOM_RPAREN);
3227 gfc_get_symbol (p, NULL, &sym);
3229 sym->attr.flavor = FL_PROCEDURE;
3230 sym->attr.generic = 1;
3231 sym->attr.use_assoc = 1;
3235 /* Unless sym is a generic interface, this reference
3239 st = gfc_find_symtree (gfc_current_ns->sym_root, p);
3240 if (!sym->attr.generic
3241 && sym->module != NULL
3242 && strcmp(module, sym->module) != 0)
3247 mio_interface_rest (&sym->generic);
3248 generic = sym->generic;
3252 sym->generic = generic;
3253 sym->attr.generic_copy = 1;
3262 /* Load common blocks. */
3267 char name[GFC_MAX_SYMBOL_LEN + 1];
3272 while (peek_atom () != ATOM_RPAREN)
3276 mio_internal_string (name);
3278 p = gfc_get_common (name, 1);
3280 mio_symbol_ref (&p->head);
3281 mio_integer (&flags);
3285 p->threadprivate = 1;
3288 /* Get whether this was a bind(c) common or not. */
3289 mio_integer (&p->is_bind_c);
3290 /* Get the binding label. */
3291 mio_internal_string (p->binding_label);
3300 /* Load equivalences. The flag in_load_equiv informs mio_expr_ref of this
3301 so that unused variables are not loaded and so that the expression can
3307 gfc_equiv *head, *tail, *end, *eq;
3311 in_load_equiv = true;
3313 end = gfc_current_ns->equiv;
3314 while (end != NULL && end->next != NULL)
3317 while (peek_atom () != ATOM_RPAREN) {
3321 while(peek_atom () != ATOM_RPAREN)
3324 head = tail = gfc_get_equiv ();
3327 tail->eq = gfc_get_equiv ();
3331 mio_pool_string (&tail->module);
3332 mio_expr (&tail->expr);
3335 /* Unused equivalence members have a unique name. */
3337 for (eq = head; eq; eq = eq->eq)
3339 if (!check_unique_name (eq->expr->symtree->name))
3348 for (eq = head; eq; eq = head)
3351 gfc_free_expr (eq->expr);
3357 gfc_current_ns->equiv = head;
3368 in_load_equiv = false;
3372 /* Recursive function to traverse the pointer_info tree and load a
3373 needed symbol. We return nonzero if we load a symbol and stop the
3374 traversal, because the act of loading can alter the tree. */
3377 load_needed (pointer_info *p)
3388 rv |= load_needed (p->left);
3389 rv |= load_needed (p->right);
3391 if (p->type != P_SYMBOL || p->u.rsym.state != NEEDED)
3394 p->u.rsym.state = USED;
3396 set_module_locus (&p->u.rsym.where);
3398 sym = p->u.rsym.sym;
3401 q = get_integer (p->u.rsym.ns);
3403 ns = (gfc_namespace *) q->u.pointer;
3406 /* Create an interface namespace if necessary. These are
3407 the namespaces that hold the formal parameters of module
3410 ns = gfc_get_namespace (NULL, 0);
3411 associate_integer_pointer (q, ns);
3414 sym = gfc_new_symbol (p->u.rsym.true_name, ns);
3415 sym->module = gfc_get_string (p->u.rsym.module);
3417 associate_integer_pointer (p, sym);
3421 sym->attr.use_assoc = 1;
3423 sym->attr.use_only = 1;
3429 /* Recursive function for cleaning up things after a module has been read. */
3432 read_cleanup (pointer_info *p)
3440 read_cleanup (p->left);
3441 read_cleanup (p->right);
3443 if (p->type == P_SYMBOL && p->u.rsym.state == USED && !p->u.rsym.referenced)
3445 /* Add hidden symbols to the symtree. */
3446 q = get_integer (p->u.rsym.ns);
3447 st = gfc_get_unique_symtree ((gfc_namespace *) q->u.pointer);
3449 st->n.sym = p->u.rsym.sym;
3452 /* Fixup any symtree references. */
3453 p->u.rsym.symtree = st;
3454 resolve_fixups (p->u.rsym.stfixup, st);
3455 p->u.rsym.stfixup = NULL;
3458 /* Free unused symbols. */
3459 if (p->type == P_SYMBOL && p->u.rsym.state == UNUSED)
3460 gfc_free_symbol (p->u.rsym.sym);
3464 /* Given a root symtree node and a symbol, try to find a symtree that
3465 references the symbol that is not a unique name. */
3467 static gfc_symtree *
3468 find_symtree_for_symbol (gfc_symtree *st, gfc_symbol *sym)
3470 gfc_symtree *s = NULL;
3475 s = find_symtree_for_symbol (st->right, sym);
3478 s = find_symtree_for_symbol (st->left, sym);
3482 if (st->n.sym == sym && !check_unique_name (st->name))
3489 /* Read a module file. */
3494 module_locus operator_interfaces, user_operators;
3496 char name[GFC_MAX_SYMBOL_LEN + 1];
3498 int ambiguous, j, nuse, symbol;
3499 pointer_info *info, *q;
3504 get_module_locus (&operator_interfaces); /* Skip these for now. */
3507 get_module_locus (&user_operators);
3511 /* Skip commons and equivalences for now. */
3517 /* Create the fixup nodes for all the symbols. */
3519 while (peek_atom () != ATOM_RPAREN)
3521 require_atom (ATOM_INTEGER);
3522 info = get_integer (atom_int);
3524 info->type = P_SYMBOL;
3525 info->u.rsym.state = UNUSED;
3527 mio_internal_string (info->u.rsym.true_name);
3528 mio_internal_string (info->u.rsym.module);
3529 mio_internal_string (info->u.rsym.binding_label);
3532 require_atom (ATOM_INTEGER);
3533 info->u.rsym.ns = atom_int;
3535 get_module_locus (&info->u.rsym.where);
3538 /* See if the symbol has already been loaded by a previous module.
3539 If so, we reference the existing symbol and prevent it from
3540 being loaded again. This should not happen if the symbol being
3541 read is an index for an assumed shape dummy array (ns != 1). */
3543 sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module);
3546 || (sym->attr.flavor == FL_VARIABLE && info->u.rsym.ns !=1))
3549 info->u.rsym.state = USED;
3550 info->u.rsym.sym = sym;
3552 /* Some symbols do not have a namespace (eg. formal arguments),
3553 so the automatic "unique symtree" mechanism must be suppressed
3554 by marking them as referenced. */
3555 q = get_integer (info->u.rsym.ns);
3556 if (q->u.pointer == NULL)
3558 info->u.rsym.referenced = 1;
3562 /* If possible recycle the symtree that references the symbol.
3563 If a symtree is not found and the module does not import one,
3564 a unique-name symtree is found by read_cleanup. */
3565 st = find_symtree_for_symbol (gfc_current_ns->sym_root, sym);
3568 info->u.rsym.symtree = st;
3569 info->u.rsym.referenced = 1;
3575 /* Parse the symtree lists. This lets us mark which symbols need to
3576 be loaded. Renaming is also done at this point by replacing the
3581 while (peek_atom () != ATOM_RPAREN)
3583 mio_internal_string (name);
3584 mio_integer (&ambiguous);
3585 mio_integer (&symbol);
3587 info = get_integer (symbol);
3589 /* See how many use names there are. If none, go through the start
3590 of the loop at least once. */
3591 nuse = number_use_names (name, false);
3595 for (j = 1; j <= nuse; j++)
3597 /* Get the jth local name for this symbol. */
3598 p = find_use_name_n (name, &j, false);
3600 if (p == NULL && strcmp (name, module_name) == 0)
3603 /* Skip symtree nodes not in an ONLY clause, unless there
3604 is an existing symtree loaded from another USE statement. */
3607 st = gfc_find_symtree (gfc_current_ns->sym_root, name);
3609 info->u.rsym.symtree = st;
3613 st = gfc_find_symtree (gfc_current_ns->sym_root, p);
3617 /* Check for ambiguous symbols. */
3618 if (st->n.sym != info->u.rsym.sym)
3620 info->u.rsym.symtree = st;
3624 /* Create a symtree node in the current namespace for this
3626 st = check_unique_name (p)
3627 ? gfc_get_unique_symtree (gfc_current_ns)
3628 : gfc_new_symtree (&gfc_current_ns->sym_root, p);
3630 st->ambiguous = ambiguous;
3632 sym = info->u.rsym.sym;
3634 /* Create a symbol node if it doesn't already exist. */
3637 info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name,
3639 sym = info->u.rsym.sym;
3640 sym->module = gfc_get_string (info->u.rsym.module);
3642 /* TODO: hmm, can we test this? Do we know it will be
3643 initialized to zeros? */
3644 if (info->u.rsym.binding_label[0] != '\0')
3645 strcpy (sym->binding_label, info->u.rsym.binding_label);
3651 /* Store the symtree pointing to this symbol. */
3652 info->u.rsym.symtree = st;
3654 if (info->u.rsym.state == UNUSED)
3655 info->u.rsym.state = NEEDED;
3656 info->u.rsym.referenced = 1;
3663 /* Load intrinsic operator interfaces. */
3664 set_module_locus (&operator_interfaces);
3667 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3669 if (i == INTRINSIC_USER)
3674 u = find_use_operator (i);
3685 mio_interface (&gfc_current_ns->operator[i]);
3690 /* Load generic and user operator interfaces. These must follow the
3691 loading of symtree because otherwise symbols can be marked as
3694 set_module_locus (&user_operators);
3696 load_operator_interfaces ();
3697 load_generic_interfaces ();
3702 /* At this point, we read those symbols that are needed but haven't
3703 been loaded yet. If one symbol requires another, the other gets
3704 marked as NEEDED if its previous state was UNUSED. */
3706 while (load_needed (pi_root));
3708 /* Make sure all elements of the rename-list were found in the module. */
3710 for (u = gfc_rename_list; u; u = u->next)
3715 if (u->operator == INTRINSIC_NONE)
3717 gfc_error ("Symbol '%s' referenced at %L not found in module '%s'",
3718 u->use_name, &u->where, module_name);
3722 if (u->operator == INTRINSIC_USER)
3724 gfc_error ("User operator '%s' referenced at %L not found "
3725 "in module '%s'", u->use_name, &u->where, module_name);
3729 gfc_error ("Intrinsic operator '%s' referenced at %L not found "
3730 "in module '%s'", gfc_op2string (u->operator), &u->where,
3734 gfc_check_interfaces (gfc_current_ns);
3736 /* Clean up symbol nodes that were never loaded, create references
3737 to hidden symbols. */
3739 read_cleanup (pi_root);
3743 /* Given an access type that is specific to an entity and the default
3744 access, return nonzero if the entity is publicly accessible. If the
3745 element is declared as PUBLIC, then it is public; if declared
3746 PRIVATE, then private, and otherwise it is public unless the default
3747 access in this context has been declared PRIVATE. */
3750 gfc_check_access (gfc_access specific_access, gfc_access default_access)
3752 if (specific_access == ACCESS_PUBLIC)
3754 if (specific_access == ACCESS_PRIVATE)
3757 if (gfc_option.flag_module_private)
3758 return default_access == ACCESS_PUBLIC;
3760 return default_access != ACCESS_PRIVATE;
3764 /* Write a common block to the module. */
3767 write_common (gfc_symtree *st)
3777 write_common (st->left);
3778 write_common (st->right);
3782 /* Write the unmangled name. */
3783 name = st->n.common->name;
3785 mio_pool_string (&name);
3788 mio_symbol_ref (&p->head);
3789 flags = p->saved ? 1 : 0;
3790 if (p->threadprivate) flags |= 2;
3791 mio_integer (&flags);
3793 /* Write out whether the common block is bind(c) or not. */
3794 mio_integer (&(p->is_bind_c));
3796 /* Write out the binding label, or the com name if no label given. */
3799 label = p->binding_label;
3800 mio_pool_string (&label);
3805 mio_pool_string (&label);
3812 /* Write the blank common block to the module. */
3815 write_blank_common (void)
3817 const char * name = BLANK_COMMON_NAME;
3819 /* TODO: Blank commons are not bind(c). The F2003 standard probably says
3820 this, but it hasn't been checked. Just making it so for now. */
3823 if (gfc_current_ns->blank_common.head == NULL)
3828 mio_pool_string (&name);
3830 mio_symbol_ref (&gfc_current_ns->blank_common.head);
3831 saved = gfc_current_ns->blank_common.saved;
3832 mio_integer (&saved);
3834 /* Write out whether the common block is bind(c) or not. */
3835 mio_integer (&is_bind_c);
3837 /* Write out the binding label, which is BLANK_COMMON_NAME, though
3838 it doesn't matter because the label isn't used. */
3839 mio_pool_string (&name);
3845 /* Write equivalences to the module. */
3854 for (eq = gfc_current_ns->equiv; eq; eq = eq->next)
3858 for (e = eq; e; e = e->eq)
3860 if (e->module == NULL)
3861 e->module = gfc_get_string ("%s.eq.%d", module_name, num);
3862 mio_allocated_string (e->module);
3863 mio_expr (&e->expr);
3872 /* Write a symbol to the module. */
3875 write_symbol (int n, gfc_symbol *sym)
3879 if (sym->attr.flavor == FL_UNKNOWN || sym->attr.flavor == FL_LABEL)
3880 gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym->name);
3883 mio_pool_string (&sym->name);
3885 mio_pool_string (&sym->module);
3886 if (sym->attr.is_bind_c || sym->attr.is_iso_c)
3888 label = sym->binding_label;
3889 mio_pool_string (&label);
3892 mio_pool_string (&sym->name);
3894 mio_pointer_ref (&sym->ns);
3901 /* Recursive traversal function to write the initial set of symbols to
3902 the module. We check to see if the symbol should be written
3903 according to the access specification. */
3906 write_symbol0 (gfc_symtree *st)
3914 write_symbol0 (st->left);
3915 write_symbol0 (st->right);
3918 if (sym->module == NULL)
3919 sym->module = gfc_get_string (module_name);
3921 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
3922 && !sym->attr.subroutine && !sym->attr.function)
3925 if (!gfc_check_access (sym->attr.access, sym->ns->default_access))
3928 p = get_pointer (sym);
3929 if (p->type == P_UNKNOWN)
3932 if (p->u.wsym.state == WRITTEN)
3935 write_symbol (p->integer, sym);
3936 p->u.wsym.state = WRITTEN;
3940 /* Recursive traversal function to write the secondary set of symbols
3941 to the module file. These are symbols that were not public yet are
3942 needed by the public symbols or another dependent symbol. The act
3943 of writing a symbol can modify the pointer_info tree, so we cease
3944 traversal if we find a symbol to write. We return nonzero if a
3945 symbol was written and pass that information upwards. */
3948 write_symbol1 (pointer_info *p)
3954 if (write_symbol1 (p->left))
3956 if (write_symbol1 (p->right))
3959 if (p->type != P_SYMBOL || p->u.wsym.state != NEEDS_WRITE)
3962 p->u.wsym.state = WRITTEN;
3963 write_symbol (p->integer, p->u.wsym.sym);
3969 /* Write operator interfaces associated with a symbol. */
3972 write_operator (gfc_user_op *uop)
3974 static char nullstring[] = "";
3975 const char *p = nullstring;
3977 if (uop->operator == NULL
3978 || !gfc_check_access (uop->access, uop->ns->default_access))
3981 mio_symbol_interface (&uop->name, &p, &uop->operator);
3985 /* Write generic interfaces associated with a symbol. */
3988 write_generic (gfc_symbol *sym)
3993 if (sym->generic == NULL
3994 || !gfc_check_access (sym->attr.access, sym->ns->default_access))
3997 if (sym->module == NULL)
3998 sym->module = gfc_get_string (module_name);
4000 /* See how many use names there are. If none, use the symbol name. */
4001 nuse = number_use_names (sym->name, false);
4004 mio_symbol_interface (&sym->name, &sym->module, &sym->generic);
4008 for (j = 1; j <= nuse; j++)
4010 /* Get the jth local name for this symbol. */
4011 p = find_use_name_n (sym->name, &j, false);
4013 mio_symbol_interface (&p, &sym->module, &sym->generic);
4019 write_symtree (gfc_symtree *st)
4025 if (!gfc_check_access (sym->attr.access, sym->ns->default_access)
4026 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
4027 && !sym->attr.subroutine && !sym->attr.function))
4030 if (check_unique_name (st->name))
4033 p = find_pointer (sym);
4035 gfc_internal_error ("write_symtree(): Symbol not written");
4037 mio_pool_string (&st->name);
4038 mio_integer (&st->ambiguous);
4039 mio_integer (&p->integer);
4048 /* Write the operator interfaces. */
4051 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
4053 if (i == INTRINSIC_USER)
4056 mio_interface (gfc_check_access (gfc_current_ns->operator_access[i],
4057 gfc_current_ns->default_access)
4058 ? &gfc_current_ns->operator[i] : NULL);
4066 gfc_traverse_user_op (gfc_current_ns, write_operator);
4072 gfc_traverse_ns (gfc_current_ns, write_generic);
4078 write_blank_common ();
4079 write_common (gfc_current_ns->common_root);
4090 /* Write symbol information. First we traverse all symbols in the
4091 primary namespace, writing those that need to be written.
4092 Sometimes writing one symbol will cause another to need to be
4093 written. A list of these symbols ends up on the write stack, and
4094 we end by popping the bottom of the stack and writing the symbol
4095 until the stack is empty. */
4099 write_symbol0 (gfc_current_ns->sym_root);
4100 while (write_symbol1 (pi_root));
4108 gfc_traverse_symtree (gfc_current_ns->sym_root, write_symtree);
4113 /* Read a MD5 sum from the header of a module file. If the file cannot
4114 be opened, or we have any other error, we return -1. */
4117 read_md5_from_module_file (const char * filename, unsigned char md5[16])
4123 /* Open the file. */
4124 if ((file = fopen (filename, "r")) == NULL)
4127 /* Read two lines. */
4128 if (fgets (buf, sizeof (buf) - 1, file) == NULL
4129 || fgets (buf, sizeof (buf) - 1, file) == NULL)
4135 /* Close the file. */
4138 /* If the header is not what we expect, or is too short, bail out. */
4139 if (strncmp (buf, "MD5:", 4) != 0 || strlen (buf) < 4 + 16)
4142 /* Now, we have a real MD5, read it into the array. */
4143 for (n = 0; n < 16; n++)
4147 if (sscanf (&(buf[4+2*n]), "%02x", &x) != 1)
4157 /* Given module, dump it to disk. If there was an error while
4158 processing the module, dump_flag will be set to zero and we delete
4159 the module file, even if it was already there. */
4162 gfc_dump_module (const char *name, int dump_flag)
4165 char *filename, *filename_tmp, *p;
4168 unsigned char md5_new[16], md5_old[16];
4170 n = strlen (name) + strlen (MODULE_EXTENSION) + 1;
4171 if (gfc_option.module_dir != NULL)
4173 n += strlen (gfc_option.module_dir);
4174 filename = (char *) alloca (n);
4175 strcpy (filename, gfc_option.module_dir);
4176 strcat (filename, name);
4180 filename = (char *) alloca (n);
4181 strcpy (filename, name);
4183 strcat (filename, MODULE_EXTENSION);
4185 /* Name of the temporary file used to write the module. */
4186 filename_tmp = (char *) alloca (n + 1);
4187 strcpy (filename_tmp, filename);
4188 strcat (filename_tmp, "0");
4190 /* There was an error while processing the module. We delete the
4191 module file, even if it was already there. */
4198 /* Write the module to the temporary file. */
4199 module_fp = fopen (filename_tmp, "w");
4200 if (module_fp == NULL)
4201 gfc_fatal_error ("Can't open module file '%s' for writing at %C: %s",
4202 filename_tmp, strerror (errno));
4204 /* Write the header, including space reserved for the MD5 sum. */
4208 *strchr (p, '\n') = '\0';
4210 fprintf (module_fp, "GFORTRAN module created from %s on %s\nMD5:",
4211 gfc_source_file, p);
4212 fgetpos (module_fp, &md5_pos);
4213 fputs ("00000000000000000000000000000000 -- "
4214 "If you edit this, you'll get what you deserve.\n\n", module_fp);
4216 /* Initialize the MD5 context that will be used for output. */
4217 md5_init_ctx (&ctx);
4219 /* Write the module itself. */
4221 strcpy (module_name, name);
4227 free_pi_tree (pi_root);
4232 /* Write the MD5 sum to the header of the module file. */
4233 md5_finish_ctx (&ctx, md5_new);
4234 fsetpos (module_fp, &md5_pos);
4235 for (n = 0; n < 16; n++)
4236 fprintf (module_fp, "%02x", md5_new[n]);
4238 if (fclose (module_fp))
4239 gfc_fatal_error ("Error writing module file '%s' for writing: %s",
4240 filename_tmp, strerror (errno));
4242 /* Read the MD5 from the header of the old module file and compare. */
4243 if (read_md5_from_module_file (filename, md5_old) != 0
4244 || memcmp (md5_old, md5_new, sizeof (md5_old)) != 0)
4246 /* Module file have changed, replace the old one. */
4248 rename (filename_tmp, filename);
4251 unlink (filename_tmp);
4256 sort_iso_c_rename_list (void)
4258 gfc_use_rename *tmp_list = NULL;
4259 gfc_use_rename *curr;
4260 gfc_use_rename *kinds_used[ISOCBINDING_NUMBER] = {NULL};
4264 for (curr = gfc_rename_list; curr; curr = curr->next)
4266 c_kind = get_c_kind (curr->use_name, c_interop_kinds_table);
4267 if (c_kind == ISOCBINDING_INVALID || c_kind == ISOCBINDING_LAST)
4269 gfc_error ("Symbol '%s' referenced at %L does not exist in "
4270 "intrinsic module ISO_C_BINDING.", curr->use_name,
4274 /* Put it in the list. */
4275 kinds_used[c_kind] = curr;
4278 /* Make a new (sorted) rename list. */
4280 while (i < ISOCBINDING_NUMBER && kinds_used[i] == NULL)
4283 if (i < ISOCBINDING_NUMBER)
4285 tmp_list = kinds_used[i];
4289 for (; i < ISOCBINDING_NUMBER; i++)
4290 if (kinds_used[i] != NULL)
4292 curr->next = kinds_used[i];
4298 gfc_rename_list = tmp_list;
4302 /* Import the intrinsic ISO_C_BINDING module, generating symbols in
4303 the current namespace for all named constants, pointer types, and
4304 procedures in the module unless the only clause was used or a rename
4305 list was provided. */
4308 import_iso_c_binding_module (void)
4310 gfc_symbol *mod_sym = NULL;
4311 gfc_symtree *mod_symtree = NULL;
4312 const char *iso_c_module_name = "__iso_c_binding";
4317 /* Look only in the current namespace. */
4318 mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, iso_c_module_name);
4320 if (mod_symtree == NULL)
4322 /* symtree doesn't already exist in current namespace. */
4323 gfc_get_sym_tree (iso_c_module_name, gfc_current_ns, &mod_symtree);
4325 if (mod_symtree != NULL)
4326 mod_sym = mod_symtree->n.sym;
4328 gfc_internal_error ("import_iso_c_binding_module(): Unable to "
4329 "create symbol for %s", iso_c_module_name);
4331 mod_sym->attr.flavor = FL_MODULE;
4332 mod_sym->attr.intrinsic = 1;
4333 mod_sym->module = gfc_get_string (iso_c_module_name);
4334 mod_sym->from_intmod = INTMOD_ISO_C_BINDING;
4337 /* Generate the symbols for the named constants representing
4338 the kinds for intrinsic data types. */
4341 /* Sort the rename list because there are dependencies between types
4342 and procedures (e.g., c_loc needs c_ptr). */
4343 sort_iso_c_rename_list ();
4345 for (u = gfc_rename_list; u; u = u->next)
4347 i = get_c_kind (u->use_name, c_interop_kinds_table);
4349 if (i == ISOCBINDING_INVALID || i == ISOCBINDING_LAST)
4351 gfc_error ("Symbol '%s' referenced at %L does not exist in "
4352 "intrinsic module ISO_C_BINDING.", u->use_name,
4357 generate_isocbinding_symbol (iso_c_module_name, i, u->local_name);
4362 for (i = 0; i < ISOCBINDING_NUMBER; i++)
4365 for (u = gfc_rename_list; u; u = u->next)
4367 if (strcmp (c_interop_kinds_table[i].name, u->use_name) == 0)
4369 local_name = u->local_name;
4374 generate_isocbinding_symbol (iso_c_module_name, i, local_name);
4377 for (u = gfc_rename_list; u; u = u->next)
4382 gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
4383 "module ISO_C_BINDING", u->use_name, &u->where);
4389 /* Add an integer named constant from a given module. */
4392 create_int_parameter (const char *name, int value, const char *modname,
4393 intmod_id module, int id)
4395 gfc_symtree *tmp_symtree;
4398 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
4399 if (tmp_symtree != NULL)
4401 if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
4404 gfc_error ("Symbol '%s' already declared", name);
4407 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree);
4408 sym = tmp_symtree->n.sym;
4410 sym->module = gfc_get_string (modname);
4411 sym->attr.flavor = FL_PARAMETER;
4412 sym->ts.type = BT_INTEGER;
4413 sym->ts.kind = gfc_default_integer_kind;
4414 sym->value = gfc_int_expr (value);
4415 sym->attr.use_assoc = 1;
4416 sym->from_intmod = module;
4417 sym->intmod_sym_id = id;
4421 /* USE the ISO_FORTRAN_ENV intrinsic module. */
4424 use_iso_fortran_env_module (void)
4426 static char mod[] = "iso_fortran_env";
4427 const char *local_name;
4429 gfc_symbol *mod_sym;
4430 gfc_symtree *mod_symtree;
4433 intmod_sym symbol[] = {
4434 #define NAMED_INTCST(a,b,c) { a, b, 0 },
4435 #include "iso-fortran-env.def"
4437 { ISOFORTRANENV_INVALID, NULL, -1234 } };
4440 #define NAMED_INTCST(a,b,c) symbol[i++].value = c;
4441 #include "iso-fortran-env.def"
4444 /* Generate the symbol for the module itself. */
4445 mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, mod);
4446 if (mod_symtree == NULL)
4448 gfc_get_sym_tree (mod, gfc_current_ns, &mod_symtree);
4449 gcc_assert (mod_symtree);
4450 mod_sym = mod_symtree->n.sym;
4452 mod_sym->attr.flavor = FL_MODULE;
4453 mod_sym->attr.intrinsic = 1;
4454 mod_sym->module = gfc_get_string (mod);
4455 mod_sym->from_intmod = INTMOD_ISO_FORTRAN_ENV;
4458 if (!mod_symtree->n.sym->attr.intrinsic)
4459 gfc_error ("Use of intrinsic module '%s' at %C conflicts with "
4460 "non-intrinsic module name used previously", mod);
4462 /* Generate the symbols for the module integer named constants. */
4464 for (u = gfc_rename_list; u; u = u->next)
4466 for (i = 0; symbol[i].name; i++)
4467 if (strcmp (symbol[i].name, u->use_name) == 0)
4470 if (symbol[i].name == NULL)
4472 gfc_error ("Symbol '%s' referenced at %L does not exist in "
4473 "intrinsic module ISO_FORTRAN_ENV", u->use_name,
4478 if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
4479 && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
4480 gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
4481 "from intrinsic module ISO_FORTRAN_ENV at %L is "
4482 "incompatible with option %s", &u->where,
4483 gfc_option.flag_default_integer
4484 ? "-fdefault-integer-8" : "-fdefault-real-8");
4486 create_int_parameter (u->local_name[0] ? u->local_name
4488 symbol[i].value, mod, INTMOD_ISO_FORTRAN_ENV,
4493 for (i = 0; symbol[i].name; i++)
4496 for (u = gfc_rename_list; u; u = u->next)
4498 if (strcmp (symbol[i].name, u->use_name) == 0)
4500 local_name = u->local_name;
4506 if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
4507 && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
4508 gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
4509 "from intrinsic module ISO_FORTRAN_ENV at %C is "
4510 "incompatible with option %s",
4511 gfc_option.flag_default_integer
4512 ? "-fdefault-integer-8" : "-fdefault-real-8");
4514 create_int_parameter (local_name ? local_name : symbol[i].name,
4515 symbol[i].value, mod, INTMOD_ISO_FORTRAN_ENV,
4519 for (u = gfc_rename_list; u; u = u->next)
4524 gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
4525 "module ISO_FORTRAN_ENV", u->use_name, &u->where);
4531 /* Process a USE directive. */
4534 gfc_use_module (void)
4539 gfc_symtree *mod_symtree;
4541 filename = (char *) alloca (strlen (module_name) + strlen (MODULE_EXTENSION)
4543 strcpy (filename, module_name);
4544 strcat (filename, MODULE_EXTENSION);
4546 /* First, try to find an non-intrinsic module, unless the USE statement
4547 specified that the module is intrinsic. */
4550 module_fp = gfc_open_included_file (filename, true, true);
4552 /* Then, see if it's an intrinsic one, unless the USE statement
4553 specified that the module is non-intrinsic. */
4554 if (module_fp == NULL && !specified_nonint)
4556 if (strcmp (module_name, "iso_fortran_env") == 0
4557 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ISO_FORTRAN_ENV "
4558 "intrinsic module at %C") != FAILURE)
4560 use_iso_fortran_env_module ();
4564 if (strcmp (module_name, "iso_c_binding") == 0
4565 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: "
4566 "ISO_C_BINDING module at %C") != FAILURE)
4568 import_iso_c_binding_module();
4572 module_fp = gfc_open_intrinsic_module (filename);
4574 if (module_fp == NULL && specified_int)
4575 gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C",
4579 if (module_fp == NULL)
4580 gfc_fatal_error ("Can't open module file '%s' for reading at %C: %s",
4581 filename, strerror (errno));
4583 /* Check that we haven't already USEd an intrinsic module with the
4586 mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, module_name);
4587 if (mod_symtree && mod_symtree->n.sym->attr.intrinsic)
4588 gfc_error ("Use of non-intrinsic module '%s' at %C conflicts with "
4589 "intrinsic module name used previously", module_name);
4596 /* Skip the first two lines of the module, after checking that this is
4597 a gfortran module file. */
4603 bad_module ("Unexpected end of module");
4606 if ((start == 1 && strcmp (atom_name, "GFORTRAN") != 0)
4607 || (start == 2 && strcmp (atom_name, " module") != 0))
4608 gfc_fatal_error ("File '%s' opened at %C is not a GFORTRAN module "
4615 /* Make sure we're not reading the same module that we may be building. */
4616 for (p = gfc_state_stack; p; p = p->previous)
4617 if (p->state == COMP_MODULE && strcmp (p->sym->name, module_name) == 0)
4618 gfc_fatal_error ("Can't USE the same module we're building!");
4621 init_true_name_tree ();
4625 free_true_name (true_name_root);
4626 true_name_root = NULL;
4628 free_pi_tree (pi_root);
4636 gfc_module_init_2 (void)
4638 last_atom = ATOM_LPAREN;
4643 gfc_module_done_2 (void)