1 /* Handle modules, which amounts to loading and saving symbols and
2 their attendant structures.
3 Copyright (C) 2000, 2001, 2002, 2003, 2004 Free Software Foundation,
5 Contributed by Andy Vaught
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 2, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING. If not, write to the Free
21 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
24 /* The syntax of gfortran modules resembles that of lisp lists, ie a
25 sequence of atoms, which can be left or right parenthesis, names,
26 integers or strings. Parenthesis are always matched which allows
27 us to skip over sections at high speed without having to know
28 anything about the internal structure of the lists. A "name" is
29 usually a fortran 95 identifier, but can also start with '@' in
30 order to reference a hidden symbol.
32 The first line of a module is an informational message about what
33 created the module, the file it came from and when it was created.
34 The second line is a warning for people not to edit the module.
35 The rest of the module looks like:
37 ( ( <Interface info for UPLUS> )
38 ( <Interface info for UMINUS> )
41 ( ( <name of operator interface> <module of op interface> <i/f1> ... )
44 ( ( <name of generic interface> <module of generic interface> <i/f1> ... )
47 ( ( <common name> <symbol> <saved flag>)
50 ( <Symbol Number (in no particular order)>
52 <Module name of symbol>
53 ( <symbol information> )
62 In general, symbols refer to other symbols by their symbol number,
63 which are zero based. Symbols are written to the module in no
76 #include "parse.h" /* FIXME */
78 #define MODULE_EXTENSION ".mod"
81 /* Structure that describes a position within a module file. */
93 P_UNKNOWN = 0, P_OTHER, P_NAMESPACE, P_COMPONENT, P_SYMBOL
97 /* The fixup structure lists pointers to pointers that have to
98 be updated when a pointer value becomes known. */
100 typedef struct fixup_t
103 struct fixup_t *next;
108 /* Structure for holding extra info needed for pointers being read. */
110 typedef struct pointer_info
112 BBT_HEADER (pointer_info);
116 /* The first component of each member of the union is the pointer
123 void *pointer; /* Member for doing pointer searches. */
128 char true_name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
130 { UNUSED, NEEDED, USED }
135 gfc_symtree *symtree;
143 { UNREFERENCED = 0, NEEDS_WRITE, WRITTEN }
153 #define gfc_get_pointer_info() gfc_getmem(sizeof(pointer_info))
156 /* Lists of rename info for the USE statement. */
158 typedef struct gfc_use_rename
160 char local_name[GFC_MAX_SYMBOL_LEN + 1], use_name[GFC_MAX_SYMBOL_LEN + 1];
161 struct gfc_use_rename *next;
163 gfc_intrinsic_op operator;
168 #define gfc_get_use_rename() gfc_getmem(sizeof(gfc_use_rename))
170 /* Local variables */
172 /* The FILE for the module we're reading or writing. */
173 static FILE *module_fp;
175 /* The name of the module we're reading (USE'ing) or writing. */
176 static char module_name[GFC_MAX_SYMBOL_LEN + 1];
178 static int module_line, module_column, only_flag;
180 { IO_INPUT, IO_OUTPUT }
183 static gfc_use_rename *gfc_rename_list;
184 static pointer_info *pi_root;
185 static int symbol_number; /* Counter for assigning symbol numbers */
189 /*****************************************************************/
191 /* Pointer/integer conversion. Pointers between structures are stored
192 as integers in the module file. The next couple of subroutines
193 handle this translation for reading and writing. */
195 /* Recursively free the tree of pointer structures. */
198 free_pi_tree (pointer_info * p)
203 if (p->fixup != NULL)
204 gfc_internal_error ("free_pi_tree(): Unresolved fixup");
206 free_pi_tree (p->left);
207 free_pi_tree (p->right);
213 /* Compare pointers when searching by pointer. Used when writing a
217 compare_pointers (void * _sn1, void * _sn2)
219 pointer_info *sn1, *sn2;
221 sn1 = (pointer_info *) _sn1;
222 sn2 = (pointer_info *) _sn2;
224 if (sn1->u.pointer < sn2->u.pointer)
226 if (sn1->u.pointer > sn2->u.pointer)
233 /* Compare integers when searching by integer. Used when reading a
237 compare_integers (void * _sn1, void * _sn2)
239 pointer_info *sn1, *sn2;
241 sn1 = (pointer_info *) _sn1;
242 sn2 = (pointer_info *) _sn2;
244 if (sn1->integer < sn2->integer)
246 if (sn1->integer > sn2->integer)
253 /* Initialize the pointer_info tree. */
262 compare = (iomode == IO_INPUT) ? compare_integers : compare_pointers;
264 /* Pointer 0 is the NULL pointer. */
265 p = gfc_get_pointer_info ();
270 gfc_insert_bbt (&pi_root, p, compare);
272 /* Pointer 1 is the current namespace. */
273 p = gfc_get_pointer_info ();
274 p->u.pointer = gfc_current_ns;
276 p->type = P_NAMESPACE;
278 gfc_insert_bbt (&pi_root, p, compare);
284 /* During module writing, call here with a pointer to something,
285 returning the pointer_info node. */
287 static pointer_info *
288 find_pointer (void *gp)
295 if (p->u.pointer == gp)
297 p = (gp < p->u.pointer) ? p->left : p->right;
304 /* Given a pointer while writing, returns the pointer_info tree node,
305 creating it if it doesn't exist. */
307 static pointer_info *
308 get_pointer (void *gp)
312 p = find_pointer (gp);
316 /* Pointer doesn't have an integer. Give it one. */
317 p = gfc_get_pointer_info ();
320 p->integer = symbol_number++;
322 gfc_insert_bbt (&pi_root, p, compare_pointers);
328 /* Given an integer during reading, find it in the pointer_info tree,
329 creating the node if not found. */
331 static pointer_info *
332 get_integer (int integer)
342 c = compare_integers (&t, p);
346 p = (c < 0) ? p->left : p->right;
352 p = gfc_get_pointer_info ();
353 p->integer = integer;
356 gfc_insert_bbt (&pi_root, p, compare_integers);
362 /* Recursive function to find a pointer within a tree by brute force. */
364 static pointer_info *
365 fp2 (pointer_info * p, const void *target)
372 if (p->u.pointer == target)
375 q = fp2 (p->left, target);
379 return fp2 (p->right, target);
383 /* During reading, find a pointer_info node from the pointer value.
384 This amounts to a brute-force search. */
386 static pointer_info *
387 find_pointer2 (void *p)
390 return fp2 (pi_root, p);
394 /* Resolve any fixups using a known pointer. */
396 resolve_fixups (fixup_t *f, void * gp)
408 /* Call here during module reading when we know what pointer to
409 associate with an integer. Any fixups that exist are resolved at
413 associate_integer_pointer (pointer_info * p, void *gp)
415 if (p->u.pointer != NULL)
416 gfc_internal_error ("associate_integer_pointer(): Already associated");
420 resolve_fixups (p->fixup, gp);
426 /* During module reading, given an integer and a pointer to a pointer,
427 either store the pointer from an already-known value or create a
428 fixup structure in order to store things later. Returns zero if
429 the reference has been actually stored, or nonzero if the reference
430 must be fixed later (ie associate_integer_pointer must be called
431 sometime later. Returns the pointer_info structure. */
433 static pointer_info *
434 add_fixup (int integer, void *gp)
440 p = get_integer (integer);
442 if (p->integer == 0 || p->u.pointer != NULL)
449 f = gfc_getmem (sizeof (fixup_t));
461 /*****************************************************************/
463 /* Parser related subroutines */
465 /* Free the rename list left behind by a USE statement. */
470 gfc_use_rename *next;
472 for (; gfc_rename_list; gfc_rename_list = next)
474 next = gfc_rename_list->next;
475 gfc_free (gfc_rename_list);
480 /* Match a USE statement. */
485 char name[GFC_MAX_SYMBOL_LEN + 1];
486 gfc_use_rename *tail = NULL, *new;
488 gfc_intrinsic_op operator;
491 m = gfc_match_name (module_name);
498 if (gfc_match_eos () == MATCH_YES)
500 if (gfc_match_char (',') != MATCH_YES)
503 if (gfc_match (" only :") == MATCH_YES)
506 if (gfc_match_eos () == MATCH_YES)
511 /* Get a new rename struct and add it to the rename list. */
512 new = gfc_get_use_rename ();
513 new->where = gfc_current_locus;
516 if (gfc_rename_list == NULL)
517 gfc_rename_list = new;
522 /* See what kind of interface we're dealing with. Assume it is
524 new->operator = INTRINSIC_NONE;
525 if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
530 case INTERFACE_NAMELESS:
531 gfc_error ("Missing generic specification in USE statement at %C");
534 case INTERFACE_GENERIC:
535 m = gfc_match (" =>");
540 strcpy (new->use_name, name);
543 strcpy (new->local_name, name);
545 m = gfc_match_name (new->use_name);
548 if (m == MATCH_ERROR)
556 strcpy (new->local_name, name);
558 m = gfc_match_name (new->use_name);
561 if (m == MATCH_ERROR)
567 case INTERFACE_USER_OP:
568 strcpy (new->use_name, name);
571 case INTERFACE_INTRINSIC_OP:
572 new->operator = operator;
576 if (gfc_match_eos () == MATCH_YES)
578 if (gfc_match_char (',') != MATCH_YES)
585 gfc_syntax_error (ST_USE);
593 /* Given a name, return the name under which to load this symbol.
594 Returns NULL if this symbol shouldn't be loaded. */
597 find_use_name (const char *name)
601 for (u = gfc_rename_list; u; u = u->next)
602 if (strcmp (u->use_name, name) == 0)
606 return only_flag ? NULL : name;
610 return (u->local_name[0] != '\0') ? u->local_name : name;
614 /* Try to find the operator in the current list. */
616 static gfc_use_rename *
617 find_use_operator (gfc_intrinsic_op operator)
621 for (u = gfc_rename_list; u; u = u->next)
622 if (u->operator == operator)
629 /*****************************************************************/
631 /* The next couple of subroutines maintain a tree used to avoid a
632 brute-force search for a combination of true name and module name.
633 While symtree names, the name that a particular symbol is known by
634 can changed with USE statements, we still have to keep track of the
635 true names to generate the correct reference, and also avoid
636 loading the same real symbol twice in a program unit.
638 When we start reading, the true name tree is built and maintained
639 as symbols are read. The tree is searched as we load new symbols
640 to see if it already exists someplace in the namespace. */
642 typedef struct true_name
644 BBT_HEADER (true_name);
649 static true_name *true_name_root;
652 /* Compare two true_name structures. */
655 compare_true_names (void * _t1, void * _t2)
660 t1 = (true_name *) _t1;
661 t2 = (true_name *) _t2;
663 c = strcmp (t1->sym->module, t2->sym->module);
667 return strcmp (t1->sym->name, t2->sym->name);
671 /* Given a true name, search the true name tree to see if it exists
672 within the main namespace. */
675 find_true_name (const char *name, const char *module)
681 strcpy (sym.name, name);
682 strcpy (sym.module, module);
688 c = compare_true_names ((void *)(&t), (void *) p);
692 p = (c < 0) ? p->left : p->right;
699 /* Given a gfc_symbol pointer that is not in the true name tree, add
703 add_true_name (gfc_symbol * sym)
707 t = gfc_getmem (sizeof (true_name));
710 gfc_insert_bbt (&true_name_root, t, compare_true_names);
714 /* Recursive function to build the initial true name tree by
715 recursively traversing the current namespace. */
718 build_tnt (gfc_symtree * st)
724 build_tnt (st->left);
725 build_tnt (st->right);
727 if (find_true_name (st->n.sym->name, st->n.sym->module) != NULL)
730 add_true_name (st->n.sym);
734 /* Initialize the true name tree with the current namespace. */
737 init_true_name_tree (void)
739 true_name_root = NULL;
741 build_tnt (gfc_current_ns->sym_root);
745 /* Recursively free a true name tree node. */
748 free_true_name (true_name * t)
753 free_true_name (t->left);
754 free_true_name (t->right);
760 /*****************************************************************/
762 /* Module reading and writing. */
766 ATOM_NAME, ATOM_LPAREN, ATOM_RPAREN, ATOM_INTEGER, ATOM_STRING
770 static atom_type last_atom;
773 /* The name buffer must be at least as long as a symbol name. Right
774 now it's not clear how we're going to store numeric constants--
775 probably as a hexadecimal string, since this will allow the exact
776 number to be preserved (this can't be done by a decimal
777 representation). Worry about that later. TODO! */
779 #define MAX_ATOM_SIZE 100
782 static char *atom_string, atom_name[MAX_ATOM_SIZE];
785 /* Report problems with a module. Error reporting is not very
786 elaborate, since this sorts of errors shouldn't really happen.
787 This subroutine never returns. */
789 static void bad_module (const char *) ATTRIBUTE_NORETURN;
792 bad_module (const char *message)
811 gfc_fatal_error ("%s module %s at line %d column %d: %s", p,
812 module_name, module_line, module_column, message);
816 /* Set the module's input pointer. */
819 set_module_locus (module_locus * m)
822 module_column = m->column;
823 module_line = m->line;
824 fsetpos (module_fp, &m->pos);
828 /* Get the module's input pointer so that we can restore it later. */
831 get_module_locus (module_locus * m)
834 m->column = module_column;
835 m->line = module_line;
836 fgetpos (module_fp, &m->pos);
840 /* Get the next character in the module, updating our reckoning of
848 c = fgetc (module_fp);
851 bad_module ("Unexpected EOF");
864 /* Parse a string constant. The delimiter is guaranteed to be a
874 get_module_locus (&start);
878 /* See how long the string is */
883 bad_module ("Unexpected end of module in string constant");
901 set_module_locus (&start);
903 atom_string = p = gfc_getmem (len + 1);
905 for (; len > 0; len--)
909 module_char (); /* Guaranteed to be another \' */
913 module_char (); /* Terminating \' */
914 *p = '\0'; /* C-style string for debug purposes */
918 /* Parse a small integer. */
921 parse_integer (int c)
929 get_module_locus (&m);
935 atom_int = 10 * atom_int + c - '0';
936 if (atom_int > 99999999)
937 bad_module ("Integer overflow");
940 set_module_locus (&m);
958 get_module_locus (&m);
963 if (!ISALNUM (c) && c != '_' && c != '-')
967 if (++len > GFC_MAX_SYMBOL_LEN)
968 bad_module ("Name too long");
973 fseek (module_fp, -1, SEEK_CUR);
974 module_column = m.column + len - 1;
981 /* Read the next atom in the module's input stream. */
992 while (c == ' ' || c == '\n');
1017 return ATOM_INTEGER;
1075 bad_module ("Bad name");
1082 /* Peek at the next atom on the input. */
1090 get_module_locus (&m);
1093 if (a == ATOM_STRING)
1094 gfc_free (atom_string);
1096 set_module_locus (&m);
1101 /* Read the next atom from the input, requiring that it be a
1105 require_atom (atom_type type)
1111 get_module_locus (&m);
1119 p = "Expected name";
1122 p = "Expected left parenthesis";
1125 p = "Expected right parenthesis";
1128 p = "Expected integer";
1131 p = "Expected string";
1134 gfc_internal_error ("require_atom(): bad atom type required");
1137 set_module_locus (&m);
1143 /* Given a pointer to an mstring array, require that the current input
1144 be one of the strings in the array. We return the enum value. */
1147 find_enum (const mstring * m)
1151 i = gfc_string2code (m, atom_name);
1155 bad_module ("find_enum(): Enum not found");
1161 /**************** Module output subroutines ***************************/
1163 /* Output a character to a module file. */
1166 write_char (char out)
1169 if (fputc (out, module_fp) == EOF)
1170 gfc_fatal_error ("Error writing modules file: %s", strerror (errno));
1182 /* Write an atom to a module. The line wrapping isn't perfect, but it
1183 should work most of the time. This isn't that big of a deal, since
1184 the file really isn't meant to be read by people anyway. */
1187 write_atom (atom_type atom, const void *v)
1209 i = *((const int *) v);
1211 gfc_internal_error ("write_atom(): Writing negative integer");
1213 sprintf (buffer, "%d", i);
1218 gfc_internal_error ("write_atom(): Trying to write dab atom");
1224 if (atom != ATOM_RPAREN)
1226 if (module_column + len > 72)
1231 if (last_atom != ATOM_LPAREN && module_column != 1)
1236 if (atom == ATOM_STRING)
1241 if (atom == ATOM_STRING && *p == '\'')
1246 if (atom == ATOM_STRING)
1254 /***************** Mid-level I/O subroutines *****************/
1256 /* These subroutines let their caller read or write atoms without
1257 caring about which of the two is actually happening. This lets a
1258 subroutine concentrate on the actual format of the data being
1261 static void mio_expr (gfc_expr **);
1262 static void mio_symbol_ref (gfc_symbol **);
1263 static void mio_symtree_ref (gfc_symtree **);
1265 /* Read or write an enumerated value. On writing, we return the input
1266 value for the convenience of callers. We avoid using an integer
1267 pointer because enums are sometimes inside bitfields. */
1270 mio_name (int t, const mstring * m)
1273 if (iomode == IO_OUTPUT)
1274 write_atom (ATOM_NAME, gfc_code2string (m, t));
1277 require_atom (ATOM_NAME);
1284 /* Specialisation of mio_name. */
1286 #define DECL_MIO_NAME(TYPE) \
1287 static inline TYPE \
1288 MIO_NAME(TYPE) (TYPE t, const mstring * m) \
1290 return (TYPE)mio_name ((int)t, m); \
1292 #define MIO_NAME(TYPE) mio_name_##TYPE
1298 if (iomode == IO_OUTPUT)
1299 write_atom (ATOM_LPAREN, NULL);
1301 require_atom (ATOM_LPAREN);
1309 if (iomode == IO_OUTPUT)
1310 write_atom (ATOM_RPAREN, NULL);
1312 require_atom (ATOM_RPAREN);
1317 mio_integer (int *ip)
1320 if (iomode == IO_OUTPUT)
1321 write_atom (ATOM_INTEGER, ip);
1324 require_atom (ATOM_INTEGER);
1330 /* Read or write a character pointer that points to a string on the
1334 mio_allocated_string (const char *s)
1336 if (iomode == IO_OUTPUT)
1338 write_atom (ATOM_STRING, s);
1343 require_atom (ATOM_STRING);
1349 /* Read or write a string that is in static memory or inside of some
1350 already-allocated structure. */
1353 mio_internal_string (char *string)
1356 if (iomode == IO_OUTPUT)
1357 write_atom (ATOM_STRING, string);
1360 require_atom (ATOM_STRING);
1361 strcpy (string, atom_string);
1362 gfc_free (atom_string);
1369 { AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL,
1370 AB_POINTER, AB_SAVE, AB_TARGET, AB_DUMMY, AB_RESULT,
1371 AB_DATA, AB_IN_NAMELIST, AB_IN_COMMON,
1372 AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE, AB_ELEMENTAL, AB_PURE,
1373 AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT
1377 static const mstring attr_bits[] =
1379 minit ("ALLOCATABLE", AB_ALLOCATABLE),
1380 minit ("DIMENSION", AB_DIMENSION),
1381 minit ("EXTERNAL", AB_EXTERNAL),
1382 minit ("INTRINSIC", AB_INTRINSIC),
1383 minit ("OPTIONAL", AB_OPTIONAL),
1384 minit ("POINTER", AB_POINTER),
1385 minit ("SAVE", AB_SAVE),
1386 minit ("TARGET", AB_TARGET),
1387 minit ("DUMMY", AB_DUMMY),
1388 minit ("RESULT", AB_RESULT),
1389 minit ("DATA", AB_DATA),
1390 minit ("IN_NAMELIST", AB_IN_NAMELIST),
1391 minit ("IN_COMMON", AB_IN_COMMON),
1392 minit ("FUNCTION", AB_FUNCTION),
1393 minit ("SUBROUTINE", AB_SUBROUTINE),
1394 minit ("SEQUENCE", AB_SEQUENCE),
1395 minit ("ELEMENTAL", AB_ELEMENTAL),
1396 minit ("PURE", AB_PURE),
1397 minit ("RECURSIVE", AB_RECURSIVE),
1398 minit ("GENERIC", AB_GENERIC),
1399 minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT),
1403 /* Specialisation of mio_name. */
1404 DECL_MIO_NAME(ab_attribute)
1405 DECL_MIO_NAME(ar_type)
1406 DECL_MIO_NAME(array_type)
1408 DECL_MIO_NAME(expr_t)
1409 DECL_MIO_NAME(gfc_access)
1410 DECL_MIO_NAME(gfc_intrinsic_op)
1411 DECL_MIO_NAME(ifsrc)
1412 DECL_MIO_NAME(procedure_type)
1413 DECL_MIO_NAME(ref_type)
1414 DECL_MIO_NAME(sym_flavor)
1415 DECL_MIO_NAME(sym_intent)
1416 #undef DECL_MIO_NAME
1418 /* Symbol attributes are stored in list with the first three elements
1419 being the enumerated fields, while the remaining elements (if any)
1420 indicate the individual attribute bits. The access field is not
1421 saved-- it controls what symbols are exported when a module is
1425 mio_symbol_attribute (symbol_attribute * attr)
1431 attr->flavor = MIO_NAME(sym_flavor) (attr->flavor, flavors);
1432 attr->intent = MIO_NAME(sym_intent) (attr->intent, intents);
1433 attr->proc = MIO_NAME(procedure_type) (attr->proc, procedures);
1434 attr->if_source = MIO_NAME(ifsrc) (attr->if_source, ifsrc_types);
1436 if (iomode == IO_OUTPUT)
1438 if (attr->allocatable)
1439 MIO_NAME(ab_attribute) (AB_ALLOCATABLE, attr_bits);
1440 if (attr->dimension)
1441 MIO_NAME(ab_attribute) (AB_DIMENSION, attr_bits);
1443 MIO_NAME(ab_attribute) (AB_EXTERNAL, attr_bits);
1444 if (attr->intrinsic)
1445 MIO_NAME(ab_attribute) (AB_INTRINSIC, attr_bits);
1447 MIO_NAME(ab_attribute) (AB_OPTIONAL, attr_bits);
1449 MIO_NAME(ab_attribute) (AB_POINTER, attr_bits);
1451 MIO_NAME(ab_attribute) (AB_SAVE, attr_bits);
1453 MIO_NAME(ab_attribute) (AB_TARGET, attr_bits);
1455 MIO_NAME(ab_attribute) (AB_DUMMY, attr_bits);
1457 MIO_NAME(ab_attribute) (AB_RESULT, attr_bits);
1458 /* We deliberately don't preserve the "entry" flag. */
1461 MIO_NAME(ab_attribute) (AB_DATA, attr_bits);
1462 if (attr->in_namelist)
1463 MIO_NAME(ab_attribute) (AB_IN_NAMELIST, attr_bits);
1464 if (attr->in_common)
1465 MIO_NAME(ab_attribute) (AB_IN_COMMON, attr_bits);
1468 MIO_NAME(ab_attribute) (AB_FUNCTION, attr_bits);
1469 if (attr->subroutine)
1470 MIO_NAME(ab_attribute) (AB_SUBROUTINE, attr_bits);
1472 MIO_NAME(ab_attribute) (AB_GENERIC, attr_bits);
1475 MIO_NAME(ab_attribute) (AB_SEQUENCE, attr_bits);
1476 if (attr->elemental)
1477 MIO_NAME(ab_attribute) (AB_ELEMENTAL, attr_bits);
1479 MIO_NAME(ab_attribute) (AB_PURE, attr_bits);
1480 if (attr->recursive)
1481 MIO_NAME(ab_attribute) (AB_RECURSIVE, attr_bits);
1482 if (attr->always_explicit)
1483 MIO_NAME(ab_attribute) (AB_ALWAYS_EXPLICIT, attr_bits);
1494 if (t == ATOM_RPAREN)
1497 bad_module ("Expected attribute bit name");
1499 switch ((ab_attribute) find_enum (attr_bits))
1501 case AB_ALLOCATABLE:
1502 attr->allocatable = 1;
1505 attr->dimension = 1;
1511 attr->intrinsic = 1;
1534 case AB_IN_NAMELIST:
1535 attr->in_namelist = 1;
1538 attr->in_common = 1;
1544 attr->subroutine = 1;
1553 attr->elemental = 1;
1559 attr->recursive = 1;
1561 case AB_ALWAYS_EXPLICIT:
1562 attr->always_explicit = 1;
1570 static const mstring bt_types[] = {
1571 minit ("INTEGER", BT_INTEGER),
1572 minit ("REAL", BT_REAL),
1573 minit ("COMPLEX", BT_COMPLEX),
1574 minit ("LOGICAL", BT_LOGICAL),
1575 minit ("CHARACTER", BT_CHARACTER),
1576 minit ("DERIVED", BT_DERIVED),
1577 minit ("PROCEDURE", BT_PROCEDURE),
1578 minit ("UNKNOWN", BT_UNKNOWN),
1584 mio_charlen (gfc_charlen ** clp)
1590 if (iomode == IO_OUTPUT)
1594 mio_expr (&cl->length);
1599 if (peek_atom () != ATOM_RPAREN)
1601 cl = gfc_get_charlen ();
1602 mio_expr (&cl->length);
1606 cl->next = gfc_current_ns->cl_list;
1607 gfc_current_ns->cl_list = cl;
1615 /* Return a symtree node with a name that is guaranteed to be unique
1616 within the namespace and corresponds to an illegal fortran name. */
1618 static gfc_symtree *
1619 get_unique_symtree (gfc_namespace * ns)
1621 char name[GFC_MAX_SYMBOL_LEN + 1];
1622 static int serial = 0;
1624 sprintf (name, "@%d", serial++);
1625 return gfc_new_symtree (&ns->sym_root, name);
1629 /* See if a name is a generated name. */
1632 check_unique_name (const char *name)
1635 return *name == '@';
1640 mio_typespec (gfc_typespec * ts)
1645 ts->type = MIO_NAME(bt) (ts->type, bt_types);
1647 if (ts->type != BT_DERIVED)
1648 mio_integer (&ts->kind);
1650 mio_symbol_ref (&ts->derived);
1652 mio_charlen (&ts->cl);
1658 static const mstring array_spec_types[] = {
1659 minit ("EXPLICIT", AS_EXPLICIT),
1660 minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE),
1661 minit ("DEFERRED", AS_DEFERRED),
1662 minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE),
1668 mio_array_spec (gfc_array_spec ** asp)
1675 if (iomode == IO_OUTPUT)
1683 if (peek_atom () == ATOM_RPAREN)
1689 *asp = as = gfc_get_array_spec ();
1692 mio_integer (&as->rank);
1693 as->type = MIO_NAME(array_type) (as->type, array_spec_types);
1695 for (i = 0; i < as->rank; i++)
1697 mio_expr (&as->lower[i]);
1698 mio_expr (&as->upper[i]);
1706 /* Given a pointer to an array reference structure (which lives in a
1707 gfc_ref structure), find the corresponding array specification
1708 structure. Storing the pointer in the ref structure doesn't quite
1709 work when loading from a module. Generating code for an array
1710 reference also needs more information than just the array spec. */
1712 static const mstring array_ref_types[] = {
1713 minit ("FULL", AR_FULL),
1714 minit ("ELEMENT", AR_ELEMENT),
1715 minit ("SECTION", AR_SECTION),
1720 mio_array_ref (gfc_array_ref * ar)
1725 ar->type = MIO_NAME(ar_type) (ar->type, array_ref_types);
1726 mio_integer (&ar->dimen);
1734 for (i = 0; i < ar->dimen; i++)
1735 mio_expr (&ar->start[i]);
1740 for (i = 0; i < ar->dimen; i++)
1742 mio_expr (&ar->start[i]);
1743 mio_expr (&ar->end[i]);
1744 mio_expr (&ar->stride[i]);
1750 gfc_internal_error ("mio_array_ref(): Unknown array ref");
1753 for (i = 0; i < ar->dimen; i++)
1754 mio_integer ((int *) &ar->dimen_type[i]);
1756 if (iomode == IO_INPUT)
1758 ar->where = gfc_current_locus;
1760 for (i = 0; i < ar->dimen; i++)
1761 ar->c_where[i] = gfc_current_locus;
1768 /* Saves or restores a pointer. The pointer is converted back and
1769 forth from an integer. We return the pointer_info pointer so that
1770 the caller can take additional action based on the pointer type. */
1772 static pointer_info *
1773 mio_pointer_ref (void *gp)
1777 if (iomode == IO_OUTPUT)
1779 p = get_pointer (*((char **) gp));
1780 write_atom (ATOM_INTEGER, &p->integer);
1784 require_atom (ATOM_INTEGER);
1785 p = add_fixup (atom_int, gp);
1792 /* Save and load references to components that occur within
1793 expressions. We have to describe these references by a number and
1794 by name. The number is necessary for forward references during
1795 reading, and the name is necessary if the symbol already exists in
1796 the namespace and is not loaded again. */
1799 mio_component_ref (gfc_component ** cp, gfc_symbol * sym)
1801 char name[GFC_MAX_SYMBOL_LEN + 1];
1805 p = mio_pointer_ref (cp);
1806 if (p->type == P_UNKNOWN)
1807 p->type = P_COMPONENT;
1809 if (iomode == IO_OUTPUT)
1810 mio_internal_string ((*cp)->name);
1813 mio_internal_string (name);
1815 if (sym->components != NULL && p->u.pointer == NULL)
1817 /* Symbol already loaded, so search by name. */
1818 for (q = sym->components; q; q = q->next)
1819 if (strcmp (q->name, name) == 0)
1823 gfc_internal_error ("mio_component_ref(): Component not found");
1825 associate_integer_pointer (p, q);
1828 /* Make sure this symbol will eventually be loaded. */
1829 p = find_pointer2 (sym);
1830 if (p->u.rsym.state == UNUSED)
1831 p->u.rsym.state = NEEDED;
1837 mio_component (gfc_component * c)
1844 if (iomode == IO_OUTPUT)
1846 p = get_pointer (c);
1847 mio_integer (&p->integer);
1852 p = get_integer (n);
1853 associate_integer_pointer (p, c);
1856 if (p->type == P_UNKNOWN)
1857 p->type = P_COMPONENT;
1859 mio_internal_string (c->name);
1860 mio_typespec (&c->ts);
1861 mio_array_spec (&c->as);
1863 mio_integer (&c->dimension);
1864 mio_integer (&c->pointer);
1866 mio_expr (&c->initializer);
1872 mio_component_list (gfc_component ** cp)
1874 gfc_component *c, *tail;
1878 if (iomode == IO_OUTPUT)
1880 for (c = *cp; c; c = c->next)
1891 if (peek_atom () == ATOM_RPAREN)
1894 c = gfc_get_component ();
1911 mio_actual_arg (gfc_actual_arglist * a)
1915 mio_internal_string (a->name);
1916 mio_expr (&a->expr);
1922 mio_actual_arglist (gfc_actual_arglist ** ap)
1924 gfc_actual_arglist *a, *tail;
1928 if (iomode == IO_OUTPUT)
1930 for (a = *ap; a; a = a->next)
1940 if (peek_atom () != ATOM_LPAREN)
1943 a = gfc_get_actual_arglist ();
1959 /* Read and write formal argument lists. */
1962 mio_formal_arglist (gfc_symbol * sym)
1964 gfc_formal_arglist *f, *tail;
1968 if (iomode == IO_OUTPUT)
1970 for (f = sym->formal; f; f = f->next)
1971 mio_symbol_ref (&f->sym);
1976 sym->formal = tail = NULL;
1978 while (peek_atom () != ATOM_RPAREN)
1980 f = gfc_get_formal_arglist ();
1981 mio_symbol_ref (&f->sym);
1983 if (sym->formal == NULL)
1996 /* Save or restore a reference to a symbol node. */
1999 mio_symbol_ref (gfc_symbol ** symp)
2003 p = mio_pointer_ref (symp);
2004 if (p->type == P_UNKNOWN)
2007 if (iomode == IO_OUTPUT)
2009 if (p->u.wsym.state == UNREFERENCED)
2010 p->u.wsym.state = NEEDS_WRITE;
2014 if (p->u.rsym.state == UNUSED)
2015 p->u.rsym.state = NEEDED;
2020 /* Save or restore a reference to a symtree node. */
2023 mio_symtree_ref (gfc_symtree ** stp)
2028 if (iomode == IO_OUTPUT)
2030 mio_symbol_ref (&(*stp)->n.sym);
2034 require_atom (ATOM_INTEGER);
2035 p = get_integer (atom_int);
2036 if (p->type == P_UNKNOWN)
2039 if (p->u.rsym.state == UNUSED)
2040 p->u.rsym.state = NEEDED;
2042 if (p->u.rsym.symtree != NULL)
2044 *stp = p->u.rsym.symtree;
2048 f = gfc_getmem (sizeof (fixup_t));
2050 f->next = p->u.rsym.stfixup;
2051 p->u.rsym.stfixup = f;
2053 f->pointer = (void **)stp;
2059 mio_iterator (gfc_iterator ** ip)
2065 if (iomode == IO_OUTPUT)
2072 if (peek_atom () == ATOM_RPAREN)
2078 *ip = gfc_get_iterator ();
2083 mio_expr (&iter->var);
2084 mio_expr (&iter->start);
2085 mio_expr (&iter->end);
2086 mio_expr (&iter->step);
2095 mio_constructor (gfc_constructor ** cp)
2097 gfc_constructor *c, *tail;
2101 if (iomode == IO_OUTPUT)
2103 for (c = *cp; c; c = c->next)
2106 mio_expr (&c->expr);
2107 mio_iterator (&c->iterator);
2117 while (peek_atom () != ATOM_RPAREN)
2119 c = gfc_get_constructor ();
2129 mio_expr (&c->expr);
2130 mio_iterator (&c->iterator);
2140 static const mstring ref_types[] = {
2141 minit ("ARRAY", REF_ARRAY),
2142 minit ("COMPONENT", REF_COMPONENT),
2143 minit ("SUBSTRING", REF_SUBSTRING),
2149 mio_ref (gfc_ref ** rp)
2156 r->type = MIO_NAME(ref_type) (r->type, ref_types);
2161 mio_array_ref (&r->u.ar);
2165 mio_symbol_ref (&r->u.c.sym);
2166 mio_component_ref (&r->u.c.component, r->u.c.sym);
2170 mio_expr (&r->u.ss.start);
2171 mio_expr (&r->u.ss.end);
2172 mio_charlen (&r->u.ss.length);
2181 mio_ref_list (gfc_ref ** rp)
2183 gfc_ref *ref, *head, *tail;
2187 if (iomode == IO_OUTPUT)
2189 for (ref = *rp; ref; ref = ref->next)
2196 while (peek_atom () != ATOM_RPAREN)
2199 head = tail = gfc_get_ref ();
2202 tail->next = gfc_get_ref ();
2216 /* Read and write an integer value. */
2219 mio_gmp_integer (mpz_t * integer)
2223 if (iomode == IO_INPUT)
2225 if (parse_atom () != ATOM_STRING)
2226 bad_module ("Expected integer string");
2228 mpz_init (*integer);
2229 if (mpz_set_str (*integer, atom_string, 10))
2230 bad_module ("Error converting integer");
2232 gfc_free (atom_string);
2237 p = mpz_get_str (NULL, 10, *integer);
2238 write_atom (ATOM_STRING, p);
2245 mio_gmp_real (mpfr_t * real)
2250 if (iomode == IO_INPUT)
2252 if (parse_atom () != ATOM_STRING)
2253 bad_module ("Expected real string");
2256 mpfr_set_str (*real, atom_string, 16, GFC_RND_MODE);
2257 gfc_free (atom_string);
2262 p = mpfr_get_str (NULL, &exponent, 16, 0, *real, GFC_RND_MODE);
2263 atom_string = gfc_getmem (strlen (p) + 20);
2265 sprintf (atom_string, "0.%s@%ld", p, exponent);
2267 /* Fix negative numbers. */
2268 if (atom_string[2] == '-')
2270 atom_string[0] = '-';
2271 atom_string[1] = '0';
2272 atom_string[2] = '.';
2275 write_atom (ATOM_STRING, atom_string);
2277 gfc_free (atom_string);
2283 /* Save and restore the shape of an array constructor. */
2286 mio_shape (mpz_t ** pshape, int rank)
2292 /* A NULL shape is represented by (). */
2295 if (iomode == IO_OUTPUT)
2307 if (t == ATOM_RPAREN)
2314 shape = gfc_get_shape (rank);
2318 for (n = 0; n < rank; n++)
2319 mio_gmp_integer (&shape[n]);
2325 static const mstring expr_types[] = {
2326 minit ("OP", EXPR_OP),
2327 minit ("FUNCTION", EXPR_FUNCTION),
2328 minit ("CONSTANT", EXPR_CONSTANT),
2329 minit ("VARIABLE", EXPR_VARIABLE),
2330 minit ("SUBSTRING", EXPR_SUBSTRING),
2331 minit ("STRUCTURE", EXPR_STRUCTURE),
2332 minit ("ARRAY", EXPR_ARRAY),
2333 minit ("NULL", EXPR_NULL),
2337 /* INTRINSIC_ASSIGN is missing because it is used as an index for
2338 generic operators, not in expressions. INTRINSIC_USER is also
2339 replaced by the correct function name by the time we see it. */
2341 static const mstring intrinsics[] =
2343 minit ("UPLUS", INTRINSIC_UPLUS),
2344 minit ("UMINUS", INTRINSIC_UMINUS),
2345 minit ("PLUS", INTRINSIC_PLUS),
2346 minit ("MINUS", INTRINSIC_MINUS),
2347 minit ("TIMES", INTRINSIC_TIMES),
2348 minit ("DIVIDE", INTRINSIC_DIVIDE),
2349 minit ("POWER", INTRINSIC_POWER),
2350 minit ("CONCAT", INTRINSIC_CONCAT),
2351 minit ("AND", INTRINSIC_AND),
2352 minit ("OR", INTRINSIC_OR),
2353 minit ("EQV", INTRINSIC_EQV),
2354 minit ("NEQV", INTRINSIC_NEQV),
2355 minit ("EQ", INTRINSIC_EQ),
2356 minit ("NE", INTRINSIC_NE),
2357 minit ("GT", INTRINSIC_GT),
2358 minit ("GE", INTRINSIC_GE),
2359 minit ("LT", INTRINSIC_LT),
2360 minit ("LE", INTRINSIC_LE),
2361 minit ("NOT", INTRINSIC_NOT),
2365 /* Read and write expressions. The form "()" is allowed to indicate a
2369 mio_expr (gfc_expr ** ep)
2377 if (iomode == IO_OUTPUT)
2386 MIO_NAME(expr_t) (e->expr_type, expr_types);
2392 if (t == ATOM_RPAREN)
2399 bad_module ("Expected expression type");
2401 e = *ep = gfc_get_expr ();
2402 e->where = gfc_current_locus;
2403 e->expr_type = (expr_t) find_enum (expr_types);
2406 mio_typespec (&e->ts);
2407 mio_integer (&e->rank);
2409 switch (e->expr_type)
2412 e->operator = MIO_NAME(gfc_intrinsic_op) (e->operator, intrinsics);
2414 switch (e->operator)
2416 case INTRINSIC_UPLUS:
2417 case INTRINSIC_UMINUS:
2422 case INTRINSIC_PLUS:
2423 case INTRINSIC_MINUS:
2424 case INTRINSIC_TIMES:
2425 case INTRINSIC_DIVIDE:
2426 case INTRINSIC_POWER:
2427 case INTRINSIC_CONCAT:
2431 case INTRINSIC_NEQV:
2443 bad_module ("Bad operator");
2449 mio_symtree_ref (&e->symtree);
2450 mio_actual_arglist (&e->value.function.actual);
2452 if (iomode == IO_OUTPUT)
2454 e->value.function.name
2455 = mio_allocated_string (e->value.function.name);
2456 flag = e->value.function.esym != NULL;
2457 mio_integer (&flag);
2459 mio_symbol_ref (&e->value.function.esym);
2461 write_atom (ATOM_STRING, e->value.function.isym->name);
2466 require_atom (ATOM_STRING);
2467 e->value.function.name = gfc_get_string (atom_string);
2468 gfc_free (atom_string);
2470 mio_integer (&flag);
2472 mio_symbol_ref (&e->value.function.esym);
2475 require_atom (ATOM_STRING);
2476 e->value.function.isym = gfc_find_function (atom_string);
2477 gfc_free (atom_string);
2484 mio_symtree_ref (&e->symtree);
2485 mio_ref_list (&e->ref);
2488 case EXPR_SUBSTRING:
2489 e->value.character.string = (char *)
2490 mio_allocated_string (e->value.character.string);
2495 case EXPR_STRUCTURE:
2497 mio_constructor (&e->value.constructor);
2498 mio_shape (&e->shape, e->rank);
2505 mio_gmp_integer (&e->value.integer);
2509 gfc_set_model_kind (e->ts.kind);
2510 mio_gmp_real (&e->value.real);
2514 gfc_set_model_kind (e->ts.kind);
2515 mio_gmp_real (&e->value.complex.r);
2516 mio_gmp_real (&e->value.complex.i);
2520 mio_integer (&e->value.logical);
2524 mio_integer (&e->value.character.length);
2525 e->value.character.string = (char *)
2526 mio_allocated_string (e->value.character.string);
2530 bad_module ("Bad type in constant expression");
2543 /* Save/restore lists of gfc_interface stuctures. When loading an
2544 interface, we are really appending to the existing list of
2545 interfaces. Checking for duplicate and ambiguous interfaces has to
2546 be done later when all symbols have been loaded. */
2549 mio_interface_rest (gfc_interface ** ip)
2551 gfc_interface *tail, *p;
2553 if (iomode == IO_OUTPUT)
2556 for (p = *ip; p; p = p->next)
2557 mio_symbol_ref (&p->sym);
2573 if (peek_atom () == ATOM_RPAREN)
2576 p = gfc_get_interface ();
2577 p->where = gfc_current_locus;
2578 mio_symbol_ref (&p->sym);
2593 /* Save/restore a nameless operator interface. */
2596 mio_interface (gfc_interface ** ip)
2600 mio_interface_rest (ip);
2604 /* Save/restore a named operator interface. */
2607 mio_symbol_interface (char *name, char *module,
2608 gfc_interface ** ip)
2613 mio_internal_string (name);
2614 mio_internal_string (module);
2616 mio_interface_rest (ip);
2621 mio_namespace_ref (gfc_namespace ** nsp)
2626 p = mio_pointer_ref (nsp);
2628 if (p->type == P_UNKNOWN)
2629 p->type = P_NAMESPACE;
2631 if (iomode == IO_INPUT && p->integer != 0)
2633 ns = (gfc_namespace *)p->u.pointer;
2636 ns = gfc_get_namespace (NULL);
2637 associate_integer_pointer (p, ns);
2645 /* Unlike most other routines, the address of the symbol node is
2646 already fixed on input and the name/module has already been filled
2650 mio_symbol (gfc_symbol * sym)
2652 gfc_formal_arglist *formal;
2656 mio_symbol_attribute (&sym->attr);
2657 mio_typespec (&sym->ts);
2659 /* Contained procedures don't have formal namespaces. Instead we output the
2660 procedure namespace. The will contain the formal arguments. */
2661 if (iomode == IO_OUTPUT)
2663 formal = sym->formal;
2664 while (formal && !formal->sym)
2665 formal = formal->next;
2668 mio_namespace_ref (&formal->sym->ns);
2670 mio_namespace_ref (&sym->formal_ns);
2674 mio_namespace_ref (&sym->formal_ns);
2677 sym->formal_ns->proc_name = sym;
2682 /* Save/restore common block links */
2683 mio_symbol_ref (&sym->common_next);
2685 mio_formal_arglist (sym);
2687 if (sym->attr.flavor == FL_PARAMETER)
2688 mio_expr (&sym->value);
2690 mio_array_spec (&sym->as);
2692 mio_symbol_ref (&sym->result);
2694 /* Note that components are always saved, even if they are supposed
2695 to be private. Component access is checked during searching. */
2697 mio_component_list (&sym->components);
2699 if (sym->components != NULL)
2700 sym->component_access =
2701 MIO_NAME(gfc_access) (sym->component_access, access_types);
2707 /************************* Top level subroutines *************************/
2709 /* Skip a list between balanced left and right parens. */
2719 switch (parse_atom ())
2730 gfc_free (atom_string);
2742 /* Load operator interfaces from the module. Interfaces are unusual
2743 in that they attach themselves to existing symbols. */
2746 load_operator_interfaces (void)
2749 char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
2754 while (peek_atom () != ATOM_RPAREN)
2758 mio_internal_string (name);
2759 mio_internal_string (module);
2761 /* Decide if we need to load this one or not. */
2762 p = find_use_name (name);
2765 while (parse_atom () != ATOM_RPAREN);
2769 uop = gfc_get_uop (p);
2770 mio_interface_rest (&uop->operator);
2778 /* Load interfaces from the module. Interfaces are unusual in that
2779 they attach themselves to existing symbols. */
2782 load_generic_interfaces (void)
2785 char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
2790 while (peek_atom () != ATOM_RPAREN)
2794 mio_internal_string (name);
2795 mio_internal_string (module);
2797 /* Decide if we need to load this one or not. */
2798 p = find_use_name (name);
2800 if (p == NULL || gfc_find_symbol (p, NULL, 0, &sym))
2802 while (parse_atom () != ATOM_RPAREN);
2808 gfc_get_symbol (p, NULL, &sym);
2810 sym->attr.flavor = FL_PROCEDURE;
2811 sym->attr.generic = 1;
2812 sym->attr.use_assoc = 1;
2815 mio_interface_rest (&sym->generic);
2822 /* Load common blocks. */
2827 char name[GFC_MAX_SYMBOL_LEN+1];
2832 while (peek_atom () != ATOM_RPAREN)
2835 mio_internal_string (name);
2837 p = gfc_get_common (name, 1);
2839 mio_symbol_ref (&p->head);
2840 mio_integer (&p->saved);
2850 /* Recursive function to traverse the pointer_info tree and load a
2851 needed symbol. We return nonzero if we load a symbol and stop the
2852 traversal, because the act of loading can alter the tree. */
2855 load_needed (pointer_info * p)
2863 if (load_needed (p->left))
2865 if (load_needed (p->right))
2868 if (p->type != P_SYMBOL || p->u.rsym.state != NEEDED)
2871 p->u.rsym.state = USED;
2873 set_module_locus (&p->u.rsym.where);
2875 sym = p->u.rsym.sym;
2878 q = get_integer (p->u.rsym.ns);
2880 ns = (gfc_namespace *) q->u.pointer;
2883 /* Create an interface namespace if necessary. These are
2884 the namespaces that hold the formal parameters of module
2887 ns = gfc_get_namespace (NULL);
2888 associate_integer_pointer (q, ns);
2891 sym = gfc_new_symbol (p->u.rsym.true_name, ns);
2892 strcpy (sym->module, p->u.rsym.module);
2894 associate_integer_pointer (p, sym);
2898 sym->attr.use_assoc = 1;
2904 /* Recursive function for cleaning up things after a module has been
2908 read_cleanup (pointer_info * p)
2916 read_cleanup (p->left);
2917 read_cleanup (p->right);
2919 if (p->type == P_SYMBOL && p->u.rsym.state == USED && !p->u.rsym.referenced)
2921 /* Add hidden symbols to the symtree. */
2922 q = get_integer (p->u.rsym.ns);
2923 st = get_unique_symtree ((gfc_namespace *) q->u.pointer);
2925 st->n.sym = p->u.rsym.sym;
2928 /* Fixup any symtree references. */
2929 p->u.rsym.symtree = st;
2930 resolve_fixups (p->u.rsym.stfixup, st);
2931 p->u.rsym.stfixup = NULL;
2934 /* Free unused symbols. */
2935 if (p->type == P_SYMBOL && p->u.rsym.state == UNUSED)
2936 gfc_free_symbol (p->u.rsym.sym);
2940 /* Read a module file. */
2945 module_locus operator_interfaces, user_operators;
2947 char name[GFC_MAX_SYMBOL_LEN + 1];
2949 int ambiguous, symbol;
2955 get_module_locus (&operator_interfaces); /* Skip these for now */
2958 get_module_locus (&user_operators);
2965 /* Create the fixup nodes for all the symbols. */
2967 while (peek_atom () != ATOM_RPAREN)
2969 require_atom (ATOM_INTEGER);
2970 info = get_integer (atom_int);
2972 info->type = P_SYMBOL;
2973 info->u.rsym.state = UNUSED;
2975 mio_internal_string (info->u.rsym.true_name);
2976 mio_internal_string (info->u.rsym.module);
2978 require_atom (ATOM_INTEGER);
2979 info->u.rsym.ns = atom_int;
2981 get_module_locus (&info->u.rsym.where);
2984 /* See if the symbol has already been loaded by a previous module.
2985 If so, we reference the existing symbol and prevent it from
2986 being loaded again. */
2988 sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module);
2992 info->u.rsym.state = USED;
2993 info->u.rsym.referenced = 1;
2994 info->u.rsym.sym = sym;
2999 /* Parse the symtree lists. This lets us mark which symbols need to
3000 be loaded. Renaming is also done at this point by replacing the
3005 while (peek_atom () != ATOM_RPAREN)
3007 mio_internal_string (name);
3008 mio_integer (&ambiguous);
3009 mio_integer (&symbol);
3011 info = get_integer (symbol);
3013 /* Get the local name for this symbol. */
3014 p = find_use_name (name);
3016 /* Skip symtree nodes not in an ONLY caluse. */
3020 /* Check for ambiguous symbols. */
3021 st = gfc_find_symtree (gfc_current_ns->sym_root, p);
3025 if (st->n.sym != info->u.rsym.sym)
3027 info->u.rsym.symtree = st;
3031 /* Create a symtree node in the current namespace for this symbol. */
3032 st = check_unique_name (p) ? get_unique_symtree (gfc_current_ns) :
3033 gfc_new_symtree (&gfc_current_ns->sym_root, p);
3035 st->ambiguous = ambiguous;
3037 sym = info->u.rsym.sym;
3039 /* Create a symbol node if it doesn't already exist. */
3042 sym = info->u.rsym.sym =
3043 gfc_new_symbol (info->u.rsym.true_name, gfc_current_ns);
3045 strcpy (sym->module, info->u.rsym.module);
3051 /* Store the symtree pointing to this symbol. */
3052 info->u.rsym.symtree = st;
3054 if (info->u.rsym.state == UNUSED)
3055 info->u.rsym.state = NEEDED;
3056 info->u.rsym.referenced = 1;
3062 /* Load intrinsic operator interfaces. */
3063 set_module_locus (&operator_interfaces);
3066 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3068 if (i == INTRINSIC_USER)
3073 u = find_use_operator (i);
3084 mio_interface (&gfc_current_ns->operator[i]);
3089 /* Load generic and user operator interfaces. These must follow the
3090 loading of symtree because otherwise symbols can be marked as
3093 set_module_locus (&user_operators);
3095 load_operator_interfaces ();
3096 load_generic_interfaces ();
3100 /* At this point, we read those symbols that are needed but haven't
3101 been loaded yet. If one symbol requires another, the other gets
3102 marked as NEEDED if its previous state was UNUSED. */
3104 while (load_needed (pi_root));
3106 /* Make sure all elements of the rename-list were found in the
3109 for (u = gfc_rename_list; u; u = u->next)
3114 if (u->operator == INTRINSIC_NONE)
3116 gfc_error ("Symbol '%s' referenced at %L not found in module '%s'",
3117 u->use_name, &u->where, module_name);
3121 if (u->operator == INTRINSIC_USER)
3124 ("User operator '%s' referenced at %L not found in module '%s'",
3125 u->use_name, &u->where, module_name);
3130 ("Intrinsic operator '%s' referenced at %L not found in module "
3131 "'%s'", gfc_op2string (u->operator), &u->where, module_name);
3134 gfc_check_interfaces (gfc_current_ns);
3136 /* Clean up symbol nodes that were never loaded, create references
3137 to hidden symbols. */
3139 read_cleanup (pi_root);
3143 /* Given an access type that is specific to an entity and the default
3144 access, return nonzero if we should write the entity. */
3147 check_access (gfc_access specific_access, gfc_access default_access)
3150 if (specific_access == ACCESS_PUBLIC)
3152 if (specific_access == ACCESS_PRIVATE)
3155 if (gfc_option.flag_module_access_private)
3157 if (default_access == ACCESS_PUBLIC)
3162 if (default_access != ACCESS_PRIVATE)
3170 /* Write a common block to the module */
3173 write_common (gfc_symtree *st)
3180 write_common(st->left);
3181 write_common(st->right);
3184 mio_internal_string(st->name);
3187 mio_symbol_ref(&p->head);
3188 mio_integer(&p->saved);
3194 /* Write a symbol to the module. */
3197 write_symbol (int n, gfc_symbol * sym)
3200 if (sym->attr.flavor == FL_UNKNOWN || sym->attr.flavor == FL_LABEL)
3201 gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym->name);
3204 mio_internal_string (sym->name);
3206 mio_internal_string (sym->module);
3207 mio_pointer_ref (&sym->ns);
3214 /* Recursive traversal function to write the initial set of symbols to
3215 the module. We check to see if the symbol should be written
3216 according to the access specification. */
3219 write_symbol0 (gfc_symtree * st)
3227 write_symbol0 (st->left);
3228 write_symbol0 (st->right);
3231 if (sym->module[0] == '\0')
3232 strcpy (sym->module, module_name);
3234 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
3235 && !sym->attr.subroutine && !sym->attr.function)
3238 if (!check_access (sym->attr.access, sym->ns->default_access))
3241 p = get_pointer (sym);
3242 if (p->type == P_UNKNOWN)
3245 if (p->u.wsym.state == WRITTEN)
3248 write_symbol (p->integer, sym);
3249 p->u.wsym.state = WRITTEN;
3255 /* Recursive traversal function to write the secondary set of symbols
3256 to the module file. These are symbols that were not public yet are
3257 needed by the public symbols or another dependent symbol. The act
3258 of writing a symbol can modify the pointer_info tree, so we cease
3259 traversal if we find a symbol to write. We return nonzero if a
3260 symbol was written and pass that information upwards. */
3263 write_symbol1 (pointer_info * p)
3269 if (write_symbol1 (p->left))
3271 if (write_symbol1 (p->right))
3274 if (p->type != P_SYMBOL || p->u.wsym.state != NEEDS_WRITE)
3277 /* FIXME: This shouldn't be necessary, but it works around
3278 deficiencies in the module loader or/and symbol handling. */
3279 if (p->u.wsym.sym->module[0] == '\0' && p->u.wsym.sym->attr.dummy)
3280 strcpy (p->u.wsym.sym->module, module_name);
3282 p->u.wsym.state = WRITTEN;
3283 write_symbol (p->integer, p->u.wsym.sym);
3289 /* Write operator interfaces associated with a symbol. */
3292 write_operator (gfc_user_op * uop)
3294 static char nullstring[] = "";
3296 if (uop->operator == NULL
3297 || !check_access (uop->access, uop->ns->default_access))
3300 mio_symbol_interface (uop->name, nullstring, &uop->operator);
3304 /* Write generic interfaces associated with a symbol. */
3307 write_generic (gfc_symbol * sym)
3310 if (sym->generic == NULL
3311 || !check_access (sym->attr.access, sym->ns->default_access))
3314 mio_symbol_interface (sym->name, sym->module, &sym->generic);
3319 write_symtree (gfc_symtree * st)
3325 if (!check_access (sym->attr.access, sym->ns->default_access)
3326 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
3327 && !sym->attr.subroutine && !sym->attr.function))
3330 if (check_unique_name (st->name))
3333 p = find_pointer (sym);
3335 gfc_internal_error ("write_symtree(): Symbol not written");
3337 mio_internal_string (st->name);
3338 mio_integer (&st->ambiguous);
3339 mio_integer (&p->integer);
3348 /* Write the operator interfaces. */
3351 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3353 if (i == INTRINSIC_USER)
3356 mio_interface (check_access (gfc_current_ns->operator_access[i],
3357 gfc_current_ns->default_access)
3358 ? &gfc_current_ns->operator[i] : NULL);
3366 gfc_traverse_user_op (gfc_current_ns, write_operator);
3372 gfc_traverse_ns (gfc_current_ns, write_generic);
3378 write_common (gfc_current_ns->common_root);
3383 /* Write symbol information. First we traverse all symbols in the
3384 primary namespace, writing those that need to be written.
3385 Sometimes writing one symbol will cause another to need to be
3386 written. A list of these symbols ends up on the write stack, and
3387 we end by popping the bottom of the stack and writing the symbol
3388 until the stack is empty. */
3392 write_symbol0 (gfc_current_ns->sym_root);
3393 while (write_symbol1 (pi_root));
3401 gfc_traverse_symtree (gfc_current_ns->sym_root, write_symtree);
3406 /* Given module, dump it to disk. If there was an error while
3407 processing the module, dump_flag will be set to zero and we delete
3408 the module file, even if it was already there. */
3411 gfc_dump_module (const char *name, int dump_flag)
3413 char filename[PATH_MAX], *p;
3417 if (gfc_option.module_dir != NULL)
3418 strcpy (filename, gfc_option.module_dir);
3420 strcat (filename, name);
3421 strcat (filename, MODULE_EXTENSION);
3429 module_fp = fopen (filename, "w");
3430 if (module_fp == NULL)
3431 gfc_fatal_error ("Can't open module file '%s' for writing at %C: %s",
3432 filename, strerror (errno));
3437 *strchr (p, '\n') = '\0';
3439 fprintf (module_fp, "GFORTRAN module created from %s on %s\n",
3440 gfc_source_file, p);
3441 fputs ("If you edit this, you'll get what you deserve.\n\n", module_fp);
3444 strcpy (module_name, name);
3450 free_pi_tree (pi_root);
3455 if (fclose (module_fp))
3456 gfc_fatal_error ("Error writing module file '%s' for writing: %s",
3457 filename, strerror (errno));
3461 /* Process a USE directive. */
3464 gfc_use_module (void)
3466 char filename[GFC_MAX_SYMBOL_LEN + 5];
3470 strcpy (filename, module_name);
3471 strcat (filename, MODULE_EXTENSION);
3473 module_fp = gfc_open_included_file (filename);
3474 if (module_fp == NULL)
3475 gfc_fatal_error ("Can't open module file '%s' for reading at %C: %s",
3476 filename, strerror (errno));
3482 /* Skip the first two lines of the module. */
3483 /* FIXME: Could also check for valid two lines here, instead. */
3489 bad_module ("Unexpected end of module");
3494 /* Make sure we're not reading the same module that we may be building. */
3495 for (p = gfc_state_stack; p; p = p->previous)
3496 if (p->state == COMP_MODULE && strcmp (p->sym->name, module_name) == 0)
3497 gfc_fatal_error ("Can't USE the same module we're building!");
3500 init_true_name_tree ();
3504 free_true_name (true_name_root);
3505 true_name_root = NULL;
3507 free_pi_tree (pi_root);
3515 gfc_module_init_2 (void)
3518 last_atom = ATOM_LPAREN;
3523 gfc_module_done_2 (void)