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, AB_ALLOC_COMP
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),
1468 minit ("ALLOC_COMP", AB_ALLOC_COMP),
1472 /* Specialization of mio_name. */
1473 DECL_MIO_NAME(ab_attribute)
1474 DECL_MIO_NAME(ar_type)
1475 DECL_MIO_NAME(array_type)
1477 DECL_MIO_NAME(expr_t)
1478 DECL_MIO_NAME(gfc_access)
1479 DECL_MIO_NAME(gfc_intrinsic_op)
1480 DECL_MIO_NAME(ifsrc)
1481 DECL_MIO_NAME(procedure_type)
1482 DECL_MIO_NAME(ref_type)
1483 DECL_MIO_NAME(sym_flavor)
1484 DECL_MIO_NAME(sym_intent)
1485 #undef DECL_MIO_NAME
1487 /* Symbol attributes are stored in list with the first three elements
1488 being the enumerated fields, while the remaining elements (if any)
1489 indicate the individual attribute bits. The access field is not
1490 saved-- it controls what symbols are exported when a module is
1494 mio_symbol_attribute (symbol_attribute * attr)
1500 attr->flavor = MIO_NAME(sym_flavor) (attr->flavor, flavors);
1501 attr->intent = MIO_NAME(sym_intent) (attr->intent, intents);
1502 attr->proc = MIO_NAME(procedure_type) (attr->proc, procedures);
1503 attr->if_source = MIO_NAME(ifsrc) (attr->if_source, ifsrc_types);
1505 if (iomode == IO_OUTPUT)
1507 if (attr->allocatable)
1508 MIO_NAME(ab_attribute) (AB_ALLOCATABLE, attr_bits);
1509 if (attr->dimension)
1510 MIO_NAME(ab_attribute) (AB_DIMENSION, attr_bits);
1512 MIO_NAME(ab_attribute) (AB_EXTERNAL, attr_bits);
1513 if (attr->intrinsic)
1514 MIO_NAME(ab_attribute) (AB_INTRINSIC, attr_bits);
1516 MIO_NAME(ab_attribute) (AB_OPTIONAL, attr_bits);
1518 MIO_NAME(ab_attribute) (AB_POINTER, attr_bits);
1520 MIO_NAME(ab_attribute) (AB_SAVE, attr_bits);
1522 MIO_NAME(ab_attribute) (AB_TARGET, attr_bits);
1523 if (attr->threadprivate)
1524 MIO_NAME(ab_attribute) (AB_THREADPRIVATE, attr_bits);
1526 MIO_NAME(ab_attribute) (AB_DUMMY, attr_bits);
1528 MIO_NAME(ab_attribute) (AB_RESULT, attr_bits);
1529 /* We deliberately don't preserve the "entry" flag. */
1532 MIO_NAME(ab_attribute) (AB_DATA, attr_bits);
1533 if (attr->in_namelist)
1534 MIO_NAME(ab_attribute) (AB_IN_NAMELIST, attr_bits);
1535 if (attr->in_common)
1536 MIO_NAME(ab_attribute) (AB_IN_COMMON, attr_bits);
1539 MIO_NAME(ab_attribute) (AB_FUNCTION, attr_bits);
1540 if (attr->subroutine)
1541 MIO_NAME(ab_attribute) (AB_SUBROUTINE, attr_bits);
1543 MIO_NAME(ab_attribute) (AB_GENERIC, attr_bits);
1546 MIO_NAME(ab_attribute) (AB_SEQUENCE, attr_bits);
1547 if (attr->elemental)
1548 MIO_NAME(ab_attribute) (AB_ELEMENTAL, attr_bits);
1550 MIO_NAME(ab_attribute) (AB_PURE, attr_bits);
1551 if (attr->recursive)
1552 MIO_NAME(ab_attribute) (AB_RECURSIVE, attr_bits);
1553 if (attr->always_explicit)
1554 MIO_NAME(ab_attribute) (AB_ALWAYS_EXPLICIT, attr_bits);
1555 if (attr->cray_pointer)
1556 MIO_NAME(ab_attribute) (AB_CRAY_POINTER, attr_bits);
1557 if (attr->cray_pointee)
1558 MIO_NAME(ab_attribute) (AB_CRAY_POINTEE, attr_bits);
1559 if (attr->alloc_comp)
1560 MIO_NAME(ab_attribute) (AB_ALLOC_COMP, attr_bits);
1571 if (t == ATOM_RPAREN)
1574 bad_module ("Expected attribute bit name");
1576 switch ((ab_attribute) find_enum (attr_bits))
1578 case AB_ALLOCATABLE:
1579 attr->allocatable = 1;
1582 attr->dimension = 1;
1588 attr->intrinsic = 1;
1602 case AB_THREADPRIVATE:
1603 attr->threadprivate = 1;
1614 case AB_IN_NAMELIST:
1615 attr->in_namelist = 1;
1618 attr->in_common = 1;
1624 attr->subroutine = 1;
1633 attr->elemental = 1;
1639 attr->recursive = 1;
1641 case AB_ALWAYS_EXPLICIT:
1642 attr->always_explicit = 1;
1644 case AB_CRAY_POINTER:
1645 attr->cray_pointer = 1;
1647 case AB_CRAY_POINTEE:
1648 attr->cray_pointee = 1;
1651 attr->alloc_comp = 1;
1659 static const mstring bt_types[] = {
1660 minit ("INTEGER", BT_INTEGER),
1661 minit ("REAL", BT_REAL),
1662 minit ("COMPLEX", BT_COMPLEX),
1663 minit ("LOGICAL", BT_LOGICAL),
1664 minit ("CHARACTER", BT_CHARACTER),
1665 minit ("DERIVED", BT_DERIVED),
1666 minit ("PROCEDURE", BT_PROCEDURE),
1667 minit ("UNKNOWN", BT_UNKNOWN),
1673 mio_charlen (gfc_charlen ** clp)
1679 if (iomode == IO_OUTPUT)
1683 mio_expr (&cl->length);
1688 if (peek_atom () != ATOM_RPAREN)
1690 cl = gfc_get_charlen ();
1691 mio_expr (&cl->length);
1695 cl->next = gfc_current_ns->cl_list;
1696 gfc_current_ns->cl_list = cl;
1704 /* Return a symtree node with a name that is guaranteed to be unique
1705 within the namespace and corresponds to an illegal fortran name. */
1707 static gfc_symtree *
1708 get_unique_symtree (gfc_namespace * ns)
1710 char name[GFC_MAX_SYMBOL_LEN + 1];
1711 static int serial = 0;
1713 sprintf (name, "@%d", serial++);
1714 return gfc_new_symtree (&ns->sym_root, name);
1718 /* See if a name is a generated name. */
1721 check_unique_name (const char *name)
1724 return *name == '@';
1729 mio_typespec (gfc_typespec * ts)
1734 ts->type = MIO_NAME(bt) (ts->type, bt_types);
1736 if (ts->type != BT_DERIVED)
1737 mio_integer (&ts->kind);
1739 mio_symbol_ref (&ts->derived);
1741 mio_charlen (&ts->cl);
1747 static const mstring array_spec_types[] = {
1748 minit ("EXPLICIT", AS_EXPLICIT),
1749 minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE),
1750 minit ("DEFERRED", AS_DEFERRED),
1751 minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE),
1757 mio_array_spec (gfc_array_spec ** asp)
1764 if (iomode == IO_OUTPUT)
1772 if (peek_atom () == ATOM_RPAREN)
1778 *asp = as = gfc_get_array_spec ();
1781 mio_integer (&as->rank);
1782 as->type = MIO_NAME(array_type) (as->type, array_spec_types);
1784 for (i = 0; i < as->rank; i++)
1786 mio_expr (&as->lower[i]);
1787 mio_expr (&as->upper[i]);
1795 /* Given a pointer to an array reference structure (which lives in a
1796 gfc_ref structure), find the corresponding array specification
1797 structure. Storing the pointer in the ref structure doesn't quite
1798 work when loading from a module. Generating code for an array
1799 reference also needs more information than just the array spec. */
1801 static const mstring array_ref_types[] = {
1802 minit ("FULL", AR_FULL),
1803 minit ("ELEMENT", AR_ELEMENT),
1804 minit ("SECTION", AR_SECTION),
1809 mio_array_ref (gfc_array_ref * ar)
1814 ar->type = MIO_NAME(ar_type) (ar->type, array_ref_types);
1815 mio_integer (&ar->dimen);
1823 for (i = 0; i < ar->dimen; i++)
1824 mio_expr (&ar->start[i]);
1829 for (i = 0; i < ar->dimen; i++)
1831 mio_expr (&ar->start[i]);
1832 mio_expr (&ar->end[i]);
1833 mio_expr (&ar->stride[i]);
1839 gfc_internal_error ("mio_array_ref(): Unknown array ref");
1842 for (i = 0; i < ar->dimen; i++)
1843 mio_integer ((int *) &ar->dimen_type[i]);
1845 if (iomode == IO_INPUT)
1847 ar->where = gfc_current_locus;
1849 for (i = 0; i < ar->dimen; i++)
1850 ar->c_where[i] = gfc_current_locus;
1857 /* Saves or restores a pointer. The pointer is converted back and
1858 forth from an integer. We return the pointer_info pointer so that
1859 the caller can take additional action based on the pointer type. */
1861 static pointer_info *
1862 mio_pointer_ref (void *gp)
1866 if (iomode == IO_OUTPUT)
1868 p = get_pointer (*((char **) gp));
1869 write_atom (ATOM_INTEGER, &p->integer);
1873 require_atom (ATOM_INTEGER);
1874 p = add_fixup (atom_int, gp);
1881 /* Save and load references to components that occur within
1882 expressions. We have to describe these references by a number and
1883 by name. The number is necessary for forward references during
1884 reading, and the name is necessary if the symbol already exists in
1885 the namespace and is not loaded again. */
1888 mio_component_ref (gfc_component ** cp, gfc_symbol * sym)
1890 char name[GFC_MAX_SYMBOL_LEN + 1];
1894 p = mio_pointer_ref (cp);
1895 if (p->type == P_UNKNOWN)
1896 p->type = P_COMPONENT;
1898 if (iomode == IO_OUTPUT)
1899 mio_pool_string (&(*cp)->name);
1902 mio_internal_string (name);
1904 /* It can happen that a component reference can be read before the
1905 associated derived type symbol has been loaded. Return now and
1906 wait for a later iteration of load_needed. */
1910 if (sym->components != NULL && p->u.pointer == NULL)
1912 /* Symbol already loaded, so search by name. */
1913 for (q = sym->components; q; q = q->next)
1914 if (strcmp (q->name, name) == 0)
1918 gfc_internal_error ("mio_component_ref(): Component not found");
1920 associate_integer_pointer (p, q);
1923 /* Make sure this symbol will eventually be loaded. */
1924 p = find_pointer2 (sym);
1925 if (p->u.rsym.state == UNUSED)
1926 p->u.rsym.state = NEEDED;
1932 mio_component (gfc_component * c)
1939 if (iomode == IO_OUTPUT)
1941 p = get_pointer (c);
1942 mio_integer (&p->integer);
1947 p = get_integer (n);
1948 associate_integer_pointer (p, c);
1951 if (p->type == P_UNKNOWN)
1952 p->type = P_COMPONENT;
1954 mio_pool_string (&c->name);
1955 mio_typespec (&c->ts);
1956 mio_array_spec (&c->as);
1958 mio_integer (&c->dimension);
1959 mio_integer (&c->pointer);
1960 mio_integer (&c->allocatable);
1962 mio_expr (&c->initializer);
1968 mio_component_list (gfc_component ** cp)
1970 gfc_component *c, *tail;
1974 if (iomode == IO_OUTPUT)
1976 for (c = *cp; c; c = c->next)
1987 if (peek_atom () == ATOM_RPAREN)
1990 c = gfc_get_component ();
2007 mio_actual_arg (gfc_actual_arglist * a)
2011 mio_pool_string (&a->name);
2012 mio_expr (&a->expr);
2018 mio_actual_arglist (gfc_actual_arglist ** ap)
2020 gfc_actual_arglist *a, *tail;
2024 if (iomode == IO_OUTPUT)
2026 for (a = *ap; a; a = a->next)
2036 if (peek_atom () != ATOM_LPAREN)
2039 a = gfc_get_actual_arglist ();
2055 /* Read and write formal argument lists. */
2058 mio_formal_arglist (gfc_symbol * sym)
2060 gfc_formal_arglist *f, *tail;
2064 if (iomode == IO_OUTPUT)
2066 for (f = sym->formal; f; f = f->next)
2067 mio_symbol_ref (&f->sym);
2072 sym->formal = tail = NULL;
2074 while (peek_atom () != ATOM_RPAREN)
2076 f = gfc_get_formal_arglist ();
2077 mio_symbol_ref (&f->sym);
2079 if (sym->formal == NULL)
2092 /* Save or restore a reference to a symbol node. */
2095 mio_symbol_ref (gfc_symbol ** symp)
2099 p = mio_pointer_ref (symp);
2100 if (p->type == P_UNKNOWN)
2103 if (iomode == IO_OUTPUT)
2105 if (p->u.wsym.state == UNREFERENCED)
2106 p->u.wsym.state = NEEDS_WRITE;
2110 if (p->u.rsym.state == UNUSED)
2111 p->u.rsym.state = NEEDED;
2116 /* Save or restore a reference to a symtree node. */
2119 mio_symtree_ref (gfc_symtree ** stp)
2123 gfc_symtree * ns_st = NULL;
2125 if (iomode == IO_OUTPUT)
2127 /* If this is a symtree for a symbol that came from a contained module
2128 namespace, it has a unique name and we should look in the current
2129 namespace to see if the required, non-contained symbol is available
2130 yet. If so, the latter should be written. */
2131 if ((*stp)->n.sym && check_unique_name((*stp)->name))
2132 ns_st = gfc_find_symtree (gfc_current_ns->sym_root,
2133 (*stp)->n.sym->name);
2135 /* On the other hand, if the existing symbol is the module name or the
2136 new symbol is a dummy argument, do not do the promotion. */
2137 if (ns_st && ns_st->n.sym
2138 && ns_st->n.sym->attr.flavor != FL_MODULE
2139 && !(*stp)->n.sym->attr.dummy)
2140 mio_symbol_ref (&ns_st->n.sym);
2142 mio_symbol_ref (&(*stp)->n.sym);
2146 require_atom (ATOM_INTEGER);
2147 p = get_integer (atom_int);
2149 /* An unused equivalence member; bail out. */
2150 if (in_load_equiv && p->u.rsym.symtree == NULL)
2153 if (p->type == P_UNKNOWN)
2156 if (p->u.rsym.state == UNUSED)
2157 p->u.rsym.state = NEEDED;
2159 if (p->u.rsym.symtree != NULL)
2161 *stp = p->u.rsym.symtree;
2165 f = gfc_getmem (sizeof (fixup_t));
2167 f->next = p->u.rsym.stfixup;
2168 p->u.rsym.stfixup = f;
2170 f->pointer = (void **)stp;
2176 mio_iterator (gfc_iterator ** ip)
2182 if (iomode == IO_OUTPUT)
2189 if (peek_atom () == ATOM_RPAREN)
2195 *ip = gfc_get_iterator ();
2200 mio_expr (&iter->var);
2201 mio_expr (&iter->start);
2202 mio_expr (&iter->end);
2203 mio_expr (&iter->step);
2212 mio_constructor (gfc_constructor ** cp)
2214 gfc_constructor *c, *tail;
2218 if (iomode == IO_OUTPUT)
2220 for (c = *cp; c; c = c->next)
2223 mio_expr (&c->expr);
2224 mio_iterator (&c->iterator);
2234 while (peek_atom () != ATOM_RPAREN)
2236 c = gfc_get_constructor ();
2246 mio_expr (&c->expr);
2247 mio_iterator (&c->iterator);
2257 static const mstring ref_types[] = {
2258 minit ("ARRAY", REF_ARRAY),
2259 minit ("COMPONENT", REF_COMPONENT),
2260 minit ("SUBSTRING", REF_SUBSTRING),
2266 mio_ref (gfc_ref ** rp)
2273 r->type = MIO_NAME(ref_type) (r->type, ref_types);
2278 mio_array_ref (&r->u.ar);
2282 mio_symbol_ref (&r->u.c.sym);
2283 mio_component_ref (&r->u.c.component, r->u.c.sym);
2287 mio_expr (&r->u.ss.start);
2288 mio_expr (&r->u.ss.end);
2289 mio_charlen (&r->u.ss.length);
2298 mio_ref_list (gfc_ref ** rp)
2300 gfc_ref *ref, *head, *tail;
2304 if (iomode == IO_OUTPUT)
2306 for (ref = *rp; ref; ref = ref->next)
2313 while (peek_atom () != ATOM_RPAREN)
2316 head = tail = gfc_get_ref ();
2319 tail->next = gfc_get_ref ();
2333 /* Read and write an integer value. */
2336 mio_gmp_integer (mpz_t * integer)
2340 if (iomode == IO_INPUT)
2342 if (parse_atom () != ATOM_STRING)
2343 bad_module ("Expected integer string");
2345 mpz_init (*integer);
2346 if (mpz_set_str (*integer, atom_string, 10))
2347 bad_module ("Error converting integer");
2349 gfc_free (atom_string);
2354 p = mpz_get_str (NULL, 10, *integer);
2355 write_atom (ATOM_STRING, p);
2362 mio_gmp_real (mpfr_t * real)
2367 if (iomode == IO_INPUT)
2369 if (parse_atom () != ATOM_STRING)
2370 bad_module ("Expected real string");
2373 mpfr_set_str (*real, atom_string, 16, GFC_RND_MODE);
2374 gfc_free (atom_string);
2379 p = mpfr_get_str (NULL, &exponent, 16, 0, *real, GFC_RND_MODE);
2380 atom_string = gfc_getmem (strlen (p) + 20);
2382 sprintf (atom_string, "0.%s@%ld", p, exponent);
2384 /* Fix negative numbers. */
2385 if (atom_string[2] == '-')
2387 atom_string[0] = '-';
2388 atom_string[1] = '0';
2389 atom_string[2] = '.';
2392 write_atom (ATOM_STRING, atom_string);
2394 gfc_free (atom_string);
2400 /* Save and restore the shape of an array constructor. */
2403 mio_shape (mpz_t ** pshape, int rank)
2409 /* A NULL shape is represented by (). */
2412 if (iomode == IO_OUTPUT)
2424 if (t == ATOM_RPAREN)
2431 shape = gfc_get_shape (rank);
2435 for (n = 0; n < rank; n++)
2436 mio_gmp_integer (&shape[n]);
2442 static const mstring expr_types[] = {
2443 minit ("OP", EXPR_OP),
2444 minit ("FUNCTION", EXPR_FUNCTION),
2445 minit ("CONSTANT", EXPR_CONSTANT),
2446 minit ("VARIABLE", EXPR_VARIABLE),
2447 minit ("SUBSTRING", EXPR_SUBSTRING),
2448 minit ("STRUCTURE", EXPR_STRUCTURE),
2449 minit ("ARRAY", EXPR_ARRAY),
2450 minit ("NULL", EXPR_NULL),
2454 /* INTRINSIC_ASSIGN is missing because it is used as an index for
2455 generic operators, not in expressions. INTRINSIC_USER is also
2456 replaced by the correct function name by the time we see it. */
2458 static const mstring intrinsics[] =
2460 minit ("UPLUS", INTRINSIC_UPLUS),
2461 minit ("UMINUS", INTRINSIC_UMINUS),
2462 minit ("PLUS", INTRINSIC_PLUS),
2463 minit ("MINUS", INTRINSIC_MINUS),
2464 minit ("TIMES", INTRINSIC_TIMES),
2465 minit ("DIVIDE", INTRINSIC_DIVIDE),
2466 minit ("POWER", INTRINSIC_POWER),
2467 minit ("CONCAT", INTRINSIC_CONCAT),
2468 minit ("AND", INTRINSIC_AND),
2469 minit ("OR", INTRINSIC_OR),
2470 minit ("EQV", INTRINSIC_EQV),
2471 minit ("NEQV", INTRINSIC_NEQV),
2472 minit ("EQ", INTRINSIC_EQ),
2473 minit ("NE", INTRINSIC_NE),
2474 minit ("GT", INTRINSIC_GT),
2475 minit ("GE", INTRINSIC_GE),
2476 minit ("LT", INTRINSIC_LT),
2477 minit ("LE", INTRINSIC_LE),
2478 minit ("NOT", INTRINSIC_NOT),
2479 minit ("PARENTHESES", INTRINSIC_PARENTHESES),
2483 /* Read and write expressions. The form "()" is allowed to indicate a
2487 mio_expr (gfc_expr ** ep)
2495 if (iomode == IO_OUTPUT)
2504 MIO_NAME(expr_t) (e->expr_type, expr_types);
2510 if (t == ATOM_RPAREN)
2517 bad_module ("Expected expression type");
2519 e = *ep = gfc_get_expr ();
2520 e->where = gfc_current_locus;
2521 e->expr_type = (expr_t) find_enum (expr_types);
2524 mio_typespec (&e->ts);
2525 mio_integer (&e->rank);
2527 switch (e->expr_type)
2530 e->value.op.operator
2531 = MIO_NAME(gfc_intrinsic_op) (e->value.op.operator, intrinsics);
2533 switch (e->value.op.operator)
2535 case INTRINSIC_UPLUS:
2536 case INTRINSIC_UMINUS:
2538 case INTRINSIC_PARENTHESES:
2539 mio_expr (&e->value.op.op1);
2542 case INTRINSIC_PLUS:
2543 case INTRINSIC_MINUS:
2544 case INTRINSIC_TIMES:
2545 case INTRINSIC_DIVIDE:
2546 case INTRINSIC_POWER:
2547 case INTRINSIC_CONCAT:
2551 case INTRINSIC_NEQV:
2558 mio_expr (&e->value.op.op1);
2559 mio_expr (&e->value.op.op2);
2563 bad_module ("Bad operator");
2569 mio_symtree_ref (&e->symtree);
2570 mio_actual_arglist (&e->value.function.actual);
2572 if (iomode == IO_OUTPUT)
2574 e->value.function.name
2575 = mio_allocated_string (e->value.function.name);
2576 flag = e->value.function.esym != NULL;
2577 mio_integer (&flag);
2579 mio_symbol_ref (&e->value.function.esym);
2581 write_atom (ATOM_STRING, e->value.function.isym->name);
2586 require_atom (ATOM_STRING);
2587 e->value.function.name = gfc_get_string (atom_string);
2588 gfc_free (atom_string);
2590 mio_integer (&flag);
2592 mio_symbol_ref (&e->value.function.esym);
2595 require_atom (ATOM_STRING);
2596 e->value.function.isym = gfc_find_function (atom_string);
2597 gfc_free (atom_string);
2604 mio_symtree_ref (&e->symtree);
2605 mio_ref_list (&e->ref);
2608 case EXPR_SUBSTRING:
2609 e->value.character.string = (char *)
2610 mio_allocated_string (e->value.character.string);
2611 mio_ref_list (&e->ref);
2614 case EXPR_STRUCTURE:
2616 mio_constructor (&e->value.constructor);
2617 mio_shape (&e->shape, e->rank);
2624 mio_gmp_integer (&e->value.integer);
2628 gfc_set_model_kind (e->ts.kind);
2629 mio_gmp_real (&e->value.real);
2633 gfc_set_model_kind (e->ts.kind);
2634 mio_gmp_real (&e->value.complex.r);
2635 mio_gmp_real (&e->value.complex.i);
2639 mio_integer (&e->value.logical);
2643 mio_integer (&e->value.character.length);
2644 e->value.character.string = (char *)
2645 mio_allocated_string (e->value.character.string);
2649 bad_module ("Bad type in constant expression");
2662 /* Read and write namelists */
2665 mio_namelist (gfc_symbol * sym)
2667 gfc_namelist *n, *m;
2668 const char *check_name;
2672 if (iomode == IO_OUTPUT)
2674 for (n = sym->namelist; n; n = n->next)
2675 mio_symbol_ref (&n->sym);
2679 /* This departure from the standard is flagged as an error.
2680 It does, in fact, work correctly. TODO: Allow it
2682 if (sym->attr.flavor == FL_NAMELIST)
2684 check_name = find_use_name (sym->name);
2685 if (check_name && strcmp (check_name, sym->name) != 0)
2686 gfc_error("Namelist %s cannot be renamed by USE"
2687 " association to %s.",
2688 sym->name, check_name);
2692 while (peek_atom () != ATOM_RPAREN)
2694 n = gfc_get_namelist ();
2695 mio_symbol_ref (&n->sym);
2697 if (sym->namelist == NULL)
2704 sym->namelist_tail = m;
2711 /* Save/restore lists of gfc_interface stuctures. When loading an
2712 interface, we are really appending to the existing list of
2713 interfaces. Checking for duplicate and ambiguous interfaces has to
2714 be done later when all symbols have been loaded. */
2717 mio_interface_rest (gfc_interface ** ip)
2719 gfc_interface *tail, *p;
2721 if (iomode == IO_OUTPUT)
2724 for (p = *ip; p; p = p->next)
2725 mio_symbol_ref (&p->sym);
2741 if (peek_atom () == ATOM_RPAREN)
2744 p = gfc_get_interface ();
2745 p->where = gfc_current_locus;
2746 mio_symbol_ref (&p->sym);
2761 /* Save/restore a nameless operator interface. */
2764 mio_interface (gfc_interface ** ip)
2768 mio_interface_rest (ip);
2772 /* Save/restore a named operator interface. */
2775 mio_symbol_interface (const char **name, const char **module,
2776 gfc_interface ** ip)
2781 mio_pool_string (name);
2782 mio_pool_string (module);
2784 mio_interface_rest (ip);
2789 mio_namespace_ref (gfc_namespace ** nsp)
2794 p = mio_pointer_ref (nsp);
2796 if (p->type == P_UNKNOWN)
2797 p->type = P_NAMESPACE;
2799 if (iomode == IO_INPUT && p->integer != 0)
2801 ns = (gfc_namespace *)p->u.pointer;
2804 ns = gfc_get_namespace (NULL, 0);
2805 associate_integer_pointer (p, ns);
2813 /* Unlike most other routines, the address of the symbol node is
2814 already fixed on input and the name/module has already been filled
2818 mio_symbol (gfc_symbol * sym)
2820 gfc_formal_arglist *formal;
2824 mio_symbol_attribute (&sym->attr);
2825 mio_typespec (&sym->ts);
2827 /* Contained procedures don't have formal namespaces. Instead we output the
2828 procedure namespace. The will contain the formal arguments. */
2829 if (iomode == IO_OUTPUT)
2831 formal = sym->formal;
2832 while (formal && !formal->sym)
2833 formal = formal->next;
2836 mio_namespace_ref (&formal->sym->ns);
2838 mio_namespace_ref (&sym->formal_ns);
2842 mio_namespace_ref (&sym->formal_ns);
2845 sym->formal_ns->proc_name = sym;
2850 /* Save/restore common block links */
2851 mio_symbol_ref (&sym->common_next);
2853 mio_formal_arglist (sym);
2855 if (sym->attr.flavor == FL_PARAMETER)
2856 mio_expr (&sym->value);
2858 mio_array_spec (&sym->as);
2860 mio_symbol_ref (&sym->result);
2862 if (sym->attr.cray_pointee)
2863 mio_symbol_ref (&sym->cp_pointer);
2865 /* Note that components are always saved, even if they are supposed
2866 to be private. Component access is checked during searching. */
2868 mio_component_list (&sym->components);
2870 if (sym->components != NULL)
2871 sym->component_access =
2872 MIO_NAME(gfc_access) (sym->component_access, access_types);
2879 /************************* Top level subroutines *************************/
2881 /* Skip a list between balanced left and right parens. */
2891 switch (parse_atom ())
2902 gfc_free (atom_string);
2914 /* Load operator interfaces from the module. Interfaces are unusual
2915 in that they attach themselves to existing symbols. */
2918 load_operator_interfaces (void)
2921 char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
2926 while (peek_atom () != ATOM_RPAREN)
2930 mio_internal_string (name);
2931 mio_internal_string (module);
2933 /* Decide if we need to load this one or not. */
2934 p = find_use_name (name);
2937 while (parse_atom () != ATOM_RPAREN);
2941 uop = gfc_get_uop (p);
2942 mio_interface_rest (&uop->operator);
2950 /* Load interfaces from the module. Interfaces are unusual in that
2951 they attach themselves to existing symbols. */
2954 load_generic_interfaces (void)
2957 char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
2962 while (peek_atom () != ATOM_RPAREN)
2966 mio_internal_string (name);
2967 mio_internal_string (module);
2969 /* Decide if we need to load this one or not. */
2970 p = find_use_name (name);
2972 if (p == NULL || gfc_find_symbol (p, NULL, 0, &sym))
2974 while (parse_atom () != ATOM_RPAREN);
2980 gfc_get_symbol (p, NULL, &sym);
2982 sym->attr.flavor = FL_PROCEDURE;
2983 sym->attr.generic = 1;
2984 sym->attr.use_assoc = 1;
2987 mio_interface_rest (&sym->generic);
2994 /* Load common blocks. */
2999 char name[GFC_MAX_SYMBOL_LEN+1];
3004 while (peek_atom () != ATOM_RPAREN)
3008 mio_internal_string (name);
3010 p = gfc_get_common (name, 1);
3012 mio_symbol_ref (&p->head);
3013 mio_integer (&flags);
3017 p->threadprivate = 1;
3026 /* load_equiv()-- Load equivalences. The flag in_load_equiv informs
3027 mio_expr_ref of this so that unused variables are not loaded and
3028 so that the expression can be safely freed.*/
3033 gfc_equiv *head, *tail, *end, *eq;
3037 in_load_equiv = true;
3039 end = gfc_current_ns->equiv;
3040 while(end != NULL && end->next != NULL)
3043 while(peek_atom() != ATOM_RPAREN) {
3047 while(peek_atom() != ATOM_RPAREN)
3050 head = tail = gfc_get_equiv();
3053 tail->eq = gfc_get_equiv();
3057 mio_pool_string(&tail->module);
3058 mio_expr(&tail->expr);
3061 /* Unused variables have no symtree. */
3063 for (eq = head; eq; eq = eq->eq)
3065 if (!eq->expr->symtree)
3074 for (eq = head; eq; eq = head)
3077 gfc_free_expr (eq->expr);
3083 gfc_current_ns->equiv = head;
3094 in_load_equiv = false;
3097 /* Recursive function to traverse the pointer_info tree and load a
3098 needed symbol. We return nonzero if we load a symbol and stop the
3099 traversal, because the act of loading can alter the tree. */
3102 load_needed (pointer_info * p)
3113 rv |= load_needed (p->left);
3114 rv |= load_needed (p->right);
3116 if (p->type != P_SYMBOL || p->u.rsym.state != NEEDED)
3119 p->u.rsym.state = USED;
3121 set_module_locus (&p->u.rsym.where);
3123 sym = p->u.rsym.sym;
3126 q = get_integer (p->u.rsym.ns);
3128 ns = (gfc_namespace *) q->u.pointer;
3131 /* Create an interface namespace if necessary. These are
3132 the namespaces that hold the formal parameters of module
3135 ns = gfc_get_namespace (NULL, 0);
3136 associate_integer_pointer (q, ns);
3139 sym = gfc_new_symbol (p->u.rsym.true_name, ns);
3140 sym->module = gfc_get_string (p->u.rsym.module);
3142 associate_integer_pointer (p, sym);
3146 sym->attr.use_assoc = 1;
3152 /* Recursive function for cleaning up things after a module has been
3156 read_cleanup (pointer_info * p)
3164 read_cleanup (p->left);
3165 read_cleanup (p->right);
3167 if (p->type == P_SYMBOL && p->u.rsym.state == USED && !p->u.rsym.referenced)
3169 /* Add hidden symbols to the symtree. */
3170 q = get_integer (p->u.rsym.ns);
3171 st = get_unique_symtree ((gfc_namespace *) q->u.pointer);
3173 st->n.sym = p->u.rsym.sym;
3176 /* Fixup any symtree references. */
3177 p->u.rsym.symtree = st;
3178 resolve_fixups (p->u.rsym.stfixup, st);
3179 p->u.rsym.stfixup = NULL;
3182 /* Free unused symbols. */
3183 if (p->type == P_SYMBOL && p->u.rsym.state == UNUSED)
3184 gfc_free_symbol (p->u.rsym.sym);
3188 /* Read a module file. */
3193 module_locus operator_interfaces, user_operators;
3195 char name[GFC_MAX_SYMBOL_LEN + 1];
3197 int ambiguous, j, nuse, symbol;
3203 get_module_locus (&operator_interfaces); /* Skip these for now */
3206 get_module_locus (&user_operators);
3210 /* Skip commons and equivalences for now. */
3216 /* Create the fixup nodes for all the symbols. */
3218 while (peek_atom () != ATOM_RPAREN)
3220 require_atom (ATOM_INTEGER);
3221 info = get_integer (atom_int);
3223 info->type = P_SYMBOL;
3224 info->u.rsym.state = UNUSED;
3226 mio_internal_string (info->u.rsym.true_name);
3227 mio_internal_string (info->u.rsym.module);
3229 require_atom (ATOM_INTEGER);
3230 info->u.rsym.ns = atom_int;
3232 get_module_locus (&info->u.rsym.where);
3235 /* See if the symbol has already been loaded by a previous module.
3236 If so, we reference the existing symbol and prevent it from
3237 being loaded again. This should not happen if the symbol being
3238 read is an index for an assumed shape dummy array (ns != 1). */
3240 sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module);
3243 || (sym->attr.flavor == FL_VARIABLE
3244 && info->u.rsym.ns !=1))
3247 info->u.rsym.state = USED;
3248 info->u.rsym.referenced = 1;
3249 info->u.rsym.sym = sym;
3254 /* Parse the symtree lists. This lets us mark which symbols need to
3255 be loaded. Renaming is also done at this point by replacing the
3260 while (peek_atom () != ATOM_RPAREN)
3262 mio_internal_string (name);
3263 mio_integer (&ambiguous);
3264 mio_integer (&symbol);
3266 info = get_integer (symbol);
3268 /* See how many use names there are. If none, go through the start
3269 of the loop at least once. */
3270 nuse = number_use_names (name);
3274 for (j = 1; j <= nuse; j++)
3276 /* Get the jth local name for this symbol. */
3277 p = find_use_name_n (name, &j);
3279 /* Skip symtree nodes not in an ONLY clause. */
3283 /* Check for ambiguous symbols. */
3284 st = gfc_find_symtree (gfc_current_ns->sym_root, p);
3288 if (st->n.sym != info->u.rsym.sym)
3290 info->u.rsym.symtree = st;
3294 /* Create a symtree node in the current namespace for this symbol. */
3295 st = check_unique_name (p) ? get_unique_symtree (gfc_current_ns) :
3296 gfc_new_symtree (&gfc_current_ns->sym_root, p);
3298 st->ambiguous = ambiguous;
3300 sym = info->u.rsym.sym;
3302 /* Create a symbol node if it doesn't already exist. */
3305 sym = info->u.rsym.sym =
3306 gfc_new_symbol (info->u.rsym.true_name,
3309 sym->module = gfc_get_string (info->u.rsym.module);
3315 /* Store the symtree pointing to this symbol. */
3316 info->u.rsym.symtree = st;
3318 if (info->u.rsym.state == UNUSED)
3319 info->u.rsym.state = NEEDED;
3320 info->u.rsym.referenced = 1;
3327 /* Load intrinsic operator interfaces. */
3328 set_module_locus (&operator_interfaces);
3331 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3333 if (i == INTRINSIC_USER)
3338 u = find_use_operator (i);
3349 mio_interface (&gfc_current_ns->operator[i]);
3354 /* Load generic and user operator interfaces. These must follow the
3355 loading of symtree because otherwise symbols can be marked as
3358 set_module_locus (&user_operators);
3360 load_operator_interfaces ();
3361 load_generic_interfaces ();
3366 /* At this point, we read those symbols that are needed but haven't
3367 been loaded yet. If one symbol requires another, the other gets
3368 marked as NEEDED if its previous state was UNUSED. */
3370 while (load_needed (pi_root));
3372 /* Make sure all elements of the rename-list were found in the
3375 for (u = gfc_rename_list; u; u = u->next)
3380 if (u->operator == INTRINSIC_NONE)
3382 gfc_error ("Symbol '%s' referenced at %L not found in module '%s'",
3383 u->use_name, &u->where, module_name);
3387 if (u->operator == INTRINSIC_USER)
3390 ("User operator '%s' referenced at %L not found in module '%s'",
3391 u->use_name, &u->where, module_name);
3396 ("Intrinsic operator '%s' referenced at %L not found in module "
3397 "'%s'", gfc_op2string (u->operator), &u->where, module_name);
3400 gfc_check_interfaces (gfc_current_ns);
3402 /* Clean up symbol nodes that were never loaded, create references
3403 to hidden symbols. */
3405 read_cleanup (pi_root);
3409 /* Given an access type that is specific to an entity and the default
3410 access, return nonzero if the entity is publicly accessible. */
3413 gfc_check_access (gfc_access specific_access, gfc_access default_access)
3416 if (specific_access == ACCESS_PUBLIC)
3418 if (specific_access == ACCESS_PRIVATE)
3421 if (gfc_option.flag_module_access_private)
3422 return default_access == ACCESS_PUBLIC;
3424 return default_access != ACCESS_PRIVATE;
3430 /* Write a common block to the module */
3433 write_common (gfc_symtree *st)
3442 write_common(st->left);
3443 write_common(st->right);
3447 /* Write the unmangled name. */
3448 name = st->n.common->name;
3450 mio_pool_string(&name);
3453 mio_symbol_ref(&p->head);
3454 flags = p->saved ? 1 : 0;
3455 if (p->threadprivate) flags |= 2;
3456 mio_integer(&flags);
3461 /* Write the blank common block to the module */
3464 write_blank_common (void)
3466 const char * name = BLANK_COMMON_NAME;
3469 if (gfc_current_ns->blank_common.head == NULL)
3474 mio_pool_string(&name);
3476 mio_symbol_ref(&gfc_current_ns->blank_common.head);
3477 saved = gfc_current_ns->blank_common.saved;
3478 mio_integer(&saved);
3483 /* Write equivalences to the module. */
3492 for(eq=gfc_current_ns->equiv; eq; eq=eq->next)
3496 for(e=eq; e; e=e->eq)
3498 if (e->module == NULL)
3499 e->module = gfc_get_string("%s.eq.%d", module_name, num);
3500 mio_allocated_string(e->module);
3509 /* Write a symbol to the module. */
3512 write_symbol (int n, gfc_symbol * sym)
3515 if (sym->attr.flavor == FL_UNKNOWN || sym->attr.flavor == FL_LABEL)
3516 gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym->name);
3519 mio_pool_string (&sym->name);
3521 mio_pool_string (&sym->module);
3522 mio_pointer_ref (&sym->ns);
3529 /* Recursive traversal function to write the initial set of symbols to
3530 the module. We check to see if the symbol should be written
3531 according to the access specification. */
3534 write_symbol0 (gfc_symtree * st)
3542 write_symbol0 (st->left);
3543 write_symbol0 (st->right);
3546 if (sym->module == NULL)
3547 sym->module = gfc_get_string (module_name);
3549 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
3550 && !sym->attr.subroutine && !sym->attr.function)
3553 if (!gfc_check_access (sym->attr.access, sym->ns->default_access))
3556 p = get_pointer (sym);
3557 if (p->type == P_UNKNOWN)
3560 if (p->u.wsym.state == WRITTEN)
3563 write_symbol (p->integer, sym);
3564 p->u.wsym.state = WRITTEN;
3570 /* Recursive traversal function to write the secondary set of symbols
3571 to the module file. These are symbols that were not public yet are
3572 needed by the public symbols or another dependent symbol. The act
3573 of writing a symbol can modify the pointer_info tree, so we cease
3574 traversal if we find a symbol to write. We return nonzero if a
3575 symbol was written and pass that information upwards. */
3578 write_symbol1 (pointer_info * p)
3584 if (write_symbol1 (p->left))
3586 if (write_symbol1 (p->right))
3589 if (p->type != P_SYMBOL || p->u.wsym.state != NEEDS_WRITE)
3592 p->u.wsym.state = WRITTEN;
3593 write_symbol (p->integer, p->u.wsym.sym);
3599 /* Write operator interfaces associated with a symbol. */
3602 write_operator (gfc_user_op * uop)
3604 static char nullstring[] = "";
3605 const char *p = nullstring;
3607 if (uop->operator == NULL
3608 || !gfc_check_access (uop->access, uop->ns->default_access))
3611 mio_symbol_interface (&uop->name, &p, &uop->operator);
3615 /* Write generic interfaces associated with a symbol. */
3618 write_generic (gfc_symbol * sym)
3621 if (sym->generic == NULL
3622 || !gfc_check_access (sym->attr.access, sym->ns->default_access))
3625 mio_symbol_interface (&sym->name, &sym->module, &sym->generic);
3630 write_symtree (gfc_symtree * st)
3636 if (!gfc_check_access (sym->attr.access, sym->ns->default_access)
3637 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
3638 && !sym->attr.subroutine && !sym->attr.function))
3641 if (check_unique_name (st->name))
3644 p = find_pointer (sym);
3646 gfc_internal_error ("write_symtree(): Symbol not written");
3648 mio_pool_string (&st->name);
3649 mio_integer (&st->ambiguous);
3650 mio_integer (&p->integer);
3659 /* Write the operator interfaces. */
3662 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3664 if (i == INTRINSIC_USER)
3667 mio_interface (gfc_check_access (gfc_current_ns->operator_access[i],
3668 gfc_current_ns->default_access)
3669 ? &gfc_current_ns->operator[i] : NULL);
3677 gfc_traverse_user_op (gfc_current_ns, write_operator);
3683 gfc_traverse_ns (gfc_current_ns, write_generic);
3689 write_blank_common ();
3690 write_common (gfc_current_ns->common_root);
3698 write_char('\n'); write_char('\n');
3700 /* Write symbol information. First we traverse all symbols in the
3701 primary namespace, writing those that need to be written.
3702 Sometimes writing one symbol will cause another to need to be
3703 written. A list of these symbols ends up on the write stack, and
3704 we end by popping the bottom of the stack and writing the symbol
3705 until the stack is empty. */
3709 write_symbol0 (gfc_current_ns->sym_root);
3710 while (write_symbol1 (pi_root));
3718 gfc_traverse_symtree (gfc_current_ns->sym_root, write_symtree);
3723 /* Given module, dump it to disk. If there was an error while
3724 processing the module, dump_flag will be set to zero and we delete
3725 the module file, even if it was already there. */
3728 gfc_dump_module (const char *name, int dump_flag)
3734 n = strlen (name) + strlen (MODULE_EXTENSION) + 1;
3735 if (gfc_option.module_dir != NULL)
3737 filename = (char *) alloca (n + strlen (gfc_option.module_dir));
3738 strcpy (filename, gfc_option.module_dir);
3739 strcat (filename, name);
3743 filename = (char *) alloca (n);
3744 strcpy (filename, name);
3746 strcat (filename, MODULE_EXTENSION);
3754 module_fp = fopen (filename, "w");
3755 if (module_fp == NULL)
3756 gfc_fatal_error ("Can't open module file '%s' for writing at %C: %s",
3757 filename, strerror (errno));
3762 *strchr (p, '\n') = '\0';
3764 fprintf (module_fp, "GFORTRAN module created from %s on %s\n",
3765 gfc_source_file, p);
3766 fputs ("If you edit this, you'll get what you deserve.\n\n", module_fp);
3769 strcpy (module_name, name);
3775 free_pi_tree (pi_root);
3780 if (fclose (module_fp))
3781 gfc_fatal_error ("Error writing module file '%s' for writing: %s",
3782 filename, strerror (errno));
3786 /* Process a USE directive. */
3789 gfc_use_module (void)
3795 filename = (char *) alloca(strlen(module_name) + strlen(MODULE_EXTENSION)
3797 strcpy (filename, module_name);
3798 strcat (filename, MODULE_EXTENSION);
3800 module_fp = gfc_open_included_file (filename, true);
3801 if (module_fp == NULL)
3802 gfc_fatal_error ("Can't open module file '%s' for reading at %C: %s",
3803 filename, strerror (errno));
3809 /* Skip the first two lines of the module. */
3810 /* FIXME: Could also check for valid two lines here, instead. */
3816 bad_module ("Unexpected end of module");
3821 /* Make sure we're not reading the same module that we may be building. */
3822 for (p = gfc_state_stack; p; p = p->previous)
3823 if (p->state == COMP_MODULE && strcmp (p->sym->name, module_name) == 0)
3824 gfc_fatal_error ("Can't USE the same module we're building!");
3827 init_true_name_tree ();
3831 free_true_name (true_name_root);
3832 true_name_root = NULL;
3834 free_pi_tree (pi_root);
3842 gfc_module_init_2 (void)
3845 last_atom = ATOM_LPAREN;
3850 gfc_module_done_2 (void)