1 /* Handle modules, which amounts to loading and saving symbols and
2 their attendant structures.
3 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
4 Free Software Foundation, Inc.
5 Contributed by Andy Vaught
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 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 */
77 #define MODULE_EXTENSION ".mod"
80 /* Structure that describes a position within a module file. */
89 /* Structure for list of symbols of intrinsic modules. */
101 P_UNKNOWN
= 0, P_OTHER
, P_NAMESPACE
, P_COMPONENT
, P_SYMBOL
105 /* The fixup structure lists pointers to pointers that have to
106 be updated when a pointer value becomes known. */
108 typedef struct fixup_t
111 struct fixup_t
*next
;
116 /* Structure for holding extra info needed for pointers being read. */
118 typedef struct pointer_info
120 BBT_HEADER (pointer_info
);
124 /* The first component of each member of the union is the pointer
131 void *pointer
; /* Member for doing pointer searches. */
136 char true_name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[GFC_MAX_SYMBOL_LEN
+ 1];
138 { UNUSED
, NEEDED
, USED
}
143 gfc_symtree
*symtree
;
144 char binding_label
[GFC_MAX_SYMBOL_LEN
+ 1];
152 { UNREFERENCED
= 0, NEEDS_WRITE
, WRITTEN
}
162 #define gfc_get_pointer_info() gfc_getmem(sizeof(pointer_info))
165 /* Lists of rename info for the USE statement. */
167 typedef struct gfc_use_rename
169 char local_name
[GFC_MAX_SYMBOL_LEN
+ 1], use_name
[GFC_MAX_SYMBOL_LEN
+ 1];
170 struct gfc_use_rename
*next
;
172 gfc_intrinsic_op
operator;
177 #define gfc_get_use_rename() gfc_getmem(sizeof(gfc_use_rename))
179 /* Local variables */
181 /* The FILE for the module we're reading or writing. */
182 static FILE *module_fp
;
184 /* MD5 context structure. */
185 static struct md5_ctx ctx
;
187 /* The name of the module we're reading (USE'ing) or writing. */
188 static char module_name
[GFC_MAX_SYMBOL_LEN
+ 1];
190 /* The way the module we're reading was specified. */
191 static bool specified_nonint
, specified_int
;
193 static int module_line
, module_column
, only_flag
;
195 { IO_INPUT
, IO_OUTPUT
}
198 static gfc_use_rename
*gfc_rename_list
;
199 static pointer_info
*pi_root
;
200 static int symbol_number
; /* Counter for assigning symbol numbers */
202 /* Tells mio_expr_ref to make symbols for unused equivalence members. */
203 static bool in_load_equiv
;
207 /*****************************************************************/
209 /* Pointer/integer conversion. Pointers between structures are stored
210 as integers in the module file. The next couple of subroutines
211 handle this translation for reading and writing. */
213 /* Recursively free the tree of pointer structures. */
216 free_pi_tree (pointer_info
*p
)
221 if (p
->fixup
!= NULL
)
222 gfc_internal_error ("free_pi_tree(): Unresolved fixup");
224 free_pi_tree (p
->left
);
225 free_pi_tree (p
->right
);
231 /* Compare pointers when searching by pointer. Used when writing a
235 compare_pointers (void *_sn1
, void *_sn2
)
237 pointer_info
*sn1
, *sn2
;
239 sn1
= (pointer_info
*) _sn1
;
240 sn2
= (pointer_info
*) _sn2
;
242 if (sn1
->u
.pointer
< sn2
->u
.pointer
)
244 if (sn1
->u
.pointer
> sn2
->u
.pointer
)
251 /* Compare integers when searching by integer. Used when reading a
255 compare_integers (void *_sn1
, void *_sn2
)
257 pointer_info
*sn1
, *sn2
;
259 sn1
= (pointer_info
*) _sn1
;
260 sn2
= (pointer_info
*) _sn2
;
262 if (sn1
->integer
< sn2
->integer
)
264 if (sn1
->integer
> sn2
->integer
)
271 /* Initialize the pointer_info tree. */
280 compare
= (iomode
== IO_INPUT
) ? compare_integers
: compare_pointers
;
282 /* Pointer 0 is the NULL pointer. */
283 p
= gfc_get_pointer_info ();
288 gfc_insert_bbt (&pi_root
, p
, compare
);
290 /* Pointer 1 is the current namespace. */
291 p
= gfc_get_pointer_info ();
292 p
->u
.pointer
= gfc_current_ns
;
294 p
->type
= P_NAMESPACE
;
296 gfc_insert_bbt (&pi_root
, p
, compare
);
302 /* During module writing, call here with a pointer to something,
303 returning the pointer_info node. */
305 static pointer_info
*
306 find_pointer (void *gp
)
313 if (p
->u
.pointer
== gp
)
315 p
= (gp
< p
->u
.pointer
) ? p
->left
: p
->right
;
322 /* Given a pointer while writing, returns the pointer_info tree node,
323 creating it if it doesn't exist. */
325 static pointer_info
*
326 get_pointer (void *gp
)
330 p
= find_pointer (gp
);
334 /* Pointer doesn't have an integer. Give it one. */
335 p
= gfc_get_pointer_info ();
338 p
->integer
= symbol_number
++;
340 gfc_insert_bbt (&pi_root
, p
, compare_pointers
);
346 /* Given an integer during reading, find it in the pointer_info tree,
347 creating the node if not found. */
349 static pointer_info
*
350 get_integer (int integer
)
360 c
= compare_integers (&t
, p
);
364 p
= (c
< 0) ? p
->left
: p
->right
;
370 p
= gfc_get_pointer_info ();
371 p
->integer
= integer
;
374 gfc_insert_bbt (&pi_root
, p
, compare_integers
);
380 /* Recursive function to find a pointer within a tree by brute force. */
382 static pointer_info
*
383 fp2 (pointer_info
*p
, const void *target
)
390 if (p
->u
.pointer
== target
)
393 q
= fp2 (p
->left
, target
);
397 return fp2 (p
->right
, target
);
401 /* During reading, find a pointer_info node from the pointer value.
402 This amounts to a brute-force search. */
404 static pointer_info
*
405 find_pointer2 (void *p
)
407 return fp2 (pi_root
, p
);
411 /* Resolve any fixups using a known pointer. */
414 resolve_fixups (fixup_t
*f
, void *gp
)
427 /* Call here during module reading when we know what pointer to
428 associate with an integer. Any fixups that exist are resolved at
432 associate_integer_pointer (pointer_info
*p
, void *gp
)
434 if (p
->u
.pointer
!= NULL
)
435 gfc_internal_error ("associate_integer_pointer(): Already associated");
439 resolve_fixups (p
->fixup
, gp
);
445 /* During module reading, given an integer and a pointer to a pointer,
446 either store the pointer from an already-known value or create a
447 fixup structure in order to store things later. Returns zero if
448 the reference has been actually stored, or nonzero if the reference
449 must be fixed later (ie associate_integer_pointer must be called
450 sometime later. Returns the pointer_info structure. */
452 static pointer_info
*
453 add_fixup (int integer
, void *gp
)
459 p
= get_integer (integer
);
461 if (p
->integer
== 0 || p
->u
.pointer
!= NULL
)
468 f
= gfc_getmem (sizeof (fixup_t
));
480 /*****************************************************************/
482 /* Parser related subroutines */
484 /* Free the rename list left behind by a USE statement. */
489 gfc_use_rename
*next
;
491 for (; gfc_rename_list
; gfc_rename_list
= next
)
493 next
= gfc_rename_list
->next
;
494 gfc_free (gfc_rename_list
);
499 /* Match a USE statement. */
504 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module_nature
[GFC_MAX_SYMBOL_LEN
+ 1];
505 gfc_use_rename
*tail
= NULL
, *new;
506 interface_type type
, type2
;
507 gfc_intrinsic_op
operator;
510 specified_int
= false;
511 specified_nonint
= false;
513 if (gfc_match (" , ") == MATCH_YES
)
515 if ((m
= gfc_match (" %n ::", module_nature
)) == MATCH_YES
)
517 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: module "
518 "nature in USE statement at %C") == FAILURE
)
521 if (strcmp (module_nature
, "intrinsic") == 0)
522 specified_int
= true;
525 if (strcmp (module_nature
, "non_intrinsic") == 0)
526 specified_nonint
= true;
529 gfc_error ("Module nature in USE statement at %C shall "
530 "be either INTRINSIC or NON_INTRINSIC");
537 /* Help output a better error message than "Unclassifiable
539 gfc_match (" %n", module_nature
);
540 if (strcmp (module_nature
, "intrinsic") == 0
541 || strcmp (module_nature
, "non_intrinsic") == 0)
542 gfc_error ("\"::\" was expected after module nature at %C "
543 "but was not found");
549 m
= gfc_match (" ::");
550 if (m
== MATCH_YES
&&
551 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: "
552 "\"USE :: module\" at %C") == FAILURE
)
557 m
= gfc_match ("% ");
563 m
= gfc_match_name (module_name
);
570 if (gfc_match_eos () == MATCH_YES
)
572 if (gfc_match_char (',') != MATCH_YES
)
575 if (gfc_match (" only :") == MATCH_YES
)
578 if (gfc_match_eos () == MATCH_YES
)
583 /* Get a new rename struct and add it to the rename list. */
584 new = gfc_get_use_rename ();
585 new->where
= gfc_current_locus
;
588 if (gfc_rename_list
== NULL
)
589 gfc_rename_list
= new;
594 /* See what kind of interface we're dealing with. Assume it is
596 new->operator = INTRINSIC_NONE
;
597 if (gfc_match_generic_spec (&type
, name
, &operator) == MATCH_ERROR
)
602 case INTERFACE_NAMELESS
:
603 gfc_error ("Missing generic specification in USE statement at %C");
606 case INTERFACE_USER_OP
:
607 case INTERFACE_GENERIC
:
608 m
= gfc_match (" =>");
610 if (type
== INTERFACE_USER_OP
&& m
== MATCH_YES
611 && (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Renaming "
612 "operators in USE statements at %C")
619 strcpy (new->use_name
, name
);
622 strcpy (new->local_name
, name
);
623 m
= gfc_match_generic_spec (&type2
, new->use_name
, &operator);
628 if (m
== MATCH_ERROR
)
636 strcpy (new->local_name
, name
);
638 m
= gfc_match_generic_spec (&type2
, new->use_name
, &operator);
643 if (m
== MATCH_ERROR
)
647 if (strcmp (new->use_name
, module_name
) == 0
648 || strcmp (new->local_name
, module_name
) == 0)
650 gfc_error ("The name '%s' at %C has already been used as "
651 "an external module name.", module_name
);
655 if (type
== INTERFACE_USER_OP
)
656 new->operator = operator;
660 case INTERFACE_INTRINSIC_OP
:
661 new->operator = operator;
665 if (gfc_match_eos () == MATCH_YES
)
667 if (gfc_match_char (',') != MATCH_YES
)
674 gfc_syntax_error (ST_USE
);
682 /* Given a name and a number, inst, return the inst name
683 under which to load this symbol. Returns NULL if this
684 symbol shouldn't be loaded. If inst is zero, returns
685 the number of instances of this name. */
688 find_use_name_n (const char *name
, int *inst
)
694 for (u
= gfc_rename_list
; u
; u
= u
->next
)
696 if (strcmp (u
->use_name
, name
) != 0)
709 return only_flag
? NULL
: name
;
713 return (u
->local_name
[0] != '\0') ? u
->local_name
: name
;
717 /* Given a name, return the name under which to load this symbol.
718 Returns NULL if this symbol shouldn't be loaded. */
721 find_use_name (const char *name
)
724 return find_use_name_n (name
, &i
);
728 /* Given a real name, return the number of use names associated with it. */
731 number_use_names (const char *name
)
735 c
= find_use_name_n (name
, &i
);
740 /* Try to find the operator in the current list. */
742 static gfc_use_rename
*
743 find_use_operator (gfc_intrinsic_op
operator)
747 for (u
= gfc_rename_list
; u
; u
= u
->next
)
748 if (u
->operator == operator)
755 /*****************************************************************/
757 /* The next couple of subroutines maintain a tree used to avoid a
758 brute-force search for a combination of true name and module name.
759 While symtree names, the name that a particular symbol is known by
760 can changed with USE statements, we still have to keep track of the
761 true names to generate the correct reference, and also avoid
762 loading the same real symbol twice in a program unit.
764 When we start reading, the true name tree is built and maintained
765 as symbols are read. The tree is searched as we load new symbols
766 to see if it already exists someplace in the namespace. */
768 typedef struct true_name
770 BBT_HEADER (true_name
);
775 static true_name
*true_name_root
;
778 /* Compare two true_name structures. */
781 compare_true_names (void *_t1
, void *_t2
)
786 t1
= (true_name
*) _t1
;
787 t2
= (true_name
*) _t2
;
789 c
= ((t1
->sym
->module
> t2
->sym
->module
)
790 - (t1
->sym
->module
< t2
->sym
->module
));
794 return strcmp (t1
->sym
->name
, t2
->sym
->name
);
798 /* Given a true name, search the true name tree to see if it exists
799 within the main namespace. */
802 find_true_name (const char *name
, const char *module
)
808 sym
.name
= gfc_get_string (name
);
810 sym
.module
= gfc_get_string (module
);
818 c
= compare_true_names ((void *) (&t
), (void *) p
);
822 p
= (c
< 0) ? p
->left
: p
->right
;
829 /* Given a gfc_symbol pointer that is not in the true name tree, add it. */
832 add_true_name (gfc_symbol
*sym
)
836 t
= gfc_getmem (sizeof (true_name
));
839 gfc_insert_bbt (&true_name_root
, t
, compare_true_names
);
843 /* Recursive function to build the initial true name tree by
844 recursively traversing the current namespace. */
847 build_tnt (gfc_symtree
*st
)
852 build_tnt (st
->left
);
853 build_tnt (st
->right
);
855 if (find_true_name (st
->n
.sym
->name
, st
->n
.sym
->module
) != NULL
)
858 add_true_name (st
->n
.sym
);
862 /* Initialize the true name tree with the current namespace. */
865 init_true_name_tree (void)
867 true_name_root
= NULL
;
868 build_tnt (gfc_current_ns
->sym_root
);
872 /* Recursively free a true name tree node. */
875 free_true_name (true_name
*t
)
879 free_true_name (t
->left
);
880 free_true_name (t
->right
);
886 /*****************************************************************/
888 /* Module reading and writing. */
892 ATOM_NAME
, ATOM_LPAREN
, ATOM_RPAREN
, ATOM_INTEGER
, ATOM_STRING
896 static atom_type last_atom
;
899 /* The name buffer must be at least as long as a symbol name. Right
900 now it's not clear how we're going to store numeric constants--
901 probably as a hexadecimal string, since this will allow the exact
902 number to be preserved (this can't be done by a decimal
903 representation). Worry about that later. TODO! */
905 #define MAX_ATOM_SIZE 100
908 static char *atom_string
, atom_name
[MAX_ATOM_SIZE
];
911 /* Report problems with a module. Error reporting is not very
912 elaborate, since this sorts of errors shouldn't really happen.
913 This subroutine never returns. */
915 static void bad_module (const char *) ATTRIBUTE_NORETURN
;
918 bad_module (const char *msgid
)
925 gfc_fatal_error ("Reading module %s at line %d column %d: %s",
926 module_name
, module_line
, module_column
, msgid
);
929 gfc_fatal_error ("Writing module %s at line %d column %d: %s",
930 module_name
, module_line
, module_column
, msgid
);
933 gfc_fatal_error ("Module %s at line %d column %d: %s",
934 module_name
, module_line
, module_column
, msgid
);
940 /* Set the module's input pointer. */
943 set_module_locus (module_locus
*m
)
945 module_column
= m
->column
;
946 module_line
= m
->line
;
947 fsetpos (module_fp
, &m
->pos
);
951 /* Get the module's input pointer so that we can restore it later. */
954 get_module_locus (module_locus
*m
)
956 m
->column
= module_column
;
957 m
->line
= module_line
;
958 fgetpos (module_fp
, &m
->pos
);
962 /* Get the next character in the module, updating our reckoning of
970 c
= getc (module_fp
);
973 bad_module ("Unexpected EOF");
986 /* Parse a string constant. The delimiter is guaranteed to be a
996 get_module_locus (&start
);
1000 /* See how long the string is. */
1005 bad_module ("Unexpected end of module in string constant");
1023 set_module_locus (&start
);
1025 atom_string
= p
= gfc_getmem (len
+ 1);
1027 for (; len
> 0; len
--)
1031 module_char (); /* Guaranteed to be another \'. */
1035 module_char (); /* Terminating \'. */
1036 *p
= '\0'; /* C-style string for debug purposes. */
1040 /* Parse a small integer. */
1043 parse_integer (int c
)
1051 get_module_locus (&m
);
1057 atom_int
= 10 * atom_int
+ c
- '0';
1058 if (atom_int
> 99999999)
1059 bad_module ("Integer overflow");
1062 set_module_locus (&m
);
1080 get_module_locus (&m
);
1085 if (!ISALNUM (c
) && c
!= '_' && c
!= '-')
1089 if (++len
> GFC_MAX_SYMBOL_LEN
)
1090 bad_module ("Name too long");
1095 fseek (module_fp
, -1, SEEK_CUR
);
1096 module_column
= m
.column
+ len
- 1;
1103 /* Read the next atom in the module's input stream. */
1114 while (c
== ' ' || c
== '\n');
1139 return ATOM_INTEGER
;
1197 bad_module ("Bad name");
1204 /* Peek at the next atom on the input. */
1212 get_module_locus (&m
);
1215 if (a
== ATOM_STRING
)
1216 gfc_free (atom_string
);
1218 set_module_locus (&m
);
1223 /* Read the next atom from the input, requiring that it be a
1227 require_atom (atom_type type
)
1233 get_module_locus (&m
);
1241 p
= _("Expected name");
1244 p
= _("Expected left parenthesis");
1247 p
= _("Expected right parenthesis");
1250 p
= _("Expected integer");
1253 p
= _("Expected string");
1256 gfc_internal_error ("require_atom(): bad atom type required");
1259 set_module_locus (&m
);
1265 /* Given a pointer to an mstring array, require that the current input
1266 be one of the strings in the array. We return the enum value. */
1269 find_enum (const mstring
*m
)
1273 i
= gfc_string2code (m
, atom_name
);
1277 bad_module ("find_enum(): Enum not found");
1283 /**************** Module output subroutines ***************************/
1285 /* Output a character to a module file. */
1288 write_char (char out
)
1290 if (putc (out
, module_fp
) == EOF
)
1291 gfc_fatal_error ("Error writing modules file: %s", strerror (errno
));
1293 /* Add this to our MD5. */
1294 md5_process_bytes (&out
, sizeof (out
), &ctx
);
1306 /* Write an atom to a module. The line wrapping isn't perfect, but it
1307 should work most of the time. This isn't that big of a deal, since
1308 the file really isn't meant to be read by people anyway. */
1311 write_atom (atom_type atom
, const void *v
)
1333 i
= *((const int *) v
);
1335 gfc_internal_error ("write_atom(): Writing negative integer");
1337 sprintf (buffer
, "%d", i
);
1342 gfc_internal_error ("write_atom(): Trying to write dab atom");
1346 if(p
== NULL
|| *p
== '\0')
1351 if (atom
!= ATOM_RPAREN
)
1353 if (module_column
+ len
> 72)
1358 if (last_atom
!= ATOM_LPAREN
&& module_column
!= 1)
1363 if (atom
== ATOM_STRING
)
1366 while (p
!= NULL
&& *p
)
1368 if (atom
== ATOM_STRING
&& *p
== '\'')
1373 if (atom
== ATOM_STRING
)
1381 /***************** Mid-level I/O subroutines *****************/
1383 /* These subroutines let their caller read or write atoms without
1384 caring about which of the two is actually happening. This lets a
1385 subroutine concentrate on the actual format of the data being
1388 static void mio_expr (gfc_expr
**);
1389 static void mio_symbol_ref (gfc_symbol
**);
1390 static void mio_symtree_ref (gfc_symtree
**);
1392 /* Read or write an enumerated value. On writing, we return the input
1393 value for the convenience of callers. We avoid using an integer
1394 pointer because enums are sometimes inside bitfields. */
1397 mio_name (int t
, const mstring
*m
)
1399 if (iomode
== IO_OUTPUT
)
1400 write_atom (ATOM_NAME
, gfc_code2string (m
, t
));
1403 require_atom (ATOM_NAME
);
1410 /* Specialization of mio_name. */
1412 #define DECL_MIO_NAME(TYPE) \
1413 static inline TYPE \
1414 MIO_NAME(TYPE) (TYPE t, const mstring *m) \
1416 return (TYPE) mio_name ((int) t, m); \
1418 #define MIO_NAME(TYPE) mio_name_##TYPE
1423 if (iomode
== IO_OUTPUT
)
1424 write_atom (ATOM_LPAREN
, NULL
);
1426 require_atom (ATOM_LPAREN
);
1433 if (iomode
== IO_OUTPUT
)
1434 write_atom (ATOM_RPAREN
, NULL
);
1436 require_atom (ATOM_RPAREN
);
1441 mio_integer (int *ip
)
1443 if (iomode
== IO_OUTPUT
)
1444 write_atom (ATOM_INTEGER
, ip
);
1447 require_atom (ATOM_INTEGER
);
1453 /* Read or write a character pointer that points to a string on the heap. */
1456 mio_allocated_string (const char *s
)
1458 if (iomode
== IO_OUTPUT
)
1460 write_atom (ATOM_STRING
, s
);
1465 require_atom (ATOM_STRING
);
1471 /* Read or write a string that is in static memory. */
1474 mio_pool_string (const char **stringp
)
1476 /* TODO: one could write the string only once, and refer to it via a
1479 /* As a special case we have to deal with a NULL string. This
1480 happens for the 'module' member of 'gfc_symbol's that are not in a
1481 module. We read / write these as the empty string. */
1482 if (iomode
== IO_OUTPUT
)
1484 const char *p
= *stringp
== NULL
? "" : *stringp
;
1485 write_atom (ATOM_STRING
, p
);
1489 require_atom (ATOM_STRING
);
1490 *stringp
= atom_string
[0] == '\0' ? NULL
: gfc_get_string (atom_string
);
1491 gfc_free (atom_string
);
1496 /* Read or write a string that is inside of some already-allocated
1500 mio_internal_string (char *string
)
1502 if (iomode
== IO_OUTPUT
)
1503 write_atom (ATOM_STRING
, string
);
1506 require_atom (ATOM_STRING
);
1507 strcpy (string
, atom_string
);
1508 gfc_free (atom_string
);
1514 { AB_ALLOCATABLE
, AB_DIMENSION
, AB_EXTERNAL
, AB_INTRINSIC
, AB_OPTIONAL
,
1515 AB_POINTER
, AB_SAVE
, AB_TARGET
, AB_DUMMY
, AB_RESULT
, AB_DATA
,
1516 AB_IN_NAMELIST
, AB_IN_COMMON
, AB_FUNCTION
, AB_SUBROUTINE
, AB_SEQUENCE
,
1517 AB_ELEMENTAL
, AB_PURE
, AB_RECURSIVE
, AB_GENERIC
, AB_ALWAYS_EXPLICIT
,
1518 AB_CRAY_POINTER
, AB_CRAY_POINTEE
, AB_THREADPRIVATE
, AB_ALLOC_COMP
,
1519 AB_VALUE
, AB_VOLATILE
, AB_PROTECTED
, AB_IS_BIND_C
, AB_IS_C_INTEROP
,
1524 static const mstring attr_bits
[] =
1526 minit ("ALLOCATABLE", AB_ALLOCATABLE
),
1527 minit ("DIMENSION", AB_DIMENSION
),
1528 minit ("EXTERNAL", AB_EXTERNAL
),
1529 minit ("INTRINSIC", AB_INTRINSIC
),
1530 minit ("OPTIONAL", AB_OPTIONAL
),
1531 minit ("POINTER", AB_POINTER
),
1532 minit ("SAVE", AB_SAVE
),
1533 minit ("VOLATILE", AB_VOLATILE
),
1534 minit ("TARGET", AB_TARGET
),
1535 minit ("THREADPRIVATE", AB_THREADPRIVATE
),
1536 minit ("DUMMY", AB_DUMMY
),
1537 minit ("RESULT", AB_RESULT
),
1538 minit ("DATA", AB_DATA
),
1539 minit ("IN_NAMELIST", AB_IN_NAMELIST
),
1540 minit ("IN_COMMON", AB_IN_COMMON
),
1541 minit ("FUNCTION", AB_FUNCTION
),
1542 minit ("SUBROUTINE", AB_SUBROUTINE
),
1543 minit ("SEQUENCE", AB_SEQUENCE
),
1544 minit ("ELEMENTAL", AB_ELEMENTAL
),
1545 minit ("PURE", AB_PURE
),
1546 minit ("RECURSIVE", AB_RECURSIVE
),
1547 minit ("GENERIC", AB_GENERIC
),
1548 minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT
),
1549 minit ("CRAY_POINTER", AB_CRAY_POINTER
),
1550 minit ("CRAY_POINTEE", AB_CRAY_POINTEE
),
1551 minit ("IS_BIND_C", AB_IS_BIND_C
),
1552 minit ("IS_C_INTEROP", AB_IS_C_INTEROP
),
1553 minit ("IS_ISO_C", AB_IS_ISO_C
),
1554 minit ("VALUE", AB_VALUE
),
1555 minit ("ALLOC_COMP", AB_ALLOC_COMP
),
1556 minit ("PROTECTED", AB_PROTECTED
),
1561 /* Specialization of mio_name. */
1562 DECL_MIO_NAME (ab_attribute
)
1563 DECL_MIO_NAME (ar_type
)
1564 DECL_MIO_NAME (array_type
)
1566 DECL_MIO_NAME (expr_t
)
1567 DECL_MIO_NAME (gfc_access
)
1568 DECL_MIO_NAME (gfc_intrinsic_op
)
1569 DECL_MIO_NAME (ifsrc
)
1570 DECL_MIO_NAME (procedure_type
)
1571 DECL_MIO_NAME (ref_type
)
1572 DECL_MIO_NAME (sym_flavor
)
1573 DECL_MIO_NAME (sym_intent
)
1574 #undef DECL_MIO_NAME
1576 /* Symbol attributes are stored in list with the first three elements
1577 being the enumerated fields, while the remaining elements (if any)
1578 indicate the individual attribute bits. The access field is not
1579 saved-- it controls what symbols are exported when a module is
1583 mio_symbol_attribute (symbol_attribute
*attr
)
1589 attr
->flavor
= MIO_NAME (sym_flavor
) (attr
->flavor
, flavors
);
1590 attr
->intent
= MIO_NAME (sym_intent
) (attr
->intent
, intents
);
1591 attr
->proc
= MIO_NAME (procedure_type
) (attr
->proc
, procedures
);
1592 attr
->if_source
= MIO_NAME (ifsrc
) (attr
->if_source
, ifsrc_types
);
1594 if (iomode
== IO_OUTPUT
)
1596 if (attr
->allocatable
)
1597 MIO_NAME (ab_attribute
) (AB_ALLOCATABLE
, attr_bits
);
1598 if (attr
->dimension
)
1599 MIO_NAME (ab_attribute
) (AB_DIMENSION
, attr_bits
);
1601 MIO_NAME (ab_attribute
) (AB_EXTERNAL
, attr_bits
);
1602 if (attr
->intrinsic
)
1603 MIO_NAME (ab_attribute
) (AB_INTRINSIC
, attr_bits
);
1605 MIO_NAME (ab_attribute
) (AB_OPTIONAL
, attr_bits
);
1607 MIO_NAME (ab_attribute
) (AB_POINTER
, attr_bits
);
1608 if (attr
->protected)
1609 MIO_NAME (ab_attribute
) (AB_PROTECTED
, attr_bits
);
1611 MIO_NAME (ab_attribute
) (AB_SAVE
, attr_bits
);
1613 MIO_NAME (ab_attribute
) (AB_VALUE
, attr_bits
);
1614 if (attr
->volatile_
)
1615 MIO_NAME (ab_attribute
) (AB_VOLATILE
, attr_bits
);
1617 MIO_NAME (ab_attribute
) (AB_TARGET
, attr_bits
);
1618 if (attr
->threadprivate
)
1619 MIO_NAME (ab_attribute
) (AB_THREADPRIVATE
, attr_bits
);
1621 MIO_NAME (ab_attribute
) (AB_DUMMY
, attr_bits
);
1623 MIO_NAME (ab_attribute
) (AB_RESULT
, attr_bits
);
1624 /* We deliberately don't preserve the "entry" flag. */
1627 MIO_NAME (ab_attribute
) (AB_DATA
, attr_bits
);
1628 if (attr
->in_namelist
)
1629 MIO_NAME (ab_attribute
) (AB_IN_NAMELIST
, attr_bits
);
1630 if (attr
->in_common
)
1631 MIO_NAME (ab_attribute
) (AB_IN_COMMON
, attr_bits
);
1634 MIO_NAME (ab_attribute
) (AB_FUNCTION
, attr_bits
);
1635 if (attr
->subroutine
)
1636 MIO_NAME (ab_attribute
) (AB_SUBROUTINE
, attr_bits
);
1638 MIO_NAME (ab_attribute
) (AB_GENERIC
, attr_bits
);
1641 MIO_NAME (ab_attribute
) (AB_SEQUENCE
, attr_bits
);
1642 if (attr
->elemental
)
1643 MIO_NAME (ab_attribute
) (AB_ELEMENTAL
, attr_bits
);
1645 MIO_NAME (ab_attribute
) (AB_PURE
, attr_bits
);
1646 if (attr
->recursive
)
1647 MIO_NAME (ab_attribute
) (AB_RECURSIVE
, attr_bits
);
1648 if (attr
->always_explicit
)
1649 MIO_NAME (ab_attribute
) (AB_ALWAYS_EXPLICIT
, attr_bits
);
1650 if (attr
->cray_pointer
)
1651 MIO_NAME (ab_attribute
) (AB_CRAY_POINTER
, attr_bits
);
1652 if (attr
->cray_pointee
)
1653 MIO_NAME (ab_attribute
) (AB_CRAY_POINTEE
, attr_bits
);
1654 if (attr
->is_bind_c
)
1655 MIO_NAME(ab_attribute
) (AB_IS_BIND_C
, attr_bits
);
1656 if (attr
->is_c_interop
)
1657 MIO_NAME(ab_attribute
) (AB_IS_C_INTEROP
, attr_bits
);
1659 MIO_NAME(ab_attribute
) (AB_IS_ISO_C
, attr_bits
);
1660 if (attr
->alloc_comp
)
1661 MIO_NAME (ab_attribute
) (AB_ALLOC_COMP
, attr_bits
);
1671 if (t
== ATOM_RPAREN
)
1674 bad_module ("Expected attribute bit name");
1676 switch ((ab_attribute
) find_enum (attr_bits
))
1678 case AB_ALLOCATABLE
:
1679 attr
->allocatable
= 1;
1682 attr
->dimension
= 1;
1688 attr
->intrinsic
= 1;
1697 attr
->protected = 1;
1706 attr
->volatile_
= 1;
1711 case AB_THREADPRIVATE
:
1712 attr
->threadprivate
= 1;
1723 case AB_IN_NAMELIST
:
1724 attr
->in_namelist
= 1;
1727 attr
->in_common
= 1;
1733 attr
->subroutine
= 1;
1742 attr
->elemental
= 1;
1748 attr
->recursive
= 1;
1750 case AB_ALWAYS_EXPLICIT
:
1751 attr
->always_explicit
= 1;
1753 case AB_CRAY_POINTER
:
1754 attr
->cray_pointer
= 1;
1756 case AB_CRAY_POINTEE
:
1757 attr
->cray_pointee
= 1;
1760 attr
->is_bind_c
= 1;
1762 case AB_IS_C_INTEROP
:
1763 attr
->is_c_interop
= 1;
1769 attr
->alloc_comp
= 1;
1777 static const mstring bt_types
[] = {
1778 minit ("INTEGER", BT_INTEGER
),
1779 minit ("REAL", BT_REAL
),
1780 minit ("COMPLEX", BT_COMPLEX
),
1781 minit ("LOGICAL", BT_LOGICAL
),
1782 minit ("CHARACTER", BT_CHARACTER
),
1783 minit ("DERIVED", BT_DERIVED
),
1784 minit ("PROCEDURE", BT_PROCEDURE
),
1785 minit ("UNKNOWN", BT_UNKNOWN
),
1786 minit ("VOID", BT_VOID
),
1792 mio_charlen (gfc_charlen
**clp
)
1798 if (iomode
== IO_OUTPUT
)
1802 mio_expr (&cl
->length
);
1806 if (peek_atom () != ATOM_RPAREN
)
1808 cl
= gfc_get_charlen ();
1809 mio_expr (&cl
->length
);
1813 cl
->next
= gfc_current_ns
->cl_list
;
1814 gfc_current_ns
->cl_list
= cl
;
1822 /* Return a symtree node with a name that is guaranteed to be unique
1823 within the namespace and corresponds to an illegal fortran name. */
1825 static gfc_symtree
*
1826 get_unique_symtree (gfc_namespace
*ns
)
1828 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1829 static int serial
= 0;
1831 sprintf (name
, "@%d", serial
++);
1832 return gfc_new_symtree (&ns
->sym_root
, name
);
1836 /* See if a name is a generated name. */
1839 check_unique_name (const char *name
)
1841 return *name
== '@';
1846 mio_typespec (gfc_typespec
*ts
)
1850 ts
->type
= MIO_NAME (bt
) (ts
->type
, bt_types
);
1852 if (ts
->type
!= BT_DERIVED
)
1853 mio_integer (&ts
->kind
);
1855 mio_symbol_ref (&ts
->derived
);
1857 /* Add info for C interop and is_iso_c. */
1858 mio_integer (&ts
->is_c_interop
);
1859 mio_integer (&ts
->is_iso_c
);
1861 /* If the typespec is for an identifier either from iso_c_binding, or
1862 a constant that was initialized to an identifier from it, use the
1863 f90_type. Otherwise, use the ts->type, since it shouldn't matter. */
1865 ts
->f90_type
= MIO_NAME (bt
) (ts
->f90_type
, bt_types
);
1867 ts
->f90_type
= MIO_NAME (bt
) (ts
->type
, bt_types
);
1869 if (ts
->type
!= BT_CHARACTER
)
1871 /* ts->cl is only valid for BT_CHARACTER. */
1876 mio_charlen (&ts
->cl
);
1882 static const mstring array_spec_types
[] = {
1883 minit ("EXPLICIT", AS_EXPLICIT
),
1884 minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE
),
1885 minit ("DEFERRED", AS_DEFERRED
),
1886 minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE
),
1892 mio_array_spec (gfc_array_spec
**asp
)
1899 if (iomode
== IO_OUTPUT
)
1907 if (peek_atom () == ATOM_RPAREN
)
1913 *asp
= as
= gfc_get_array_spec ();
1916 mio_integer (&as
->rank
);
1917 as
->type
= MIO_NAME (array_type
) (as
->type
, array_spec_types
);
1919 for (i
= 0; i
< as
->rank
; i
++)
1921 mio_expr (&as
->lower
[i
]);
1922 mio_expr (&as
->upper
[i
]);
1930 /* Given a pointer to an array reference structure (which lives in a
1931 gfc_ref structure), find the corresponding array specification
1932 structure. Storing the pointer in the ref structure doesn't quite
1933 work when loading from a module. Generating code for an array
1934 reference also needs more information than just the array spec. */
1936 static const mstring array_ref_types
[] = {
1937 minit ("FULL", AR_FULL
),
1938 minit ("ELEMENT", AR_ELEMENT
),
1939 minit ("SECTION", AR_SECTION
),
1945 mio_array_ref (gfc_array_ref
*ar
)
1950 ar
->type
= MIO_NAME (ar_type
) (ar
->type
, array_ref_types
);
1951 mio_integer (&ar
->dimen
);
1959 for (i
= 0; i
< ar
->dimen
; i
++)
1960 mio_expr (&ar
->start
[i
]);
1965 for (i
= 0; i
< ar
->dimen
; i
++)
1967 mio_expr (&ar
->start
[i
]);
1968 mio_expr (&ar
->end
[i
]);
1969 mio_expr (&ar
->stride
[i
]);
1975 gfc_internal_error ("mio_array_ref(): Unknown array ref");
1978 /* Unfortunately, ar->dimen_type is an anonymous enumerated type so
1979 we can't call mio_integer directly. Instead loop over each element
1980 and cast it to/from an integer. */
1981 if (iomode
== IO_OUTPUT
)
1983 for (i
= 0; i
< ar
->dimen
; i
++)
1985 int tmp
= (int)ar
->dimen_type
[i
];
1986 write_atom (ATOM_INTEGER
, &tmp
);
1991 for (i
= 0; i
< ar
->dimen
; i
++)
1993 require_atom (ATOM_INTEGER
);
1994 ar
->dimen_type
[i
] = atom_int
;
1998 if (iomode
== IO_INPUT
)
2000 ar
->where
= gfc_current_locus
;
2002 for (i
= 0; i
< ar
->dimen
; i
++)
2003 ar
->c_where
[i
] = gfc_current_locus
;
2010 /* Saves or restores a pointer. The pointer is converted back and
2011 forth from an integer. We return the pointer_info pointer so that
2012 the caller can take additional action based on the pointer type. */
2014 static pointer_info
*
2015 mio_pointer_ref (void *gp
)
2019 if (iomode
== IO_OUTPUT
)
2021 p
= get_pointer (*((char **) gp
));
2022 write_atom (ATOM_INTEGER
, &p
->integer
);
2026 require_atom (ATOM_INTEGER
);
2027 p
= add_fixup (atom_int
, gp
);
2034 /* Save and load references to components that occur within
2035 expressions. We have to describe these references by a number and
2036 by name. The number is necessary for forward references during
2037 reading, and the name is necessary if the symbol already exists in
2038 the namespace and is not loaded again. */
2041 mio_component_ref (gfc_component
**cp
, gfc_symbol
*sym
)
2043 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2047 p
= mio_pointer_ref (cp
);
2048 if (p
->type
== P_UNKNOWN
)
2049 p
->type
= P_COMPONENT
;
2051 if (iomode
== IO_OUTPUT
)
2052 mio_pool_string (&(*cp
)->name
);
2055 mio_internal_string (name
);
2057 /* It can happen that a component reference can be read before the
2058 associated derived type symbol has been loaded. Return now and
2059 wait for a later iteration of load_needed. */
2063 if (sym
->components
!= NULL
&& p
->u
.pointer
== NULL
)
2065 /* Symbol already loaded, so search by name. */
2066 for (q
= sym
->components
; q
; q
= q
->next
)
2067 if (strcmp (q
->name
, name
) == 0)
2071 gfc_internal_error ("mio_component_ref(): Component not found");
2073 associate_integer_pointer (p
, q
);
2076 /* Make sure this symbol will eventually be loaded. */
2077 p
= find_pointer2 (sym
);
2078 if (p
->u
.rsym
.state
== UNUSED
)
2079 p
->u
.rsym
.state
= NEEDED
;
2085 mio_component (gfc_component
*c
)
2092 if (iomode
== IO_OUTPUT
)
2094 p
= get_pointer (c
);
2095 mio_integer (&p
->integer
);
2100 p
= get_integer (n
);
2101 associate_integer_pointer (p
, c
);
2104 if (p
->type
== P_UNKNOWN
)
2105 p
->type
= P_COMPONENT
;
2107 mio_pool_string (&c
->name
);
2108 mio_typespec (&c
->ts
);
2109 mio_array_spec (&c
->as
);
2111 mio_integer (&c
->dimension
);
2112 mio_integer (&c
->pointer
);
2113 mio_integer (&c
->allocatable
);
2114 c
->access
= MIO_NAME (gfc_access
) (c
->access
, access_types
);
2116 mio_expr (&c
->initializer
);
2122 mio_component_list (gfc_component
**cp
)
2124 gfc_component
*c
, *tail
;
2128 if (iomode
== IO_OUTPUT
)
2130 for (c
= *cp
; c
; c
= c
->next
)
2140 if (peek_atom () == ATOM_RPAREN
)
2143 c
= gfc_get_component ();
2160 mio_actual_arg (gfc_actual_arglist
*a
)
2163 mio_pool_string (&a
->name
);
2164 mio_expr (&a
->expr
);
2170 mio_actual_arglist (gfc_actual_arglist
**ap
)
2172 gfc_actual_arglist
*a
, *tail
;
2176 if (iomode
== IO_OUTPUT
)
2178 for (a
= *ap
; a
; a
= a
->next
)
2188 if (peek_atom () != ATOM_LPAREN
)
2191 a
= gfc_get_actual_arglist ();
2207 /* Read and write formal argument lists. */
2210 mio_formal_arglist (gfc_symbol
*sym
)
2212 gfc_formal_arglist
*f
, *tail
;
2216 if (iomode
== IO_OUTPUT
)
2218 for (f
= sym
->formal
; f
; f
= f
->next
)
2219 mio_symbol_ref (&f
->sym
);
2223 sym
->formal
= tail
= NULL
;
2225 while (peek_atom () != ATOM_RPAREN
)
2227 f
= gfc_get_formal_arglist ();
2228 mio_symbol_ref (&f
->sym
);
2230 if (sym
->formal
== NULL
)
2243 /* Save or restore a reference to a symbol node. */
2246 mio_symbol_ref (gfc_symbol
**symp
)
2250 p
= mio_pointer_ref (symp
);
2251 if (p
->type
== P_UNKNOWN
)
2254 if (iomode
== IO_OUTPUT
)
2256 if (p
->u
.wsym
.state
== UNREFERENCED
)
2257 p
->u
.wsym
.state
= NEEDS_WRITE
;
2261 if (p
->u
.rsym
.state
== UNUSED
)
2262 p
->u
.rsym
.state
= NEEDED
;
2267 /* Save or restore a reference to a symtree node. */
2270 mio_symtree_ref (gfc_symtree
**stp
)
2275 if (iomode
== IO_OUTPUT
)
2276 mio_symbol_ref (&(*stp
)->n
.sym
);
2279 require_atom (ATOM_INTEGER
);
2280 p
= get_integer (atom_int
);
2282 /* An unused equivalence member; make a symbol and a symtree
2284 if (in_load_equiv
&& p
->u
.rsym
.symtree
== NULL
)
2286 /* Since this is not used, it must have a unique name. */
2287 p
->u
.rsym
.symtree
= get_unique_symtree (gfc_current_ns
);
2289 /* Make the symbol. */
2290 if (p
->u
.rsym
.sym
== NULL
)
2292 p
->u
.rsym
.sym
= gfc_new_symbol (p
->u
.rsym
.true_name
,
2294 p
->u
.rsym
.sym
->module
= gfc_get_string (p
->u
.rsym
.module
);
2297 p
->u
.rsym
.symtree
->n
.sym
= p
->u
.rsym
.sym
;
2298 p
->u
.rsym
.symtree
->n
.sym
->refs
++;
2299 p
->u
.rsym
.referenced
= 1;
2302 if (p
->type
== P_UNKNOWN
)
2305 if (p
->u
.rsym
.state
== UNUSED
)
2306 p
->u
.rsym
.state
= NEEDED
;
2308 if (p
->u
.rsym
.symtree
!= NULL
)
2310 *stp
= p
->u
.rsym
.symtree
;
2314 f
= gfc_getmem (sizeof (fixup_t
));
2316 f
->next
= p
->u
.rsym
.stfixup
;
2317 p
->u
.rsym
.stfixup
= f
;
2319 f
->pointer
= (void **) stp
;
2326 mio_iterator (gfc_iterator
**ip
)
2332 if (iomode
== IO_OUTPUT
)
2339 if (peek_atom () == ATOM_RPAREN
)
2345 *ip
= gfc_get_iterator ();
2350 mio_expr (&iter
->var
);
2351 mio_expr (&iter
->start
);
2352 mio_expr (&iter
->end
);
2353 mio_expr (&iter
->step
);
2361 mio_constructor (gfc_constructor
**cp
)
2363 gfc_constructor
*c
, *tail
;
2367 if (iomode
== IO_OUTPUT
)
2369 for (c
= *cp
; c
; c
= c
->next
)
2372 mio_expr (&c
->expr
);
2373 mio_iterator (&c
->iterator
);
2382 while (peek_atom () != ATOM_RPAREN
)
2384 c
= gfc_get_constructor ();
2394 mio_expr (&c
->expr
);
2395 mio_iterator (&c
->iterator
);
2404 static const mstring ref_types
[] = {
2405 minit ("ARRAY", REF_ARRAY
),
2406 minit ("COMPONENT", REF_COMPONENT
),
2407 minit ("SUBSTRING", REF_SUBSTRING
),
2413 mio_ref (gfc_ref
**rp
)
2420 r
->type
= MIO_NAME (ref_type
) (r
->type
, ref_types
);
2425 mio_array_ref (&r
->u
.ar
);
2429 mio_symbol_ref (&r
->u
.c
.sym
);
2430 mio_component_ref (&r
->u
.c
.component
, r
->u
.c
.sym
);
2434 mio_expr (&r
->u
.ss
.start
);
2435 mio_expr (&r
->u
.ss
.end
);
2436 mio_charlen (&r
->u
.ss
.length
);
2445 mio_ref_list (gfc_ref
**rp
)
2447 gfc_ref
*ref
, *head
, *tail
;
2451 if (iomode
== IO_OUTPUT
)
2453 for (ref
= *rp
; ref
; ref
= ref
->next
)
2460 while (peek_atom () != ATOM_RPAREN
)
2463 head
= tail
= gfc_get_ref ();
2466 tail
->next
= gfc_get_ref ();
2480 /* Read and write an integer value. */
2483 mio_gmp_integer (mpz_t
*integer
)
2487 if (iomode
== IO_INPUT
)
2489 if (parse_atom () != ATOM_STRING
)
2490 bad_module ("Expected integer string");
2492 mpz_init (*integer
);
2493 if (mpz_set_str (*integer
, atom_string
, 10))
2494 bad_module ("Error converting integer");
2496 gfc_free (atom_string
);
2500 p
= mpz_get_str (NULL
, 10, *integer
);
2501 write_atom (ATOM_STRING
, p
);
2508 mio_gmp_real (mpfr_t
*real
)
2513 if (iomode
== IO_INPUT
)
2515 if (parse_atom () != ATOM_STRING
)
2516 bad_module ("Expected real string");
2519 mpfr_set_str (*real
, atom_string
, 16, GFC_RND_MODE
);
2520 gfc_free (atom_string
);
2524 p
= mpfr_get_str (NULL
, &exponent
, 16, 0, *real
, GFC_RND_MODE
);
2525 atom_string
= gfc_getmem (strlen (p
) + 20);
2527 sprintf (atom_string
, "0.%s@%ld", p
, exponent
);
2529 /* Fix negative numbers. */
2530 if (atom_string
[2] == '-')
2532 atom_string
[0] = '-';
2533 atom_string
[1] = '0';
2534 atom_string
[2] = '.';
2537 write_atom (ATOM_STRING
, atom_string
);
2539 gfc_free (atom_string
);
2545 /* Save and restore the shape of an array constructor. */
2548 mio_shape (mpz_t
**pshape
, int rank
)
2554 /* A NULL shape is represented by (). */
2557 if (iomode
== IO_OUTPUT
)
2569 if (t
== ATOM_RPAREN
)
2576 shape
= gfc_get_shape (rank
);
2580 for (n
= 0; n
< rank
; n
++)
2581 mio_gmp_integer (&shape
[n
]);
2587 static const mstring expr_types
[] = {
2588 minit ("OP", EXPR_OP
),
2589 minit ("FUNCTION", EXPR_FUNCTION
),
2590 minit ("CONSTANT", EXPR_CONSTANT
),
2591 minit ("VARIABLE", EXPR_VARIABLE
),
2592 minit ("SUBSTRING", EXPR_SUBSTRING
),
2593 minit ("STRUCTURE", EXPR_STRUCTURE
),
2594 minit ("ARRAY", EXPR_ARRAY
),
2595 minit ("NULL", EXPR_NULL
),
2599 /* INTRINSIC_ASSIGN is missing because it is used as an index for
2600 generic operators, not in expressions. INTRINSIC_USER is also
2601 replaced by the correct function name by the time we see it. */
2603 static const mstring intrinsics
[] =
2605 minit ("UPLUS", INTRINSIC_UPLUS
),
2606 minit ("UMINUS", INTRINSIC_UMINUS
),
2607 minit ("PLUS", INTRINSIC_PLUS
),
2608 minit ("MINUS", INTRINSIC_MINUS
),
2609 minit ("TIMES", INTRINSIC_TIMES
),
2610 minit ("DIVIDE", INTRINSIC_DIVIDE
),
2611 minit ("POWER", INTRINSIC_POWER
),
2612 minit ("CONCAT", INTRINSIC_CONCAT
),
2613 minit ("AND", INTRINSIC_AND
),
2614 minit ("OR", INTRINSIC_OR
),
2615 minit ("EQV", INTRINSIC_EQV
),
2616 minit ("NEQV", INTRINSIC_NEQV
),
2617 minit ("EQ", INTRINSIC_EQ
),
2618 minit ("NE", INTRINSIC_NE
),
2619 minit ("GT", INTRINSIC_GT
),
2620 minit ("GE", INTRINSIC_GE
),
2621 minit ("LT", INTRINSIC_LT
),
2622 minit ("LE", INTRINSIC_LE
),
2623 minit ("NOT", INTRINSIC_NOT
),
2624 minit ("PARENTHESES", INTRINSIC_PARENTHESES
),
2629 /* Remedy a couple of situations where the gfc_expr's can be defective. */
2632 fix_mio_expr (gfc_expr
*e
)
2634 gfc_symtree
*ns_st
= NULL
;
2637 if (iomode
!= IO_OUTPUT
)
2642 /* If this is a symtree for a symbol that came from a contained module
2643 namespace, it has a unique name and we should look in the current
2644 namespace to see if the required, non-contained symbol is available
2645 yet. If so, the latter should be written. */
2646 if (e
->symtree
->n
.sym
&& check_unique_name (e
->symtree
->name
))
2647 ns_st
= gfc_find_symtree (gfc_current_ns
->sym_root
,
2648 e
->symtree
->n
.sym
->name
);
2650 /* On the other hand, if the existing symbol is the module name or the
2651 new symbol is a dummy argument, do not do the promotion. */
2652 if (ns_st
&& ns_st
->n
.sym
2653 && ns_st
->n
.sym
->attr
.flavor
!= FL_MODULE
2654 && !e
->symtree
->n
.sym
->attr
.dummy
)
2657 else if (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.name
)
2659 /* In some circumstances, a function used in an initialization
2660 expression, in one use associated module, can fail to be
2661 coupled to its symtree when used in a specification
2662 expression in another module. */
2663 fname
= e
->value
.function
.esym
? e
->value
.function
.esym
->name
2664 : e
->value
.function
.isym
->name
;
2665 e
->symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, fname
);
2670 /* Read and write expressions. The form "()" is allowed to indicate a
2674 mio_expr (gfc_expr
**ep
)
2682 if (iomode
== IO_OUTPUT
)
2691 MIO_NAME (expr_t
) (e
->expr_type
, expr_types
);
2696 if (t
== ATOM_RPAREN
)
2703 bad_module ("Expected expression type");
2705 e
= *ep
= gfc_get_expr ();
2706 e
->where
= gfc_current_locus
;
2707 e
->expr_type
= (expr_t
) find_enum (expr_types
);
2710 mio_typespec (&e
->ts
);
2711 mio_integer (&e
->rank
);
2715 switch (e
->expr_type
)
2718 e
->value
.op
.operator
2719 = MIO_NAME (gfc_intrinsic_op
) (e
->value
.op
.operator, intrinsics
);
2721 switch (e
->value
.op
.operator)
2723 case INTRINSIC_UPLUS
:
2724 case INTRINSIC_UMINUS
:
2726 case INTRINSIC_PARENTHESES
:
2727 mio_expr (&e
->value
.op
.op1
);
2730 case INTRINSIC_PLUS
:
2731 case INTRINSIC_MINUS
:
2732 case INTRINSIC_TIMES
:
2733 case INTRINSIC_DIVIDE
:
2734 case INTRINSIC_POWER
:
2735 case INTRINSIC_CONCAT
:
2739 case INTRINSIC_NEQV
:
2746 mio_expr (&e
->value
.op
.op1
);
2747 mio_expr (&e
->value
.op
.op2
);
2751 bad_module ("Bad operator");
2757 mio_symtree_ref (&e
->symtree
);
2758 mio_actual_arglist (&e
->value
.function
.actual
);
2760 if (iomode
== IO_OUTPUT
)
2762 e
->value
.function
.name
2763 = mio_allocated_string (e
->value
.function
.name
);
2764 flag
= e
->value
.function
.esym
!= NULL
;
2765 mio_integer (&flag
);
2767 mio_symbol_ref (&e
->value
.function
.esym
);
2769 write_atom (ATOM_STRING
, e
->value
.function
.isym
->name
);
2773 require_atom (ATOM_STRING
);
2774 e
->value
.function
.name
= gfc_get_string (atom_string
);
2775 gfc_free (atom_string
);
2777 mio_integer (&flag
);
2779 mio_symbol_ref (&e
->value
.function
.esym
);
2782 require_atom (ATOM_STRING
);
2783 e
->value
.function
.isym
= gfc_find_function (atom_string
);
2784 gfc_free (atom_string
);
2791 mio_symtree_ref (&e
->symtree
);
2792 mio_ref_list (&e
->ref
);
2795 case EXPR_SUBSTRING
:
2796 e
->value
.character
.string
2797 = (char *) mio_allocated_string (e
->value
.character
.string
);
2798 mio_ref_list (&e
->ref
);
2801 case EXPR_STRUCTURE
:
2803 mio_constructor (&e
->value
.constructor
);
2804 mio_shape (&e
->shape
, e
->rank
);
2811 mio_gmp_integer (&e
->value
.integer
);
2815 gfc_set_model_kind (e
->ts
.kind
);
2816 mio_gmp_real (&e
->value
.real
);
2820 gfc_set_model_kind (e
->ts
.kind
);
2821 mio_gmp_real (&e
->value
.complex.r
);
2822 mio_gmp_real (&e
->value
.complex.i
);
2826 mio_integer (&e
->value
.logical
);
2830 mio_integer (&e
->value
.character
.length
);
2831 e
->value
.character
.string
2832 = (char *) mio_allocated_string (e
->value
.character
.string
);
2836 bad_module ("Bad type in constant expression");
2849 /* Read and write namelists. */
2852 mio_namelist (gfc_symbol
*sym
)
2854 gfc_namelist
*n
, *m
;
2855 const char *check_name
;
2859 if (iomode
== IO_OUTPUT
)
2861 for (n
= sym
->namelist
; n
; n
= n
->next
)
2862 mio_symbol_ref (&n
->sym
);
2866 /* This departure from the standard is flagged as an error.
2867 It does, in fact, work correctly. TODO: Allow it
2869 if (sym
->attr
.flavor
== FL_NAMELIST
)
2871 check_name
= find_use_name (sym
->name
);
2872 if (check_name
&& strcmp (check_name
, sym
->name
) != 0)
2873 gfc_error ("Namelist %s cannot be renamed by USE "
2874 "association to %s", sym
->name
, check_name
);
2878 while (peek_atom () != ATOM_RPAREN
)
2880 n
= gfc_get_namelist ();
2881 mio_symbol_ref (&n
->sym
);
2883 if (sym
->namelist
== NULL
)
2890 sym
->namelist_tail
= m
;
2897 /* Save/restore lists of gfc_interface stuctures. When loading an
2898 interface, we are really appending to the existing list of
2899 interfaces. Checking for duplicate and ambiguous interfaces has to
2900 be done later when all symbols have been loaded. */
2903 mio_interface_rest (gfc_interface
**ip
)
2905 gfc_interface
*tail
, *p
;
2907 if (iomode
== IO_OUTPUT
)
2910 for (p
= *ip
; p
; p
= p
->next
)
2911 mio_symbol_ref (&p
->sym
);
2926 if (peek_atom () == ATOM_RPAREN
)
2929 p
= gfc_get_interface ();
2930 p
->where
= gfc_current_locus
;
2931 mio_symbol_ref (&p
->sym
);
2946 /* Save/restore a nameless operator interface. */
2949 mio_interface (gfc_interface
**ip
)
2952 mio_interface_rest (ip
);
2956 /* Save/restore a named operator interface. */
2959 mio_symbol_interface (const char **name
, const char **module
,
2963 mio_pool_string (name
);
2964 mio_pool_string (module
);
2965 mio_interface_rest (ip
);
2970 mio_namespace_ref (gfc_namespace
**nsp
)
2975 p
= mio_pointer_ref (nsp
);
2977 if (p
->type
== P_UNKNOWN
)
2978 p
->type
= P_NAMESPACE
;
2980 if (iomode
== IO_INPUT
&& p
->integer
!= 0)
2982 ns
= (gfc_namespace
*) p
->u
.pointer
;
2985 ns
= gfc_get_namespace (NULL
, 0);
2986 associate_integer_pointer (p
, ns
);
2994 /* Unlike most other routines, the address of the symbol node is already
2995 fixed on input and the name/module has already been filled in. */
2998 mio_symbol (gfc_symbol
*sym
)
3000 int intmod
= INTMOD_NONE
;
3002 gfc_formal_arglist
*formal
;
3006 mio_symbol_attribute (&sym
->attr
);
3007 mio_typespec (&sym
->ts
);
3009 /* Contained procedures don't have formal namespaces. Instead we output the
3010 procedure namespace. The will contain the formal arguments. */
3011 if (iomode
== IO_OUTPUT
)
3013 formal
= sym
->formal
;
3014 while (formal
&& !formal
->sym
)
3015 formal
= formal
->next
;
3018 mio_namespace_ref (&formal
->sym
->ns
);
3020 mio_namespace_ref (&sym
->formal_ns
);
3024 mio_namespace_ref (&sym
->formal_ns
);
3027 sym
->formal_ns
->proc_name
= sym
;
3032 /* Save/restore common block links. */
3033 mio_symbol_ref (&sym
->common_next
);
3035 mio_formal_arglist (sym
);
3037 if (sym
->attr
.flavor
== FL_PARAMETER
)
3038 mio_expr (&sym
->value
);
3040 mio_array_spec (&sym
->as
);
3042 mio_symbol_ref (&sym
->result
);
3044 if (sym
->attr
.cray_pointee
)
3045 mio_symbol_ref (&sym
->cp_pointer
);
3047 /* Note that components are always saved, even if they are supposed
3048 to be private. Component access is checked during searching. */
3050 mio_component_list (&sym
->components
);
3052 if (sym
->components
!= NULL
)
3053 sym
->component_access
3054 = MIO_NAME (gfc_access
) (sym
->component_access
, access_types
);
3058 /* Add the fields that say whether this is from an intrinsic module,
3059 and if so, what symbol it is within the module. */
3060 /* mio_integer (&(sym->from_intmod)); */
3061 if (iomode
== IO_OUTPUT
)
3063 intmod
= sym
->from_intmod
;
3064 mio_integer (&intmod
);
3068 mio_integer (&intmod
);
3069 sym
->from_intmod
= intmod
;
3072 mio_integer (&(sym
->intmod_sym_id
));
3078 /************************* Top level subroutines *************************/
3080 /* Skip a list between balanced left and right parens. */
3090 switch (parse_atom ())
3101 gfc_free (atom_string
);
3113 /* Load operator interfaces from the module. Interfaces are unusual
3114 in that they attach themselves to existing symbols. */
3117 load_operator_interfaces (void)
3120 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[GFC_MAX_SYMBOL_LEN
+ 1];
3125 while (peek_atom () != ATOM_RPAREN
)
3129 mio_internal_string (name
);
3130 mio_internal_string (module
);
3132 /* Decide if we need to load this one or not. */
3133 p
= find_use_name (name
);
3136 while (parse_atom () != ATOM_RPAREN
);
3140 uop
= gfc_get_uop (p
);
3141 mio_interface_rest (&uop
->operator);
3149 /* Load interfaces from the module. Interfaces are unusual in that
3150 they attach themselves to existing symbols. */
3153 load_generic_interfaces (void)
3156 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[GFC_MAX_SYMBOL_LEN
+ 1];
3158 gfc_interface
*generic
= NULL
;
3163 while (peek_atom () != ATOM_RPAREN
)
3167 mio_internal_string (name
);
3168 mio_internal_string (module
);
3170 n
= number_use_names (name
);
3173 for (i
= 1; i
<= n
; i
++)
3175 /* Decide if we need to load this one or not. */
3176 p
= find_use_name_n (name
, &i
);
3178 if (p
== NULL
|| gfc_find_symbol (p
, NULL
, 0, &sym
))
3180 while (parse_atom () != ATOM_RPAREN
);
3186 gfc_get_symbol (p
, NULL
, &sym
);
3188 sym
->attr
.flavor
= FL_PROCEDURE
;
3189 sym
->attr
.generic
= 1;
3190 sym
->attr
.use_assoc
= 1;
3194 /* Unless sym is a generic interface, this reference
3198 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
3199 if (!sym
->attr
.generic
3200 && sym
->module
!= NULL
3201 && strcmp(module
, sym
->module
) != 0)
3206 mio_interface_rest (&sym
->generic
);
3207 generic
= sym
->generic
;
3211 sym
->generic
= generic
;
3212 sym
->attr
.generic_copy
= 1;
3221 /* Load common blocks. */
3226 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3231 while (peek_atom () != ATOM_RPAREN
)
3235 mio_internal_string (name
);
3237 p
= gfc_get_common (name
, 1);
3239 mio_symbol_ref (&p
->head
);
3240 mio_integer (&flags
);
3244 p
->threadprivate
= 1;
3247 /* Get whether this was a bind(c) common or not. */
3248 mio_integer (&p
->is_bind_c
);
3249 /* Get the binding label. */
3250 mio_internal_string (p
->binding_label
);
3259 /* Load equivalences. The flag in_load_equiv informs mio_expr_ref of this
3260 so that unused variables are not loaded and so that the expression can
3266 gfc_equiv
*head
, *tail
, *end
, *eq
;
3270 in_load_equiv
= true;
3272 end
= gfc_current_ns
->equiv
;
3273 while (end
!= NULL
&& end
->next
!= NULL
)
3276 while (peek_atom () != ATOM_RPAREN
) {
3280 while(peek_atom () != ATOM_RPAREN
)
3283 head
= tail
= gfc_get_equiv ();
3286 tail
->eq
= gfc_get_equiv ();
3290 mio_pool_string (&tail
->module
);
3291 mio_expr (&tail
->expr
);
3294 /* Unused equivalence members have a unique name. */
3296 for (eq
= head
; eq
; eq
= eq
->eq
)
3298 if (!check_unique_name (eq
->expr
->symtree
->name
))
3307 for (eq
= head
; eq
; eq
= head
)
3310 gfc_free_expr (eq
->expr
);
3316 gfc_current_ns
->equiv
= head
;
3327 in_load_equiv
= false;
3331 /* Recursive function to traverse the pointer_info tree and load a
3332 needed symbol. We return nonzero if we load a symbol and stop the
3333 traversal, because the act of loading can alter the tree. */
3336 load_needed (pointer_info
*p
)
3347 rv
|= load_needed (p
->left
);
3348 rv
|= load_needed (p
->right
);
3350 if (p
->type
!= P_SYMBOL
|| p
->u
.rsym
.state
!= NEEDED
)
3353 p
->u
.rsym
.state
= USED
;
3355 set_module_locus (&p
->u
.rsym
.where
);
3357 sym
= p
->u
.rsym
.sym
;
3360 q
= get_integer (p
->u
.rsym
.ns
);
3362 ns
= (gfc_namespace
*) q
->u
.pointer
;
3365 /* Create an interface namespace if necessary. These are
3366 the namespaces that hold the formal parameters of module
3369 ns
= gfc_get_namespace (NULL
, 0);
3370 associate_integer_pointer (q
, ns
);
3373 sym
= gfc_new_symbol (p
->u
.rsym
.true_name
, ns
);
3374 sym
->module
= gfc_get_string (p
->u
.rsym
.module
);
3376 associate_integer_pointer (p
, sym
);
3380 sym
->attr
.use_assoc
= 1;
3382 sym
->attr
.use_only
= 1;
3388 /* Recursive function for cleaning up things after a module has been read. */
3391 read_cleanup (pointer_info
*p
)
3399 read_cleanup (p
->left
);
3400 read_cleanup (p
->right
);
3402 if (p
->type
== P_SYMBOL
&& p
->u
.rsym
.state
== USED
&& !p
->u
.rsym
.referenced
)
3404 /* Add hidden symbols to the symtree. */
3405 q
= get_integer (p
->u
.rsym
.ns
);
3406 st
= get_unique_symtree ((gfc_namespace
*) q
->u
.pointer
);
3408 st
->n
.sym
= p
->u
.rsym
.sym
;
3411 /* Fixup any symtree references. */
3412 p
->u
.rsym
.symtree
= st
;
3413 resolve_fixups (p
->u
.rsym
.stfixup
, st
);
3414 p
->u
.rsym
.stfixup
= NULL
;
3417 /* Free unused symbols. */
3418 if (p
->type
== P_SYMBOL
&& p
->u
.rsym
.state
== UNUSED
)
3419 gfc_free_symbol (p
->u
.rsym
.sym
);
3423 /* Given a root symtree node and a symbol, try to find a symtree that
3424 references the symbol that is not a unique name. */
3426 static gfc_symtree
*
3427 find_symtree_for_symbol (gfc_symtree
*st
, gfc_symbol
*sym
)
3429 gfc_symtree
*s
= NULL
;
3434 s
= find_symtree_for_symbol (st
->right
, sym
);
3437 s
= find_symtree_for_symbol (st
->left
, sym
);
3441 if (st
->n
.sym
== sym
&& !check_unique_name (st
->name
))
3448 /* Read a module file. */
3453 module_locus operator_interfaces
, user_operators
;
3455 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3457 int ambiguous
, j
, nuse
, symbol
;
3458 pointer_info
*info
, *q
;
3463 get_module_locus (&operator_interfaces
); /* Skip these for now. */
3466 get_module_locus (&user_operators
);
3470 /* Skip commons and equivalences for now. */
3476 /* Create the fixup nodes for all the symbols. */
3478 while (peek_atom () != ATOM_RPAREN
)
3480 require_atom (ATOM_INTEGER
);
3481 info
= get_integer (atom_int
);
3483 info
->type
= P_SYMBOL
;
3484 info
->u
.rsym
.state
= UNUSED
;
3486 mio_internal_string (info
->u
.rsym
.true_name
);
3487 mio_internal_string (info
->u
.rsym
.module
);
3488 mio_internal_string (info
->u
.rsym
.binding_label
);
3491 require_atom (ATOM_INTEGER
);
3492 info
->u
.rsym
.ns
= atom_int
;
3494 get_module_locus (&info
->u
.rsym
.where
);
3497 /* See if the symbol has already been loaded by a previous module.
3498 If so, we reference the existing symbol and prevent it from
3499 being loaded again. This should not happen if the symbol being
3500 read is an index for an assumed shape dummy array (ns != 1). */
3502 sym
= find_true_name (info
->u
.rsym
.true_name
, info
->u
.rsym
.module
);
3505 || (sym
->attr
.flavor
== FL_VARIABLE
&& info
->u
.rsym
.ns
!=1))
3508 info
->u
.rsym
.state
= USED
;
3509 info
->u
.rsym
.sym
= sym
;
3511 /* Some symbols do not have a namespace (eg. formal arguments),
3512 so the automatic "unique symtree" mechanism must be suppressed
3513 by marking them as referenced. */
3514 q
= get_integer (info
->u
.rsym
.ns
);
3515 if (q
->u
.pointer
== NULL
)
3517 info
->u
.rsym
.referenced
= 1;
3521 /* If possible recycle the symtree that references the symbol.
3522 If a symtree is not found and the module does not import one,
3523 a unique-name symtree is found by read_cleanup. */
3524 st
= find_symtree_for_symbol (gfc_current_ns
->sym_root
, sym
);
3527 info
->u
.rsym
.symtree
= st
;
3528 info
->u
.rsym
.referenced
= 1;
3534 /* Parse the symtree lists. This lets us mark which symbols need to
3535 be loaded. Renaming is also done at this point by replacing the
3540 while (peek_atom () != ATOM_RPAREN
)
3542 mio_internal_string (name
);
3543 mio_integer (&ambiguous
);
3544 mio_integer (&symbol
);
3546 info
= get_integer (symbol
);
3548 /* See how many use names there are. If none, go through the start
3549 of the loop at least once. */
3550 nuse
= number_use_names (name
);
3554 for (j
= 1; j
<= nuse
; j
++)
3556 /* Get the jth local name for this symbol. */
3557 p
= find_use_name_n (name
, &j
);
3559 if (p
== NULL
&& strcmp (name
, module_name
) == 0)
3562 /* Skip symtree nodes not in an ONLY clause, unless there
3563 is an existing symtree loaded from another USE statement. */
3566 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
3568 info
->u
.rsym
.symtree
= st
;
3572 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
3576 /* Check for ambiguous symbols. */
3577 if (st
->n
.sym
!= info
->u
.rsym
.sym
)
3579 info
->u
.rsym
.symtree
= st
;
3583 /* Create a symtree node in the current namespace for this
3585 st
= check_unique_name (p
)
3586 ? get_unique_symtree (gfc_current_ns
)
3587 : gfc_new_symtree (&gfc_current_ns
->sym_root
, p
);
3589 st
->ambiguous
= ambiguous
;
3591 sym
= info
->u
.rsym
.sym
;
3593 /* Create a symbol node if it doesn't already exist. */
3596 info
->u
.rsym
.sym
= gfc_new_symbol (info
->u
.rsym
.true_name
,
3598 sym
= info
->u
.rsym
.sym
;
3599 sym
->module
= gfc_get_string (info
->u
.rsym
.module
);
3601 /* TODO: hmm, can we test this? Do we know it will be
3602 initialized to zeros? */
3603 if (info
->u
.rsym
.binding_label
[0] != '\0')
3604 strcpy (sym
->binding_label
, info
->u
.rsym
.binding_label
);
3610 /* Store the symtree pointing to this symbol. */
3611 info
->u
.rsym
.symtree
= st
;
3613 if (info
->u
.rsym
.state
== UNUSED
)
3614 info
->u
.rsym
.state
= NEEDED
;
3615 info
->u
.rsym
.referenced
= 1;
3622 /* Load intrinsic operator interfaces. */
3623 set_module_locus (&operator_interfaces
);
3626 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
3628 if (i
== INTRINSIC_USER
)
3633 u
= find_use_operator (i
);
3644 mio_interface (&gfc_current_ns
->operator[i
]);
3649 /* Load generic and user operator interfaces. These must follow the
3650 loading of symtree because otherwise symbols can be marked as
3653 set_module_locus (&user_operators
);
3655 load_operator_interfaces ();
3656 load_generic_interfaces ();
3661 /* At this point, we read those symbols that are needed but haven't
3662 been loaded yet. If one symbol requires another, the other gets
3663 marked as NEEDED if its previous state was UNUSED. */
3665 while (load_needed (pi_root
));
3667 /* Make sure all elements of the rename-list were found in the module. */
3669 for (u
= gfc_rename_list
; u
; u
= u
->next
)
3674 if (u
->operator == INTRINSIC_NONE
)
3676 gfc_error ("Symbol '%s' referenced at %L not found in module '%s'",
3677 u
->use_name
, &u
->where
, module_name
);
3681 if (u
->operator == INTRINSIC_USER
)
3683 gfc_error ("User operator '%s' referenced at %L not found "
3684 "in module '%s'", u
->use_name
, &u
->where
, module_name
);
3688 gfc_error ("Intrinsic operator '%s' referenced at %L not found "
3689 "in module '%s'", gfc_op2string (u
->operator), &u
->where
,
3693 gfc_check_interfaces (gfc_current_ns
);
3695 /* Clean up symbol nodes that were never loaded, create references
3696 to hidden symbols. */
3698 read_cleanup (pi_root
);
3702 /* Given an access type that is specific to an entity and the default
3703 access, return nonzero if the entity is publicly accessible. If the
3704 element is declared as PUBLIC, then it is public; if declared
3705 PRIVATE, then private, and otherwise it is public unless the default
3706 access in this context has been declared PRIVATE. */
3709 gfc_check_access (gfc_access specific_access
, gfc_access default_access
)
3711 if (specific_access
== ACCESS_PUBLIC
)
3713 if (specific_access
== ACCESS_PRIVATE
)
3716 return default_access
!= ACCESS_PRIVATE
;
3720 /* Write a common block to the module. */
3723 write_common (gfc_symtree
*st
)
3733 write_common (st
->left
);
3734 write_common (st
->right
);
3738 /* Write the unmangled name. */
3739 name
= st
->n
.common
->name
;
3741 mio_pool_string (&name
);
3744 mio_symbol_ref (&p
->head
);
3745 flags
= p
->saved
? 1 : 0;
3746 if (p
->threadprivate
) flags
|= 2;
3747 mio_integer (&flags
);
3749 /* Write out whether the common block is bind(c) or not. */
3750 mio_integer (&(p
->is_bind_c
));
3752 /* Write out the binding label, or the com name if no label given. */
3755 label
= p
->binding_label
;
3756 mio_pool_string (&label
);
3761 mio_pool_string (&label
);
3768 /* Write the blank common block to the module. */
3771 write_blank_common (void)
3773 const char * name
= BLANK_COMMON_NAME
;
3775 /* TODO: Blank commons are not bind(c). The F2003 standard probably says
3776 this, but it hasn't been checked. Just making it so for now. */
3779 if (gfc_current_ns
->blank_common
.head
== NULL
)
3784 mio_pool_string (&name
);
3786 mio_symbol_ref (&gfc_current_ns
->blank_common
.head
);
3787 saved
= gfc_current_ns
->blank_common
.saved
;
3788 mio_integer (&saved
);
3790 /* Write out whether the common block is bind(c) or not. */
3791 mio_integer (&is_bind_c
);
3793 /* Write out the binding label, which is BLANK_COMMON_NAME, though
3794 it doesn't matter because the label isn't used. */
3795 mio_pool_string (&name
);
3801 /* Write equivalences to the module. */
3810 for (eq
= gfc_current_ns
->equiv
; eq
; eq
= eq
->next
)
3814 for (e
= eq
; e
; e
= e
->eq
)
3816 if (e
->module
== NULL
)
3817 e
->module
= gfc_get_string ("%s.eq.%d", module_name
, num
);
3818 mio_allocated_string (e
->module
);
3819 mio_expr (&e
->expr
);
3828 /* Write a symbol to the module. */
3831 write_symbol (int n
, gfc_symbol
*sym
)
3835 if (sym
->attr
.flavor
== FL_UNKNOWN
|| sym
->attr
.flavor
== FL_LABEL
)
3836 gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym
->name
);
3839 mio_pool_string (&sym
->name
);
3841 mio_pool_string (&sym
->module
);
3842 if (sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
)
3844 label
= sym
->binding_label
;
3845 mio_pool_string (&label
);
3848 mio_pool_string (&sym
->name
);
3850 mio_pointer_ref (&sym
->ns
);
3857 /* Recursive traversal function to write the initial set of symbols to
3858 the module. We check to see if the symbol should be written
3859 according to the access specification. */
3862 write_symbol0 (gfc_symtree
*st
)
3870 write_symbol0 (st
->left
);
3871 write_symbol0 (st
->right
);
3874 if (sym
->module
== NULL
)
3875 sym
->module
= gfc_get_string (module_name
);
3877 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
3878 && !sym
->attr
.subroutine
&& !sym
->attr
.function
)
3881 if (!gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
))
3884 p
= get_pointer (sym
);
3885 if (p
->type
== P_UNKNOWN
)
3888 if (p
->u
.wsym
.state
== WRITTEN
)
3891 write_symbol (p
->integer
, sym
);
3892 p
->u
.wsym
.state
= WRITTEN
;
3896 /* Recursive traversal function to write the secondary set of symbols
3897 to the module file. These are symbols that were not public yet are
3898 needed by the public symbols or another dependent symbol. The act
3899 of writing a symbol can modify the pointer_info tree, so we cease
3900 traversal if we find a symbol to write. We return nonzero if a
3901 symbol was written and pass that information upwards. */
3904 write_symbol1 (pointer_info
*p
)
3910 if (write_symbol1 (p
->left
))
3912 if (write_symbol1 (p
->right
))
3915 if (p
->type
!= P_SYMBOL
|| p
->u
.wsym
.state
!= NEEDS_WRITE
)
3918 p
->u
.wsym
.state
= WRITTEN
;
3919 write_symbol (p
->integer
, p
->u
.wsym
.sym
);
3925 /* Write operator interfaces associated with a symbol. */
3928 write_operator (gfc_user_op
*uop
)
3930 static char nullstring
[] = "";
3931 const char *p
= nullstring
;
3933 if (uop
->operator == NULL
3934 || !gfc_check_access (uop
->access
, uop
->ns
->default_access
))
3937 mio_symbol_interface (&uop
->name
, &p
, &uop
->operator);
3941 /* Write generic interfaces associated with a symbol. */
3944 write_generic (gfc_symbol
*sym
)
3946 if (sym
->generic
== NULL
3947 || !gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
))
3950 if (sym
->module
== NULL
)
3951 sym
->module
= gfc_get_string (module_name
);
3953 mio_symbol_interface (&sym
->name
, &sym
->module
, &sym
->generic
);
3958 write_symtree (gfc_symtree
*st
)
3964 if (!gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
)
3965 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
3966 && !sym
->attr
.subroutine
&& !sym
->attr
.function
))
3969 if (check_unique_name (st
->name
))
3972 p
= find_pointer (sym
);
3974 gfc_internal_error ("write_symtree(): Symbol not written");
3976 mio_pool_string (&st
->name
);
3977 mio_integer (&st
->ambiguous
);
3978 mio_integer (&p
->integer
);
3987 /* Write the operator interfaces. */
3990 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
3992 if (i
== INTRINSIC_USER
)
3995 mio_interface (gfc_check_access (gfc_current_ns
->operator_access
[i
],
3996 gfc_current_ns
->default_access
)
3997 ? &gfc_current_ns
->operator[i
] : NULL
);
4005 gfc_traverse_user_op (gfc_current_ns
, write_operator
);
4011 gfc_traverse_ns (gfc_current_ns
, write_generic
);
4017 write_blank_common ();
4018 write_common (gfc_current_ns
->common_root
);
4029 /* Write symbol information. First we traverse all symbols in the
4030 primary namespace, writing those that need to be written.
4031 Sometimes writing one symbol will cause another to need to be
4032 written. A list of these symbols ends up on the write stack, and
4033 we end by popping the bottom of the stack and writing the symbol
4034 until the stack is empty. */
4038 write_symbol0 (gfc_current_ns
->sym_root
);
4039 while (write_symbol1 (pi_root
));
4047 gfc_traverse_symtree (gfc_current_ns
->sym_root
, write_symtree
);
4052 /* Read a MD5 sum from the header of a module file. If the file cannot
4053 be opened, or we have any other error, we return -1. */
4056 read_md5_from_module_file (const char * filename
, unsigned char md5
[16])
4062 /* Open the file. */
4063 if ((file
= fopen (filename
, "r")) == NULL
)
4066 /* Read two lines. */
4067 if (fgets (buf
, sizeof (buf
) - 1, file
) == NULL
4068 || fgets (buf
, sizeof (buf
) - 1, file
) == NULL
)
4074 /* Close the file. */
4077 /* If the header is not what we expect, or is too short, bail out. */
4078 if (strncmp (buf
, "MD5:", 4) != 0 || strlen (buf
) < 4 + 16)
4081 /* Now, we have a real MD5, read it into the array. */
4082 for (n
= 0; n
< 16; n
++)
4086 if (sscanf (&(buf
[4+2*n
]), "%02x", &x
) != 1)
4096 /* Given module, dump it to disk. If there was an error while
4097 processing the module, dump_flag will be set to zero and we delete
4098 the module file, even if it was already there. */
4101 gfc_dump_module (const char *name
, int dump_flag
)
4104 char *filename
, *filename_tmp
, *p
;
4107 unsigned char md5_new
[16], md5_old
[16];
4109 n
= strlen (name
) + strlen (MODULE_EXTENSION
) + 1;
4110 if (gfc_option
.module_dir
!= NULL
)
4112 n
+= strlen (gfc_option
.module_dir
);
4113 filename
= (char *) alloca (n
);
4114 strcpy (filename
, gfc_option
.module_dir
);
4115 strcat (filename
, name
);
4119 filename
= (char *) alloca (n
);
4120 strcpy (filename
, name
);
4122 strcat (filename
, MODULE_EXTENSION
);
4124 /* Name of the temporary file used to write the module. */
4125 filename_tmp
= (char *) alloca (n
+ 1);
4126 strcpy (filename_tmp
, filename
);
4127 strcat (filename_tmp
, "0");
4129 /* There was an error while processing the module. We delete the
4130 module file, even if it was already there. */
4137 /* Write the module to the temporary file. */
4138 module_fp
= fopen (filename_tmp
, "w");
4139 if (module_fp
== NULL
)
4140 gfc_fatal_error ("Can't open module file '%s' for writing at %C: %s",
4141 filename_tmp
, strerror (errno
));
4143 /* Write the header, including space reserved for the MD5 sum. */
4147 *strchr (p
, '\n') = '\0';
4149 fprintf (module_fp
, "GFORTRAN module created from %s on %s\nMD5:",
4150 gfc_source_file
, p
);
4151 fgetpos (module_fp
, &md5_pos
);
4152 fputs ("00000000000000000000000000000000 -- "
4153 "If you edit this, you'll get what you deserve.\n\n", module_fp
);
4155 /* Initialize the MD5 context that will be used for output. */
4156 md5_init_ctx (&ctx
);
4158 /* Write the module itself. */
4160 strcpy (module_name
, name
);
4166 free_pi_tree (pi_root
);
4171 /* Write the MD5 sum to the header of the module file. */
4172 md5_finish_ctx (&ctx
, md5_new
);
4173 fsetpos (module_fp
, &md5_pos
);
4174 for (n
= 0; n
< 16; n
++)
4175 fprintf (module_fp
, "%02x", md5_new
[n
]);
4177 if (fclose (module_fp
))
4178 gfc_fatal_error ("Error writing module file '%s' for writing: %s",
4179 filename_tmp
, strerror (errno
));
4181 /* Read the MD5 from the header of the old module file and compare. */
4182 if (read_md5_from_module_file (filename
, md5_old
) != 0
4183 || memcmp (md5_old
, md5_new
, sizeof (md5_old
)) != 0)
4185 /* Module file have changed, replace the old one. */
4187 rename (filename_tmp
, filename
);
4190 unlink (filename_tmp
);
4195 sort_iso_c_rename_list (void)
4197 gfc_use_rename
*tmp_list
= NULL
;
4198 gfc_use_rename
*curr
;
4199 gfc_use_rename
*kinds_used
[ISOCBINDING_NUMBER
] = {NULL
};
4203 for (curr
= gfc_rename_list
; curr
; curr
= curr
->next
)
4205 c_kind
= get_c_kind (curr
->use_name
, c_interop_kinds_table
);
4206 if (c_kind
== ISOCBINDING_INVALID
|| c_kind
== ISOCBINDING_LAST
)
4208 gfc_error ("Symbol '%s' referenced at %L does not exist in "
4209 "intrinsic module ISO_C_BINDING.", curr
->use_name
,
4213 /* Put it in the list. */
4214 kinds_used
[c_kind
] = curr
;
4217 /* Make a new (sorted) rename list. */
4219 while (i
< ISOCBINDING_NUMBER
&& kinds_used
[i
] == NULL
)
4222 if (i
< ISOCBINDING_NUMBER
)
4224 tmp_list
= kinds_used
[i
];
4228 for (; i
< ISOCBINDING_NUMBER
; i
++)
4229 if (kinds_used
[i
] != NULL
)
4231 curr
->next
= kinds_used
[i
];
4237 gfc_rename_list
= tmp_list
;
4241 /* Import the instrinsic ISO_C_BINDING module, generating symbols in
4242 the current namespace for all named constants, pointer types, and
4243 procedures in the module unless the only clause was used or a rename
4244 list was provided. */
4247 import_iso_c_binding_module (void)
4249 gfc_symbol
*mod_sym
= NULL
;
4250 gfc_symtree
*mod_symtree
= NULL
;
4251 const char *iso_c_module_name
= "__iso_c_binding";
4256 /* Look only in the current namespace. */
4257 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, iso_c_module_name
);
4259 if (mod_symtree
== NULL
)
4261 /* symtree doesn't already exist in current namespace. */
4262 gfc_get_sym_tree (iso_c_module_name
, gfc_current_ns
, &mod_symtree
);
4264 if (mod_symtree
!= NULL
)
4265 mod_sym
= mod_symtree
->n
.sym
;
4267 gfc_internal_error ("import_iso_c_binding_module(): Unable to "
4268 "create symbol for %s", iso_c_module_name
);
4270 mod_sym
->attr
.flavor
= FL_MODULE
;
4271 mod_sym
->attr
.intrinsic
= 1;
4272 mod_sym
->module
= gfc_get_string (iso_c_module_name
);
4273 mod_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
4276 /* Generate the symbols for the named constants representing
4277 the kinds for intrinsic data types. */
4280 /* Sort the rename list because there are dependencies between types
4281 and procedures (e.g., c_loc needs c_ptr). */
4282 sort_iso_c_rename_list ();
4284 for (u
= gfc_rename_list
; u
; u
= u
->next
)
4286 i
= get_c_kind (u
->use_name
, c_interop_kinds_table
);
4288 if (i
== ISOCBINDING_INVALID
|| i
== ISOCBINDING_LAST
)
4290 gfc_error ("Symbol '%s' referenced at %L does not exist in "
4291 "intrinsic module ISO_C_BINDING.", u
->use_name
,
4296 generate_isocbinding_symbol (iso_c_module_name
, i
, u
->local_name
);
4301 for (i
= 0; i
< ISOCBINDING_NUMBER
; i
++)
4304 for (u
= gfc_rename_list
; u
; u
= u
->next
)
4306 if (strcmp (c_interop_kinds_table
[i
].name
, u
->use_name
) == 0)
4308 local_name
= u
->local_name
;
4313 generate_isocbinding_symbol (iso_c_module_name
, i
, local_name
);
4316 for (u
= gfc_rename_list
; u
; u
= u
->next
)
4321 gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
4322 "module ISO_C_BINDING", u
->use_name
, &u
->where
);
4328 /* Add an integer named constant from a given module. */
4331 create_int_parameter (const char *name
, int value
, const char *modname
,
4332 intmod_id module
, int id
)
4334 gfc_symtree
*tmp_symtree
;
4337 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
4338 if (tmp_symtree
!= NULL
)
4340 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
4343 gfc_error ("Symbol '%s' already declared", name
);
4346 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
);
4347 sym
= tmp_symtree
->n
.sym
;
4349 sym
->module
= gfc_get_string (modname
);
4350 sym
->attr
.flavor
= FL_PARAMETER
;
4351 sym
->ts
.type
= BT_INTEGER
;
4352 sym
->ts
.kind
= gfc_default_integer_kind
;
4353 sym
->value
= gfc_int_expr (value
);
4354 sym
->attr
.use_assoc
= 1;
4355 sym
->from_intmod
= module
;
4356 sym
->intmod_sym_id
= id
;
4360 /* USE the ISO_FORTRAN_ENV intrinsic module. */
4363 use_iso_fortran_env_module (void)
4365 static char mod
[] = "iso_fortran_env";
4366 const char *local_name
;
4368 gfc_symbol
*mod_sym
;
4369 gfc_symtree
*mod_symtree
;
4372 intmod_sym symbol
[] = {
4373 #define NAMED_INTCST(a,b,c) { a, b, 0 },
4374 #include "iso-fortran-env.def"
4376 { ISOFORTRANENV_INVALID
, NULL
, -1234 } };
4379 #define NAMED_INTCST(a,b,c) symbol[i++].value = c;
4380 #include "iso-fortran-env.def"
4383 /* Generate the symbol for the module itself. */
4384 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, mod
);
4385 if (mod_symtree
== NULL
)
4387 gfc_get_sym_tree (mod
, gfc_current_ns
, &mod_symtree
);
4388 gcc_assert (mod_symtree
);
4389 mod_sym
= mod_symtree
->n
.sym
;
4391 mod_sym
->attr
.flavor
= FL_MODULE
;
4392 mod_sym
->attr
.intrinsic
= 1;
4393 mod_sym
->module
= gfc_get_string (mod
);
4394 mod_sym
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
4397 if (!mod_symtree
->n
.sym
->attr
.intrinsic
)
4398 gfc_error ("Use of intrinsic module '%s' at %C conflicts with "
4399 "non-intrinsic module name used previously", mod
);
4401 /* Generate the symbols for the module integer named constants. */
4403 for (u
= gfc_rename_list
; u
; u
= u
->next
)
4405 for (i
= 0; symbol
[i
].name
; i
++)
4406 if (strcmp (symbol
[i
].name
, u
->use_name
) == 0)
4409 if (symbol
[i
].name
== NULL
)
4411 gfc_error ("Symbol '%s' referenced at %L does not exist in "
4412 "intrinsic module ISO_FORTRAN_ENV", u
->use_name
,
4417 if ((gfc_option
.flag_default_integer
|| gfc_option
.flag_default_real
)
4418 && symbol
[i
].id
== ISOFORTRANENV_NUMERIC_STORAGE_SIZE
)
4419 gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
4420 "from intrinsic module ISO_FORTRAN_ENV at %L is "
4421 "incompatible with option %s", &u
->where
,
4422 gfc_option
.flag_default_integer
4423 ? "-fdefault-integer-8" : "-fdefault-real-8");
4425 create_int_parameter (u
->local_name
[0] ? u
->local_name
4427 symbol
[i
].value
, mod
, INTMOD_ISO_FORTRAN_ENV
,
4432 for (i
= 0; symbol
[i
].name
; i
++)
4435 for (u
= gfc_rename_list
; u
; u
= u
->next
)
4437 if (strcmp (symbol
[i
].name
, u
->use_name
) == 0)
4439 local_name
= u
->local_name
;
4445 if ((gfc_option
.flag_default_integer
|| gfc_option
.flag_default_real
)
4446 && symbol
[i
].id
== ISOFORTRANENV_NUMERIC_STORAGE_SIZE
)
4447 gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
4448 "from intrinsic module ISO_FORTRAN_ENV at %C is "
4449 "incompatible with option %s",
4450 gfc_option
.flag_default_integer
4451 ? "-fdefault-integer-8" : "-fdefault-real-8");
4453 create_int_parameter (local_name
? local_name
: symbol
[i
].name
,
4454 symbol
[i
].value
, mod
, INTMOD_ISO_FORTRAN_ENV
,
4458 for (u
= gfc_rename_list
; u
; u
= u
->next
)
4463 gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
4464 "module ISO_FORTRAN_ENV", u
->use_name
, &u
->where
);
4470 /* Process a USE directive. */
4473 gfc_use_module (void)
4478 gfc_symtree
*mod_symtree
;
4480 filename
= (char *) alloca (strlen (module_name
) + strlen (MODULE_EXTENSION
)
4482 strcpy (filename
, module_name
);
4483 strcat (filename
, MODULE_EXTENSION
);
4485 /* First, try to find an non-intrinsic module, unless the USE statement
4486 specified that the module is intrinsic. */
4489 module_fp
= gfc_open_included_file (filename
, true, true);
4491 /* Then, see if it's an intrinsic one, unless the USE statement
4492 specified that the module is non-intrinsic. */
4493 if (module_fp
== NULL
&& !specified_nonint
)
4495 if (strcmp (module_name
, "iso_fortran_env") == 0
4496 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: ISO_FORTRAN_ENV "
4497 "intrinsic module at %C") != FAILURE
)
4499 use_iso_fortran_env_module ();
4503 if (strcmp (module_name
, "iso_c_binding") == 0
4504 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: "
4505 "ISO_C_BINDING module at %C") != FAILURE
)
4507 import_iso_c_binding_module();
4511 module_fp
= gfc_open_intrinsic_module (filename
);
4513 if (module_fp
== NULL
&& specified_int
)
4514 gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C",
4518 if (module_fp
== NULL
)
4519 gfc_fatal_error ("Can't open module file '%s' for reading at %C: %s",
4520 filename
, strerror (errno
));
4522 /* Check that we haven't already USEd an intrinsic module with the
4525 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, module_name
);
4526 if (mod_symtree
&& mod_symtree
->n
.sym
->attr
.intrinsic
)
4527 gfc_error ("Use of non-intrinsic module '%s' at %C conflicts with "
4528 "intrinsic module name used previously", module_name
);
4535 /* Skip the first two lines of the module, after checking that this is
4536 a gfortran module file. */
4542 bad_module ("Unexpected end of module");
4545 if ((start
== 1 && strcmp (atom_name
, "GFORTRAN") != 0)
4546 || (start
== 2 && strcmp (atom_name
, " module") != 0))
4547 gfc_fatal_error ("File '%s' opened at %C is not a GFORTRAN module "
4554 /* Make sure we're not reading the same module that we may be building. */
4555 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
4556 if (p
->state
== COMP_MODULE
&& strcmp (p
->sym
->name
, module_name
) == 0)
4557 gfc_fatal_error ("Can't USE the same module we're building!");
4560 init_true_name_tree ();
4564 free_true_name (true_name_root
);
4565 true_name_root
= NULL
;
4567 free_pi_tree (pi_root
);
4575 gfc_module_init_2 (void)
4577 last_atom
= ATOM_LPAREN
;
4582 gfc_module_done_2 (void)