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 /* Content of module. */
194 static char* module_content
;
196 static long module_pos
;
197 static int module_line
, module_column
, only_flag
;
198 static int prev_module_line
, prev_module_column
;
201 { IO_INPUT
, IO_OUTPUT
}
204 static gfc_use_rename
*gfc_rename_list
;
205 static pointer_info
*pi_root
;
206 static int symbol_number
; /* Counter for assigning symbol numbers */
208 /* Tells mio_expr_ref to make symbols for unused equivalence members. */
209 static bool in_load_equiv
;
213 /*****************************************************************/
215 /* Pointer/integer conversion. Pointers between structures are stored
216 as integers in the module file. The next couple of subroutines
217 handle this translation for reading and writing. */
219 /* Recursively free the tree of pointer structures. */
222 free_pi_tree (pointer_info
*p
)
227 if (p
->fixup
!= NULL
)
228 gfc_internal_error ("free_pi_tree(): Unresolved fixup");
230 free_pi_tree (p
->left
);
231 free_pi_tree (p
->right
);
233 if (iomode
== IO_INPUT
)
235 XDELETEVEC (p
->u
.rsym
.true_name
);
236 XDELETEVEC (p
->u
.rsym
.module
);
237 XDELETEVEC (p
->u
.rsym
.binding_label
);
244 /* Compare pointers when searching by pointer. Used when writing a
248 compare_pointers (void *_sn1
, void *_sn2
)
250 pointer_info
*sn1
, *sn2
;
252 sn1
= (pointer_info
*) _sn1
;
253 sn2
= (pointer_info
*) _sn2
;
255 if (sn1
->u
.pointer
< sn2
->u
.pointer
)
257 if (sn1
->u
.pointer
> sn2
->u
.pointer
)
264 /* Compare integers when searching by integer. Used when reading a
268 compare_integers (void *_sn1
, void *_sn2
)
270 pointer_info
*sn1
, *sn2
;
272 sn1
= (pointer_info
*) _sn1
;
273 sn2
= (pointer_info
*) _sn2
;
275 if (sn1
->integer
< sn2
->integer
)
277 if (sn1
->integer
> sn2
->integer
)
284 /* Initialize the pointer_info tree. */
293 compare
= (iomode
== IO_INPUT
) ? compare_integers
: compare_pointers
;
295 /* Pointer 0 is the NULL pointer. */
296 p
= gfc_get_pointer_info ();
301 gfc_insert_bbt (&pi_root
, p
, compare
);
303 /* Pointer 1 is the current namespace. */
304 p
= gfc_get_pointer_info ();
305 p
->u
.pointer
= gfc_current_ns
;
307 p
->type
= P_NAMESPACE
;
309 gfc_insert_bbt (&pi_root
, p
, compare
);
315 /* During module writing, call here with a pointer to something,
316 returning the pointer_info node. */
318 static pointer_info
*
319 find_pointer (void *gp
)
326 if (p
->u
.pointer
== gp
)
328 p
= (gp
< p
->u
.pointer
) ? p
->left
: p
->right
;
335 /* Given a pointer while writing, returns the pointer_info tree node,
336 creating it if it doesn't exist. */
338 static pointer_info
*
339 get_pointer (void *gp
)
343 p
= find_pointer (gp
);
347 /* Pointer doesn't have an integer. Give it one. */
348 p
= gfc_get_pointer_info ();
351 p
->integer
= symbol_number
++;
353 gfc_insert_bbt (&pi_root
, p
, compare_pointers
);
359 /* Given an integer during reading, find it in the pointer_info tree,
360 creating the node if not found. */
362 static pointer_info
*
363 get_integer (int integer
)
373 c
= compare_integers (&t
, p
);
377 p
= (c
< 0) ? p
->left
: p
->right
;
383 p
= gfc_get_pointer_info ();
384 p
->integer
= integer
;
387 gfc_insert_bbt (&pi_root
, p
, compare_integers
);
393 /* Recursive function to find a pointer within a tree by brute force. */
395 static pointer_info
*
396 fp2 (pointer_info
*p
, const void *target
)
403 if (p
->u
.pointer
== target
)
406 q
= fp2 (p
->left
, target
);
410 return fp2 (p
->right
, target
);
414 /* During reading, find a pointer_info node from the pointer value.
415 This amounts to a brute-force search. */
417 static pointer_info
*
418 find_pointer2 (void *p
)
420 return fp2 (pi_root
, p
);
424 /* Resolve any fixups using a known pointer. */
427 resolve_fixups (fixup_t
*f
, void *gp
)
440 /* Convert a string such that it starts with a lower-case character. Used
441 to convert the symtree name of a derived-type to the symbol name or to
442 the name of the associated generic function. */
445 dt_lower_string (const char *name
)
447 if (name
[0] != (char) TOLOWER ((unsigned char) name
[0]))
448 return gfc_get_string ("%c%s", (char) TOLOWER ((unsigned char) name
[0]),
450 return gfc_get_string (name
);
454 /* Convert a string such that it starts with an upper-case character. Used to
455 return the symtree-name for a derived type; the symbol name itself and the
456 symtree/symbol name of the associated generic function start with a lower-
460 dt_upper_string (const char *name
)
462 if (name
[0] != (char) TOUPPER ((unsigned char) name
[0]))
463 return gfc_get_string ("%c%s", (char) TOUPPER ((unsigned char) name
[0]),
465 return gfc_get_string (name
);
468 /* Call here during module reading when we know what pointer to
469 associate with an integer. Any fixups that exist are resolved at
473 associate_integer_pointer (pointer_info
*p
, void *gp
)
475 if (p
->u
.pointer
!= NULL
)
476 gfc_internal_error ("associate_integer_pointer(): Already associated");
480 resolve_fixups (p
->fixup
, gp
);
486 /* During module reading, given an integer and a pointer to a pointer,
487 either store the pointer from an already-known value or create a
488 fixup structure in order to store things later. Returns zero if
489 the reference has been actually stored, or nonzero if the reference
490 must be fixed later (i.e., associate_integer_pointer must be called
491 sometime later. Returns the pointer_info structure. */
493 static pointer_info
*
494 add_fixup (int integer
, void *gp
)
500 p
= get_integer (integer
);
502 if (p
->integer
== 0 || p
->u
.pointer
!= NULL
)
505 *cp
= (char *) p
->u
.pointer
;
514 f
->pointer
= (void **) gp
;
521 /*****************************************************************/
523 /* Parser related subroutines */
525 /* Free the rename list left behind by a USE statement. */
528 free_rename (gfc_use_rename
*list
)
530 gfc_use_rename
*next
;
532 for (; list
; list
= next
)
540 /* Match a USE statement. */
545 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module_nature
[GFC_MAX_SYMBOL_LEN
+ 1];
546 gfc_use_rename
*tail
= NULL
, *new_use
;
547 interface_type type
, type2
;
550 gfc_use_list
*use_list
;
552 use_list
= gfc_get_use_list ();
554 if (gfc_match (" , ") == MATCH_YES
)
556 if ((m
= gfc_match (" %n ::", module_nature
)) == MATCH_YES
)
558 if (!gfc_notify_std (GFC_STD_F2003
, "module "
559 "nature in USE statement at %C"))
562 if (strcmp (module_nature
, "intrinsic") == 0)
563 use_list
->intrinsic
= true;
566 if (strcmp (module_nature
, "non_intrinsic") == 0)
567 use_list
->non_intrinsic
= true;
570 gfc_error ("Module nature in USE statement at %C shall "
571 "be either INTRINSIC or NON_INTRINSIC");
578 /* Help output a better error message than "Unclassifiable
580 gfc_match (" %n", module_nature
);
581 if (strcmp (module_nature
, "intrinsic") == 0
582 || strcmp (module_nature
, "non_intrinsic") == 0)
583 gfc_error ("\"::\" was expected after module nature at %C "
584 "but was not found");
591 m
= gfc_match (" ::");
592 if (m
== MATCH_YES
&&
593 !gfc_notify_std(GFC_STD_F2003
, "\"USE :: module\" at %C"))
598 m
= gfc_match ("% ");
607 use_list
->where
= gfc_current_locus
;
609 m
= gfc_match_name (name
);
616 use_list
->module_name
= gfc_get_string (name
);
618 if (gfc_match_eos () == MATCH_YES
)
621 if (gfc_match_char (',') != MATCH_YES
)
624 if (gfc_match (" only :") == MATCH_YES
)
625 use_list
->only_flag
= true;
627 if (gfc_match_eos () == MATCH_YES
)
632 /* Get a new rename struct and add it to the rename list. */
633 new_use
= gfc_get_use_rename ();
634 new_use
->where
= gfc_current_locus
;
637 if (use_list
->rename
== NULL
)
638 use_list
->rename
= new_use
;
640 tail
->next
= new_use
;
643 /* See what kind of interface we're dealing with. Assume it is
645 new_use
->op
= INTRINSIC_NONE
;
646 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
651 case INTERFACE_NAMELESS
:
652 gfc_error ("Missing generic specification in USE statement at %C");
655 case INTERFACE_USER_OP
:
656 case INTERFACE_GENERIC
:
657 m
= gfc_match (" =>");
659 if (type
== INTERFACE_USER_OP
&& m
== MATCH_YES
660 && (!gfc_notify_std(GFC_STD_F2003
, "Renaming "
661 "operators in USE statements at %C")))
664 if (type
== INTERFACE_USER_OP
)
665 new_use
->op
= INTRINSIC_USER
;
667 if (use_list
->only_flag
)
670 strcpy (new_use
->use_name
, name
);
673 strcpy (new_use
->local_name
, name
);
674 m
= gfc_match_generic_spec (&type2
, new_use
->use_name
, &op
);
679 if (m
== MATCH_ERROR
)
687 strcpy (new_use
->local_name
, name
);
689 m
= gfc_match_generic_spec (&type2
, new_use
->use_name
, &op
);
694 if (m
== MATCH_ERROR
)
698 if (strcmp (new_use
->use_name
, use_list
->module_name
) == 0
699 || strcmp (new_use
->local_name
, use_list
->module_name
) == 0)
701 gfc_error ("The name '%s' at %C has already been used as "
702 "an external module name.", use_list
->module_name
);
707 case INTERFACE_INTRINSIC_OP
:
715 if (gfc_match_eos () == MATCH_YES
)
717 if (gfc_match_char (',') != MATCH_YES
)
724 gfc_use_list
*last
= module_list
;
727 last
->next
= use_list
;
730 module_list
= use_list
;
735 gfc_syntax_error (ST_USE
);
738 free_rename (use_list
->rename
);
744 /* Given a name and a number, inst, return the inst name
745 under which to load this symbol. Returns NULL if this
746 symbol shouldn't be loaded. If inst is zero, returns
747 the number of instances of this name. If interface is
748 true, a user-defined operator is sought, otherwise only
749 non-operators are sought. */
752 find_use_name_n (const char *name
, int *inst
, bool interface
)
755 const char *low_name
= NULL
;
758 /* For derived types. */
759 if (name
[0] != (char) TOLOWER ((unsigned char) name
[0]))
760 low_name
= dt_lower_string (name
);
763 for (u
= gfc_rename_list
; u
; u
= u
->next
)
765 if ((!low_name
&& strcmp (u
->use_name
, name
) != 0)
766 || (low_name
&& strcmp (u
->use_name
, low_name
) != 0)
767 || (u
->op
== INTRINSIC_USER
&& !interface
)
768 || (u
->op
!= INTRINSIC_USER
&& interface
))
781 return only_flag
? NULL
: name
;
787 if (u
->local_name
[0] == '\0')
789 return dt_upper_string (u
->local_name
);
792 return (u
->local_name
[0] != '\0') ? u
->local_name
: name
;
796 /* Given a name, return the name under which to load this symbol.
797 Returns NULL if this symbol shouldn't be loaded. */
800 find_use_name (const char *name
, bool interface
)
803 return find_use_name_n (name
, &i
, interface
);
807 /* Given a real name, return the number of use names associated with it. */
810 number_use_names (const char *name
, bool interface
)
813 find_use_name_n (name
, &i
, interface
);
818 /* Try to find the operator in the current list. */
820 static gfc_use_rename
*
821 find_use_operator (gfc_intrinsic_op op
)
825 for (u
= gfc_rename_list
; u
; u
= u
->next
)
833 /*****************************************************************/
835 /* The next couple of subroutines maintain a tree used to avoid a
836 brute-force search for a combination of true name and module name.
837 While symtree names, the name that a particular symbol is known by
838 can changed with USE statements, we still have to keep track of the
839 true names to generate the correct reference, and also avoid
840 loading the same real symbol twice in a program unit.
842 When we start reading, the true name tree is built and maintained
843 as symbols are read. The tree is searched as we load new symbols
844 to see if it already exists someplace in the namespace. */
846 typedef struct true_name
848 BBT_HEADER (true_name
);
854 static true_name
*true_name_root
;
857 /* Compare two true_name structures. */
860 compare_true_names (void *_t1
, void *_t2
)
865 t1
= (true_name
*) _t1
;
866 t2
= (true_name
*) _t2
;
868 c
= ((t1
->sym
->module
> t2
->sym
->module
)
869 - (t1
->sym
->module
< t2
->sym
->module
));
873 return strcmp (t1
->name
, t2
->name
);
877 /* Given a true name, search the true name tree to see if it exists
878 within the main namespace. */
881 find_true_name (const char *name
, const char *module
)
887 t
.name
= gfc_get_string (name
);
889 sym
.module
= gfc_get_string (module
);
897 c
= compare_true_names ((void *) (&t
), (void *) p
);
901 p
= (c
< 0) ? p
->left
: p
->right
;
908 /* Given a gfc_symbol pointer that is not in the true name tree, add it. */
911 add_true_name (gfc_symbol
*sym
)
915 t
= XCNEW (true_name
);
917 if (sym
->attr
.flavor
== FL_DERIVED
)
918 t
->name
= dt_upper_string (sym
->name
);
922 gfc_insert_bbt (&true_name_root
, t
, compare_true_names
);
926 /* Recursive function to build the initial true name tree by
927 recursively traversing the current namespace. */
930 build_tnt (gfc_symtree
*st
)
936 build_tnt (st
->left
);
937 build_tnt (st
->right
);
939 if (st
->n
.sym
->attr
.flavor
== FL_DERIVED
)
940 name
= dt_upper_string (st
->n
.sym
->name
);
942 name
= st
->n
.sym
->name
;
944 if (find_true_name (name
, st
->n
.sym
->module
) != NULL
)
947 add_true_name (st
->n
.sym
);
951 /* Initialize the true name tree with the current namespace. */
954 init_true_name_tree (void)
956 true_name_root
= NULL
;
957 build_tnt (gfc_current_ns
->sym_root
);
961 /* Recursively free a true name tree node. */
964 free_true_name (true_name
*t
)
968 free_true_name (t
->left
);
969 free_true_name (t
->right
);
975 /*****************************************************************/
977 /* Module reading and writing. */
981 ATOM_NAME
, ATOM_LPAREN
, ATOM_RPAREN
, ATOM_INTEGER
, ATOM_STRING
985 static atom_type last_atom
;
988 /* The name buffer must be at least as long as a symbol name. Right
989 now it's not clear how we're going to store numeric constants--
990 probably as a hexadecimal string, since this will allow the exact
991 number to be preserved (this can't be done by a decimal
992 representation). Worry about that later. TODO! */
994 #define MAX_ATOM_SIZE 100
997 static char *atom_string
, atom_name
[MAX_ATOM_SIZE
];
1000 /* Report problems with a module. Error reporting is not very
1001 elaborate, since this sorts of errors shouldn't really happen.
1002 This subroutine never returns. */
1004 static void bad_module (const char *) ATTRIBUTE_NORETURN
;
1007 bad_module (const char *msgid
)
1009 XDELETEVEC (module_content
);
1010 module_content
= NULL
;
1015 gfc_fatal_error ("Reading module %s at line %d column %d: %s",
1016 module_name
, module_line
, module_column
, msgid
);
1019 gfc_fatal_error ("Writing module %s at line %d column %d: %s",
1020 module_name
, module_line
, module_column
, msgid
);
1023 gfc_fatal_error ("Module %s at line %d column %d: %s",
1024 module_name
, module_line
, module_column
, msgid
);
1030 /* Set the module's input pointer. */
1033 set_module_locus (module_locus
*m
)
1035 module_column
= m
->column
;
1036 module_line
= m
->line
;
1037 module_pos
= m
->pos
;
1041 /* Get the module's input pointer so that we can restore it later. */
1044 get_module_locus (module_locus
*m
)
1046 m
->column
= module_column
;
1047 m
->line
= module_line
;
1048 m
->pos
= module_pos
;
1052 /* Get the next character in the module, updating our reckoning of
1058 const char c
= module_content
[module_pos
++];
1060 bad_module ("Unexpected EOF");
1062 prev_module_line
= module_line
;
1063 prev_module_column
= module_column
;
1075 /* Unget a character while remembering the line and column. Works for
1076 a single character only. */
1079 module_unget_char (void)
1081 module_line
= prev_module_line
;
1082 module_column
= prev_module_column
;
1086 /* Parse a string constant. The delimiter is guaranteed to be a
1096 atom_string
= XNEWVEC (char, cursz
);
1104 int c2
= module_char ();
1107 module_unget_char ();
1115 atom_string
= XRESIZEVEC (char, atom_string
, cursz
);
1117 atom_string
[len
] = c
;
1121 atom_string
= XRESIZEVEC (char, atom_string
, len
+ 1);
1122 atom_string
[len
] = '\0'; /* C-style string for debug purposes. */
1126 /* Parse a small integer. */
1129 parse_integer (int c
)
1138 module_unget_char ();
1142 atom_int
= 10 * atom_int
+ c
- '0';
1143 if (atom_int
> 99999999)
1144 bad_module ("Integer overflow");
1166 if (!ISALNUM (c
) && c
!= '_' && c
!= '-')
1168 module_unget_char ();
1173 if (++len
> GFC_MAX_SYMBOL_LEN
)
1174 bad_module ("Name too long");
1182 /* Read the next atom in the module's input stream. */
1193 while (c
== ' ' || c
== '\r' || c
== '\n');
1218 return ATOM_INTEGER
;
1276 bad_module ("Bad name");
1283 /* Peek at the next atom on the input. */
1294 while (c
== ' ' || c
== '\r' || c
== '\n');
1299 module_unget_char ();
1303 module_unget_char ();
1307 module_unget_char ();
1320 module_unget_char ();
1321 return ATOM_INTEGER
;
1375 module_unget_char ();
1379 bad_module ("Bad name");
1384 /* Read the next atom from the input, requiring that it be a
1388 require_atom (atom_type type
)
1394 column
= module_column
;
1403 p
= _("Expected name");
1406 p
= _("Expected left parenthesis");
1409 p
= _("Expected right parenthesis");
1412 p
= _("Expected integer");
1415 p
= _("Expected string");
1418 gfc_internal_error ("require_atom(): bad atom type required");
1421 module_column
= column
;
1428 /* Given a pointer to an mstring array, require that the current input
1429 be one of the strings in the array. We return the enum value. */
1432 find_enum (const mstring
*m
)
1436 i
= gfc_string2code (m
, atom_name
);
1440 bad_module ("find_enum(): Enum not found");
1446 /* Read a string. The caller is responsible for freeing. */
1452 require_atom (ATOM_STRING
);
1459 /**************** Module output subroutines ***************************/
1461 /* Output a character to a module file. */
1464 write_char (char out
)
1466 if (putc (out
, module_fp
) == EOF
)
1467 gfc_fatal_error ("Error writing modules file: %s", xstrerror (errno
));
1469 /* Add this to our MD5. */
1470 md5_process_bytes (&out
, sizeof (out
), &ctx
);
1482 /* Write an atom to a module. The line wrapping isn't perfect, but it
1483 should work most of the time. This isn't that big of a deal, since
1484 the file really isn't meant to be read by people anyway. */
1487 write_atom (atom_type atom
, const void *v
)
1497 p
= (const char *) v
;
1509 i
= *((const int *) v
);
1511 gfc_internal_error ("write_atom(): Writing negative integer");
1513 sprintf (buffer
, "%d", i
);
1518 gfc_internal_error ("write_atom(): Trying to write dab atom");
1522 if(p
== NULL
|| *p
== '\0')
1527 if (atom
!= ATOM_RPAREN
)
1529 if (module_column
+ len
> 72)
1534 if (last_atom
!= ATOM_LPAREN
&& module_column
!= 1)
1539 if (atom
== ATOM_STRING
)
1542 while (p
!= NULL
&& *p
)
1544 if (atom
== ATOM_STRING
&& *p
== '\'')
1549 if (atom
== ATOM_STRING
)
1557 /***************** Mid-level I/O subroutines *****************/
1559 /* These subroutines let their caller read or write atoms without
1560 caring about which of the two is actually happening. This lets a
1561 subroutine concentrate on the actual format of the data being
1564 static void mio_expr (gfc_expr
**);
1565 pointer_info
*mio_symbol_ref (gfc_symbol
**);
1566 pointer_info
*mio_interface_rest (gfc_interface
**);
1567 static void mio_symtree_ref (gfc_symtree
**);
1569 /* Read or write an enumerated value. On writing, we return the input
1570 value for the convenience of callers. We avoid using an integer
1571 pointer because enums are sometimes inside bitfields. */
1574 mio_name (int t
, const mstring
*m
)
1576 if (iomode
== IO_OUTPUT
)
1577 write_atom (ATOM_NAME
, gfc_code2string (m
, t
));
1580 require_atom (ATOM_NAME
);
1587 /* Specialization of mio_name. */
1589 #define DECL_MIO_NAME(TYPE) \
1590 static inline TYPE \
1591 MIO_NAME(TYPE) (TYPE t, const mstring *m) \
1593 return (TYPE) mio_name ((int) t, m); \
1595 #define MIO_NAME(TYPE) mio_name_##TYPE
1600 if (iomode
== IO_OUTPUT
)
1601 write_atom (ATOM_LPAREN
, NULL
);
1603 require_atom (ATOM_LPAREN
);
1610 if (iomode
== IO_OUTPUT
)
1611 write_atom (ATOM_RPAREN
, NULL
);
1613 require_atom (ATOM_RPAREN
);
1618 mio_integer (int *ip
)
1620 if (iomode
== IO_OUTPUT
)
1621 write_atom (ATOM_INTEGER
, ip
);
1624 require_atom (ATOM_INTEGER
);
1630 /* Read or write a gfc_intrinsic_op value. */
1633 mio_intrinsic_op (gfc_intrinsic_op
* op
)
1635 /* FIXME: Would be nicer to do this via the operators symbolic name. */
1636 if (iomode
== IO_OUTPUT
)
1638 int converted
= (int) *op
;
1639 write_atom (ATOM_INTEGER
, &converted
);
1643 require_atom (ATOM_INTEGER
);
1644 *op
= (gfc_intrinsic_op
) atom_int
;
1649 /* Read or write a character pointer that points to a string on the heap. */
1652 mio_allocated_string (const char *s
)
1654 if (iomode
== IO_OUTPUT
)
1656 write_atom (ATOM_STRING
, s
);
1661 require_atom (ATOM_STRING
);
1667 /* Functions for quoting and unquoting strings. */
1670 quote_string (const gfc_char_t
*s
, const size_t slength
)
1672 const gfc_char_t
*p
;
1676 /* Calculate the length we'll need: a backslash takes two ("\\"),
1677 non-printable characters take 10 ("\Uxxxxxxxx") and others take 1. */
1678 for (p
= s
, i
= 0; i
< slength
; p
++, i
++)
1682 else if (!gfc_wide_is_printable (*p
))
1688 q
= res
= XCNEWVEC (char, len
+ 1);
1689 for (p
= s
, i
= 0; i
< slength
; p
++, i
++)
1692 *q
++ = '\\', *q
++ = '\\';
1693 else if (!gfc_wide_is_printable (*p
))
1695 sprintf (q
, "\\U%08" HOST_WIDE_INT_PRINT
"x",
1696 (unsigned HOST_WIDE_INT
) *p
);
1700 *q
++ = (unsigned char) *p
;
1708 unquote_string (const char *s
)
1714 for (p
= s
, len
= 0; *p
; p
++, len
++)
1721 else if (p
[1] == 'U')
1722 p
+= 9; /* That is a "\U????????". */
1724 gfc_internal_error ("unquote_string(): got bad string");
1727 res
= gfc_get_wide_string (len
+ 1);
1728 for (i
= 0, p
= s
; i
< len
; i
++, p
++)
1733 res
[i
] = (unsigned char) *p
;
1734 else if (p
[1] == '\\')
1736 res
[i
] = (unsigned char) '\\';
1741 /* We read the 8-digits hexadecimal constant that follows. */
1746 gcc_assert (p
[1] == 'U');
1747 for (j
= 0; j
< 8; j
++)
1750 gcc_assert (sscanf (&p
[j
+2], "%01x", &n
) == 1);
1764 /* Read or write a character pointer that points to a wide string on the
1765 heap, performing quoting/unquoting of nonprintable characters using the
1766 form \U???????? (where each ? is a hexadecimal digit).
1767 Length is the length of the string, only known and used in output mode. */
1769 static const gfc_char_t
*
1770 mio_allocated_wide_string (const gfc_char_t
*s
, const size_t length
)
1772 if (iomode
== IO_OUTPUT
)
1774 char *quoted
= quote_string (s
, length
);
1775 write_atom (ATOM_STRING
, quoted
);
1781 gfc_char_t
*unquoted
;
1783 require_atom (ATOM_STRING
);
1784 unquoted
= unquote_string (atom_string
);
1791 /* Read or write a string that is in static memory. */
1794 mio_pool_string (const char **stringp
)
1796 /* TODO: one could write the string only once, and refer to it via a
1799 /* As a special case we have to deal with a NULL string. This
1800 happens for the 'module' member of 'gfc_symbol's that are not in a
1801 module. We read / write these as the empty string. */
1802 if (iomode
== IO_OUTPUT
)
1804 const char *p
= *stringp
== NULL
? "" : *stringp
;
1805 write_atom (ATOM_STRING
, p
);
1809 require_atom (ATOM_STRING
);
1810 *stringp
= atom_string
[0] == '\0' ? NULL
: gfc_get_string (atom_string
);
1816 /* Read or write a string that is inside of some already-allocated
1820 mio_internal_string (char *string
)
1822 if (iomode
== IO_OUTPUT
)
1823 write_atom (ATOM_STRING
, string
);
1826 require_atom (ATOM_STRING
);
1827 strcpy (string
, atom_string
);
1834 { AB_ALLOCATABLE
, AB_DIMENSION
, AB_EXTERNAL
, AB_INTRINSIC
, AB_OPTIONAL
,
1835 AB_POINTER
, AB_TARGET
, AB_DUMMY
, AB_RESULT
, AB_DATA
,
1836 AB_IN_NAMELIST
, AB_IN_COMMON
, AB_FUNCTION
, AB_SUBROUTINE
, AB_SEQUENCE
,
1837 AB_ELEMENTAL
, AB_PURE
, AB_RECURSIVE
, AB_GENERIC
, AB_ALWAYS_EXPLICIT
,
1838 AB_CRAY_POINTER
, AB_CRAY_POINTEE
, AB_THREADPRIVATE
,
1839 AB_ALLOC_COMP
, AB_POINTER_COMP
, AB_PROC_POINTER_COMP
, AB_PRIVATE_COMP
,
1840 AB_VALUE
, AB_VOLATILE
, AB_PROTECTED
, AB_LOCK_COMP
,
1841 AB_IS_BIND_C
, AB_IS_C_INTEROP
, AB_IS_ISO_C
, AB_ABSTRACT
, AB_ZERO_COMP
,
1842 AB_IS_CLASS
, AB_PROCEDURE
, AB_PROC_POINTER
, AB_ASYNCHRONOUS
, AB_CODIMENSION
,
1843 AB_COARRAY_COMP
, AB_VTYPE
, AB_VTAB
, AB_CONTIGUOUS
, AB_CLASS_POINTER
,
1844 AB_IMPLICIT_PURE
, AB_ARTIFICIAL
, AB_UNLIMITED_POLY
1848 static const mstring attr_bits
[] =
1850 minit ("ALLOCATABLE", AB_ALLOCATABLE
),
1851 minit ("ARTIFICIAL", AB_ARTIFICIAL
),
1852 minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS
),
1853 minit ("DIMENSION", AB_DIMENSION
),
1854 minit ("CODIMENSION", AB_CODIMENSION
),
1855 minit ("CONTIGUOUS", AB_CONTIGUOUS
),
1856 minit ("EXTERNAL", AB_EXTERNAL
),
1857 minit ("INTRINSIC", AB_INTRINSIC
),
1858 minit ("OPTIONAL", AB_OPTIONAL
),
1859 minit ("POINTER", AB_POINTER
),
1860 minit ("VOLATILE", AB_VOLATILE
),
1861 minit ("TARGET", AB_TARGET
),
1862 minit ("THREADPRIVATE", AB_THREADPRIVATE
),
1863 minit ("DUMMY", AB_DUMMY
),
1864 minit ("RESULT", AB_RESULT
),
1865 minit ("DATA", AB_DATA
),
1866 minit ("IN_NAMELIST", AB_IN_NAMELIST
),
1867 minit ("IN_COMMON", AB_IN_COMMON
),
1868 minit ("FUNCTION", AB_FUNCTION
),
1869 minit ("SUBROUTINE", AB_SUBROUTINE
),
1870 minit ("SEQUENCE", AB_SEQUENCE
),
1871 minit ("ELEMENTAL", AB_ELEMENTAL
),
1872 minit ("PURE", AB_PURE
),
1873 minit ("RECURSIVE", AB_RECURSIVE
),
1874 minit ("GENERIC", AB_GENERIC
),
1875 minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT
),
1876 minit ("CRAY_POINTER", AB_CRAY_POINTER
),
1877 minit ("CRAY_POINTEE", AB_CRAY_POINTEE
),
1878 minit ("IS_BIND_C", AB_IS_BIND_C
),
1879 minit ("IS_C_INTEROP", AB_IS_C_INTEROP
),
1880 minit ("IS_ISO_C", AB_IS_ISO_C
),
1881 minit ("VALUE", AB_VALUE
),
1882 minit ("ALLOC_COMP", AB_ALLOC_COMP
),
1883 minit ("COARRAY_COMP", AB_COARRAY_COMP
),
1884 minit ("LOCK_COMP", AB_LOCK_COMP
),
1885 minit ("POINTER_COMP", AB_POINTER_COMP
),
1886 minit ("PROC_POINTER_COMP", AB_PROC_POINTER_COMP
),
1887 minit ("PRIVATE_COMP", AB_PRIVATE_COMP
),
1888 minit ("ZERO_COMP", AB_ZERO_COMP
),
1889 minit ("PROTECTED", AB_PROTECTED
),
1890 minit ("ABSTRACT", AB_ABSTRACT
),
1891 minit ("IS_CLASS", AB_IS_CLASS
),
1892 minit ("PROCEDURE", AB_PROCEDURE
),
1893 minit ("PROC_POINTER", AB_PROC_POINTER
),
1894 minit ("VTYPE", AB_VTYPE
),
1895 minit ("VTAB", AB_VTAB
),
1896 minit ("CLASS_POINTER", AB_CLASS_POINTER
),
1897 minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE
),
1898 minit ("UNLIMITED_POLY", AB_UNLIMITED_POLY
),
1902 /* For binding attributes. */
1903 static const mstring binding_passing
[] =
1906 minit ("NOPASS", 1),
1909 static const mstring binding_overriding
[] =
1911 minit ("OVERRIDABLE", 0),
1912 minit ("NON_OVERRIDABLE", 1),
1913 minit ("DEFERRED", 2),
1916 static const mstring binding_generic
[] =
1918 minit ("SPECIFIC", 0),
1919 minit ("GENERIC", 1),
1922 static const mstring binding_ppc
[] =
1924 minit ("NO_PPC", 0),
1929 /* Specialization of mio_name. */
1930 DECL_MIO_NAME (ab_attribute
)
1931 DECL_MIO_NAME (ar_type
)
1932 DECL_MIO_NAME (array_type
)
1934 DECL_MIO_NAME (expr_t
)
1935 DECL_MIO_NAME (gfc_access
)
1936 DECL_MIO_NAME (gfc_intrinsic_op
)
1937 DECL_MIO_NAME (ifsrc
)
1938 DECL_MIO_NAME (save_state
)
1939 DECL_MIO_NAME (procedure_type
)
1940 DECL_MIO_NAME (ref_type
)
1941 DECL_MIO_NAME (sym_flavor
)
1942 DECL_MIO_NAME (sym_intent
)
1943 #undef DECL_MIO_NAME
1945 /* Symbol attributes are stored in list with the first three elements
1946 being the enumerated fields, while the remaining elements (if any)
1947 indicate the individual attribute bits. The access field is not
1948 saved-- it controls what symbols are exported when a module is
1952 mio_symbol_attribute (symbol_attribute
*attr
)
1955 unsigned ext_attr
,extension_level
;
1959 attr
->flavor
= MIO_NAME (sym_flavor
) (attr
->flavor
, flavors
);
1960 attr
->intent
= MIO_NAME (sym_intent
) (attr
->intent
, intents
);
1961 attr
->proc
= MIO_NAME (procedure_type
) (attr
->proc
, procedures
);
1962 attr
->if_source
= MIO_NAME (ifsrc
) (attr
->if_source
, ifsrc_types
);
1963 attr
->save
= MIO_NAME (save_state
) (attr
->save
, save_status
);
1965 ext_attr
= attr
->ext_attr
;
1966 mio_integer ((int *) &ext_attr
);
1967 attr
->ext_attr
= ext_attr
;
1969 extension_level
= attr
->extension
;
1970 mio_integer ((int *) &extension_level
);
1971 attr
->extension
= extension_level
;
1973 if (iomode
== IO_OUTPUT
)
1975 if (attr
->allocatable
)
1976 MIO_NAME (ab_attribute
) (AB_ALLOCATABLE
, attr_bits
);
1977 if (attr
->artificial
)
1978 MIO_NAME (ab_attribute
) (AB_ARTIFICIAL
, attr_bits
);
1979 if (attr
->asynchronous
)
1980 MIO_NAME (ab_attribute
) (AB_ASYNCHRONOUS
, attr_bits
);
1981 if (attr
->dimension
)
1982 MIO_NAME (ab_attribute
) (AB_DIMENSION
, attr_bits
);
1983 if (attr
->codimension
)
1984 MIO_NAME (ab_attribute
) (AB_CODIMENSION
, attr_bits
);
1985 if (attr
->contiguous
)
1986 MIO_NAME (ab_attribute
) (AB_CONTIGUOUS
, attr_bits
);
1988 MIO_NAME (ab_attribute
) (AB_EXTERNAL
, attr_bits
);
1989 if (attr
->intrinsic
)
1990 MIO_NAME (ab_attribute
) (AB_INTRINSIC
, attr_bits
);
1992 MIO_NAME (ab_attribute
) (AB_OPTIONAL
, attr_bits
);
1994 MIO_NAME (ab_attribute
) (AB_POINTER
, attr_bits
);
1995 if (attr
->class_pointer
)
1996 MIO_NAME (ab_attribute
) (AB_CLASS_POINTER
, attr_bits
);
1997 if (attr
->is_protected
)
1998 MIO_NAME (ab_attribute
) (AB_PROTECTED
, attr_bits
);
2000 MIO_NAME (ab_attribute
) (AB_VALUE
, attr_bits
);
2001 if (attr
->volatile_
)
2002 MIO_NAME (ab_attribute
) (AB_VOLATILE
, attr_bits
);
2004 MIO_NAME (ab_attribute
) (AB_TARGET
, attr_bits
);
2005 if (attr
->threadprivate
)
2006 MIO_NAME (ab_attribute
) (AB_THREADPRIVATE
, attr_bits
);
2008 MIO_NAME (ab_attribute
) (AB_DUMMY
, attr_bits
);
2010 MIO_NAME (ab_attribute
) (AB_RESULT
, attr_bits
);
2011 /* We deliberately don't preserve the "entry" flag. */
2014 MIO_NAME (ab_attribute
) (AB_DATA
, attr_bits
);
2015 if (attr
->in_namelist
)
2016 MIO_NAME (ab_attribute
) (AB_IN_NAMELIST
, attr_bits
);
2017 if (attr
->in_common
)
2018 MIO_NAME (ab_attribute
) (AB_IN_COMMON
, attr_bits
);
2021 MIO_NAME (ab_attribute
) (AB_FUNCTION
, attr_bits
);
2022 if (attr
->subroutine
)
2023 MIO_NAME (ab_attribute
) (AB_SUBROUTINE
, attr_bits
);
2025 MIO_NAME (ab_attribute
) (AB_GENERIC
, attr_bits
);
2027 MIO_NAME (ab_attribute
) (AB_ABSTRACT
, attr_bits
);
2030 MIO_NAME (ab_attribute
) (AB_SEQUENCE
, attr_bits
);
2031 if (attr
->elemental
)
2032 MIO_NAME (ab_attribute
) (AB_ELEMENTAL
, attr_bits
);
2034 MIO_NAME (ab_attribute
) (AB_PURE
, attr_bits
);
2035 if (attr
->implicit_pure
)
2036 MIO_NAME (ab_attribute
) (AB_IMPLICIT_PURE
, attr_bits
);
2037 if (attr
->unlimited_polymorphic
)
2038 MIO_NAME (ab_attribute
) (AB_UNLIMITED_POLY
, attr_bits
);
2039 if (attr
->recursive
)
2040 MIO_NAME (ab_attribute
) (AB_RECURSIVE
, attr_bits
);
2041 if (attr
->always_explicit
)
2042 MIO_NAME (ab_attribute
) (AB_ALWAYS_EXPLICIT
, attr_bits
);
2043 if (attr
->cray_pointer
)
2044 MIO_NAME (ab_attribute
) (AB_CRAY_POINTER
, attr_bits
);
2045 if (attr
->cray_pointee
)
2046 MIO_NAME (ab_attribute
) (AB_CRAY_POINTEE
, attr_bits
);
2047 if (attr
->is_bind_c
)
2048 MIO_NAME(ab_attribute
) (AB_IS_BIND_C
, attr_bits
);
2049 if (attr
->is_c_interop
)
2050 MIO_NAME(ab_attribute
) (AB_IS_C_INTEROP
, attr_bits
);
2052 MIO_NAME(ab_attribute
) (AB_IS_ISO_C
, attr_bits
);
2053 if (attr
->alloc_comp
)
2054 MIO_NAME (ab_attribute
) (AB_ALLOC_COMP
, attr_bits
);
2055 if (attr
->pointer_comp
)
2056 MIO_NAME (ab_attribute
) (AB_POINTER_COMP
, attr_bits
);
2057 if (attr
->proc_pointer_comp
)
2058 MIO_NAME (ab_attribute
) (AB_PROC_POINTER_COMP
, attr_bits
);
2059 if (attr
->private_comp
)
2060 MIO_NAME (ab_attribute
) (AB_PRIVATE_COMP
, attr_bits
);
2061 if (attr
->coarray_comp
)
2062 MIO_NAME (ab_attribute
) (AB_COARRAY_COMP
, attr_bits
);
2063 if (attr
->lock_comp
)
2064 MIO_NAME (ab_attribute
) (AB_LOCK_COMP
, attr_bits
);
2065 if (attr
->zero_comp
)
2066 MIO_NAME (ab_attribute
) (AB_ZERO_COMP
, attr_bits
);
2068 MIO_NAME (ab_attribute
) (AB_IS_CLASS
, attr_bits
);
2069 if (attr
->procedure
)
2070 MIO_NAME (ab_attribute
) (AB_PROCEDURE
, attr_bits
);
2071 if (attr
->proc_pointer
)
2072 MIO_NAME (ab_attribute
) (AB_PROC_POINTER
, attr_bits
);
2074 MIO_NAME (ab_attribute
) (AB_VTYPE
, attr_bits
);
2076 MIO_NAME (ab_attribute
) (AB_VTAB
, attr_bits
);
2086 if (t
== ATOM_RPAREN
)
2089 bad_module ("Expected attribute bit name");
2091 switch ((ab_attribute
) find_enum (attr_bits
))
2093 case AB_ALLOCATABLE
:
2094 attr
->allocatable
= 1;
2097 attr
->artificial
= 1;
2099 case AB_ASYNCHRONOUS
:
2100 attr
->asynchronous
= 1;
2103 attr
->dimension
= 1;
2105 case AB_CODIMENSION
:
2106 attr
->codimension
= 1;
2109 attr
->contiguous
= 1;
2115 attr
->intrinsic
= 1;
2123 case AB_CLASS_POINTER
:
2124 attr
->class_pointer
= 1;
2127 attr
->is_protected
= 1;
2133 attr
->volatile_
= 1;
2138 case AB_THREADPRIVATE
:
2139 attr
->threadprivate
= 1;
2150 case AB_IN_NAMELIST
:
2151 attr
->in_namelist
= 1;
2154 attr
->in_common
= 1;
2160 attr
->subroutine
= 1;
2172 attr
->elemental
= 1;
2177 case AB_IMPLICIT_PURE
:
2178 attr
->implicit_pure
= 1;
2180 case AB_UNLIMITED_POLY
:
2181 attr
->unlimited_polymorphic
= 1;
2184 attr
->recursive
= 1;
2186 case AB_ALWAYS_EXPLICIT
:
2187 attr
->always_explicit
= 1;
2189 case AB_CRAY_POINTER
:
2190 attr
->cray_pointer
= 1;
2192 case AB_CRAY_POINTEE
:
2193 attr
->cray_pointee
= 1;
2196 attr
->is_bind_c
= 1;
2198 case AB_IS_C_INTEROP
:
2199 attr
->is_c_interop
= 1;
2205 attr
->alloc_comp
= 1;
2207 case AB_COARRAY_COMP
:
2208 attr
->coarray_comp
= 1;
2211 attr
->lock_comp
= 1;
2213 case AB_POINTER_COMP
:
2214 attr
->pointer_comp
= 1;
2216 case AB_PROC_POINTER_COMP
:
2217 attr
->proc_pointer_comp
= 1;
2219 case AB_PRIVATE_COMP
:
2220 attr
->private_comp
= 1;
2223 attr
->zero_comp
= 1;
2229 attr
->procedure
= 1;
2231 case AB_PROC_POINTER
:
2232 attr
->proc_pointer
= 1;
2246 static const mstring bt_types
[] = {
2247 minit ("INTEGER", BT_INTEGER
),
2248 minit ("REAL", BT_REAL
),
2249 minit ("COMPLEX", BT_COMPLEX
),
2250 minit ("LOGICAL", BT_LOGICAL
),
2251 minit ("CHARACTER", BT_CHARACTER
),
2252 minit ("DERIVED", BT_DERIVED
),
2253 minit ("CLASS", BT_CLASS
),
2254 minit ("PROCEDURE", BT_PROCEDURE
),
2255 minit ("UNKNOWN", BT_UNKNOWN
),
2256 minit ("VOID", BT_VOID
),
2257 minit ("ASSUMED", BT_ASSUMED
),
2263 mio_charlen (gfc_charlen
**clp
)
2269 if (iomode
== IO_OUTPUT
)
2273 mio_expr (&cl
->length
);
2277 if (peek_atom () != ATOM_RPAREN
)
2279 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2280 mio_expr (&cl
->length
);
2289 /* See if a name is a generated name. */
2292 check_unique_name (const char *name
)
2294 return *name
== '@';
2299 mio_typespec (gfc_typespec
*ts
)
2303 ts
->type
= MIO_NAME (bt
) (ts
->type
, bt_types
);
2305 if (ts
->type
!= BT_DERIVED
&& ts
->type
!= BT_CLASS
)
2306 mio_integer (&ts
->kind
);
2308 mio_symbol_ref (&ts
->u
.derived
);
2310 mio_symbol_ref (&ts
->interface
);
2312 /* Add info for C interop and is_iso_c. */
2313 mio_integer (&ts
->is_c_interop
);
2314 mio_integer (&ts
->is_iso_c
);
2316 /* If the typespec is for an identifier either from iso_c_binding, or
2317 a constant that was initialized to an identifier from it, use the
2318 f90_type. Otherwise, use the ts->type, since it shouldn't matter. */
2320 ts
->f90_type
= MIO_NAME (bt
) (ts
->f90_type
, bt_types
);
2322 ts
->f90_type
= MIO_NAME (bt
) (ts
->type
, bt_types
);
2324 if (ts
->type
!= BT_CHARACTER
)
2326 /* ts->u.cl is only valid for BT_CHARACTER. */
2331 mio_charlen (&ts
->u
.cl
);
2333 /* So as not to disturb the existing API, use an ATOM_NAME to
2334 transmit deferred characteristic for characters (F2003). */
2335 if (iomode
== IO_OUTPUT
)
2337 if (ts
->type
== BT_CHARACTER
&& ts
->deferred
)
2338 write_atom (ATOM_NAME
, "DEFERRED_CL");
2340 else if (peek_atom () != ATOM_RPAREN
)
2342 if (parse_atom () != ATOM_NAME
)
2343 bad_module ("Expected string");
2351 static const mstring array_spec_types
[] = {
2352 minit ("EXPLICIT", AS_EXPLICIT
),
2353 minit ("ASSUMED_RANK", AS_ASSUMED_RANK
),
2354 minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE
),
2355 minit ("DEFERRED", AS_DEFERRED
),
2356 minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE
),
2362 mio_array_spec (gfc_array_spec
**asp
)
2369 if (iomode
== IO_OUTPUT
)
2377 /* mio_integer expects nonnegative values. */
2378 rank
= as
->rank
> 0 ? as
->rank
: 0;
2379 mio_integer (&rank
);
2383 if (peek_atom () == ATOM_RPAREN
)
2389 *asp
= as
= gfc_get_array_spec ();
2390 mio_integer (&as
->rank
);
2393 mio_integer (&as
->corank
);
2394 as
->type
= MIO_NAME (array_type
) (as
->type
, array_spec_types
);
2396 if (iomode
== IO_INPUT
&& as
->type
== AS_ASSUMED_RANK
)
2398 if (iomode
== IO_INPUT
&& as
->corank
)
2399 as
->cotype
= (as
->type
== AS_DEFERRED
) ? AS_DEFERRED
: AS_EXPLICIT
;
2401 if (as
->rank
+ as
->corank
> 0)
2402 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
2404 mio_expr (&as
->lower
[i
]);
2405 mio_expr (&as
->upper
[i
]);
2413 /* Given a pointer to an array reference structure (which lives in a
2414 gfc_ref structure), find the corresponding array specification
2415 structure. Storing the pointer in the ref structure doesn't quite
2416 work when loading from a module. Generating code for an array
2417 reference also needs more information than just the array spec. */
2419 static const mstring array_ref_types
[] = {
2420 minit ("FULL", AR_FULL
),
2421 minit ("ELEMENT", AR_ELEMENT
),
2422 minit ("SECTION", AR_SECTION
),
2428 mio_array_ref (gfc_array_ref
*ar
)
2433 ar
->type
= MIO_NAME (ar_type
) (ar
->type
, array_ref_types
);
2434 mio_integer (&ar
->dimen
);
2442 for (i
= 0; i
< ar
->dimen
; i
++)
2443 mio_expr (&ar
->start
[i
]);
2448 for (i
= 0; i
< ar
->dimen
; i
++)
2450 mio_expr (&ar
->start
[i
]);
2451 mio_expr (&ar
->end
[i
]);
2452 mio_expr (&ar
->stride
[i
]);
2458 gfc_internal_error ("mio_array_ref(): Unknown array ref");
2461 /* Unfortunately, ar->dimen_type is an anonymous enumerated type so
2462 we can't call mio_integer directly. Instead loop over each element
2463 and cast it to/from an integer. */
2464 if (iomode
== IO_OUTPUT
)
2466 for (i
= 0; i
< ar
->dimen
; i
++)
2468 int tmp
= (int)ar
->dimen_type
[i
];
2469 write_atom (ATOM_INTEGER
, &tmp
);
2474 for (i
= 0; i
< ar
->dimen
; i
++)
2476 require_atom (ATOM_INTEGER
);
2477 ar
->dimen_type
[i
] = (enum gfc_array_ref_dimen_type
) atom_int
;
2481 if (iomode
== IO_INPUT
)
2483 ar
->where
= gfc_current_locus
;
2485 for (i
= 0; i
< ar
->dimen
; i
++)
2486 ar
->c_where
[i
] = gfc_current_locus
;
2493 /* Saves or restores a pointer. The pointer is converted back and
2494 forth from an integer. We return the pointer_info pointer so that
2495 the caller can take additional action based on the pointer type. */
2497 static pointer_info
*
2498 mio_pointer_ref (void *gp
)
2502 if (iomode
== IO_OUTPUT
)
2504 p
= get_pointer (*((char **) gp
));
2505 write_atom (ATOM_INTEGER
, &p
->integer
);
2509 require_atom (ATOM_INTEGER
);
2510 p
= add_fixup (atom_int
, gp
);
2517 /* Save and load references to components that occur within
2518 expressions. We have to describe these references by a number and
2519 by name. The number is necessary for forward references during
2520 reading, and the name is necessary if the symbol already exists in
2521 the namespace and is not loaded again. */
2524 mio_component_ref (gfc_component
**cp
, gfc_symbol
*sym
)
2526 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2530 p
= mio_pointer_ref (cp
);
2531 if (p
->type
== P_UNKNOWN
)
2532 p
->type
= P_COMPONENT
;
2534 if (iomode
== IO_OUTPUT
)
2535 mio_pool_string (&(*cp
)->name
);
2538 mio_internal_string (name
);
2540 if (sym
&& sym
->attr
.is_class
)
2541 sym
= sym
->components
->ts
.u
.derived
;
2543 /* It can happen that a component reference can be read before the
2544 associated derived type symbol has been loaded. Return now and
2545 wait for a later iteration of load_needed. */
2549 if (sym
->components
!= NULL
&& p
->u
.pointer
== NULL
)
2551 /* Symbol already loaded, so search by name. */
2552 q
= gfc_find_component (sym
, name
, true, true);
2555 associate_integer_pointer (p
, q
);
2558 /* Make sure this symbol will eventually be loaded. */
2559 p
= find_pointer2 (sym
);
2560 if (p
->u
.rsym
.state
== UNUSED
)
2561 p
->u
.rsym
.state
= NEEDED
;
2566 static void mio_namespace_ref (gfc_namespace
**nsp
);
2567 static void mio_formal_arglist (gfc_formal_arglist
**formal
);
2568 static void mio_typebound_proc (gfc_typebound_proc
** proc
);
2571 mio_component (gfc_component
*c
, int vtype
)
2578 if (iomode
== IO_OUTPUT
)
2580 p
= get_pointer (c
);
2581 mio_integer (&p
->integer
);
2586 p
= get_integer (n
);
2587 associate_integer_pointer (p
, c
);
2590 if (p
->type
== P_UNKNOWN
)
2591 p
->type
= P_COMPONENT
;
2593 mio_pool_string (&c
->name
);
2594 mio_typespec (&c
->ts
);
2595 mio_array_spec (&c
->as
);
2597 mio_symbol_attribute (&c
->attr
);
2598 if (c
->ts
.type
== BT_CLASS
)
2599 c
->attr
.class_ok
= 1;
2600 c
->attr
.access
= MIO_NAME (gfc_access
) (c
->attr
.access
, access_types
);
2602 if (!vtype
|| strcmp (c
->name
, "_final") == 0
2603 || strcmp (c
->name
, "_hash") == 0)
2604 mio_expr (&c
->initializer
);
2606 if (c
->attr
.proc_pointer
)
2607 mio_typebound_proc (&c
->tb
);
2614 mio_component_list (gfc_component
**cp
, int vtype
)
2616 gfc_component
*c
, *tail
;
2620 if (iomode
== IO_OUTPUT
)
2622 for (c
= *cp
; c
; c
= c
->next
)
2623 mio_component (c
, vtype
);
2632 if (peek_atom () == ATOM_RPAREN
)
2635 c
= gfc_get_component ();
2636 mio_component (c
, vtype
);
2652 mio_actual_arg (gfc_actual_arglist
*a
)
2655 mio_pool_string (&a
->name
);
2656 mio_expr (&a
->expr
);
2662 mio_actual_arglist (gfc_actual_arglist
**ap
)
2664 gfc_actual_arglist
*a
, *tail
;
2668 if (iomode
== IO_OUTPUT
)
2670 for (a
= *ap
; a
; a
= a
->next
)
2680 if (peek_atom () != ATOM_LPAREN
)
2683 a
= gfc_get_actual_arglist ();
2699 /* Read and write formal argument lists. */
2702 mio_formal_arglist (gfc_formal_arglist
**formal
)
2704 gfc_formal_arglist
*f
, *tail
;
2708 if (iomode
== IO_OUTPUT
)
2710 for (f
= *formal
; f
; f
= f
->next
)
2711 mio_symbol_ref (&f
->sym
);
2715 *formal
= tail
= NULL
;
2717 while (peek_atom () != ATOM_RPAREN
)
2719 f
= gfc_get_formal_arglist ();
2720 mio_symbol_ref (&f
->sym
);
2722 if (*formal
== NULL
)
2735 /* Save or restore a reference to a symbol node. */
2738 mio_symbol_ref (gfc_symbol
**symp
)
2742 p
= mio_pointer_ref (symp
);
2743 if (p
->type
== P_UNKNOWN
)
2746 if (iomode
== IO_OUTPUT
)
2748 if (p
->u
.wsym
.state
== UNREFERENCED
)
2749 p
->u
.wsym
.state
= NEEDS_WRITE
;
2753 if (p
->u
.rsym
.state
== UNUSED
)
2754 p
->u
.rsym
.state
= NEEDED
;
2760 /* Save or restore a reference to a symtree node. */
2763 mio_symtree_ref (gfc_symtree
**stp
)
2768 if (iomode
== IO_OUTPUT
)
2769 mio_symbol_ref (&(*stp
)->n
.sym
);
2772 require_atom (ATOM_INTEGER
);
2773 p
= get_integer (atom_int
);
2775 /* An unused equivalence member; make a symbol and a symtree
2777 if (in_load_equiv
&& p
->u
.rsym
.symtree
== NULL
)
2779 /* Since this is not used, it must have a unique name. */
2780 p
->u
.rsym
.symtree
= gfc_get_unique_symtree (gfc_current_ns
);
2782 /* Make the symbol. */
2783 if (p
->u
.rsym
.sym
== NULL
)
2785 p
->u
.rsym
.sym
= gfc_new_symbol (p
->u
.rsym
.true_name
,
2787 p
->u
.rsym
.sym
->module
= gfc_get_string (p
->u
.rsym
.module
);
2790 p
->u
.rsym
.symtree
->n
.sym
= p
->u
.rsym
.sym
;
2791 p
->u
.rsym
.symtree
->n
.sym
->refs
++;
2792 p
->u
.rsym
.referenced
= 1;
2794 /* If the symbol is PRIVATE and in COMMON, load_commons will
2795 generate a fixup symbol, which must be associated. */
2797 resolve_fixups (p
->fixup
, p
->u
.rsym
.sym
);
2801 if (p
->type
== P_UNKNOWN
)
2804 if (p
->u
.rsym
.state
== UNUSED
)
2805 p
->u
.rsym
.state
= NEEDED
;
2807 if (p
->u
.rsym
.symtree
!= NULL
)
2809 *stp
= p
->u
.rsym
.symtree
;
2813 f
= XCNEW (fixup_t
);
2815 f
->next
= p
->u
.rsym
.stfixup
;
2816 p
->u
.rsym
.stfixup
= f
;
2818 f
->pointer
= (void **) stp
;
2825 mio_iterator (gfc_iterator
**ip
)
2831 if (iomode
== IO_OUTPUT
)
2838 if (peek_atom () == ATOM_RPAREN
)
2844 *ip
= gfc_get_iterator ();
2849 mio_expr (&iter
->var
);
2850 mio_expr (&iter
->start
);
2851 mio_expr (&iter
->end
);
2852 mio_expr (&iter
->step
);
2860 mio_constructor (gfc_constructor_base
*cp
)
2866 if (iomode
== IO_OUTPUT
)
2868 for (c
= gfc_constructor_first (*cp
); c
; c
= gfc_constructor_next (c
))
2871 mio_expr (&c
->expr
);
2872 mio_iterator (&c
->iterator
);
2878 while (peek_atom () != ATOM_RPAREN
)
2880 c
= gfc_constructor_append_expr (cp
, NULL
, NULL
);
2883 mio_expr (&c
->expr
);
2884 mio_iterator (&c
->iterator
);
2893 static const mstring ref_types
[] = {
2894 minit ("ARRAY", REF_ARRAY
),
2895 minit ("COMPONENT", REF_COMPONENT
),
2896 minit ("SUBSTRING", REF_SUBSTRING
),
2902 mio_ref (gfc_ref
**rp
)
2909 r
->type
= MIO_NAME (ref_type
) (r
->type
, ref_types
);
2914 mio_array_ref (&r
->u
.ar
);
2918 mio_symbol_ref (&r
->u
.c
.sym
);
2919 mio_component_ref (&r
->u
.c
.component
, r
->u
.c
.sym
);
2923 mio_expr (&r
->u
.ss
.start
);
2924 mio_expr (&r
->u
.ss
.end
);
2925 mio_charlen (&r
->u
.ss
.length
);
2934 mio_ref_list (gfc_ref
**rp
)
2936 gfc_ref
*ref
, *head
, *tail
;
2940 if (iomode
== IO_OUTPUT
)
2942 for (ref
= *rp
; ref
; ref
= ref
->next
)
2949 while (peek_atom () != ATOM_RPAREN
)
2952 head
= tail
= gfc_get_ref ();
2955 tail
->next
= gfc_get_ref ();
2969 /* Read and write an integer value. */
2972 mio_gmp_integer (mpz_t
*integer
)
2976 if (iomode
== IO_INPUT
)
2978 if (parse_atom () != ATOM_STRING
)
2979 bad_module ("Expected integer string");
2981 mpz_init (*integer
);
2982 if (mpz_set_str (*integer
, atom_string
, 10))
2983 bad_module ("Error converting integer");
2989 p
= mpz_get_str (NULL
, 10, *integer
);
2990 write_atom (ATOM_STRING
, p
);
2997 mio_gmp_real (mpfr_t
*real
)
3002 if (iomode
== IO_INPUT
)
3004 if (parse_atom () != ATOM_STRING
)
3005 bad_module ("Expected real string");
3008 mpfr_set_str (*real
, atom_string
, 16, GFC_RND_MODE
);
3013 p
= mpfr_get_str (NULL
, &exponent
, 16, 0, *real
, GFC_RND_MODE
);
3015 if (mpfr_nan_p (*real
) || mpfr_inf_p (*real
))
3017 write_atom (ATOM_STRING
, p
);
3022 atom_string
= XCNEWVEC (char, strlen (p
) + 20);
3024 sprintf (atom_string
, "0.%s@%ld", p
, exponent
);
3026 /* Fix negative numbers. */
3027 if (atom_string
[2] == '-')
3029 atom_string
[0] = '-';
3030 atom_string
[1] = '0';
3031 atom_string
[2] = '.';
3034 write_atom (ATOM_STRING
, atom_string
);
3042 /* Save and restore the shape of an array constructor. */
3045 mio_shape (mpz_t
**pshape
, int rank
)
3051 /* A NULL shape is represented by (). */
3054 if (iomode
== IO_OUTPUT
)
3066 if (t
== ATOM_RPAREN
)
3073 shape
= gfc_get_shape (rank
);
3077 for (n
= 0; n
< rank
; n
++)
3078 mio_gmp_integer (&shape
[n
]);
3084 static const mstring expr_types
[] = {
3085 minit ("OP", EXPR_OP
),
3086 minit ("FUNCTION", EXPR_FUNCTION
),
3087 minit ("CONSTANT", EXPR_CONSTANT
),
3088 minit ("VARIABLE", EXPR_VARIABLE
),
3089 minit ("SUBSTRING", EXPR_SUBSTRING
),
3090 minit ("STRUCTURE", EXPR_STRUCTURE
),
3091 minit ("ARRAY", EXPR_ARRAY
),
3092 minit ("NULL", EXPR_NULL
),
3093 minit ("COMPCALL", EXPR_COMPCALL
),
3097 /* INTRINSIC_ASSIGN is missing because it is used as an index for
3098 generic operators, not in expressions. INTRINSIC_USER is also
3099 replaced by the correct function name by the time we see it. */
3101 static const mstring intrinsics
[] =
3103 minit ("UPLUS", INTRINSIC_UPLUS
),
3104 minit ("UMINUS", INTRINSIC_UMINUS
),
3105 minit ("PLUS", INTRINSIC_PLUS
),
3106 minit ("MINUS", INTRINSIC_MINUS
),
3107 minit ("TIMES", INTRINSIC_TIMES
),
3108 minit ("DIVIDE", INTRINSIC_DIVIDE
),
3109 minit ("POWER", INTRINSIC_POWER
),
3110 minit ("CONCAT", INTRINSIC_CONCAT
),
3111 minit ("AND", INTRINSIC_AND
),
3112 minit ("OR", INTRINSIC_OR
),
3113 minit ("EQV", INTRINSIC_EQV
),
3114 minit ("NEQV", INTRINSIC_NEQV
),
3115 minit ("EQ_SIGN", INTRINSIC_EQ
),
3116 minit ("EQ", INTRINSIC_EQ_OS
),
3117 minit ("NE_SIGN", INTRINSIC_NE
),
3118 minit ("NE", INTRINSIC_NE_OS
),
3119 minit ("GT_SIGN", INTRINSIC_GT
),
3120 minit ("GT", INTRINSIC_GT_OS
),
3121 minit ("GE_SIGN", INTRINSIC_GE
),
3122 minit ("GE", INTRINSIC_GE_OS
),
3123 minit ("LT_SIGN", INTRINSIC_LT
),
3124 minit ("LT", INTRINSIC_LT_OS
),
3125 minit ("LE_SIGN", INTRINSIC_LE
),
3126 minit ("LE", INTRINSIC_LE_OS
),
3127 minit ("NOT", INTRINSIC_NOT
),
3128 minit ("PARENTHESES", INTRINSIC_PARENTHESES
),
3133 /* Remedy a couple of situations where the gfc_expr's can be defective. */
3136 fix_mio_expr (gfc_expr
*e
)
3138 gfc_symtree
*ns_st
= NULL
;
3141 if (iomode
!= IO_OUTPUT
)
3146 /* If this is a symtree for a symbol that came from a contained module
3147 namespace, it has a unique name and we should look in the current
3148 namespace to see if the required, non-contained symbol is available
3149 yet. If so, the latter should be written. */
3150 if (e
->symtree
->n
.sym
&& check_unique_name (e
->symtree
->name
))
3152 const char *name
= e
->symtree
->n
.sym
->name
;
3153 if (e
->symtree
->n
.sym
->attr
.flavor
== FL_DERIVED
)
3154 name
= dt_upper_string (name
);
3155 ns_st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
3158 /* On the other hand, if the existing symbol is the module name or the
3159 new symbol is a dummy argument, do not do the promotion. */
3160 if (ns_st
&& ns_st
->n
.sym
3161 && ns_st
->n
.sym
->attr
.flavor
!= FL_MODULE
3162 && !e
->symtree
->n
.sym
->attr
.dummy
)
3165 else if (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.name
)
3169 /* In some circumstances, a function used in an initialization
3170 expression, in one use associated module, can fail to be
3171 coupled to its symtree when used in a specification
3172 expression in another module. */
3173 fname
= e
->value
.function
.esym
? e
->value
.function
.esym
->name
3174 : e
->value
.function
.isym
->name
;
3175 e
->symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, fname
);
3180 /* This is probably a reference to a private procedure from another
3181 module. To prevent a segfault, make a generic with no specific
3182 instances. If this module is used, without the required
3183 specific coming from somewhere, the appropriate error message
3185 gfc_get_symbol (fname
, gfc_current_ns
, &sym
);
3186 sym
->attr
.flavor
= FL_PROCEDURE
;
3187 sym
->attr
.generic
= 1;
3188 e
->symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, fname
);
3189 gfc_commit_symbol (sym
);
3194 /* Read and write expressions. The form "()" is allowed to indicate a
3198 mio_expr (gfc_expr
**ep
)
3206 if (iomode
== IO_OUTPUT
)
3215 MIO_NAME (expr_t
) (e
->expr_type
, expr_types
);
3220 if (t
== ATOM_RPAREN
)
3227 bad_module ("Expected expression type");
3229 e
= *ep
= gfc_get_expr ();
3230 e
->where
= gfc_current_locus
;
3231 e
->expr_type
= (expr_t
) find_enum (expr_types
);
3234 mio_typespec (&e
->ts
);
3235 mio_integer (&e
->rank
);
3239 switch (e
->expr_type
)
3243 = MIO_NAME (gfc_intrinsic_op
) (e
->value
.op
.op
, intrinsics
);
3245 switch (e
->value
.op
.op
)
3247 case INTRINSIC_UPLUS
:
3248 case INTRINSIC_UMINUS
:
3250 case INTRINSIC_PARENTHESES
:
3251 mio_expr (&e
->value
.op
.op1
);
3254 case INTRINSIC_PLUS
:
3255 case INTRINSIC_MINUS
:
3256 case INTRINSIC_TIMES
:
3257 case INTRINSIC_DIVIDE
:
3258 case INTRINSIC_POWER
:
3259 case INTRINSIC_CONCAT
:
3263 case INTRINSIC_NEQV
:
3265 case INTRINSIC_EQ_OS
:
3267 case INTRINSIC_NE_OS
:
3269 case INTRINSIC_GT_OS
:
3271 case INTRINSIC_GE_OS
:
3273 case INTRINSIC_LT_OS
:
3275 case INTRINSIC_LE_OS
:
3276 mio_expr (&e
->value
.op
.op1
);
3277 mio_expr (&e
->value
.op
.op2
);
3281 bad_module ("Bad operator");
3287 mio_symtree_ref (&e
->symtree
);
3288 mio_actual_arglist (&e
->value
.function
.actual
);
3290 if (iomode
== IO_OUTPUT
)
3292 e
->value
.function
.name
3293 = mio_allocated_string (e
->value
.function
.name
);
3294 flag
= e
->value
.function
.esym
!= NULL
;
3295 mio_integer (&flag
);
3297 mio_symbol_ref (&e
->value
.function
.esym
);
3299 write_atom (ATOM_STRING
, e
->value
.function
.isym
->name
);
3303 require_atom (ATOM_STRING
);
3304 e
->value
.function
.name
= gfc_get_string (atom_string
);
3307 mio_integer (&flag
);
3309 mio_symbol_ref (&e
->value
.function
.esym
);
3312 require_atom (ATOM_STRING
);
3313 e
->value
.function
.isym
= gfc_find_function (atom_string
);
3321 mio_symtree_ref (&e
->symtree
);
3322 mio_ref_list (&e
->ref
);
3325 case EXPR_SUBSTRING
:
3326 e
->value
.character
.string
3327 = CONST_CAST (gfc_char_t
*,
3328 mio_allocated_wide_string (e
->value
.character
.string
,
3329 e
->value
.character
.length
));
3330 mio_ref_list (&e
->ref
);
3333 case EXPR_STRUCTURE
:
3335 mio_constructor (&e
->value
.constructor
);
3336 mio_shape (&e
->shape
, e
->rank
);
3343 mio_gmp_integer (&e
->value
.integer
);
3347 gfc_set_model_kind (e
->ts
.kind
);
3348 mio_gmp_real (&e
->value
.real
);
3352 gfc_set_model_kind (e
->ts
.kind
);
3353 mio_gmp_real (&mpc_realref (e
->value
.complex));
3354 mio_gmp_real (&mpc_imagref (e
->value
.complex));
3358 mio_integer (&e
->value
.logical
);
3362 mio_integer (&e
->value
.character
.length
);
3363 e
->value
.character
.string
3364 = CONST_CAST (gfc_char_t
*,
3365 mio_allocated_wide_string (e
->value
.character
.string
,
3366 e
->value
.character
.length
));
3370 bad_module ("Bad type in constant expression");
3388 /* Read and write namelists. */
3391 mio_namelist (gfc_symbol
*sym
)
3393 gfc_namelist
*n
, *m
;
3394 const char *check_name
;
3398 if (iomode
== IO_OUTPUT
)
3400 for (n
= sym
->namelist
; n
; n
= n
->next
)
3401 mio_symbol_ref (&n
->sym
);
3405 /* This departure from the standard is flagged as an error.
3406 It does, in fact, work correctly. TODO: Allow it
3408 if (sym
->attr
.flavor
== FL_NAMELIST
)
3410 check_name
= find_use_name (sym
->name
, false);
3411 if (check_name
&& strcmp (check_name
, sym
->name
) != 0)
3412 gfc_error ("Namelist %s cannot be renamed by USE "
3413 "association to %s", sym
->name
, check_name
);
3417 while (peek_atom () != ATOM_RPAREN
)
3419 n
= gfc_get_namelist ();
3420 mio_symbol_ref (&n
->sym
);
3422 if (sym
->namelist
== NULL
)
3429 sym
->namelist_tail
= m
;
3436 /* Save/restore lists of gfc_interface structures. When loading an
3437 interface, we are really appending to the existing list of
3438 interfaces. Checking for duplicate and ambiguous interfaces has to
3439 be done later when all symbols have been loaded. */
3442 mio_interface_rest (gfc_interface
**ip
)
3444 gfc_interface
*tail
, *p
;
3445 pointer_info
*pi
= NULL
;
3447 if (iomode
== IO_OUTPUT
)
3450 for (p
= *ip
; p
; p
= p
->next
)
3451 mio_symbol_ref (&p
->sym
);
3466 if (peek_atom () == ATOM_RPAREN
)
3469 p
= gfc_get_interface ();
3470 p
->where
= gfc_current_locus
;
3471 pi
= mio_symbol_ref (&p
->sym
);
3487 /* Save/restore a nameless operator interface. */
3490 mio_interface (gfc_interface
**ip
)
3493 mio_interface_rest (ip
);
3497 /* Save/restore a named operator interface. */
3500 mio_symbol_interface (const char **name
, const char **module
,
3504 mio_pool_string (name
);
3505 mio_pool_string (module
);
3506 mio_interface_rest (ip
);
3511 mio_namespace_ref (gfc_namespace
**nsp
)
3516 p
= mio_pointer_ref (nsp
);
3518 if (p
->type
== P_UNKNOWN
)
3519 p
->type
= P_NAMESPACE
;
3521 if (iomode
== IO_INPUT
&& p
->integer
!= 0)
3523 ns
= (gfc_namespace
*) p
->u
.pointer
;
3526 ns
= gfc_get_namespace (NULL
, 0);
3527 associate_integer_pointer (p
, ns
);
3535 /* Save/restore the f2k_derived namespace of a derived-type symbol. */
3537 static gfc_namespace
* current_f2k_derived
;
3540 mio_typebound_proc (gfc_typebound_proc
** proc
)
3543 int overriding_flag
;
3545 if (iomode
== IO_INPUT
)
3547 *proc
= gfc_get_typebound_proc (NULL
);
3548 (*proc
)->where
= gfc_current_locus
;
3554 (*proc
)->access
= MIO_NAME (gfc_access
) ((*proc
)->access
, access_types
);
3556 /* IO the NON_OVERRIDABLE/DEFERRED combination. */
3557 gcc_assert (!((*proc
)->deferred
&& (*proc
)->non_overridable
));
3558 overriding_flag
= ((*proc
)->deferred
<< 1) | (*proc
)->non_overridable
;
3559 overriding_flag
= mio_name (overriding_flag
, binding_overriding
);
3560 (*proc
)->deferred
= ((overriding_flag
& 2) != 0);
3561 (*proc
)->non_overridable
= ((overriding_flag
& 1) != 0);
3562 gcc_assert (!((*proc
)->deferred
&& (*proc
)->non_overridable
));
3564 (*proc
)->nopass
= mio_name ((*proc
)->nopass
, binding_passing
);
3565 (*proc
)->is_generic
= mio_name ((*proc
)->is_generic
, binding_generic
);
3566 (*proc
)->ppc
= mio_name((*proc
)->ppc
, binding_ppc
);
3568 mio_pool_string (&((*proc
)->pass_arg
));
3570 flag
= (int) (*proc
)->pass_arg_num
;
3571 mio_integer (&flag
);
3572 (*proc
)->pass_arg_num
= (unsigned) flag
;
3574 if ((*proc
)->is_generic
)
3581 if (iomode
== IO_OUTPUT
)
3582 for (g
= (*proc
)->u
.generic
; g
; g
= g
->next
)
3584 iop
= (int) g
->is_operator
;
3586 mio_allocated_string (g
->specific_st
->name
);
3590 (*proc
)->u
.generic
= NULL
;
3591 while (peek_atom () != ATOM_RPAREN
)
3593 gfc_symtree
** sym_root
;
3595 g
= gfc_get_tbp_generic ();
3599 g
->is_operator
= (bool) iop
;
3601 require_atom (ATOM_STRING
);
3602 sym_root
= ¤t_f2k_derived
->tb_sym_root
;
3603 g
->specific_st
= gfc_get_tbp_symtree (sym_root
, atom_string
);
3606 g
->next
= (*proc
)->u
.generic
;
3607 (*proc
)->u
.generic
= g
;
3613 else if (!(*proc
)->ppc
)
3614 mio_symtree_ref (&(*proc
)->u
.specific
);
3619 /* Walker-callback function for this purpose. */
3621 mio_typebound_symtree (gfc_symtree
* st
)
3623 if (iomode
== IO_OUTPUT
&& !st
->n
.tb
)
3626 if (iomode
== IO_OUTPUT
)
3629 mio_allocated_string (st
->name
);
3631 /* For IO_INPUT, the above is done in mio_f2k_derived. */
3633 mio_typebound_proc (&st
->n
.tb
);
3637 /* IO a full symtree (in all depth). */
3639 mio_full_typebound_tree (gfc_symtree
** root
)
3643 if (iomode
== IO_OUTPUT
)
3644 gfc_traverse_symtree (*root
, &mio_typebound_symtree
);
3647 while (peek_atom () == ATOM_LPAREN
)
3653 require_atom (ATOM_STRING
);
3654 st
= gfc_get_tbp_symtree (root
, atom_string
);
3657 mio_typebound_symtree (st
);
3665 mio_finalizer (gfc_finalizer
**f
)
3667 if (iomode
== IO_OUTPUT
)
3670 gcc_assert ((*f
)->proc_tree
); /* Should already be resolved. */
3671 mio_symtree_ref (&(*f
)->proc_tree
);
3675 *f
= gfc_get_finalizer ();
3676 (*f
)->where
= gfc_current_locus
; /* Value should not matter. */
3679 mio_symtree_ref (&(*f
)->proc_tree
);
3680 (*f
)->proc_sym
= NULL
;
3685 mio_f2k_derived (gfc_namespace
*f2k
)
3687 current_f2k_derived
= f2k
;
3689 /* Handle the list of finalizer procedures. */
3691 if (iomode
== IO_OUTPUT
)
3694 for (f
= f2k
->finalizers
; f
; f
= f
->next
)
3699 f2k
->finalizers
= NULL
;
3700 while (peek_atom () != ATOM_RPAREN
)
3702 gfc_finalizer
*cur
= NULL
;
3703 mio_finalizer (&cur
);
3704 cur
->next
= f2k
->finalizers
;
3705 f2k
->finalizers
= cur
;
3710 /* Handle type-bound procedures. */
3711 mio_full_typebound_tree (&f2k
->tb_sym_root
);
3713 /* Type-bound user operators. */
3714 mio_full_typebound_tree (&f2k
->tb_uop_root
);
3716 /* Type-bound intrinsic operators. */
3718 if (iomode
== IO_OUTPUT
)
3721 for (op
= GFC_INTRINSIC_BEGIN
; op
!= GFC_INTRINSIC_END
; ++op
)
3723 gfc_intrinsic_op realop
;
3725 if (op
== INTRINSIC_USER
|| !f2k
->tb_op
[op
])
3729 realop
= (gfc_intrinsic_op
) op
;
3730 mio_intrinsic_op (&realop
);
3731 mio_typebound_proc (&f2k
->tb_op
[op
]);
3736 while (peek_atom () != ATOM_RPAREN
)
3738 gfc_intrinsic_op op
= GFC_INTRINSIC_BEGIN
; /* Silence GCC. */
3741 mio_intrinsic_op (&op
);
3742 mio_typebound_proc (&f2k
->tb_op
[op
]);
3749 mio_full_f2k_derived (gfc_symbol
*sym
)
3753 if (iomode
== IO_OUTPUT
)
3755 if (sym
->f2k_derived
)
3756 mio_f2k_derived (sym
->f2k_derived
);
3760 if (peek_atom () != ATOM_RPAREN
)
3762 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
3763 mio_f2k_derived (sym
->f2k_derived
);
3766 gcc_assert (!sym
->f2k_derived
);
3773 /* Unlike most other routines, the address of the symbol node is already
3774 fixed on input and the name/module has already been filled in. */
3777 mio_symbol (gfc_symbol
*sym
)
3779 int intmod
= INTMOD_NONE
;
3783 mio_symbol_attribute (&sym
->attr
);
3784 mio_typespec (&sym
->ts
);
3785 if (sym
->ts
.type
== BT_CLASS
)
3786 sym
->attr
.class_ok
= 1;
3788 if (iomode
== IO_OUTPUT
)
3789 mio_namespace_ref (&sym
->formal_ns
);
3792 mio_namespace_ref (&sym
->formal_ns
);
3794 sym
->formal_ns
->proc_name
= sym
;
3797 /* Save/restore common block links. */
3798 mio_symbol_ref (&sym
->common_next
);
3800 mio_formal_arglist (&sym
->formal
);
3802 if (sym
->attr
.flavor
== FL_PARAMETER
)
3803 mio_expr (&sym
->value
);
3805 mio_array_spec (&sym
->as
);
3807 mio_symbol_ref (&sym
->result
);
3809 if (sym
->attr
.cray_pointee
)
3810 mio_symbol_ref (&sym
->cp_pointer
);
3812 /* Note that components are always saved, even if they are supposed
3813 to be private. Component access is checked during searching. */
3815 mio_component_list (&sym
->components
, sym
->attr
.vtype
);
3817 if (sym
->components
!= NULL
)
3818 sym
->component_access
3819 = MIO_NAME (gfc_access
) (sym
->component_access
, access_types
);
3821 /* Load/save the f2k_derived namespace of a derived-type symbol. */
3822 mio_full_f2k_derived (sym
);
3826 /* Add the fields that say whether this is from an intrinsic module,
3827 and if so, what symbol it is within the module. */
3828 /* mio_integer (&(sym->from_intmod)); */
3829 if (iomode
== IO_OUTPUT
)
3831 intmod
= sym
->from_intmod
;
3832 mio_integer (&intmod
);
3836 mio_integer (&intmod
);
3837 sym
->from_intmod
= (intmod_id
) intmod
;
3840 mio_integer (&(sym
->intmod_sym_id
));
3842 if (sym
->attr
.flavor
== FL_DERIVED
)
3843 mio_integer (&(sym
->hash_value
));
3849 /************************* Top level subroutines *************************/
3851 /* Given a root symtree node and a symbol, try to find a symtree that
3852 references the symbol that is not a unique name. */
3854 static gfc_symtree
*
3855 find_symtree_for_symbol (gfc_symtree
*st
, gfc_symbol
*sym
)
3857 gfc_symtree
*s
= NULL
;
3862 s
= find_symtree_for_symbol (st
->right
, sym
);
3865 s
= find_symtree_for_symbol (st
->left
, sym
);
3869 if (st
->n
.sym
== sym
&& !check_unique_name (st
->name
))
3876 /* A recursive function to look for a specific symbol by name and by
3877 module. Whilst several symtrees might point to one symbol, its
3878 is sufficient for the purposes here than one exist. Note that
3879 generic interfaces are distinguished as are symbols that have been
3880 renamed in another module. */
3881 static gfc_symtree
*
3882 find_symbol (gfc_symtree
*st
, const char *name
,
3883 const char *module
, int generic
)
3886 gfc_symtree
*retval
, *s
;
3888 if (st
== NULL
|| st
->n
.sym
== NULL
)
3891 c
= strcmp (name
, st
->n
.sym
->name
);
3892 if (c
== 0 && st
->n
.sym
->module
3893 && strcmp (module
, st
->n
.sym
->module
) == 0
3894 && !check_unique_name (st
->name
))
3896 s
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
3898 /* Detect symbols that are renamed by use association in another
3899 module by the absence of a symtree and null attr.use_rename,
3900 since the latter is not transmitted in the module file. */
3901 if (((!generic
&& !st
->n
.sym
->attr
.generic
)
3902 || (generic
&& st
->n
.sym
->attr
.generic
))
3903 && !(s
== NULL
&& !st
->n
.sym
->attr
.use_rename
))
3907 retval
= find_symbol (st
->left
, name
, module
, generic
);
3910 retval
= find_symbol (st
->right
, name
, module
, generic
);
3916 /* Skip a list between balanced left and right parens. */
3926 switch (parse_atom ())
3949 /* Load operator interfaces from the module. Interfaces are unusual
3950 in that they attach themselves to existing symbols. */
3953 load_operator_interfaces (void)
3956 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[GFC_MAX_SYMBOL_LEN
+ 1];
3958 pointer_info
*pi
= NULL
;
3963 while (peek_atom () != ATOM_RPAREN
)
3967 mio_internal_string (name
);
3968 mio_internal_string (module
);
3970 n
= number_use_names (name
, true);
3973 for (i
= 1; i
<= n
; i
++)
3975 /* Decide if we need to load this one or not. */
3976 p
= find_use_name_n (name
, &i
, true);
3980 while (parse_atom () != ATOM_RPAREN
);
3986 uop
= gfc_get_uop (p
);
3987 pi
= mio_interface_rest (&uop
->op
);
3991 if (gfc_find_uop (p
, NULL
))
3993 uop
= gfc_get_uop (p
);
3994 uop
->op
= gfc_get_interface ();
3995 uop
->op
->where
= gfc_current_locus
;
3996 add_fixup (pi
->integer
, &uop
->op
->sym
);
4005 /* Load interfaces from the module. Interfaces are unusual in that
4006 they attach themselves to existing symbols. */
4009 load_generic_interfaces (void)
4012 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[GFC_MAX_SYMBOL_LEN
+ 1];
4014 gfc_interface
*generic
= NULL
, *gen
= NULL
;
4016 bool ambiguous_set
= false;
4020 while (peek_atom () != ATOM_RPAREN
)
4024 mio_internal_string (name
);
4025 mio_internal_string (module
);
4027 n
= number_use_names (name
, false);
4028 renamed
= n
? 1 : 0;
4031 for (i
= 1; i
<= n
; i
++)
4034 /* Decide if we need to load this one or not. */
4035 p
= find_use_name_n (name
, &i
, false);
4037 st
= find_symbol (gfc_current_ns
->sym_root
,
4038 name
, module_name
, 1);
4040 if (!p
|| gfc_find_symbol (p
, NULL
, 0, &sym
))
4042 /* Skip the specific names for these cases. */
4043 while (i
== 1 && parse_atom () != ATOM_RPAREN
);
4048 /* If the symbol exists already and is being USEd without being
4049 in an ONLY clause, do not load a new symtree(11.3.2). */
4050 if (!only_flag
&& st
)
4058 if (strcmp (st
->name
, p
) != 0)
4060 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, p
);
4066 /* Since we haven't found a valid generic interface, we had
4070 gfc_get_symbol (p
, NULL
, &sym
);
4071 sym
->name
= gfc_get_string (name
);
4072 sym
->module
= module_name
;
4073 sym
->attr
.flavor
= FL_PROCEDURE
;
4074 sym
->attr
.generic
= 1;
4075 sym
->attr
.use_assoc
= 1;
4080 /* Unless sym is a generic interface, this reference
4083 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
4087 if (st
&& !sym
->attr
.generic
4090 && strcmp (module
, sym
->module
))
4092 ambiguous_set
= true;
4097 sym
->attr
.use_only
= only_flag
;
4098 sym
->attr
.use_rename
= renamed
;
4102 mio_interface_rest (&sym
->generic
);
4103 generic
= sym
->generic
;
4105 else if (!sym
->generic
)
4107 sym
->generic
= generic
;
4108 sym
->attr
.generic_copy
= 1;
4111 /* If a procedure that is not generic has generic interfaces
4112 that include itself, it is generic! We need to take care
4113 to retain symbols ambiguous that were already so. */
4114 if (sym
->attr
.use_assoc
4115 && !sym
->attr
.generic
4116 && sym
->attr
.flavor
== FL_PROCEDURE
)
4118 for (gen
= generic
; gen
; gen
= gen
->next
)
4120 if (gen
->sym
== sym
)
4122 sym
->attr
.generic
= 1;
4137 /* Load common blocks. */
4142 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4147 while (peek_atom () != ATOM_RPAREN
)
4152 mio_internal_string (name
);
4154 p
= gfc_get_common (name
, 1);
4156 mio_symbol_ref (&p
->head
);
4157 mio_integer (&flags
);
4161 p
->threadprivate
= 1;
4164 /* Get whether this was a bind(c) common or not. */
4165 mio_integer (&p
->is_bind_c
);
4166 /* Get the binding label. */
4167 label
= read_string ();
4169 p
->binding_label
= IDENTIFIER_POINTER (get_identifier (label
));
4179 /* Load equivalences. The flag in_load_equiv informs mio_expr_ref of this
4180 so that unused variables are not loaded and so that the expression can
4186 gfc_equiv
*head
, *tail
, *end
, *eq
;
4190 in_load_equiv
= true;
4192 end
= gfc_current_ns
->equiv
;
4193 while (end
!= NULL
&& end
->next
!= NULL
)
4196 while (peek_atom () != ATOM_RPAREN
) {
4200 while(peek_atom () != ATOM_RPAREN
)
4203 head
= tail
= gfc_get_equiv ();
4206 tail
->eq
= gfc_get_equiv ();
4210 mio_pool_string (&tail
->module
);
4211 mio_expr (&tail
->expr
);
4214 /* Unused equivalence members have a unique name. In addition, it
4215 must be checked that the symbols are from the same module. */
4217 for (eq
= head
; eq
; eq
= eq
->eq
)
4219 if (eq
->expr
->symtree
->n
.sym
->module
4220 && head
->expr
->symtree
->n
.sym
->module
4221 && strcmp (head
->expr
->symtree
->n
.sym
->module
,
4222 eq
->expr
->symtree
->n
.sym
->module
) == 0
4223 && !check_unique_name (eq
->expr
->symtree
->name
))
4232 for (eq
= head
; eq
; eq
= head
)
4235 gfc_free_expr (eq
->expr
);
4241 gfc_current_ns
->equiv
= head
;
4252 in_load_equiv
= false;
4256 /* This function loads the sym_root of f2k_derived with the extensions to
4257 the derived type. */
4259 load_derived_extensions (void)
4262 gfc_symbol
*derived
;
4266 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4267 char module
[GFC_MAX_SYMBOL_LEN
+ 1];
4271 while (peek_atom () != ATOM_RPAREN
)
4274 mio_integer (&symbol
);
4275 info
= get_integer (symbol
);
4276 derived
= info
->u
.rsym
.sym
;
4278 /* This one is not being loaded. */
4279 if (!info
|| !derived
)
4281 while (peek_atom () != ATOM_RPAREN
)
4286 gcc_assert (derived
->attr
.flavor
== FL_DERIVED
);
4287 if (derived
->f2k_derived
== NULL
)
4288 derived
->f2k_derived
= gfc_get_namespace (NULL
, 0);
4290 while (peek_atom () != ATOM_RPAREN
)
4293 mio_internal_string (name
);
4294 mio_internal_string (module
);
4296 /* Only use one use name to find the symbol. */
4298 p
= find_use_name_n (name
, &j
, false);
4301 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
4303 st
= gfc_find_symtree (derived
->f2k_derived
->sym_root
, name
);
4306 /* Only use the real name in f2k_derived to ensure a single
4308 st
= gfc_new_symtree (&derived
->f2k_derived
->sym_root
, name
);
4321 /* Recursive function to traverse the pointer_info tree and load a
4322 needed symbol. We return nonzero if we load a symbol and stop the
4323 traversal, because the act of loading can alter the tree. */
4326 load_needed (pointer_info
*p
)
4337 rv
|= load_needed (p
->left
);
4338 rv
|= load_needed (p
->right
);
4340 if (p
->type
!= P_SYMBOL
|| p
->u
.rsym
.state
!= NEEDED
)
4343 p
->u
.rsym
.state
= USED
;
4345 set_module_locus (&p
->u
.rsym
.where
);
4347 sym
= p
->u
.rsym
.sym
;
4350 q
= get_integer (p
->u
.rsym
.ns
);
4352 ns
= (gfc_namespace
*) q
->u
.pointer
;
4355 /* Create an interface namespace if necessary. These are
4356 the namespaces that hold the formal parameters of module
4359 ns
= gfc_get_namespace (NULL
, 0);
4360 associate_integer_pointer (q
, ns
);
4363 /* Use the module sym as 'proc_name' so that gfc_get_symbol_decl
4364 doesn't go pear-shaped if the symbol is used. */
4366 gfc_find_symbol (p
->u
.rsym
.module
, gfc_current_ns
,
4369 sym
= gfc_new_symbol (p
->u
.rsym
.true_name
, ns
);
4370 sym
->name
= dt_lower_string (p
->u
.rsym
.true_name
);
4371 sym
->module
= gfc_get_string (p
->u
.rsym
.module
);
4372 if (p
->u
.rsym
.binding_label
)
4373 sym
->binding_label
= IDENTIFIER_POINTER (get_identifier
4374 (p
->u
.rsym
.binding_label
));
4376 associate_integer_pointer (p
, sym
);
4380 sym
->attr
.use_assoc
= 1;
4382 /* Mark as only or rename for later diagnosis for explicitly imported
4383 but not used warnings; don't mark internal symbols such as __vtab,
4384 __def_init etc. Only mark them if they have been explicitly loaded. */
4386 if (only_flag
&& sym
->name
[0] != '_' && sym
->name
[1] != '_')
4390 /* Search the use/rename list for the variable; if the variable is
4392 for (u
= gfc_rename_list
; u
; u
= u
->next
)
4394 if (strcmp (u
->use_name
, sym
->name
) == 0)
4396 sym
->attr
.use_only
= 1;
4402 if (p
->u
.rsym
.renamed
)
4403 sym
->attr
.use_rename
= 1;
4409 /* Recursive function for cleaning up things after a module has been read. */
4412 read_cleanup (pointer_info
*p
)
4420 read_cleanup (p
->left
);
4421 read_cleanup (p
->right
);
4423 if (p
->type
== P_SYMBOL
&& p
->u
.rsym
.state
== USED
&& !p
->u
.rsym
.referenced
)
4426 /* Add hidden symbols to the symtree. */
4427 q
= get_integer (p
->u
.rsym
.ns
);
4428 ns
= (gfc_namespace
*) q
->u
.pointer
;
4430 if (!p
->u
.rsym
.sym
->attr
.vtype
4431 && !p
->u
.rsym
.sym
->attr
.vtab
)
4432 st
= gfc_get_unique_symtree (ns
);
4435 /* There is no reason to use 'unique_symtrees' for vtabs or
4436 vtypes - their name is fine for a symtree and reduces the
4437 namespace pollution. */
4438 st
= gfc_find_symtree (ns
->sym_root
, p
->u
.rsym
.sym
->name
);
4440 st
= gfc_new_symtree (&ns
->sym_root
, p
->u
.rsym
.sym
->name
);
4443 st
->n
.sym
= p
->u
.rsym
.sym
;
4446 /* Fixup any symtree references. */
4447 p
->u
.rsym
.symtree
= st
;
4448 resolve_fixups (p
->u
.rsym
.stfixup
, st
);
4449 p
->u
.rsym
.stfixup
= NULL
;
4452 /* Free unused symbols. */
4453 if (p
->type
== P_SYMBOL
&& p
->u
.rsym
.state
== UNUSED
)
4454 gfc_free_symbol (p
->u
.rsym
.sym
);
4458 /* It is not quite enough to check for ambiguity in the symbols by
4459 the loaded symbol and the new symbol not being identical. */
4461 check_for_ambiguous (gfc_symbol
*st_sym
, pointer_info
*info
)
4465 symbol_attribute attr
;
4467 if (st_sym
->name
== gfc_current_ns
->proc_name
->name
)
4469 gfc_error ("'%s' of module '%s', imported at %C, is also the name of the "
4470 "current program unit", st_sym
->name
, module_name
);
4474 rsym
= info
->u
.rsym
.sym
;
4478 if (st_sym
->attr
.vtab
|| st_sym
->attr
.vtype
)
4481 /* If the existing symbol is generic from a different module and
4482 the new symbol is generic there can be no ambiguity. */
4483 if (st_sym
->attr
.generic
4485 && st_sym
->module
!= module_name
)
4487 /* The new symbol's attributes have not yet been read. Since
4488 we need attr.generic, read it directly. */
4489 get_module_locus (&locus
);
4490 set_module_locus (&info
->u
.rsym
.where
);
4493 mio_symbol_attribute (&attr
);
4494 set_module_locus (&locus
);
4503 /* Read a module file. */
4508 module_locus operator_interfaces
, user_operators
, extensions
;
4510 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4512 int ambiguous
, j
, nuse
, symbol
;
4513 pointer_info
*info
, *q
;
4514 gfc_use_rename
*u
= NULL
;
4518 get_module_locus (&operator_interfaces
); /* Skip these for now. */
4521 get_module_locus (&user_operators
);
4525 /* Skip commons, equivalences and derived type extensions for now. */
4529 get_module_locus (&extensions
);
4534 /* Create the fixup nodes for all the symbols. */
4536 while (peek_atom () != ATOM_RPAREN
)
4539 require_atom (ATOM_INTEGER
);
4540 info
= get_integer (atom_int
);
4542 info
->type
= P_SYMBOL
;
4543 info
->u
.rsym
.state
= UNUSED
;
4545 info
->u
.rsym
.true_name
= read_string ();
4546 info
->u
.rsym
.module
= read_string ();
4547 bind_label
= read_string ();
4548 if (strlen (bind_label
))
4549 info
->u
.rsym
.binding_label
= bind_label
;
4551 XDELETEVEC (bind_label
);
4553 require_atom (ATOM_INTEGER
);
4554 info
->u
.rsym
.ns
= atom_int
;
4556 get_module_locus (&info
->u
.rsym
.where
);
4559 /* See if the symbol has already been loaded by a previous module.
4560 If so, we reference the existing symbol and prevent it from
4561 being loaded again. This should not happen if the symbol being
4562 read is an index for an assumed shape dummy array (ns != 1). */
4564 sym
= find_true_name (info
->u
.rsym
.true_name
, info
->u
.rsym
.module
);
4567 || (sym
->attr
.flavor
== FL_VARIABLE
&& info
->u
.rsym
.ns
!=1))
4570 info
->u
.rsym
.state
= USED
;
4571 info
->u
.rsym
.sym
= sym
;
4573 /* Some symbols do not have a namespace (eg. formal arguments),
4574 so the automatic "unique symtree" mechanism must be suppressed
4575 by marking them as referenced. */
4576 q
= get_integer (info
->u
.rsym
.ns
);
4577 if (q
->u
.pointer
== NULL
)
4579 info
->u
.rsym
.referenced
= 1;
4583 /* If possible recycle the symtree that references the symbol.
4584 If a symtree is not found and the module does not import one,
4585 a unique-name symtree is found by read_cleanup. */
4586 st
= find_symtree_for_symbol (gfc_current_ns
->sym_root
, sym
);
4589 info
->u
.rsym
.symtree
= st
;
4590 info
->u
.rsym
.referenced
= 1;
4596 /* Parse the symtree lists. This lets us mark which symbols need to
4597 be loaded. Renaming is also done at this point by replacing the
4602 while (peek_atom () != ATOM_RPAREN
)
4604 mio_internal_string (name
);
4605 mio_integer (&ambiguous
);
4606 mio_integer (&symbol
);
4608 info
= get_integer (symbol
);
4610 /* See how many use names there are. If none, go through the start
4611 of the loop at least once. */
4612 nuse
= number_use_names (name
, false);
4613 info
->u
.rsym
.renamed
= nuse
? 1 : 0;
4618 for (j
= 1; j
<= nuse
; j
++)
4620 /* Get the jth local name for this symbol. */
4621 p
= find_use_name_n (name
, &j
, false);
4623 if (p
== NULL
&& strcmp (name
, module_name
) == 0)
4626 /* Exception: Always import vtabs & vtypes. */
4627 if (p
== NULL
&& name
[0] == '_'
4628 && (strncmp (name
, "__vtab_", 5) == 0
4629 || strncmp (name
, "__vtype_", 6) == 0))
4632 /* Skip symtree nodes not in an ONLY clause, unless there
4633 is an existing symtree loaded from another USE statement. */
4636 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
4638 && strcmp (st
->n
.sym
->name
, info
->u
.rsym
.true_name
) == 0
4639 && st
->n
.sym
->module
!= NULL
4640 && strcmp (st
->n
.sym
->module
, info
->u
.rsym
.module
) == 0)
4642 info
->u
.rsym
.symtree
= st
;
4643 info
->u
.rsym
.sym
= st
->n
.sym
;
4648 /* If a symbol of the same name and module exists already,
4649 this symbol, which is not in an ONLY clause, must not be
4650 added to the namespace(11.3.2). Note that find_symbol
4651 only returns the first occurrence that it finds. */
4652 if (!only_flag
&& !info
->u
.rsym
.renamed
4653 && strcmp (name
, module_name
) != 0
4654 && find_symbol (gfc_current_ns
->sym_root
, name
,
4658 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
4662 /* Check for ambiguous symbols. */
4663 if (check_for_ambiguous (st
->n
.sym
, info
))
4666 info
->u
.rsym
.symtree
= st
;
4670 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
4672 /* Create a symtree node in the current namespace for this
4674 st
= check_unique_name (p
)
4675 ? gfc_get_unique_symtree (gfc_current_ns
)
4676 : gfc_new_symtree (&gfc_current_ns
->sym_root
, p
);
4677 st
->ambiguous
= ambiguous
;
4679 sym
= info
->u
.rsym
.sym
;
4681 /* Create a symbol node if it doesn't already exist. */
4684 info
->u
.rsym
.sym
= gfc_new_symbol (info
->u
.rsym
.true_name
,
4686 info
->u
.rsym
.sym
->name
= dt_lower_string (info
->u
.rsym
.true_name
);
4687 sym
= info
->u
.rsym
.sym
;
4688 sym
->module
= gfc_get_string (info
->u
.rsym
.module
);
4690 if (info
->u
.rsym
.binding_label
)
4691 sym
->binding_label
=
4692 IDENTIFIER_POINTER (get_identifier
4693 (info
->u
.rsym
.binding_label
));
4699 if (strcmp (name
, p
) != 0)
4700 sym
->attr
.use_rename
= 1;
4703 || (strncmp (name
, "__vtab_", 5) != 0
4704 && strncmp (name
, "__vtype_", 6) != 0))
4705 sym
->attr
.use_only
= only_flag
;
4707 /* Store the symtree pointing to this symbol. */
4708 info
->u
.rsym
.symtree
= st
;
4710 if (info
->u
.rsym
.state
== UNUSED
)
4711 info
->u
.rsym
.state
= NEEDED
;
4712 info
->u
.rsym
.referenced
= 1;
4719 /* Load intrinsic operator interfaces. */
4720 set_module_locus (&operator_interfaces
);
4723 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
4725 if (i
== INTRINSIC_USER
)
4730 u
= find_use_operator ((gfc_intrinsic_op
) i
);
4741 mio_interface (&gfc_current_ns
->op
[i
]);
4742 if (u
&& !gfc_current_ns
->op
[i
])
4748 /* Load generic and user operator interfaces. These must follow the
4749 loading of symtree because otherwise symbols can be marked as
4752 set_module_locus (&user_operators
);
4754 load_operator_interfaces ();
4755 load_generic_interfaces ();
4760 /* At this point, we read those symbols that are needed but haven't
4761 been loaded yet. If one symbol requires another, the other gets
4762 marked as NEEDED if its previous state was UNUSED. */
4764 while (load_needed (pi_root
));
4766 /* Make sure all elements of the rename-list were found in the module. */
4768 for (u
= gfc_rename_list
; u
; u
= u
->next
)
4773 if (u
->op
== INTRINSIC_NONE
)
4775 gfc_error ("Symbol '%s' referenced at %L not found in module '%s'",
4776 u
->use_name
, &u
->where
, module_name
);
4780 if (u
->op
== INTRINSIC_USER
)
4782 gfc_error ("User operator '%s' referenced at %L not found "
4783 "in module '%s'", u
->use_name
, &u
->where
, module_name
);
4787 gfc_error ("Intrinsic operator '%s' referenced at %L not found "
4788 "in module '%s'", gfc_op2string (u
->op
), &u
->where
,
4792 /* Now we should be in a position to fill f2k_derived with derived type
4793 extensions, since everything has been loaded. */
4794 set_module_locus (&extensions
);
4795 load_derived_extensions ();
4797 /* Clean up symbol nodes that were never loaded, create references
4798 to hidden symbols. */
4800 read_cleanup (pi_root
);
4804 /* Given an access type that is specific to an entity and the default
4805 access, return nonzero if the entity is publicly accessible. If the
4806 element is declared as PUBLIC, then it is public; if declared
4807 PRIVATE, then private, and otherwise it is public unless the default
4808 access in this context has been declared PRIVATE. */
4811 check_access (gfc_access specific_access
, gfc_access default_access
)
4813 if (specific_access
== ACCESS_PUBLIC
)
4815 if (specific_access
== ACCESS_PRIVATE
)
4818 if (gfc_option
.flag_module_private
)
4819 return default_access
== ACCESS_PUBLIC
;
4821 return default_access
!= ACCESS_PRIVATE
;
4826 gfc_check_symbol_access (gfc_symbol
*sym
)
4828 if (sym
->attr
.vtab
|| sym
->attr
.vtype
)
4831 return check_access (sym
->attr
.access
, sym
->ns
->default_access
);
4835 /* A structure to remember which commons we've already written. */
4837 struct written_common
4839 BBT_HEADER(written_common
);
4840 const char *name
, *label
;
4843 static struct written_common
*written_commons
= NULL
;
4845 /* Comparison function used for balancing the binary tree. */
4848 compare_written_commons (void *a1
, void *b1
)
4850 const char *aname
= ((struct written_common
*) a1
)->name
;
4851 const char *alabel
= ((struct written_common
*) a1
)->label
;
4852 const char *bname
= ((struct written_common
*) b1
)->name
;
4853 const char *blabel
= ((struct written_common
*) b1
)->label
;
4854 int c
= strcmp (aname
, bname
);
4856 return (c
!= 0 ? c
: strcmp (alabel
, blabel
));
4859 /* Free a list of written commons. */
4862 free_written_common (struct written_common
*w
)
4868 free_written_common (w
->left
);
4870 free_written_common (w
->right
);
4875 /* Write a common block to the module -- recursive helper function. */
4878 write_common_0 (gfc_symtree
*st
, bool this_module
)
4884 struct written_common
*w
;
4885 bool write_me
= true;
4890 write_common_0 (st
->left
, this_module
);
4892 /* We will write out the binding label, or "" if no label given. */
4893 name
= st
->n
.common
->name
;
4895 label
= (p
->is_bind_c
&& p
->binding_label
) ? p
->binding_label
: "";
4897 /* Check if we've already output this common. */
4898 w
= written_commons
;
4901 int c
= strcmp (name
, w
->name
);
4902 c
= (c
!= 0 ? c
: strcmp (label
, w
->label
));
4906 w
= (c
< 0) ? w
->left
: w
->right
;
4909 if (this_module
&& p
->use_assoc
)
4914 /* Write the common to the module. */
4916 mio_pool_string (&name
);
4918 mio_symbol_ref (&p
->head
);
4919 flags
= p
->saved
? 1 : 0;
4920 if (p
->threadprivate
)
4922 mio_integer (&flags
);
4924 /* Write out whether the common block is bind(c) or not. */
4925 mio_integer (&(p
->is_bind_c
));
4927 mio_pool_string (&label
);
4930 /* Record that we have written this common. */
4931 w
= XCNEW (struct written_common
);
4934 gfc_insert_bbt (&written_commons
, w
, compare_written_commons
);
4937 write_common_0 (st
->right
, this_module
);
4941 /* Write a common, by initializing the list of written commons, calling
4942 the recursive function write_common_0() and cleaning up afterwards. */
4945 write_common (gfc_symtree
*st
)
4947 written_commons
= NULL
;
4948 write_common_0 (st
, true);
4949 write_common_0 (st
, false);
4950 free_written_common (written_commons
);
4951 written_commons
= NULL
;
4955 /* Write the blank common block to the module. */
4958 write_blank_common (void)
4960 const char * name
= BLANK_COMMON_NAME
;
4962 /* TODO: Blank commons are not bind(c). The F2003 standard probably says
4963 this, but it hasn't been checked. Just making it so for now. */
4966 if (gfc_current_ns
->blank_common
.head
== NULL
)
4971 mio_pool_string (&name
);
4973 mio_symbol_ref (&gfc_current_ns
->blank_common
.head
);
4974 saved
= gfc_current_ns
->blank_common
.saved
;
4975 mio_integer (&saved
);
4977 /* Write out whether the common block is bind(c) or not. */
4978 mio_integer (&is_bind_c
);
4980 /* Write out an empty binding label. */
4981 write_atom (ATOM_STRING
, "");
4987 /* Write equivalences to the module. */
4996 for (eq
= gfc_current_ns
->equiv
; eq
; eq
= eq
->next
)
5000 for (e
= eq
; e
; e
= e
->eq
)
5002 if (e
->module
== NULL
)
5003 e
->module
= gfc_get_string ("%s.eq.%d", module_name
, num
);
5004 mio_allocated_string (e
->module
);
5005 mio_expr (&e
->expr
);
5014 /* Write derived type extensions to the module. */
5017 write_dt_extensions (gfc_symtree
*st
)
5019 if (!gfc_check_symbol_access (st
->n
.sym
))
5021 if (!(st
->n
.sym
->ns
&& st
->n
.sym
->ns
->proc_name
5022 && st
->n
.sym
->ns
->proc_name
->attr
.flavor
== FL_MODULE
))
5026 mio_pool_string (&st
->name
);
5027 if (st
->n
.sym
->module
!= NULL
)
5028 mio_pool_string (&st
->n
.sym
->module
);
5031 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
5032 if (iomode
== IO_OUTPUT
)
5033 strcpy (name
, module_name
);
5034 mio_internal_string (name
);
5035 if (iomode
== IO_INPUT
)
5036 module_name
= gfc_get_string (name
);
5042 write_derived_extensions (gfc_symtree
*st
)
5044 if (!((st
->n
.sym
->attr
.flavor
== FL_DERIVED
)
5045 && (st
->n
.sym
->f2k_derived
!= NULL
)
5046 && (st
->n
.sym
->f2k_derived
->sym_root
!= NULL
)))
5050 mio_symbol_ref (&(st
->n
.sym
));
5051 gfc_traverse_symtree (st
->n
.sym
->f2k_derived
->sym_root
,
5052 write_dt_extensions
);
5057 /* Write a symbol to the module. */
5060 write_symbol (int n
, gfc_symbol
*sym
)
5064 if (sym
->attr
.flavor
== FL_UNKNOWN
|| sym
->attr
.flavor
== FL_LABEL
)
5065 gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym
->name
);
5069 if (sym
->attr
.flavor
== FL_DERIVED
)
5072 name
= dt_upper_string (sym
->name
);
5073 mio_pool_string (&name
);
5076 mio_pool_string (&sym
->name
);
5078 mio_pool_string (&sym
->module
);
5079 if ((sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
) && sym
->binding_label
)
5081 label
= sym
->binding_label
;
5082 mio_pool_string (&label
);
5085 write_atom (ATOM_STRING
, "");
5087 mio_pointer_ref (&sym
->ns
);
5094 /* Recursive traversal function to write the initial set of symbols to
5095 the module. We check to see if the symbol should be written
5096 according to the access specification. */
5099 write_symbol0 (gfc_symtree
*st
)
5103 bool dont_write
= false;
5108 write_symbol0 (st
->left
);
5111 if (sym
->module
== NULL
)
5112 sym
->module
= module_name
;
5114 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
5115 && !sym
->attr
.subroutine
&& !sym
->attr
.function
)
5118 if (!gfc_check_symbol_access (sym
))
5123 p
= get_pointer (sym
);
5124 if (p
->type
== P_UNKNOWN
)
5127 if (p
->u
.wsym
.state
!= WRITTEN
)
5129 write_symbol (p
->integer
, sym
);
5130 p
->u
.wsym
.state
= WRITTEN
;
5134 write_symbol0 (st
->right
);
5138 /* Type for the temporary tree used when writing secondary symbols. */
5140 struct sorted_pointer_info
5142 BBT_HEADER (sorted_pointer_info
);
5147 #define gfc_get_sorted_pointer_info() XCNEW (sorted_pointer_info)
5149 /* Recursively traverse the temporary tree, free its contents. */
5152 free_sorted_pointer_info_tree (sorted_pointer_info
*p
)
5157 free_sorted_pointer_info_tree (p
->left
);
5158 free_sorted_pointer_info_tree (p
->right
);
5163 /* Comparison function for the temporary tree. */
5166 compare_sorted_pointer_info (void *_spi1
, void *_spi2
)
5168 sorted_pointer_info
*spi1
, *spi2
;
5169 spi1
= (sorted_pointer_info
*)_spi1
;
5170 spi2
= (sorted_pointer_info
*)_spi2
;
5172 if (spi1
->p
->integer
< spi2
->p
->integer
)
5174 if (spi1
->p
->integer
> spi2
->p
->integer
)
5180 /* Finds the symbols that need to be written and collects them in the
5181 sorted_pi tree so that they can be traversed in an order
5182 independent of memory addresses. */
5185 find_symbols_to_write(sorted_pointer_info
**tree
, pointer_info
*p
)
5190 if (p
->type
== P_SYMBOL
&& p
->u
.wsym
.state
== NEEDS_WRITE
)
5192 sorted_pointer_info
*sp
= gfc_get_sorted_pointer_info();
5195 gfc_insert_bbt (tree
, sp
, compare_sorted_pointer_info
);
5198 find_symbols_to_write (tree
, p
->left
);
5199 find_symbols_to_write (tree
, p
->right
);
5203 /* Recursive function that traverses the tree of symbols that need to be
5204 written and writes them in order. */
5207 write_symbol1_recursion (sorted_pointer_info
*sp
)
5212 write_symbol1_recursion (sp
->left
);
5214 pointer_info
*p1
= sp
->p
;
5215 gcc_assert (p1
->type
== P_SYMBOL
&& p1
->u
.wsym
.state
== NEEDS_WRITE
);
5217 p1
->u
.wsym
.state
= WRITTEN
;
5218 write_symbol (p1
->integer
, p1
->u
.wsym
.sym
);
5219 p1
->u
.wsym
.sym
->attr
.public_used
= 1;
5221 write_symbol1_recursion (sp
->right
);
5225 /* Write the secondary set of symbols to the module file. These are
5226 symbols that were not public yet are needed by the public symbols
5227 or another dependent symbol. The act of writing a symbol can add
5228 symbols to the pointer_info tree, so we return nonzero if a symbol
5229 was written and pass that information upwards. The caller will
5230 then call this function again until nothing was written. It uses
5231 the utility functions and a temporary tree to ensure a reproducible
5232 ordering of the symbol output and thus the module file. */
5235 write_symbol1 (pointer_info
*p
)
5240 /* Put symbols that need to be written into a tree sorted on the
5243 sorted_pointer_info
*spi_root
= NULL
;
5244 find_symbols_to_write (&spi_root
, p
);
5246 /* No symbols to write, return. */
5250 /* Otherwise, write and free the tree again. */
5251 write_symbol1_recursion (spi_root
);
5252 free_sorted_pointer_info_tree (spi_root
);
5258 /* Write operator interfaces associated with a symbol. */
5261 write_operator (gfc_user_op
*uop
)
5263 static char nullstring
[] = "";
5264 const char *p
= nullstring
;
5266 if (uop
->op
== NULL
|| !check_access (uop
->access
, uop
->ns
->default_access
))
5269 mio_symbol_interface (&uop
->name
, &p
, &uop
->op
);
5273 /* Write generic interfaces from the namespace sym_root. */
5276 write_generic (gfc_symtree
*st
)
5283 write_generic (st
->left
);
5286 if (sym
&& !check_unique_name (st
->name
)
5287 && sym
->generic
&& gfc_check_symbol_access (sym
))
5290 sym
->module
= module_name
;
5292 mio_symbol_interface (&st
->name
, &sym
->module
, &sym
->generic
);
5295 write_generic (st
->right
);
5300 write_symtree (gfc_symtree
*st
)
5307 /* A symbol in an interface body must not be visible in the
5309 if (sym
->ns
!= gfc_current_ns
5310 && sym
->ns
->proc_name
5311 && sym
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
5314 if (!gfc_check_symbol_access (sym
)
5315 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
5316 && !sym
->attr
.subroutine
&& !sym
->attr
.function
))
5319 if (check_unique_name (st
->name
))
5322 p
= find_pointer (sym
);
5324 gfc_internal_error ("write_symtree(): Symbol not written");
5326 mio_pool_string (&st
->name
);
5327 mio_integer (&st
->ambiguous
);
5328 mio_integer (&p
->integer
);
5337 /* Write the operator interfaces. */
5340 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
5342 if (i
== INTRINSIC_USER
)
5345 mio_interface (check_access (gfc_current_ns
->operator_access
[i
],
5346 gfc_current_ns
->default_access
)
5347 ? &gfc_current_ns
->op
[i
] : NULL
);
5355 gfc_traverse_user_op (gfc_current_ns
, write_operator
);
5361 write_generic (gfc_current_ns
->sym_root
);
5367 write_blank_common ();
5368 write_common (gfc_current_ns
->common_root
);
5380 gfc_traverse_symtree (gfc_current_ns
->sym_root
,
5381 write_derived_extensions
);
5386 /* Write symbol information. First we traverse all symbols in the
5387 primary namespace, writing those that need to be written.
5388 Sometimes writing one symbol will cause another to need to be
5389 written. A list of these symbols ends up on the write stack, and
5390 we end by popping the bottom of the stack and writing the symbol
5391 until the stack is empty. */
5395 write_symbol0 (gfc_current_ns
->sym_root
);
5396 while (write_symbol1 (pi_root
))
5405 gfc_traverse_symtree (gfc_current_ns
->sym_root
, write_symtree
);
5410 /* Read a MD5 sum from the header of a module file. If the file cannot
5411 be opened, or we have any other error, we return -1. */
5414 read_md5_from_module_file (const char * filename
, unsigned char md5
[16])
5420 /* Open the file. */
5421 if ((file
= fopen (filename
, "r")) == NULL
)
5424 /* Read the first line. */
5425 if (fgets (buf
, sizeof (buf
) - 1, file
) == NULL
)
5431 /* The file also needs to be overwritten if the version number changed. */
5432 n
= strlen ("GFORTRAN module version '" MOD_VERSION
"' created");
5433 if (strncmp (buf
, "GFORTRAN module version '" MOD_VERSION
"' created", n
) != 0)
5439 /* Read a second line. */
5440 if (fgets (buf
, sizeof (buf
) - 1, file
) == NULL
)
5446 /* Close the file. */
5449 /* If the header is not what we expect, or is too short, bail out. */
5450 if (strncmp (buf
, "MD5:", 4) != 0 || strlen (buf
) < 4 + 16)
5453 /* Now, we have a real MD5, read it into the array. */
5454 for (n
= 0; n
< 16; n
++)
5458 if (sscanf (&(buf
[4+2*n
]), "%02x", &x
) != 1)
5468 /* Given module, dump it to disk. If there was an error while
5469 processing the module, dump_flag will be set to zero and we delete
5470 the module file, even if it was already there. */
5473 gfc_dump_module (const char *name
, int dump_flag
)
5476 char *filename
, *filename_tmp
;
5478 unsigned char md5_new
[16], md5_old
[16];
5480 n
= strlen (name
) + strlen (MODULE_EXTENSION
) + 1;
5481 if (gfc_option
.module_dir
!= NULL
)
5483 n
+= strlen (gfc_option
.module_dir
);
5484 filename
= (char *) alloca (n
);
5485 strcpy (filename
, gfc_option
.module_dir
);
5486 strcat (filename
, name
);
5490 filename
= (char *) alloca (n
);
5491 strcpy (filename
, name
);
5493 strcat (filename
, MODULE_EXTENSION
);
5495 /* Name of the temporary file used to write the module. */
5496 filename_tmp
= (char *) alloca (n
+ 1);
5497 strcpy (filename_tmp
, filename
);
5498 strcat (filename_tmp
, "0");
5500 /* There was an error while processing the module. We delete the
5501 module file, even if it was already there. */
5508 if (gfc_cpp_makedep ())
5509 gfc_cpp_add_target (filename
);
5511 /* Write the module to the temporary file. */
5512 module_fp
= fopen (filename_tmp
, "w");
5513 if (module_fp
== NULL
)
5514 gfc_fatal_error ("Can't open module file '%s' for writing at %C: %s",
5515 filename_tmp
, xstrerror (errno
));
5517 /* Write the header, including space reserved for the MD5 sum. */
5518 fprintf (module_fp
, "GFORTRAN module version '%s' created from %s\n"
5519 "MD5:", MOD_VERSION
, gfc_source_file
);
5520 fgetpos (module_fp
, &md5_pos
);
5521 fputs ("00000000000000000000000000000000 -- "
5522 "If you edit this, you'll get what you deserve.\n\n", module_fp
);
5524 /* Initialize the MD5 context that will be used for output. */
5525 md5_init_ctx (&ctx
);
5527 /* Write the module itself. */
5529 module_name
= gfc_get_string (name
);
5535 free_pi_tree (pi_root
);
5540 /* Write the MD5 sum to the header of the module file. */
5541 md5_finish_ctx (&ctx
, md5_new
);
5542 fsetpos (module_fp
, &md5_pos
);
5543 for (n
= 0; n
< 16; n
++)
5544 fprintf (module_fp
, "%02x", md5_new
[n
]);
5546 if (fclose (module_fp
))
5547 gfc_fatal_error ("Error writing module file '%s' for writing: %s",
5548 filename_tmp
, xstrerror (errno
));
5550 /* Read the MD5 from the header of the old module file and compare. */
5551 if (read_md5_from_module_file (filename
, md5_old
) != 0
5552 || memcmp (md5_old
, md5_new
, sizeof (md5_old
)) != 0)
5554 /* Module file have changed, replace the old one. */
5555 if (unlink (filename
) && errno
!= ENOENT
)
5556 gfc_fatal_error ("Can't delete module file '%s': %s", filename
,
5558 if (rename (filename_tmp
, filename
))
5559 gfc_fatal_error ("Can't rename module file '%s' to '%s': %s",
5560 filename_tmp
, filename
, xstrerror (errno
));
5564 if (unlink (filename_tmp
))
5565 gfc_fatal_error ("Can't delete temporary module file '%s': %s",
5566 filename_tmp
, xstrerror (errno
));
5572 create_intrinsic_function (const char *name
, int id
,
5573 const char *modname
, intmod_id module
,
5574 bool subroutine
, gfc_symbol
*result_type
)
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
;
5593 gfc_isym_id isym_id
= gfc_isym_id_by_intmod (module
, id
);
5594 isym
= gfc_intrinsic_subroutine_by_id (isym_id
);
5595 sym
->attr
.subroutine
= 1;
5599 gfc_isym_id isym_id
= gfc_isym_id_by_intmod (module
, id
);
5600 isym
= gfc_intrinsic_function_by_id (isym_id
);
5602 sym
->attr
.function
= 1;
5605 sym
->ts
.type
= BT_DERIVED
;
5606 sym
->ts
.u
.derived
= result_type
;
5607 sym
->ts
.is_c_interop
= 1;
5608 isym
->ts
.f90_type
= BT_VOID
;
5609 isym
->ts
.type
= BT_DERIVED
;
5610 isym
->ts
.f90_type
= BT_VOID
;
5611 isym
->ts
.u
.derived
= result_type
;
5612 isym
->ts
.is_c_interop
= 1;
5617 sym
->attr
.flavor
= FL_PROCEDURE
;
5618 sym
->attr
.intrinsic
= 1;
5620 sym
->module
= gfc_get_string (modname
);
5621 sym
->attr
.use_assoc
= 1;
5622 sym
->from_intmod
= module
;
5623 sym
->intmod_sym_id
= id
;
5627 /* Import the intrinsic ISO_C_BINDING module, generating symbols in
5628 the current namespace for all named constants, pointer types, and
5629 procedures in the module unless the only clause was used or a rename
5630 list was provided. */
5633 import_iso_c_binding_module (void)
5635 gfc_symbol
*mod_sym
= NULL
, *return_type
;
5636 gfc_symtree
*mod_symtree
= NULL
, *tmp_symtree
;
5637 gfc_symtree
*c_ptr
= NULL
, *c_funptr
= NULL
;
5638 const char *iso_c_module_name
= "__iso_c_binding";
5641 bool want_c_ptr
= false, want_c_funptr
= false;
5643 /* Look only in the current namespace. */
5644 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, iso_c_module_name
);
5646 if (mod_symtree
== NULL
)
5648 /* symtree doesn't already exist in current namespace. */
5649 gfc_get_sym_tree (iso_c_module_name
, gfc_current_ns
, &mod_symtree
,
5652 if (mod_symtree
!= NULL
)
5653 mod_sym
= mod_symtree
->n
.sym
;
5655 gfc_internal_error ("import_iso_c_binding_module(): Unable to "
5656 "create symbol for %s", iso_c_module_name
);
5658 mod_sym
->attr
.flavor
= FL_MODULE
;
5659 mod_sym
->attr
.intrinsic
= 1;
5660 mod_sym
->module
= gfc_get_string (iso_c_module_name
);
5661 mod_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
5664 /* Check whether C_PTR or C_FUNPTR are in the include list, if so, load it;
5665 check also whether C_NULL_(FUN)PTR or C_(FUN)LOC are requested, which
5667 for (u
= gfc_rename_list
; u
; u
= u
->next
)
5669 if (strcmp (c_interop_kinds_table
[ISOCBINDING_NULL_PTR
].name
,
5672 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_LOC
].name
,
5675 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_NULL_FUNPTR
].name
,
5677 want_c_funptr
= true;
5678 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_FUNLOC
].name
,
5680 want_c_funptr
= true;
5681 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_PTR
].name
,
5684 c_ptr
= generate_isocbinding_symbol (iso_c_module_name
,
5685 (iso_c_binding_symbol
)
5687 u
->local_name
[0] ? u
->local_name
5691 else if (strcmp (c_interop_kinds_table
[ISOCBINDING_FUNPTR
].name
,
5695 = generate_isocbinding_symbol (iso_c_module_name
,
5696 (iso_c_binding_symbol
)
5698 u
->local_name
[0] ? u
->local_name
5704 if ((want_c_ptr
|| !only_flag
) && !c_ptr
)
5705 c_ptr
= generate_isocbinding_symbol (iso_c_module_name
,
5706 (iso_c_binding_symbol
)
5708 NULL
, NULL
, only_flag
);
5709 if ((want_c_funptr
|| !only_flag
) && !c_funptr
)
5710 c_funptr
= generate_isocbinding_symbol (iso_c_module_name
,
5711 (iso_c_binding_symbol
)
5713 NULL
, NULL
, only_flag
);
5715 /* Generate the symbols for the named constants representing
5716 the kinds for intrinsic data types. */
5717 for (i
= 0; i
< ISOCBINDING_NUMBER
; i
++)
5720 for (u
= gfc_rename_list
; u
; u
= u
->next
)
5721 if (strcmp (c_interop_kinds_table
[i
].name
, u
->use_name
) == 0)
5730 #define NAMED_FUNCTION(a,b,c,d) \
5732 not_in_std = (gfc_option.allow_std & d) == 0; \
5735 #define NAMED_SUBROUTINE(a,b,c,d) \
5737 not_in_std = (gfc_option.allow_std & d) == 0; \
5740 #define NAMED_INTCST(a,b,c,d) \
5742 not_in_std = (gfc_option.allow_std & d) == 0; \
5745 #define NAMED_REALCST(a,b,c,d) \
5747 not_in_std = (gfc_option.allow_std & d) == 0; \
5750 #define NAMED_CMPXCST(a,b,c,d) \
5752 not_in_std = (gfc_option.allow_std & d) == 0; \
5755 #include "iso-c-binding.def"
5763 gfc_error ("The symbol '%s', referenced at %L, is not "
5764 "in the selected standard", name
, &u
->where
);
5770 #define NAMED_FUNCTION(a,b,c,d) \
5772 if (a == ISOCBINDING_LOC) \
5773 return_type = c_ptr->n.sym; \
5774 else if (a == ISOCBINDING_FUNLOC) \
5775 return_type = c_funptr->n.sym; \
5777 return_type = NULL; \
5778 create_intrinsic_function (u->local_name[0] \
5779 ? u->local_name : u->use_name, \
5780 a, iso_c_module_name, \
5781 INTMOD_ISO_C_BINDING, false, \
5784 #define NAMED_SUBROUTINE(a,b,c,d) \
5786 create_intrinsic_function (u->local_name[0] ? u->local_name \
5788 a, iso_c_module_name, \
5789 INTMOD_ISO_C_BINDING, true, NULL); \
5791 #include "iso-c-binding.def"
5793 case ISOCBINDING_PTR
:
5794 case ISOCBINDING_FUNPTR
:
5795 /* Already handled above. */
5798 if (i
== ISOCBINDING_NULL_PTR
)
5799 tmp_symtree
= c_ptr
;
5800 else if (i
== ISOCBINDING_NULL_FUNPTR
)
5801 tmp_symtree
= c_funptr
;
5804 generate_isocbinding_symbol (iso_c_module_name
,
5805 (iso_c_binding_symbol
) i
,
5807 ? u
->local_name
: u
->use_name
,
5808 tmp_symtree
, false);
5812 if (!found
&& !only_flag
)
5814 /* Skip, if the symbol is not in the enabled standard. */
5817 #define NAMED_FUNCTION(a,b,c,d) \
5819 if ((gfc_option.allow_std & d) == 0) \
5822 #define NAMED_SUBROUTINE(a,b,c,d) \
5824 if ((gfc_option.allow_std & d) == 0) \
5827 #define NAMED_INTCST(a,b,c,d) \
5829 if ((gfc_option.allow_std & d) == 0) \
5832 #define NAMED_REALCST(a,b,c,d) \
5834 if ((gfc_option.allow_std & d) == 0) \
5837 #define NAMED_CMPXCST(a,b,c,d) \
5839 if ((gfc_option.allow_std & d) == 0) \
5842 #include "iso-c-binding.def"
5844 ; /* Not GFC_STD_* versioned. */
5849 #define NAMED_FUNCTION(a,b,c,d) \
5851 if (a == ISOCBINDING_LOC) \
5852 return_type = c_ptr->n.sym; \
5853 else if (a == ISOCBINDING_FUNLOC) \
5854 return_type = c_funptr->n.sym; \
5856 return_type = NULL; \
5857 create_intrinsic_function (b, a, iso_c_module_name, \
5858 INTMOD_ISO_C_BINDING, false, \
5861 #define NAMED_SUBROUTINE(a,b,c,d) \
5863 create_intrinsic_function (b, a, iso_c_module_name, \
5864 INTMOD_ISO_C_BINDING, true, NULL); \
5866 #include "iso-c-binding.def"
5868 case ISOCBINDING_PTR
:
5869 case ISOCBINDING_FUNPTR
:
5870 /* Already handled above. */
5873 if (i
== ISOCBINDING_NULL_PTR
)
5874 tmp_symtree
= c_ptr
;
5875 else if (i
== ISOCBINDING_NULL_FUNPTR
)
5876 tmp_symtree
= c_funptr
;
5879 generate_isocbinding_symbol (iso_c_module_name
,
5880 (iso_c_binding_symbol
) i
, NULL
,
5881 tmp_symtree
, false);
5886 for (u
= gfc_rename_list
; u
; u
= u
->next
)
5891 gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
5892 "module ISO_C_BINDING", u
->use_name
, &u
->where
);
5897 /* Add an integer named constant from a given module. */
5900 create_int_parameter (const char *name
, int value
, const char *modname
,
5901 intmod_id module
, int id
)
5903 gfc_symtree
*tmp_symtree
;
5906 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
5907 if (tmp_symtree
!= NULL
)
5909 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
5912 gfc_error ("Symbol '%s' already declared", name
);
5915 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
5916 sym
= tmp_symtree
->n
.sym
;
5918 sym
->module
= gfc_get_string (modname
);
5919 sym
->attr
.flavor
= FL_PARAMETER
;
5920 sym
->ts
.type
= BT_INTEGER
;
5921 sym
->ts
.kind
= gfc_default_integer_kind
;
5922 sym
->value
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, value
);
5923 sym
->attr
.use_assoc
= 1;
5924 sym
->from_intmod
= module
;
5925 sym
->intmod_sym_id
= id
;
5929 /* Value is already contained by the array constructor, but not
5933 create_int_parameter_array (const char *name
, int size
, gfc_expr
*value
,
5934 const char *modname
, intmod_id module
, int id
)
5936 gfc_symtree
*tmp_symtree
;
5939 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
5940 if (tmp_symtree
!= NULL
)
5942 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
5945 gfc_error ("Symbol '%s' already declared", name
);
5948 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
5949 sym
= tmp_symtree
->n
.sym
;
5951 sym
->module
= gfc_get_string (modname
);
5952 sym
->attr
.flavor
= FL_PARAMETER
;
5953 sym
->ts
.type
= BT_INTEGER
;
5954 sym
->ts
.kind
= gfc_default_integer_kind
;
5955 sym
->attr
.use_assoc
= 1;
5956 sym
->from_intmod
= module
;
5957 sym
->intmod_sym_id
= id
;
5958 sym
->attr
.dimension
= 1;
5959 sym
->as
= gfc_get_array_spec ();
5961 sym
->as
->type
= AS_EXPLICIT
;
5962 sym
->as
->lower
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, 1);
5963 sym
->as
->upper
[0] = gfc_get_int_expr (gfc_default_integer_kind
, NULL
, size
);
5966 sym
->value
->shape
= gfc_get_shape (1);
5967 mpz_init_set_ui (sym
->value
->shape
[0], size
);
5971 /* Add an derived type for a given module. */
5974 create_derived_type (const char *name
, const char *modname
,
5975 intmod_id module
, int id
)
5977 gfc_symtree
*tmp_symtree
;
5978 gfc_symbol
*sym
, *dt_sym
;
5979 gfc_interface
*intr
, *head
;
5981 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
5982 if (tmp_symtree
!= NULL
)
5984 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
5987 gfc_error ("Symbol '%s' already declared", name
);
5990 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
5991 sym
= tmp_symtree
->n
.sym
;
5992 sym
->module
= gfc_get_string (modname
);
5993 sym
->from_intmod
= module
;
5994 sym
->intmod_sym_id
= id
;
5995 sym
->attr
.flavor
= FL_PROCEDURE
;
5996 sym
->attr
.function
= 1;
5997 sym
->attr
.generic
= 1;
5999 gfc_get_sym_tree (dt_upper_string (sym
->name
),
6000 gfc_current_ns
, &tmp_symtree
, false);
6001 dt_sym
= tmp_symtree
->n
.sym
;
6002 dt_sym
->name
= gfc_get_string (sym
->name
);
6003 dt_sym
->attr
.flavor
= FL_DERIVED
;
6004 dt_sym
->attr
.private_comp
= 1;
6005 dt_sym
->attr
.zero_comp
= 1;
6006 dt_sym
->attr
.use_assoc
= 1;
6007 dt_sym
->module
= gfc_get_string (modname
);
6008 dt_sym
->from_intmod
= module
;
6009 dt_sym
->intmod_sym_id
= id
;
6011 head
= sym
->generic
;
6012 intr
= gfc_get_interface ();
6014 intr
->where
= gfc_current_locus
;
6016 sym
->generic
= intr
;
6017 sym
->attr
.if_source
= IFSRC_DECL
;
6021 /* Read the contents of the module file into a temporary buffer. */
6024 read_module_to_tmpbuf ()
6026 /* Find out the size of the file and reserve space. Assume we're at
6028 fseek (module_fp
, 0, SEEK_END
);
6029 long file_size
= ftell (module_fp
);
6030 fseek (module_fp
, 0, SEEK_SET
);
6032 /* An extra byte for the terminating NULL. */
6033 module_content
= XNEWVEC (char, file_size
+ 1);
6035 fread (module_content
, 1, file_size
, module_fp
);
6036 module_content
[file_size
] = '\0';
6042 /* USE the ISO_FORTRAN_ENV intrinsic module. */
6045 use_iso_fortran_env_module (void)
6047 static char mod
[] = "iso_fortran_env";
6049 gfc_symbol
*mod_sym
;
6050 gfc_symtree
*mod_symtree
;
6054 intmod_sym symbol
[] = {
6055 #define NAMED_INTCST(a,b,c,d) { a, b, 0, d },
6056 #define NAMED_KINDARRAY(a,b,c,d) { a, b, 0, d },
6057 #define NAMED_DERIVED_TYPE(a,b,c,d) { a, b, 0, d },
6058 #define NAMED_FUNCTION(a,b,c,d) { a, b, c, d },
6059 #define NAMED_SUBROUTINE(a,b,c,d) { a, b, c, d },
6060 #include "iso-fortran-env.def"
6061 { ISOFORTRANENV_INVALID
, NULL
, -1234, 0 } };
6064 #define NAMED_INTCST(a,b,c,d) symbol[i++].value = c;
6065 #include "iso-fortran-env.def"
6067 /* Generate the symbol for the module itself. */
6068 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, mod
);
6069 if (mod_symtree
== NULL
)
6071 gfc_get_sym_tree (mod
, gfc_current_ns
, &mod_symtree
, false);
6072 gcc_assert (mod_symtree
);
6073 mod_sym
= mod_symtree
->n
.sym
;
6075 mod_sym
->attr
.flavor
= FL_MODULE
;
6076 mod_sym
->attr
.intrinsic
= 1;
6077 mod_sym
->module
= gfc_get_string (mod
);
6078 mod_sym
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
6081 if (!mod_symtree
->n
.sym
->attr
.intrinsic
)
6082 gfc_error ("Use of intrinsic module '%s' at %C conflicts with "
6083 "non-intrinsic module name used previously", mod
);
6085 /* Generate the symbols for the module integer named constants. */
6087 for (i
= 0; symbol
[i
].name
; i
++)
6090 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6092 if (strcmp (symbol
[i
].name
, u
->use_name
) == 0)
6097 if (!gfc_notify_std (symbol
[i
].standard
, "The symbol '%s', "
6098 "referenced at %L, is not in the selected "
6099 "standard", symbol
[i
].name
, &u
->where
))
6102 if ((gfc_option
.flag_default_integer
|| gfc_option
.flag_default_real
)
6103 && symbol
[i
].id
== ISOFORTRANENV_NUMERIC_STORAGE_SIZE
)
6104 gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named "
6105 "constant from intrinsic module "
6106 "ISO_FORTRAN_ENV at %L is incompatible with "
6107 "option %s", &u
->where
,
6108 gfc_option
.flag_default_integer
6109 ? "-fdefault-integer-8"
6110 : "-fdefault-real-8");
6111 switch (symbol
[i
].id
)
6113 #define NAMED_INTCST(a,b,c,d) \
6115 #include "iso-fortran-env.def"
6116 create_int_parameter (u
->local_name
[0] ? u
->local_name
6118 symbol
[i
].value
, mod
,
6119 INTMOD_ISO_FORTRAN_ENV
, symbol
[i
].id
);
6122 #define NAMED_KINDARRAY(a,b,KINDS,d) \
6124 expr = gfc_get_array_expr (BT_INTEGER, \
6125 gfc_default_integer_kind,\
6127 for (j = 0; KINDS[j].kind != 0; j++) \
6128 gfc_constructor_append_expr (&expr->value.constructor, \
6129 gfc_get_int_expr (gfc_default_integer_kind, NULL, \
6130 KINDS[j].kind), NULL); \
6131 create_int_parameter_array (u->local_name[0] ? u->local_name \
6134 INTMOD_ISO_FORTRAN_ENV, \
6137 #include "iso-fortran-env.def"
6139 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
6141 #include "iso-fortran-env.def"
6142 create_derived_type (u
->local_name
[0] ? u
->local_name
6144 mod
, INTMOD_ISO_FORTRAN_ENV
,
6148 #define NAMED_FUNCTION(a,b,c,d) \
6150 #include "iso-fortran-env.def"
6151 create_intrinsic_function (u
->local_name
[0] ? u
->local_name
6154 INTMOD_ISO_FORTRAN_ENV
, false,
6164 if (!found
&& !only_flag
)
6166 if ((gfc_option
.allow_std
& symbol
[i
].standard
) == 0)
6169 if ((gfc_option
.flag_default_integer
|| gfc_option
.flag_default_real
)
6170 && symbol
[i
].id
== ISOFORTRANENV_NUMERIC_STORAGE_SIZE
)
6171 gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
6172 "from intrinsic module ISO_FORTRAN_ENV at %C is "
6173 "incompatible with option %s",
6174 gfc_option
.flag_default_integer
6175 ? "-fdefault-integer-8" : "-fdefault-real-8");
6177 switch (symbol
[i
].id
)
6179 #define NAMED_INTCST(a,b,c,d) \
6181 #include "iso-fortran-env.def"
6182 create_int_parameter (symbol
[i
].name
, symbol
[i
].value
, mod
,
6183 INTMOD_ISO_FORTRAN_ENV
, symbol
[i
].id
);
6186 #define NAMED_KINDARRAY(a,b,KINDS,d) \
6188 expr = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, \
6190 for (j = 0; KINDS[j].kind != 0; j++) \
6191 gfc_constructor_append_expr (&expr->value.constructor, \
6192 gfc_get_int_expr (gfc_default_integer_kind, NULL, \
6193 KINDS[j].kind), NULL); \
6194 create_int_parameter_array (symbol[i].name, j, expr, mod, \
6195 INTMOD_ISO_FORTRAN_ENV, symbol[i].id);\
6197 #include "iso-fortran-env.def"
6199 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
6201 #include "iso-fortran-env.def"
6202 create_derived_type (symbol
[i
].name
, mod
, INTMOD_ISO_FORTRAN_ENV
,
6206 #define NAMED_FUNCTION(a,b,c,d) \
6208 #include "iso-fortran-env.def"
6209 create_intrinsic_function (symbol
[i
].name
, symbol
[i
].id
, mod
,
6210 INTMOD_ISO_FORTRAN_ENV
, false,
6220 for (u
= gfc_rename_list
; u
; u
= u
->next
)
6225 gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
6226 "module ISO_FORTRAN_ENV", u
->use_name
, &u
->where
);
6231 /* Process a USE directive. */
6234 gfc_use_module (gfc_use_list
*module
)
6239 gfc_symtree
*mod_symtree
;
6240 gfc_use_list
*use_stmt
;
6241 locus old_locus
= gfc_current_locus
;
6243 gfc_current_locus
= module
->where
;
6244 module_name
= module
->module_name
;
6245 gfc_rename_list
= module
->rename
;
6246 only_flag
= module
->only_flag
;
6248 filename
= XALLOCAVEC (char, strlen (module_name
) + strlen (MODULE_EXTENSION
)
6250 strcpy (filename
, module_name
);
6251 strcat (filename
, MODULE_EXTENSION
);
6253 /* First, try to find an non-intrinsic module, unless the USE statement
6254 specified that the module is intrinsic. */
6256 if (!module
->intrinsic
)
6257 module_fp
= gfc_open_included_file (filename
, true, true);
6259 /* Then, see if it's an intrinsic one, unless the USE statement
6260 specified that the module is non-intrinsic. */
6261 if (module_fp
== NULL
&& !module
->non_intrinsic
)
6263 if (strcmp (module_name
, "iso_fortran_env") == 0
6264 && gfc_notify_std (GFC_STD_F2003
, "ISO_FORTRAN_ENV "
6265 "intrinsic module at %C"))
6267 use_iso_fortran_env_module ();
6268 free_rename (module
->rename
);
6269 module
->rename
= NULL
;
6270 gfc_current_locus
= old_locus
;
6271 module
->intrinsic
= true;
6275 if (strcmp (module_name
, "iso_c_binding") == 0
6276 && gfc_notify_std (GFC_STD_F2003
, "ISO_C_BINDING module at %C"))
6278 import_iso_c_binding_module();
6279 free_rename (module
->rename
);
6280 module
->rename
= NULL
;
6281 gfc_current_locus
= old_locus
;
6282 module
->intrinsic
= true;
6286 module_fp
= gfc_open_intrinsic_module (filename
);
6288 if (module_fp
== NULL
&& module
->intrinsic
)
6289 gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C",
6293 if (module_fp
== NULL
)
6294 gfc_fatal_error ("Can't open module file '%s' for reading at %C: %s",
6295 filename
, xstrerror (errno
));
6297 /* Check that we haven't already USEd an intrinsic module with the
6300 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, module_name
);
6301 if (mod_symtree
&& mod_symtree
->n
.sym
->attr
.intrinsic
)
6302 gfc_error ("Use of non-intrinsic module '%s' at %C conflicts with "
6303 "intrinsic module name used previously", module_name
);
6310 read_module_to_tmpbuf ();
6313 /* Skip the first two lines of the module, after checking that this is
6314 a gfortran module file. */
6320 bad_module ("Unexpected end of module");
6323 if ((start
== 1 && strcmp (atom_name
, "GFORTRAN") != 0)
6324 || (start
== 2 && strcmp (atom_name
, " module") != 0))
6325 gfc_fatal_error ("File '%s' opened at %C is not a GNU Fortran"
6326 " module file", filename
);
6329 if (strcmp (atom_name
, " version") != 0
6330 || module_char () != ' '
6331 || parse_atom () != ATOM_STRING
6332 || strcmp (atom_string
, MOD_VERSION
))
6333 gfc_fatal_error ("Cannot read module file '%s' opened at %C,"
6334 " because it was created by a different"
6335 " version of GNU Fortran", filename
);
6344 /* Make sure we're not reading the same module that we may be building. */
6345 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
6346 if (p
->state
== COMP_MODULE
&& strcmp (p
->sym
->name
, module_name
) == 0)
6347 gfc_fatal_error ("Can't USE the same module we're building!");
6350 init_true_name_tree ();
6354 free_true_name (true_name_root
);
6355 true_name_root
= NULL
;
6357 free_pi_tree (pi_root
);
6360 XDELETEVEC (module_content
);
6361 module_content
= NULL
;
6363 use_stmt
= gfc_get_use_list ();
6364 *use_stmt
= *module
;
6365 use_stmt
->next
= gfc_current_ns
->use_stmts
;
6366 gfc_current_ns
->use_stmts
= use_stmt
;
6368 gfc_current_locus
= old_locus
;
6372 /* Remove duplicated intrinsic operators from the rename list. */
6375 rename_list_remove_duplicate (gfc_use_rename
*list
)
6377 gfc_use_rename
*seek
, *last
;
6379 for (; list
; list
= list
->next
)
6380 if (list
->op
!= INTRINSIC_USER
&& list
->op
!= INTRINSIC_NONE
)
6383 for (seek
= list
->next
; seek
; seek
= last
->next
)
6385 if (list
->op
== seek
->op
)
6387 last
->next
= seek
->next
;
6397 /* Process all USE directives. */
6400 gfc_use_modules (void)
6402 gfc_use_list
*next
, *seek
, *last
;
6404 for (next
= module_list
; next
; next
= next
->next
)
6406 bool non_intrinsic
= next
->non_intrinsic
;
6407 bool intrinsic
= next
->intrinsic
;
6408 bool neither
= !non_intrinsic
&& !intrinsic
;
6410 for (seek
= next
->next
; seek
; seek
= seek
->next
)
6412 if (next
->module_name
!= seek
->module_name
)
6415 if (seek
->non_intrinsic
)
6416 non_intrinsic
= true;
6417 else if (seek
->intrinsic
)
6423 if (intrinsic
&& neither
&& !non_intrinsic
)
6428 filename
= XALLOCAVEC (char,
6429 strlen (next
->module_name
)
6430 + strlen (MODULE_EXTENSION
) + 1);
6431 strcpy (filename
, next
->module_name
);
6432 strcat (filename
, MODULE_EXTENSION
);
6433 fp
= gfc_open_included_file (filename
, true, true);
6436 non_intrinsic
= true;
6442 for (seek
= next
->next
; seek
; seek
= last
->next
)
6444 if (next
->module_name
!= seek
->module_name
)
6450 if ((!next
->intrinsic
&& !seek
->intrinsic
)
6451 || (next
->intrinsic
&& seek
->intrinsic
)
6454 if (!seek
->only_flag
)
6455 next
->only_flag
= false;
6458 gfc_use_rename
*r
= seek
->rename
;
6461 r
->next
= next
->rename
;
6462 next
->rename
= seek
->rename
;
6464 last
->next
= seek
->next
;
6472 for (; module_list
; module_list
= next
)
6474 next
= module_list
->next
;
6475 rename_list_remove_duplicate (module_list
->rename
);
6476 gfc_use_module (module_list
);
6479 gfc_rename_list
= NULL
;
6484 gfc_free_use_stmts (gfc_use_list
*use_stmts
)
6487 for (; use_stmts
; use_stmts
= next
)
6489 gfc_use_rename
*next_rename
;
6491 for (; use_stmts
->rename
; use_stmts
->rename
= next_rename
)
6493 next_rename
= use_stmts
->rename
->next
;
6494 free (use_stmts
->rename
);
6496 next
= use_stmts
->next
;
6503 gfc_module_init_2 (void)
6505 last_atom
= ATOM_LPAREN
;
6506 gfc_rename_list
= NULL
;
6512 gfc_module_done_2 (void)
6514 free_rename (gfc_rename_list
);
6515 gfc_rename_list
= NULL
;