1 /* Handle modules, which amounts to loading and saving symbols and
2 their attendant structures.
3 Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
23 /* The syntax of g95 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 ( <Symbol Number (in no particular order)>
48 <Module name of symbol>
49 ( <symbol information> )
58 In general, symbols refer to other symbols by their symbol number,
59 which are zero based. Symbols are written to the module in no
71 #include "parse.h" /* FIXME */
73 #define MODULE_EXTENSION ".mod"
76 /* Structure that descibes a position within a module file */
88 P_UNKNOWN = 0, P_OTHER, P_NAMESPACE, P_COMPONENT, P_SYMBOL
92 /* The fixup structure lists pointers to pointers that have to
93 be updated when a pointer value becomes known. */
95 typedef struct fixup_t
103 /* Structure for holding extra info needed for pointers being read */
105 typedef struct pointer_info
107 BBT_HEADER (pointer_info);
111 /* The first component of each member of the union is the pointer
118 void *pointer; /* Member for doing pointer searches */
123 char true_name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
125 { UNUSED, NEEDED, USED }
130 gfc_symtree *symtree;
138 { UNREFERENCED = 0, NEEDS_WRITE, WRITTEN }
148 #define gfc_get_pointer_info() gfc_getmem(sizeof(pointer_info))
151 /* Lists of rename info for the USE statement */
153 typedef struct gfc_use_rename
155 char local_name[GFC_MAX_SYMBOL_LEN + 1], use_name[GFC_MAX_SYMBOL_LEN + 1];
156 struct gfc_use_rename *next;
158 gfc_intrinsic_op operator;
163 #define gfc_get_use_rename() gfc_getmem(sizeof(gfc_use_rename))
165 /* Local variables */
167 /* The FILE for the module we're reading or writing. */
168 static FILE *module_fp;
170 /* The name of the module we're reading (USE'ing) or writing. */
171 static char module_name[GFC_MAX_SYMBOL_LEN + 1];
173 static int module_line, module_column, only_flag;
175 { IO_INPUT, IO_OUTPUT }
178 static gfc_use_rename *gfc_rename_list;
179 static pointer_info *pi_root;
180 static int symbol_number; /* Counter for assigning symbol numbers */
184 /*****************************************************************/
186 /* Pointer/integer conversion. Pointers between structures are stored
187 as integers in the module file. The next couple of subroutines
188 handle this translation for reading and writing. */
190 /* Recursively free the tree of pointer structures. */
193 free_pi_tree (pointer_info * p)
199 if (p->fixup != NULL)
200 gfc_internal_error ("free_pi_tree(): Unresolved fixup");
202 free_pi_tree (p->left);
203 free_pi_tree (p->right);
209 /* Compare pointers when searching by pointer. Used when writing a
213 compare_pointers (void * _sn1, void * _sn2)
215 pointer_info *sn1, *sn2;
217 sn1 = (pointer_info *) _sn1;
218 sn2 = (pointer_info *) _sn2;
220 if (sn1->u.pointer < sn2->u.pointer)
222 if (sn1->u.pointer > sn2->u.pointer)
229 /* Compare integers when searching by integer. Used when reading a
233 compare_integers (void * _sn1, void * _sn2)
235 pointer_info *sn1, *sn2;
237 sn1 = (pointer_info *) _sn1;
238 sn2 = (pointer_info *) _sn2;
240 if (sn1->integer < sn2->integer)
242 if (sn1->integer > sn2->integer)
249 /* Initialize the pointer_info tree. */
258 compare = (iomode == IO_INPUT) ? compare_integers : compare_pointers;
260 /* Pointer 0 is the NULL pointer. */
261 p = gfc_get_pointer_info ();
266 gfc_insert_bbt (&pi_root, p, compare);
268 /* Pointer 1 is the current namespace. */
269 p = gfc_get_pointer_info ();
270 p->u.pointer = gfc_current_ns;
272 p->type = P_NAMESPACE;
274 gfc_insert_bbt (&pi_root, p, compare);
280 /* During module writing, call here with a pointer to something,
281 returning the pointer_info node. */
283 static pointer_info *
284 find_pointer (void *gp)
291 if (p->u.pointer == gp)
293 p = (gp < p->u.pointer) ? p->left : p->right;
300 /* Given a pointer while writing, returns the pointer_info tree node,
301 creating it if it doesn't exist. */
303 static pointer_info *
304 get_pointer (void *gp)
308 p = find_pointer (gp);
312 /* Pointer doesn't have an integer. Give it one. */
313 p = gfc_get_pointer_info ();
316 p->integer = symbol_number++;
318 gfc_insert_bbt (&pi_root, p, compare_pointers);
324 /* Given an integer during reading, find it in the pointer_info tree,
325 creating the node if not found. */
327 static pointer_info *
328 get_integer (int integer)
338 c = compare_integers (&t, p);
342 p = (c < 0) ? p->left : p->right;
348 p = gfc_get_pointer_info ();
349 p->integer = integer;
352 gfc_insert_bbt (&pi_root, p, compare_integers);
358 /* Recursive function to find a pointer within a tree by brute force. */
360 static pointer_info *
361 fp2 (pointer_info * p, const void *target)
368 if (p->u.pointer == target)
371 q = fp2 (p->left, target);
375 return fp2 (p->right, target);
379 /* During reading, find a pointer_info node from the pointer value.
380 This amounts to a brute-force search. */
382 static pointer_info *
383 find_pointer2 (void *p)
386 return fp2 (pi_root, p);
390 /* Resolve any fixups using a known pointer. */
392 resolve_fixups (fixup_t *f, void * gp)
404 /* Call here during module reading when we know what pointer to
405 associate with an integer. Any fixups that exist are resolved at
409 associate_integer_pointer (pointer_info * p, void *gp)
411 if (p->u.pointer != NULL)
412 gfc_internal_error ("associate_integer_pointer(): Already associated");
416 resolve_fixups (p->fixup, gp);
422 /* During module reading, given an integer and a pointer to a pointer,
423 either store the pointer from an already-known value or create a
424 fixup structure in order to store things later. Returns zero if
425 the reference has been actually stored, or nonzero if the reference
426 must be fixed later (ie associate_integer_pointer must be called
427 sometime later. Returns the pointer_info structure. */
429 static pointer_info *
430 add_fixup (int integer, void *gp)
436 p = get_integer (integer);
438 if (p->integer == 0 || p->u.pointer != NULL)
445 f = gfc_getmem (sizeof (fixup_t));
457 /*****************************************************************/
459 /* Parser related subroutines */
461 /* Free the rename list left behind by a USE statement. */
466 gfc_use_rename *next;
468 for (; gfc_rename_list; gfc_rename_list = next)
470 next = gfc_rename_list->next;
471 gfc_free (gfc_rename_list);
476 /* Match a USE statement. */
481 char name[GFC_MAX_SYMBOL_LEN + 1];
482 gfc_use_rename *tail = NULL, *new;
484 gfc_intrinsic_op operator;
487 m = gfc_match_name (module_name);
494 if (gfc_match_eos () == MATCH_YES)
496 if (gfc_match_char (',') != MATCH_YES)
499 if (gfc_match (" only :") == MATCH_YES)
502 if (gfc_match_eos () == MATCH_YES)
507 /* Get a new rename struct and add it to the rename list. */
508 new = gfc_get_use_rename ();
509 new->where = gfc_current_locus;
512 if (gfc_rename_list == NULL)
513 gfc_rename_list = new;
518 /* See what kind of interface we're dealing with. Asusume it is
520 new->operator = INTRINSIC_NONE;
521 if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
526 case INTERFACE_NAMELESS:
527 gfc_error ("Missing generic specification in USE statement at %C");
530 case INTERFACE_GENERIC:
531 m = gfc_match (" =>");
536 strcpy (new->use_name, name);
539 strcpy (new->local_name, name);
541 m = gfc_match_name (new->use_name);
544 if (m == MATCH_ERROR)
552 strcpy (new->local_name, name);
554 m = gfc_match_name (new->use_name);
557 if (m == MATCH_ERROR)
563 case INTERFACE_USER_OP:
564 strcpy (new->use_name, name);
567 case INTERFACE_INTRINSIC_OP:
568 new->operator = operator;
572 if (gfc_match_eos () == MATCH_YES)
574 if (gfc_match_char (',') != MATCH_YES)
581 gfc_syntax_error (ST_USE);
589 /* Given a name, return the name under which to load this symbol.
590 Returns NULL if this symbol shouldn't be loaded. */
593 find_use_name (const char *name)
597 for (u = gfc_rename_list; u; u = u->next)
598 if (strcmp (u->use_name, name) == 0)
602 return only_flag ? NULL : name;
606 return (u->local_name[0] != '\0') ? u->local_name : name;
610 /* Try to find the operator in the current list. */
612 static gfc_use_rename *
613 find_use_operator (gfc_intrinsic_op operator)
617 for (u = gfc_rename_list; u; u = u->next)
618 if (u->operator == operator)
625 /*****************************************************************/
627 /* The next couple of subroutines maintain a tree used to avoid a
628 brute-force search for a combination of true name and module name.
629 While symtree names, the name that a particular symbol is known by
630 can changed with USE statements, we still have to keep track of the
631 true names to generate the correct reference, and also avoid
632 loading the same real symbol twice in a program unit.
634 When we start reading, the true name tree is built and maintained
635 as symbols are read. The tree is searched as we load new symbols
636 to see if it already exists someplace in the namespace. */
638 typedef struct true_name
640 BBT_HEADER (true_name);
645 static true_name *true_name_root;
648 /* Compare two true_name structures. */
651 compare_true_names (void * _t1, void * _t2)
656 t1 = (true_name *) _t1;
657 t2 = (true_name *) _t2;
659 c = strcmp (t1->sym->module, t2->sym->module);
663 return strcmp (t1->sym->name, t2->sym->name);
667 /* Given a true name, search the true name tree to see if it exists
668 within the main namespace. */
671 find_true_name (const char *name, const char *module)
677 strcpy (sym.name, name);
678 strcpy (sym.module, module);
684 c = compare_true_names ((void *)(&t), (void *) p);
688 p = (c < 0) ? p->left : p->right;
695 /* Given a gfc_symbol pointer that is not in the true name tree, add
699 add_true_name (gfc_symbol * sym)
703 t = gfc_getmem (sizeof (true_name));
706 gfc_insert_bbt (&true_name_root, t, compare_true_names);
710 /* Recursive function to build the initial true name tree by
711 recursively traversing the current namespace. */
714 build_tnt (gfc_symtree * st)
720 build_tnt (st->left);
721 build_tnt (st->right);
723 if (find_true_name (st->n.sym->name, st->n.sym->module) != NULL)
726 add_true_name (st->n.sym);
730 /* Initialize the true name tree with the current namespace. */
733 init_true_name_tree (void)
735 true_name_root = NULL;
737 build_tnt (gfc_current_ns->sym_root);
741 /* Recursively free a true name tree node. */
744 free_true_name (true_name * t)
749 free_true_name (t->left);
750 free_true_name (t->right);
756 /*****************************************************************/
758 /* Module reading and writing. */
762 ATOM_NAME, ATOM_LPAREN, ATOM_RPAREN, ATOM_INTEGER, ATOM_STRING
766 static atom_type last_atom;
769 /* The name buffer must be at least as long as a symbol name. Right
770 now it's not clear how we're going to store numeric constants--
771 probably as a hexadecimal string, since this will allow the exact
772 number to be preserved (this can't be done by a decimal
773 representation). Worry about that later. TODO! */
775 #define MAX_ATOM_SIZE 100
778 static char *atom_string, atom_name[MAX_ATOM_SIZE];
781 /* Report problems with a module. Error reporting is not very
782 elaborate, since this sorts of errors shouldn't really happen.
783 This subroutine never returns. */
785 static void bad_module (const char *) ATTRIBUTE_NORETURN;
788 bad_module (const char *message)
807 gfc_fatal_error ("%s module %s at line %d column %d: %s", p,
808 module_name, module_line, module_column, message);
812 /* Set the module's input pointer. */
815 set_module_locus (module_locus * m)
818 module_column = m->column;
819 module_line = m->line;
820 fsetpos (module_fp, &m->pos);
824 /* Get the module's input pointer so that we can restore it later. */
827 get_module_locus (module_locus * m)
830 m->column = module_column;
831 m->line = module_line;
832 fgetpos (module_fp, &m->pos);
836 /* Get the next character in the module, updating our reckoning of
844 c = fgetc (module_fp);
847 bad_module ("Unexpected EOF");
860 /* Parse a string constant. The delimiter is guaranteed to be a
870 get_module_locus (&start);
874 /* See how long the string is */
879 bad_module ("Unexpected end of module in string constant");
897 set_module_locus (&start);
899 atom_string = p = gfc_getmem (len + 1);
901 for (; len > 0; len--)
905 module_char (); /* Guaranteed to be another \' */
909 module_char (); /* Terminating \' */
910 *p = '\0'; /* C-style string for debug purposes */
914 /* Parse a small integer. */
917 parse_integer (int c)
925 get_module_locus (&m);
931 atom_int = 10 * atom_int + c - '0';
932 if (atom_int > 99999999)
933 bad_module ("Integer overflow");
936 set_module_locus (&m);
954 get_module_locus (&m);
959 if (!ISALNUM (c) && c != '_' && c != '-')
963 if (++len > GFC_MAX_SYMBOL_LEN)
964 bad_module ("Name too long");
969 fseek (module_fp, -1, SEEK_CUR);
970 module_column = m.column + len - 1;
977 /* Read the next atom in the module's input stream. */
988 while (c == ' ' || c == '\n');
1013 return ATOM_INTEGER;
1071 bad_module ("Bad name");
1078 /* Peek at the next atom on the input. */
1086 get_module_locus (&m);
1089 if (a == ATOM_STRING)
1090 gfc_free (atom_string);
1092 set_module_locus (&m);
1097 /* Read the next atom from the input, requiring that it be a
1101 require_atom (atom_type type)
1107 get_module_locus (&m);
1115 p = "Expected name";
1118 p = "Expected left parenthesis";
1121 p = "Expected right parenthesis";
1124 p = "Expected integer";
1127 p = "Expected string";
1130 gfc_internal_error ("require_atom(): bad atom type required");
1133 set_module_locus (&m);
1139 /* Given a pointer to an mstring array, require that the current input
1140 be one of the strings in the array. We return the enum value. */
1143 find_enum (const mstring * m)
1147 i = gfc_string2code (m, atom_name);
1151 bad_module ("find_enum(): Enum not found");
1157 /**************** Module output subroutines ***************************/
1159 /* Output a character to a module file. */
1162 write_char (char out)
1165 if (fputc (out, module_fp) == EOF)
1166 gfc_fatal_error ("Error writing modules file: %s", strerror (errno));
1178 /* Write an atom to a module. The line wrapping isn't perfect, but it
1179 should work most of the time. This isn't that big of a deal, since
1180 the file really isn't meant to be read by people anyway. */
1183 write_atom (atom_type atom, const void *v)
1205 i = *((const int *) v);
1207 gfc_internal_error ("write_atom(): Writing negative integer");
1209 sprintf (buffer, "%d", i);
1214 gfc_internal_error ("write_atom(): Trying to write dab atom");
1220 if (atom != ATOM_RPAREN)
1222 if (module_column + len > 72)
1227 if (last_atom != ATOM_LPAREN && module_column != 1)
1232 if (atom == ATOM_STRING)
1237 if (atom == ATOM_STRING && *p == '\'')
1242 if (atom == ATOM_STRING)
1250 /***************** Mid-level I/O subroutines *****************/
1252 /* These subroutines let their caller read or write atoms without
1253 caring about which of the two is actually happening. This lets a
1254 subroutine concentrate on the actual format of the data being
1257 static void mio_expr (gfc_expr **);
1258 static void mio_symbol_ref (gfc_symbol **);
1259 static void mio_symtree_ref (gfc_symtree **);
1261 /* Read or write an enumerated value. On writing, we return the input
1262 value for the convenience of callers. We avoid using an integer
1263 pointer because enums are sometimes inside bitfields. */
1266 mio_name (int t, const mstring * m)
1269 if (iomode == IO_OUTPUT)
1270 write_atom (ATOM_NAME, gfc_code2string (m, t));
1273 require_atom (ATOM_NAME);
1280 /* Specialisation of mio_name. */
1282 #define DECL_MIO_NAME(TYPE) \
1283 static inline TYPE \
1284 MIO_NAME(TYPE) (TYPE t, const mstring * m) \
1286 return (TYPE)mio_name ((int)t, m); \
1288 #define MIO_NAME(TYPE) mio_name_##TYPE
1294 if (iomode == IO_OUTPUT)
1295 write_atom (ATOM_LPAREN, NULL);
1297 require_atom (ATOM_LPAREN);
1305 if (iomode == IO_OUTPUT)
1306 write_atom (ATOM_RPAREN, NULL);
1308 require_atom (ATOM_RPAREN);
1313 mio_integer (int *ip)
1316 if (iomode == IO_OUTPUT)
1317 write_atom (ATOM_INTEGER, ip);
1320 require_atom (ATOM_INTEGER);
1326 /* Read or write a character pointer that points to a string on the
1330 mio_allocated_string (char **sp)
1333 if (iomode == IO_OUTPUT)
1334 write_atom (ATOM_STRING, *sp);
1337 require_atom (ATOM_STRING);
1343 /* Read or write a string that is in static memory or inside of some
1344 already-allocated structure. */
1347 mio_internal_string (char *string)
1350 if (iomode == IO_OUTPUT)
1351 write_atom (ATOM_STRING, string);
1354 require_atom (ATOM_STRING);
1355 strcpy (string, atom_string);
1356 gfc_free (atom_string);
1363 { AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL,
1364 AB_POINTER, AB_SAVE, AB_TARGET, AB_DUMMY, AB_COMMON, AB_RESULT,
1365 AB_ENTRY, AB_DATA, AB_IN_NAMELIST, AB_IN_COMMON, AB_SAVED_COMMON,
1366 AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE, AB_ELEMENTAL, AB_PURE,
1367 AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT
1371 static const mstring attr_bits[] =
1373 minit ("ALLOCATABLE", AB_ALLOCATABLE),
1374 minit ("DIMENSION", AB_DIMENSION),
1375 minit ("EXTERNAL", AB_EXTERNAL),
1376 minit ("INTRINSIC", AB_INTRINSIC),
1377 minit ("OPTIONAL", AB_OPTIONAL),
1378 minit ("POINTER", AB_POINTER),
1379 minit ("SAVE", AB_SAVE),
1380 minit ("TARGET", AB_TARGET),
1381 minit ("DUMMY", AB_DUMMY),
1382 minit ("COMMON", AB_COMMON),
1383 minit ("RESULT", AB_RESULT),
1384 minit ("ENTRY", AB_ENTRY),
1385 minit ("DATA", AB_DATA),
1386 minit ("IN_NAMELIST", AB_IN_NAMELIST),
1387 minit ("IN_COMMON", AB_IN_COMMON),
1388 minit ("SAVED_COMMON", AB_SAVED_COMMON),
1389 minit ("FUNCTION", AB_FUNCTION),
1390 minit ("SUBROUTINE", AB_SUBROUTINE),
1391 minit ("SEQUENCE", AB_SEQUENCE),
1392 minit ("ELEMENTAL", AB_ELEMENTAL),
1393 minit ("PURE", AB_PURE),
1394 minit ("RECURSIVE", AB_RECURSIVE),
1395 minit ("GENERIC", AB_GENERIC),
1396 minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT),
1400 /* Specialisation of mio_name. */
1401 DECL_MIO_NAME(ab_attribute)
1402 DECL_MIO_NAME(ar_type)
1403 DECL_MIO_NAME(array_type)
1405 DECL_MIO_NAME(expr_t)
1406 DECL_MIO_NAME(gfc_access)
1407 DECL_MIO_NAME(gfc_intrinsic_op)
1408 DECL_MIO_NAME(ifsrc)
1409 DECL_MIO_NAME(procedure_type)
1410 DECL_MIO_NAME(ref_type)
1411 DECL_MIO_NAME(sym_flavor)
1412 DECL_MIO_NAME(sym_intent)
1413 #undef DECL_MIO_NAME
1415 /* Symbol attributes are stored in list with the first three elements
1416 being the enumerated fields, while the remaining elements (if any)
1417 indicate the individual attribute bits. The access field is not
1418 saved-- it controls what symbols are exported when a module is
1422 mio_symbol_attribute (symbol_attribute * attr)
1428 attr->flavor = MIO_NAME(sym_flavor) (attr->flavor, flavors);
1429 attr->intent = MIO_NAME(sym_intent) (attr->intent, intents);
1430 attr->proc = MIO_NAME(procedure_type) (attr->proc, procedures);
1431 attr->if_source = MIO_NAME(ifsrc) (attr->if_source, ifsrc_types);
1433 if (iomode == IO_OUTPUT)
1435 if (attr->allocatable)
1436 MIO_NAME(ab_attribute) (AB_ALLOCATABLE, attr_bits);
1437 if (attr->dimension)
1438 MIO_NAME(ab_attribute) (AB_DIMENSION, attr_bits);
1440 MIO_NAME(ab_attribute) (AB_EXTERNAL, attr_bits);
1441 if (attr->intrinsic)
1442 MIO_NAME(ab_attribute) (AB_INTRINSIC, attr_bits);
1444 MIO_NAME(ab_attribute) (AB_OPTIONAL, attr_bits);
1446 MIO_NAME(ab_attribute) (AB_POINTER, attr_bits);
1448 MIO_NAME(ab_attribute) (AB_SAVE, attr_bits);
1450 MIO_NAME(ab_attribute) (AB_TARGET, attr_bits);
1452 MIO_NAME(ab_attribute) (AB_DUMMY, attr_bits);
1454 MIO_NAME(ab_attribute) (AB_COMMON, attr_bits);
1456 MIO_NAME(ab_attribute) (AB_RESULT, attr_bits);
1458 MIO_NAME(ab_attribute) (AB_ENTRY, attr_bits);
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);
1466 if (attr->saved_common)
1467 MIO_NAME(ab_attribute) (AB_SAVED_COMMON, attr_bits);
1470 MIO_NAME(ab_attribute) (AB_FUNCTION, attr_bits);
1471 if (attr->subroutine)
1472 MIO_NAME(ab_attribute) (AB_SUBROUTINE, attr_bits);
1474 MIO_NAME(ab_attribute) (AB_GENERIC, attr_bits);
1477 MIO_NAME(ab_attribute) (AB_SEQUENCE, attr_bits);
1478 if (attr->elemental)
1479 MIO_NAME(ab_attribute) (AB_ELEMENTAL, attr_bits);
1481 MIO_NAME(ab_attribute) (AB_PURE, attr_bits);
1482 if (attr->recursive)
1483 MIO_NAME(ab_attribute) (AB_RECURSIVE, attr_bits);
1484 if (attr->always_explicit)
1485 MIO_NAME(ab_attribute) (AB_ALWAYS_EXPLICIT, attr_bits);
1496 if (t == ATOM_RPAREN)
1499 bad_module ("Expected attribute bit name");
1501 switch ((ab_attribute) find_enum (attr_bits))
1503 case AB_ALLOCATABLE:
1504 attr->allocatable = 1;
1507 attr->dimension = 1;
1513 attr->intrinsic = 1;
1542 case AB_IN_NAMELIST:
1543 attr->in_namelist = 1;
1546 attr->in_common = 1;
1548 case AB_SAVED_COMMON:
1549 attr->saved_common = 1;
1555 attr->subroutine = 1;
1564 attr->elemental = 1;
1570 attr->recursive = 1;
1572 case AB_ALWAYS_EXPLICIT:
1573 attr->always_explicit = 1;
1581 static const mstring bt_types[] = {
1582 minit ("INTEGER", BT_INTEGER),
1583 minit ("REAL", BT_REAL),
1584 minit ("COMPLEX", BT_COMPLEX),
1585 minit ("LOGICAL", BT_LOGICAL),
1586 minit ("CHARACTER", BT_CHARACTER),
1587 minit ("DERIVED", BT_DERIVED),
1588 minit ("PROCEDURE", BT_PROCEDURE),
1589 minit ("UNKNOWN", BT_UNKNOWN),
1595 mio_charlen (gfc_charlen ** clp)
1601 if (iomode == IO_OUTPUT)
1605 mio_expr (&cl->length);
1610 if (peek_atom () != ATOM_RPAREN)
1612 cl = gfc_get_charlen ();
1613 mio_expr (&cl->length);
1617 cl->next = gfc_current_ns->cl_list;
1618 gfc_current_ns->cl_list = cl;
1626 /* Return a symtree node with a name that is guaranteed to be unique
1627 within the namespace and corresponds to an illegal fortran name. */
1629 static gfc_symtree *
1630 get_unique_symtree (gfc_namespace * ns)
1632 char name[GFC_MAX_SYMBOL_LEN + 1];
1633 static int serial = 0;
1635 sprintf (name, "@%d", serial++);
1636 return gfc_new_symtree (&ns->sym_root, name);
1640 /* See if a name is a generated name. */
1643 check_unique_name (const char *name)
1646 return *name == '@';
1651 mio_typespec (gfc_typespec * ts)
1656 ts->type = MIO_NAME(bt) (ts->type, bt_types);
1658 if (ts->type != BT_DERIVED)
1659 mio_integer (&ts->kind);
1661 mio_symbol_ref (&ts->derived);
1663 mio_charlen (&ts->cl);
1669 static const mstring array_spec_types[] = {
1670 minit ("EXPLICIT", AS_EXPLICIT),
1671 minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE),
1672 minit ("DEFERRED", AS_DEFERRED),
1673 minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE),
1679 mio_array_spec (gfc_array_spec ** asp)
1686 if (iomode == IO_OUTPUT)
1694 if (peek_atom () == ATOM_RPAREN)
1700 *asp = as = gfc_get_array_spec ();
1703 mio_integer (&as->rank);
1704 as->type = MIO_NAME(array_type) (as->type, array_spec_types);
1706 for (i = 0; i < as->rank; i++)
1708 mio_expr (&as->lower[i]);
1709 mio_expr (&as->upper[i]);
1717 /* Given a pointer to an array reference structure (which lives in a
1718 gfc_ref structure), find the corresponding array specification
1719 structure. Storing the pointer in the ref structure doesn't quite
1720 work when loading from a module. Generating code for an array
1721 reference also needs more infomation than just the array spec. */
1723 static const mstring array_ref_types[] = {
1724 minit ("FULL", AR_FULL),
1725 minit ("ELEMENT", AR_ELEMENT),
1726 minit ("SECTION", AR_SECTION),
1731 mio_array_ref (gfc_array_ref * ar)
1736 ar->type = MIO_NAME(ar_type) (ar->type, array_ref_types);
1737 mio_integer (&ar->dimen);
1745 for (i = 0; i < ar->dimen; i++)
1746 mio_expr (&ar->start[i]);
1751 for (i = 0; i < ar->dimen; i++)
1753 mio_expr (&ar->start[i]);
1754 mio_expr (&ar->end[i]);
1755 mio_expr (&ar->stride[i]);
1761 gfc_internal_error ("mio_array_ref(): Unknown array ref");
1764 for (i = 0; i < ar->dimen; i++)
1765 mio_integer ((int *) &ar->dimen_type[i]);
1767 if (iomode == IO_INPUT)
1769 ar->where = gfc_current_locus;
1771 for (i = 0; i < ar->dimen; i++)
1772 ar->c_where[i] = gfc_current_locus;
1779 /* Saves or restores a pointer. The pointer is converted back and
1780 forth from an integer. We return the pointer_info pointer so that
1781 the caller can take additional action based on the pointer type. */
1783 static pointer_info *
1784 mio_pointer_ref (void *gp)
1788 if (iomode == IO_OUTPUT)
1790 p = get_pointer (*((char **) gp));
1791 write_atom (ATOM_INTEGER, &p->integer);
1795 require_atom (ATOM_INTEGER);
1796 p = add_fixup (atom_int, gp);
1803 /* Save and load references to components that occur within
1804 expressions. We have to describe these references by a number and
1805 by name. The number is necessary for forward references during
1806 reading, and the name is necessary if the symbol already exists in
1807 the namespace and is not loaded again. */
1810 mio_component_ref (gfc_component ** cp, gfc_symbol * sym)
1812 char name[GFC_MAX_SYMBOL_LEN + 1];
1816 p = mio_pointer_ref (cp);
1817 if (p->type == P_UNKNOWN)
1818 p->type = P_COMPONENT;
1820 if (iomode == IO_OUTPUT)
1821 mio_internal_string ((*cp)->name);
1824 mio_internal_string (name);
1826 if (sym->components != NULL && p->u.pointer == NULL)
1828 /* Symbol already loaded, so search by name. */
1829 for (q = sym->components; q; q = q->next)
1830 if (strcmp (q->name, name) == 0)
1834 gfc_internal_error ("mio_component_ref(): Component not found");
1836 associate_integer_pointer (p, q);
1839 /* Make sure this symbol will eventually be loaded. */
1840 p = find_pointer2 (sym);
1841 if (p->u.rsym.state == UNUSED)
1842 p->u.rsym.state = NEEDED;
1848 mio_component (gfc_component * c)
1855 if (iomode == IO_OUTPUT)
1857 p = get_pointer (c);
1858 mio_integer (&p->integer);
1863 p = get_integer (n);
1864 associate_integer_pointer (p, c);
1867 if (p->type == P_UNKNOWN)
1868 p->type = P_COMPONENT;
1870 mio_internal_string (c->name);
1871 mio_typespec (&c->ts);
1872 mio_array_spec (&c->as);
1874 mio_integer (&c->dimension);
1875 mio_integer (&c->pointer);
1877 mio_expr (&c->initializer);
1883 mio_component_list (gfc_component ** cp)
1885 gfc_component *c, *tail;
1889 if (iomode == IO_OUTPUT)
1891 for (c = *cp; c; c = c->next)
1902 if (peek_atom () == ATOM_RPAREN)
1905 c = gfc_get_component ();
1922 mio_actual_arg (gfc_actual_arglist * a)
1926 mio_internal_string (a->name);
1927 mio_expr (&a->expr);
1933 mio_actual_arglist (gfc_actual_arglist ** ap)
1935 gfc_actual_arglist *a, *tail;
1939 if (iomode == IO_OUTPUT)
1941 for (a = *ap; a; a = a->next)
1951 if (peek_atom () != ATOM_LPAREN)
1954 a = gfc_get_actual_arglist ();
1970 /* Read and write formal argument lists. */
1973 mio_formal_arglist (gfc_symbol * sym)
1975 gfc_formal_arglist *f, *tail;
1979 if (iomode == IO_OUTPUT)
1981 for (f = sym->formal; f; f = f->next)
1982 mio_symbol_ref (&f->sym);
1987 sym->formal = tail = NULL;
1989 while (peek_atom () != ATOM_RPAREN)
1991 f = gfc_get_formal_arglist ();
1992 mio_symbol_ref (&f->sym);
1994 if (sym->formal == NULL)
2007 /* Save or restore a reference to a symbol node. */
2010 mio_symbol_ref (gfc_symbol ** symp)
2014 p = mio_pointer_ref (symp);
2015 if (p->type == P_UNKNOWN)
2018 if (iomode == IO_OUTPUT)
2020 if (p->u.wsym.state == UNREFERENCED)
2021 p->u.wsym.state = NEEDS_WRITE;
2025 if (p->u.rsym.state == UNUSED)
2026 p->u.rsym.state = NEEDED;
2031 /* Save or restore a reference to a symtree node. */
2034 mio_symtree_ref (gfc_symtree ** stp)
2039 if (iomode == IO_OUTPUT)
2041 mio_symbol_ref (&(*stp)->n.sym);
2045 require_atom (ATOM_INTEGER);
2046 p = get_integer (atom_int);
2047 if (p->type == P_UNKNOWN)
2050 if (p->u.rsym.state == UNUSED)
2051 p->u.rsym.state = NEEDED;
2053 if (p->u.rsym.symtree != NULL)
2055 *stp = p->u.rsym.symtree;
2059 f = gfc_getmem (sizeof (fixup_t));
2061 f->next = p->u.rsym.stfixup;
2062 p->u.rsym.stfixup = f;
2064 f->pointer = (void **)stp;
2070 mio_iterator (gfc_iterator ** ip)
2076 if (iomode == IO_OUTPUT)
2083 if (peek_atom () == ATOM_RPAREN)
2089 *ip = gfc_get_iterator ();
2094 mio_expr (&iter->var);
2095 mio_expr (&iter->start);
2096 mio_expr (&iter->end);
2097 mio_expr (&iter->step);
2106 mio_constructor (gfc_constructor ** cp)
2108 gfc_constructor *c, *tail;
2112 if (iomode == IO_OUTPUT)
2114 for (c = *cp; c; c = c->next)
2117 mio_expr (&c->expr);
2118 mio_iterator (&c->iterator);
2128 while (peek_atom () != ATOM_RPAREN)
2130 c = gfc_get_constructor ();
2140 mio_expr (&c->expr);
2141 mio_iterator (&c->iterator);
2151 static const mstring ref_types[] = {
2152 minit ("ARRAY", REF_ARRAY),
2153 minit ("COMPONENT", REF_COMPONENT),
2154 minit ("SUBSTRING", REF_SUBSTRING),
2160 mio_ref (gfc_ref ** rp)
2167 r->type = MIO_NAME(ref_type) (r->type, ref_types);
2172 mio_array_ref (&r->u.ar);
2176 mio_symbol_ref (&r->u.c.sym);
2177 mio_component_ref (&r->u.c.component, r->u.c.sym);
2181 mio_expr (&r->u.ss.start);
2182 mio_expr (&r->u.ss.end);
2183 mio_charlen (&r->u.ss.length);
2192 mio_ref_list (gfc_ref ** rp)
2194 gfc_ref *ref, *head, *tail;
2198 if (iomode == IO_OUTPUT)
2200 for (ref = *rp; ref; ref = ref->next)
2207 while (peek_atom () != ATOM_RPAREN)
2210 head = tail = gfc_get_ref ();
2213 tail->next = gfc_get_ref ();
2227 /* Read and write an integer value. */
2230 mio_gmp_integer (mpz_t * integer)
2234 if (iomode == IO_INPUT)
2236 if (parse_atom () != ATOM_STRING)
2237 bad_module ("Expected integer string");
2239 mpz_init (*integer);
2240 if (mpz_set_str (*integer, atom_string, 10))
2241 bad_module ("Error converting integer");
2243 gfc_free (atom_string);
2248 p = mpz_get_str (NULL, 10, *integer);
2249 write_atom (ATOM_STRING, p);
2256 mio_gmp_real (mpf_t * real)
2261 if (iomode == IO_INPUT)
2263 if (parse_atom () != ATOM_STRING)
2264 bad_module ("Expected real string");
2267 mpf_set_str (*real, atom_string, -16);
2268 gfc_free (atom_string);
2273 p = mpf_get_str (NULL, &exponent, 16, 0, *real);
2274 atom_string = gfc_getmem (strlen (p) + 20);
2276 sprintf (atom_string, "0.%s@%ld", p, exponent);
2278 /* Fix negative numbers. */
2279 if (atom_string[2] == '-')
2281 atom_string[0] = '-';
2282 atom_string[1] = '0';
2283 atom_string[2] = '.';
2286 write_atom (ATOM_STRING, atom_string);
2288 gfc_free (atom_string);
2294 /* Save and restore the shape of an array constructor. */
2297 mio_shape (mpz_t ** pshape, int rank)
2303 /* A NULL shape is represented by (). */
2306 if (iomode == IO_OUTPUT)
2318 if (t == ATOM_RPAREN)
2325 shape = gfc_get_shape (rank);
2329 for (n = 0; n < rank; n++)
2330 mio_gmp_integer (&shape[n]);
2336 static const mstring expr_types[] = {
2337 minit ("OP", EXPR_OP),
2338 minit ("FUNCTION", EXPR_FUNCTION),
2339 minit ("CONSTANT", EXPR_CONSTANT),
2340 minit ("VARIABLE", EXPR_VARIABLE),
2341 minit ("SUBSTRING", EXPR_SUBSTRING),
2342 minit ("STRUCTURE", EXPR_STRUCTURE),
2343 minit ("ARRAY", EXPR_ARRAY),
2344 minit ("NULL", EXPR_NULL),
2348 /* INTRINSIC_ASSIGN is missing because it is used as an index for
2349 generic operators, not in expressions. INTRINSIC_USER is also
2350 replaced by the correct function name by the time we see it. */
2352 static const mstring intrinsics[] =
2354 minit ("UPLUS", INTRINSIC_UPLUS),
2355 minit ("UMINUS", INTRINSIC_UMINUS),
2356 minit ("PLUS", INTRINSIC_PLUS),
2357 minit ("MINUS", INTRINSIC_MINUS),
2358 minit ("TIMES", INTRINSIC_TIMES),
2359 minit ("DIVIDE", INTRINSIC_DIVIDE),
2360 minit ("POWER", INTRINSIC_POWER),
2361 minit ("CONCAT", INTRINSIC_CONCAT),
2362 minit ("AND", INTRINSIC_AND),
2363 minit ("OR", INTRINSIC_OR),
2364 minit ("EQV", INTRINSIC_EQV),
2365 minit ("NEQV", INTRINSIC_NEQV),
2366 minit ("EQ", INTRINSIC_EQ),
2367 minit ("NE", INTRINSIC_NE),
2368 minit ("GT", INTRINSIC_GT),
2369 minit ("GE", INTRINSIC_GE),
2370 minit ("LT", INTRINSIC_LT),
2371 minit ("LE", INTRINSIC_LE),
2372 minit ("NOT", INTRINSIC_NOT),
2376 /* Read and write expressions. The form "()" is allowed to indicate a
2380 mio_expr (gfc_expr ** ep)
2388 if (iomode == IO_OUTPUT)
2397 MIO_NAME(expr_t) (e->expr_type, expr_types);
2403 if (t == ATOM_RPAREN)
2410 bad_module ("Expected expression type");
2412 e = *ep = gfc_get_expr ();
2413 e->where = gfc_current_locus;
2414 e->expr_type = (expr_t) find_enum (expr_types);
2417 mio_typespec (&e->ts);
2418 mio_integer (&e->rank);
2420 switch (e->expr_type)
2423 e->operator = MIO_NAME(gfc_intrinsic_op) (e->operator, intrinsics);
2425 switch (e->operator)
2427 case INTRINSIC_UPLUS:
2428 case INTRINSIC_UMINUS:
2433 case INTRINSIC_PLUS:
2434 case INTRINSIC_MINUS:
2435 case INTRINSIC_TIMES:
2436 case INTRINSIC_DIVIDE:
2437 case INTRINSIC_POWER:
2438 case INTRINSIC_CONCAT:
2442 case INTRINSIC_NEQV:
2454 bad_module ("Bad operator");
2460 mio_symtree_ref (&e->symtree);
2461 mio_actual_arglist (&e->value.function.actual);
2463 if (iomode == IO_OUTPUT)
2465 mio_allocated_string (&e->value.function.name);
2466 flag = e->value.function.esym != NULL;
2467 mio_integer (&flag);
2469 mio_symbol_ref (&e->value.function.esym);
2471 write_atom (ATOM_STRING, e->value.function.isym->name);
2476 require_atom (ATOM_STRING);
2477 e->value.function.name = gfc_get_string (atom_string);
2478 gfc_free (atom_string);
2480 mio_integer (&flag);
2482 mio_symbol_ref (&e->value.function.esym);
2485 require_atom (ATOM_STRING);
2486 e->value.function.isym = gfc_find_function (atom_string);
2487 gfc_free (atom_string);
2494 mio_symtree_ref (&e->symtree);
2495 mio_ref_list (&e->ref);
2498 case EXPR_SUBSTRING:
2499 mio_allocated_string (&e->value.character.string);
2504 case EXPR_STRUCTURE:
2506 mio_constructor (&e->value.constructor);
2507 mio_shape (&e->shape, e->rank);
2514 mio_gmp_integer (&e->value.integer);
2518 mio_gmp_real (&e->value.real);
2522 mio_gmp_real (&e->value.complex.r);
2523 mio_gmp_real (&e->value.complex.i);
2527 mio_integer (&e->value.logical);
2531 mio_integer (&e->value.character.length);
2532 mio_allocated_string (&e->value.character.string);
2536 bad_module ("Bad type in constant expression");
2549 /* Save/restore lists of gfc_interface stuctures. When loading an
2550 interface, we are really appending to the existing list of
2551 interfaces. Checking for duplicate and ambiguous interfaces has to
2552 be done later when all symbols have been loaded. */
2555 mio_interface_rest (gfc_interface ** ip)
2557 gfc_interface *tail, *p;
2559 if (iomode == IO_OUTPUT)
2562 for (p = *ip; p; p = p->next)
2563 mio_symbol_ref (&p->sym);
2579 if (peek_atom () == ATOM_RPAREN)
2582 p = gfc_get_interface ();
2583 mio_symbol_ref (&p->sym);
2598 /* Save/restore a nameless operator interface. */
2601 mio_interface (gfc_interface ** ip)
2605 mio_interface_rest (ip);
2609 /* Save/restore a named operator interface. */
2612 mio_symbol_interface (char *name, char *module,
2613 gfc_interface ** ip)
2618 mio_internal_string (name);
2619 mio_internal_string (module);
2621 mio_interface_rest (ip);
2626 mio_namespace_ref (gfc_namespace ** nsp)
2631 p = mio_pointer_ref (nsp);
2633 if (p->type == P_UNKNOWN)
2634 p->type = P_NAMESPACE;
2636 if (iomode == IO_INPUT && p->integer != 0 && p->u.pointer == NULL)
2638 ns = gfc_get_namespace (NULL);
2639 associate_integer_pointer (p, ns);
2644 /* Unlike most other routines, the address of the symbol node is
2645 already fixed on input and the name/module has already been filled
2649 mio_symbol (gfc_symbol * sym)
2651 gfc_formal_arglist *formal;
2655 mio_symbol_attribute (&sym->attr);
2656 mio_typespec (&sym->ts);
2658 /* Contained procedures don't have formal namespaces. Instead we output the
2659 procedure namespace. The will contain the formal arguments. */
2660 if (iomode == IO_OUTPUT)
2662 formal = sym->formal;
2663 while (formal && !formal->sym)
2664 formal = formal->next;
2667 mio_namespace_ref (&formal->sym->ns);
2669 mio_namespace_ref (&sym->formal_ns);
2673 mio_namespace_ref (&sym->formal_ns);
2676 sym->formal_ns->proc_name = sym;
2681 /* Save/restore common block links */
2682 mio_symbol_ref (&sym->common_head);
2683 mio_symbol_ref (&sym->common_next);
2685 mio_formal_arglist (sym);
2687 mio_expr (&sym->value);
2688 mio_array_spec (&sym->as);
2690 mio_symbol_ref (&sym->result);
2692 /* Note that components are always saved, even if they are supposed
2693 to be private. Component access is checked during searching. */
2695 mio_component_list (&sym->components);
2697 if (sym->components != NULL)
2698 sym->component_access =
2699 MIO_NAME(gfc_access) (sym->component_access, access_types);
2701 mio_symbol_ref (&sym->common_head);
2702 mio_symbol_ref (&sym->common_next);
2708 /************************* Top level subroutines *************************/
2710 /* Skip a list between balanced left and right parens. */
2720 switch (parse_atom ())
2731 gfc_free (atom_string);
2743 /* Load operator interfaces from the module. Interfaces are unusual
2744 in that they attach themselves to existing symbols. */
2747 load_operator_interfaces (void)
2750 char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
2755 while (peek_atom () != ATOM_RPAREN)
2759 mio_internal_string (name);
2760 mio_internal_string (module);
2762 /* Decide if we need to load this one or not. */
2763 p = find_use_name (name);
2766 while (parse_atom () != ATOM_RPAREN);
2770 uop = gfc_get_uop (p);
2771 mio_interface_rest (&uop->operator);
2779 /* Load interfaces from the module. Interfaces are unusual in that
2780 they attach themselves to existing symbols. */
2783 load_generic_interfaces (void)
2786 char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
2791 while (peek_atom () != ATOM_RPAREN)
2795 mio_internal_string (name);
2796 mio_internal_string (module);
2798 /* Decide if we need to load this one or not. */
2799 p = find_use_name (name);
2801 if (p == NULL || gfc_find_symbol (p, NULL, 0, &sym))
2803 while (parse_atom () != ATOM_RPAREN);
2809 gfc_get_symbol (p, NULL, &sym);
2811 sym->attr.flavor = FL_PROCEDURE;
2812 sym->attr.generic = 1;
2813 sym->attr.use_assoc = 1;
2816 mio_interface_rest (&sym->generic);
2823 /* Recursive function to traverse the pointer_info tree and load a
2824 needed symbol. We return nonzero if we load a symbol and stop the
2825 traversal, because the act of loading can alter the tree. */
2828 load_needed (pointer_info * p)
2836 if (load_needed (p->left))
2838 if (load_needed (p->right))
2841 if (p->type != P_SYMBOL || p->u.rsym.state != NEEDED)
2844 p->u.rsym.state = USED;
2846 set_module_locus (&p->u.rsym.where);
2848 sym = p->u.rsym.sym;
2851 q = get_integer (p->u.rsym.ns);
2853 ns = (gfc_namespace *) q->u.pointer;
2856 /* Create an interface namespace if necessary. These are
2857 the namespaces that hold the formal parameters of module
2860 ns = gfc_get_namespace (NULL);
2861 associate_integer_pointer (q, ns);
2864 sym = gfc_new_symbol (p->u.rsym.true_name, ns);
2865 strcpy (sym->module, p->u.rsym.module);
2867 associate_integer_pointer (p, sym);
2871 sym->attr.use_assoc = 1;
2877 /* Recursive function for cleaning up things after a module has been
2881 read_cleanup (pointer_info * p)
2889 read_cleanup (p->left);
2890 read_cleanup (p->right);
2892 if (p->type == P_SYMBOL && p->u.rsym.state == USED && !p->u.rsym.referenced)
2894 /* Add hidden symbols to the symtree. */
2895 q = get_integer (p->u.rsym.ns);
2896 st = get_unique_symtree ((gfc_namespace *) q->u.pointer);
2898 st->n.sym = p->u.rsym.sym;
2901 /* Fixup any symtree references. */
2902 p->u.rsym.symtree = st;
2903 resolve_fixups (p->u.rsym.stfixup, st);
2904 p->u.rsym.stfixup = NULL;
2907 /* Free unused symbols. */
2908 if (p->type == P_SYMBOL && p->u.rsym.state == UNUSED)
2909 gfc_free_symbol (p->u.rsym.sym);
2913 /* Read a module file. */
2918 module_locus operator_interfaces, user_operators;
2920 char name[GFC_MAX_SYMBOL_LEN + 1];
2922 int ambiguous, symbol;
2928 get_module_locus (&operator_interfaces); /* Skip these for now */
2931 get_module_locus (&user_operators);
2937 /* Create the fixup nodes for all the symbols. */
2939 while (peek_atom () != ATOM_RPAREN)
2941 require_atom (ATOM_INTEGER);
2942 info = get_integer (atom_int);
2944 info->type = P_SYMBOL;
2945 info->u.rsym.state = UNUSED;
2947 mio_internal_string (info->u.rsym.true_name);
2948 mio_internal_string (info->u.rsym.module);
2950 require_atom (ATOM_INTEGER);
2951 info->u.rsym.ns = atom_int;
2953 get_module_locus (&info->u.rsym.where);
2956 /* See if the symbol has already been loaded by a previous module.
2957 If so, we reference the existing symbol and prevent it from
2958 being loaded again. */
2960 sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module);
2964 info->u.rsym.state = USED;
2965 info->u.rsym.referenced = 1;
2966 info->u.rsym.sym = sym;
2971 /* Parse the symtree lists. This lets us mark which symbols need to
2972 be loaded. Renaming is also done at this point by replacing the
2977 while (peek_atom () != ATOM_RPAREN)
2979 mio_internal_string (name);
2980 mio_integer (&ambiguous);
2981 mio_integer (&symbol);
2983 info = get_integer (symbol);
2985 /* Get the local name for this symbol. */
2986 p = find_use_name (name);
2988 /* Skip symtree nodes not in an ONLY caluse. */
2992 /* Check for ambiguous symbols. */
2993 st = gfc_find_symtree (gfc_current_ns->sym_root, p);
2997 if (st->n.sym != info->u.rsym.sym)
2999 info->u.rsym.symtree = st;
3003 /* Create a symtree node in the current namespace for this symbol. */
3004 st = check_unique_name (p) ? get_unique_symtree (gfc_current_ns) :
3005 gfc_new_symtree (&gfc_current_ns->sym_root, p);
3007 st->ambiguous = ambiguous;
3009 sym = info->u.rsym.sym;
3011 /* Create a symbol node if it doesn't already exist. */
3014 sym = info->u.rsym.sym =
3015 gfc_new_symbol (info->u.rsym.true_name, gfc_current_ns);
3017 strcpy (sym->module, info->u.rsym.module);
3023 /* Store the symtree pointing to this symbol. */
3024 info->u.rsym.symtree = st;
3026 if (info->u.rsym.state == UNUSED)
3027 info->u.rsym.state = NEEDED;
3028 info->u.rsym.referenced = 1;
3034 /* Load intrinsic operator interfaces. */
3035 set_module_locus (&operator_interfaces);
3038 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3040 if (i == INTRINSIC_USER)
3045 u = find_use_operator (i);
3056 mio_interface (&gfc_current_ns->operator[i]);
3061 /* Load generic and user operator interfaces. These must follow the
3062 loading of symtree because otherwise symbols can be marked as
3065 set_module_locus (&user_operators);
3067 load_operator_interfaces ();
3068 load_generic_interfaces ();
3070 /* At this point, we read those symbols that are needed but haven't
3071 been loaded yet. If one symbol requires another, the other gets
3072 marked as NEEDED if its previous state was UNUSED. */
3074 while (load_needed (pi_root));
3076 /* Make sure all elements of the rename-list were found in the
3079 for (u = gfc_rename_list; u; u = u->next)
3084 if (u->operator == INTRINSIC_NONE)
3086 gfc_error ("Symbol '%s' referenced at %L not found in module '%s'",
3087 u->use_name, &u->where, module_name);
3091 if (u->operator == INTRINSIC_USER)
3094 ("User operator '%s' referenced at %L not found in module '%s'",
3095 u->use_name, &u->where, module_name);
3100 ("Intrinsic operator '%s' referenced at %L not found in module "
3101 "'%s'", gfc_op2string (u->operator), &u->where, module_name);
3104 gfc_check_interfaces (gfc_current_ns);
3106 /* Clean up symbol nodes that were never loaded, create references
3107 to hidden symbols. */
3109 read_cleanup (pi_root);
3113 /* Given an access type that is specific to an entity and the default
3114 access, return nonzero if we should write the entity. */
3117 check_access (gfc_access specific_access, gfc_access default_access)
3120 if (specific_access == ACCESS_PUBLIC)
3122 if (specific_access == ACCESS_PRIVATE)
3125 if (gfc_option.flag_module_access_private)
3127 if (default_access == ACCESS_PUBLIC)
3132 if (default_access != ACCESS_PRIVATE)
3140 /* Write a symbol to the module. */
3143 write_symbol (int n, gfc_symbol * sym)
3146 if (sym->attr.flavor == FL_UNKNOWN || sym->attr.flavor == FL_LABEL)
3147 gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym->name);
3150 if (sym->attr.flavor == FL_VARIABLE && sym->ts.type == BT_UNKNOWN)
3151 /* TODO: this is a workaround for some of the problems in PR15481,
3152 and fixes the dependent bug PR13372. In an ideal frontend, this
3153 should never happen. */
3157 mio_internal_string (sym->name);
3159 if (sym->module[0] == '\0')
3160 strcpy (sym->module, module_name);
3162 mio_internal_string (sym->module);
3163 mio_pointer_ref (&sym->ns);
3170 /* Recursive traversal function to write the initial set of symbols to
3171 the module. We check to see if the symbol should be written
3172 according to the access specification. */
3175 write_symbol0 (gfc_symtree * st)
3183 write_symbol0 (st->left);
3184 write_symbol0 (st->right);
3188 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
3189 && !sym->attr.subroutine && !sym->attr.function)
3192 if (!check_access (sym->attr.access, sym->ns->default_access))
3195 p = get_pointer (sym);
3196 if (p->type == P_UNKNOWN)
3199 if (p->u.wsym.state == WRITTEN)
3202 write_symbol (p->integer, sym);
3203 p->u.wsym.state = WRITTEN;
3209 /* Recursive traversal function to write the secondary set of symbols
3210 to the module file. These are symbols that were not public yet are
3211 needed by the public symbols or another dependent symbol. The act
3212 of writing a symbol can modify the pointer_info tree, so we cease
3213 traversal if we find a symbol to write. We return nonzero if a
3214 symbol was written and pass that information upwards. */
3217 write_symbol1 (pointer_info * p)
3223 if (write_symbol1 (p->left))
3225 if (write_symbol1 (p->right))
3228 if (p->type != P_SYMBOL || p->u.wsym.state != NEEDS_WRITE)
3231 p->u.wsym.state = WRITTEN;
3232 write_symbol (p->integer, p->u.wsym.sym);
3238 /* Write operator interfaces associated with a symbol. */
3241 write_operator (gfc_user_op * uop)
3243 static char nullstring[] = "";
3245 if (uop->operator == NULL
3246 || !check_access (uop->access, uop->ns->default_access))
3249 mio_symbol_interface (uop->name, nullstring, &uop->operator);
3253 /* Write generic interfaces associated with a symbol. */
3256 write_generic (gfc_symbol * sym)
3259 if (sym->generic == NULL
3260 || !check_access (sym->attr.access, sym->ns->default_access))
3263 mio_symbol_interface (sym->name, sym->module, &sym->generic);
3268 write_symtree (gfc_symtree * st)
3274 if (!check_access (sym->attr.access, sym->ns->default_access)
3275 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
3276 && !sym->attr.subroutine && !sym->attr.function))
3279 if (sym->attr.flavor == FL_VARIABLE && sym->ts.type == BT_UNKNOWN)
3280 /* TODO: this is a workaround for some of the problems in PR15481,
3281 and fixes the dependent bug PR13372. In an ideal frontend, this
3282 should never happen. */
3285 if (check_unique_name (st->name))
3288 p = find_pointer (sym);
3290 gfc_internal_error ("write_symtree(): Symbol not written");
3292 mio_internal_string (st->name);
3293 mio_integer (&st->ambiguous);
3294 mio_integer (&p->integer);
3303 /* Write the operator interfaces. */
3306 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3308 if (i == INTRINSIC_USER)
3311 mio_interface (check_access (gfc_current_ns->operator_access[i],
3312 gfc_current_ns->default_access)
3313 ? &gfc_current_ns->operator[i] : NULL);
3321 gfc_traverse_user_op (gfc_current_ns, write_operator);
3327 gfc_traverse_ns (gfc_current_ns, write_generic);
3332 /* Write symbol information. First we traverse all symbols in the
3333 primary namespace, writing those that need to be written.
3334 Sometimes writing one symbol will cause another to need to be
3335 written. A list of these symbols ends up on the write stack, and
3336 we end by popping the bottom of the stack and writing the symbol
3337 until the stack is empty. */
3341 write_symbol0 (gfc_current_ns->sym_root);
3342 while (write_symbol1 (pi_root));
3350 gfc_traverse_symtree (gfc_current_ns, write_symtree);
3355 /* Given module, dump it to disk. If there was an error while
3356 processing the module, dump_flag will be set to zero and we delete
3357 the module file, even if it was already there. */
3360 gfc_dump_module (const char *name, int dump_flag)
3362 char filename[PATH_MAX], *p;
3366 if (gfc_option.module_dir != NULL)
3367 strcpy (filename, gfc_option.module_dir);
3369 strcat (filename, name);
3370 strcat (filename, MODULE_EXTENSION);
3378 module_fp = fopen (filename, "w");
3379 if (module_fp == NULL)
3380 gfc_fatal_error ("Can't open module file '%s' for writing: %s",
3381 filename, strerror (errno));
3386 *strchr (p, '\n') = '\0';
3388 fprintf (module_fp, "GFORTRAN module created from %s on %s\n",
3389 gfc_source_file, p);
3390 fputs ("If you edit this, you'll get what you deserve.\n\n", module_fp);
3393 strcpy (module_name, name);
3399 free_pi_tree (pi_root);
3404 if (fclose (module_fp))
3405 gfc_fatal_error ("Error writing module file '%s' for writing: %s",
3406 filename, strerror (errno));
3410 /* Process a USE directive. */
3413 gfc_use_module (void)
3415 char filename[GFC_MAX_SYMBOL_LEN + 5];
3419 strcpy (filename, module_name);
3420 strcat (filename, MODULE_EXTENSION);
3422 module_fp = gfc_open_included_file (filename);
3423 if (module_fp == NULL)
3424 gfc_fatal_error ("Can't open module file '%s' for reading: %s",
3425 filename, strerror (errno));
3431 /* Skip the first two lines of the module. */
3432 /* FIXME: Could also check for valid two lines here, instead. */
3438 bad_module ("Unexpected end of module");
3443 /* Make sure we're not reading the same module that we may be building. */
3444 for (p = gfc_state_stack; p; p = p->previous)
3445 if (p->state == COMP_MODULE && strcmp (p->sym->name, module_name) == 0)
3446 gfc_fatal_error ("Can't USE the same module we're building!");
3449 init_true_name_tree ();
3453 free_true_name (true_name_root);
3454 true_name_root = NULL;
3456 free_pi_tree (pi_root);
3464 gfc_module_init_2 (void)
3467 last_atom = ATOM_LPAREN;
3472 gfc_module_done_2 (void)