1 /* Handle modules, which amounts to loading and saving symbols and
2 their attendant structures.
3 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free
4 Software Foundation, Inc.
5 Contributed by Andy Vaught
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 2, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING. If not, write to the Free
21 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
24 /* The syntax of gfortran modules resembles that of lisp lists, ie a
25 sequence of atoms, which can be left or right parenthesis, names,
26 integers or strings. Parenthesis are always matched which allows
27 us to skip over sections at high speed without having to know
28 anything about the internal structure of the lists. A "name" is
29 usually a fortran 95 identifier, but can also start with '@' in
30 order to reference a hidden symbol.
32 The first line of a module is an informational message about what
33 created the module, the file it came from and when it was created.
34 The second line is a warning for people not to edit the module.
35 The rest of the module looks like:
37 ( ( <Interface info for UPLUS> )
38 ( <Interface info for UMINUS> )
41 ( ( <name of operator interface> <module of op interface> <i/f1> ... )
44 ( ( <name of generic interface> <module of generic interface> <i/f1> ... )
47 ( ( <common name> <symbol> <saved flag>)
53 ( <Symbol Number (in no particular order)>
55 <Module name of symbol>
56 ( <symbol information> )
65 In general, symbols refer to other symbols by their symbol number,
66 which are zero based. Symbols are written to the module in no
74 #include "parse.h" /* FIXME */
76 #define MODULE_EXTENSION ".mod"
79 /* Structure that describes a position within a module file. */
91 P_UNKNOWN = 0, P_OTHER, P_NAMESPACE, P_COMPONENT, P_SYMBOL
95 /* The fixup structure lists pointers to pointers that have to
96 be updated when a pointer value becomes known. */
98 typedef struct fixup_t
101 struct fixup_t *next;
106 /* Structure for holding extra info needed for pointers being read. */
108 typedef struct pointer_info
110 BBT_HEADER (pointer_info);
114 /* The first component of each member of the union is the pointer
121 void *pointer; /* Member for doing pointer searches. */
126 char true_name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
128 { UNUSED, NEEDED, USED }
133 gfc_symtree *symtree;
141 { UNREFERENCED = 0, NEEDS_WRITE, WRITTEN }
151 #define gfc_get_pointer_info() gfc_getmem(sizeof(pointer_info))
154 /* Lists of rename info for the USE statement. */
156 typedef struct gfc_use_rename
158 char local_name[GFC_MAX_SYMBOL_LEN + 1], use_name[GFC_MAX_SYMBOL_LEN + 1];
159 struct gfc_use_rename *next;
161 gfc_intrinsic_op operator;
166 #define gfc_get_use_rename() gfc_getmem(sizeof(gfc_use_rename))
168 /* Local variables */
170 /* The FILE for the module we're reading or writing. */
171 static FILE *module_fp;
173 /* The name of the module we're reading (USE'ing) or writing. */
174 static char module_name[GFC_MAX_SYMBOL_LEN + 1];
176 static int module_line, module_column, only_flag;
178 { IO_INPUT, IO_OUTPUT }
181 static gfc_use_rename *gfc_rename_list;
182 static pointer_info *pi_root;
183 static int symbol_number; /* Counter for assigning symbol numbers */
185 /* Tells mio_expr_ref not to load unused equivalence members. */
186 static bool in_load_equiv;
190 /*****************************************************************/
192 /* Pointer/integer conversion. Pointers between structures are stored
193 as integers in the module file. The next couple of subroutines
194 handle this translation for reading and writing. */
196 /* Recursively free the tree of pointer structures. */
199 free_pi_tree (pointer_info * p)
204 if (p->fixup != NULL)
205 gfc_internal_error ("free_pi_tree(): Unresolved fixup");
207 free_pi_tree (p->left);
208 free_pi_tree (p->right);
214 /* Compare pointers when searching by pointer. Used when writing a
218 compare_pointers (void * _sn1, void * _sn2)
220 pointer_info *sn1, *sn2;
222 sn1 = (pointer_info *) _sn1;
223 sn2 = (pointer_info *) _sn2;
225 if (sn1->u.pointer < sn2->u.pointer)
227 if (sn1->u.pointer > sn2->u.pointer)
234 /* Compare integers when searching by integer. Used when reading a
238 compare_integers (void * _sn1, void * _sn2)
240 pointer_info *sn1, *sn2;
242 sn1 = (pointer_info *) _sn1;
243 sn2 = (pointer_info *) _sn2;
245 if (sn1->integer < sn2->integer)
247 if (sn1->integer > sn2->integer)
254 /* Initialize the pointer_info tree. */
263 compare = (iomode == IO_INPUT) ? compare_integers : compare_pointers;
265 /* Pointer 0 is the NULL pointer. */
266 p = gfc_get_pointer_info ();
271 gfc_insert_bbt (&pi_root, p, compare);
273 /* Pointer 1 is the current namespace. */
274 p = gfc_get_pointer_info ();
275 p->u.pointer = gfc_current_ns;
277 p->type = P_NAMESPACE;
279 gfc_insert_bbt (&pi_root, p, compare);
285 /* During module writing, call here with a pointer to something,
286 returning the pointer_info node. */
288 static pointer_info *
289 find_pointer (void *gp)
296 if (p->u.pointer == gp)
298 p = (gp < p->u.pointer) ? p->left : p->right;
305 /* Given a pointer while writing, returns the pointer_info tree node,
306 creating it if it doesn't exist. */
308 static pointer_info *
309 get_pointer (void *gp)
313 p = find_pointer (gp);
317 /* Pointer doesn't have an integer. Give it one. */
318 p = gfc_get_pointer_info ();
321 p->integer = symbol_number++;
323 gfc_insert_bbt (&pi_root, p, compare_pointers);
329 /* Given an integer during reading, find it in the pointer_info tree,
330 creating the node if not found. */
332 static pointer_info *
333 get_integer (int integer)
343 c = compare_integers (&t, p);
347 p = (c < 0) ? p->left : p->right;
353 p = gfc_get_pointer_info ();
354 p->integer = integer;
357 gfc_insert_bbt (&pi_root, p, compare_integers);
363 /* Recursive function to find a pointer within a tree by brute force. */
365 static pointer_info *
366 fp2 (pointer_info * p, const void *target)
373 if (p->u.pointer == target)
376 q = fp2 (p->left, target);
380 return fp2 (p->right, target);
384 /* During reading, find a pointer_info node from the pointer value.
385 This amounts to a brute-force search. */
387 static pointer_info *
388 find_pointer2 (void *p)
391 return fp2 (pi_root, p);
395 /* Resolve any fixups using a known pointer. */
397 resolve_fixups (fixup_t *f, void * gp)
409 /* Call here during module reading when we know what pointer to
410 associate with an integer. Any fixups that exist are resolved at
414 associate_integer_pointer (pointer_info * p, void *gp)
416 if (p->u.pointer != NULL)
417 gfc_internal_error ("associate_integer_pointer(): Already associated");
421 resolve_fixups (p->fixup, gp);
427 /* During module reading, given an integer and a pointer to a pointer,
428 either store the pointer from an already-known value or create a
429 fixup structure in order to store things later. Returns zero if
430 the reference has been actually stored, or nonzero if the reference
431 must be fixed later (ie associate_integer_pointer must be called
432 sometime later. Returns the pointer_info structure. */
434 static pointer_info *
435 add_fixup (int integer, void *gp)
441 p = get_integer (integer);
443 if (p->integer == 0 || p->u.pointer != NULL)
450 f = gfc_getmem (sizeof (fixup_t));
462 /*****************************************************************/
464 /* Parser related subroutines */
466 /* Free the rename list left behind by a USE statement. */
471 gfc_use_rename *next;
473 for (; gfc_rename_list; gfc_rename_list = next)
475 next = gfc_rename_list->next;
476 gfc_free (gfc_rename_list);
481 /* Match a USE statement. */
486 char name[GFC_MAX_SYMBOL_LEN + 1];
487 gfc_use_rename *tail = NULL, *new;
489 gfc_intrinsic_op operator;
492 m = gfc_match_name (module_name);
499 if (gfc_match_eos () == MATCH_YES)
501 if (gfc_match_char (',') != MATCH_YES)
504 if (gfc_match (" only :") == MATCH_YES)
507 if (gfc_match_eos () == MATCH_YES)
512 /* Get a new rename struct and add it to the rename list. */
513 new = gfc_get_use_rename ();
514 new->where = gfc_current_locus;
517 if (gfc_rename_list == NULL)
518 gfc_rename_list = new;
523 /* See what kind of interface we're dealing with. Assume it is
525 new->operator = INTRINSIC_NONE;
526 if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
531 case INTERFACE_NAMELESS:
532 gfc_error ("Missing generic specification in USE statement at %C");
535 case INTERFACE_GENERIC:
536 m = gfc_match (" =>");
541 strcpy (new->use_name, name);
544 strcpy (new->local_name, name);
546 m = gfc_match_name (new->use_name);
549 if (m == MATCH_ERROR)
557 strcpy (new->local_name, name);
559 m = gfc_match_name (new->use_name);
562 if (m == MATCH_ERROR)
568 case INTERFACE_USER_OP:
569 strcpy (new->use_name, name);
572 case INTERFACE_INTRINSIC_OP:
573 new->operator = operator;
577 if (gfc_match_eos () == MATCH_YES)
579 if (gfc_match_char (',') != MATCH_YES)
586 gfc_syntax_error (ST_USE);
594 /* Given a name and a number, inst, return the inst name
595 under which to load this symbol. Returns NULL if this
596 symbol shouldn't be loaded. If inst is zero, returns
597 the number of instances of this name. */
600 find_use_name_n (const char *name, int *inst)
606 for (u = gfc_rename_list; u; u = u->next)
608 if (strcmp (u->use_name, name) != 0)
621 return only_flag ? NULL : name;
625 return (u->local_name[0] != '\0') ? u->local_name : name;
628 /* Given a name, return the name under which to load this symbol.
629 Returns NULL if this symbol shouldn't be loaded. */
632 find_use_name (const char *name)
635 return find_use_name_n (name, &i);
638 /* Given a real name, return the number of use names associated
642 number_use_names (const char *name)
646 c = find_use_name_n (name, &i);
651 /* Try to find the operator in the current list. */
653 static gfc_use_rename *
654 find_use_operator (gfc_intrinsic_op operator)
658 for (u = gfc_rename_list; u; u = u->next)
659 if (u->operator == operator)
666 /*****************************************************************/
668 /* The next couple of subroutines maintain a tree used to avoid a
669 brute-force search for a combination of true name and module name.
670 While symtree names, the name that a particular symbol is known by
671 can changed with USE statements, we still have to keep track of the
672 true names to generate the correct reference, and also avoid
673 loading the same real symbol twice in a program unit.
675 When we start reading, the true name tree is built and maintained
676 as symbols are read. The tree is searched as we load new symbols
677 to see if it already exists someplace in the namespace. */
679 typedef struct true_name
681 BBT_HEADER (true_name);
686 static true_name *true_name_root;
689 /* Compare two true_name structures. */
692 compare_true_names (void * _t1, void * _t2)
697 t1 = (true_name *) _t1;
698 t2 = (true_name *) _t2;
700 c = ((t1->sym->module > t2->sym->module)
701 - (t1->sym->module < t2->sym->module));
705 return strcmp (t1->sym->name, t2->sym->name);
709 /* Given a true name, search the true name tree to see if it exists
710 within the main namespace. */
713 find_true_name (const char *name, const char *module)
719 sym.name = gfc_get_string (name);
721 sym.module = gfc_get_string (module);
729 c = compare_true_names ((void *)(&t), (void *) p);
733 p = (c < 0) ? p->left : p->right;
740 /* Given a gfc_symbol pointer that is not in the true name tree, add
744 add_true_name (gfc_symbol * sym)
748 t = gfc_getmem (sizeof (true_name));
751 gfc_insert_bbt (&true_name_root, t, compare_true_names);
755 /* Recursive function to build the initial true name tree by
756 recursively traversing the current namespace. */
759 build_tnt (gfc_symtree * st)
765 build_tnt (st->left);
766 build_tnt (st->right);
768 if (find_true_name (st->n.sym->name, st->n.sym->module) != NULL)
771 add_true_name (st->n.sym);
775 /* Initialize the true name tree with the current namespace. */
778 init_true_name_tree (void)
780 true_name_root = NULL;
782 build_tnt (gfc_current_ns->sym_root);
786 /* Recursively free a true name tree node. */
789 free_true_name (true_name * t)
794 free_true_name (t->left);
795 free_true_name (t->right);
801 /*****************************************************************/
803 /* Module reading and writing. */
807 ATOM_NAME, ATOM_LPAREN, ATOM_RPAREN, ATOM_INTEGER, ATOM_STRING
811 static atom_type last_atom;
814 /* The name buffer must be at least as long as a symbol name. Right
815 now it's not clear how we're going to store numeric constants--
816 probably as a hexadecimal string, since this will allow the exact
817 number to be preserved (this can't be done by a decimal
818 representation). Worry about that later. TODO! */
820 #define MAX_ATOM_SIZE 100
823 static char *atom_string, atom_name[MAX_ATOM_SIZE];
826 /* Report problems with a module. Error reporting is not very
827 elaborate, since this sorts of errors shouldn't really happen.
828 This subroutine never returns. */
830 static void bad_module (const char *) ATTRIBUTE_NORETURN;
833 bad_module (const char *msgid)
840 gfc_fatal_error ("Reading module %s at line %d column %d: %s",
841 module_name, module_line, module_column, msgid);
844 gfc_fatal_error ("Writing module %s at line %d column %d: %s",
845 module_name, module_line, module_column, msgid);
848 gfc_fatal_error ("Module %s at line %d column %d: %s",
849 module_name, module_line, module_column, msgid);
855 /* Set the module's input pointer. */
858 set_module_locus (module_locus * m)
861 module_column = m->column;
862 module_line = m->line;
863 fsetpos (module_fp, &m->pos);
867 /* Get the module's input pointer so that we can restore it later. */
870 get_module_locus (module_locus * m)
873 m->column = module_column;
874 m->line = module_line;
875 fgetpos (module_fp, &m->pos);
879 /* Get the next character in the module, updating our reckoning of
887 c = fgetc (module_fp);
890 bad_module ("Unexpected EOF");
903 /* Parse a string constant. The delimiter is guaranteed to be a
913 get_module_locus (&start);
917 /* See how long the string is */
922 bad_module ("Unexpected end of module in string constant");
940 set_module_locus (&start);
942 atom_string = p = gfc_getmem (len + 1);
944 for (; len > 0; len--)
948 module_char (); /* Guaranteed to be another \' */
952 module_char (); /* Terminating \' */
953 *p = '\0'; /* C-style string for debug purposes */
957 /* Parse a small integer. */
960 parse_integer (int c)
968 get_module_locus (&m);
974 atom_int = 10 * atom_int + c - '0';
975 if (atom_int > 99999999)
976 bad_module ("Integer overflow");
979 set_module_locus (&m);
997 get_module_locus (&m);
1002 if (!ISALNUM (c) && c != '_' && c != '-')
1006 if (++len > GFC_MAX_SYMBOL_LEN)
1007 bad_module ("Name too long");
1012 fseek (module_fp, -1, SEEK_CUR);
1013 module_column = m.column + len - 1;
1020 /* Read the next atom in the module's input stream. */
1031 while (c == ' ' || c == '\n');
1056 return ATOM_INTEGER;
1114 bad_module ("Bad name");
1121 /* Peek at the next atom on the input. */
1129 get_module_locus (&m);
1132 if (a == ATOM_STRING)
1133 gfc_free (atom_string);
1135 set_module_locus (&m);
1140 /* Read the next atom from the input, requiring that it be a
1144 require_atom (atom_type type)
1150 get_module_locus (&m);
1158 p = _("Expected name");
1161 p = _("Expected left parenthesis");
1164 p = _("Expected right parenthesis");
1167 p = _("Expected integer");
1170 p = _("Expected string");
1173 gfc_internal_error ("require_atom(): bad atom type required");
1176 set_module_locus (&m);
1182 /* Given a pointer to an mstring array, require that the current input
1183 be one of the strings in the array. We return the enum value. */
1186 find_enum (const mstring * m)
1190 i = gfc_string2code (m, atom_name);
1194 bad_module ("find_enum(): Enum not found");
1200 /**************** Module output subroutines ***************************/
1202 /* Output a character to a module file. */
1205 write_char (char out)
1208 if (fputc (out, module_fp) == EOF)
1209 gfc_fatal_error ("Error writing modules file: %s", strerror (errno));
1221 /* Write an atom to a module. The line wrapping isn't perfect, but it
1222 should work most of the time. This isn't that big of a deal, since
1223 the file really isn't meant to be read by people anyway. */
1226 write_atom (atom_type atom, const void *v)
1248 i = *((const int *) v);
1250 gfc_internal_error ("write_atom(): Writing negative integer");
1252 sprintf (buffer, "%d", i);
1257 gfc_internal_error ("write_atom(): Trying to write dab atom");
1263 if (atom != ATOM_RPAREN)
1265 if (module_column + len > 72)
1270 if (last_atom != ATOM_LPAREN && module_column != 1)
1275 if (atom == ATOM_STRING)
1280 if (atom == ATOM_STRING && *p == '\'')
1285 if (atom == ATOM_STRING)
1293 /***************** Mid-level I/O subroutines *****************/
1295 /* These subroutines let their caller read or write atoms without
1296 caring about which of the two is actually happening. This lets a
1297 subroutine concentrate on the actual format of the data being
1300 static void mio_expr (gfc_expr **);
1301 static void mio_symbol_ref (gfc_symbol **);
1302 static void mio_symtree_ref (gfc_symtree **);
1304 /* Read or write an enumerated value. On writing, we return the input
1305 value for the convenience of callers. We avoid using an integer
1306 pointer because enums are sometimes inside bitfields. */
1309 mio_name (int t, const mstring * m)
1312 if (iomode == IO_OUTPUT)
1313 write_atom (ATOM_NAME, gfc_code2string (m, t));
1316 require_atom (ATOM_NAME);
1323 /* Specialization of mio_name. */
1325 #define DECL_MIO_NAME(TYPE) \
1326 static inline TYPE \
1327 MIO_NAME(TYPE) (TYPE t, const mstring * m) \
1329 return (TYPE)mio_name ((int)t, m); \
1331 #define MIO_NAME(TYPE) mio_name_##TYPE
1337 if (iomode == IO_OUTPUT)
1338 write_atom (ATOM_LPAREN, NULL);
1340 require_atom (ATOM_LPAREN);
1348 if (iomode == IO_OUTPUT)
1349 write_atom (ATOM_RPAREN, NULL);
1351 require_atom (ATOM_RPAREN);
1356 mio_integer (int *ip)
1359 if (iomode == IO_OUTPUT)
1360 write_atom (ATOM_INTEGER, ip);
1363 require_atom (ATOM_INTEGER);
1369 /* Read or write a character pointer that points to a string on the
1373 mio_allocated_string (const char *s)
1375 if (iomode == IO_OUTPUT)
1377 write_atom (ATOM_STRING, s);
1382 require_atom (ATOM_STRING);
1388 /* Read or write a string that is in static memory. */
1391 mio_pool_string (const char **stringp)
1393 /* TODO: one could write the string only once, and refer to it via a
1396 /* As a special case we have to deal with a NULL string. This
1397 happens for the 'module' member of 'gfc_symbol's that are not in a
1398 module. We read / write these as the empty string. */
1399 if (iomode == IO_OUTPUT)
1401 const char *p = *stringp == NULL ? "" : *stringp;
1402 write_atom (ATOM_STRING, p);
1406 require_atom (ATOM_STRING);
1407 *stringp = atom_string[0] == '\0' ? NULL : gfc_get_string (atom_string);
1408 gfc_free (atom_string);
1413 /* Read or write a string that is inside of some already-allocated
1417 mio_internal_string (char *string)
1420 if (iomode == IO_OUTPUT)
1421 write_atom (ATOM_STRING, string);
1424 require_atom (ATOM_STRING);
1425 strcpy (string, atom_string);
1426 gfc_free (atom_string);
1433 { AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL,
1434 AB_POINTER, AB_SAVE, AB_TARGET, AB_DUMMY, AB_RESULT,
1435 AB_DATA, AB_IN_NAMELIST, AB_IN_COMMON,
1436 AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE, AB_ELEMENTAL, AB_PURE,
1437 AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT, AB_CRAY_POINTER,
1438 AB_CRAY_POINTEE, AB_THREADPRIVATE
1442 static const mstring attr_bits[] =
1444 minit ("ALLOCATABLE", AB_ALLOCATABLE),
1445 minit ("DIMENSION", AB_DIMENSION),
1446 minit ("EXTERNAL", AB_EXTERNAL),
1447 minit ("INTRINSIC", AB_INTRINSIC),
1448 minit ("OPTIONAL", AB_OPTIONAL),
1449 minit ("POINTER", AB_POINTER),
1450 minit ("SAVE", AB_SAVE),
1451 minit ("TARGET", AB_TARGET),
1452 minit ("THREADPRIVATE", AB_THREADPRIVATE),
1453 minit ("DUMMY", AB_DUMMY),
1454 minit ("RESULT", AB_RESULT),
1455 minit ("DATA", AB_DATA),
1456 minit ("IN_NAMELIST", AB_IN_NAMELIST),
1457 minit ("IN_COMMON", AB_IN_COMMON),
1458 minit ("FUNCTION", AB_FUNCTION),
1459 minit ("SUBROUTINE", AB_SUBROUTINE),
1460 minit ("SEQUENCE", AB_SEQUENCE),
1461 minit ("ELEMENTAL", AB_ELEMENTAL),
1462 minit ("PURE", AB_PURE),
1463 minit ("RECURSIVE", AB_RECURSIVE),
1464 minit ("GENERIC", AB_GENERIC),
1465 minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT),
1466 minit ("CRAY_POINTER", AB_CRAY_POINTER),
1467 minit ("CRAY_POINTEE", AB_CRAY_POINTEE),
1471 /* Specialization of mio_name. */
1472 DECL_MIO_NAME(ab_attribute)
1473 DECL_MIO_NAME(ar_type)
1474 DECL_MIO_NAME(array_type)
1476 DECL_MIO_NAME(expr_t)
1477 DECL_MIO_NAME(gfc_access)
1478 DECL_MIO_NAME(gfc_intrinsic_op)
1479 DECL_MIO_NAME(ifsrc)
1480 DECL_MIO_NAME(procedure_type)
1481 DECL_MIO_NAME(ref_type)
1482 DECL_MIO_NAME(sym_flavor)
1483 DECL_MIO_NAME(sym_intent)
1484 #undef DECL_MIO_NAME
1486 /* Symbol attributes are stored in list with the first three elements
1487 being the enumerated fields, while the remaining elements (if any)
1488 indicate the individual attribute bits. The access field is not
1489 saved-- it controls what symbols are exported when a module is
1493 mio_symbol_attribute (symbol_attribute * attr)
1499 attr->flavor = MIO_NAME(sym_flavor) (attr->flavor, flavors);
1500 attr->intent = MIO_NAME(sym_intent) (attr->intent, intents);
1501 attr->proc = MIO_NAME(procedure_type) (attr->proc, procedures);
1502 attr->if_source = MIO_NAME(ifsrc) (attr->if_source, ifsrc_types);
1504 if (iomode == IO_OUTPUT)
1506 if (attr->allocatable)
1507 MIO_NAME(ab_attribute) (AB_ALLOCATABLE, attr_bits);
1508 if (attr->dimension)
1509 MIO_NAME(ab_attribute) (AB_DIMENSION, attr_bits);
1511 MIO_NAME(ab_attribute) (AB_EXTERNAL, attr_bits);
1512 if (attr->intrinsic)
1513 MIO_NAME(ab_attribute) (AB_INTRINSIC, attr_bits);
1515 MIO_NAME(ab_attribute) (AB_OPTIONAL, attr_bits);
1517 MIO_NAME(ab_attribute) (AB_POINTER, attr_bits);
1519 MIO_NAME(ab_attribute) (AB_SAVE, attr_bits);
1521 MIO_NAME(ab_attribute) (AB_TARGET, attr_bits);
1522 if (attr->threadprivate)
1523 MIO_NAME(ab_attribute) (AB_THREADPRIVATE, attr_bits);
1525 MIO_NAME(ab_attribute) (AB_DUMMY, attr_bits);
1527 MIO_NAME(ab_attribute) (AB_RESULT, attr_bits);
1528 /* We deliberately don't preserve the "entry" flag. */
1531 MIO_NAME(ab_attribute) (AB_DATA, attr_bits);
1532 if (attr->in_namelist)
1533 MIO_NAME(ab_attribute) (AB_IN_NAMELIST, attr_bits);
1534 if (attr->in_common)
1535 MIO_NAME(ab_attribute) (AB_IN_COMMON, attr_bits);
1538 MIO_NAME(ab_attribute) (AB_FUNCTION, attr_bits);
1539 if (attr->subroutine)
1540 MIO_NAME(ab_attribute) (AB_SUBROUTINE, attr_bits);
1542 MIO_NAME(ab_attribute) (AB_GENERIC, attr_bits);
1545 MIO_NAME(ab_attribute) (AB_SEQUENCE, attr_bits);
1546 if (attr->elemental)
1547 MIO_NAME(ab_attribute) (AB_ELEMENTAL, attr_bits);
1549 MIO_NAME(ab_attribute) (AB_PURE, attr_bits);
1550 if (attr->recursive)
1551 MIO_NAME(ab_attribute) (AB_RECURSIVE, attr_bits);
1552 if (attr->always_explicit)
1553 MIO_NAME(ab_attribute) (AB_ALWAYS_EXPLICIT, attr_bits);
1554 if (attr->cray_pointer)
1555 MIO_NAME(ab_attribute) (AB_CRAY_POINTER, attr_bits);
1556 if (attr->cray_pointee)
1557 MIO_NAME(ab_attribute) (AB_CRAY_POINTEE, attr_bits);
1568 if (t == ATOM_RPAREN)
1571 bad_module ("Expected attribute bit name");
1573 switch ((ab_attribute) find_enum (attr_bits))
1575 case AB_ALLOCATABLE:
1576 attr->allocatable = 1;
1579 attr->dimension = 1;
1585 attr->intrinsic = 1;
1599 case AB_THREADPRIVATE:
1600 attr->threadprivate = 1;
1611 case AB_IN_NAMELIST:
1612 attr->in_namelist = 1;
1615 attr->in_common = 1;
1621 attr->subroutine = 1;
1630 attr->elemental = 1;
1636 attr->recursive = 1;
1638 case AB_ALWAYS_EXPLICIT:
1639 attr->always_explicit = 1;
1641 case AB_CRAY_POINTER:
1642 attr->cray_pointer = 1;
1644 case AB_CRAY_POINTEE:
1645 attr->cray_pointee = 1;
1653 static const mstring bt_types[] = {
1654 minit ("INTEGER", BT_INTEGER),
1655 minit ("REAL", BT_REAL),
1656 minit ("COMPLEX", BT_COMPLEX),
1657 minit ("LOGICAL", BT_LOGICAL),
1658 minit ("CHARACTER", BT_CHARACTER),
1659 minit ("DERIVED", BT_DERIVED),
1660 minit ("PROCEDURE", BT_PROCEDURE),
1661 minit ("UNKNOWN", BT_UNKNOWN),
1667 mio_charlen (gfc_charlen ** clp)
1673 if (iomode == IO_OUTPUT)
1677 mio_expr (&cl->length);
1682 if (peek_atom () != ATOM_RPAREN)
1684 cl = gfc_get_charlen ();
1685 mio_expr (&cl->length);
1689 cl->next = gfc_current_ns->cl_list;
1690 gfc_current_ns->cl_list = cl;
1698 /* Return a symtree node with a name that is guaranteed to be unique
1699 within the namespace and corresponds to an illegal fortran name. */
1701 static gfc_symtree *
1702 get_unique_symtree (gfc_namespace * ns)
1704 char name[GFC_MAX_SYMBOL_LEN + 1];
1705 static int serial = 0;
1707 sprintf (name, "@%d", serial++);
1708 return gfc_new_symtree (&ns->sym_root, name);
1712 /* See if a name is a generated name. */
1715 check_unique_name (const char *name)
1718 return *name == '@';
1723 mio_typespec (gfc_typespec * ts)
1728 ts->type = MIO_NAME(bt) (ts->type, bt_types);
1730 if (ts->type != BT_DERIVED)
1731 mio_integer (&ts->kind);
1733 mio_symbol_ref (&ts->derived);
1735 mio_charlen (&ts->cl);
1741 static const mstring array_spec_types[] = {
1742 minit ("EXPLICIT", AS_EXPLICIT),
1743 minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE),
1744 minit ("DEFERRED", AS_DEFERRED),
1745 minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE),
1751 mio_array_spec (gfc_array_spec ** asp)
1758 if (iomode == IO_OUTPUT)
1766 if (peek_atom () == ATOM_RPAREN)
1772 *asp = as = gfc_get_array_spec ();
1775 mio_integer (&as->rank);
1776 as->type = MIO_NAME(array_type) (as->type, array_spec_types);
1778 for (i = 0; i < as->rank; i++)
1780 mio_expr (&as->lower[i]);
1781 mio_expr (&as->upper[i]);
1789 /* Given a pointer to an array reference structure (which lives in a
1790 gfc_ref structure), find the corresponding array specification
1791 structure. Storing the pointer in the ref structure doesn't quite
1792 work when loading from a module. Generating code for an array
1793 reference also needs more information than just the array spec. */
1795 static const mstring array_ref_types[] = {
1796 minit ("FULL", AR_FULL),
1797 minit ("ELEMENT", AR_ELEMENT),
1798 minit ("SECTION", AR_SECTION),
1803 mio_array_ref (gfc_array_ref * ar)
1808 ar->type = MIO_NAME(ar_type) (ar->type, array_ref_types);
1809 mio_integer (&ar->dimen);
1817 for (i = 0; i < ar->dimen; i++)
1818 mio_expr (&ar->start[i]);
1823 for (i = 0; i < ar->dimen; i++)
1825 mio_expr (&ar->start[i]);
1826 mio_expr (&ar->end[i]);
1827 mio_expr (&ar->stride[i]);
1833 gfc_internal_error ("mio_array_ref(): Unknown array ref");
1836 for (i = 0; i < ar->dimen; i++)
1837 mio_integer ((int *) &ar->dimen_type[i]);
1839 if (iomode == IO_INPUT)
1841 ar->where = gfc_current_locus;
1843 for (i = 0; i < ar->dimen; i++)
1844 ar->c_where[i] = gfc_current_locus;
1851 /* Saves or restores a pointer. The pointer is converted back and
1852 forth from an integer. We return the pointer_info pointer so that
1853 the caller can take additional action based on the pointer type. */
1855 static pointer_info *
1856 mio_pointer_ref (void *gp)
1860 if (iomode == IO_OUTPUT)
1862 p = get_pointer (*((char **) gp));
1863 write_atom (ATOM_INTEGER, &p->integer);
1867 require_atom (ATOM_INTEGER);
1868 p = add_fixup (atom_int, gp);
1875 /* Save and load references to components that occur within
1876 expressions. We have to describe these references by a number and
1877 by name. The number is necessary for forward references during
1878 reading, and the name is necessary if the symbol already exists in
1879 the namespace and is not loaded again. */
1882 mio_component_ref (gfc_component ** cp, gfc_symbol * sym)
1884 char name[GFC_MAX_SYMBOL_LEN + 1];
1888 p = mio_pointer_ref (cp);
1889 if (p->type == P_UNKNOWN)
1890 p->type = P_COMPONENT;
1892 if (iomode == IO_OUTPUT)
1893 mio_pool_string (&(*cp)->name);
1896 mio_internal_string (name);
1898 /* It can happen that a component reference can be read before the
1899 associated derived type symbol has been loaded. Return now and
1900 wait for a later iteration of load_needed. */
1904 if (sym->components != NULL && p->u.pointer == NULL)
1906 /* Symbol already loaded, so search by name. */
1907 for (q = sym->components; q; q = q->next)
1908 if (strcmp (q->name, name) == 0)
1912 gfc_internal_error ("mio_component_ref(): Component not found");
1914 associate_integer_pointer (p, q);
1917 /* Make sure this symbol will eventually be loaded. */
1918 p = find_pointer2 (sym);
1919 if (p->u.rsym.state == UNUSED)
1920 p->u.rsym.state = NEEDED;
1926 mio_component (gfc_component * c)
1933 if (iomode == IO_OUTPUT)
1935 p = get_pointer (c);
1936 mio_integer (&p->integer);
1941 p = get_integer (n);
1942 associate_integer_pointer (p, c);
1945 if (p->type == P_UNKNOWN)
1946 p->type = P_COMPONENT;
1948 mio_pool_string (&c->name);
1949 mio_typespec (&c->ts);
1950 mio_array_spec (&c->as);
1952 mio_integer (&c->dimension);
1953 mio_integer (&c->pointer);
1955 mio_expr (&c->initializer);
1961 mio_component_list (gfc_component ** cp)
1963 gfc_component *c, *tail;
1967 if (iomode == IO_OUTPUT)
1969 for (c = *cp; c; c = c->next)
1980 if (peek_atom () == ATOM_RPAREN)
1983 c = gfc_get_component ();
2000 mio_actual_arg (gfc_actual_arglist * a)
2004 mio_pool_string (&a->name);
2005 mio_expr (&a->expr);
2011 mio_actual_arglist (gfc_actual_arglist ** ap)
2013 gfc_actual_arglist *a, *tail;
2017 if (iomode == IO_OUTPUT)
2019 for (a = *ap; a; a = a->next)
2029 if (peek_atom () != ATOM_LPAREN)
2032 a = gfc_get_actual_arglist ();
2048 /* Read and write formal argument lists. */
2051 mio_formal_arglist (gfc_symbol * sym)
2053 gfc_formal_arglist *f, *tail;
2057 if (iomode == IO_OUTPUT)
2059 for (f = sym->formal; f; f = f->next)
2060 mio_symbol_ref (&f->sym);
2065 sym->formal = tail = NULL;
2067 while (peek_atom () != ATOM_RPAREN)
2069 f = gfc_get_formal_arglist ();
2070 mio_symbol_ref (&f->sym);
2072 if (sym->formal == NULL)
2085 /* Save or restore a reference to a symbol node. */
2088 mio_symbol_ref (gfc_symbol ** symp)
2092 p = mio_pointer_ref (symp);
2093 if (p->type == P_UNKNOWN)
2096 if (iomode == IO_OUTPUT)
2098 if (p->u.wsym.state == UNREFERENCED)
2099 p->u.wsym.state = NEEDS_WRITE;
2103 if (p->u.rsym.state == UNUSED)
2104 p->u.rsym.state = NEEDED;
2109 /* Save or restore a reference to a symtree node. */
2112 mio_symtree_ref (gfc_symtree ** stp)
2116 gfc_symtree * ns_st = NULL;
2118 if (iomode == IO_OUTPUT)
2120 /* If this is a symtree for a symbol that came from a contained module
2121 namespace, it has a unique name and we should look in the current
2122 namespace to see if the required, non-contained symbol is available
2123 yet. If so, the latter should be written. */
2124 if ((*stp)->n.sym && check_unique_name((*stp)->name))
2125 ns_st = gfc_find_symtree (gfc_current_ns->sym_root,
2126 (*stp)->n.sym->name);
2128 /* On the other hand, if the existing symbol is the module name or the
2129 new symbol is a dummy argument, do not do the promotion. */
2130 if (ns_st && ns_st->n.sym
2131 && ns_st->n.sym->attr.flavor != FL_MODULE
2132 && !(*stp)->n.sym->attr.dummy)
2133 mio_symbol_ref (&ns_st->n.sym);
2135 mio_symbol_ref (&(*stp)->n.sym);
2139 require_atom (ATOM_INTEGER);
2140 p = get_integer (atom_int);
2142 /* An unused equivalence member; bail out. */
2143 if (in_load_equiv && p->u.rsym.symtree == NULL)
2146 if (p->type == P_UNKNOWN)
2149 if (p->u.rsym.state == UNUSED)
2150 p->u.rsym.state = NEEDED;
2152 if (p->u.rsym.symtree != NULL)
2154 *stp = p->u.rsym.symtree;
2158 f = gfc_getmem (sizeof (fixup_t));
2160 f->next = p->u.rsym.stfixup;
2161 p->u.rsym.stfixup = f;
2163 f->pointer = (void **)stp;
2169 mio_iterator (gfc_iterator ** ip)
2175 if (iomode == IO_OUTPUT)
2182 if (peek_atom () == ATOM_RPAREN)
2188 *ip = gfc_get_iterator ();
2193 mio_expr (&iter->var);
2194 mio_expr (&iter->start);
2195 mio_expr (&iter->end);
2196 mio_expr (&iter->step);
2205 mio_constructor (gfc_constructor ** cp)
2207 gfc_constructor *c, *tail;
2211 if (iomode == IO_OUTPUT)
2213 for (c = *cp; c; c = c->next)
2216 mio_expr (&c->expr);
2217 mio_iterator (&c->iterator);
2227 while (peek_atom () != ATOM_RPAREN)
2229 c = gfc_get_constructor ();
2239 mio_expr (&c->expr);
2240 mio_iterator (&c->iterator);
2250 static const mstring ref_types[] = {
2251 minit ("ARRAY", REF_ARRAY),
2252 minit ("COMPONENT", REF_COMPONENT),
2253 minit ("SUBSTRING", REF_SUBSTRING),
2259 mio_ref (gfc_ref ** rp)
2266 r->type = MIO_NAME(ref_type) (r->type, ref_types);
2271 mio_array_ref (&r->u.ar);
2275 mio_symbol_ref (&r->u.c.sym);
2276 mio_component_ref (&r->u.c.component, r->u.c.sym);
2280 mio_expr (&r->u.ss.start);
2281 mio_expr (&r->u.ss.end);
2282 mio_charlen (&r->u.ss.length);
2291 mio_ref_list (gfc_ref ** rp)
2293 gfc_ref *ref, *head, *tail;
2297 if (iomode == IO_OUTPUT)
2299 for (ref = *rp; ref; ref = ref->next)
2306 while (peek_atom () != ATOM_RPAREN)
2309 head = tail = gfc_get_ref ();
2312 tail->next = gfc_get_ref ();
2326 /* Read and write an integer value. */
2329 mio_gmp_integer (mpz_t * integer)
2333 if (iomode == IO_INPUT)
2335 if (parse_atom () != ATOM_STRING)
2336 bad_module ("Expected integer string");
2338 mpz_init (*integer);
2339 if (mpz_set_str (*integer, atom_string, 10))
2340 bad_module ("Error converting integer");
2342 gfc_free (atom_string);
2347 p = mpz_get_str (NULL, 10, *integer);
2348 write_atom (ATOM_STRING, p);
2355 mio_gmp_real (mpfr_t * real)
2360 if (iomode == IO_INPUT)
2362 if (parse_atom () != ATOM_STRING)
2363 bad_module ("Expected real string");
2366 mpfr_set_str (*real, atom_string, 16, GFC_RND_MODE);
2367 gfc_free (atom_string);
2372 p = mpfr_get_str (NULL, &exponent, 16, 0, *real, GFC_RND_MODE);
2373 atom_string = gfc_getmem (strlen (p) + 20);
2375 sprintf (atom_string, "0.%s@%ld", p, exponent);
2377 /* Fix negative numbers. */
2378 if (atom_string[2] == '-')
2380 atom_string[0] = '-';
2381 atom_string[1] = '0';
2382 atom_string[2] = '.';
2385 write_atom (ATOM_STRING, atom_string);
2387 gfc_free (atom_string);
2393 /* Save and restore the shape of an array constructor. */
2396 mio_shape (mpz_t ** pshape, int rank)
2402 /* A NULL shape is represented by (). */
2405 if (iomode == IO_OUTPUT)
2417 if (t == ATOM_RPAREN)
2424 shape = gfc_get_shape (rank);
2428 for (n = 0; n < rank; n++)
2429 mio_gmp_integer (&shape[n]);
2435 static const mstring expr_types[] = {
2436 minit ("OP", EXPR_OP),
2437 minit ("FUNCTION", EXPR_FUNCTION),
2438 minit ("CONSTANT", EXPR_CONSTANT),
2439 minit ("VARIABLE", EXPR_VARIABLE),
2440 minit ("SUBSTRING", EXPR_SUBSTRING),
2441 minit ("STRUCTURE", EXPR_STRUCTURE),
2442 minit ("ARRAY", EXPR_ARRAY),
2443 minit ("NULL", EXPR_NULL),
2447 /* INTRINSIC_ASSIGN is missing because it is used as an index for
2448 generic operators, not in expressions. INTRINSIC_USER is also
2449 replaced by the correct function name by the time we see it. */
2451 static const mstring intrinsics[] =
2453 minit ("UPLUS", INTRINSIC_UPLUS),
2454 minit ("UMINUS", INTRINSIC_UMINUS),
2455 minit ("PLUS", INTRINSIC_PLUS),
2456 minit ("MINUS", INTRINSIC_MINUS),
2457 minit ("TIMES", INTRINSIC_TIMES),
2458 minit ("DIVIDE", INTRINSIC_DIVIDE),
2459 minit ("POWER", INTRINSIC_POWER),
2460 minit ("CONCAT", INTRINSIC_CONCAT),
2461 minit ("AND", INTRINSIC_AND),
2462 minit ("OR", INTRINSIC_OR),
2463 minit ("EQV", INTRINSIC_EQV),
2464 minit ("NEQV", INTRINSIC_NEQV),
2465 minit ("EQ", INTRINSIC_EQ),
2466 minit ("NE", INTRINSIC_NE),
2467 minit ("GT", INTRINSIC_GT),
2468 minit ("GE", INTRINSIC_GE),
2469 minit ("LT", INTRINSIC_LT),
2470 minit ("LE", INTRINSIC_LE),
2471 minit ("NOT", INTRINSIC_NOT),
2472 minit ("PARENTHESES", INTRINSIC_PARENTHESES),
2476 /* Read and write expressions. The form "()" is allowed to indicate a
2480 mio_expr (gfc_expr ** ep)
2488 if (iomode == IO_OUTPUT)
2497 MIO_NAME(expr_t) (e->expr_type, expr_types);
2503 if (t == ATOM_RPAREN)
2510 bad_module ("Expected expression type");
2512 e = *ep = gfc_get_expr ();
2513 e->where = gfc_current_locus;
2514 e->expr_type = (expr_t) find_enum (expr_types);
2517 mio_typespec (&e->ts);
2518 mio_integer (&e->rank);
2520 switch (e->expr_type)
2523 e->value.op.operator
2524 = MIO_NAME(gfc_intrinsic_op) (e->value.op.operator, intrinsics);
2526 switch (e->value.op.operator)
2528 case INTRINSIC_UPLUS:
2529 case INTRINSIC_UMINUS:
2531 case INTRINSIC_PARENTHESES:
2532 mio_expr (&e->value.op.op1);
2535 case INTRINSIC_PLUS:
2536 case INTRINSIC_MINUS:
2537 case INTRINSIC_TIMES:
2538 case INTRINSIC_DIVIDE:
2539 case INTRINSIC_POWER:
2540 case INTRINSIC_CONCAT:
2544 case INTRINSIC_NEQV:
2551 mio_expr (&e->value.op.op1);
2552 mio_expr (&e->value.op.op2);
2556 bad_module ("Bad operator");
2562 mio_symtree_ref (&e->symtree);
2563 mio_actual_arglist (&e->value.function.actual);
2565 if (iomode == IO_OUTPUT)
2567 e->value.function.name
2568 = mio_allocated_string (e->value.function.name);
2569 flag = e->value.function.esym != NULL;
2570 mio_integer (&flag);
2572 mio_symbol_ref (&e->value.function.esym);
2574 write_atom (ATOM_STRING, e->value.function.isym->name);
2579 require_atom (ATOM_STRING);
2580 e->value.function.name = gfc_get_string (atom_string);
2581 gfc_free (atom_string);
2583 mio_integer (&flag);
2585 mio_symbol_ref (&e->value.function.esym);
2588 require_atom (ATOM_STRING);
2589 e->value.function.isym = gfc_find_function (atom_string);
2590 gfc_free (atom_string);
2597 mio_symtree_ref (&e->symtree);
2598 mio_ref_list (&e->ref);
2601 case EXPR_SUBSTRING:
2602 e->value.character.string = (char *)
2603 mio_allocated_string (e->value.character.string);
2604 mio_ref_list (&e->ref);
2607 case EXPR_STRUCTURE:
2609 mio_constructor (&e->value.constructor);
2610 mio_shape (&e->shape, e->rank);
2617 mio_gmp_integer (&e->value.integer);
2621 gfc_set_model_kind (e->ts.kind);
2622 mio_gmp_real (&e->value.real);
2626 gfc_set_model_kind (e->ts.kind);
2627 mio_gmp_real (&e->value.complex.r);
2628 mio_gmp_real (&e->value.complex.i);
2632 mio_integer (&e->value.logical);
2636 mio_integer (&e->value.character.length);
2637 e->value.character.string = (char *)
2638 mio_allocated_string (e->value.character.string);
2642 bad_module ("Bad type in constant expression");
2655 /* Read and write namelists */
2658 mio_namelist (gfc_symbol * sym)
2660 gfc_namelist *n, *m;
2661 const char *check_name;
2665 if (iomode == IO_OUTPUT)
2667 for (n = sym->namelist; n; n = n->next)
2668 mio_symbol_ref (&n->sym);
2672 /* This departure from the standard is flagged as an error.
2673 It does, in fact, work correctly. TODO: Allow it
2675 if (sym->attr.flavor == FL_NAMELIST)
2677 check_name = find_use_name (sym->name);
2678 if (check_name && strcmp (check_name, sym->name) != 0)
2679 gfc_error("Namelist %s cannot be renamed by USE"
2680 " association to %s.",
2681 sym->name, check_name);
2685 while (peek_atom () != ATOM_RPAREN)
2687 n = gfc_get_namelist ();
2688 mio_symbol_ref (&n->sym);
2690 if (sym->namelist == NULL)
2697 sym->namelist_tail = m;
2704 /* Save/restore lists of gfc_interface stuctures. When loading an
2705 interface, we are really appending to the existing list of
2706 interfaces. Checking for duplicate and ambiguous interfaces has to
2707 be done later when all symbols have been loaded. */
2710 mio_interface_rest (gfc_interface ** ip)
2712 gfc_interface *tail, *p;
2714 if (iomode == IO_OUTPUT)
2717 for (p = *ip; p; p = p->next)
2718 mio_symbol_ref (&p->sym);
2734 if (peek_atom () == ATOM_RPAREN)
2737 p = gfc_get_interface ();
2738 p->where = gfc_current_locus;
2739 mio_symbol_ref (&p->sym);
2754 /* Save/restore a nameless operator interface. */
2757 mio_interface (gfc_interface ** ip)
2761 mio_interface_rest (ip);
2765 /* Save/restore a named operator interface. */
2768 mio_symbol_interface (const char **name, const char **module,
2769 gfc_interface ** ip)
2774 mio_pool_string (name);
2775 mio_pool_string (module);
2777 mio_interface_rest (ip);
2782 mio_namespace_ref (gfc_namespace ** nsp)
2787 p = mio_pointer_ref (nsp);
2789 if (p->type == P_UNKNOWN)
2790 p->type = P_NAMESPACE;
2792 if (iomode == IO_INPUT && p->integer != 0)
2794 ns = (gfc_namespace *)p->u.pointer;
2797 ns = gfc_get_namespace (NULL, 0);
2798 associate_integer_pointer (p, ns);
2806 /* Unlike most other routines, the address of the symbol node is
2807 already fixed on input and the name/module has already been filled
2811 mio_symbol (gfc_symbol * sym)
2813 gfc_formal_arglist *formal;
2817 mio_symbol_attribute (&sym->attr);
2818 mio_typespec (&sym->ts);
2820 /* Contained procedures don't have formal namespaces. Instead we output the
2821 procedure namespace. The will contain the formal arguments. */
2822 if (iomode == IO_OUTPUT)
2824 formal = sym->formal;
2825 while (formal && !formal->sym)
2826 formal = formal->next;
2829 mio_namespace_ref (&formal->sym->ns);
2831 mio_namespace_ref (&sym->formal_ns);
2835 mio_namespace_ref (&sym->formal_ns);
2838 sym->formal_ns->proc_name = sym;
2843 /* Save/restore common block links */
2844 mio_symbol_ref (&sym->common_next);
2846 mio_formal_arglist (sym);
2848 if (sym->attr.flavor == FL_PARAMETER)
2849 mio_expr (&sym->value);
2851 mio_array_spec (&sym->as);
2853 mio_symbol_ref (&sym->result);
2855 if (sym->attr.cray_pointee)
2856 mio_symbol_ref (&sym->cp_pointer);
2858 /* Note that components are always saved, even if they are supposed
2859 to be private. Component access is checked during searching. */
2861 mio_component_list (&sym->components);
2863 if (sym->components != NULL)
2864 sym->component_access =
2865 MIO_NAME(gfc_access) (sym->component_access, access_types);
2872 /************************* Top level subroutines *************************/
2874 /* Skip a list between balanced left and right parens. */
2884 switch (parse_atom ())
2895 gfc_free (atom_string);
2907 /* Load operator interfaces from the module. Interfaces are unusual
2908 in that they attach themselves to existing symbols. */
2911 load_operator_interfaces (void)
2914 char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
2919 while (peek_atom () != ATOM_RPAREN)
2923 mio_internal_string (name);
2924 mio_internal_string (module);
2926 /* Decide if we need to load this one or not. */
2927 p = find_use_name (name);
2930 while (parse_atom () != ATOM_RPAREN);
2934 uop = gfc_get_uop (p);
2935 mio_interface_rest (&uop->operator);
2943 /* Load interfaces from the module. Interfaces are unusual in that
2944 they attach themselves to existing symbols. */
2947 load_generic_interfaces (void)
2950 char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
2955 while (peek_atom () != ATOM_RPAREN)
2959 mio_internal_string (name);
2960 mio_internal_string (module);
2962 /* Decide if we need to load this one or not. */
2963 p = find_use_name (name);
2965 if (p == NULL || gfc_find_symbol (p, NULL, 0, &sym))
2967 while (parse_atom () != ATOM_RPAREN);
2973 gfc_get_symbol (p, NULL, &sym);
2975 sym->attr.flavor = FL_PROCEDURE;
2976 sym->attr.generic = 1;
2977 sym->attr.use_assoc = 1;
2980 mio_interface_rest (&sym->generic);
2987 /* Load common blocks. */
2992 char name[GFC_MAX_SYMBOL_LEN+1];
2997 while (peek_atom () != ATOM_RPAREN)
3001 mio_internal_string (name);
3003 p = gfc_get_common (name, 1);
3005 mio_symbol_ref (&p->head);
3006 mio_integer (&flags);
3010 p->threadprivate = 1;
3019 /* load_equiv()-- Load equivalences. The flag in_load_equiv informs
3020 mio_expr_ref of this so that unused variables are not loaded and
3021 so that the expression can be safely freed.*/
3026 gfc_equiv *head, *tail, *end, *eq;
3030 in_load_equiv = true;
3032 end = gfc_current_ns->equiv;
3033 while(end != NULL && end->next != NULL)
3036 while(peek_atom() != ATOM_RPAREN) {
3040 while(peek_atom() != ATOM_RPAREN)
3043 head = tail = gfc_get_equiv();
3046 tail->eq = gfc_get_equiv();
3050 mio_pool_string(&tail->module);
3051 mio_expr(&tail->expr);
3054 /* Unused variables have no symtree. */
3056 for (eq = head; eq; eq = eq->eq)
3058 if (!eq->expr->symtree)
3067 for (eq = head; eq; eq = head)
3070 gfc_free_expr (eq->expr);
3076 gfc_current_ns->equiv = head;
3087 in_load_equiv = false;
3090 /* Recursive function to traverse the pointer_info tree and load a
3091 needed symbol. We return nonzero if we load a symbol and stop the
3092 traversal, because the act of loading can alter the tree. */
3095 load_needed (pointer_info * p)
3106 rv |= load_needed (p->left);
3107 rv |= load_needed (p->right);
3109 if (p->type != P_SYMBOL || p->u.rsym.state != NEEDED)
3112 p->u.rsym.state = USED;
3114 set_module_locus (&p->u.rsym.where);
3116 sym = p->u.rsym.sym;
3119 q = get_integer (p->u.rsym.ns);
3121 ns = (gfc_namespace *) q->u.pointer;
3124 /* Create an interface namespace if necessary. These are
3125 the namespaces that hold the formal parameters of module
3128 ns = gfc_get_namespace (NULL, 0);
3129 associate_integer_pointer (q, ns);
3132 sym = gfc_new_symbol (p->u.rsym.true_name, ns);
3133 sym->module = gfc_get_string (p->u.rsym.module);
3135 associate_integer_pointer (p, sym);
3139 sym->attr.use_assoc = 1;
3145 /* Recursive function for cleaning up things after a module has been
3149 read_cleanup (pointer_info * p)
3157 read_cleanup (p->left);
3158 read_cleanup (p->right);
3160 if (p->type == P_SYMBOL && p->u.rsym.state == USED && !p->u.rsym.referenced)
3162 /* Add hidden symbols to the symtree. */
3163 q = get_integer (p->u.rsym.ns);
3164 st = get_unique_symtree ((gfc_namespace *) q->u.pointer);
3166 st->n.sym = p->u.rsym.sym;
3169 /* Fixup any symtree references. */
3170 p->u.rsym.symtree = st;
3171 resolve_fixups (p->u.rsym.stfixup, st);
3172 p->u.rsym.stfixup = NULL;
3175 /* Free unused symbols. */
3176 if (p->type == P_SYMBOL && p->u.rsym.state == UNUSED)
3177 gfc_free_symbol (p->u.rsym.sym);
3181 /* Read a module file. */
3186 module_locus operator_interfaces, user_operators;
3188 char name[GFC_MAX_SYMBOL_LEN + 1];
3190 int ambiguous, j, nuse, symbol;
3196 get_module_locus (&operator_interfaces); /* Skip these for now */
3199 get_module_locus (&user_operators);
3203 /* Skip commons and equivalences for now. */
3209 /* Create the fixup nodes for all the symbols. */
3211 while (peek_atom () != ATOM_RPAREN)
3213 require_atom (ATOM_INTEGER);
3214 info = get_integer (atom_int);
3216 info->type = P_SYMBOL;
3217 info->u.rsym.state = UNUSED;
3219 mio_internal_string (info->u.rsym.true_name);
3220 mio_internal_string (info->u.rsym.module);
3222 require_atom (ATOM_INTEGER);
3223 info->u.rsym.ns = atom_int;
3225 get_module_locus (&info->u.rsym.where);
3228 /* See if the symbol has already been loaded by a previous module.
3229 If so, we reference the existing symbol and prevent it from
3230 being loaded again. This should not happen if the symbol being
3231 read is an index for an assumed shape dummy array (ns != 1). */
3233 sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module);
3236 || (sym->attr.flavor == FL_VARIABLE
3237 && info->u.rsym.ns !=1))
3240 info->u.rsym.state = USED;
3241 info->u.rsym.referenced = 1;
3242 info->u.rsym.sym = sym;
3247 /* Parse the symtree lists. This lets us mark which symbols need to
3248 be loaded. Renaming is also done at this point by replacing the
3253 while (peek_atom () != ATOM_RPAREN)
3255 mio_internal_string (name);
3256 mio_integer (&ambiguous);
3257 mio_integer (&symbol);
3259 info = get_integer (symbol);
3261 /* See how many use names there are. If none, go through the start
3262 of the loop at least once. */
3263 nuse = number_use_names (name);
3267 for (j = 1; j <= nuse; j++)
3269 /* Get the jth local name for this symbol. */
3270 p = find_use_name_n (name, &j);
3272 /* Skip symtree nodes not in an ONLY clause. */
3276 /* Check for ambiguous symbols. */
3277 st = gfc_find_symtree (gfc_current_ns->sym_root, p);
3281 if (st->n.sym != info->u.rsym.sym)
3283 info->u.rsym.symtree = st;
3287 /* Create a symtree node in the current namespace for this symbol. */
3288 st = check_unique_name (p) ? get_unique_symtree (gfc_current_ns) :
3289 gfc_new_symtree (&gfc_current_ns->sym_root, p);
3291 st->ambiguous = ambiguous;
3293 sym = info->u.rsym.sym;
3295 /* Create a symbol node if it doesn't already exist. */
3298 sym = info->u.rsym.sym =
3299 gfc_new_symbol (info->u.rsym.true_name,
3302 sym->module = gfc_get_string (info->u.rsym.module);
3308 /* Store the symtree pointing to this symbol. */
3309 info->u.rsym.symtree = st;
3311 if (info->u.rsym.state == UNUSED)
3312 info->u.rsym.state = NEEDED;
3313 info->u.rsym.referenced = 1;
3320 /* Load intrinsic operator interfaces. */
3321 set_module_locus (&operator_interfaces);
3324 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3326 if (i == INTRINSIC_USER)
3331 u = find_use_operator (i);
3342 mio_interface (&gfc_current_ns->operator[i]);
3347 /* Load generic and user operator interfaces. These must follow the
3348 loading of symtree because otherwise symbols can be marked as
3351 set_module_locus (&user_operators);
3353 load_operator_interfaces ();
3354 load_generic_interfaces ();
3359 /* At this point, we read those symbols that are needed but haven't
3360 been loaded yet. If one symbol requires another, the other gets
3361 marked as NEEDED if its previous state was UNUSED. */
3363 while (load_needed (pi_root));
3365 /* Make sure all elements of the rename-list were found in the
3368 for (u = gfc_rename_list; u; u = u->next)
3373 if (u->operator == INTRINSIC_NONE)
3375 gfc_error ("Symbol '%s' referenced at %L not found in module '%s'",
3376 u->use_name, &u->where, module_name);
3380 if (u->operator == INTRINSIC_USER)
3383 ("User operator '%s' referenced at %L not found in module '%s'",
3384 u->use_name, &u->where, module_name);
3389 ("Intrinsic operator '%s' referenced at %L not found in module "
3390 "'%s'", gfc_op2string (u->operator), &u->where, module_name);
3393 gfc_check_interfaces (gfc_current_ns);
3395 /* Clean up symbol nodes that were never loaded, create references
3396 to hidden symbols. */
3398 read_cleanup (pi_root);
3402 /* Given an access type that is specific to an entity and the default
3403 access, return nonzero if the entity is publicly accessible. */
3406 gfc_check_access (gfc_access specific_access, gfc_access default_access)
3409 if (specific_access == ACCESS_PUBLIC)
3411 if (specific_access == ACCESS_PRIVATE)
3414 if (gfc_option.flag_module_access_private)
3415 return default_access == ACCESS_PUBLIC;
3417 return default_access != ACCESS_PRIVATE;
3423 /* Write a common block to the module */
3426 write_common (gfc_symtree *st)
3435 write_common(st->left);
3436 write_common(st->right);
3440 /* Write the unmangled name. */
3441 name = st->n.common->name;
3443 mio_pool_string(&name);
3446 mio_symbol_ref(&p->head);
3447 flags = p->saved ? 1 : 0;
3448 if (p->threadprivate) flags |= 2;
3449 mio_integer(&flags);
3454 /* Write the blank common block to the module */
3457 write_blank_common (void)
3459 const char * name = BLANK_COMMON_NAME;
3462 if (gfc_current_ns->blank_common.head == NULL)
3467 mio_pool_string(&name);
3469 mio_symbol_ref(&gfc_current_ns->blank_common.head);
3470 saved = gfc_current_ns->blank_common.saved;
3471 mio_integer(&saved);
3476 /* Write equivalences to the module. */
3485 for(eq=gfc_current_ns->equiv; eq; eq=eq->next)
3489 for(e=eq; e; e=e->eq)
3491 if (e->module == NULL)
3492 e->module = gfc_get_string("%s.eq.%d", module_name, num);
3493 mio_allocated_string(e->module);
3502 /* Write a symbol to the module. */
3505 write_symbol (int n, gfc_symbol * sym)
3508 if (sym->attr.flavor == FL_UNKNOWN || sym->attr.flavor == FL_LABEL)
3509 gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym->name);
3512 mio_pool_string (&sym->name);
3514 mio_pool_string (&sym->module);
3515 mio_pointer_ref (&sym->ns);
3522 /* Recursive traversal function to write the initial set of symbols to
3523 the module. We check to see if the symbol should be written
3524 according to the access specification. */
3527 write_symbol0 (gfc_symtree * st)
3535 write_symbol0 (st->left);
3536 write_symbol0 (st->right);
3539 if (sym->module == NULL)
3540 sym->module = gfc_get_string (module_name);
3542 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
3543 && !sym->attr.subroutine && !sym->attr.function)
3546 if (!gfc_check_access (sym->attr.access, sym->ns->default_access))
3549 p = get_pointer (sym);
3550 if (p->type == P_UNKNOWN)
3553 if (p->u.wsym.state == WRITTEN)
3556 write_symbol (p->integer, sym);
3557 p->u.wsym.state = WRITTEN;
3563 /* Recursive traversal function to write the secondary set of symbols
3564 to the module file. These are symbols that were not public yet are
3565 needed by the public symbols or another dependent symbol. The act
3566 of writing a symbol can modify the pointer_info tree, so we cease
3567 traversal if we find a symbol to write. We return nonzero if a
3568 symbol was written and pass that information upwards. */
3571 write_symbol1 (pointer_info * p)
3577 if (write_symbol1 (p->left))
3579 if (write_symbol1 (p->right))
3582 if (p->type != P_SYMBOL || p->u.wsym.state != NEEDS_WRITE)
3585 p->u.wsym.state = WRITTEN;
3586 write_symbol (p->integer, p->u.wsym.sym);
3592 /* Write operator interfaces associated with a symbol. */
3595 write_operator (gfc_user_op * uop)
3597 static char nullstring[] = "";
3598 const char *p = nullstring;
3600 if (uop->operator == NULL
3601 || !gfc_check_access (uop->access, uop->ns->default_access))
3604 mio_symbol_interface (&uop->name, &p, &uop->operator);
3608 /* Write generic interfaces associated with a symbol. */
3611 write_generic (gfc_symbol * sym)
3614 if (sym->generic == NULL
3615 || !gfc_check_access (sym->attr.access, sym->ns->default_access))
3618 mio_symbol_interface (&sym->name, &sym->module, &sym->generic);
3623 write_symtree (gfc_symtree * st)
3629 if (!gfc_check_access (sym->attr.access, sym->ns->default_access)
3630 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
3631 && !sym->attr.subroutine && !sym->attr.function))
3634 if (check_unique_name (st->name))
3637 p = find_pointer (sym);
3639 gfc_internal_error ("write_symtree(): Symbol not written");
3641 mio_pool_string (&st->name);
3642 mio_integer (&st->ambiguous);
3643 mio_integer (&p->integer);
3652 /* Write the operator interfaces. */
3655 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3657 if (i == INTRINSIC_USER)
3660 mio_interface (gfc_check_access (gfc_current_ns->operator_access[i],
3661 gfc_current_ns->default_access)
3662 ? &gfc_current_ns->operator[i] : NULL);
3670 gfc_traverse_user_op (gfc_current_ns, write_operator);
3676 gfc_traverse_ns (gfc_current_ns, write_generic);
3682 write_blank_common ();
3683 write_common (gfc_current_ns->common_root);
3691 write_char('\n'); write_char('\n');
3693 /* Write symbol information. First we traverse all symbols in the
3694 primary namespace, writing those that need to be written.
3695 Sometimes writing one symbol will cause another to need to be
3696 written. A list of these symbols ends up on the write stack, and
3697 we end by popping the bottom of the stack and writing the symbol
3698 until the stack is empty. */
3702 write_symbol0 (gfc_current_ns->sym_root);
3703 while (write_symbol1 (pi_root));
3711 gfc_traverse_symtree (gfc_current_ns->sym_root, write_symtree);
3716 /* Given module, dump it to disk. If there was an error while
3717 processing the module, dump_flag will be set to zero and we delete
3718 the module file, even if it was already there. */
3721 gfc_dump_module (const char *name, int dump_flag)
3727 n = strlen (name) + strlen (MODULE_EXTENSION) + 1;
3728 if (gfc_option.module_dir != NULL)
3730 filename = (char *) alloca (n + strlen (gfc_option.module_dir));
3731 strcpy (filename, gfc_option.module_dir);
3732 strcat (filename, name);
3736 filename = (char *) alloca (n);
3737 strcpy (filename, name);
3739 strcat (filename, MODULE_EXTENSION);
3747 module_fp = fopen (filename, "w");
3748 if (module_fp == NULL)
3749 gfc_fatal_error ("Can't open module file '%s' for writing at %C: %s",
3750 filename, strerror (errno));
3755 *strchr (p, '\n') = '\0';
3757 fprintf (module_fp, "GFORTRAN module created from %s on %s\n",
3758 gfc_source_file, p);
3759 fputs ("If you edit this, you'll get what you deserve.\n\n", module_fp);
3762 strcpy (module_name, name);
3768 free_pi_tree (pi_root);
3773 if (fclose (module_fp))
3774 gfc_fatal_error ("Error writing module file '%s' for writing: %s",
3775 filename, strerror (errno));
3779 /* Process a USE directive. */
3782 gfc_use_module (void)
3788 filename = (char *) alloca(strlen(module_name) + strlen(MODULE_EXTENSION)
3790 strcpy (filename, module_name);
3791 strcat (filename, MODULE_EXTENSION);
3793 module_fp = gfc_open_included_file (filename, true);
3794 if (module_fp == NULL)
3795 gfc_fatal_error ("Can't open module file '%s' for reading at %C: %s",
3796 filename, strerror (errno));
3802 /* Skip the first two lines of the module. */
3803 /* FIXME: Could also check for valid two lines here, instead. */
3809 bad_module ("Unexpected end of module");
3814 /* Make sure we're not reading the same module that we may be building. */
3815 for (p = gfc_state_stack; p; p = p->previous)
3816 if (p->state == COMP_MODULE && strcmp (p->sym->name, module_name) == 0)
3817 gfc_fatal_error ("Can't USE the same module we're building!");
3820 init_true_name_tree ();
3824 free_true_name (true_name_root);
3825 true_name_root = NULL;
3827 free_pi_tree (pi_root);
3835 gfc_module_init_2 (void)
3838 last_atom = ATOM_LPAREN;
3843 gfc_module_done_2 (void)