1 /* Handle modules, which amounts to loading and saving symbols and
2 their attendant structures.
3 Copyright (C) 2000-2013 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
22 /* The syntax of gfortran modules resembles that of lisp lists, i.e. a
23 sequence of atoms, which can be left or right parenthesis, names,
24 integers or strings. Parenthesis are always matched which allows
25 us to skip over sections at high speed without having to know
26 anything about the internal structure of the lists. A "name" is
27 usually a fortran 95 identifier, but can also start with '@' in
28 order to reference a hidden symbol.
30 The first line of a module is an informational message about what
31 created the module, the file it came from and when it was created.
32 The second line is a warning for people not to edit the module.
33 The rest of the module looks like:
35 ( ( <Interface info for UPLUS> )
36 ( <Interface info for UMINUS> )
39 ( ( <name of operator interface> <module of op interface> <i/f1> ... )
42 ( ( <name of generic interface> <module of generic interface> <i/f1> ... )
45 ( ( <common name> <symbol> <saved flag>)
51 ( <Symbol Number (in no particular order)>
53 <Module name of symbol>
54 ( <symbol information> )
63 In general, symbols refer to other symbols by their symbol number,
64 which are zero based. Symbols are written to the module in no
69 #include "coretypes.h"
73 #include "parse.h" /* FIXME */
75 #include "constructor.h"
79 #define MODULE_EXTENSION ".mod"
81 /* Don't put any single quote (') in MOD_VERSION,
82 if yout want it to be recognized. */
83 #define MOD_VERSION "10"
86 /* Structure that describes a position within a module file. */
95 /* Structure for list of symbols of intrinsic modules. */
108 P_UNKNOWN
= 0, P_OTHER
, P_NAMESPACE
, P_COMPONENT
, P_SYMBOL
112 /* The fixup structure lists pointers to pointers that have to
113 be updated when a pointer value becomes known. */
115 typedef struct fixup_t
118 struct fixup_t
*next
;
123 /* Structure for holding extra info needed for pointers being read. */
139 typedef struct pointer_info
141 BBT_HEADER (pointer_info
);
145 /* The first component of each member of the union is the pointer
152 void *pointer
; /* Member for doing pointer searches. */
157 char *true_name
, *module
, *binding_label
;
159 gfc_symtree
*symtree
;
160 enum gfc_rsym_state state
;
161 int ns
, referenced
, renamed
;
169 enum gfc_wsym_state state
;
178 #define gfc_get_pointer_info() XCNEW (pointer_info)
181 /* Local variables */
183 /* The FILE for the module we're reading or writing. */
184 static FILE *module_fp
;
186 /* MD5 context structure. */
187 static struct md5_ctx ctx
;
189 /* The name of the module we're reading (USE'ing) or writing. */
190 static const char *module_name
;
191 static gfc_use_list
*module_list
;
193 static int module_line
, module_column
, only_flag
;
194 static int prev_module_line
, prev_module_column
, prev_character
;
197 { IO_INPUT
, IO_OUTPUT
}
200 static gfc_use_rename
*gfc_rename_list
;
201 static pointer_info
*pi_root
;
202 static int symbol_number
; /* Counter for assigning symbol numbers */
204 /* Tells mio_expr_ref to make symbols for unused equivalence members. */
205 static bool in_load_equiv
;
209 /*****************************************************************/
211 /* Pointer/integer conversion. Pointers between structures are stored
212 as integers in the module file. The next couple of subroutines
213 handle this translation for reading and writing. */
215 /* Recursively free the tree of pointer structures. */
218 free_pi_tree (pointer_info
*p
)
223 if (p
->fixup
!= NULL
)
224 gfc_internal_error ("free_pi_tree(): Unresolved fixup");
226 free_pi_tree (p
->left
);
227 free_pi_tree (p
->right
);
229 if (iomode
== IO_INPUT
)
231 XDELETEVEC (p
->u
.rsym
.true_name
);
232 XDELETEVEC (p
->u
.rsym
.module
);
233 XDELETEVEC (p
->u
.rsym
.binding_label
);
240 /* Compare pointers when searching by pointer. Used when writing a
244 compare_pointers (void *_sn1
, void *_sn2
)
246 pointer_info
*sn1
, *sn2
;
248 sn1
= (pointer_info
*) _sn1
;
249 sn2
= (pointer_info
*) _sn2
;
251 if (sn1
->u
.pointer
< sn2
->u
.pointer
)
253 if (sn1
->u
.pointer
> sn2
->u
.pointer
)
260 /* Compare integers when searching by integer. Used when reading a
264 compare_integers (void *_sn1
, void *_sn2
)
266 pointer_info
*sn1
, *sn2
;
268 sn1
= (pointer_info
*) _sn1
;
269 sn2
= (pointer_info
*) _sn2
;
271 if (sn1
->integer
< sn2
->integer
)
273 if (sn1
->integer
> sn2
->integer
)
280 /* Initialize the pointer_info tree. */
289 compare
= (iomode
== IO_INPUT
) ? compare_integers
: compare_pointers
;
291 /* Pointer 0 is the NULL pointer. */
292 p
= gfc_get_pointer_info ();
297 gfc_insert_bbt (&pi_root
, p
, compare
);
299 /* Pointer 1 is the current namespace. */
300 p
= gfc_get_pointer_info ();
301 p
->u
.pointer
= gfc_current_ns
;
303 p
->type
= P_NAMESPACE
;
305 gfc_insert_bbt (&pi_root
, p
, compare
);
311 /* During module writing, call here with a pointer to something,
312 returning the pointer_info node. */
314 static pointer_info
*
315 find_pointer (void *gp
)
322 if (p
->u
.pointer
== gp
)
324 p
= (gp
< p
->u
.pointer
) ? p
->left
: p
->right
;
331 /* Given a pointer while writing, returns the pointer_info tree node,
332 creating it if it doesn't exist. */
334 static pointer_info
*
335 get_pointer (void *gp
)
339 p
= find_pointer (gp
);
343 /* Pointer doesn't have an integer. Give it one. */
344 p
= gfc_get_pointer_info ();
347 p
->integer
= symbol_number
++;
349 gfc_insert_bbt (&pi_root
, p
, compare_pointers
);
355 /* Given an integer during reading, find it in the pointer_info tree,
356 creating the node if not found. */
358 static pointer_info
*
359 get_integer (int integer
)
369 c
= compare_integers (&t
, p
);
373 p
= (c
< 0) ? p
->left
: p
->right
;
379 p
= gfc_get_pointer_info ();
380 p
->integer
= integer
;
383 gfc_insert_bbt (&pi_root
, p
, compare_integers
);
389 /* Recursive function to find a pointer within a tree by brute force. */
391 static pointer_info
*
392 fp2 (pointer_info
*p
, const void *target
)
399 if (p
->u
.pointer
== target
)
402 q
= fp2 (p
->left
, target
);
406 return fp2 (p
->right
, target
);
410 /* During reading, find a pointer_info node from the pointer value.
411 This amounts to a brute-force search. */
413 static pointer_info
*
414 find_pointer2 (void *p
)
416 return fp2 (pi_root
, p
);
420 /* Resolve any fixups using a known pointer. */
423 resolve_fixups (fixup_t
*f
, void *gp
)
436 /* Convert a string such that it starts with a lower-case character. Used
437 to convert the symtree name of a derived-type to the symbol name or to
438 the name of the associated generic function. */
441 dt_lower_string (const char *name
)
443 if (name
[0] != (char) TOLOWER ((unsigned char) name
[0]))
444 return gfc_get_string ("%c%s", (char) TOLOWER ((unsigned char) name
[0]),
446 return gfc_get_string (name
);
450 /* Convert a string such that it starts with an upper-case character. Used to
451 return the symtree-name for a derived type; the symbol name itself and the
452 symtree/symbol name of the associated generic function start with a lower-
456 dt_upper_string (const char *name
)
458 if (name
[0] != (char) TOUPPER ((unsigned char) name
[0]))
459 return gfc_get_string ("%c%s", (char) TOUPPER ((unsigned char) name
[0]),
461 return gfc_get_string (name
);
464 /* Call here during module reading when we know what pointer to
465 associate with an integer. Any fixups that exist are resolved at
469 associate_integer_pointer (pointer_info
*p
, void *gp
)
471 if (p
->u
.pointer
!= NULL
)
472 gfc_internal_error ("associate_integer_pointer(): Already associated");
476 resolve_fixups (p
->fixup
, gp
);
482 /* During module reading, given an integer and a pointer to a pointer,
483 either store the pointer from an already-known value or create a
484 fixup structure in order to store things later. Returns zero if
485 the reference has been actually stored, or nonzero if the reference
486 must be fixed later (i.e., associate_integer_pointer must be called
487 sometime later. Returns the pointer_info structure. */
489 static pointer_info
*
490 add_fixup (int integer
, void *gp
)
496 p
= get_integer (integer
);
498 if (p
->integer
== 0 || p
->u
.pointer
!= NULL
)
501 *cp
= (char *) p
->u
.pointer
;
510 f
->pointer
= (void **) gp
;
517 /*****************************************************************/
519 /* Parser related subroutines */
521 /* Free the rename list left behind by a USE statement. */
524 free_rename (gfc_use_rename
*list
)
526 gfc_use_rename
*next
;
528 for (; list
; list
= next
)
536 /* Match a USE statement. */
541 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module_nature
[GFC_MAX_SYMBOL_LEN
+ 1];
542 gfc_use_rename
*tail
= NULL
, *new_use
;
543 interface_type type
, type2
;
546 gfc_use_list
*use_list
;
548 use_list
= gfc_get_use_list ();
550 if (gfc_match (" , ") == MATCH_YES
)
552 if ((m
= gfc_match (" %n ::", module_nature
)) == MATCH_YES
)
554 if (gfc_notify_std (GFC_STD_F2003
, "module "
555 "nature in USE statement at %C") == FAILURE
)
558 if (strcmp (module_nature
, "intrinsic") == 0)
559 use_list
->intrinsic
= true;
562 if (strcmp (module_nature
, "non_intrinsic") == 0)
563 use_list
->non_intrinsic
= true;
566 gfc_error ("Module nature in USE statement at %C shall "
567 "be either INTRINSIC or NON_INTRINSIC");
574 /* Help output a better error message than "Unclassifiable
576 gfc_match (" %n", module_nature
);
577 if (strcmp (module_nature
, "intrinsic") == 0
578 || strcmp (module_nature
, "non_intrinsic") == 0)
579 gfc_error ("\"::\" was expected after module nature at %C "
580 "but was not found");
587 m
= gfc_match (" ::");
588 if (m
== MATCH_YES
&&
589 gfc_notify_std (GFC_STD_F2003
,
590 "\"USE :: module\" at %C") == FAILURE
)
595 m
= gfc_match ("% ");
604 use_list
->where
= gfc_current_locus
;
606 m
= gfc_match_name (name
);
613 use_list
->module_name
= gfc_get_string (name
);
615 if (gfc_match_eos () == MATCH_YES
)
618 if (gfc_match_char (',') != MATCH_YES
)
621 if (gfc_match (" only :") == MATCH_YES
)
622 use_list
->only_flag
= true;
624 if (gfc_match_eos () == MATCH_YES
)
629 /* Get a new rename struct and add it to the rename list. */
630 new_use
= gfc_get_use_rename ();
631 new_use
->where
= gfc_current_locus
;
634 if (use_list
->rename
== NULL
)
635 use_list
->rename
= new_use
;
637 tail
->next
= new_use
;
640 /* See what kind of interface we're dealing with. Assume it is
642 new_use
->op
= INTRINSIC_NONE
;
643 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
648 case INTERFACE_NAMELESS
:
649 gfc_error ("Missing generic specification in USE statement at %C");
652 case INTERFACE_USER_OP
:
653 case INTERFACE_GENERIC
:
654 m
= gfc_match (" =>");
656 if (type
== INTERFACE_USER_OP
&& m
== MATCH_YES
657 && (gfc_notify_std (GFC_STD_F2003
, "Renaming "
658 "operators in USE statements at %C")
662 if (type
== INTERFACE_USER_OP
)
663 new_use
->op
= INTRINSIC_USER
;
665 if (use_list
->only_flag
)
668 strcpy (new_use
->use_name
, name
);
671 strcpy (new_use
->local_name
, name
);
672 m
= gfc_match_generic_spec (&type2
, new_use
->use_name
, &op
);
677 if (m
== MATCH_ERROR
)
685 strcpy (new_use
->local_name
, name
);
687 m
= gfc_match_generic_spec (&type2
, new_use
->use_name
, &op
);
692 if (m
== MATCH_ERROR
)
696 if (strcmp (new_use
->use_name
, use_list
->module_name
) == 0
697 || strcmp (new_use
->local_name
, use_list
->module_name
) == 0)
699 gfc_error ("The name '%s' at %C has already been used as "
700 "an external module name.", use_list
->module_name
);
705 case INTERFACE_INTRINSIC_OP
:
713 if (gfc_match_eos () == MATCH_YES
)
715 if (gfc_match_char (',') != MATCH_YES
)
722 gfc_use_list
*last
= module_list
;
725 last
->next
= use_list
;
728 module_list
= use_list
;
733 gfc_syntax_error (ST_USE
);
736 free_rename (use_list
->rename
);
742 /* Given a name and a number, inst, return the inst name
743 under which to load this symbol. Returns NULL if this
744 symbol shouldn't be loaded. If inst is zero, returns
745 the number of instances of this name. If interface is
746 true, a user-defined operator is sought, otherwise only
747 non-operators are sought. */
750 find_use_name_n (const char *name
, int *inst
, bool interface
)
753 const char *low_name
= NULL
;
756 /* For derived types. */
757 if (name
[0] != (char) TOLOWER ((unsigned char) name
[0]))
758 low_name
= dt_lower_string (name
);
761 for (u
= gfc_rename_list
; u
; u
= u
->next
)
763 if ((!low_name
&& strcmp (u
->use_name
, name
) != 0)
764 || (low_name
&& strcmp (u
->use_name
, low_name
) != 0)
765 || (u
->op
== INTRINSIC_USER
&& !interface
)
766 || (u
->op
!= INTRINSIC_USER
&& interface
))
779 return only_flag
? NULL
: name
;
785 if (u
->local_name
[0] == '\0')
787 return dt_upper_string (u
->local_name
);
790 return (u
->local_name
[0] != '\0') ? u
->local_name
: name
;
794 /* Given a name, return the name under which to load this symbol.
795 Returns NULL if this symbol shouldn't be loaded. */
798 find_use_name (const char *name
, bool interface
)
801 return find_use_name_n (name
, &i
, interface
);
805 /* Given a real name, return the number of use names associated with it. */
808 number_use_names (const char *name
, bool interface
)
811 find_use_name_n (name
, &i
, interface
);
816 /* Try to find the operator in the current list. */
818 static gfc_use_rename
*
819 find_use_operator (gfc_intrinsic_op op
)
823 for (u
= gfc_rename_list
; u
; u
= u
->next
)
831 /*****************************************************************/
833 /* The next couple of subroutines maintain a tree used to avoid a
834 brute-force search for a combination of true name and module name.
835 While symtree names, the name that a particular symbol is known by
836 can changed with USE statements, we still have to keep track of the
837 true names to generate the correct reference, and also avoid
838 loading the same real symbol twice in a program unit.
840 When we start reading, the true name tree is built and maintained
841 as symbols are read. The tree is searched as we load new symbols
842 to see if it already exists someplace in the namespace. */
844 typedef struct true_name
846 BBT_HEADER (true_name
);
852 static true_name
*true_name_root
;
855 /* Compare two true_name structures. */
858 compare_true_names (void *_t1
, void *_t2
)
863 t1
= (true_name
*) _t1
;
864 t2
= (true_name
*) _t2
;
866 c
= ((t1
->sym
->module
> t2
->sym
->module
)
867 - (t1
->sym
->module
< t2
->sym
->module
));
871 return strcmp (t1
->name
, t2
->name
);
875 /* Given a true name, search the true name tree to see if it exists
876 within the main namespace. */
879 find_true_name (const char *name
, const char *module
)
885 t
.name
= gfc_get_string (name
);
887 sym
.module
= gfc_get_string (module
);
895 c
= compare_true_names ((void *) (&t
), (void *) p
);
899 p
= (c
< 0) ? p
->left
: p
->right
;
906 /* Given a gfc_symbol pointer that is not in the true name tree, add it. */
909 add_true_name (gfc_symbol
*sym
)
913 t
= XCNEW (true_name
);
915 if (sym
->attr
.flavor
== FL_DERIVED
)
916 t
->name
= dt_upper_string (sym
->name
);
920 gfc_insert_bbt (&true_name_root
, t
, compare_true_names
);
924 /* Recursive function to build the initial true name tree by
925 recursively traversing the current namespace. */
928 build_tnt (gfc_symtree
*st
)
934 build_tnt (st
->left
);
935 build_tnt (st
->right
);
937 if (st
->n
.sym
->attr
.flavor
== FL_DERIVED
)
938 name
= dt_upper_string (st
->n
.sym
->name
);
940 name
= st
->n
.sym
->name
;
942 if (find_true_name (name
, st
->n
.sym
->module
) != NULL
)
945 add_true_name (st
->n
.sym
);
949 /* Initialize the true name tree with the current namespace. */
952 init_true_name_tree (void)
954 true_name_root
= NULL
;
955 build_tnt (gfc_current_ns
->sym_root
);
959 /* Recursively free a true name tree node. */
962 free_true_name (true_name
*t
)
966 free_true_name (t
->left
);
967 free_true_name (t
->right
);
973 /*****************************************************************/
975 /* Module reading and writing. */
979 ATOM_NAME
, ATOM_LPAREN
, ATOM_RPAREN
, ATOM_INTEGER
, ATOM_STRING
983 static atom_type last_atom
;
986 /* The name buffer must be at least as long as a symbol name. Right
987 now it's not clear how we're going to store numeric constants--
988 probably as a hexadecimal string, since this will allow the exact
989 number to be preserved (this can't be done by a decimal
990 representation). Worry about that later. TODO! */
992 #define MAX_ATOM_SIZE 100
995 static char *atom_string
, atom_name
[MAX_ATOM_SIZE
];
998 /* Report problems with a module. Error reporting is not very
999 elaborate, since this sorts of errors shouldn't really happen.
1000 This subroutine never returns. */
1002 static void bad_module (const char *) ATTRIBUTE_NORETURN
;
1005 bad_module (const char *msgid
)
1012 gfc_fatal_error ("Reading module %s at line %d column %d: %s",
1013 module_name
, module_line
, module_column
, msgid
);
1016 gfc_fatal_error ("Writing module %s at line %d column %d: %s",
1017 module_name
, module_line
, module_column
, msgid
);
1020 gfc_fatal_error ("Module %s at line %d column %d: %s",
1021 module_name
, module_line
, module_column
, msgid
);
1027 /* Set the module's input pointer. */
1030 set_module_locus (module_locus
*m
)
1032 module_column
= m
->column
;
1033 module_line
= m
->line
;
1034 fsetpos (module_fp
, &m
->pos
);
1038 /* Get the module's input pointer so that we can restore it later. */
1041 get_module_locus (module_locus
*m
)
1043 m
->column
= module_column
;
1044 m
->line
= module_line
;
1045 fgetpos (module_fp
, &m
->pos
);
1049 /* Get the next character in the module, updating our reckoning of
1057 c
= getc (module_fp
);
1060 bad_module ("Unexpected EOF");
1062 prev_module_line
= module_line
;
1063 prev_module_column
= module_column
;
1076 /* Unget a character while remembering the line and column. Works for
1077 a single character only. */
1080 module_unget_char (void)
1082 module_line
= prev_module_line
;
1083 module_column
= prev_module_column
;
1084 ungetc (prev_character
, module_fp
);
1087 /* Parse a string constant. The delimiter is guaranteed to be a
1097 atom_string
= XNEWVEC (char, cursz
);
1105 int c2
= module_char ();
1108 module_unget_char ();
1116 atom_string
= XRESIZEVEC (char, atom_string
, cursz
);
1118 atom_string
[len
] = c
;
1122 atom_string
= XRESIZEVEC (char, atom_string
, len
+ 1);
1123 atom_string
[len
] = '\0'; /* C-style string for debug purposes. */
1127 /* Parse a small integer. */
1130 parse_integer (int c
)
1139 module_unget_char ();
1143 atom_int
= 10 * atom_int
+ c
- '0';
1144 if (atom_int
> 99999999)
1145 bad_module ("Integer overflow");
1167 if (!ISALNUM (c
) && c
!= '_' && c
!= '-')
1169 module_unget_char ();
1174 if (++len
> GFC_MAX_SYMBOL_LEN
)
1175 bad_module ("Name too long");
1183 /* Read the next atom in the module's input stream. */
1194 while (c
== ' ' || c
== '\r' || c
== '\n');
1219 return ATOM_INTEGER
;
1277 bad_module ("Bad name");
1284 /* Peek at the next atom on the input. */
1295 while (c
== ' ' || c
== '\r' || c
== '\n');
1300 module_unget_char ();
1304 module_unget_char ();
1308 module_unget_char ();
1321 module_unget_char ();
1322 return ATOM_INTEGER
;
1376 module_unget_char ();
1380 bad_module ("Bad name");
1385 /* Read the next atom from the input, requiring that it be a
1389 require_atom (atom_type type
)
1395 column
= module_column
;
1404 p
= _("Expected name");
1407 p
= _("Expected left parenthesis");
1410 p
= _("Expected right parenthesis");
1413 p
= _("Expected integer");
1416 p
= _("Expected string");
1419 gfc_internal_error ("require_atom(): bad atom type required");
1422 module_column
= column
;
1429 /* Given a pointer to an mstring array, require that the current input
1430 be one of the strings in the array. We return the enum value. */
1433 find_enum (const mstring
*m
)
1437 i
= gfc_string2code (m
, atom_name
);
1441 bad_module ("find_enum(): Enum not found");
1447 /* Read a string. The caller is responsible for freeing. */
1453 require_atom (ATOM_STRING
);
1460 /**************** Module output subroutines ***************************/
1462 /* Output a character to a module file. */
1465 write_char (char out
)
1467 if (putc (out
, module_fp
) == EOF
)
1468 gfc_fatal_error ("Error writing modules file: %s", xstrerror (errno
));
1470 /* Add this to our MD5. */
1471 md5_process_bytes (&out
, sizeof (out
), &ctx
);
1483 /* Write an atom to a module. The line wrapping isn't perfect, but it
1484 should work most of the time. This isn't that big of a deal, since
1485 the file really isn't meant to be read by people anyway. */
1488 write_atom (atom_type atom
, const void *v
)
1498 p
= (const char *) v
;
1510 i
= *((const int *) v
);
1512 gfc_internal_error ("write_atom(): Writing negative integer");
1514 sprintf (buffer
, "%d", i
);
1519 gfc_internal_error ("write_atom(): Trying to write dab atom");
1523 if(p
== NULL
|| *p
== '\0')
1528 if (atom
!= ATOM_RPAREN
)
1530 if (module_column
+ len
> 72)
1535 if (last_atom
!= ATOM_LPAREN
&& module_column
!= 1)
1540 if (atom
== ATOM_STRING
)
1543 while (p
!= NULL
&& *p
)
1545 if (atom
== ATOM_STRING
&& *p
== '\'')
1550 if (atom
== ATOM_STRING
)
1558 /***************** Mid-level I/O subroutines *****************/
1560 /* These subroutines let their caller read or write atoms without
1561 caring about which of the two is actually happening. This lets a
1562 subroutine concentrate on the actual format of the data being
1565 static void mio_expr (gfc_expr
**);
1566 pointer_info
*mio_symbol_ref (gfc_symbol
**);
1567 pointer_info
*mio_interface_rest (gfc_interface
**);
1568 static void mio_symtree_ref (gfc_symtree
**);
1570 /* Read or write an enumerated value. On writing, we return the input
1571 value for the convenience of callers. We avoid using an integer
1572 pointer because enums are sometimes inside bitfields. */
1575 mio_name (int t
, const mstring
*m
)
1577 if (iomode
== IO_OUTPUT
)
1578 write_atom (ATOM_NAME
, gfc_code2string (m
, t
));
1581 require_atom (ATOM_NAME
);
1588 /* Specialization of mio_name. */
1590 #define DECL_MIO_NAME(TYPE) \
1591 static inline TYPE \
1592 MIO_NAME(TYPE) (TYPE t, const mstring *m) \
1594 return (TYPE) mio_name ((int) t, m); \
1596 #define MIO_NAME(TYPE) mio_name_##TYPE
1601 if (iomode
== IO_OUTPUT
)
1602 write_atom (ATOM_LPAREN
, NULL
);
1604 require_atom (ATOM_LPAREN
);
1611 if (iomode
== IO_OUTPUT
)
1612 write_atom (ATOM_RPAREN
, NULL
);
1614 require_atom (ATOM_RPAREN
);
1619 mio_integer (int *ip
)
1621 if (iomode
== IO_OUTPUT
)
1622 write_atom (ATOM_INTEGER
, ip
);
1625 require_atom (ATOM_INTEGER
);
1631 /* Read or write a gfc_intrinsic_op value. */
1634 mio_intrinsic_op (gfc_intrinsic_op
* op
)
1636 /* FIXME: Would be nicer to do this via the operators symbolic name. */
1637 if (iomode
== IO_OUTPUT
)
1639 int converted
= (int) *op
;
1640 write_atom (ATOM_INTEGER
, &converted
);
1644 require_atom (ATOM_INTEGER
);
1645 *op
= (gfc_intrinsic_op
) atom_int
;
1650 /* Read or write a character pointer that points to a string on the heap. */
1653 mio_allocated_string (const char *s
)
1655 if (iomode
== IO_OUTPUT
)
1657 write_atom (ATOM_STRING
, s
);
1662 require_atom (ATOM_STRING
);
1668 /* Functions for quoting and unquoting strings. */
1671 quote_string (const gfc_char_t
*s
, const size_t slength
)
1673 const gfc_char_t
*p
;
1677 /* Calculate the length we'll need: a backslash takes two ("\\"),
1678 non-printable characters take 10 ("\Uxxxxxxxx") and others take 1. */
1679 for (p
= s
, i
= 0; i
< slength
; p
++, i
++)
1683 else if (!gfc_wide_is_printable (*p
))
1689 q
= res
= XCNEWVEC (char, len
+ 1);
1690 for (p
= s
, i
= 0; i
< slength
; p
++, i
++)
1693 *q
++ = '\\', *q
++ = '\\';
1694 else if (!gfc_wide_is_printable (*p
))
1696 sprintf (q
, "\\U%08" HOST_WIDE_INT_PRINT
"x",
1697 (unsigned HOST_WIDE_INT
) *p
);
1701 *q
++ = (unsigned char) *p
;
1709 unquote_string (const char *s
)
1715 for (p
= s
, len
= 0; *p
; p
++, len
++)
1722 else if (p
[1] == 'U')
1723 p
+= 9; /* That is a "\U????????". */
1725 gfc_internal_error ("unquote_string(): got bad string");
1728 res
= gfc_get_wide_string (len
+ 1);
1729 for (i
= 0, p
= s
; i
< len
; i
++, p
++)
1734 res
[i
] = (unsigned char) *p
;
1735 else if (p
[1] == '\\')
1737 res
[i
] = (unsigned char) '\\';
1742 /* We read the 8-digits hexadecimal constant that follows. */
1747 gcc_assert (p
[1] == 'U');
1748 for (j
= 0; j
< 8; j
++)
1751 gcc_assert (sscanf (&p
[j
+2], "%01x", &n
) == 1);
1765 /* Read or write a character pointer that points to a wide string on the
1766 heap, performing quoting/unquoting of nonprintable characters using the
1767 form \U???????? (where each ? is a hexadecimal digit).
1768 Length is the length of the string, only known and used in output mode. */
1770 static const gfc_char_t
*
1771 mio_allocated_wide_string (const gfc_char_t
*s
, const size_t length
)
1773 if (iomode
== IO_OUTPUT
)
1775 char *quoted
= quote_string (s
, length
);
1776 write_atom (ATOM_STRING
, quoted
);
1782 gfc_char_t
*unquoted
;
1784 require_atom (ATOM_STRING
);
1785 unquoted
= unquote_string (atom_string
);
1792 /* Read or write a string that is in static memory. */
1795 mio_pool_string (const char **stringp
)
1797 /* TODO: one could write the string only once, and refer to it via a
1800 /* As a special case we have to deal with a NULL string. This
1801 happens for the 'module' member of 'gfc_symbol's that are not in a
1802 module. We read / write these as the empty string. */
1803 if (iomode
== IO_OUTPUT
)
1805 const char *p
= *stringp
== NULL
? "" : *stringp
;
1806 write_atom (ATOM_STRING
, p
);
1810 require_atom (ATOM_STRING
);
1811 *stringp
= atom_string
[0] == '\0' ? NULL
: gfc_get_string (atom_string
);
1817 /* Read or write a string that is inside of some already-allocated
1821 mio_internal_string (char *string
)
1823 if (iomode
== IO_OUTPUT
)
1824 write_atom (ATOM_STRING
, string
);
1827 require_atom (ATOM_STRING
);
1828 strcpy (string
, atom_string
);
1835 { AB_ALLOCATABLE
, AB_DIMENSION
, AB_EXTERNAL
, AB_INTRINSIC
, AB_OPTIONAL
,
1836 AB_POINTER
, AB_TARGET
, AB_DUMMY
, AB_RESULT
, AB_DATA
,
1837 AB_IN_NAMELIST
, AB_IN_COMMON
, AB_FUNCTION
, AB_SUBROUTINE
, AB_SEQUENCE
,
1838 AB_ELEMENTAL
, AB_PURE
, AB_RECURSIVE
, AB_GENERIC
, AB_ALWAYS_EXPLICIT
,
1839 AB_CRAY_POINTER
, AB_CRAY_POINTEE
, AB_THREADPRIVATE
,
1840 AB_ALLOC_COMP
, AB_POINTER_COMP
, AB_PROC_POINTER_COMP
, AB_PRIVATE_COMP
,
1841 AB_VALUE
, AB_VOLATILE
, AB_PROTECTED
, AB_LOCK_COMP
,
1842 AB_IS_BIND_C
, AB_IS_C_INTEROP
, AB_IS_ISO_C
, AB_ABSTRACT
, AB_ZERO_COMP
,
1843 AB_IS_CLASS
, AB_PROCEDURE
, AB_PROC_POINTER
, AB_ASYNCHRONOUS
, AB_CODIMENSION
,
1844 AB_COARRAY_COMP
, AB_VTYPE
, AB_VTAB
, AB_CONTIGUOUS
, AB_CLASS_POINTER
,
1845 AB_IMPLICIT_PURE
, AB_ARTIFICIAL
, AB_UNLIMITED_POLY
1849 static const mstring attr_bits
[] =
1851 minit ("ALLOCATABLE", AB_ALLOCATABLE
),
1852 minit ("ARTIFICIAL", AB_ARTIFICIAL
),
1853 minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS
),
1854 minit ("DIMENSION", AB_DIMENSION
),
1855 minit ("CODIMENSION", AB_CODIMENSION
),
1856 minit ("CONTIGUOUS", AB_CONTIGUOUS
),
1857 minit ("EXTERNAL", AB_EXTERNAL
),
1858 minit ("INTRINSIC", AB_INTRINSIC
),
1859 minit ("OPTIONAL", AB_OPTIONAL
),
1860 minit ("POINTER", AB_POINTER
),
1861 minit ("VOLATILE", AB_VOLATILE
),
1862 minit ("TARGET", AB_TARGET
),
1863 minit ("THREADPRIVATE", AB_THREADPRIVATE
),
1864 minit ("DUMMY", AB_DUMMY
),
1865 minit ("RESULT", AB_RESULT
),
1866 minit ("DATA", AB_DATA
),
1867 minit ("IN_NAMELIST", AB_IN_NAMELIST
),
1868 minit ("IN_COMMON", AB_IN_COMMON
),
1869 minit ("FUNCTION", AB_FUNCTION
),
1870 minit ("SUBROUTINE", AB_SUBROUTINE
),
1871 minit ("SEQUENCE", AB_SEQUENCE
),
1872 minit ("ELEMENTAL", AB_ELEMENTAL
),
1873 minit ("PURE", AB_PURE
),
1874 minit ("RECURSIVE", AB_RECURSIVE
),
1875 minit ("GENERIC", AB_GENERIC
),
1876 minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT
),
1877 minit ("CRAY_POINTER", AB_CRAY_POINTER
),
1878 minit ("CRAY_POINTEE", AB_CRAY_POINTEE
),
1879 minit ("IS_BIND_C", AB_IS_BIND_C
),
1880 minit ("IS_C_INTEROP", AB_IS_C_INTEROP
),
1881 minit ("IS_ISO_C", AB_IS_ISO_C
),
1882 minit ("VALUE", AB_VALUE
),
1883 minit ("ALLOC_COMP", AB_ALLOC_COMP
),
1884 minit ("COARRAY_COMP", AB_COARRAY_COMP
),
1885 minit ("LOCK_COMP", AB_LOCK_COMP
),
1886 minit ("POINTER_COMP", AB_POINTER_COMP
),
1887 minit ("PROC_POINTER_COMP", AB_PROC_POINTER_COMP
),
1888 minit ("PRIVATE_COMP", AB_PRIVATE_COMP
),
1889 minit ("ZERO_COMP", AB_ZERO_COMP
),
1890 minit ("PROTECTED", AB_PROTECTED
),
1891 minit ("ABSTRACT", AB_ABSTRACT
),
1892 minit ("IS_CLASS", AB_IS_CLASS
),
1893 minit ("PROCEDURE", AB_PROCEDURE
),
1894 minit ("PROC_POINTER", AB_PROC_POINTER
),
1895 minit ("VTYPE", AB_VTYPE
),
1896 minit ("VTAB", AB_VTAB
),
1897 minit ("CLASS_POINTER", AB_CLASS_POINTER
),
1898 minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE
),
1899 minit ("UNLIMITED_POLY", AB_UNLIMITED_POLY
),
1903 /* For binding attributes. */
1904 static const mstring binding_passing
[] =
1907 minit ("NOPASS", 1),
1910 static const mstring binding_overriding
[] =
1912 minit ("OVERRIDABLE", 0),
1913 minit ("NON_OVERRIDABLE", 1),
1914 minit ("DEFERRED", 2),
1917 static const mstring binding_generic
[] =
1919 minit ("SPECIFIC", 0),
1920 minit ("GENERIC", 1),
1923 static const mstring binding_ppc
[] =
1925 minit ("NO_PPC", 0),
1930 /* Specialization of mio_name. */
1931 DECL_MIO_NAME (ab_attribute
)
1932 DECL_MIO_NAME (ar_type
)
1933 DECL_MIO_NAME (array_type
)
1935 DECL_MIO_NAME (expr_t
)
1936 DECL_MIO_NAME (gfc_access
)
1937 DECL_MIO_NAME (gfc_intrinsic_op
)
1938 DECL_MIO_NAME (ifsrc
)
1939 DECL_MIO_NAME (save_state
)
1940 DECL_MIO_NAME (procedure_type
)
1941 DECL_MIO_NAME (ref_type
)
1942 DECL_MIO_NAME (sym_flavor
)
1943 DECL_MIO_NAME (sym_intent
)
1944 #undef DECL_MIO_NAME
1946 /* Symbol attributes are stored in list with the first three elements
1947 being the enumerated fields, while the remaining elements (if any)
1948 indicate the individual attribute bits. The access field is not
1949 saved-- it controls what symbols are exported when a module is
1953 mio_symbol_attribute (symbol_attribute
*attr
)
1956 unsigned ext_attr
,extension_level
;
1960 attr
->flavor
= MIO_NAME (sym_flavor
) (attr
->flavor
, flavors
);
1961 attr
->intent
= MIO_NAME (sym_intent
) (attr
->intent
, intents
);
1962 attr
->proc
= MIO_NAME (procedure_type
) (attr
->proc
, procedures
);
1963 attr
->if_source
= MIO_NAME (ifsrc
) (attr
->if_source
, ifsrc_types
);
1964 attr
->save
= MIO_NAME (save_state
) (attr
->save
, save_status
);
1966 ext_attr
= attr
->ext_attr
;
1967 mio_integer ((int *) &ext_attr
);
1968 attr
->ext_attr
= ext_attr
;
1970 extension_level
= attr
->extension
;
1971 mio_integer ((int *) &extension_level
);
1972 attr
->extension
= extension_level
;
1974 if (iomode
== IO_OUTPUT
)
1976 if (attr
->allocatable
)
1977 MIO_NAME (ab_attribute
) (AB_ALLOCATABLE
, attr_bits
);
1978 if (attr
->artificial
)
1979 MIO_NAME (ab_attribute
) (AB_ARTIFICIAL
, attr_bits
);
1980 if (attr
->asynchronous
)
1981 MIO_NAME (ab_attribute
) (AB_ASYNCHRONOUS
, attr_bits
);
1982 if (attr
->dimension
)
1983 MIO_NAME (ab_attribute
) (AB_DIMENSION
, attr_bits
);
1984 if (attr
->codimension
)
1985 MIO_NAME (ab_attribute
) (AB_CODIMENSION
, attr_bits
);
1986 if (attr
->contiguous
)
1987 MIO_NAME (ab_attribute
) (AB_CONTIGUOUS
, attr_bits
);
1989 MIO_NAME (ab_attribute
) (AB_EXTERNAL
, attr_bits
);
1990 if (attr
->intrinsic
)
1991 MIO_NAME (ab_attribute
) (AB_INTRINSIC
, attr_bits
);
1993 MIO_NAME (ab_attribute
) (AB_OPTIONAL
, attr_bits
);
1995 MIO_NAME (ab_attribute
) (AB_POINTER
, attr_bits
);
1996 if (attr
->class_pointer
)
1997 MIO_NAME (ab_attribute
) (AB_CLASS_POINTER
, attr_bits
);
1998 if (attr
->is_protected
)
1999 MIO_NAME (ab_attribute
) (AB_PROTECTED
, attr_bits
);
2001 MIO_NAME (ab_attribute
) (AB_VALUE
, attr_bits
);
2002 if (attr
->volatile_
)
2003 MIO_NAME (ab_attribute
) (AB_VOLATILE
, attr_bits
);
2005 MIO_NAME (ab_attribute
) (AB_TARGET
, attr_bits
);
2006 if (attr
->threadprivate
)
2007 MIO_NAME (ab_attribute
) (AB_THREADPRIVATE
, attr_bits
);
2009 MIO_NAME (ab_attribute
) (AB_DUMMY
, attr_bits
);
2011 MIO_NAME (ab_attribute
) (AB_RESULT
, attr_bits
);
2012 /* We deliberately don't preserve the "entry" flag. */
2015 MIO_NAME (ab_attribute
) (AB_DATA
, attr_bits
);
2016 if (attr
->in_namelist
)
2017 MIO_NAME (ab_attribute
) (AB_IN_NAMELIST
, attr_bits
);
2018 if (attr
->in_common
)
2019 MIO_NAME (ab_attribute
) (AB_IN_COMMON
, attr_bits
);
2022 MIO_NAME (ab_attribute
) (AB_FUNCTION
, attr_bits
);
2023 if (attr
->subroutine
)
2024 MIO_NAME (ab_attribute
) (AB_SUBROUTINE
, attr_bits
);
2026 MIO_NAME (ab_attribute
) (AB_GENERIC
, attr_bits
);
2028 MIO_NAME (ab_attribute
) (AB_ABSTRACT
, attr_bits
);
2031 MIO_NAME (ab_attribute
) (AB_SEQUENCE
, attr_bits
);
2032 if (attr
->elemental
)
2033 MIO_NAME (ab_attribute
) (AB_ELEMENTAL
, attr_bits
);
2035 MIO_NAME (ab_attribute
) (AB_PURE
, attr_bits
);
2036 if (attr
->implicit_pure
)
2037 MIO_NAME (ab_attribute
) (AB_IMPLICIT_PURE
, attr_bits
);
2038 if (attr
->unlimited_polymorphic
)
2039 MIO_NAME (ab_attribute
) (AB_UNLIMITED_POLY
, attr_bits
);
2040 if (attr
->recursive
)
2041 MIO_NAME (ab_attribute
) (AB_RECURSIVE
, attr_bits
);
2042 if (attr
->always_explicit
)
2043 MIO_NAME (ab_attribute
) (AB_ALWAYS_EXPLICIT
, attr_bits
);
2044 if (attr
->cray_pointer
)
2045 MIO_NAME (ab_attribute
) (AB_CRAY_POINTER
, attr_bits
);
2046 if (attr
->cray_pointee
)
2047 MIO_NAME (ab_attribute
) (AB_CRAY_POINTEE
, attr_bits
);
2048 if (attr
->is_bind_c
)
2049 MIO_NAME(ab_attribute
) (AB_IS_BIND_C
, attr_bits
);
2050 if (attr
->is_c_interop
)
2051 MIO_NAME(ab_attribute
) (AB_IS_C_INTEROP
, attr_bits
);
2053 MIO_NAME(ab_attribute
) (AB_IS_ISO_C
, attr_bits
);
2054 if (attr
->alloc_comp
)
2055 MIO_NAME (ab_attribute
) (AB_ALLOC_COMP
, attr_bits
);
2056 if (attr
->pointer_comp
)
2057 MIO_NAME (ab_attribute
) (AB_POINTER_COMP
, attr_bits
);
2058 if (attr
->proc_pointer_comp
)
2059 MIO_NAME (ab_attribute
) (AB_PROC_POINTER_COMP
, attr_bits
);
2060 if (attr
->private_comp
)
2061 MIO_NAME (ab_attribute
) (AB_PRIVATE_COMP
, attr_bits
);
2062 if (attr
->coarray_comp
)
2063 MIO_NAME (ab_attribute
) (AB_COARRAY_COMP
, attr_bits
);
2064 if (attr
->lock_comp
)
2065 MIO_NAME (ab_attribute
) (AB_LOCK_COMP
, attr_bits
);
2066 if (attr
->zero_comp
)
2067 MIO_NAME (ab_attribute
) (AB_ZERO_COMP
, attr_bits
);
2069 MIO_NAME (ab_attribute
) (AB_IS_CLASS
, attr_bits
);
2070 if (attr
->procedure
)
2071 MIO_NAME (ab_attribute
) (AB_PROCEDURE
, attr_bits
);
2072 if (attr
->proc_pointer
)
2073 MIO_NAME (ab_attribute
) (AB_PROC_POINTER
, attr_bits
);
2075 MIO_NAME (ab_attribute
) (AB_VTYPE
, attr_bits
);
2077 MIO_NAME (ab_attribute
) (AB_VTAB
, attr_bits
);
2087 if (t
== ATOM_RPAREN
)
2090 bad_module ("Expected attribute bit name");
2092 switch ((ab_attribute
) find_enum (attr_bits
))
2094 case AB_ALLOCATABLE
:
2095 attr
->allocatable
= 1;
2098 attr
->artificial
= 1;
2100 case AB_ASYNCHRONOUS
:
2101 attr
->asynchronous
= 1;
2104 attr
->dimension
= 1;
2106 case AB_CODIMENSION
:
2107 attr
->codimension
= 1;
2110 attr
->contiguous
= 1;
2116 attr
->intrinsic
= 1;
2124 case AB_CLASS_POINTER
:
2125 attr
->class_pointer
= 1;
2128 attr
->is_protected
= 1;
2134 attr
->volatile_
= 1;
2139 case AB_THREADPRIVATE
:
2140 attr
->threadprivate
= 1;
2151 case AB_IN_NAMELIST
:
2152 attr
->in_namelist
= 1;
2155 attr
->in_common
= 1;
2161 attr
->subroutine
= 1;
2173 attr
->elemental
= 1;
2178 case AB_IMPLICIT_PURE
:
2179 attr
->implicit_pure
= 1;
2181 case AB_UNLIMITED_POLY
:
2182 attr
->unlimited_polymorphic
= 1;
2185 attr
->recursive
= 1;
2187 case AB_ALWAYS_EXPLICIT
:
2188 attr
->always_explicit
= 1;
2190 case AB_CRAY_POINTER
:
2191 attr
->cray_pointer
= 1;
2193 case AB_CRAY_POINTEE
:
2194 attr
->cray_pointee
= 1;
2197 attr
->is_bind_c
= 1;
2199 case AB_IS_C_INTEROP
:
2200 attr
->is_c_interop
= 1;
2206 attr
->alloc_comp
= 1;
2208 case AB_COARRAY_COMP
:
2209 attr
->coarray_comp
= 1;
2212 attr
->lock_comp
= 1;
2214 case AB_POINTER_COMP
:
2215 attr
->pointer_comp
= 1;
2217 case AB_PROC_POINTER_COMP
:
2218 attr
->proc_pointer_comp
= 1;
2220 case AB_PRIVATE_COMP
:
2221 attr
->private_comp
= 1;
2224 attr
->zero_comp
= 1;
2230 attr
->procedure
= 1;
2232 case AB_PROC_POINTER
:
2233 attr
->proc_pointer
= 1;
2247 static const mstring bt_types
[] = {
2248 minit ("INTEGER", BT_INTEGER
),
2249 minit ("REAL", BT_REAL
),
2250 minit ("COMPLEX", BT_COMPLEX
),
2251 minit ("LOGICAL", BT_LOGICAL
),
2252 minit ("CHARACTER", BT_CHARACTER
),
2253 minit ("DERIVED", BT_DERIVED
),
2254 minit ("CLASS", BT_CLASS
),
2255 minit ("PROCEDURE", BT_PROCEDURE
),
2256 minit ("UNKNOWN", BT_UNKNOWN
),
2257 minit ("VOID", BT_VOID
),
2258 minit ("ASSUMED", BT_ASSUMED
),
2264 mio_charlen (gfc_charlen
**clp
)
2270 if (iomode
== IO_OUTPUT
)
2274 mio_expr (&cl
->length
);
2278 if (peek_atom () != ATOM_RPAREN
)
2280 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2281 mio_expr (&cl
->length
);
2290 /* See if a name is a generated name. */
2293 check_unique_name (const char *name
)
2295 return *name
== '@';
2300 mio_typespec (gfc_typespec
*ts
)
2304 ts
->type
= MIO_NAME (bt
) (ts
->type
, bt_types
);
2306 if (ts
->type
!= BT_DERIVED
&& ts
->type
!= BT_CLASS
)
2307 mio_integer (&ts
->kind
);
2309 mio_symbol_ref (&ts
->u
.derived
);
2311 mio_symbol_ref (&ts
->interface
);
2313 /* Add info for C interop and is_iso_c. */
2314 mio_integer (&ts
->is_c_interop
);
2315 mio_integer (&ts
->is_iso_c
);
2317 /* If the typespec is for an identifier either from iso_c_binding, or
2318 a constant that was initialized to an identifier from it, use the
2319 f90_type. Otherwise, use the ts->type, since it shouldn't matter. */
2321 ts
->f90_type
= MIO_NAME (bt
) (ts
->f90_type
, bt_types
);
2323 ts
->f90_type
= MIO_NAME (bt
) (ts
->type
, bt_types
);
2325 if (ts
->type
!= BT_CHARACTER
)
2327 /* ts->u.cl is only valid for BT_CHARACTER. */
2332 mio_charlen (&ts
->u
.cl
);
2334 /* So as not to disturb the existing API, use an ATOM_NAME to
2335 transmit deferred characteristic for characters (F2003). */
2336 if (iomode
== IO_OUTPUT
)
2338 if (ts
->type
== BT_CHARACTER
&& ts
->deferred
)
2339 write_atom (ATOM_NAME
, "DEFERRED_CL");
2341 else if (peek_atom () != ATOM_RPAREN
)
2343 if (parse_atom () != ATOM_NAME
)
2344 bad_module ("Expected string");
2352 static const mstring array_spec_types
[] = {
2353 minit ("EXPLICIT", AS_EXPLICIT
),
2354 minit ("ASSUMED_RANK", AS_ASSUMED_RANK
),
2355 minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE
),
2356 minit ("DEFERRED", AS_DEFERRED
),
2357 minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE
),
2363 mio_array_spec (gfc_array_spec
**asp
)
2370 if (iomode
== IO_OUTPUT
)
2378 /* mio_integer expects nonnegative values. */
2379 rank
= as
->rank
> 0 ? as
->rank
: 0;
2380 mio_integer (&rank
);
2384 if (peek_atom () == ATOM_RPAREN
)
2390 *asp
= as
= gfc_get_array_spec ();
2391 mio_integer (&as
->rank
);
2394 mio_integer (&as
->corank
);
2395 as
->type
= MIO_NAME (array_type
) (as
->type
, array_spec_types
);
2397 if (iomode
== IO_INPUT
&& as
->type
== AS_ASSUMED_RANK
)
2399 if (iomode
== IO_INPUT
&& as
->corank
)
2400 as
->cotype
= (as
->type
== AS_DEFERRED
) ? AS_DEFERRED
: AS_EXPLICIT
;
2402 if (as
->rank
+ as
->corank
> 0)
2403 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
2405 mio_expr (&as
->lower
[i
]);
2406 mio_expr (&as
->upper
[i
]);
2414 /* Given a pointer to an array reference structure (which lives in a
2415 gfc_ref structure), find the corresponding array specification
2416 structure. Storing the pointer in the ref structure doesn't quite
2417 work when loading from a module. Generating code for an array
2418 reference also needs more information than just the array spec. */
2420 static const mstring array_ref_types
[] = {
2421 minit ("FULL", AR_FULL
),
2422 minit ("ELEMENT", AR_ELEMENT
),
2423 minit ("SECTION", AR_SECTION
),
2429 mio_array_ref (gfc_array_ref
*ar
)
2434 ar
->type
= MIO_NAME (ar_type
) (ar
->type
, array_ref_types
);
2435 mio_integer (&ar
->dimen
);
2443 for (i
= 0; i
< ar
->dimen
; i
++)
2444 mio_expr (&ar
->start
[i
]);
2449 for (i
= 0; i
< ar
->dimen
; i
++)
2451 mio_expr (&ar
->start
[i
]);
2452 mio_expr (&ar
->end
[i
]);
2453 mio_expr (&ar
->stride
[i
]);
2459 gfc_internal_error ("mio_array_ref(): Unknown array ref");
2462 /* Unfortunately, ar->dimen_type is an anonymous enumerated type so
2463 we can't call mio_integer directly. Instead loop over each element
2464 and cast it to/from an integer. */
2465 if (iomode
== IO_OUTPUT
)
2467 for (i
= 0; i
< ar
->dimen
; i
++)
2469 int tmp
= (int)ar
->dimen_type
[i
];
2470 write_atom (ATOM_INTEGER
, &tmp
);
2475 for (i
= 0; i
< ar
->dimen
; i
++)
2477 require_atom (ATOM_INTEGER
);
2478 ar
->dimen_type
[i
] = (enum gfc_array_ref_dimen_type
) atom_int
;
2482 if (iomode
== IO_INPUT
)
2484 ar
->where
= gfc_current_locus
;
2486 for (i
= 0; i
< ar
->dimen
; i
++)
2487 ar
->c_where
[i
] = gfc_current_locus
;
2494 /* Saves or restores a pointer. The pointer is converted back and
2495 forth from an integer. We return the pointer_info pointer so that
2496 the caller can take additional action based on the pointer type. */
2498 static pointer_info
*
2499 mio_pointer_ref (void *gp
)
2503 if (iomode
== IO_OUTPUT
)
2505 p
= get_pointer (*((char **) gp
));
2506 write_atom (ATOM_INTEGER
, &p
->integer
);
2510 require_atom (ATOM_INTEGER
);
2511 p
= add_fixup (atom_int
, gp
);
2518 /* Save and load references to components that occur within
2519 expressions. We have to describe these references by a number and
2520 by name. The number is necessary for forward references during
2521 reading, and the name is necessary if the symbol already exists in
2522 the namespace and is not loaded again. */
2525 mio_component_ref (gfc_component
**cp
, gfc_symbol
*sym
)
2527 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2531 p
= mio_pointer_ref (cp
);
2532 if (p
->type
== P_UNKNOWN
)
2533 p
->type
= P_COMPONENT
;
2535 if (iomode
== IO_OUTPUT
)
2536 mio_pool_string (&(*cp
)->name
);
2539 mio_internal_string (name
);
2541 if (sym
&& sym
->attr
.is_class
)
2542 sym
= sym
->components
->ts
.u
.derived
;
2544 /* It can happen that a component reference can be read before the
2545 associated derived type symbol has been loaded. Return now and
2546 wait for a later iteration of load_needed. */
2550 if (sym
->components
!= NULL
&& p
->u
.pointer
== NULL
)
2552 /* Symbol already loaded, so search by name. */
2553 q
= gfc_find_component (sym
, name
, true, true);
2556 associate_integer_pointer (p
, q
);
2559 /* Make sure this symbol will eventually be loaded. */
2560 p
= find_pointer2 (sym
);
2561 if (p
->u
.rsym
.state
== UNUSED
)
2562 p
->u
.rsym
.state
= NEEDED
;
2567 static void mio_namespace_ref (gfc_namespace
**nsp
);
2568 static void mio_formal_arglist (gfc_formal_arglist
**formal
);
2569 static void mio_typebound_proc (gfc_typebound_proc
** proc
);
2572 mio_component (gfc_component
*c
, int vtype
)
2579 if (iomode
== IO_OUTPUT
)
2581 p
= get_pointer (c
);
2582 mio_integer (&p
->integer
);
2587 p
= get_integer (n
);
2588 associate_integer_pointer (p
, c
);
2591 if (p
->type
== P_UNKNOWN
)
2592 p
->type
= P_COMPONENT
;
2594 mio_pool_string (&c
->name
);
2595 mio_typespec (&c
->ts
);
2596 mio_array_spec (&c
->as
);
2598 mio_symbol_attribute (&c
->attr
);
2599 if (c
->ts
.type
== BT_CLASS
)
2600 c
->attr
.class_ok
= 1;
2601 c
->attr
.access
= MIO_NAME (gfc_access
) (c
->attr
.access
, access_types
);
2603 if (!vtype
|| strcmp (c
->name
, "_final") == 0
2604 || strcmp (c
->name
, "_hash") == 0)
2605 mio_expr (&c
->initializer
);
2607 if (c
->attr
.proc_pointer
)
2608 mio_typebound_proc (&c
->tb
);
2615 mio_component_list (gfc_component
**cp
, int vtype
)
2617 gfc_component
*c
, *tail
;
2621 if (iomode
== IO_OUTPUT
)
2623 for (c
= *cp
; c
; c
= c
->next
)
2624 mio_component (c
, vtype
);
2633 if (peek_atom () == ATOM_RPAREN
)
2636 c
= gfc_get_component ();
2637 mio_component (c
, vtype
);
2653 mio_actual_arg (gfc_actual_arglist
*a
)
2656 mio_pool_string (&a
->name
);
2657 mio_expr (&a
->expr
);
2663 mio_actual_arglist (gfc_actual_arglist
**ap
)
2665 gfc_actual_arglist
*a
, *tail
;
2669 if (iomode
== IO_OUTPUT
)
2671 for (a
= *ap
; a
; a
= a
->next
)
2681 if (peek_atom () != ATOM_LPAREN
)
2684 a
= gfc_get_actual_arglist ();
2700 /* Read and write formal argument lists. */
2703 mio_formal_arglist (gfc_formal_arglist
**formal
)
2705 gfc_formal_arglist
*f
, *tail
;
2709 if (iomode
== IO_OUTPUT
)
2711 for (f
= *formal
; f
; f
= f
->next
)
2712 mio_symbol_ref (&f
->sym
);
2716 *formal
= tail
= NULL
;
2718 while (peek_atom () != ATOM_RPAREN
)
2720 f
= gfc_get_formal_arglist ();
2721 mio_symbol_ref (&f
->sym
);
2723 if (*formal
== NULL
)
2736 /* Save or restore a reference to a symbol node. */
2739 mio_symbol_ref (gfc_symbol
**symp
)
2743 p
= mio_pointer_ref (symp
);
2744 if (p
->type
== P_UNKNOWN
)
2747 if (iomode
== IO_OUTPUT
)
2749 if (p
->u
.wsym
.state
== UNREFERENCED
)
2750 p
->u
.wsym
.state
= NEEDS_WRITE
;
2754 if (p
->u
.rsym
.state
== UNUSED
)
2755 p
->u
.rsym
.state
= NEEDED
;
2761 /* Save or restore a reference to a symtree node. */
2764 mio_symtree_ref (gfc_symtree
**stp
)
2769 if (iomode
== IO_OUTPUT
)
2770 mio_symbol_ref (&(*stp
)->n
.sym
);
2773 require_atom (ATOM_INTEGER
);
2774 p
= get_integer (atom_int
);
2776 /* An unused equivalence member; make a symbol and a symtree
2778 if (in_load_equiv
&& p
->u
.rsym
.symtree
== NULL
)
2780 /* Since this is not used, it must have a unique name. */
2781 p
->u
.rsym
.symtree
= gfc_get_unique_symtree (gfc_current_ns
);
2783 /* Make the symbol. */
2784 if (p
->u
.rsym
.sym
== NULL
)
2786 p
->u
.rsym
.sym
= gfc_new_symbol (p
->u
.rsym
.true_name
,
2788 p
->u
.rsym
.sym
->module
= gfc_get_string (p
->u
.rsym
.module
);
2791 p
->u
.rsym
.symtree
->n
.sym
= p
->u
.rsym
.sym
;
2792 p
->u
.rsym
.symtree
->n
.sym
->refs
++;
2793 p
->u
.rsym
.referenced
= 1;
2795 /* If the symbol is PRIVATE and in COMMON, load_commons will
2796 generate a fixup symbol, which must be associated. */
2798 resolve_fixups (p
->fixup
, p
->u
.rsym
.sym
);
2802 if (p
->type
== P_UNKNOWN
)
2805 if (p
->u
.rsym
.state
== UNUSED
)
2806 p
->u
.rsym
.state
= NEEDED
;
2808 if (p
->u
.rsym
.symtree
!= NULL
)
2810 *stp
= p
->u
.rsym
.symtree
;
2814 f
= XCNEW (fixup_t
);
2816 f
->next
= p
->u
.rsym
.stfixup
;
2817 p
->u
.rsym
.stfixup
= f
;
2819 f
->pointer
= (void **) stp
;
2826 mio_iterator (gfc_iterator
**ip
)
2832 if (iomode
== IO_OUTPUT
)
2839 if (peek_atom () == ATOM_RPAREN
)
2845 *ip
= gfc_get_iterator ();
2850 mio_expr (&iter
->var
);
2851 mio_expr (&iter
->start
);
2852 mio_expr (&iter
->end
);
2853 mio_expr (&iter
->step
);
2861 mio_constructor (gfc_constructor_base
*cp
)
2867 if (iomode
== IO_OUTPUT
)
2869 for (c
= gfc_constructor_first (*cp
); c
; c
= gfc_constructor_next (c
))
2872 mio_expr (&c
->expr
);
2873 mio_iterator (&c
->iterator
);
2879 while (peek_atom () != ATOM_RPAREN
)
2881 c
= gfc_constructor_append_expr (cp
, NULL
, NULL
);
2884 mio_expr (&c
->expr
);
2885 mio_iterator (&c
->iterator
);
2894 static const mstring ref_types
[] = {
2895 minit ("ARRAY", REF_ARRAY
),
2896 minit ("COMPONENT", REF_COMPONENT
),
2897 minit ("SUBSTRING", REF_SUBSTRING
),
2903 mio_ref (gfc_ref
**rp
)
2910 r
->type
= MIO_NAME (ref_type
) (r
->type
, ref_types
);
2915 mio_array_ref (&r
->u
.ar
);
2919 mio_symbol_ref (&r
->u
.c
.sym
);
2920 mio_component_ref (&r
->u
.c
.component
, r
->u
.c
.sym
);
2924 mio_expr (&r
->u
.ss
.start
);
2925 mio_expr (&r
->u
.ss
.end
);
2926 mio_charlen (&r
->u
.ss
.length
);
2935 mio_ref_list (gfc_ref
**rp
)
2937 gfc_ref
*ref
, *head
, *tail
;
2941 if (iomode
== IO_OUTPUT
)
2943 for (ref
= *rp
; ref
; ref
= ref
->next
)
2950 while (peek_atom () != ATOM_RPAREN
)
2953 head
= tail
= gfc_get_ref ();
2956 tail
->next
= gfc_get_ref ();
2970 /* Read and write an integer value. */
2973 mio_gmp_integer (mpz_t
*integer
)
2977 if (iomode
== IO_INPUT
)
2979 if (parse_atom () != ATOM_STRING
)
2980 bad_module ("Expected integer string");
2982 mpz_init (*integer
);
2983 if (mpz_set_str (*integer
, atom_string
, 10))
2984 bad_module ("Error converting integer");
2990 p
= mpz_get_str (NULL
, 10, *integer
);
2991 write_atom (ATOM_STRING
, p
);
2998 mio_gmp_real (mpfr_t
*real
)
3003 if (iomode
== IO_INPUT
)
3005 if (parse_atom () != ATOM_STRING
)
3006 bad_module ("Expected real string");
3009 mpfr_set_str (*real
, atom_string
, 16, GFC_RND_MODE
);
3014 p
= mpfr_get_str (NULL
, &exponent
, 16, 0, *real
, GFC_RND_MODE
);
3016 if (mpfr_nan_p (*real
) || mpfr_inf_p (*real
))
3018 write_atom (ATOM_STRING
, p
);
3023 atom_string
= XCNEWVEC (char, strlen (p
) + 20);
3025 sprintf (atom_string
, "0.%s@%ld", p
, exponent
);
3027 /* Fix negative numbers. */
3028 if (atom_string
[2] == '-')
3030 atom_string
[0] = '-';
3031 atom_string
[1] = '0';
3032 atom_string
[2] = '.';
3035 write_atom (ATOM_STRING
, atom_string
);
3043 /* Save and restore the shape of an array constructor. */
3046 mio_shape (mpz_t
**pshape
, int rank
)
3052 /* A NULL shape is represented by (). */
3055 if (iomode
== IO_OUTPUT
)
3067 if (t
== ATOM_RPAREN
)
3074 shape
= gfc_get_shape (rank
);
3078 for (n
= 0; n
< rank
; n
++)
3079 mio_gmp_integer (&shape
[n
]);
3085 static const mstring expr_types
[] = {
3086 minit ("OP", EXPR_OP
),
3087 minit ("FUNCTION", EXPR_FUNCTION
),
3088 minit ("CONSTANT", EXPR_CONSTANT
),
3089 minit ("VARIABLE", EXPR_VARIABLE
),
3090 minit ("SUBSTRING", EXPR_SUBSTRING
),
3091 minit ("STRUCTURE", EXPR_STRUCTURE
),
3092 minit ("ARRAY", EXPR_ARRAY
),
3093 minit ("NULL", EXPR_NULL
),
3094 minit ("COMPCALL", EXPR_COMPCALL
),
3098 /* INTRINSIC_ASSIGN is missing because it is used as an index for
3099 generic operators, not in expressions. INTRINSIC_USER is also
3100 replaced by the correct function name by the time we see it. */
3102 static const mstring intrinsics
[] =
3104 minit ("UPLUS", INTRINSIC_UPLUS
),
3105 minit ("UMINUS", INTRINSIC_UMINUS
),
3106 minit ("PLUS", INTRINSIC_PLUS
),
3107 minit ("MINUS", INTRINSIC_MINUS
),
3108 minit ("TIMES", INTRINSIC_TIMES
),
3109 minit ("DIVIDE", INTRINSIC_DIVIDE
),
3110 minit ("POWER", INTRINSIC_POWER
),
3111 minit ("CONCAT", INTRINSIC_CONCAT
),
3112 minit ("AND", INTRINSIC_AND
),
3113 minit ("OR", INTRINSIC_OR
),
3114 minit ("EQV", INTRINSIC_EQV
),
3115 minit ("NEQV", INTRINSIC_NEQV
),
3116 minit ("EQ_SIGN", INTRINSIC_EQ
),
3117 minit ("EQ", INTRINSIC_EQ_OS
),
3118 minit ("NE_SIGN", INTRINSIC_NE
),
3119 minit ("NE", INTRINSIC_NE_OS
),
3120 minit ("GT_SIGN", INTRINSIC_GT
),
3121 minit ("GT", INTRINSIC_GT_OS
),
3122 minit ("GE_SIGN", INTRINSIC_GE
),
3123 minit ("GE", INTRINSIC_GE_OS
),
3124 minit ("LT_SIGN", INTRINSIC_LT
),
3125 minit ("LT", INTRINSIC_LT_OS
),
3126 minit ("LE_SIGN", INTRINSIC_LE
),
3127 minit ("LE", INTRINSIC_LE_OS
),
3128 minit ("NOT", INTRINSIC_NOT
),
3129 minit ("PARENTHESES", INTRINSIC_PARENTHESES
),
3134 /* Remedy a couple of situations where the gfc_expr's can be defective. */
3137 fix_mio_expr (gfc_expr
*e
)
3139 gfc_symtree
*ns_st
= NULL
;
3142 if (iomode
!= IO_OUTPUT
)
3147 /* If this is a symtree for a symbol that came from a contained module
3148 namespace, it has a unique name and we should look in the current
3149 namespace to see if the required, non-contained symbol is available
3150 yet. If so, the latter should be written. */
3151 if (e
->symtree
->n
.sym
&& check_unique_name (e
->symtree
->name
))
3153 const char *name
= e
->symtree
->n
.sym
->name
;
3154 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_DERIVED
)
3155 name
= dt_upper_string (name
);
3156 ns_st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
3159 /* On the other hand, if the existing symbol is the module name or the
3160 new symbol is a dummy argument, do not do the promotion. */
3161 if (ns_st
&& ns_st
->n
.sym
3162 && ns_st
->n
.sym
->attr
.flavor
!= FL_MODULE
3163 && !e
->symtree
->n
.sym
->attr
.dummy
)
3166 else if (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.name
)
3170 /* In some circumstances, a function used in an initialization
3171 expression, in one use associated module, can fail to be
3172 coupled to its symtree when used in a specification
3173 expression in another module. */
3174 fname
= e
->value
.function
.esym
? e
->value
.function
.esym
->name
3175 : e
->value
.function
.isym
->name
;
3176 e
->symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, fname
);
3181 /* This is probably a reference to a private procedure from another
3182 module. To prevent a segfault, make a generic with no specific
3183 instances. If this module is used, without the required
3184 specific coming from somewhere, the appropriate error message
3186 gfc_get_symbol (fname
, gfc_current_ns
, &sym
);
3187 sym
->attr
.flavor
= FL_PROCEDURE
;
3188 sym
->attr
.generic
= 1;
3189 e
->symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, fname
);
3190 gfc_commit_symbol (sym
);
3195 /* Read and write expressions. The form "()" is allowed to indicate a
3199 mio_expr (gfc_expr
**ep
)
3207 if (iomode
== IO_OUTPUT
)
3216 MIO_NAME (expr_t
) (e
->expr_type
, expr_types
);
3221 if (t
== ATOM_RPAREN
)
3228 bad_module ("Expected expression type");
3230 e
= *ep
= gfc_get_expr ();
3231 e
->where
= gfc_current_locus
;
3232 e
->expr_type
= (expr_t
) find_enum (expr_types
);
3235 mio_typespec (&e
->ts
);
3236 mio_integer (&e
->rank
);
3240 switch (e
->expr_type
)
3244 = MIO_NAME (gfc_intrinsic_op
) (e
->value
.op
.op
, intrinsics
);
3246 switch (e
->value
.op
.op
)
3248 case INTRINSIC_UPLUS
:
3249 case INTRINSIC_UMINUS
:
3251 case INTRINSIC_PARENTHESES
:
3252 mio_expr (&e
->value
.op
.op1
);
3255 case INTRINSIC_PLUS
:
3256 case INTRINSIC_MINUS
:
3257 case INTRINSIC_TIMES
:
3258 case INTRINSIC_DIVIDE
:
3259 case INTRINSIC_POWER
:
3260 case INTRINSIC_CONCAT
:
3264 case INTRINSIC_NEQV
:
3266 case INTRINSIC_EQ_OS
:
3268 case INTRINSIC_NE_OS
:
3270 case INTRINSIC_GT_OS
:
3272 case INTRINSIC_GE_OS
:
3274 case INTRINSIC_LT_OS
:
3276 case INTRINSIC_LE_OS
:
3277 mio_expr (&e
->value
.op
.op1
);
3278 mio_expr (&e
->value
.op
.op2
);
3282 bad_module ("Bad operator");
3288 mio_symtree_ref (&e
->symtree
);
3289 mio_actual_arglist (&e
->value
.function
.actual
);
3291 if (iomode
== IO_OUTPUT
)
3293 e
->value
.function
.name
3294 = mio_allocated_string (e
->value
.function
.name
);
3295 flag
= e
->value
.function
.esym
!= NULL
;
3296 mio_integer (&flag
);
3298 mio_symbol_ref (&e
->value
.function
.esym
);
3300 write_atom (ATOM_STRING
, e
->value
.function
.isym
->name
);
3304 require_atom (ATOM_STRING
);
3305 e
->value
.function
.name
= gfc_get_string (atom_string
);
3308 mio_integer (&flag
);
3310 mio_symbol_ref (&e
->value
.function
.esym
);
3313 require_atom (ATOM_STRING
);
3314 e
->value
.function
.isym
= gfc_find_function (atom_string
);
3322 mio_symtree_ref (&e
->symtree
);
3323 mio_ref_list (&e
->ref
);
3326 case EXPR_SUBSTRING
:
3327 e
->value
.character
.string
3328 = CONST_CAST (gfc_char_t
*,
3329 mio_allocated_wide_string (e
->value
.character
.string
,
3330 e
->value
.character
.length
));
3331 mio_ref_list (&e
->ref
);
3334 case EXPR_STRUCTURE
:
3336 mio_constructor (&e
->value
.constructor
);
3337 mio_shape (&e
->shape
, e
->rank
);
3344 mio_gmp_integer (&e
->value
.integer
);
3348 gfc_set_model_kind (e
->ts
.kind
);
3349 mio_gmp_real (&e
->value
.real
);
3353 gfc_set_model_kind (e
->ts
.kind
);
3354 mio_gmp_real (&mpc_realref (e
->value
.complex));
3355 mio_gmp_real (&mpc_imagref (e
->value
.complex));
3359 mio_integer (&e
->value
.logical
);
3363 mio_integer (&e
->value
.character
.length
);
3364 e
->value
.character
.string
3365 = CONST_CAST (gfc_char_t
*,
3366 mio_allocated_wide_string (e
->value
.character
.string
,
3367 e
->value
.character
.length
));
3371 bad_module ("Bad type in constant expression");
3389 /* Read and write namelists. */
3392 mio_namelist (gfc_symbol
*sym
)
3394 gfc_namelist
*n
, *m
;
3395 const char *check_name
;
3399 if (iomode
== IO_OUTPUT
)
3401 for (n
= sym
->namelist
; n
; n
= n
->next
)
3402 mio_symbol_ref (&n
->sym
);
3406 /* This departure from the standard is flagged as an error.
3407 It does, in fact, work correctly. TODO: Allow it
3409 if (sym
->attr
.flavor
== FL_NAMELIST
)
3411 check_name
= find_use_name (sym
->name
, false);
3412 if (check_name
&& strcmp (check_name
, sym
->name
) != 0)
3413 gfc_error ("Namelist %s cannot be renamed by USE "
3414 "association to %s", sym
->name
, check_name
);
3418 while (peek_atom () != ATOM_RPAREN
)
3420 n
= gfc_get_namelist ();
3421 mio_symbol_ref (&n
->sym
);
3423 if (sym
->namelist
== NULL
)
3430 sym
->namelist_tail
= m
;
3437 /* Save/restore lists of gfc_interface structures. When loading an
3438 interface, we are really appending to the existing list of
3439 interfaces. Checking for duplicate and ambiguous interfaces has to
3440 be done later when all symbols have been loaded. */
3443 mio_interface_rest (gfc_interface
**ip
)
3445 gfc_interface
*tail
, *p
;
3446 pointer_info
*pi
= NULL
;
3448 if (iomode
== IO_OUTPUT
)
3451 for (p
= *ip
; p
; p
= p
->next
)
3452 mio_symbol_ref (&p
->sym
);
3467 if (peek_atom () == ATOM_RPAREN
)
3470 p
= gfc_get_interface ();
3471 p
->where
= gfc_current_locus
;
3472 pi
= mio_symbol_ref (&p
->sym
);
3488 /* Save/restore a nameless operator interface. */
3491 mio_interface (gfc_interface
**ip
)
3494 mio_interface_rest (ip
);
3498 /* Save/restore a named operator interface. */
3501 mio_symbol_interface (const char **name
, const char **module
,
3505 mio_pool_string (name
);
3506 mio_pool_string (module
);
3507 mio_interface_rest (ip
);
3512 mio_namespace_ref (gfc_namespace
**nsp
)
3517 p
= mio_pointer_ref (nsp
);
3519 if (p
->type
== P_UNKNOWN
)
3520 p
->type
= P_NAMESPACE
;
3522 if (iomode
== IO_INPUT
&& p
->integer
!= 0)
3524 ns
= (gfc_namespace
*) p
->u
.pointer
;
3527 ns
= gfc_get_namespace (NULL
, 0);
3528 associate_integer_pointer (p
, ns
);
3536 /* Save/restore the f2k_derived namespace of a derived-type symbol. */
3538 static gfc_namespace
* current_f2k_derived
;
3541 mio_typebound_proc (gfc_typebound_proc
** proc
)
3544 int overriding_flag
;
3546 if (iomode
== IO_INPUT
)
3548 *proc
= gfc_get_typebound_proc (NULL
);
3549 (*proc
)->where
= gfc_current_locus
;
3555 (*proc
)->access
= MIO_NAME (gfc_access
) ((*proc
)->access
, access_types
);
3557 /* IO the NON_OVERRIDABLE/DEFERRED combination. */
3558 gcc_assert (!((*proc
)->deferred
&& (*proc
)->non_overridable
));
3559 overriding_flag
= ((*proc
)->deferred
<< 1) | (*proc
)->non_overridable
;
3560 overriding_flag
= mio_name (overriding_flag
, binding_overriding
);
3561 (*proc
)->deferred
= ((overriding_flag
& 2) != 0);
3562 (*proc
)->non_overridable
= ((overriding_flag
& 1) != 0);
3563 gcc_assert (!((*proc
)->deferred
&& (*proc
)->non_overridable
));
3565 (*proc
)->nopass
= mio_name ((*proc
)->nopass
, binding_passing
);
3566 (*proc
)->is_generic
= mio_name ((*proc
)->is_generic
, binding_generic
);
3567 (*proc
)->ppc
= mio_name((*proc
)->ppc
, binding_ppc
);
3569 mio_pool_string (&((*proc
)->pass_arg
));
3571 flag
= (int) (*proc
)->pass_arg_num
;
3572 mio_integer (&flag
);
3573 (*proc
)->pass_arg_num
= (unsigned) flag
;
3575 if ((*proc
)->is_generic
)
3582 if (iomode
== IO_OUTPUT
)
3583 for (g
= (*proc
)->u
.generic
; g
; g
= g
->next
)
3585 iop
= (int) g
->is_operator
;
3587 mio_allocated_string (g
->specific_st
->name
);
3591 (*proc
)->u
.generic
= NULL
;
3592 while (peek_atom () != ATOM_RPAREN
)
3594 gfc_symtree
** sym_root
;
3596 g
= gfc_get_tbp_generic ();
3600 g
->is_operator
= (bool) iop
;
3602 require_atom (ATOM_STRING
);
3603 sym_root
= ¤t_f2k_derived
->tb_sym_root
;
3604 g
->specific_st
= gfc_get_tbp_symtree (sym_root
, atom_string
);
3607 g
->next
= (*proc
)->u
.generic
;
3608 (*proc
)->u
.generic
= g
;
3614 else if (!(*proc
)->ppc
)
3615 mio_symtree_ref (&(*proc
)->u
.specific
);
3620 /* Walker-callback function for this purpose. */
3622 mio_typebound_symtree (gfc_symtree
* st
)
3624 if (iomode
== IO_OUTPUT
&& !st
->n
.tb
)
3627 if (iomode
== IO_OUTPUT
)
3630 mio_allocated_string (st
->name
);
3632 /* For IO_INPUT, the above is done in mio_f2k_derived. */
3634 mio_typebound_proc (&st
->n
.tb
);
3638 /* IO a full symtree (in all depth). */
3640 mio_full_typebound_tree (gfc_symtree
** root
)
3644 if (iomode
== IO_OUTPUT
)
3645 gfc_traverse_symtree (*root
, &mio_typebound_symtree
);
3648 while (peek_atom () == ATOM_LPAREN
)
3654 require_atom (ATOM_STRING
);
3655 st
= gfc_get_tbp_symtree (root
, atom_string
);
3658 mio_typebound_symtree (st
);
3666 mio_finalizer (gfc_finalizer
**f
)
3668 if (iomode
== IO_OUTPUT
)
3671 gcc_assert ((*f
)->proc_tree
); /* Should already be resolved. */
3672 mio_symtree_ref (&(*f
)->proc_tree
);
3676 *f
= gfc_get_finalizer ();
3677 (*f
)->where
= gfc_current_locus
; /* Value should not matter. */
3680 mio_symtree_ref (&(*f
)->proc_tree
);
3681 (*f
)->proc_sym
= NULL
;
3686 mio_f2k_derived (gfc_namespace
*f2k
)
3688 current_f2k_derived
= f2k
;
3690 /* Handle the list of finalizer procedures. */
3692 if (iomode
== IO_OUTPUT
)
3695 for (f
= f2k
->finalizers
; f
; f
= f
->next
)
3700 f2k
->finalizers
= NULL
;
3701 while (peek_atom () != ATOM_RPAREN
)
3703 gfc_finalizer
*cur
= NULL
;
3704 mio_finalizer (&cur
);
3705 cur
->next
= f2k
->finalizers
;
3706 f2k
->finalizers
= cur
;
3711 /* Handle type-bound procedures. */
3712 mio_full_typebound_tree (&f2k
->tb_sym_root
);
3714 /* Type-bound user operators. */
3715 mio_full_typebound_tree (&f2k
->tb_uop_root
);
3717 /* Type-bound intrinsic operators. */
3719 if (iomode
== IO_OUTPUT
)
3722 for (op
= GFC_INTRINSIC_BEGIN
; op
!= GFC_INTRINSIC_END
; ++op
)
3724 gfc_intrinsic_op realop
;
3726 if (op
== INTRINSIC_USER
|| !f2k
->tb_op
[op
])
3730 realop
= (gfc_intrinsic_op
) op
;
3731 mio_intrinsic_op (&realop
);
3732 mio_typebound_proc (&f2k
->tb_op
[op
]);
3737 while (peek_atom () != ATOM_RPAREN
)
3739 gfc_intrinsic_op op
= GFC_INTRINSIC_BEGIN
; /* Silence GCC. */
3742 mio_intrinsic_op (&op
);
3743 mio_typebound_proc (&f2k
->tb_op
[op
]);
3750 mio_full_f2k_derived (gfc_symbol
*sym
)
3754 if (iomode
== IO_OUTPUT
)
3756 if (sym
->f2k_derived
)
3757 mio_f2k_derived (sym
->f2k_derived
);
3761 if (peek_atom () != ATOM_RPAREN
)
3763 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
3764 mio_f2k_derived (sym
->f2k_derived
);
3767 gcc_assert (!sym
->f2k_derived
);
3774 /* Unlike most other routines, the address of the symbol node is already
3775 fixed on input and the name/module has already been filled in. */
3778 mio_symbol (gfc_symbol
*sym
)
3780 int intmod
= INTMOD_NONE
;
3784 mio_symbol_attribute (&sym
->attr
);
3785 mio_typespec (&sym
->ts
);
3786 if (sym
->ts
.type
== BT_CLASS
)
3787 sym
->attr
.class_ok
= 1;
3789 if (iomode
== IO_OUTPUT
)
3790 mio_namespace_ref (&sym
->formal_ns
);
3793 mio_namespace_ref (&sym
->formal_ns
);
3795 sym
->formal_ns
->proc_name
= sym
;
3798 /* Save/restore common block links. */
3799 mio_symbol_ref (&sym
->common_next
);
3801 mio_formal_arglist (&sym
->formal
);
3803 if (sym
->attr
.flavor
== FL_PARAMETER
)
3804 mio_expr (&sym
->value
);
3806 mio_array_spec (&sym
->as
);
3808 mio_symbol_ref (&sym
->result
);
3810 if (sym
->attr
.cray_pointee
)
3811 mio_symbol_ref (&sym
->cp_pointer
);
3813 /* Note that components are always saved, even if they are supposed
3814 to be private. Component access is checked during searching. */
3816 mio_component_list (&sym
->components
, sym
->attr
.vtype
);
3818 if (sym
->components
!= NULL
)
3819 sym
->component_access
3820 = MIO_NAME (gfc_access
) (sym
->component_access
, access_types
);
3822 /* Load/save the f2k_derived namespace of a derived-type symbol. */
3823 mio_full_f2k_derived (sym
);
3827 /* Add the fields that say whether this is from an intrinsic module,
3828 and if so, what symbol it is within the module. */
3829 /* mio_integer (&(sym->from_intmod)); */
3830 if (iomode
== IO_OUTPUT
)
3832 intmod
= sym
->from_intmod
;
3833 mio_integer (&intmod
);
3837 mio_integer (&intmod
);
3838 sym
->from_intmod
= (intmod_id
) intmod
;
3841 mio_integer (&(sym
->intmod_sym_id
));
3843 if (sym
->attr
.flavor
== FL_DERIVED
)
3844 mio_integer (&(sym
->hash_value
));
3850 /************************* Top level subroutines *************************/
3852 /* Given a root symtree node and a symbol, try to find a symtree that
3853 references the symbol that is not a unique name. */
3855 static gfc_symtree
*
3856 find_symtree_for_symbol (gfc_symtree
*st
, gfc_symbol
*sym
)
3858 gfc_symtree
*s
= NULL
;
3863 s
= find_symtree_for_symbol (st
->right
, sym
);
3866 s
= find_symtree_for_symbol (st
->left
, sym
);
3870 if (st
->n
.sym
== sym
&& !check_unique_name (st
->name
))
3877 /* A recursive function to look for a specific symbol by name and by
3878 module. Whilst several symtrees might point to one symbol, its
3879 is sufficient for the purposes here than one exist. Note that
3880 generic interfaces are distinguished as are symbols that have been
3881 renamed in another module. */
3882 static gfc_symtree
*
3883 find_symbol (gfc_symtree
*st
, const char *name
,
3884 const char *module
, int generic
)
3887 gfc_symtree
*retval
, *s
;
3889 if (st
== NULL
|| st
->n
.sym
== NULL
)
3892 c
= strcmp (name
, st
->n
.sym
->name
);
3893 if (c
== 0 && st
->n
.sym
->module
3894 && strcmp (module
, st
->n
.sym
->module
) == 0
3895 && !check_unique_name (st
->name
))
3897 s
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
3899 /* Detect symbols that are renamed by use association in another
3900 module by the absence of a symtree and null attr.use_rename,
3901 since the latter is not transmitted in the module file. */
3902 if (((!generic
&& !st
->n
.sym
->attr
.generic
)
3903 || (generic
&& st
->n
.sym
->attr
.generic
))
3904 && !(s
== NULL
&& !st
->n
.sym
->attr
.use_rename
))
3908 retval
= find_symbol (st
->left
, name
, module
, generic
);
3911 retval
= find_symbol (st
->right
, name
, module
, generic
);
3917 /* Skip a list between balanced left and right parens. */
3927 switch (parse_atom ())
3950 /* Load operator interfaces from the module. Interfaces are unusual
3951 in that they attach themselves to existing symbols. */
3954 load_operator_interfaces (void)
3957 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[GFC_MAX_SYMBOL_LEN
+ 1];
3959 pointer_info
*pi
= NULL
;
3964 while (peek_atom () != ATOM_RPAREN
)
3968 mio_internal_string (name
);
3969 mio_internal_string (module
);
3971 n
= number_use_names (name
, true);
3974 for (i
= 1; i
<= n
; i
++)
3976 /* Decide if we need to load this one or not. */
3977 p
= find_use_name_n (name
, &i
, true);
3981 while (parse_atom () != ATOM_RPAREN
);
3987 uop
= gfc_get_uop (p
);
3988 pi
= mio_interface_rest (&uop
->op
);
3992 if (gfc_find_uop (p
, NULL
))
3994 uop
= gfc_get_uop (p
);
3995 uop
->op
= gfc_get_interface ();
3996 uop
->op
->where
= gfc_current_locus
;
3997 add_fixup (pi
->integer
, &uop
->op
->sym
);
4006 /* Load interfaces from the module. Interfaces are unusual in that
4007 they attach themselves to existing symbols. */
4010 load_generic_interfaces (void)
4013 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[GFC_MAX_SYMBOL_LEN
+ 1];
4015 gfc_interface
*generic
= NULL
, *gen
= NULL
;
4017 bool ambiguous_set
= false;
4021 while (peek_atom () != ATOM_RPAREN
)
4025 mio_internal_string (name
);
4026 mio_internal_string (module
);
4028 n
= number_use_names (name
, false);
4029 renamed
= n
? 1 : 0;
4032 for (i
= 1; i
<= n
; i
++)
4035 /* Decide if we need to load this one or not. */
4036 p
= find_use_name_n (name
, &i
, false);
4038 st
= find_symbol (gfc_current_ns
->sym_root
,
4039 name
, module_name
, 1);
4041 if (!p
|| gfc_find_symbol (p
, NULL
, 0, &sym
))
4043 /* Skip the specific names for these cases. */
4044 while (i
== 1 && parse_atom () != ATOM_RPAREN
);
4049 /* If the symbol exists already and is being USEd without being
4050 in an ONLY clause, do not load a new symtree(11.3.2). */
4051 if (!only_flag
&& st
)
4059 if (strcmp (st
->name
, p
) != 0)
4061 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, p
);
4067 /* Since we haven't found a valid generic interface, we had
4071 gfc_get_symbol (p
, NULL
, &sym
);
4072 sym
->name
= gfc_get_string (name
);
4073 sym
->module
= module_name
;
4074 sym
->attr
.flavor
= FL_PROCEDURE
;
4075 sym
->attr
.generic
= 1;
4076 sym
->attr
.use_assoc
= 1;
4081 /* Unless sym is a generic interface, this reference
4084 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
4088 if (st
&& !sym
->attr
.generic
4091 && strcmp(module
, sym
->module
))
4093 ambiguous_set
= true;
4098 sym
->attr
.use_only
= only_flag
;
4099 sym
->attr
.use_rename
= renamed
;
4103 mio_interface_rest (&sym
->generic
);
4104 generic
= sym
->generic
;
4106 else if (!sym
->generic
)
4108 sym
->generic
= generic
;
4109 sym
->attr
.generic_copy
= 1;
4112 /* If a procedure that is not generic has generic interfaces
4113 that include itself, it is generic! We need to take care
4114 to retain symbols ambiguous that were already so. */
4115 if (sym
->attr
.use_assoc
4116 && !sym
->attr
.generic
4117 && sym
->attr
.flavor
== FL_PROCEDURE
)
4119 for (gen
= generic
; gen
; gen
= gen
->next
)
4121 if (gen
->sym
== sym
)
4123 sym
->attr
.generic
= 1;
4138 /* Load common blocks. */
4143 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4148 while (peek_atom () != ATOM_RPAREN
)
4153 mio_internal_string (name
);
4155 p
= gfc_get_common (name
, 1);
4157 mio_symbol_ref (&p
->head
);
4158 mio_integer (&flags
);
4162 p
->threadprivate
= 1;
4165 /* Get whether this was a bind(c) common or not. */
4166 mio_integer (&p
->is_bind_c
);
4167 /* Get the binding label. */
4168 label
= read_string ();
4170 p
->binding_label
= IDENTIFIER_POINTER (get_identifier (label
));
4180 /* Load equivalences. The flag in_load_equiv informs mio_expr_ref of this
4181 so that unused variables are not loaded and so that the expression can
4187 gfc_equiv
*head
, *tail
, *end
, *eq
;
4191 in_load_equiv
= true;
4193 end
= gfc_current_ns
->equiv
;
4194 while (end
!= NULL
&& end
->next
!= NULL
)
4197 while (peek_atom () != ATOM_RPAREN
) {
4201 while(peek_atom () != ATOM_RPAREN
)
4204 head
= tail
= gfc_get_equiv ();
4207 tail
->eq
= gfc_get_equiv ();
4211 mio_pool_string (&tail
->module
);
4212 mio_expr (&tail
->expr
);
4215 /* Unused equivalence members have a unique name. In addition, it
4216 must be checked that the symbols are from the same module. */
4218 for (eq
= head
; eq
; eq
= eq
->eq
)
4220 if (eq
->expr
->symtree
->n
.sym
->module
4221 && head
->expr
->symtree
->n
.sym
->module
4222 && strcmp (head
->expr
->symtree
->n
.sym
->module
,
4223 eq
->expr
->symtree
->n
.sym
->module
) == 0
4224 && !check_unique_name (eq
->expr
->symtree
->name
))
4233 for (eq
= head
; eq
; eq
= head
)
4236 gfc_free_expr (eq
->expr
);
4242 gfc_current_ns
->equiv
= head
;
4253 in_load_equiv
= false;
4257 /* This function loads the sym_root of f2k_derived with the extensions to
4258 the derived type. */
4260 load_derived_extensions (void)
4263 gfc_symbol
*derived
;
4267 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4268 char module
[GFC_MAX_SYMBOL_LEN
+ 1];
4272 while (peek_atom () != ATOM_RPAREN
)
4275 mio_integer (&symbol
);
4276 info
= get_integer (symbol
);
4277 derived
= info
->u
.rsym
.sym
;
4279 /* This one is not being loaded. */
4280 if (!info
|| !derived
)
4282 while (peek_atom () != ATOM_RPAREN
)
4287 gcc_assert (derived
->attr
.flavor
== FL_DERIVED
);
4288 if (derived
->f2k_derived
== NULL
)
4289 derived
->f2k_derived
= gfc_get_namespace (NULL
, 0);
4291 while (peek_atom () != ATOM_RPAREN
)
4294 mio_internal_string (name
);
4295 mio_internal_string (module
);
4297 /* Only use one use name to find the symbol. */
4299 p
= find_use_name_n (name
, &j
, false);
4302 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
4304 st
= gfc_find_symtree (derived
->f2k_derived
->sym_root
, name
);
4307 /* Only use the real name in f2k_derived to ensure a single
4309 st
= gfc_new_symtree (&derived
->f2k_derived
->sym_root
, name
);
4322 /* Recursive function to traverse the pointer_info tree and load a
4323 needed symbol. We return nonzero if we load a symbol and stop the
4324 traversal, because the act of loading can alter the tree. */
4327 load_needed (pointer_info
*p
)
4338 rv
|= load_needed (p
->left
);
4339 rv
|= load_needed (p
->right
);
4341 if (p
->type
!= P_SYMBOL
|| p
->u
.rsym
.state
!= NEEDED
)
4344 p
->u
.rsym
.state
= USED
;
4346 set_module_locus (&p
->u
.rsym
.where
);
4348 sym
= p
->u
.rsym
.sym
;
4351 q
= get_integer (p
->u
.rsym
.ns
);
4353 ns
= (gfc_namespace
*) q
->u
.pointer
;
4356 /* Create an interface namespace if necessary. These are
4357 the namespaces that hold the formal parameters of module
4360 ns
= gfc_get_namespace (NULL
, 0);
4361 associate_integer_pointer (q
, ns
);
4364 /* Use the module sym as 'proc_name' so that gfc_get_symbol_decl
4365 doesn't go pear-shaped if the symbol is used. */
4367 gfc_find_symbol (p
->u
.rsym
.module
, gfc_current_ns
,
4370 sym
= gfc_new_symbol (p
->u
.rsym
.true_name
, ns
);
4371 sym
->name
= dt_lower_string (p
->u
.rsym
.true_name
);
4372 sym
->module
= gfc_get_string (p
->u
.rsym
.module
);
4373 if (p
->u
.rsym
.binding_label
)
4374 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier
4375 (p
->u
.rsym
.binding_label
));
4377 associate_integer_pointer (p
, sym
);
4381 sym
->attr
.use_assoc
= 1;
4383 /* Mark as only or rename for later diagnosis for explicitly imported
4384 but not used warnings; don't mark internal symbols such as __vtab,
4385 __def_init etc. Only mark them if they have been explicitly loaded. */
4387 if (only_flag
&& sym
->name
[0] != '_' && sym
->name
[1] != '_')
4391 /* Search the use/rename list for the variable; if the variable is
4393 for (u
= gfc_rename_list
; u
; u
= u
->next
)
4395 if (strcmp (u
->use_name
, sym
->name
) == 0)
4397 sym
->attr
.use_only
= 1;
4403 if (p
->u
.rsym
.renamed
)
4404 sym
->attr
.use_rename
= 1;
4410 /* Recursive function for cleaning up things after a module has been read. */
4413 read_cleanup (pointer_info
*p
)
4421 read_cleanup (p
->left
);
4422 read_cleanup (p
->right
);
4424 if (p
->type
== P_SYMBOL
&& p
->u
.rsym
.state
== USED
&& !p
->u
.rsym
.referenced
)
4427 /* Add hidden symbols to the symtree. */
4428 q
= get_integer (p
->u
.rsym
.ns
);
4429 ns
= (gfc_namespace
*) q
->u
.pointer
;
4431 if (!p
->u
.rsym
.sym
->attr
.vtype
4432 && !p
->u
.rsym
.sym
->attr
.vtab
)
4433 st
= gfc_get_unique_symtree (ns
);
4436 /* There is no reason to use 'unique_symtrees' for vtabs or
4437 vtypes - their name is fine for a symtree and reduces the
4438 namespace pollution. */
4439 st
= gfc_find_symtree (ns
->sym_root
, p
->u
.rsym
.sym
->name
);
4441 st
= gfc_new_symtree (&ns
->sym_root
, p
->u
.rsym
.sym
->name
);
4444 st
->n
.sym
= p
->u
.rsym
.sym
;
4447 /* Fixup any symtree references. */
4448 p
->u
.rsym
.symtree
= st
;
4449 resolve_fixups (p
->u
.rsym
.stfixup
, st
);
4450 p
->u
.rsym
.stfixup
= NULL
;
4453 /* Free unused symbols. */
4454 if (p
->type
== P_SYMBOL
&& p
->u
.rsym
.state
== UNUSED
)
4455 gfc_free_symbol (p
->u
.rsym
.sym
);
4459 /* It is not quite enough to check for ambiguity in the symbols by
4460 the loaded symbol and the new symbol not being identical. */
4462 check_for_ambiguous (gfc_symbol
*st_sym
, pointer_info
*info
)
4466 symbol_attribute attr
;
4468 if (st_sym
->name
== gfc_current_ns
->proc_name
->name
)
4470 gfc_error ("'%s' of module '%s', imported at %C, is also the name of the "
4471 "current program unit", st_sym
->name
, module_name
);
4475 rsym
= info
->u
.rsym
.sym
;
4479 if (st_sym
->attr
.vtab
|| st_sym
->attr
.vtype
)
4482 /* If the existing symbol is generic from a different module and
4483 the new symbol is generic there can be no ambiguity. */
4484 if (st_sym
->attr
.generic
4486 && st_sym
->module
!= module_name
)
4488 /* The new symbol's attributes have not yet been read. Since
4489 we need attr.generic, read it directly. */
4490 get_module_locus (&locus
);
4491 set_module_locus (&info
->u
.rsym
.where
);
4494 mio_symbol_attribute (&attr
);
4495 set_module_locus (&locus
);
4504 /* Read a module file. */
4509 module_locus operator_interfaces
, user_operators
, extensions
;
4511 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4513 int ambiguous
, j
, nuse
, symbol
;
4514 pointer_info
*info
, *q
;
4515 gfc_use_rename
*u
= NULL
;
4519 get_module_locus (&operator_interfaces
); /* Skip these for now. */
4522 get_module_locus (&user_operators
);
4526 /* Skip commons, equivalences and derived type extensions for now. */
4530 get_module_locus (&extensions
);
4535 /* Create the fixup nodes for all the symbols. */
4537 while (peek_atom () != ATOM_RPAREN
)
4540 require_atom (ATOM_INTEGER
);
4541 info
= get_integer (atom_int
);
4543 info
->type
= P_SYMBOL
;
4544 info
->u
.rsym
.state
= UNUSED
;
4546 info
->u
.rsym
.true_name
= read_string ();
4547 info
->u
.rsym
.module
= read_string ();
4548 bind_label
= read_string ();
4549 if (strlen (bind_label
))
4550 info
->u
.rsym
.binding_label
= bind_label
;
4552 XDELETEVEC (bind_label
);
4554 require_atom (ATOM_INTEGER
);
4555 info
->u
.rsym
.ns
= atom_int
;
4557 get_module_locus (&info
->u
.rsym
.where
);
4560 /* See if the symbol has already been loaded by a previous module.
4561 If so, we reference the existing symbol and prevent it from
4562 being loaded again. This should not happen if the symbol being
4563 read is an index for an assumed shape dummy array (ns != 1). */
4565 sym
= find_true_name (info
->u
.rsym
.true_name
, info
->u
.rsym
.module
);
4568 || (sym
->attr
.flavor
== FL_VARIABLE
&& info
->u
.rsym
.ns
!=1))
4571 info
->u
.rsym
.state
= USED
;
4572 info
->u
.rsym
.sym
= sym
;
4574 /* Some symbols do not have a namespace (eg. formal arguments),
4575 so the automatic "unique symtree" mechanism must be suppressed
4576 by marking them as referenced. */
4577 q
= get_integer (info
->u
.rsym
.ns
);
4578 if (q
->u
.pointer
== NULL
)
4580 info
->u
.rsym
.referenced
= 1;
4584 /* If possible recycle the symtree that references the symbol.
4585 If a symtree is not found and the module does not import one,
4586 a unique-name symtree is found by read_cleanup. */
4587 st
= find_symtree_for_symbol (gfc_current_ns
->sym_root
, sym
);
4590 info
->u
.rsym
.symtree
= st
;
4591 info
->u
.rsym
.referenced
= 1;
4597 /* Parse the symtree lists. This lets us mark which symbols need to
4598 be loaded. Renaming is also done at this point by replacing the
4603 while (peek_atom () != ATOM_RPAREN
)
4605 mio_internal_string (name
);
4606 mio_integer (&ambiguous
);
4607 mio_integer (&symbol
);
4609 info
= get_integer (symbol
);
4611 /* See how many use names there are. If none, go through the start
4612 of the loop at least once. */
4613 nuse
= number_use_names (name
, false);
4614 info
->u
.rsym
.renamed
= nuse
? 1 : 0;
4619 for (j
= 1; j
<= nuse
; j
++)
4621 /* Get the jth local name for this symbol. */
4622 p
= find_use_name_n (name
, &j
, false);
4624 if (p
== NULL
&& strcmp (name
, module_name
) == 0)
4627 /* Exception: Always import vtabs & vtypes. */
4628 if (p
== NULL
&& name
[0] == '_'
4629 && (strncmp (name
, "__vtab_", 5) == 0
4630 || strncmp (name
, "__vtype_", 6) == 0))
4633 /* Skip symtree nodes not in an ONLY clause, unless there
4634 is an existing symtree loaded from another USE statement. */
4637 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
4639 && strcmp (st
->n
.sym
->name
, info
->u
.rsym
.true_name
) == 0
4640 && st
->n
.sym
->module
!= NULL
4641 && strcmp (st
->n
.sym
->module
, info
->u
.rsym
.module
) == 0)
4643 info
->u
.rsym
.symtree
= st
;
4644 info
->u
.rsym
.sym
= st
->n
.sym
;
4649 /* If a symbol of the same name and module exists already,
4650 this symbol, which is not in an ONLY clause, must not be
4651 added to the namespace(11.3.2). Note that find_symbol
4652 only returns the first occurrence that it finds. */
4653 if (!only_flag
&& !info
->u
.rsym
.renamed
4654 && strcmp (name
, module_name
) != 0
4655 && find_symbol (gfc_current_ns
->sym_root
, name
,
4659 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
4663 /* Check for ambiguous symbols. */
4664 if (check_for_ambiguous (st
->n
.sym
, info
))
4667 info
->u
.rsym
.symtree
= st
;
4671 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
4673 /* Create a symtree node in the current namespace for this
4675 st
= check_unique_name (p
)
4676 ? gfc_get_unique_symtree (gfc_current_ns
)
4677 : gfc_new_symtree (&gfc_current_ns
->sym_root
, p
);
4678 st
->ambiguous
= ambiguous
;
4680 sym
= info
->u
.rsym
.sym
;
4682 /* Create a symbol node if it doesn't already exist. */
4685 info
->u
.rsym
.sym
= gfc_new_symbol (info
->u
.rsym
.true_name
,
4687 info
->u
.rsym
.sym
->name
= dt_lower_string (info
->u
.rsym
.true_name
);
4688 sym
= info
->u
.rsym
.sym
;
4689 sym
->module
= gfc_get_string (info
->u
.rsym
.module
);
4691 if (info
->u
.rsym
.binding_label
)
4692 sym
->binding_label
=
4693 IDENTIFIER_POINTER (get_identifier
4694 (info
->u
.rsym
.binding_label
));
4700 if (strcmp (name
, p
) != 0)
4701 sym
->attr
.use_rename
= 1;
4704 || (strncmp (name
, "__vtab_", 5) != 0
4705 && strncmp (name
, "__vtype_", 6) != 0))
4706 sym
->attr
.use_only
= only_flag
;
4708 /* Store the symtree pointing to this symbol. */
4709 info
->u
.rsym
.symtree
= st
;
4711 if (info
->u
.rsym
.state
== UNUSED
)
4712 info
->u
.rsym
.state
= NEEDED
;
4713 info
->u
.rsym
.referenced
= 1;
4720 /* Load intrinsic operator interfaces. */
4721 set_module_locus (&operator_interfaces
);
4724 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
4726 if (i
== INTRINSIC_USER
)
4731 u
= find_use_operator ((gfc_intrinsic_op
) i
);
4742 mio_interface (&gfc_current_ns
->op
[i
]);
4743 if (u
&& !gfc_current_ns
->op
[i
])
4749 /* Load generic and user operator interfaces. These must follow the
4750 loading of symtree because otherwise symbols can be marked as
4753 set_module_locus (&user_operators
);
4755 load_operator_interfaces ();
4756 load_generic_interfaces ();
4761 /* At this point, we read those symbols that are needed but haven't
4762 been loaded yet. If one symbol requires another, the other gets
4763 marked as NEEDED if its previous state was UNUSED. */
4765 while (load_needed (pi_root
));
4767 /* Make sure all elements of the rename-list were found in the module. */
4769 for (u
= gfc_rename_list
; u
; u
= u
->next
)
4774 if (u
->op
== INTRINSIC_NONE
)
4776 gfc_error ("Symbol '%s' referenced at %L not found in module '%s'",
4777 u
->use_name
, &u
->where
, module_name
);
4781 if (u
->op
== INTRINSIC_USER
)
4783 gfc_error ("User operator '%s' referenced at %L not found "
4784 "in module '%s'", u
->use_name
, &u
->where
, module_name
);
4788 gfc_error ("Intrinsic operator '%s' referenced at %L not found "
4789 "in module '%s'", gfc_op2string (u
->op
), &u
->where
,
4793 /* Now we should be in a position to fill f2k_derived with derived type
4794 extensions, since everything has been loaded. */
4795 set_module_locus (&extensions
);
4796 load_derived_extensions ();
4798 /* Clean up symbol nodes that were never loaded, create references
4799 to hidden symbols. */
4801 read_cleanup (pi_root
);
4805 /* Given an access type that is specific to an entity and the default
4806 access, return nonzero if the entity is publicly accessible. If the
4807 element is declared as PUBLIC, then it is public; if declared
4808 PRIVATE, then private, and otherwise it is public unless the default
4809 access in this context has been declared PRIVATE. */
4812 check_access (gfc_access specific_access
, gfc_access default_access
)
4814 if (specific_access
== ACCESS_PUBLIC
)
4816 if (specific_access
== ACCESS_PRIVATE
)
4819 if (gfc_option
.flag_module_private
)
4820 return default_access
== ACCESS_PUBLIC
;
4822 return default_access
!= ACCESS_PRIVATE
;
4827 gfc_check_symbol_access (gfc_symbol
*sym
)
4829 if (sym
->attr
.vtab
|| sym
->attr
.vtype
)
4832 return check_access (sym
->attr
.access
, sym
->ns
->default_access
);
4836 /* A structure to remember which commons we've already written. */
4838 struct written_common
4840 BBT_HEADER(written_common
);
4841 const char *name
, *label
;
4844 static struct written_common
*written_commons
= NULL
;
4846 /* Comparison function used for balancing the binary tree. */
4849 compare_written_commons (void *a1
, void *b1
)
4851 const char *aname
= ((struct written_common
*) a1
)->name
;
4852 const char *alabel
= ((struct written_common
*) a1
)->label
;
4853 const char *bname
= ((struct written_common
*) b1
)->name
;
4854 const char *blabel
= ((struct written_common
*) b1
)->label
;
4855 int c
= strcmp (aname
, bname
);
4857 return (c
!= 0 ? c
: strcmp (alabel
, blabel
));
4860 /* Free a list of written commons. */
4863 free_written_common (struct written_common
*w
)
4869 free_written_common (w
->left
);
4871 free_written_common (w
->right
);
4876 /* Write a common block to the module -- recursive helper function. */
4879 write_common_0 (gfc_symtree
*st
, bool this_module
)
4885 struct written_common
*w
;
4886 bool write_me
= true;
4891 write_common_0 (st
->left
, this_module
);
4893 /* We will write out the binding label, or "" if no label given. */
4894 name
= st
->n
.common
->name
;
4896 label
= (p
->is_bind_c
&& p
->binding_label
) ? p
->binding_label
: "";
4898 /* Check if we've already output this common. */
4899 w
= written_commons
;
4902 int c
= strcmp (name
, w
->name
);
4903 c
= (c
!= 0 ? c
: strcmp (label
, w
->label
));
4907 w
= (c
< 0) ? w
->left
: w
->right
;
4910 if (this_module
&& p
->use_assoc
)
4915 /* Write the common to the module. */
4917 mio_pool_string (&name
);
4919 mio_symbol_ref (&p
->head
);
4920 flags
= p
->saved
? 1 : 0;
4921 if (p
->threadprivate
)
4923 mio_integer (&flags
);
4925 /* Write out whether the common block is bind(c) or not. */
4926 mio_integer (&(p
->is_bind_c
));
4928 mio_pool_string (&label
);
4931 /* Record that we have written this common. */
4932 w
= XCNEW (struct written_common
);
4935 gfc_insert_bbt (&written_commons
, w
, compare_written_commons
);
4938 write_common_0 (st
->right
, this_module
);
4942 /* Write a common, by initializing the list of written commons, calling
4943 the recursive function write_common_0() and cleaning up afterwards. */
4946 write_common (gfc_symtree
*st
)
4948 written_commons
= NULL
;
4949 write_common_0 (st
, true);
4950 write_common_0 (st
, false);
4951 free_written_common (written_commons
);
4952 written_commons
= NULL
;
4956 /* Write the blank common block to the module. */
4959 write_blank_common (void)
4961 const char * name
= BLANK_COMMON_NAME
;
4963 /* TODO: Blank commons are not bind(c). The F2003 standard probably says
4964 this, but it hasn't been checked. Just making it so for now. */
4967 if (gfc_current_ns
->blank_common
.head
== NULL
)
4972 mio_pool_string (&name
);
4974 mio_symbol_ref (&gfc_current_ns
->blank_common
.head
);
4975 saved
= gfc_current_ns
->blank_common
.saved
;
4976 mio_integer (&saved
);
4978 /* Write out whether the common block is bind(c) or not. */
4979 mio_integer (&is_bind_c
);
4981 /* Write out an empty binding label. */
4982 write_atom (ATOM_STRING
, "");
4988 /* Write equivalences to the module. */
4997 for (eq
= gfc_current_ns
->equiv
; eq
; eq
= eq
->next
)
5001 for (e
= eq
; e
; e
= e
->eq
)
5003 if (e
->module
== NULL
)
5004 e
->module
= gfc_get_string ("%s.eq.%d", module_name
, num
);
5005 mio_allocated_string (e
->module
);
5006 mio_expr (&e
->expr
);
5015 /* Write derived type extensions to the module. */
5018 write_dt_extensions (gfc_symtree
*st
)
5020 if (!gfc_check_symbol_access (st
->n
.sym
))
5022 if (!(st
->n
.sym
->ns
&& st
->n
.sym
->ns
->proc_name
5023 && st
->n
.sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
))
5027 mio_pool_string (&st
->name
);
5028 if (st
->n
.sym
->module
!= NULL
)
5029 mio_pool_string (&st
->n
.sym
->module
);
5032 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5033 if (iomode
== IO_OUTPUT
)
5034 strcpy (name
, module_name
);
5035 mio_internal_string (name
);
5036 if (iomode
== IO_INPUT
)
5037 module_name
= gfc_get_string (name
);
5043 write_derived_extensions (gfc_symtree
*st
)
5045 if (!((st
->n
.sym
->attr
.flavor
== FL_DERIVED
)
5046 && (st
->n
.sym
->f2k_derived
!= NULL
)
5047 && (st
->n
.sym
->f2k_derived
->sym_root
!= NULL
)))
5051 mio_symbol_ref (&(st
->n
.sym
));
5052 gfc_traverse_symtree (st
->n
.sym
->f2k_derived
->sym_root
,
5053 write_dt_extensions
);
5058 /* Write a symbol to the module. */
5061 write_symbol (int n
, gfc_symbol
*sym
)
5065 if (sym
->attr
.flavor
== FL_UNKNOWN
|| sym
->attr
.flavor
== FL_LABEL
)
5066 gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym
->name
);
5070 if (sym
->attr
.flavor
== FL_DERIVED
)
5073 name
= dt_upper_string (sym
->name
);
5074 mio_pool_string (&name
);
5077 mio_pool_string (&sym
->name
);
5079 mio_pool_string (&sym
->module
);
5080 if ((sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
) && sym
->binding_label
)
5082 label
= sym
->binding_label
;
5083 mio_pool_string (&label
);
5086 write_atom (ATOM_STRING
, "");
5088 mio_pointer_ref (&sym
->ns
);
5095 /* Recursive traversal function to write the initial set of symbols to
5096 the module. We check to see if the symbol should be written
5097 according to the access specification. */
5100 write_symbol0 (gfc_symtree
*st
)
5104 bool dont_write
= false;
5109 write_symbol0 (st
->left
);
5112 if (sym
->module
== NULL
)
5113 sym
->module
= module_name
;
5115 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
5116 && !sym
->attr
.subroutine
&& !sym
->attr
.function
)
5119 if (!gfc_check_symbol_access (sym
))
5124 p
= get_pointer (sym
);
5125 if (p
->type
== P_UNKNOWN
)
5128 if (p
->u
.wsym
.state
!= WRITTEN
)
5130 write_symbol (p
->integer
, sym
);
5131 p
->u
.wsym
.state
= WRITTEN
;
5135 write_symbol0 (st
->right
);
5139 /* Type for the temporary tree used when writing secondary symbols. */
5141 struct sorted_pointer_info
5143 BBT_HEADER (sorted_pointer_info
);
5148 #define gfc_get_sorted_pointer_info() XCNEW (sorted_pointer_info)
5150 /* Recursively traverse the temporary tree, free its contents. */
5153 free_sorted_pointer_info_tree (sorted_pointer_info
*p
)
5158 free_sorted_pointer_info_tree (p
->left
);
5159 free_sorted_pointer_info_tree (p
->right
);
5164 /* Comparison function for the temporary tree. */
5167 compare_sorted_pointer_info (void *_spi1
, void *_spi2
)
5169 sorted_pointer_info
*spi1
, *spi2
;
5170 spi1
= (sorted_pointer_info
*)_spi1
;
5171 spi2
= (sorted_pointer_info
*)_spi2
;
5173 if (spi1
->p
->integer
< spi2
->p
->integer
)
5175 if (spi1
->p
->integer
> spi2
->p
->integer
)
5181 /* Finds the symbols that need to be written and collects them in the
5182 sorted_pi tree so that they can be traversed in an order
5183 independent of memory addresses. */
5186 find_symbols_to_write(sorted_pointer_info
**tree
, pointer_info
*p
)
5191 if (p
->type
== P_SYMBOL
&& p
->u
.wsym
.state
== NEEDS_WRITE
)
5193 sorted_pointer_info
*sp
= gfc_get_sorted_pointer_info();
5196 gfc_insert_bbt (tree
, sp
, compare_sorted_pointer_info
);
5199 find_symbols_to_write (tree
, p
->left
);
5200 find_symbols_to_write (tree
, p
->right
);
5204 /* Recursive function that traverses the tree of symbols that need to be
5205 written and writes them in order. */
5208 write_symbol1_recursion (sorted_pointer_info
*sp
)
5213 write_symbol1_recursion (sp
->left
);
5215 pointer_info
*p1
= sp
->p
;
5216 gcc_assert (p1
->type
== P_SYMBOL
&& p1
->u
.wsym
.state
== NEEDS_WRITE
);
5218 p1
->u
.wsym
.state
= WRITTEN
;
5219 write_symbol (p1
->integer
, p1
->u
.wsym
.sym
);
5220 p1
->u
.wsym
.sym
->attr
.public_used
= 1;
5222 write_symbol1_recursion (sp
->right
);
5226 /* Write the secondary set of symbols to the module file. These are
5227 symbols that were not public yet are needed by the public symbols
5228 or another dependent symbol. The act of writing a symbol can add
5229 symbols to the pointer_info tree, so we return nonzero if a symbol
5230 was written and pass that information upwards. The caller will
5231 then call this function again until nothing was written. It uses
5232 the utility functions and a temporary tree to ensure a reproducible
5233 ordering of the symbol output and thus the module file. */
5236 write_symbol1 (pointer_info
*p
)
5241 /* Put symbols that need to be written into a tree sorted on the
5244 sorted_pointer_info
*spi_root
= NULL
;
5245 find_symbols_to_write (&spi_root
, p
);
5247 /* No symbols to write, return. */
5251 /* Otherwise, write and free the tree again. */
5252 write_symbol1_recursion (spi_root
);
5253 free_sorted_pointer_info_tree (spi_root
);
5259 /* Write operator interfaces associated with a symbol. */
5262 write_operator (gfc_user_op
*uop
)
5264 static char nullstring
[] = "";
5265 const char *p
= nullstring
;
5267 if (uop
->op
== NULL
|| !check_access (uop
->access
, uop
->ns
->default_access
))
5270 mio_symbol_interface (&uop
->name
, &p
, &uop
->op
);
5274 /* Write generic interfaces from the namespace sym_root. */
5277 write_generic (gfc_symtree
*st
)
5284 write_generic (st
->left
);
5287 if (sym
&& !check_unique_name (st
->name
)
5288 && sym
->generic
&& gfc_check_symbol_access (sym
))
5291 sym
->module
= module_name
;
5293 mio_symbol_interface (&st
->name
, &sym
->module
, &sym
->generic
);
5296 write_generic (st
->right
);
5301 write_symtree (gfc_symtree
*st
)
5308 /* A symbol in an interface body must not be visible in the
5310 if (sym
->ns
!= gfc_current_ns
5311 && sym
->ns
->proc_name
5312 && sym
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
5315 if (!gfc_check_symbol_access (sym
)
5316 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
5317 && !sym
->attr
.subroutine
&& !sym
->attr
.function
))
5320 if (check_unique_name (st
->name
))
5323 p
= find_pointer (sym
);
5325 gfc_internal_error ("write_symtree(): Symbol not written");
5327 mio_pool_string (&st
->name
);
5328 mio_integer (&st
->ambiguous
);
5329 mio_integer (&p
->integer
);
5338 /* Write the operator interfaces. */
5341 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
5343 if (i
== INTRINSIC_USER
)
5346 mio_interface (check_access (gfc_current_ns
->operator_access
[i
],
5347 gfc_current_ns
->default_access
)
5348 ? &gfc_current_ns
->op
[i
] : NULL
);
5356 gfc_traverse_user_op (gfc_current_ns
, write_operator
);
5362 write_generic (gfc_current_ns
->sym_root
);
5368 write_blank_common ();
5369 write_common (gfc_current_ns
->common_root
);
5381 gfc_traverse_symtree (gfc_current_ns
->sym_root
,
5382 write_derived_extensions
);
5387 /* Write symbol information. First we traverse all symbols in the
5388 primary namespace, writing those that need to be written.
5389 Sometimes writing one symbol will cause another to need to be
5390 written. A list of these symbols ends up on the write stack, and
5391 we end by popping the bottom of the stack and writing the symbol
5392 until the stack is empty. */
5396 write_symbol0 (gfc_current_ns
->sym_root
);
5397 while (write_symbol1 (pi_root
))
5406 gfc_traverse_symtree (gfc_current_ns
->sym_root
, write_symtree
);
5411 /* Read a MD5 sum from the header of a module file. If the file cannot
5412 be opened, or we have any other error, we return -1. */
5415 read_md5_from_module_file (const char * filename
, unsigned char md5
[16])
5421 /* Open the file. */
5422 if ((file
= fopen (filename
, "r")) == NULL
)
5425 /* Read the first line. */
5426 if (fgets (buf
, sizeof (buf
) - 1, file
) == NULL
)
5432 /* The file also needs to be overwritten if the version number changed. */
5433 n
= strlen ("GFORTRAN module version '" MOD_VERSION
"' created");
5434 if (strncmp (buf
, "GFORTRAN module version '" MOD_VERSION
"' created", n
) != 0)
5440 /* Read a second line. */
5441 if (fgets (buf
, sizeof (buf
) - 1, file
) == NULL
)
5447 /* Close the file. */
5450 /* If the header is not what we expect, or is too short, bail out. */
5451 if (strncmp (buf
, "MD5:", 4) != 0 || strlen (buf
) < 4 + 16)
5454 /* Now, we have a real MD5, read it into the array. */
5455 for (n
= 0; n
< 16; n
++)
5459 if (sscanf (&(buf
[4+2*n
]), "%02x", &x
) != 1)
5469 /* Given module, dump it to disk. If there was an error while
5470 processing the module, dump_flag will be set to zero and we delete
5471 the module file, even if it was already there. */
5474 gfc_dump_module (const char *name
, int dump_flag
)
5477 char *filename
, *filename_tmp
;
5479 unsigned char md5_new
[16], md5_old
[16];
5481 n
= strlen (name
) + strlen (MODULE_EXTENSION
) + 1;
5482 if (gfc_option
.module_dir
!= NULL
)
5484 n
+= strlen (gfc_option
.module_dir
);
5485 filename
= (char *) alloca (n
);
5486 strcpy (filename
, gfc_option
.module_dir
);
5487 strcat (filename
, name
);
5491 filename
= (char *) alloca (n
);
5492 strcpy (filename
, name
);
5494 strcat (filename
, MODULE_EXTENSION
);
5496 /* Name of the temporary file used to write the module. */
5497 filename_tmp
= (char *) alloca (n
+ 1);
5498 strcpy (filename_tmp
, filename
);
5499 strcat (filename_tmp
, "0");
5501 /* There was an error while processing the module. We delete the
5502 module file, even if it was already there. */
5509 if (gfc_cpp_makedep ())
5510 gfc_cpp_add_target (filename
);
5512 /* Write the module to the temporary file. */
5513 module_fp
= fopen (filename_tmp
, "w");
5514 if (module_fp
== NULL
)
5515 gfc_fatal_error ("Can't open module file '%s' for writing at %C: %s",
5516 filename_tmp
, xstrerror (errno
));
5518 /* Write the header, including space reserved for the MD5 sum. */
5519 fprintf (module_fp
, "GFORTRAN module version '%s' created from %s\n"
5520 "MD5:", MOD_VERSION
, gfc_source_file
);
5521 fgetpos (module_fp
, &md5_pos
);
5522 fputs ("00000000000000000000000000000000 -- "
5523 "If you edit this, you'll get what you deserve.\n\n", module_fp
);
5525 /* Initialize the MD5 context that will be used for output. */
5526 md5_init_ctx (&ctx
);
5528 /* Write the module itself. */
5530 module_name
= gfc_get_string (name
);
5536 free_pi_tree (pi_root
);
5541 /* Write the MD5 sum to the header of the module file. */
5542 md5_finish_ctx (&ctx
, md5_new
);
5543 fsetpos (module_fp
, &md5_pos
);
5544 for (n
= 0; n
< 16; n
++)
5545 fprintf (module_fp
, "%02x", md5_new
[n
]);
5547 if (fclose (module_fp
))
5548 gfc_fatal_error ("Error writing module file '%s' for writing: %s",
5549 filename_tmp
, xstrerror (errno
));
5551 /* Read the MD5 from the header of the old module file and compare. */
5552 if (read_md5_from_module_file (filename
, md5_old
) != 0
5553 || memcmp (md5_old
, md5_new
, sizeof (md5_old
)) != 0)
5555 /* Module file have changed, replace the old one. */
5556 if (unlink (filename
) && errno
!= ENOENT
)
5557 gfc_fatal_error ("Can't delete module file '%s': %s", filename
,
5559 if (rename (filename_tmp
, filename
))
5560 gfc_fatal_error ("Can't rename module file '%s' to '%s': %s",
5561 filename_tmp
, filename
, xstrerror (errno
));
5565 if (unlink (filename_tmp
))
5566 gfc_fatal_error ("Can't delete temporary module file '%s': %s",
5567 filename_tmp
, xstrerror (errno
));
5573 create_intrinsic_function (const char *name
, gfc_isym_id id
,
5574 const char *modname
, intmod_id module
)
5576 gfc_intrinsic_sym
*isym
;
5577 gfc_symtree
*tmp_symtree
;
5580 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
5583 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
5585 gfc_error ("Symbol '%s' already declared", name
);
5588 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
5589 sym
= tmp_symtree
->n
.sym
;
5591 isym
= gfc_intrinsic_function_by_id (id
);
5594 sym
->attr
.flavor
= FL_PROCEDURE
;
5595 sym
->attr
.intrinsic
= 1;
5597 sym
->module
= gfc_get_string (modname
);
5598 sym
->attr
.use_assoc
= 1;
5599 sym
->from_intmod
= module
;
5600 sym
->intmod_sym_id
= id
;
5604 /* Import the intrinsic ISO_C_BINDING module, generating symbols in
5605 the current namespace for all named constants, pointer types, and
5606 procedures in the module unless the only clause was used or a rename
5607 list was provided. */
5610 import_iso_c_binding_module (void)
5612 gfc_symbol
*mod_sym
= NULL
;
5613 gfc_symtree
*mod_symtree
= NULL
;
5614 const char *iso_c_module_name
= "__iso_c_binding";
5618 /* Look only in the current namespace. */
5619 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, iso_c_module_name
);
5621 if (mod_symtree
== NULL
)
5623 /* symtree doesn't already exist in current namespace. */
5624 gfc_get_sym_tree (iso_c_module_name
, gfc_current_ns
, &mod_symtree
,
5627 if (mod_symtree
!= NULL
)
5628 mod_sym
= mod_symtree
->n
.sym
;
5630 gfc_internal_error ("import_iso_c_binding_module(): Unable to "
5631 "create symbol for %s", iso_c_module_name
);
5633 mod_sym
->attr
.flavor
= FL_MODULE
;
5634 mod_sym
->attr
.intrinsic
= 1;
5635 mod_sym
->module
= gfc_get_string (iso_c_module_name
);
5636 mod_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
5639 /* Generate the symbols for the named constants representing
5640 the kinds for intrinsic data types. */
5641 for (i
= 0; i
< ISOCBINDING_NUMBER
; i
++)
5644 for (u
= gfc_rename_list
; u
; u
= u
->next
)
5645 if (strcmp (c_interop_kinds_table
[i
].name
, u
->use_name
) == 0)
5654 #define NAMED_FUNCTION(a,b,c,d) \
5656 not_in_std = (gfc_option.allow_std & d) == 0; \
5659 #include "iso-c-binding.def"
5660 #undef NAMED_FUNCTION
5661 #define NAMED_INTCST(a,b,c,d) \
5663 not_in_std = (gfc_option.allow_std & d) == 0; \
5666 #include "iso-c-binding.def"
5668 #define NAMED_REALCST(a,b,c,d) \
5670 not_in_std = (gfc_option.allow_std & d) == 0; \
5673 #include "iso-c-binding.def"
5674 #undef NAMED_REALCST
5675 #define NAMED_CMPXCST(a,b,c,d) \
5677 not_in_std = (gfc_option.allow_std & d) == 0; \
5680 #include "iso-c-binding.def"
5681 #undef NAMED_CMPXCST
5689 gfc_error ("The symbol '%s', referenced at %L, is not "
5690 "in the selected standard", name
, &u
->where
);
5696 #define NAMED_FUNCTION(a,b,c,d) \
5698 create_intrinsic_function (u->local_name[0] ? u->local_name \
5701 iso_c_module_name, \
5702 INTMOD_ISO_C_BINDING); \
5704 #include "iso-c-binding.def"
5705 #undef NAMED_FUNCTION
5708 generate_isocbinding_symbol (iso_c_module_name
,
5709 (iso_c_binding_symbol
) i
,
5710 u
->local_name
[0] ? u
->local_name
5715 if (!found
&& !only_flag
)
5717 /* Skip, if the symbol is not in the enabled standard. */
5720 #define NAMED_FUNCTION(a,b,c,d) \
5722 if ((gfc_option.allow_std & d) == 0) \
5725 #include "iso-c-binding.def"
5726 #undef NAMED_FUNCTION
5728 #define NAMED_INTCST(a,b,c,d) \
5730 if ((gfc_option.allow_std & d) == 0) \
5733 #include "iso-c-binding.def"
5735 #define NAMED_REALCST(a,b,c,d) \
5737 if ((gfc_option.allow_std & d) == 0) \
5740 #include "iso-c-binding.def"
5741 #undef NAMED_REALCST
5742 #define NAMED_CMPXCST(a,b,c,d) \
5744 if ((gfc_option.allow_std & d) == 0) \
5747 #include "iso-c-binding.def"
5748 #undef NAMED_CMPXCST
5750 ; /* Not GFC_STD_* versioned. */
5755 #define NAMED_FUNCTION(a,b,c,d) \
5757 create_intrinsic_function (b, (gfc_isym_id) c, \
5758 iso_c_module_name, \
5759 INTMOD_ISO_C_BINDING); \
5761 #include "iso-c-binding.def"
5762 #undef NAMED_FUNCTION
5765 generate_isocbinding_symbol (iso_c_module_name
,
5766 (iso_c_binding_symbol
) i
, NULL
);
5771 for (u
= gfc_rename_list
; u
; u
= u
->next
)
5776 gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
5777 "module ISO_C_BINDING", u
->use_name
, &u
->where
);
5782 /* Add an integer named constant from a given module. */
5785 create_int_parameter (const char *name
, int value
, const char *modname
,
5786 intmod_id module
, int id
)
5788 gfc_symtree
*tmp_symtree
;
5791 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
5792 if (tmp_symtree
!= NULL
)
5794 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
5797 gfc_error ("Symbol '%s' already declared", name
);
5800 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
5801 sym
= tmp_symtree
->n
.sym
;
5803 sym
->module
= gfc_get_string (modname
);
5804 sym
->attr
.flavor
= FL_PARAMETER
;
5805 sym
->ts
.type
= BT_INTEGER
;
5806 sym
->ts
.kind
= gfc_default_integer_kind
;
5807 sym
->value
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, value
);
5808 sym
->attr
.use_assoc
= 1;
5809 sym
->from_intmod
= module
;
5810 sym
->intmod_sym_id
= id
;
5814 /* Value is already contained by the array constructor, but not
5818 create_int_parameter_array (const char *name
, int size
, gfc_expr
*value
,
5819 const char *modname
, intmod_id module
, int id
)
5821 gfc_symtree
*tmp_symtree
;
5824 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
5825 if (tmp_symtree
!= NULL
)
5827 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
5830 gfc_error ("Symbol '%s' already declared", name
);
5833 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
5834 sym
= tmp_symtree
->n
.sym
;
5836 sym
->module
= gfc_get_string (modname
);
5837 sym
->attr
.flavor
= FL_PARAMETER
;
5838 sym
->ts
.type
= BT_INTEGER
;
5839 sym
->ts
.kind
= gfc_default_integer_kind
;
5840 sym
->attr
.use_assoc
= 1;
5841 sym
->from_intmod
= module
;
5842 sym
->intmod_sym_id
= id
;
5843 sym
->attr
.dimension
= 1;
5844 sym
->as
= gfc_get_array_spec ();
5846 sym
->as
->type
= AS_EXPLICIT
;
5847 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
5848 sym
->as
->upper
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, size
);
5851 sym
->value
->shape
= gfc_get_shape (1);
5852 mpz_init_set_ui (sym
->value
->shape
[0], size
);
5856 /* Add an derived type for a given module. */
5859 create_derived_type (const char *name
, const char *modname
,
5860 intmod_id module
, int id
)
5862 gfc_symtree
*tmp_symtree
;
5863 gfc_symbol
*sym
, *dt_sym
;
5864 gfc_interface
*intr
, *head
;
5866 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
5867 if (tmp_symtree
!= NULL
)
5869 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
5872 gfc_error ("Symbol '%s' already declared", name
);
5875 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
5876 sym
= tmp_symtree
->n
.sym
;
5877 sym
->module
= gfc_get_string (modname
);
5878 sym
->from_intmod
= module
;
5879 sym
->intmod_sym_id
= id
;
5880 sym
->attr
.flavor
= FL_PROCEDURE
;
5881 sym
->attr
.function
= 1;
5882 sym
->attr
.generic
= 1;
5884 gfc_get_sym_tree (dt_upper_string (sym
->name
),
5885 gfc_current_ns
, &tmp_symtree
, false);
5886 dt_sym
= tmp_symtree
->n
.sym
;
5887 dt_sym
->name
= gfc_get_string (sym
->name
);
5888 dt_sym
->attr
.flavor
= FL_DERIVED
;
5889 dt_sym
->attr
.private_comp
= 1;
5890 dt_sym
->attr
.zero_comp
= 1;
5891 dt_sym
->attr
.use_assoc
= 1;
5892 dt_sym
->module
= gfc_get_string (modname
);
5893 dt_sym
->from_intmod
= module
;
5894 dt_sym
->intmod_sym_id
= id
;
5896 head
= sym
->generic
;
5897 intr
= gfc_get_interface ();
5899 intr
->where
= gfc_current_locus
;
5901 sym
->generic
= intr
;
5902 sym
->attr
.if_source
= IFSRC_DECL
;
5906 /* USE the ISO_FORTRAN_ENV intrinsic module. */
5909 use_iso_fortran_env_module (void)
5911 static char mod
[] = "iso_fortran_env";
5913 gfc_symbol
*mod_sym
;
5914 gfc_symtree
*mod_symtree
;
5918 intmod_sym symbol
[] = {
5919 #define NAMED_INTCST(a,b,c,d) { a, b, 0, d },
5920 #include "iso-fortran-env.def"
5922 #define NAMED_KINDARRAY(a,b,c,d) { a, b, 0, d },
5923 #include "iso-fortran-env.def"
5924 #undef NAMED_KINDARRAY
5925 #define NAMED_DERIVED_TYPE(a,b,c,d) { a, b, 0, d },
5926 #include "iso-fortran-env.def"
5927 #undef NAMED_DERIVED_TYPE
5928 #define NAMED_FUNCTION(a,b,c,d) { a, b, c, d },
5929 #include "iso-fortran-env.def"
5930 #undef NAMED_FUNCTION
5931 { ISOFORTRANENV_INVALID
, NULL
, -1234, 0 } };
5934 #define NAMED_INTCST(a,b,c,d) symbol[i++].value = c;
5935 #include "iso-fortran-env.def"
5938 /* Generate the symbol for the module itself. */
5939 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, mod
);
5940 if (mod_symtree
== NULL
)
5942 gfc_get_sym_tree (mod
, gfc_current_ns
, &mod_symtree
, false);
5943 gcc_assert (mod_symtree
);
5944 mod_sym
= mod_symtree
->n
.sym
;
5946 mod_sym
->attr
.flavor
= FL_MODULE
;
5947 mod_sym
->attr
.intrinsic
= 1;
5948 mod_sym
->module
= gfc_get_string (mod
);
5949 mod_sym
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
5952 if (!mod_symtree
->n
.sym
->attr
.intrinsic
)
5953 gfc_error ("Use of intrinsic module '%s' at %C conflicts with "
5954 "non-intrinsic module name used previously", mod
);
5956 /* Generate the symbols for the module integer named constants. */
5958 for (i
= 0; symbol
[i
].name
; i
++)
5961 for (u
= gfc_rename_list
; u
; u
= u
->next
)
5963 if (strcmp (symbol
[i
].name
, u
->use_name
) == 0)
5968 if (gfc_notify_std (symbol
[i
].standard
, "The symbol '%s', "
5969 "referenced at %L, is not in the selected "
5970 "standard", symbol
[i
].name
,
5971 &u
->where
) == FAILURE
)
5974 if ((gfc_option
.flag_default_integer
|| gfc_option
.flag_default_real
)
5975 && symbol
[i
].id
== ISOFORTRANENV_NUMERIC_STORAGE_SIZE
)
5976 gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named "
5977 "constant from intrinsic module "
5978 "ISO_FORTRAN_ENV at %L is incompatible with "
5979 "option %s", &u
->where
,
5980 gfc_option
.flag_default_integer
5981 ? "-fdefault-integer-8"
5982 : "-fdefault-real-8");
5983 switch (symbol
[i
].id
)
5985 #define NAMED_INTCST(a,b,c,d) \
5987 #include "iso-fortran-env.def"
5989 create_int_parameter (u
->local_name
[0] ? u
->local_name
5991 symbol
[i
].value
, mod
,
5992 INTMOD_ISO_FORTRAN_ENV
, symbol
[i
].id
);
5995 #define NAMED_KINDARRAY(a,b,KINDS,d) \
5997 expr = gfc_get_array_expr (BT_INTEGER, \
5998 gfc_default_integer_kind,\
6000 for (j = 0; KINDS[j].kind != 0; j++) \
6001 gfc_constructor_append_expr (&expr->value.constructor, \
6002 gfc_get_int_expr (gfc_default_integer_kind, NULL, \
6003 KINDS[j].kind), NULL); \
6004 create_int_parameter_array (u->local_name[0] ? u->local_name \
6007 INTMOD_ISO_FORTRAN_ENV, \
6010 #include "iso-fortran-env.def"
6011 #undef NAMED_KINDARRAY
6013 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
6015 #include "iso-fortran-env.def"
6016 create_derived_type (u
->local_name
[0] ? u
->local_name
6018 mod
, INTMOD_ISO_FORTRAN_ENV
,
6021 #undef NAMED_DERIVED_TYPE
6023 #define NAMED_FUNCTION(a,b,c,d) \
6025 #include "iso-fortran-env.def"
6026 #undef NAMED_FUNCTION
6027 create_intrinsic_function (u
->local_name
[0] ? u
->local_name
6029 (gfc_isym_id
) symbol
[i
].value
, mod
,
6030 INTMOD_ISO_FORTRAN_ENV
);
6039 if (!found
&& !only_flag
)
6041 if ((gfc_option
.allow_std
& symbol
[i
].standard
) == 0)
6044 if ((gfc_option
.flag_default_integer
|| gfc_option
.flag_default_real
)
6045 && symbol
[i
].id
== ISOFORTRANENV_NUMERIC_STORAGE_SIZE
)
6046 gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
6047 "from intrinsic module ISO_FORTRAN_ENV at %C is "
6048 "incompatible with option %s",
6049 gfc_option
.flag_default_integer
6050 ? "-fdefault-integer-8" : "-fdefault-real-8");
6052 switch (symbol
[i
].id
)
6054 #define NAMED_INTCST(a,b,c,d) \
6056 #include "iso-fortran-env.def"
6058 create_int_parameter (symbol
[i
].name
, symbol
[i
].value
, mod
,
6059 INTMOD_ISO_FORTRAN_ENV
, symbol
[i
].id
);
6062 #define NAMED_KINDARRAY(a,b,KINDS,d) \
6064 expr = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, \
6066 for (j = 0; KINDS[j].kind != 0; j++) \
6067 gfc_constructor_append_expr (&expr->value.constructor, \
6068 gfc_get_int_expr (gfc_default_integer_kind, NULL, \
6069 KINDS[j].kind), NULL); \
6070 create_int_parameter_array (symbol[i].name, j, expr, mod, \
6071 INTMOD_ISO_FORTRAN_ENV, symbol[i].id);\
6073 #include "iso-fortran-env.def"
6074 #undef NAMED_KINDARRAY
6076 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
6078 #include "iso-fortran-env.def"
6079 create_derived_type (symbol
[i
].name
, mod
, INTMOD_ISO_FORTRAN_ENV
,
6082 #undef NAMED_DERIVED_TYPE
6084 #define NAMED_FUNCTION(a,b,c,d) \
6086 #include "iso-fortran-env.def"
6087 #undef NAMED_FUNCTION
6088 create_intrinsic_function (symbol
[i
].name
,
6089 (gfc_isym_id
) symbol
[i
].value
, mod
,
6090 INTMOD_ISO_FORTRAN_ENV
);
6099 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6104 gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
6105 "module ISO_FORTRAN_ENV", u
->use_name
, &u
->where
);
6110 /* Process a USE directive. */
6113 gfc_use_module (gfc_use_list
*module
)
6118 gfc_symtree
*mod_symtree
;
6119 gfc_use_list
*use_stmt
;
6120 locus old_locus
= gfc_current_locus
;
6122 gfc_current_locus
= module
->where
;
6123 module_name
= module
->module_name
;
6124 gfc_rename_list
= module
->rename
;
6125 only_flag
= module
->only_flag
;
6127 filename
= XALLOCAVEC (char, strlen (module_name
) + strlen (MODULE_EXTENSION
)
6129 strcpy (filename
, module_name
);
6130 strcat (filename
, MODULE_EXTENSION
);
6132 /* First, try to find an non-intrinsic module, unless the USE statement
6133 specified that the module is intrinsic. */
6135 if (!module
->intrinsic
)
6136 module_fp
= gfc_open_included_file (filename
, true, true);
6138 /* Then, see if it's an intrinsic one, unless the USE statement
6139 specified that the module is non-intrinsic. */
6140 if (module_fp
== NULL
&& !module
->non_intrinsic
)
6142 if (strcmp (module_name
, "iso_fortran_env") == 0
6143 && gfc_notify_std (GFC_STD_F2003
, "ISO_FORTRAN_ENV "
6144 "intrinsic module at %C") != FAILURE
)
6146 use_iso_fortran_env_module ();
6147 free_rename (module
->rename
);
6148 module
->rename
= NULL
;
6149 gfc_current_locus
= old_locus
;
6150 module
->intrinsic
= true;
6154 if (strcmp (module_name
, "iso_c_binding") == 0
6155 && gfc_notify_std (GFC_STD_F2003
,
6156 "ISO_C_BINDING module at %C") != FAILURE
)
6158 import_iso_c_binding_module();
6159 free_rename (module
->rename
);
6160 module
->rename
= NULL
;
6161 gfc_current_locus
= old_locus
;
6162 module
->intrinsic
= true;
6166 module_fp
= gfc_open_intrinsic_module (filename
);
6168 if (module_fp
== NULL
&& module
->intrinsic
)
6169 gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C",
6173 if (module_fp
== NULL
)
6174 gfc_fatal_error ("Can't open module file '%s' for reading at %C: %s",
6175 filename
, xstrerror (errno
));
6177 /* Check that we haven't already USEd an intrinsic module with the
6180 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, module_name
);
6181 if (mod_symtree
&& mod_symtree
->n
.sym
->attr
.intrinsic
)
6182 gfc_error ("Use of non-intrinsic module '%s' at %C conflicts with "
6183 "intrinsic module name used previously", module_name
);
6190 /* Skip the first two lines of the module, after checking that this is
6191 a gfortran module file. */
6197 bad_module ("Unexpected end of module");
6200 if ((start
== 1 && strcmp (atom_name
, "GFORTRAN") != 0)
6201 || (start
== 2 && strcmp (atom_name
, " module") != 0))
6202 gfc_fatal_error ("File '%s' opened at %C is not a GNU Fortran"
6203 " module file", filename
);
6206 if (strcmp (atom_name
, " version") != 0
6207 || module_char () != ' '
6208 || parse_atom () != ATOM_STRING
6209 || strcmp (atom_string
, MOD_VERSION
))
6210 gfc_fatal_error ("Cannot read module file '%s' opened at %C,"
6211 " because it was created by a different"
6212 " version of GNU Fortran", filename
);
6221 /* Make sure we're not reading the same module that we may be building. */
6222 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
6223 if (p
->state
== COMP_MODULE
&& strcmp (p
->sym
->name
, module_name
) == 0)
6224 gfc_fatal_error ("Can't USE the same module we're building!");
6227 init_true_name_tree ();
6231 free_true_name (true_name_root
);
6232 true_name_root
= NULL
;
6234 free_pi_tree (pi_root
);
6239 use_stmt
= gfc_get_use_list ();
6240 *use_stmt
= *module
;
6241 use_stmt
->next
= gfc_current_ns
->use_stmts
;
6242 gfc_current_ns
->use_stmts
= use_stmt
;
6244 gfc_current_locus
= old_locus
;
6248 /* Remove duplicated intrinsic operators from the rename list. */
6251 rename_list_remove_duplicate (gfc_use_rename
*list
)
6253 gfc_use_rename
*seek
, *last
;
6255 for (; list
; list
= list
->next
)
6256 if (list
->op
!= INTRINSIC_USER
&& list
->op
!= INTRINSIC_NONE
)
6259 for (seek
= list
->next
; seek
; seek
= last
->next
)
6261 if (list
->op
== seek
->op
)
6263 last
->next
= seek
->next
;
6273 /* Process all USE directives. */
6276 gfc_use_modules (void)
6278 gfc_use_list
*next
, *seek
, *last
;
6280 for (next
= module_list
; next
; next
= next
->next
)
6282 bool non_intrinsic
= next
->non_intrinsic
;
6283 bool intrinsic
= next
->intrinsic
;
6284 bool neither
= !non_intrinsic
&& !intrinsic
;
6286 for (seek
= next
->next
; seek
; seek
= seek
->next
)
6288 if (next
->module_name
!= seek
->module_name
)
6291 if (seek
->non_intrinsic
)
6292 non_intrinsic
= true;
6293 else if (seek
->intrinsic
)
6299 if (intrinsic
&& neither
&& !non_intrinsic
)
6304 filename
= XALLOCAVEC (char,
6305 strlen (next
->module_name
)
6306 + strlen (MODULE_EXTENSION
) + 1);
6307 strcpy (filename
, next
->module_name
);
6308 strcat (filename
, MODULE_EXTENSION
);
6309 fp
= gfc_open_included_file (filename
, true, true);
6312 non_intrinsic
= true;
6318 for (seek
= next
->next
; seek
; seek
= last
->next
)
6320 if (next
->module_name
!= seek
->module_name
)
6326 if ((!next
->intrinsic
&& !seek
->intrinsic
)
6327 || (next
->intrinsic
&& seek
->intrinsic
)
6330 if (!seek
->only_flag
)
6331 next
->only_flag
= false;
6334 gfc_use_rename
*r
= seek
->rename
;
6337 r
->next
= next
->rename
;
6338 next
->rename
= seek
->rename
;
6340 last
->next
= seek
->next
;
6348 for (; module_list
; module_list
= next
)
6350 next
= module_list
->next
;
6351 rename_list_remove_duplicate (module_list
->rename
);
6352 gfc_use_module (module_list
);
6355 gfc_rename_list
= NULL
;
6360 gfc_free_use_stmts (gfc_use_list
*use_stmts
)
6363 for (; use_stmts
; use_stmts
= next
)
6365 gfc_use_rename
*next_rename
;
6367 for (; use_stmts
->rename
; use_stmts
->rename
= next_rename
)
6369 next_rename
= use_stmts
->rename
->next
;
6370 free (use_stmts
->rename
);
6372 next
= use_stmts
->next
;
6379 gfc_module_init_2 (void)
6381 last_atom
= ATOM_LPAREN
;
6382 gfc_rename_list
= NULL
;
6388 gfc_module_done_2 (void)
6390 free_rename (gfc_rename_list
);
6391 gfc_rename_list
= NULL
;