1 /* Handle modules, which amounts to loading and saving symbols and
2 their attendant structures.
3 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
5 Free Software Foundation, Inc.
6 Contributed by Andy Vaught
8 This file is part of GCC.
10 GCC is free software; you can redistribute it and/or modify it under
11 the terms of the GNU General Public License as published by the Free
12 Software Foundation; either version 3, or (at your option) any later
15 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
16 WARRANTY; without even the implied warranty of MERCHANTABILITY or
17 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
20 You should have received a copy of the GNU General Public License
21 along with GCC; see the file COPYING3. If not see
22 <http://www.gnu.org/licenses/>. */
24 /* The syntax of gfortran modules resembles that of lisp lists, i.e. a
25 sequence of atoms, which can be left or right parenthesis, names,
26 integers or strings. Parenthesis are always matched which allows
27 us to skip over sections at high speed without having to know
28 anything about the internal structure of the lists. A "name" is
29 usually a fortran 95 identifier, but can also start with '@' in
30 order to reference a hidden symbol.
32 The first line of a module is an informational message about what
33 created the module, the file it came from and when it was created.
34 The second line is a warning for people not to edit the module.
35 The rest of the module looks like:
37 ( ( <Interface info for UPLUS> )
38 ( <Interface info for UMINUS> )
41 ( ( <name of operator interface> <module of op interface> <i/f1> ... )
44 ( ( <name of generic interface> <module of generic interface> <i/f1> ... )
47 ( ( <common name> <symbol> <saved flag>)
53 ( <Symbol Number (in no particular order)>
55 <Module name of symbol>
56 ( <symbol information> )
65 In general, symbols refer to other symbols by their symbol number,
66 which are zero based. Symbols are written to the module in no
74 #include "parse.h" /* FIXME */
76 #include "constructor.h"
78 #define MODULE_EXTENSION ".mod"
80 /* Don't put any single quote (') in MOD_VERSION,
81 if yout want it to be recognized. */
82 #define MOD_VERSION "5"
85 /* Structure that describes a position within a module file. */
94 /* Structure for list of symbols of intrinsic modules. */
107 P_UNKNOWN
= 0, P_OTHER
, P_NAMESPACE
, P_COMPONENT
, P_SYMBOL
111 /* The fixup structure lists pointers to pointers that have to
112 be updated when a pointer value becomes known. */
114 typedef struct fixup_t
117 struct fixup_t
*next
;
122 /* Structure for holding extra info needed for pointers being read. */
138 typedef struct pointer_info
140 BBT_HEADER (pointer_info
);
144 /* The first component of each member of the union is the pointer
151 void *pointer
; /* Member for doing pointer searches. */
156 char true_name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[GFC_MAX_SYMBOL_LEN
+ 1];
157 enum gfc_rsym_state state
;
158 int ns
, referenced
, renamed
;
161 gfc_symtree
*symtree
;
162 char binding_label
[GFC_MAX_SYMBOL_LEN
+ 1];
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 char module_name
[GFC_MAX_SYMBOL_LEN
+ 1];
192 /* The way the module we're reading was specified. */
193 static bool specified_nonint
, specified_int
;
195 static int module_line
, module_column
, only_flag
;
197 { IO_INPUT
, IO_OUTPUT
}
200 static gfc_use_rename
*gfc_rename_list
;
201 static pointer_info
*pi_root
;
202 static int symbol_number
; /* Counter for assigning symbol numbers */
204 /* Tells mio_expr_ref to make symbols for unused equivalence members. */
205 static bool in_load_equiv
;
207 static locus use_locus
;
211 /*****************************************************************/
213 /* Pointer/integer conversion. Pointers between structures are stored
214 as integers in the module file. The next couple of subroutines
215 handle this translation for reading and writing. */
217 /* Recursively free the tree of pointer structures. */
220 free_pi_tree (pointer_info
*p
)
225 if (p
->fixup
!= NULL
)
226 gfc_internal_error ("free_pi_tree(): Unresolved fixup");
228 free_pi_tree (p
->left
);
229 free_pi_tree (p
->right
);
235 /* Compare pointers when searching by pointer. Used when writing a
239 compare_pointers (void *_sn1
, void *_sn2
)
241 pointer_info
*sn1
, *sn2
;
243 sn1
= (pointer_info
*) _sn1
;
244 sn2
= (pointer_info
*) _sn2
;
246 if (sn1
->u
.pointer
< sn2
->u
.pointer
)
248 if (sn1
->u
.pointer
> sn2
->u
.pointer
)
255 /* Compare integers when searching by integer. Used when reading a
259 compare_integers (void *_sn1
, void *_sn2
)
261 pointer_info
*sn1
, *sn2
;
263 sn1
= (pointer_info
*) _sn1
;
264 sn2
= (pointer_info
*) _sn2
;
266 if (sn1
->integer
< sn2
->integer
)
268 if (sn1
->integer
> sn2
->integer
)
275 /* Initialize the pointer_info tree. */
284 compare
= (iomode
== IO_INPUT
) ? compare_integers
: compare_pointers
;
286 /* Pointer 0 is the NULL pointer. */
287 p
= gfc_get_pointer_info ();
292 gfc_insert_bbt (&pi_root
, p
, compare
);
294 /* Pointer 1 is the current namespace. */
295 p
= gfc_get_pointer_info ();
296 p
->u
.pointer
= gfc_current_ns
;
298 p
->type
= P_NAMESPACE
;
300 gfc_insert_bbt (&pi_root
, p
, compare
);
306 /* During module writing, call here with a pointer to something,
307 returning the pointer_info node. */
309 static pointer_info
*
310 find_pointer (void *gp
)
317 if (p
->u
.pointer
== gp
)
319 p
= (gp
< p
->u
.pointer
) ? p
->left
: p
->right
;
326 /* Given a pointer while writing, returns the pointer_info tree node,
327 creating it if it doesn't exist. */
329 static pointer_info
*
330 get_pointer (void *gp
)
334 p
= find_pointer (gp
);
338 /* Pointer doesn't have an integer. Give it one. */
339 p
= gfc_get_pointer_info ();
342 p
->integer
= symbol_number
++;
344 gfc_insert_bbt (&pi_root
, p
, compare_pointers
);
350 /* Given an integer during reading, find it in the pointer_info tree,
351 creating the node if not found. */
353 static pointer_info
*
354 get_integer (int integer
)
364 c
= compare_integers (&t
, p
);
368 p
= (c
< 0) ? p
->left
: p
->right
;
374 p
= gfc_get_pointer_info ();
375 p
->integer
= integer
;
378 gfc_insert_bbt (&pi_root
, p
, compare_integers
);
384 /* Recursive function to find a pointer within a tree by brute force. */
386 static pointer_info
*
387 fp2 (pointer_info
*p
, const void *target
)
394 if (p
->u
.pointer
== target
)
397 q
= fp2 (p
->left
, target
);
401 return fp2 (p
->right
, target
);
405 /* During reading, find a pointer_info node from the pointer value.
406 This amounts to a brute-force search. */
408 static pointer_info
*
409 find_pointer2 (void *p
)
411 return fp2 (pi_root
, p
);
415 /* Resolve any fixups using a known pointer. */
418 resolve_fixups (fixup_t
*f
, void *gp
)
431 /* Call here during module reading when we know what pointer to
432 associate with an integer. Any fixups that exist are resolved at
436 associate_integer_pointer (pointer_info
*p
, void *gp
)
438 if (p
->u
.pointer
!= NULL
)
439 gfc_internal_error ("associate_integer_pointer(): Already associated");
443 resolve_fixups (p
->fixup
, gp
);
449 /* During module reading, given an integer and a pointer to a pointer,
450 either store the pointer from an already-known value or create a
451 fixup structure in order to store things later. Returns zero if
452 the reference has been actually stored, or nonzero if the reference
453 must be fixed later (i.e., associate_integer_pointer must be called
454 sometime later. Returns the pointer_info structure. */
456 static pointer_info
*
457 add_fixup (int integer
, void *gp
)
463 p
= get_integer (integer
);
465 if (p
->integer
== 0 || p
->u
.pointer
!= NULL
)
468 *cp
= (char *) p
->u
.pointer
;
477 f
->pointer
= (void **) gp
;
484 /*****************************************************************/
486 /* Parser related subroutines */
488 /* Free the rename list left behind by a USE statement. */
493 gfc_use_rename
*next
;
495 for (; gfc_rename_list
; gfc_rename_list
= next
)
497 next
= gfc_rename_list
->next
;
498 gfc_free (gfc_rename_list
);
503 /* Match a USE statement. */
508 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module_nature
[GFC_MAX_SYMBOL_LEN
+ 1];
509 gfc_use_rename
*tail
= NULL
, *new_use
;
510 interface_type type
, type2
;
514 specified_int
= false;
515 specified_nonint
= false;
517 if (gfc_match (" , ") == MATCH_YES
)
519 if ((m
= gfc_match (" %n ::", module_nature
)) == MATCH_YES
)
521 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: module "
522 "nature in USE statement at %C") == FAILURE
)
525 if (strcmp (module_nature
, "intrinsic") == 0)
526 specified_int
= true;
529 if (strcmp (module_nature
, "non_intrinsic") == 0)
530 specified_nonint
= true;
533 gfc_error ("Module nature in USE statement at %C shall "
534 "be either INTRINSIC or NON_INTRINSIC");
541 /* Help output a better error message than "Unclassifiable
543 gfc_match (" %n", module_nature
);
544 if (strcmp (module_nature
, "intrinsic") == 0
545 || strcmp (module_nature
, "non_intrinsic") == 0)
546 gfc_error ("\"::\" was expected after module nature at %C "
547 "but was not found");
553 m
= gfc_match (" ::");
554 if (m
== MATCH_YES
&&
555 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: "
556 "\"USE :: module\" at %C") == FAILURE
)
561 m
= gfc_match ("% ");
567 use_locus
= gfc_current_locus
;
569 m
= gfc_match_name (module_name
);
576 if (gfc_match_eos () == MATCH_YES
)
578 if (gfc_match_char (',') != MATCH_YES
)
581 if (gfc_match (" only :") == MATCH_YES
)
584 if (gfc_match_eos () == MATCH_YES
)
589 /* Get a new rename struct and add it to the rename list. */
590 new_use
= gfc_get_use_rename ();
591 new_use
->where
= gfc_current_locus
;
594 if (gfc_rename_list
== NULL
)
595 gfc_rename_list
= new_use
;
597 tail
->next
= new_use
;
600 /* See what kind of interface we're dealing with. Assume it is
602 new_use
->op
= INTRINSIC_NONE
;
603 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
608 case INTERFACE_NAMELESS
:
609 gfc_error ("Missing generic specification in USE statement at %C");
612 case INTERFACE_USER_OP
:
613 case INTERFACE_GENERIC
:
614 m
= gfc_match (" =>");
616 if (type
== INTERFACE_USER_OP
&& m
== MATCH_YES
617 && (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Renaming "
618 "operators in USE statements at %C")
622 if (type
== INTERFACE_USER_OP
)
623 new_use
->op
= INTRINSIC_USER
;
628 strcpy (new_use
->use_name
, name
);
631 strcpy (new_use
->local_name
, name
);
632 m
= gfc_match_generic_spec (&type2
, new_use
->use_name
, &op
);
637 if (m
== MATCH_ERROR
)
645 strcpy (new_use
->local_name
, name
);
647 m
= gfc_match_generic_spec (&type2
, new_use
->use_name
, &op
);
652 if (m
== MATCH_ERROR
)
656 if (strcmp (new_use
->use_name
, module_name
) == 0
657 || strcmp (new_use
->local_name
, module_name
) == 0)
659 gfc_error ("The name '%s' at %C has already been used as "
660 "an external module name.", module_name
);
665 case INTERFACE_INTRINSIC_OP
:
673 if (gfc_match_eos () == MATCH_YES
)
675 if (gfc_match_char (',') != MATCH_YES
)
682 gfc_syntax_error (ST_USE
);
690 /* Given a name and a number, inst, return the inst name
691 under which to load this symbol. Returns NULL if this
692 symbol shouldn't be loaded. If inst is zero, returns
693 the number of instances of this name. If interface is
694 true, a user-defined operator is sought, otherwise only
695 non-operators are sought. */
698 find_use_name_n (const char *name
, int *inst
, bool interface
)
704 for (u
= gfc_rename_list
; u
; u
= u
->next
)
706 if (strcmp (u
->use_name
, name
) != 0
707 || (u
->op
== INTRINSIC_USER
&& !interface
)
708 || (u
->op
!= INTRINSIC_USER
&& interface
))
721 return only_flag
? NULL
: name
;
725 return (u
->local_name
[0] != '\0') ? u
->local_name
: name
;
729 /* Given a name, return the name under which to load this symbol.
730 Returns NULL if this symbol shouldn't be loaded. */
733 find_use_name (const char *name
, bool interface
)
736 return find_use_name_n (name
, &i
, interface
);
740 /* Given a real name, return the number of use names associated with it. */
743 number_use_names (const char *name
, bool interface
)
746 find_use_name_n (name
, &i
, interface
);
751 /* Try to find the operator in the current list. */
753 static gfc_use_rename
*
754 find_use_operator (gfc_intrinsic_op op
)
758 for (u
= gfc_rename_list
; u
; u
= u
->next
)
766 /*****************************************************************/
768 /* The next couple of subroutines maintain a tree used to avoid a
769 brute-force search for a combination of true name and module name.
770 While symtree names, the name that a particular symbol is known by
771 can changed with USE statements, we still have to keep track of the
772 true names to generate the correct reference, and also avoid
773 loading the same real symbol twice in a program unit.
775 When we start reading, the true name tree is built and maintained
776 as symbols are read. The tree is searched as we load new symbols
777 to see if it already exists someplace in the namespace. */
779 typedef struct true_name
781 BBT_HEADER (true_name
);
786 static true_name
*true_name_root
;
789 /* Compare two true_name structures. */
792 compare_true_names (void *_t1
, void *_t2
)
797 t1
= (true_name
*) _t1
;
798 t2
= (true_name
*) _t2
;
800 c
= ((t1
->sym
->module
> t2
->sym
->module
)
801 - (t1
->sym
->module
< t2
->sym
->module
));
805 return strcmp (t1
->sym
->name
, t2
->sym
->name
);
809 /* Given a true name, search the true name tree to see if it exists
810 within the main namespace. */
813 find_true_name (const char *name
, const char *module
)
819 sym
.name
= gfc_get_string (name
);
821 sym
.module
= gfc_get_string (module
);
829 c
= compare_true_names ((void *) (&t
), (void *) p
);
833 p
= (c
< 0) ? p
->left
: p
->right
;
840 /* Given a gfc_symbol pointer that is not in the true name tree, add it. */
843 add_true_name (gfc_symbol
*sym
)
847 t
= XCNEW (true_name
);
850 gfc_insert_bbt (&true_name_root
, t
, compare_true_names
);
854 /* Recursive function to build the initial true name tree by
855 recursively traversing the current namespace. */
858 build_tnt (gfc_symtree
*st
)
863 build_tnt (st
->left
);
864 build_tnt (st
->right
);
866 if (find_true_name (st
->n
.sym
->name
, st
->n
.sym
->module
) != NULL
)
869 add_true_name (st
->n
.sym
);
873 /* Initialize the true name tree with the current namespace. */
876 init_true_name_tree (void)
878 true_name_root
= NULL
;
879 build_tnt (gfc_current_ns
->sym_root
);
883 /* Recursively free a true name tree node. */
886 free_true_name (true_name
*t
)
890 free_true_name (t
->left
);
891 free_true_name (t
->right
);
897 /*****************************************************************/
899 /* Module reading and writing. */
903 ATOM_NAME
, ATOM_LPAREN
, ATOM_RPAREN
, ATOM_INTEGER
, ATOM_STRING
907 static atom_type last_atom
;
910 /* The name buffer must be at least as long as a symbol name. Right
911 now it's not clear how we're going to store numeric constants--
912 probably as a hexadecimal string, since this will allow the exact
913 number to be preserved (this can't be done by a decimal
914 representation). Worry about that later. TODO! */
916 #define MAX_ATOM_SIZE 100
919 static char *atom_string
, atom_name
[MAX_ATOM_SIZE
];
922 /* Report problems with a module. Error reporting is not very
923 elaborate, since this sorts of errors shouldn't really happen.
924 This subroutine never returns. */
926 static void bad_module (const char *) ATTRIBUTE_NORETURN
;
929 bad_module (const char *msgid
)
936 gfc_fatal_error ("Reading module %s at line %d column %d: %s",
937 module_name
, module_line
, module_column
, msgid
);
940 gfc_fatal_error ("Writing module %s at line %d column %d: %s",
941 module_name
, module_line
, module_column
, msgid
);
944 gfc_fatal_error ("Module %s at line %d column %d: %s",
945 module_name
, module_line
, module_column
, msgid
);
951 /* Set the module's input pointer. */
954 set_module_locus (module_locus
*m
)
956 module_column
= m
->column
;
957 module_line
= m
->line
;
958 fsetpos (module_fp
, &m
->pos
);
962 /* Get the module's input pointer so that we can restore it later. */
965 get_module_locus (module_locus
*m
)
967 m
->column
= module_column
;
968 m
->line
= module_line
;
969 fgetpos (module_fp
, &m
->pos
);
973 /* Get the next character in the module, updating our reckoning of
981 c
= getc (module_fp
);
984 bad_module ("Unexpected EOF");
997 /* Parse a string constant. The delimiter is guaranteed to be a
1007 get_module_locus (&start
);
1011 /* See how long the string is. */
1016 bad_module ("Unexpected end of module in string constant");
1034 set_module_locus (&start
);
1036 atom_string
= p
= XCNEWVEC (char, len
+ 1);
1038 for (; len
> 0; len
--)
1042 module_char (); /* Guaranteed to be another \'. */
1046 module_char (); /* Terminating \'. */
1047 *p
= '\0'; /* C-style string for debug purposes. */
1051 /* Parse a small integer. */
1054 parse_integer (int c
)
1062 get_module_locus (&m
);
1068 atom_int
= 10 * atom_int
+ c
- '0';
1069 if (atom_int
> 99999999)
1070 bad_module ("Integer overflow");
1073 set_module_locus (&m
);
1091 get_module_locus (&m
);
1096 if (!ISALNUM (c
) && c
!= '_' && c
!= '-')
1100 if (++len
> GFC_MAX_SYMBOL_LEN
)
1101 bad_module ("Name too long");
1106 fseek (module_fp
, -1, SEEK_CUR
);
1107 module_column
= m
.column
+ len
- 1;
1114 /* Read the next atom in the module's input stream. */
1125 while (c
== ' ' || c
== '\r' || c
== '\n');
1150 return ATOM_INTEGER
;
1208 bad_module ("Bad name");
1215 /* Peek at the next atom on the input. */
1223 get_module_locus (&m
);
1226 if (a
== ATOM_STRING
)
1227 gfc_free (atom_string
);
1229 set_module_locus (&m
);
1234 /* Read the next atom from the input, requiring that it be a
1238 require_atom (atom_type type
)
1244 get_module_locus (&m
);
1252 p
= _("Expected name");
1255 p
= _("Expected left parenthesis");
1258 p
= _("Expected right parenthesis");
1261 p
= _("Expected integer");
1264 p
= _("Expected string");
1267 gfc_internal_error ("require_atom(): bad atom type required");
1270 set_module_locus (&m
);
1276 /* Given a pointer to an mstring array, require that the current input
1277 be one of the strings in the array. We return the enum value. */
1280 find_enum (const mstring
*m
)
1284 i
= gfc_string2code (m
, atom_name
);
1288 bad_module ("find_enum(): Enum not found");
1294 /**************** Module output subroutines ***************************/
1296 /* Output a character to a module file. */
1299 write_char (char out
)
1301 if (putc (out
, module_fp
) == EOF
)
1302 gfc_fatal_error ("Error writing modules file: %s", strerror (errno
));
1304 /* Add this to our MD5. */
1305 md5_process_bytes (&out
, sizeof (out
), &ctx
);
1317 /* Write an atom to a module. The line wrapping isn't perfect, but it
1318 should work most of the time. This isn't that big of a deal, since
1319 the file really isn't meant to be read by people anyway. */
1322 write_atom (atom_type atom
, const void *v
)
1332 p
= (const char *) v
;
1344 i
= *((const int *) v
);
1346 gfc_internal_error ("write_atom(): Writing negative integer");
1348 sprintf (buffer
, "%d", i
);
1353 gfc_internal_error ("write_atom(): Trying to write dab atom");
1357 if(p
== NULL
|| *p
== '\0')
1362 if (atom
!= ATOM_RPAREN
)
1364 if (module_column
+ len
> 72)
1369 if (last_atom
!= ATOM_LPAREN
&& module_column
!= 1)
1374 if (atom
== ATOM_STRING
)
1377 while (p
!= NULL
&& *p
)
1379 if (atom
== ATOM_STRING
&& *p
== '\'')
1384 if (atom
== ATOM_STRING
)
1392 /***************** Mid-level I/O subroutines *****************/
1394 /* These subroutines let their caller read or write atoms without
1395 caring about which of the two is actually happening. This lets a
1396 subroutine concentrate on the actual format of the data being
1399 static void mio_expr (gfc_expr
**);
1400 pointer_info
*mio_symbol_ref (gfc_symbol
**);
1401 pointer_info
*mio_interface_rest (gfc_interface
**);
1402 static void mio_symtree_ref (gfc_symtree
**);
1404 /* Read or write an enumerated value. On writing, we return the input
1405 value for the convenience of callers. We avoid using an integer
1406 pointer because enums are sometimes inside bitfields. */
1409 mio_name (int t
, const mstring
*m
)
1411 if (iomode
== IO_OUTPUT
)
1412 write_atom (ATOM_NAME
, gfc_code2string (m
, t
));
1415 require_atom (ATOM_NAME
);
1422 /* Specialization of mio_name. */
1424 #define DECL_MIO_NAME(TYPE) \
1425 static inline TYPE \
1426 MIO_NAME(TYPE) (TYPE t, const mstring *m) \
1428 return (TYPE) mio_name ((int) t, m); \
1430 #define MIO_NAME(TYPE) mio_name_##TYPE
1435 if (iomode
== IO_OUTPUT
)
1436 write_atom (ATOM_LPAREN
, NULL
);
1438 require_atom (ATOM_LPAREN
);
1445 if (iomode
== IO_OUTPUT
)
1446 write_atom (ATOM_RPAREN
, NULL
);
1448 require_atom (ATOM_RPAREN
);
1453 mio_integer (int *ip
)
1455 if (iomode
== IO_OUTPUT
)
1456 write_atom (ATOM_INTEGER
, ip
);
1459 require_atom (ATOM_INTEGER
);
1465 /* Read or write a gfc_intrinsic_op value. */
1468 mio_intrinsic_op (gfc_intrinsic_op
* op
)
1470 /* FIXME: Would be nicer to do this via the operators symbolic name. */
1471 if (iomode
== IO_OUTPUT
)
1473 int converted
= (int) *op
;
1474 write_atom (ATOM_INTEGER
, &converted
);
1478 require_atom (ATOM_INTEGER
);
1479 *op
= (gfc_intrinsic_op
) atom_int
;
1484 /* Read or write a character pointer that points to a string on the heap. */
1487 mio_allocated_string (const char *s
)
1489 if (iomode
== IO_OUTPUT
)
1491 write_atom (ATOM_STRING
, s
);
1496 require_atom (ATOM_STRING
);
1502 /* Functions for quoting and unquoting strings. */
1505 quote_string (const gfc_char_t
*s
, const size_t slength
)
1507 const gfc_char_t
*p
;
1511 /* Calculate the length we'll need: a backslash takes two ("\\"),
1512 non-printable characters take 10 ("\Uxxxxxxxx") and others take 1. */
1513 for (p
= s
, i
= 0; i
< slength
; p
++, i
++)
1517 else if (!gfc_wide_is_printable (*p
))
1523 q
= res
= XCNEWVEC (char, len
+ 1);
1524 for (p
= s
, i
= 0; i
< slength
; p
++, i
++)
1527 *q
++ = '\\', *q
++ = '\\';
1528 else if (!gfc_wide_is_printable (*p
))
1530 sprintf (q
, "\\U%08" HOST_WIDE_INT_PRINT
"x",
1531 (unsigned HOST_WIDE_INT
) *p
);
1535 *q
++ = (unsigned char) *p
;
1543 unquote_string (const char *s
)
1549 for (p
= s
, len
= 0; *p
; p
++, len
++)
1556 else if (p
[1] == 'U')
1557 p
+= 9; /* That is a "\U????????". */
1559 gfc_internal_error ("unquote_string(): got bad string");
1562 res
= gfc_get_wide_string (len
+ 1);
1563 for (i
= 0, p
= s
; i
< len
; i
++, p
++)
1568 res
[i
] = (unsigned char) *p
;
1569 else if (p
[1] == '\\')
1571 res
[i
] = (unsigned char) '\\';
1576 /* We read the 8-digits hexadecimal constant that follows. */
1581 gcc_assert (p
[1] == 'U');
1582 for (j
= 0; j
< 8; j
++)
1585 gcc_assert (sscanf (&p
[j
+2], "%01x", &n
) == 1);
1599 /* Read or write a character pointer that points to a wide string on the
1600 heap, performing quoting/unquoting of nonprintable characters using the
1601 form \U???????? (where each ? is a hexadecimal digit).
1602 Length is the length of the string, only known and used in output mode. */
1604 static const gfc_char_t
*
1605 mio_allocated_wide_string (const gfc_char_t
*s
, const size_t length
)
1607 if (iomode
== IO_OUTPUT
)
1609 char *quoted
= quote_string (s
, length
);
1610 write_atom (ATOM_STRING
, quoted
);
1616 gfc_char_t
*unquoted
;
1618 require_atom (ATOM_STRING
);
1619 unquoted
= unquote_string (atom_string
);
1620 gfc_free (atom_string
);
1626 /* Read or write a string that is in static memory. */
1629 mio_pool_string (const char **stringp
)
1631 /* TODO: one could write the string only once, and refer to it via a
1634 /* As a special case we have to deal with a NULL string. This
1635 happens for the 'module' member of 'gfc_symbol's that are not in a
1636 module. We read / write these as the empty string. */
1637 if (iomode
== IO_OUTPUT
)
1639 const char *p
= *stringp
== NULL
? "" : *stringp
;
1640 write_atom (ATOM_STRING
, p
);
1644 require_atom (ATOM_STRING
);
1645 *stringp
= atom_string
[0] == '\0' ? NULL
: gfc_get_string (atom_string
);
1646 gfc_free (atom_string
);
1651 /* Read or write a string that is inside of some already-allocated
1655 mio_internal_string (char *string
)
1657 if (iomode
== IO_OUTPUT
)
1658 write_atom (ATOM_STRING
, string
);
1661 require_atom (ATOM_STRING
);
1662 strcpy (string
, atom_string
);
1663 gfc_free (atom_string
);
1669 { AB_ALLOCATABLE
, AB_DIMENSION
, AB_EXTERNAL
, AB_INTRINSIC
, AB_OPTIONAL
,
1670 AB_POINTER
, AB_TARGET
, AB_DUMMY
, AB_RESULT
, AB_DATA
,
1671 AB_IN_NAMELIST
, AB_IN_COMMON
, AB_FUNCTION
, AB_SUBROUTINE
, AB_SEQUENCE
,
1672 AB_ELEMENTAL
, AB_PURE
, AB_RECURSIVE
, AB_GENERIC
, AB_ALWAYS_EXPLICIT
,
1673 AB_CRAY_POINTER
, AB_CRAY_POINTEE
, AB_THREADPRIVATE
, AB_ALLOC_COMP
,
1674 AB_POINTER_COMP
, AB_PRIVATE_COMP
, AB_VALUE
, AB_VOLATILE
, AB_PROTECTED
,
1675 AB_IS_BIND_C
, AB_IS_C_INTEROP
, AB_IS_ISO_C
, AB_ABSTRACT
, AB_ZERO_COMP
,
1676 AB_IS_CLASS
, AB_PROCEDURE
, AB_PROC_POINTER
, AB_ASYNCHRONOUS
, AB_CODIMENSION
,
1681 static const mstring attr_bits
[] =
1683 minit ("ALLOCATABLE", AB_ALLOCATABLE
),
1684 minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS
),
1685 minit ("DIMENSION", AB_DIMENSION
),
1686 minit ("CODIMENSION", AB_CODIMENSION
),
1687 minit ("EXTERNAL", AB_EXTERNAL
),
1688 minit ("INTRINSIC", AB_INTRINSIC
),
1689 minit ("OPTIONAL", AB_OPTIONAL
),
1690 minit ("POINTER", AB_POINTER
),
1691 minit ("VOLATILE", AB_VOLATILE
),
1692 minit ("TARGET", AB_TARGET
),
1693 minit ("THREADPRIVATE", AB_THREADPRIVATE
),
1694 minit ("DUMMY", AB_DUMMY
),
1695 minit ("RESULT", AB_RESULT
),
1696 minit ("DATA", AB_DATA
),
1697 minit ("IN_NAMELIST", AB_IN_NAMELIST
),
1698 minit ("IN_COMMON", AB_IN_COMMON
),
1699 minit ("FUNCTION", AB_FUNCTION
),
1700 minit ("SUBROUTINE", AB_SUBROUTINE
),
1701 minit ("SEQUENCE", AB_SEQUENCE
),
1702 minit ("ELEMENTAL", AB_ELEMENTAL
),
1703 minit ("PURE", AB_PURE
),
1704 minit ("RECURSIVE", AB_RECURSIVE
),
1705 minit ("GENERIC", AB_GENERIC
),
1706 minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT
),
1707 minit ("CRAY_POINTER", AB_CRAY_POINTER
),
1708 minit ("CRAY_POINTEE", AB_CRAY_POINTEE
),
1709 minit ("IS_BIND_C", AB_IS_BIND_C
),
1710 minit ("IS_C_INTEROP", AB_IS_C_INTEROP
),
1711 minit ("IS_ISO_C", AB_IS_ISO_C
),
1712 minit ("VALUE", AB_VALUE
),
1713 minit ("ALLOC_COMP", AB_ALLOC_COMP
),
1714 minit ("COARRAY_COMP", AB_COARRAY_COMP
),
1715 minit ("POINTER_COMP", AB_POINTER_COMP
),
1716 minit ("PRIVATE_COMP", AB_PRIVATE_COMP
),
1717 minit ("ZERO_COMP", AB_ZERO_COMP
),
1718 minit ("PROTECTED", AB_PROTECTED
),
1719 minit ("ABSTRACT", AB_ABSTRACT
),
1720 minit ("IS_CLASS", AB_IS_CLASS
),
1721 minit ("PROCEDURE", AB_PROCEDURE
),
1722 minit ("PROC_POINTER", AB_PROC_POINTER
),
1726 /* For binding attributes. */
1727 static const mstring binding_passing
[] =
1730 minit ("NOPASS", 1),
1733 static const mstring binding_overriding
[] =
1735 minit ("OVERRIDABLE", 0),
1736 minit ("NON_OVERRIDABLE", 1),
1737 minit ("DEFERRED", 2),
1740 static const mstring binding_generic
[] =
1742 minit ("SPECIFIC", 0),
1743 minit ("GENERIC", 1),
1746 static const mstring binding_ppc
[] =
1748 minit ("NO_PPC", 0),
1753 /* Specialization of mio_name. */
1754 DECL_MIO_NAME (ab_attribute
)
1755 DECL_MIO_NAME (ar_type
)
1756 DECL_MIO_NAME (array_type
)
1758 DECL_MIO_NAME (expr_t
)
1759 DECL_MIO_NAME (gfc_access
)
1760 DECL_MIO_NAME (gfc_intrinsic_op
)
1761 DECL_MIO_NAME (ifsrc
)
1762 DECL_MIO_NAME (save_state
)
1763 DECL_MIO_NAME (procedure_type
)
1764 DECL_MIO_NAME (ref_type
)
1765 DECL_MIO_NAME (sym_flavor
)
1766 DECL_MIO_NAME (sym_intent
)
1767 #undef DECL_MIO_NAME
1769 /* Symbol attributes are stored in list with the first three elements
1770 being the enumerated fields, while the remaining elements (if any)
1771 indicate the individual attribute bits. The access field is not
1772 saved-- it controls what symbols are exported when a module is
1776 mio_symbol_attribute (symbol_attribute
*attr
)
1779 unsigned ext_attr
,extension_level
;
1783 attr
->flavor
= MIO_NAME (sym_flavor
) (attr
->flavor
, flavors
);
1784 attr
->intent
= MIO_NAME (sym_intent
) (attr
->intent
, intents
);
1785 attr
->proc
= MIO_NAME (procedure_type
) (attr
->proc
, procedures
);
1786 attr
->if_source
= MIO_NAME (ifsrc
) (attr
->if_source
, ifsrc_types
);
1787 attr
->save
= MIO_NAME (save_state
) (attr
->save
, save_status
);
1789 ext_attr
= attr
->ext_attr
;
1790 mio_integer ((int *) &ext_attr
);
1791 attr
->ext_attr
= ext_attr
;
1793 extension_level
= attr
->extension
;
1794 mio_integer ((int *) &extension_level
);
1795 attr
->extension
= extension_level
;
1797 if (iomode
== IO_OUTPUT
)
1799 if (attr
->allocatable
)
1800 MIO_NAME (ab_attribute
) (AB_ALLOCATABLE
, attr_bits
);
1801 if (attr
->asynchronous
)
1802 MIO_NAME (ab_attribute
) (AB_ASYNCHRONOUS
, attr_bits
);
1803 if (attr
->dimension
)
1804 MIO_NAME (ab_attribute
) (AB_DIMENSION
, attr_bits
);
1805 if (attr
->codimension
)
1806 MIO_NAME (ab_attribute
) (AB_CODIMENSION
, attr_bits
);
1808 MIO_NAME (ab_attribute
) (AB_EXTERNAL
, attr_bits
);
1809 if (attr
->intrinsic
)
1810 MIO_NAME (ab_attribute
) (AB_INTRINSIC
, attr_bits
);
1812 MIO_NAME (ab_attribute
) (AB_OPTIONAL
, attr_bits
);
1814 MIO_NAME (ab_attribute
) (AB_POINTER
, attr_bits
);
1815 if (attr
->is_protected
)
1816 MIO_NAME (ab_attribute
) (AB_PROTECTED
, attr_bits
);
1818 MIO_NAME (ab_attribute
) (AB_VALUE
, attr_bits
);
1819 if (attr
->volatile_
)
1820 MIO_NAME (ab_attribute
) (AB_VOLATILE
, attr_bits
);
1822 MIO_NAME (ab_attribute
) (AB_TARGET
, attr_bits
);
1823 if (attr
->threadprivate
)
1824 MIO_NAME (ab_attribute
) (AB_THREADPRIVATE
, attr_bits
);
1826 MIO_NAME (ab_attribute
) (AB_DUMMY
, attr_bits
);
1828 MIO_NAME (ab_attribute
) (AB_RESULT
, attr_bits
);
1829 /* We deliberately don't preserve the "entry" flag. */
1832 MIO_NAME (ab_attribute
) (AB_DATA
, attr_bits
);
1833 if (attr
->in_namelist
)
1834 MIO_NAME (ab_attribute
) (AB_IN_NAMELIST
, attr_bits
);
1835 if (attr
->in_common
)
1836 MIO_NAME (ab_attribute
) (AB_IN_COMMON
, attr_bits
);
1839 MIO_NAME (ab_attribute
) (AB_FUNCTION
, attr_bits
);
1840 if (attr
->subroutine
)
1841 MIO_NAME (ab_attribute
) (AB_SUBROUTINE
, attr_bits
);
1843 MIO_NAME (ab_attribute
) (AB_GENERIC
, attr_bits
);
1845 MIO_NAME (ab_attribute
) (AB_ABSTRACT
, attr_bits
);
1848 MIO_NAME (ab_attribute
) (AB_SEQUENCE
, attr_bits
);
1849 if (attr
->elemental
)
1850 MIO_NAME (ab_attribute
) (AB_ELEMENTAL
, attr_bits
);
1852 MIO_NAME (ab_attribute
) (AB_PURE
, attr_bits
);
1853 if (attr
->recursive
)
1854 MIO_NAME (ab_attribute
) (AB_RECURSIVE
, attr_bits
);
1855 if (attr
->always_explicit
)
1856 MIO_NAME (ab_attribute
) (AB_ALWAYS_EXPLICIT
, attr_bits
);
1857 if (attr
->cray_pointer
)
1858 MIO_NAME (ab_attribute
) (AB_CRAY_POINTER
, attr_bits
);
1859 if (attr
->cray_pointee
)
1860 MIO_NAME (ab_attribute
) (AB_CRAY_POINTEE
, attr_bits
);
1861 if (attr
->is_bind_c
)
1862 MIO_NAME(ab_attribute
) (AB_IS_BIND_C
, attr_bits
);
1863 if (attr
->is_c_interop
)
1864 MIO_NAME(ab_attribute
) (AB_IS_C_INTEROP
, attr_bits
);
1866 MIO_NAME(ab_attribute
) (AB_IS_ISO_C
, attr_bits
);
1867 if (attr
->alloc_comp
)
1868 MIO_NAME (ab_attribute
) (AB_ALLOC_COMP
, attr_bits
);
1869 if (attr
->pointer_comp
)
1870 MIO_NAME (ab_attribute
) (AB_POINTER_COMP
, attr_bits
);
1871 if (attr
->private_comp
)
1872 MIO_NAME (ab_attribute
) (AB_PRIVATE_COMP
, attr_bits
);
1873 if (attr
->coarray_comp
)
1874 MIO_NAME (ab_attribute
) (AB_COARRAY_COMP
, attr_bits
);
1875 if (attr
->zero_comp
)
1876 MIO_NAME (ab_attribute
) (AB_ZERO_COMP
, attr_bits
);
1878 MIO_NAME (ab_attribute
) (AB_IS_CLASS
, attr_bits
);
1879 if (attr
->procedure
)
1880 MIO_NAME (ab_attribute
) (AB_PROCEDURE
, attr_bits
);
1881 if (attr
->proc_pointer
)
1882 MIO_NAME (ab_attribute
) (AB_PROC_POINTER
, attr_bits
);
1892 if (t
== ATOM_RPAREN
)
1895 bad_module ("Expected attribute bit name");
1897 switch ((ab_attribute
) find_enum (attr_bits
))
1899 case AB_ALLOCATABLE
:
1900 attr
->allocatable
= 1;
1902 case AB_ASYNCHRONOUS
:
1903 attr
->asynchronous
= 1;
1906 attr
->dimension
= 1;
1908 case AB_CODIMENSION
:
1909 attr
->codimension
= 1;
1915 attr
->intrinsic
= 1;
1924 attr
->is_protected
= 1;
1930 attr
->volatile_
= 1;
1935 case AB_THREADPRIVATE
:
1936 attr
->threadprivate
= 1;
1947 case AB_IN_NAMELIST
:
1948 attr
->in_namelist
= 1;
1951 attr
->in_common
= 1;
1957 attr
->subroutine
= 1;
1969 attr
->elemental
= 1;
1975 attr
->recursive
= 1;
1977 case AB_ALWAYS_EXPLICIT
:
1978 attr
->always_explicit
= 1;
1980 case AB_CRAY_POINTER
:
1981 attr
->cray_pointer
= 1;
1983 case AB_CRAY_POINTEE
:
1984 attr
->cray_pointee
= 1;
1987 attr
->is_bind_c
= 1;
1989 case AB_IS_C_INTEROP
:
1990 attr
->is_c_interop
= 1;
1996 attr
->alloc_comp
= 1;
1998 case AB_COARRAY_COMP
:
1999 attr
->coarray_comp
= 1;
2001 case AB_POINTER_COMP
:
2002 attr
->pointer_comp
= 1;
2004 case AB_PRIVATE_COMP
:
2005 attr
->private_comp
= 1;
2008 attr
->zero_comp
= 1;
2014 attr
->procedure
= 1;
2016 case AB_PROC_POINTER
:
2017 attr
->proc_pointer
= 1;
2025 static const mstring bt_types
[] = {
2026 minit ("INTEGER", BT_INTEGER
),
2027 minit ("REAL", BT_REAL
),
2028 minit ("COMPLEX", BT_COMPLEX
),
2029 minit ("LOGICAL", BT_LOGICAL
),
2030 minit ("CHARACTER", BT_CHARACTER
),
2031 minit ("DERIVED", BT_DERIVED
),
2032 minit ("CLASS", BT_CLASS
),
2033 minit ("PROCEDURE", BT_PROCEDURE
),
2034 minit ("UNKNOWN", BT_UNKNOWN
),
2035 minit ("VOID", BT_VOID
),
2041 mio_charlen (gfc_charlen
**clp
)
2047 if (iomode
== IO_OUTPUT
)
2051 mio_expr (&cl
->length
);
2055 if (peek_atom () != ATOM_RPAREN
)
2057 cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
2058 mio_expr (&cl
->length
);
2067 /* See if a name is a generated name. */
2070 check_unique_name (const char *name
)
2072 return *name
== '@';
2077 mio_typespec (gfc_typespec
*ts
)
2081 ts
->type
= MIO_NAME (bt
) (ts
->type
, bt_types
);
2083 if (ts
->type
!= BT_DERIVED
&& ts
->type
!= BT_CLASS
)
2084 mio_integer (&ts
->kind
);
2086 mio_symbol_ref (&ts
->u
.derived
);
2088 /* Add info for C interop and is_iso_c. */
2089 mio_integer (&ts
->is_c_interop
);
2090 mio_integer (&ts
->is_iso_c
);
2092 /* If the typespec is for an identifier either from iso_c_binding, or
2093 a constant that was initialized to an identifier from it, use the
2094 f90_type. Otherwise, use the ts->type, since it shouldn't matter. */
2096 ts
->f90_type
= MIO_NAME (bt
) (ts
->f90_type
, bt_types
);
2098 ts
->f90_type
= MIO_NAME (bt
) (ts
->type
, bt_types
);
2100 if (ts
->type
!= BT_CHARACTER
)
2102 /* ts->u.cl is only valid for BT_CHARACTER. */
2107 mio_charlen (&ts
->u
.cl
);
2113 static const mstring array_spec_types
[] = {
2114 minit ("EXPLICIT", AS_EXPLICIT
),
2115 minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE
),
2116 minit ("DEFERRED", AS_DEFERRED
),
2117 minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE
),
2123 mio_array_spec (gfc_array_spec
**asp
)
2130 if (iomode
== IO_OUTPUT
)
2138 if (peek_atom () == ATOM_RPAREN
)
2144 *asp
= as
= gfc_get_array_spec ();
2147 mio_integer (&as
->rank
);
2148 mio_integer (&as
->corank
);
2149 as
->type
= MIO_NAME (array_type
) (as
->type
, array_spec_types
);
2151 for (i
= 0; i
< as
->rank
+ as
->corank
; i
++)
2153 mio_expr (&as
->lower
[i
]);
2154 mio_expr (&as
->upper
[i
]);
2162 /* Given a pointer to an array reference structure (which lives in a
2163 gfc_ref structure), find the corresponding array specification
2164 structure. Storing the pointer in the ref structure doesn't quite
2165 work when loading from a module. Generating code for an array
2166 reference also needs more information than just the array spec. */
2168 static const mstring array_ref_types
[] = {
2169 minit ("FULL", AR_FULL
),
2170 minit ("ELEMENT", AR_ELEMENT
),
2171 minit ("SECTION", AR_SECTION
),
2177 mio_array_ref (gfc_array_ref
*ar
)
2182 ar
->type
= MIO_NAME (ar_type
) (ar
->type
, array_ref_types
);
2183 mio_integer (&ar
->dimen
);
2191 for (i
= 0; i
< ar
->dimen
; i
++)
2192 mio_expr (&ar
->start
[i
]);
2197 for (i
= 0; i
< ar
->dimen
; i
++)
2199 mio_expr (&ar
->start
[i
]);
2200 mio_expr (&ar
->end
[i
]);
2201 mio_expr (&ar
->stride
[i
]);
2207 gfc_internal_error ("mio_array_ref(): Unknown array ref");
2210 /* Unfortunately, ar->dimen_type is an anonymous enumerated type so
2211 we can't call mio_integer directly. Instead loop over each element
2212 and cast it to/from an integer. */
2213 if (iomode
== IO_OUTPUT
)
2215 for (i
= 0; i
< ar
->dimen
; i
++)
2217 int tmp
= (int)ar
->dimen_type
[i
];
2218 write_atom (ATOM_INTEGER
, &tmp
);
2223 for (i
= 0; i
< ar
->dimen
; i
++)
2225 require_atom (ATOM_INTEGER
);
2226 ar
->dimen_type
[i
] = (enum gfc_array_ref_dimen_type
) atom_int
;
2230 if (iomode
== IO_INPUT
)
2232 ar
->where
= gfc_current_locus
;
2234 for (i
= 0; i
< ar
->dimen
; i
++)
2235 ar
->c_where
[i
] = gfc_current_locus
;
2242 /* Saves or restores a pointer. The pointer is converted back and
2243 forth from an integer. We return the pointer_info pointer so that
2244 the caller can take additional action based on the pointer type. */
2246 static pointer_info
*
2247 mio_pointer_ref (void *gp
)
2251 if (iomode
== IO_OUTPUT
)
2253 p
= get_pointer (*((char **) gp
));
2254 write_atom (ATOM_INTEGER
, &p
->integer
);
2258 require_atom (ATOM_INTEGER
);
2259 p
= add_fixup (atom_int
, gp
);
2266 /* Save and load references to components that occur within
2267 expressions. We have to describe these references by a number and
2268 by name. The number is necessary for forward references during
2269 reading, and the name is necessary if the symbol already exists in
2270 the namespace and is not loaded again. */
2273 mio_component_ref (gfc_component
**cp
, gfc_symbol
*sym
)
2275 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2279 p
= mio_pointer_ref (cp
);
2280 if (p
->type
== P_UNKNOWN
)
2281 p
->type
= P_COMPONENT
;
2283 if (iomode
== IO_OUTPUT
)
2284 mio_pool_string (&(*cp
)->name
);
2287 mio_internal_string (name
);
2289 /* It can happen that a component reference can be read before the
2290 associated derived type symbol has been loaded. Return now and
2291 wait for a later iteration of load_needed. */
2295 if (sym
->components
!= NULL
&& p
->u
.pointer
== NULL
)
2297 /* Symbol already loaded, so search by name. */
2298 for (q
= sym
->components
; q
; q
= q
->next
)
2299 if (strcmp (q
->name
, name
) == 0)
2303 gfc_internal_error ("mio_component_ref(): Component not found");
2305 associate_integer_pointer (p
, q
);
2308 /* Make sure this symbol will eventually be loaded. */
2309 p
= find_pointer2 (sym
);
2310 if (p
->u
.rsym
.state
== UNUSED
)
2311 p
->u
.rsym
.state
= NEEDED
;
2316 static void mio_namespace_ref (gfc_namespace
**nsp
);
2317 static void mio_formal_arglist (gfc_formal_arglist
**formal
);
2318 static void mio_typebound_proc (gfc_typebound_proc
** proc
);
2321 mio_component (gfc_component
*c
)
2325 gfc_formal_arglist
*formal
;
2329 if (iomode
== IO_OUTPUT
)
2331 p
= get_pointer (c
);
2332 mio_integer (&p
->integer
);
2337 p
= get_integer (n
);
2338 associate_integer_pointer (p
, c
);
2341 if (p
->type
== P_UNKNOWN
)
2342 p
->type
= P_COMPONENT
;
2344 mio_pool_string (&c
->name
);
2345 mio_typespec (&c
->ts
);
2346 mio_array_spec (&c
->as
);
2348 mio_symbol_attribute (&c
->attr
);
2349 c
->attr
.access
= MIO_NAME (gfc_access
) (c
->attr
.access
, access_types
);
2351 mio_expr (&c
->initializer
);
2353 if (c
->attr
.proc_pointer
)
2355 if (iomode
== IO_OUTPUT
)
2358 while (formal
&& !formal
->sym
)
2359 formal
= formal
->next
;
2362 mio_namespace_ref (&formal
->sym
->ns
);
2364 mio_namespace_ref (&c
->formal_ns
);
2368 mio_namespace_ref (&c
->formal_ns
);
2369 /* TODO: if (c->formal_ns)
2371 c->formal_ns->proc_name = c;
2376 mio_formal_arglist (&c
->formal
);
2378 mio_typebound_proc (&c
->tb
);
2386 mio_component_list (gfc_component
**cp
)
2388 gfc_component
*c
, *tail
;
2392 if (iomode
== IO_OUTPUT
)
2394 for (c
= *cp
; c
; c
= c
->next
)
2404 if (peek_atom () == ATOM_RPAREN
)
2407 c
= gfc_get_component ();
2424 mio_actual_arg (gfc_actual_arglist
*a
)
2427 mio_pool_string (&a
->name
);
2428 mio_expr (&a
->expr
);
2434 mio_actual_arglist (gfc_actual_arglist
**ap
)
2436 gfc_actual_arglist
*a
, *tail
;
2440 if (iomode
== IO_OUTPUT
)
2442 for (a
= *ap
; a
; a
= a
->next
)
2452 if (peek_atom () != ATOM_LPAREN
)
2455 a
= gfc_get_actual_arglist ();
2471 /* Read and write formal argument lists. */
2474 mio_formal_arglist (gfc_formal_arglist
**formal
)
2476 gfc_formal_arglist
*f
, *tail
;
2480 if (iomode
== IO_OUTPUT
)
2482 for (f
= *formal
; f
; f
= f
->next
)
2483 mio_symbol_ref (&f
->sym
);
2487 *formal
= tail
= NULL
;
2489 while (peek_atom () != ATOM_RPAREN
)
2491 f
= gfc_get_formal_arglist ();
2492 mio_symbol_ref (&f
->sym
);
2494 if (*formal
== NULL
)
2507 /* Save or restore a reference to a symbol node. */
2510 mio_symbol_ref (gfc_symbol
**symp
)
2514 p
= mio_pointer_ref (symp
);
2515 if (p
->type
== P_UNKNOWN
)
2518 if (iomode
== IO_OUTPUT
)
2520 if (p
->u
.wsym
.state
== UNREFERENCED
)
2521 p
->u
.wsym
.state
= NEEDS_WRITE
;
2525 if (p
->u
.rsym
.state
== UNUSED
)
2526 p
->u
.rsym
.state
= NEEDED
;
2532 /* Save or restore a reference to a symtree node. */
2535 mio_symtree_ref (gfc_symtree
**stp
)
2540 if (iomode
== IO_OUTPUT
)
2541 mio_symbol_ref (&(*stp
)->n
.sym
);
2544 require_atom (ATOM_INTEGER
);
2545 p
= get_integer (atom_int
);
2547 /* An unused equivalence member; make a symbol and a symtree
2549 if (in_load_equiv
&& p
->u
.rsym
.symtree
== NULL
)
2551 /* Since this is not used, it must have a unique name. */
2552 p
->u
.rsym
.symtree
= gfc_get_unique_symtree (gfc_current_ns
);
2554 /* Make the symbol. */
2555 if (p
->u
.rsym
.sym
== NULL
)
2557 p
->u
.rsym
.sym
= gfc_new_symbol (p
->u
.rsym
.true_name
,
2559 p
->u
.rsym
.sym
->module
= gfc_get_string (p
->u
.rsym
.module
);
2562 p
->u
.rsym
.symtree
->n
.sym
= p
->u
.rsym
.sym
;
2563 p
->u
.rsym
.symtree
->n
.sym
->refs
++;
2564 p
->u
.rsym
.referenced
= 1;
2566 /* If the symbol is PRIVATE and in COMMON, load_commons will
2567 generate a fixup symbol, which must be associated. */
2569 resolve_fixups (p
->fixup
, p
->u
.rsym
.sym
);
2573 if (p
->type
== P_UNKNOWN
)
2576 if (p
->u
.rsym
.state
== UNUSED
)
2577 p
->u
.rsym
.state
= NEEDED
;
2579 if (p
->u
.rsym
.symtree
!= NULL
)
2581 *stp
= p
->u
.rsym
.symtree
;
2585 f
= XCNEW (fixup_t
);
2587 f
->next
= p
->u
.rsym
.stfixup
;
2588 p
->u
.rsym
.stfixup
= f
;
2590 f
->pointer
= (void **) stp
;
2597 mio_iterator (gfc_iterator
**ip
)
2603 if (iomode
== IO_OUTPUT
)
2610 if (peek_atom () == ATOM_RPAREN
)
2616 *ip
= gfc_get_iterator ();
2621 mio_expr (&iter
->var
);
2622 mio_expr (&iter
->start
);
2623 mio_expr (&iter
->end
);
2624 mio_expr (&iter
->step
);
2632 mio_constructor (gfc_constructor_base
*cp
)
2638 if (iomode
== IO_OUTPUT
)
2640 for (c
= gfc_constructor_first (*cp
); c
; c
= gfc_constructor_next (c
))
2643 mio_expr (&c
->expr
);
2644 mio_iterator (&c
->iterator
);
2650 while (peek_atom () != ATOM_RPAREN
)
2652 c
= gfc_constructor_append_expr (cp
, NULL
, NULL
);
2655 mio_expr (&c
->expr
);
2656 mio_iterator (&c
->iterator
);
2665 static const mstring ref_types
[] = {
2666 minit ("ARRAY", REF_ARRAY
),
2667 minit ("COMPONENT", REF_COMPONENT
),
2668 minit ("SUBSTRING", REF_SUBSTRING
),
2674 mio_ref (gfc_ref
**rp
)
2681 r
->type
= MIO_NAME (ref_type
) (r
->type
, ref_types
);
2686 mio_array_ref (&r
->u
.ar
);
2690 mio_symbol_ref (&r
->u
.c
.sym
);
2691 mio_component_ref (&r
->u
.c
.component
, r
->u
.c
.sym
);
2695 mio_expr (&r
->u
.ss
.start
);
2696 mio_expr (&r
->u
.ss
.end
);
2697 mio_charlen (&r
->u
.ss
.length
);
2706 mio_ref_list (gfc_ref
**rp
)
2708 gfc_ref
*ref
, *head
, *tail
;
2712 if (iomode
== IO_OUTPUT
)
2714 for (ref
= *rp
; ref
; ref
= ref
->next
)
2721 while (peek_atom () != ATOM_RPAREN
)
2724 head
= tail
= gfc_get_ref ();
2727 tail
->next
= gfc_get_ref ();
2741 /* Read and write an integer value. */
2744 mio_gmp_integer (mpz_t
*integer
)
2748 if (iomode
== IO_INPUT
)
2750 if (parse_atom () != ATOM_STRING
)
2751 bad_module ("Expected integer string");
2753 mpz_init (*integer
);
2754 if (mpz_set_str (*integer
, atom_string
, 10))
2755 bad_module ("Error converting integer");
2757 gfc_free (atom_string
);
2761 p
= mpz_get_str (NULL
, 10, *integer
);
2762 write_atom (ATOM_STRING
, p
);
2769 mio_gmp_real (mpfr_t
*real
)
2774 if (iomode
== IO_INPUT
)
2776 if (parse_atom () != ATOM_STRING
)
2777 bad_module ("Expected real string");
2780 mpfr_set_str (*real
, atom_string
, 16, GFC_RND_MODE
);
2781 gfc_free (atom_string
);
2785 p
= mpfr_get_str (NULL
, &exponent
, 16, 0, *real
, GFC_RND_MODE
);
2787 if (mpfr_nan_p (*real
) || mpfr_inf_p (*real
))
2789 write_atom (ATOM_STRING
, p
);
2794 atom_string
= XCNEWVEC (char, strlen (p
) + 20);
2796 sprintf (atom_string
, "0.%s@%ld", p
, exponent
);
2798 /* Fix negative numbers. */
2799 if (atom_string
[2] == '-')
2801 atom_string
[0] = '-';
2802 atom_string
[1] = '0';
2803 atom_string
[2] = '.';
2806 write_atom (ATOM_STRING
, atom_string
);
2808 gfc_free (atom_string
);
2814 /* Save and restore the shape of an array constructor. */
2817 mio_shape (mpz_t
**pshape
, int rank
)
2823 /* A NULL shape is represented by (). */
2826 if (iomode
== IO_OUTPUT
)
2838 if (t
== ATOM_RPAREN
)
2845 shape
= gfc_get_shape (rank
);
2849 for (n
= 0; n
< rank
; n
++)
2850 mio_gmp_integer (&shape
[n
]);
2856 static const mstring expr_types
[] = {
2857 minit ("OP", EXPR_OP
),
2858 minit ("FUNCTION", EXPR_FUNCTION
),
2859 minit ("CONSTANT", EXPR_CONSTANT
),
2860 minit ("VARIABLE", EXPR_VARIABLE
),
2861 minit ("SUBSTRING", EXPR_SUBSTRING
),
2862 minit ("STRUCTURE", EXPR_STRUCTURE
),
2863 minit ("ARRAY", EXPR_ARRAY
),
2864 minit ("NULL", EXPR_NULL
),
2865 minit ("COMPCALL", EXPR_COMPCALL
),
2869 /* INTRINSIC_ASSIGN is missing because it is used as an index for
2870 generic operators, not in expressions. INTRINSIC_USER is also
2871 replaced by the correct function name by the time we see it. */
2873 static const mstring intrinsics
[] =
2875 minit ("UPLUS", INTRINSIC_UPLUS
),
2876 minit ("UMINUS", INTRINSIC_UMINUS
),
2877 minit ("PLUS", INTRINSIC_PLUS
),
2878 minit ("MINUS", INTRINSIC_MINUS
),
2879 minit ("TIMES", INTRINSIC_TIMES
),
2880 minit ("DIVIDE", INTRINSIC_DIVIDE
),
2881 minit ("POWER", INTRINSIC_POWER
),
2882 minit ("CONCAT", INTRINSIC_CONCAT
),
2883 minit ("AND", INTRINSIC_AND
),
2884 minit ("OR", INTRINSIC_OR
),
2885 minit ("EQV", INTRINSIC_EQV
),
2886 minit ("NEQV", INTRINSIC_NEQV
),
2887 minit ("EQ_SIGN", INTRINSIC_EQ
),
2888 minit ("EQ", INTRINSIC_EQ_OS
),
2889 minit ("NE_SIGN", INTRINSIC_NE
),
2890 minit ("NE", INTRINSIC_NE_OS
),
2891 minit ("GT_SIGN", INTRINSIC_GT
),
2892 minit ("GT", INTRINSIC_GT_OS
),
2893 minit ("GE_SIGN", INTRINSIC_GE
),
2894 minit ("GE", INTRINSIC_GE_OS
),
2895 minit ("LT_SIGN", INTRINSIC_LT
),
2896 minit ("LT", INTRINSIC_LT_OS
),
2897 minit ("LE_SIGN", INTRINSIC_LE
),
2898 minit ("LE", INTRINSIC_LE_OS
),
2899 minit ("NOT", INTRINSIC_NOT
),
2900 minit ("PARENTHESES", INTRINSIC_PARENTHESES
),
2905 /* Remedy a couple of situations where the gfc_expr's can be defective. */
2908 fix_mio_expr (gfc_expr
*e
)
2910 gfc_symtree
*ns_st
= NULL
;
2913 if (iomode
!= IO_OUTPUT
)
2918 /* If this is a symtree for a symbol that came from a contained module
2919 namespace, it has a unique name and we should look in the current
2920 namespace to see if the required, non-contained symbol is available
2921 yet. If so, the latter should be written. */
2922 if (e
->symtree
->n
.sym
&& check_unique_name (e
->symtree
->name
))
2923 ns_st
= gfc_find_symtree (gfc_current_ns
->sym_root
,
2924 e
->symtree
->n
.sym
->name
);
2926 /* On the other hand, if the existing symbol is the module name or the
2927 new symbol is a dummy argument, do not do the promotion. */
2928 if (ns_st
&& ns_st
->n
.sym
2929 && ns_st
->n
.sym
->attr
.flavor
!= FL_MODULE
2930 && !e
->symtree
->n
.sym
->attr
.dummy
)
2933 else if (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.name
)
2937 /* In some circumstances, a function used in an initialization
2938 expression, in one use associated module, can fail to be
2939 coupled to its symtree when used in a specification
2940 expression in another module. */
2941 fname
= e
->value
.function
.esym
? e
->value
.function
.esym
->name
2942 : e
->value
.function
.isym
->name
;
2943 e
->symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, fname
);
2948 /* This is probably a reference to a private procedure from another
2949 module. To prevent a segfault, make a generic with no specific
2950 instances. If this module is used, without the required
2951 specific coming from somewhere, the appropriate error message
2953 gfc_get_symbol (fname
, gfc_current_ns
, &sym
);
2954 sym
->attr
.flavor
= FL_PROCEDURE
;
2955 sym
->attr
.generic
= 1;
2956 e
->symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, fname
);
2961 /* Read and write expressions. The form "()" is allowed to indicate a
2965 mio_expr (gfc_expr
**ep
)
2973 if (iomode
== IO_OUTPUT
)
2982 MIO_NAME (expr_t
) (e
->expr_type
, expr_types
);
2987 if (t
== ATOM_RPAREN
)
2994 bad_module ("Expected expression type");
2996 e
= *ep
= gfc_get_expr ();
2997 e
->where
= gfc_current_locus
;
2998 e
->expr_type
= (expr_t
) find_enum (expr_types
);
3001 mio_typespec (&e
->ts
);
3002 mio_integer (&e
->rank
);
3006 switch (e
->expr_type
)
3010 = MIO_NAME (gfc_intrinsic_op
) (e
->value
.op
.op
, intrinsics
);
3012 switch (e
->value
.op
.op
)
3014 case INTRINSIC_UPLUS
:
3015 case INTRINSIC_UMINUS
:
3017 case INTRINSIC_PARENTHESES
:
3018 mio_expr (&e
->value
.op
.op1
);
3021 case INTRINSIC_PLUS
:
3022 case INTRINSIC_MINUS
:
3023 case INTRINSIC_TIMES
:
3024 case INTRINSIC_DIVIDE
:
3025 case INTRINSIC_POWER
:
3026 case INTRINSIC_CONCAT
:
3030 case INTRINSIC_NEQV
:
3032 case INTRINSIC_EQ_OS
:
3034 case INTRINSIC_NE_OS
:
3036 case INTRINSIC_GT_OS
:
3038 case INTRINSIC_GE_OS
:
3040 case INTRINSIC_LT_OS
:
3042 case INTRINSIC_LE_OS
:
3043 mio_expr (&e
->value
.op
.op1
);
3044 mio_expr (&e
->value
.op
.op2
);
3048 bad_module ("Bad operator");
3054 mio_symtree_ref (&e
->symtree
);
3055 mio_actual_arglist (&e
->value
.function
.actual
);
3057 if (iomode
== IO_OUTPUT
)
3059 e
->value
.function
.name
3060 = mio_allocated_string (e
->value
.function
.name
);
3061 flag
= e
->value
.function
.esym
!= NULL
;
3062 mio_integer (&flag
);
3064 mio_symbol_ref (&e
->value
.function
.esym
);
3066 write_atom (ATOM_STRING
, e
->value
.function
.isym
->name
);
3070 require_atom (ATOM_STRING
);
3071 e
->value
.function
.name
= gfc_get_string (atom_string
);
3072 gfc_free (atom_string
);
3074 mio_integer (&flag
);
3076 mio_symbol_ref (&e
->value
.function
.esym
);
3079 require_atom (ATOM_STRING
);
3080 e
->value
.function
.isym
= gfc_find_function (atom_string
);
3081 gfc_free (atom_string
);
3088 mio_symtree_ref (&e
->symtree
);
3089 mio_ref_list (&e
->ref
);
3092 case EXPR_SUBSTRING
:
3093 e
->value
.character
.string
3094 = CONST_CAST (gfc_char_t
*,
3095 mio_allocated_wide_string (e
->value
.character
.string
,
3096 e
->value
.character
.length
));
3097 mio_ref_list (&e
->ref
);
3100 case EXPR_STRUCTURE
:
3102 mio_constructor (&e
->value
.constructor
);
3103 mio_shape (&e
->shape
, e
->rank
);
3110 mio_gmp_integer (&e
->value
.integer
);
3114 gfc_set_model_kind (e
->ts
.kind
);
3115 mio_gmp_real (&e
->value
.real
);
3119 gfc_set_model_kind (e
->ts
.kind
);
3120 mio_gmp_real (&mpc_realref (e
->value
.complex));
3121 mio_gmp_real (&mpc_imagref (e
->value
.complex));
3125 mio_integer (&e
->value
.logical
);
3129 mio_integer (&e
->value
.character
.length
);
3130 e
->value
.character
.string
3131 = CONST_CAST (gfc_char_t
*,
3132 mio_allocated_wide_string (e
->value
.character
.string
,
3133 e
->value
.character
.length
));
3137 bad_module ("Bad type in constant expression");
3155 /* Read and write namelists. */
3158 mio_namelist (gfc_symbol
*sym
)
3160 gfc_namelist
*n
, *m
;
3161 const char *check_name
;
3165 if (iomode
== IO_OUTPUT
)
3167 for (n
= sym
->namelist
; n
; n
= n
->next
)
3168 mio_symbol_ref (&n
->sym
);
3172 /* This departure from the standard is flagged as an error.
3173 It does, in fact, work correctly. TODO: Allow it
3175 if (sym
->attr
.flavor
== FL_NAMELIST
)
3177 check_name
= find_use_name (sym
->name
, false);
3178 if (check_name
&& strcmp (check_name
, sym
->name
) != 0)
3179 gfc_error ("Namelist %s cannot be renamed by USE "
3180 "association to %s", sym
->name
, check_name
);
3184 while (peek_atom () != ATOM_RPAREN
)
3186 n
= gfc_get_namelist ();
3187 mio_symbol_ref (&n
->sym
);
3189 if (sym
->namelist
== NULL
)
3196 sym
->namelist_tail
= m
;
3203 /* Save/restore lists of gfc_interface structures. When loading an
3204 interface, we are really appending to the existing list of
3205 interfaces. Checking for duplicate and ambiguous interfaces has to
3206 be done later when all symbols have been loaded. */
3209 mio_interface_rest (gfc_interface
**ip
)
3211 gfc_interface
*tail
, *p
;
3212 pointer_info
*pi
= NULL
;
3214 if (iomode
== IO_OUTPUT
)
3217 for (p
= *ip
; p
; p
= p
->next
)
3218 mio_symbol_ref (&p
->sym
);
3233 if (peek_atom () == ATOM_RPAREN
)
3236 p
= gfc_get_interface ();
3237 p
->where
= gfc_current_locus
;
3238 pi
= mio_symbol_ref (&p
->sym
);
3254 /* Save/restore a nameless operator interface. */
3257 mio_interface (gfc_interface
**ip
)
3260 mio_interface_rest (ip
);
3264 /* Save/restore a named operator interface. */
3267 mio_symbol_interface (const char **name
, const char **module
,
3271 mio_pool_string (name
);
3272 mio_pool_string (module
);
3273 mio_interface_rest (ip
);
3278 mio_namespace_ref (gfc_namespace
**nsp
)
3283 p
= mio_pointer_ref (nsp
);
3285 if (p
->type
== P_UNKNOWN
)
3286 p
->type
= P_NAMESPACE
;
3288 if (iomode
== IO_INPUT
&& p
->integer
!= 0)
3290 ns
= (gfc_namespace
*) p
->u
.pointer
;
3293 ns
= gfc_get_namespace (NULL
, 0);
3294 associate_integer_pointer (p
, ns
);
3302 /* Save/restore the f2k_derived namespace of a derived-type symbol. */
3304 static gfc_namespace
* current_f2k_derived
;
3307 mio_typebound_proc (gfc_typebound_proc
** proc
)
3310 int overriding_flag
;
3312 if (iomode
== IO_INPUT
)
3314 *proc
= gfc_get_typebound_proc ();
3315 (*proc
)->where
= gfc_current_locus
;
3321 (*proc
)->access
= MIO_NAME (gfc_access
) ((*proc
)->access
, access_types
);
3323 /* IO the NON_OVERRIDABLE/DEFERRED combination. */
3324 gcc_assert (!((*proc
)->deferred
&& (*proc
)->non_overridable
));
3325 overriding_flag
= ((*proc
)->deferred
<< 1) | (*proc
)->non_overridable
;
3326 overriding_flag
= mio_name (overriding_flag
, binding_overriding
);
3327 (*proc
)->deferred
= ((overriding_flag
& 2) != 0);
3328 (*proc
)->non_overridable
= ((overriding_flag
& 1) != 0);
3329 gcc_assert (!((*proc
)->deferred
&& (*proc
)->non_overridable
));
3331 (*proc
)->nopass
= mio_name ((*proc
)->nopass
, binding_passing
);
3332 (*proc
)->is_generic
= mio_name ((*proc
)->is_generic
, binding_generic
);
3333 (*proc
)->ppc
= mio_name((*proc
)->ppc
, binding_ppc
);
3335 mio_pool_string (&((*proc
)->pass_arg
));
3337 flag
= (int) (*proc
)->pass_arg_num
;
3338 mio_integer (&flag
);
3339 (*proc
)->pass_arg_num
= (unsigned) flag
;
3341 if ((*proc
)->is_generic
)
3347 if (iomode
== IO_OUTPUT
)
3348 for (g
= (*proc
)->u
.generic
; g
; g
= g
->next
)
3349 mio_allocated_string (g
->specific_st
->name
);
3352 (*proc
)->u
.generic
= NULL
;
3353 while (peek_atom () != ATOM_RPAREN
)
3355 gfc_symtree
** sym_root
;
3357 g
= gfc_get_tbp_generic ();
3360 require_atom (ATOM_STRING
);
3361 sym_root
= ¤t_f2k_derived
->tb_sym_root
;
3362 g
->specific_st
= gfc_get_tbp_symtree (sym_root
, atom_string
);
3363 gfc_free (atom_string
);
3365 g
->next
= (*proc
)->u
.generic
;
3366 (*proc
)->u
.generic
= g
;
3372 else if (!(*proc
)->ppc
)
3373 mio_symtree_ref (&(*proc
)->u
.specific
);
3378 /* Walker-callback function for this purpose. */
3380 mio_typebound_symtree (gfc_symtree
* st
)
3382 if (iomode
== IO_OUTPUT
&& !st
->n
.tb
)
3385 if (iomode
== IO_OUTPUT
)
3388 mio_allocated_string (st
->name
);
3390 /* For IO_INPUT, the above is done in mio_f2k_derived. */
3392 mio_typebound_proc (&st
->n
.tb
);
3396 /* IO a full symtree (in all depth). */
3398 mio_full_typebound_tree (gfc_symtree
** root
)
3402 if (iomode
== IO_OUTPUT
)
3403 gfc_traverse_symtree (*root
, &mio_typebound_symtree
);
3406 while (peek_atom () == ATOM_LPAREN
)
3412 require_atom (ATOM_STRING
);
3413 st
= gfc_get_tbp_symtree (root
, atom_string
);
3414 gfc_free (atom_string
);
3416 mio_typebound_symtree (st
);
3424 mio_finalizer (gfc_finalizer
**f
)
3426 if (iomode
== IO_OUTPUT
)
3429 gcc_assert ((*f
)->proc_tree
); /* Should already be resolved. */
3430 mio_symtree_ref (&(*f
)->proc_tree
);
3434 *f
= gfc_get_finalizer ();
3435 (*f
)->where
= gfc_current_locus
; /* Value should not matter. */
3438 mio_symtree_ref (&(*f
)->proc_tree
);
3439 (*f
)->proc_sym
= NULL
;
3444 mio_f2k_derived (gfc_namespace
*f2k
)
3446 current_f2k_derived
= f2k
;
3448 /* Handle the list of finalizer procedures. */
3450 if (iomode
== IO_OUTPUT
)
3453 for (f
= f2k
->finalizers
; f
; f
= f
->next
)
3458 f2k
->finalizers
= NULL
;
3459 while (peek_atom () != ATOM_RPAREN
)
3461 gfc_finalizer
*cur
= NULL
;
3462 mio_finalizer (&cur
);
3463 cur
->next
= f2k
->finalizers
;
3464 f2k
->finalizers
= cur
;
3469 /* Handle type-bound procedures. */
3470 mio_full_typebound_tree (&f2k
->tb_sym_root
);
3472 /* Type-bound user operators. */
3473 mio_full_typebound_tree (&f2k
->tb_uop_root
);
3475 /* Type-bound intrinsic operators. */
3477 if (iomode
== IO_OUTPUT
)
3480 for (op
= GFC_INTRINSIC_BEGIN
; op
!= GFC_INTRINSIC_END
; ++op
)
3482 gfc_intrinsic_op realop
;
3484 if (op
== INTRINSIC_USER
|| !f2k
->tb_op
[op
])
3488 realop
= (gfc_intrinsic_op
) op
;
3489 mio_intrinsic_op (&realop
);
3490 mio_typebound_proc (&f2k
->tb_op
[op
]);
3495 while (peek_atom () != ATOM_RPAREN
)
3497 gfc_intrinsic_op op
= GFC_INTRINSIC_BEGIN
; /* Silence GCC. */
3500 mio_intrinsic_op (&op
);
3501 mio_typebound_proc (&f2k
->tb_op
[op
]);
3508 mio_full_f2k_derived (gfc_symbol
*sym
)
3512 if (iomode
== IO_OUTPUT
)
3514 if (sym
->f2k_derived
)
3515 mio_f2k_derived (sym
->f2k_derived
);
3519 if (peek_atom () != ATOM_RPAREN
)
3521 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
3522 mio_f2k_derived (sym
->f2k_derived
);
3525 gcc_assert (!sym
->f2k_derived
);
3532 /* Unlike most other routines, the address of the symbol node is already
3533 fixed on input and the name/module has already been filled in. */
3536 mio_symbol (gfc_symbol
*sym
)
3538 int intmod
= INTMOD_NONE
;
3542 mio_symbol_attribute (&sym
->attr
);
3543 mio_typespec (&sym
->ts
);
3545 if (iomode
== IO_OUTPUT
)
3546 mio_namespace_ref (&sym
->formal_ns
);
3549 mio_namespace_ref (&sym
->formal_ns
);
3552 sym
->formal_ns
->proc_name
= sym
;
3557 /* Save/restore common block links. */
3558 mio_symbol_ref (&sym
->common_next
);
3560 mio_formal_arglist (&sym
->formal
);
3562 if (sym
->attr
.flavor
== FL_PARAMETER
)
3563 mio_expr (&sym
->value
);
3565 mio_array_spec (&sym
->as
);
3567 mio_symbol_ref (&sym
->result
);
3569 if (sym
->attr
.cray_pointee
)
3570 mio_symbol_ref (&sym
->cp_pointer
);
3572 /* Note that components are always saved, even if they are supposed
3573 to be private. Component access is checked during searching. */
3575 mio_component_list (&sym
->components
);
3577 if (sym
->components
!= NULL
)
3578 sym
->component_access
3579 = MIO_NAME (gfc_access
) (sym
->component_access
, access_types
);
3581 /* Load/save the f2k_derived namespace of a derived-type symbol. */
3582 mio_full_f2k_derived (sym
);
3586 /* Add the fields that say whether this is from an intrinsic module,
3587 and if so, what symbol it is within the module. */
3588 /* mio_integer (&(sym->from_intmod)); */
3589 if (iomode
== IO_OUTPUT
)
3591 intmod
= sym
->from_intmod
;
3592 mio_integer (&intmod
);
3596 mio_integer (&intmod
);
3597 sym
->from_intmod
= (intmod_id
) intmod
;
3600 mio_integer (&(sym
->intmod_sym_id
));
3602 if (sym
->attr
.flavor
== FL_DERIVED
)
3603 mio_integer (&(sym
->hash_value
));
3609 /************************* Top level subroutines *************************/
3611 /* Given a root symtree node and a symbol, try to find a symtree that
3612 references the symbol that is not a unique name. */
3614 static gfc_symtree
*
3615 find_symtree_for_symbol (gfc_symtree
*st
, gfc_symbol
*sym
)
3617 gfc_symtree
*s
= NULL
;
3622 s
= find_symtree_for_symbol (st
->right
, sym
);
3625 s
= find_symtree_for_symbol (st
->left
, sym
);
3629 if (st
->n
.sym
== sym
&& !check_unique_name (st
->name
))
3636 /* A recursive function to look for a specific symbol by name and by
3637 module. Whilst several symtrees might point to one symbol, its
3638 is sufficient for the purposes here than one exist. Note that
3639 generic interfaces are distinguished as are symbols that have been
3640 renamed in another module. */
3641 static gfc_symtree
*
3642 find_symbol (gfc_symtree
*st
, const char *name
,
3643 const char *module
, int generic
)
3646 gfc_symtree
*retval
, *s
;
3648 if (st
== NULL
|| st
->n
.sym
== NULL
)
3651 c
= strcmp (name
, st
->n
.sym
->name
);
3652 if (c
== 0 && st
->n
.sym
->module
3653 && strcmp (module
, st
->n
.sym
->module
) == 0
3654 && !check_unique_name (st
->name
))
3656 s
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
3658 /* Detect symbols that are renamed by use association in another
3659 module by the absence of a symtree and null attr.use_rename,
3660 since the latter is not transmitted in the module file. */
3661 if (((!generic
&& !st
->n
.sym
->attr
.generic
)
3662 || (generic
&& st
->n
.sym
->attr
.generic
))
3663 && !(s
== NULL
&& !st
->n
.sym
->attr
.use_rename
))
3667 retval
= find_symbol (st
->left
, name
, module
, generic
);
3670 retval
= find_symbol (st
->right
, name
, module
, generic
);
3676 /* Skip a list between balanced left and right parens. */
3686 switch (parse_atom ())
3697 gfc_free (atom_string
);
3709 /* Load operator interfaces from the module. Interfaces are unusual
3710 in that they attach themselves to existing symbols. */
3713 load_operator_interfaces (void)
3716 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[GFC_MAX_SYMBOL_LEN
+ 1];
3718 pointer_info
*pi
= NULL
;
3723 while (peek_atom () != ATOM_RPAREN
)
3727 mio_internal_string (name
);
3728 mio_internal_string (module
);
3730 n
= number_use_names (name
, true);
3733 for (i
= 1; i
<= n
; i
++)
3735 /* Decide if we need to load this one or not. */
3736 p
= find_use_name_n (name
, &i
, true);
3740 while (parse_atom () != ATOM_RPAREN
);
3746 uop
= gfc_get_uop (p
);
3747 pi
= mio_interface_rest (&uop
->op
);
3751 if (gfc_find_uop (p
, NULL
))
3753 uop
= gfc_get_uop (p
);
3754 uop
->op
= gfc_get_interface ();
3755 uop
->op
->where
= gfc_current_locus
;
3756 add_fixup (pi
->integer
, &uop
->op
->sym
);
3765 /* Load interfaces from the module. Interfaces are unusual in that
3766 they attach themselves to existing symbols. */
3769 load_generic_interfaces (void)
3772 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[GFC_MAX_SYMBOL_LEN
+ 1];
3774 gfc_interface
*generic
= NULL
, *gen
= NULL
;
3776 bool ambiguous_set
= false;
3780 while (peek_atom () != ATOM_RPAREN
)
3784 mio_internal_string (name
);
3785 mio_internal_string (module
);
3787 n
= number_use_names (name
, false);
3788 renamed
= n
? 1 : 0;
3791 for (i
= 1; i
<= n
; i
++)
3794 /* Decide if we need to load this one or not. */
3795 p
= find_use_name_n (name
, &i
, false);
3797 st
= find_symbol (gfc_current_ns
->sym_root
,
3798 name
, module_name
, 1);
3800 if (!p
|| gfc_find_symbol (p
, NULL
, 0, &sym
))
3802 /* Skip the specific names for these cases. */
3803 while (i
== 1 && parse_atom () != ATOM_RPAREN
);
3808 /* If the symbol exists already and is being USEd without being
3809 in an ONLY clause, do not load a new symtree(11.3.2). */
3810 if (!only_flag
&& st
)
3815 /* Make the symbol inaccessible if it has been added by a USE
3816 statement without an ONLY(11.3.2). */
3818 && !st
->n
.sym
->attr
.use_only
3819 && !st
->n
.sym
->attr
.use_rename
3820 && strcmp (st
->n
.sym
->module
, module_name
) == 0)
3823 gfc_delete_symtree (&gfc_current_ns
->sym_root
, name
);
3824 st
= gfc_get_unique_symtree (gfc_current_ns
);
3831 if (strcmp (st
->name
, p
) != 0)
3833 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, p
);
3839 /* Since we haven't found a valid generic interface, we had
3843 gfc_get_symbol (p
, NULL
, &sym
);
3844 sym
->name
= gfc_get_string (name
);
3845 sym
->module
= gfc_get_string (module_name
);
3846 sym
->attr
.flavor
= FL_PROCEDURE
;
3847 sym
->attr
.generic
= 1;
3848 sym
->attr
.use_assoc
= 1;
3853 /* Unless sym is a generic interface, this reference
3856 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
3860 if (st
&& !sym
->attr
.generic
3863 && strcmp(module
, sym
->module
))
3865 ambiguous_set
= true;
3870 sym
->attr
.use_only
= only_flag
;
3871 sym
->attr
.use_rename
= renamed
;
3875 mio_interface_rest (&sym
->generic
);
3876 generic
= sym
->generic
;
3878 else if (!sym
->generic
)
3880 sym
->generic
= generic
;
3881 sym
->attr
.generic_copy
= 1;
3884 /* If a procedure that is not generic has generic interfaces
3885 that include itself, it is generic! We need to take care
3886 to retain symbols ambiguous that were already so. */
3887 if (sym
->attr
.use_assoc
3888 && !sym
->attr
.generic
3889 && sym
->attr
.flavor
== FL_PROCEDURE
)
3891 for (gen
= generic
; gen
; gen
= gen
->next
)
3893 if (gen
->sym
== sym
)
3895 sym
->attr
.generic
= 1;
3910 /* Load common blocks. */
3915 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3920 while (peek_atom () != ATOM_RPAREN
)
3924 mio_internal_string (name
);
3926 p
= gfc_get_common (name
, 1);
3928 mio_symbol_ref (&p
->head
);
3929 mio_integer (&flags
);
3933 p
->threadprivate
= 1;
3936 /* Get whether this was a bind(c) common or not. */
3937 mio_integer (&p
->is_bind_c
);
3938 /* Get the binding label. */
3939 mio_internal_string (p
->binding_label
);
3948 /* Load equivalences. The flag in_load_equiv informs mio_expr_ref of this
3949 so that unused variables are not loaded and so that the expression can
3955 gfc_equiv
*head
, *tail
, *end
, *eq
;
3959 in_load_equiv
= true;
3961 end
= gfc_current_ns
->equiv
;
3962 while (end
!= NULL
&& end
->next
!= NULL
)
3965 while (peek_atom () != ATOM_RPAREN
) {
3969 while(peek_atom () != ATOM_RPAREN
)
3972 head
= tail
= gfc_get_equiv ();
3975 tail
->eq
= gfc_get_equiv ();
3979 mio_pool_string (&tail
->module
);
3980 mio_expr (&tail
->expr
);
3983 /* Unused equivalence members have a unique name. In addition, it
3984 must be checked that the symbols are from the same module. */
3986 for (eq
= head
; eq
; eq
= eq
->eq
)
3988 if (eq
->expr
->symtree
->n
.sym
->module
3989 && head
->expr
->symtree
->n
.sym
->module
3990 && strcmp (head
->expr
->symtree
->n
.sym
->module
,
3991 eq
->expr
->symtree
->n
.sym
->module
) == 0
3992 && !check_unique_name (eq
->expr
->symtree
->name
))
4001 for (eq
= head
; eq
; eq
= head
)
4004 gfc_free_expr (eq
->expr
);
4010 gfc_current_ns
->equiv
= head
;
4021 in_load_equiv
= false;
4025 /* This function loads the sym_root of f2k_derived with the extensions to
4026 the derived type. */
4028 load_derived_extensions (void)
4031 gfc_symbol
*derived
;
4035 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4036 char module
[GFC_MAX_SYMBOL_LEN
+ 1];
4040 while (peek_atom () != ATOM_RPAREN
)
4043 mio_integer (&symbol
);
4044 info
= get_integer (symbol
);
4045 derived
= info
->u
.rsym
.sym
;
4047 /* This one is not being loaded. */
4048 if (!info
|| !derived
)
4050 while (peek_atom () != ATOM_RPAREN
)
4055 gcc_assert (derived
->attr
.flavor
== FL_DERIVED
);
4056 if (derived
->f2k_derived
== NULL
)
4057 derived
->f2k_derived
= gfc_get_namespace (NULL
, 0);
4059 while (peek_atom () != ATOM_RPAREN
)
4062 mio_internal_string (name
);
4063 mio_internal_string (module
);
4065 /* Only use one use name to find the symbol. */
4067 p
= find_use_name_n (name
, &j
, false);
4070 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
4072 st
= gfc_find_symtree (derived
->f2k_derived
->sym_root
, name
);
4075 /* Only use the real name in f2k_derived to ensure a single
4077 st
= gfc_new_symtree (&derived
->f2k_derived
->sym_root
, name
);
4090 /* Recursive function to traverse the pointer_info tree and load a
4091 needed symbol. We return nonzero if we load a symbol and stop the
4092 traversal, because the act of loading can alter the tree. */
4095 load_needed (pointer_info
*p
)
4106 rv
|= load_needed (p
->left
);
4107 rv
|= load_needed (p
->right
);
4109 if (p
->type
!= P_SYMBOL
|| p
->u
.rsym
.state
!= NEEDED
)
4112 p
->u
.rsym
.state
= USED
;
4114 set_module_locus (&p
->u
.rsym
.where
);
4116 sym
= p
->u
.rsym
.sym
;
4119 q
= get_integer (p
->u
.rsym
.ns
);
4121 ns
= (gfc_namespace
*) q
->u
.pointer
;
4124 /* Create an interface namespace if necessary. These are
4125 the namespaces that hold the formal parameters of module
4128 ns
= gfc_get_namespace (NULL
, 0);
4129 associate_integer_pointer (q
, ns
);
4132 /* Use the module sym as 'proc_name' so that gfc_get_symbol_decl
4133 doesn't go pear-shaped if the symbol is used. */
4135 gfc_find_symbol (p
->u
.rsym
.module
, gfc_current_ns
,
4138 sym
= gfc_new_symbol (p
->u
.rsym
.true_name
, ns
);
4139 sym
->module
= gfc_get_string (p
->u
.rsym
.module
);
4140 strcpy (sym
->binding_label
, p
->u
.rsym
.binding_label
);
4142 associate_integer_pointer (p
, sym
);
4146 sym
->attr
.use_assoc
= 1;
4148 sym
->attr
.use_only
= 1;
4149 if (p
->u
.rsym
.renamed
)
4150 sym
->attr
.use_rename
= 1;
4156 /* Recursive function for cleaning up things after a module has been read. */
4159 read_cleanup (pointer_info
*p
)
4167 read_cleanup (p
->left
);
4168 read_cleanup (p
->right
);
4170 if (p
->type
== P_SYMBOL
&& p
->u
.rsym
.state
== USED
&& !p
->u
.rsym
.referenced
)
4172 /* Add hidden symbols to the symtree. */
4173 q
= get_integer (p
->u
.rsym
.ns
);
4174 st
= gfc_get_unique_symtree ((gfc_namespace
*) q
->u
.pointer
);
4176 st
->n
.sym
= p
->u
.rsym
.sym
;
4179 /* Fixup any symtree references. */
4180 p
->u
.rsym
.symtree
= st
;
4181 resolve_fixups (p
->u
.rsym
.stfixup
, st
);
4182 p
->u
.rsym
.stfixup
= NULL
;
4185 /* Free unused symbols. */
4186 if (p
->type
== P_SYMBOL
&& p
->u
.rsym
.state
== UNUSED
)
4187 gfc_free_symbol (p
->u
.rsym
.sym
);
4191 /* It is not quite enough to check for ambiguity in the symbols by
4192 the loaded symbol and the new symbol not being identical. */
4194 check_for_ambiguous (gfc_symbol
*st_sym
, pointer_info
*info
)
4198 symbol_attribute attr
;
4200 rsym
= info
->u
.rsym
.sym
;
4204 /* If the existing symbol is generic from a different module and
4205 the new symbol is generic there can be no ambiguity. */
4206 if (st_sym
->attr
.generic
4208 && strcmp (st_sym
->module
, module_name
))
4210 /* The new symbol's attributes have not yet been read. Since
4211 we need attr.generic, read it directly. */
4212 get_module_locus (&locus
);
4213 set_module_locus (&info
->u
.rsym
.where
);
4216 mio_symbol_attribute (&attr
);
4217 set_module_locus (&locus
);
4226 /* Read a module file. */
4231 module_locus operator_interfaces
, user_operators
, extensions
;
4233 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4235 int ambiguous
, j
, nuse
, symbol
;
4236 pointer_info
*info
, *q
;
4241 get_module_locus (&operator_interfaces
); /* Skip these for now. */
4244 get_module_locus (&user_operators
);
4248 /* Skip commons, equivalences and derived type extensions for now. */
4252 get_module_locus (&extensions
);
4257 /* Create the fixup nodes for all the symbols. */
4259 while (peek_atom () != ATOM_RPAREN
)
4261 require_atom (ATOM_INTEGER
);
4262 info
= get_integer (atom_int
);
4264 info
->type
= P_SYMBOL
;
4265 info
->u
.rsym
.state
= UNUSED
;
4267 mio_internal_string (info
->u
.rsym
.true_name
);
4268 mio_internal_string (info
->u
.rsym
.module
);
4269 mio_internal_string (info
->u
.rsym
.binding_label
);
4272 require_atom (ATOM_INTEGER
);
4273 info
->u
.rsym
.ns
= atom_int
;
4275 get_module_locus (&info
->u
.rsym
.where
);
4278 /* See if the symbol has already been loaded by a previous module.
4279 If so, we reference the existing symbol and prevent it from
4280 being loaded again. This should not happen if the symbol being
4281 read is an index for an assumed shape dummy array (ns != 1). */
4283 sym
= find_true_name (info
->u
.rsym
.true_name
, info
->u
.rsym
.module
);
4286 || (sym
->attr
.flavor
== FL_VARIABLE
&& info
->u
.rsym
.ns
!=1))
4289 info
->u
.rsym
.state
= USED
;
4290 info
->u
.rsym
.sym
= sym
;
4292 /* Some symbols do not have a namespace (eg. formal arguments),
4293 so the automatic "unique symtree" mechanism must be suppressed
4294 by marking them as referenced. */
4295 q
= get_integer (info
->u
.rsym
.ns
);
4296 if (q
->u
.pointer
== NULL
)
4298 info
->u
.rsym
.referenced
= 1;
4302 /* If possible recycle the symtree that references the symbol.
4303 If a symtree is not found and the module does not import one,
4304 a unique-name symtree is found by read_cleanup. */
4305 st
= find_symtree_for_symbol (gfc_current_ns
->sym_root
, sym
);
4308 info
->u
.rsym
.symtree
= st
;
4309 info
->u
.rsym
.referenced
= 1;
4315 /* Parse the symtree lists. This lets us mark which symbols need to
4316 be loaded. Renaming is also done at this point by replacing the
4321 while (peek_atom () != ATOM_RPAREN
)
4323 mio_internal_string (name
);
4324 mio_integer (&ambiguous
);
4325 mio_integer (&symbol
);
4327 info
= get_integer (symbol
);
4329 /* See how many use names there are. If none, go through the start
4330 of the loop at least once. */
4331 nuse
= number_use_names (name
, false);
4332 info
->u
.rsym
.renamed
= nuse
? 1 : 0;
4337 for (j
= 1; j
<= nuse
; j
++)
4339 /* Get the jth local name for this symbol. */
4340 p
= find_use_name_n (name
, &j
, false);
4342 if (p
== NULL
&& strcmp (name
, module_name
) == 0)
4345 /* Skip symtree nodes not in an ONLY clause, unless there
4346 is an existing symtree loaded from another USE statement. */
4349 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
4351 info
->u
.rsym
.symtree
= st
;
4355 /* If a symbol of the same name and module exists already,
4356 this symbol, which is not in an ONLY clause, must not be
4357 added to the namespace(11.3.2). Note that find_symbol
4358 only returns the first occurrence that it finds. */
4359 if (!only_flag
&& !info
->u
.rsym
.renamed
4360 && strcmp (name
, module_name
) != 0
4361 && find_symbol (gfc_current_ns
->sym_root
, name
,
4365 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
4369 /* Check for ambiguous symbols. */
4370 if (check_for_ambiguous (st
->n
.sym
, info
))
4372 info
->u
.rsym
.symtree
= st
;
4376 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
4378 /* Delete the symtree if the symbol has been added by a USE
4379 statement without an ONLY(11.3.2). Remember that the rsym
4380 will be the same as the symbol found in the symtree, for
4382 if (st
&& (only_flag
|| info
->u
.rsym
.renamed
)
4383 && !st
->n
.sym
->attr
.use_only
4384 && !st
->n
.sym
->attr
.use_rename
4385 && info
->u
.rsym
.sym
== st
->n
.sym
)
4386 gfc_delete_symtree (&gfc_current_ns
->sym_root
, name
);
4388 /* Create a symtree node in the current namespace for this
4390 st
= check_unique_name (p
)
4391 ? gfc_get_unique_symtree (gfc_current_ns
)
4392 : gfc_new_symtree (&gfc_current_ns
->sym_root
, p
);
4393 st
->ambiguous
= ambiguous
;
4395 sym
= info
->u
.rsym
.sym
;
4397 /* Create a symbol node if it doesn't already exist. */
4400 info
->u
.rsym
.sym
= gfc_new_symbol (info
->u
.rsym
.true_name
,
4402 sym
= info
->u
.rsym
.sym
;
4403 sym
->module
= gfc_get_string (info
->u
.rsym
.module
);
4405 /* TODO: hmm, can we test this? Do we know it will be
4406 initialized to zeros? */
4407 if (info
->u
.rsym
.binding_label
[0] != '\0')
4408 strcpy (sym
->binding_label
, info
->u
.rsym
.binding_label
);
4414 if (strcmp (name
, p
) != 0)
4415 sym
->attr
.use_rename
= 1;
4417 /* We need to set the only_flag here so that symbols from the
4418 same USE...ONLY but earlier are not deleted from the tree in
4419 the gfc_delete_symtree above. */
4420 sym
->attr
.use_only
= only_flag
;
4422 /* Store the symtree pointing to this symbol. */
4423 info
->u
.rsym
.symtree
= st
;
4425 if (info
->u
.rsym
.state
== UNUSED
)
4426 info
->u
.rsym
.state
= NEEDED
;
4427 info
->u
.rsym
.referenced
= 1;
4434 /* Load intrinsic operator interfaces. */
4435 set_module_locus (&operator_interfaces
);
4438 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
4440 if (i
== INTRINSIC_USER
)
4445 u
= find_use_operator ((gfc_intrinsic_op
) i
);
4456 mio_interface (&gfc_current_ns
->op
[i
]);
4461 /* Load generic and user operator interfaces. These must follow the
4462 loading of symtree because otherwise symbols can be marked as
4465 set_module_locus (&user_operators
);
4467 load_operator_interfaces ();
4468 load_generic_interfaces ();
4473 /* At this point, we read those symbols that are needed but haven't
4474 been loaded yet. If one symbol requires another, the other gets
4475 marked as NEEDED if its previous state was UNUSED. */
4477 while (load_needed (pi_root
));
4479 /* Make sure all elements of the rename-list were found in the module. */
4481 for (u
= gfc_rename_list
; u
; u
= u
->next
)
4486 if (u
->op
== INTRINSIC_NONE
)
4488 gfc_error ("Symbol '%s' referenced at %L not found in module '%s'",
4489 u
->use_name
, &u
->where
, module_name
);
4493 if (u
->op
== INTRINSIC_USER
)
4495 gfc_error ("User operator '%s' referenced at %L not found "
4496 "in module '%s'", u
->use_name
, &u
->where
, module_name
);
4500 gfc_error ("Intrinsic operator '%s' referenced at %L not found "
4501 "in module '%s'", gfc_op2string (u
->op
), &u
->where
,
4505 /* Now we should be in a position to fill f2k_derived with derived type
4506 extensions, since everything has been loaded. */
4507 set_module_locus (&extensions
);
4508 load_derived_extensions ();
4510 /* Clean up symbol nodes that were never loaded, create references
4511 to hidden symbols. */
4513 read_cleanup (pi_root
);
4517 /* Given an access type that is specific to an entity and the default
4518 access, return nonzero if the entity is publicly accessible. If the
4519 element is declared as PUBLIC, then it is public; if declared
4520 PRIVATE, then private, and otherwise it is public unless the default
4521 access in this context has been declared PRIVATE. */
4524 gfc_check_access (gfc_access specific_access
, gfc_access default_access
)
4526 if (specific_access
== ACCESS_PUBLIC
)
4528 if (specific_access
== ACCESS_PRIVATE
)
4531 if (gfc_option
.flag_module_private
)
4532 return default_access
== ACCESS_PUBLIC
;
4534 return default_access
!= ACCESS_PRIVATE
;
4538 /* A structure to remember which commons we've already written. */
4540 struct written_common
4542 BBT_HEADER(written_common
);
4543 const char *name
, *label
;
4546 static struct written_common
*written_commons
= NULL
;
4548 /* Comparison function used for balancing the binary tree. */
4551 compare_written_commons (void *a1
, void *b1
)
4553 const char *aname
= ((struct written_common
*) a1
)->name
;
4554 const char *alabel
= ((struct written_common
*) a1
)->label
;
4555 const char *bname
= ((struct written_common
*) b1
)->name
;
4556 const char *blabel
= ((struct written_common
*) b1
)->label
;
4557 int c
= strcmp (aname
, bname
);
4559 return (c
!= 0 ? c
: strcmp (alabel
, blabel
));
4562 /* Free a list of written commons. */
4565 free_written_common (struct written_common
*w
)
4571 free_written_common (w
->left
);
4573 free_written_common (w
->right
);
4578 /* Write a common block to the module -- recursive helper function. */
4581 write_common_0 (gfc_symtree
*st
, bool this_module
)
4587 struct written_common
*w
;
4588 bool write_me
= true;
4593 write_common_0 (st
->left
, this_module
);
4595 /* We will write out the binding label, or the name if no label given. */
4596 name
= st
->n
.common
->name
;
4598 label
= p
->is_bind_c
? p
->binding_label
: p
->name
;
4600 /* Check if we've already output this common. */
4601 w
= written_commons
;
4604 int c
= strcmp (name
, w
->name
);
4605 c
= (c
!= 0 ? c
: strcmp (label
, w
->label
));
4609 w
= (c
< 0) ? w
->left
: w
->right
;
4612 if (this_module
&& p
->use_assoc
)
4617 /* Write the common to the module. */
4619 mio_pool_string (&name
);
4621 mio_symbol_ref (&p
->head
);
4622 flags
= p
->saved
? 1 : 0;
4623 if (p
->threadprivate
)
4625 mio_integer (&flags
);
4627 /* Write out whether the common block is bind(c) or not. */
4628 mio_integer (&(p
->is_bind_c
));
4630 mio_pool_string (&label
);
4633 /* Record that we have written this common. */
4634 w
= XCNEW (struct written_common
);
4637 gfc_insert_bbt (&written_commons
, w
, compare_written_commons
);
4640 write_common_0 (st
->right
, this_module
);
4644 /* Write a common, by initializing the list of written commons, calling
4645 the recursive function write_common_0() and cleaning up afterwards. */
4648 write_common (gfc_symtree
*st
)
4650 written_commons
= NULL
;
4651 write_common_0 (st
, true);
4652 write_common_0 (st
, false);
4653 free_written_common (written_commons
);
4654 written_commons
= NULL
;
4658 /* Write the blank common block to the module. */
4661 write_blank_common (void)
4663 const char * name
= BLANK_COMMON_NAME
;
4665 /* TODO: Blank commons are not bind(c). The F2003 standard probably says
4666 this, but it hasn't been checked. Just making it so for now. */
4669 if (gfc_current_ns
->blank_common
.head
== NULL
)
4674 mio_pool_string (&name
);
4676 mio_symbol_ref (&gfc_current_ns
->blank_common
.head
);
4677 saved
= gfc_current_ns
->blank_common
.saved
;
4678 mio_integer (&saved
);
4680 /* Write out whether the common block is bind(c) or not. */
4681 mio_integer (&is_bind_c
);
4683 /* Write out the binding label, which is BLANK_COMMON_NAME, though
4684 it doesn't matter because the label isn't used. */
4685 mio_pool_string (&name
);
4691 /* Write equivalences to the module. */
4700 for (eq
= gfc_current_ns
->equiv
; eq
; eq
= eq
->next
)
4704 for (e
= eq
; e
; e
= e
->eq
)
4706 if (e
->module
== NULL
)
4707 e
->module
= gfc_get_string ("%s.eq.%d", module_name
, num
);
4708 mio_allocated_string (e
->module
);
4709 mio_expr (&e
->expr
);
4718 /* Write derived type extensions to the module. */
4721 write_dt_extensions (gfc_symtree
*st
)
4723 if (!gfc_check_access (st
->n
.sym
->attr
.access
,
4724 st
->n
.sym
->ns
->default_access
))
4728 mio_pool_string (&st
->n
.sym
->name
);
4729 if (st
->n
.sym
->module
!= NULL
)
4730 mio_pool_string (&st
->n
.sym
->module
);
4732 mio_internal_string (module_name
);
4737 write_derived_extensions (gfc_symtree
*st
)
4739 if (!((st
->n
.sym
->attr
.flavor
== FL_DERIVED
)
4740 && (st
->n
.sym
->f2k_derived
!= NULL
)
4741 && (st
->n
.sym
->f2k_derived
->sym_root
!= NULL
)))
4745 mio_symbol_ref (&(st
->n
.sym
));
4746 gfc_traverse_symtree (st
->n
.sym
->f2k_derived
->sym_root
,
4747 write_dt_extensions
);
4752 /* Write a symbol to the module. */
4755 write_symbol (int n
, gfc_symbol
*sym
)
4759 if (sym
->attr
.flavor
== FL_UNKNOWN
|| sym
->attr
.flavor
== FL_LABEL
)
4760 gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym
->name
);
4763 mio_pool_string (&sym
->name
);
4765 mio_pool_string (&sym
->module
);
4766 if (sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
)
4768 label
= sym
->binding_label
;
4769 mio_pool_string (&label
);
4772 mio_pool_string (&sym
->name
);
4774 mio_pointer_ref (&sym
->ns
);
4781 /* Recursive traversal function to write the initial set of symbols to
4782 the module. We check to see if the symbol should be written
4783 according to the access specification. */
4786 write_symbol0 (gfc_symtree
*st
)
4790 bool dont_write
= false;
4795 write_symbol0 (st
->left
);
4798 if (sym
->module
== NULL
)
4799 sym
->module
= gfc_get_string (module_name
);
4801 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
4802 && !sym
->attr
.subroutine
&& !sym
->attr
.function
)
4805 if (!gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
))
4810 p
= get_pointer (sym
);
4811 if (p
->type
== P_UNKNOWN
)
4814 if (p
->u
.wsym
.state
!= WRITTEN
)
4816 write_symbol (p
->integer
, sym
);
4817 p
->u
.wsym
.state
= WRITTEN
;
4821 write_symbol0 (st
->right
);
4825 /* Recursive traversal function to write the secondary set of symbols
4826 to the module file. These are symbols that were not public yet are
4827 needed by the public symbols or another dependent symbol. The act
4828 of writing a symbol can modify the pointer_info tree, so we cease
4829 traversal if we find a symbol to write. We return nonzero if a
4830 symbol was written and pass that information upwards. */
4833 write_symbol1 (pointer_info
*p
)
4840 result
= write_symbol1 (p
->left
);
4842 if (!(p
->type
!= P_SYMBOL
|| p
->u
.wsym
.state
!= NEEDS_WRITE
))
4844 p
->u
.wsym
.state
= WRITTEN
;
4845 write_symbol (p
->integer
, p
->u
.wsym
.sym
);
4849 result
|= write_symbol1 (p
->right
);
4854 /* Write operator interfaces associated with a symbol. */
4857 write_operator (gfc_user_op
*uop
)
4859 static char nullstring
[] = "";
4860 const char *p
= nullstring
;
4863 || !gfc_check_access (uop
->access
, uop
->ns
->default_access
))
4866 mio_symbol_interface (&uop
->name
, &p
, &uop
->op
);
4870 /* Write generic interfaces from the namespace sym_root. */
4873 write_generic (gfc_symtree
*st
)
4880 write_generic (st
->left
);
4881 write_generic (st
->right
);
4884 if (!sym
|| check_unique_name (st
->name
))
4887 if (sym
->generic
== NULL
4888 || !gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
))
4891 if (sym
->module
== NULL
)
4892 sym
->module
= gfc_get_string (module_name
);
4894 mio_symbol_interface (&st
->name
, &sym
->module
, &sym
->generic
);
4899 write_symtree (gfc_symtree
*st
)
4906 /* A symbol in an interface body must not be visible in the
4908 if (sym
->ns
!= gfc_current_ns
4909 && sym
->ns
->proc_name
4910 && sym
->ns
->proc_name
->attr
.if_source
== IFSRC_IFBODY
)
4913 if (!gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
)
4914 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
4915 && !sym
->attr
.subroutine
&& !sym
->attr
.function
))
4918 if (check_unique_name (st
->name
))
4921 p
= find_pointer (sym
);
4923 gfc_internal_error ("write_symtree(): Symbol not written");
4925 mio_pool_string (&st
->name
);
4926 mio_integer (&st
->ambiguous
);
4927 mio_integer (&p
->integer
);
4936 /* Write the operator interfaces. */
4939 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
4941 if (i
== INTRINSIC_USER
)
4944 mio_interface (gfc_check_access (gfc_current_ns
->operator_access
[i
],
4945 gfc_current_ns
->default_access
)
4946 ? &gfc_current_ns
->op
[i
] : NULL
);
4954 gfc_traverse_user_op (gfc_current_ns
, write_operator
);
4960 write_generic (gfc_current_ns
->sym_root
);
4966 write_blank_common ();
4967 write_common (gfc_current_ns
->common_root
);
4979 gfc_traverse_symtree (gfc_current_ns
->sym_root
,
4980 write_derived_extensions
);
4985 /* Write symbol information. First we traverse all symbols in the
4986 primary namespace, writing those that need to be written.
4987 Sometimes writing one symbol will cause another to need to be
4988 written. A list of these symbols ends up on the write stack, and
4989 we end by popping the bottom of the stack and writing the symbol
4990 until the stack is empty. */
4994 write_symbol0 (gfc_current_ns
->sym_root
);
4995 while (write_symbol1 (pi_root
))
5004 gfc_traverse_symtree (gfc_current_ns
->sym_root
, write_symtree
);
5009 /* Read a MD5 sum from the header of a module file. If the file cannot
5010 be opened, or we have any other error, we return -1. */
5013 read_md5_from_module_file (const char * filename
, unsigned char md5
[16])
5019 /* Open the file. */
5020 if ((file
= fopen (filename
, "r")) == NULL
)
5023 /* Read the first line. */
5024 if (fgets (buf
, sizeof (buf
) - 1, file
) == NULL
)
5030 /* The file also needs to be overwritten if the version number changed. */
5031 n
= strlen ("GFORTRAN module version '" MOD_VERSION
"' created");
5032 if (strncmp (buf
, "GFORTRAN module version '" MOD_VERSION
"' created", n
) != 0)
5038 /* Read a second line. */
5039 if (fgets (buf
, sizeof (buf
) - 1, file
) == NULL
)
5045 /* Close the file. */
5048 /* If the header is not what we expect, or is too short, bail out. */
5049 if (strncmp (buf
, "MD5:", 4) != 0 || strlen (buf
) < 4 + 16)
5052 /* Now, we have a real MD5, read it into the array. */
5053 for (n
= 0; n
< 16; n
++)
5057 if (sscanf (&(buf
[4+2*n
]), "%02x", &x
) != 1)
5067 /* Given module, dump it to disk. If there was an error while
5068 processing the module, dump_flag will be set to zero and we delete
5069 the module file, even if it was already there. */
5072 gfc_dump_module (const char *name
, int dump_flag
)
5075 char *filename
, *filename_tmp
, *p
;
5078 unsigned char md5_new
[16], md5_old
[16];
5080 n
= strlen (name
) + strlen (MODULE_EXTENSION
) + 1;
5081 if (gfc_option
.module_dir
!= NULL
)
5083 n
+= strlen (gfc_option
.module_dir
);
5084 filename
= (char *) alloca (n
);
5085 strcpy (filename
, gfc_option
.module_dir
);
5086 strcat (filename
, name
);
5090 filename
= (char *) alloca (n
);
5091 strcpy (filename
, name
);
5093 strcat (filename
, MODULE_EXTENSION
);
5095 /* Name of the temporary file used to write the module. */
5096 filename_tmp
= (char *) alloca (n
+ 1);
5097 strcpy (filename_tmp
, filename
);
5098 strcat (filename_tmp
, "0");
5100 /* There was an error while processing the module. We delete the
5101 module file, even if it was already there. */
5108 /* Write the module to the temporary file. */
5109 module_fp
= fopen (filename_tmp
, "w");
5110 if (module_fp
== NULL
)
5111 gfc_fatal_error ("Can't open module file '%s' for writing at %C: %s",
5112 filename_tmp
, strerror (errno
));
5114 /* Write the header, including space reserved for the MD5 sum. */
5118 *strchr (p
, '\n') = '\0';
5120 fprintf (module_fp
, "GFORTRAN module version '%s' created from %s on %s\n"
5121 "MD5:", MOD_VERSION
, gfc_source_file
, p
);
5122 fgetpos (module_fp
, &md5_pos
);
5123 fputs ("00000000000000000000000000000000 -- "
5124 "If you edit this, you'll get what you deserve.\n\n", module_fp
);
5126 /* Initialize the MD5 context that will be used for output. */
5127 md5_init_ctx (&ctx
);
5129 /* Write the module itself. */
5131 strcpy (module_name
, name
);
5137 free_pi_tree (pi_root
);
5142 /* Write the MD5 sum to the header of the module file. */
5143 md5_finish_ctx (&ctx
, md5_new
);
5144 fsetpos (module_fp
, &md5_pos
);
5145 for (n
= 0; n
< 16; n
++)
5146 fprintf (module_fp
, "%02x", md5_new
[n
]);
5148 if (fclose (module_fp
))
5149 gfc_fatal_error ("Error writing module file '%s' for writing: %s",
5150 filename_tmp
, strerror (errno
));
5152 /* Read the MD5 from the header of the old module file and compare. */
5153 if (read_md5_from_module_file (filename
, md5_old
) != 0
5154 || memcmp (md5_old
, md5_new
, sizeof (md5_old
)) != 0)
5156 /* Module file have changed, replace the old one. */
5157 if (unlink (filename
) && errno
!= ENOENT
)
5158 gfc_fatal_error ("Can't delete module file '%s': %s", filename
,
5160 if (rename (filename_tmp
, filename
))
5161 gfc_fatal_error ("Can't rename module file '%s' to '%s': %s",
5162 filename_tmp
, filename
, strerror (errno
));
5166 if (unlink (filename_tmp
))
5167 gfc_fatal_error ("Can't delete temporary module file '%s': %s",
5168 filename_tmp
, strerror (errno
));
5174 sort_iso_c_rename_list (void)
5176 gfc_use_rename
*tmp_list
= NULL
;
5177 gfc_use_rename
*curr
;
5178 gfc_use_rename
*kinds_used
[ISOCBINDING_NUMBER
] = {NULL
};
5182 for (curr
= gfc_rename_list
; curr
; curr
= curr
->next
)
5184 c_kind
= get_c_kind (curr
->use_name
, c_interop_kinds_table
);
5185 if (c_kind
== ISOCBINDING_INVALID
|| c_kind
== ISOCBINDING_LAST
)
5187 gfc_error ("Symbol '%s' referenced at %L does not exist in "
5188 "intrinsic module ISO_C_BINDING.", curr
->use_name
,
5192 /* Put it in the list. */
5193 kinds_used
[c_kind
] = curr
;
5196 /* Make a new (sorted) rename list. */
5198 while (i
< ISOCBINDING_NUMBER
&& kinds_used
[i
] == NULL
)
5201 if (i
< ISOCBINDING_NUMBER
)
5203 tmp_list
= kinds_used
[i
];
5207 for (; i
< ISOCBINDING_NUMBER
; i
++)
5208 if (kinds_used
[i
] != NULL
)
5210 curr
->next
= kinds_used
[i
];
5216 gfc_rename_list
= tmp_list
;
5220 /* Import the intrinsic ISO_C_BINDING module, generating symbols in
5221 the current namespace for all named constants, pointer types, and
5222 procedures in the module unless the only clause was used or a rename
5223 list was provided. */
5226 import_iso_c_binding_module (void)
5228 gfc_symbol
*mod_sym
= NULL
;
5229 gfc_symtree
*mod_symtree
= NULL
;
5230 const char *iso_c_module_name
= "__iso_c_binding";
5235 /* Look only in the current namespace. */
5236 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, iso_c_module_name
);
5238 if (mod_symtree
== NULL
)
5240 /* symtree doesn't already exist in current namespace. */
5241 gfc_get_sym_tree (iso_c_module_name
, gfc_current_ns
, &mod_symtree
,
5244 if (mod_symtree
!= NULL
)
5245 mod_sym
= mod_symtree
->n
.sym
;
5247 gfc_internal_error ("import_iso_c_binding_module(): Unable to "
5248 "create symbol for %s", iso_c_module_name
);
5250 mod_sym
->attr
.flavor
= FL_MODULE
;
5251 mod_sym
->attr
.intrinsic
= 1;
5252 mod_sym
->module
= gfc_get_string (iso_c_module_name
);
5253 mod_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
5256 /* Generate the symbols for the named constants representing
5257 the kinds for intrinsic data types. */
5260 /* Sort the rename list because there are dependencies between types
5261 and procedures (e.g., c_loc needs c_ptr). */
5262 sort_iso_c_rename_list ();
5264 for (u
= gfc_rename_list
; u
; u
= u
->next
)
5266 i
= get_c_kind (u
->use_name
, c_interop_kinds_table
);
5268 if (i
== ISOCBINDING_INVALID
|| i
== ISOCBINDING_LAST
)
5270 gfc_error ("Symbol '%s' referenced at %L does not exist in "
5271 "intrinsic module ISO_C_BINDING.", u
->use_name
,
5276 generate_isocbinding_symbol (iso_c_module_name
,
5277 (iso_c_binding_symbol
) i
,
5283 for (i
= 0; i
< ISOCBINDING_NUMBER
; i
++)
5286 for (u
= gfc_rename_list
; u
; u
= u
->next
)
5288 if (strcmp (c_interop_kinds_table
[i
].name
, u
->use_name
) == 0)
5290 local_name
= u
->local_name
;
5295 generate_isocbinding_symbol (iso_c_module_name
,
5296 (iso_c_binding_symbol
) i
,
5300 for (u
= gfc_rename_list
; u
; u
= u
->next
)
5305 gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
5306 "module ISO_C_BINDING", u
->use_name
, &u
->where
);
5312 /* Add an integer named constant from a given module. */
5315 create_int_parameter (const char *name
, int value
, const char *modname
,
5316 intmod_id module
, int id
)
5318 gfc_symtree
*tmp_symtree
;
5321 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
5322 if (tmp_symtree
!= NULL
)
5324 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
5327 gfc_error ("Symbol '%s' already declared", name
);
5330 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
, false);
5331 sym
= tmp_symtree
->n
.sym
;
5333 sym
->module
= gfc_get_string (modname
);
5334 sym
->attr
.flavor
= FL_PARAMETER
;
5335 sym
->ts
.type
= BT_INTEGER
;
5336 sym
->ts
.kind
= gfc_default_integer_kind
;
5337 sym
->value
= gfc_get_int_expr (gfc_default_integer_kind
, NULL
, value
);
5338 sym
->attr
.use_assoc
= 1;
5339 sym
->from_intmod
= module
;
5340 sym
->intmod_sym_id
= id
;
5344 /* USE the ISO_FORTRAN_ENV intrinsic module. */
5347 use_iso_fortran_env_module (void)
5349 static char mod
[] = "iso_fortran_env";
5350 const char *local_name
;
5352 gfc_symbol
*mod_sym
;
5353 gfc_symtree
*mod_symtree
;
5356 intmod_sym symbol
[] = {
5357 #define NAMED_INTCST(a,b,c,d) { a, b, 0, d },
5358 #include "iso-fortran-env.def"
5360 { ISOFORTRANENV_INVALID
, NULL
, -1234, 0 } };
5363 #define NAMED_INTCST(a,b,c,d) symbol[i++].value = c;
5364 #include "iso-fortran-env.def"
5367 /* Generate the symbol for the module itself. */
5368 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, mod
);
5369 if (mod_symtree
== NULL
)
5371 gfc_get_sym_tree (mod
, gfc_current_ns
, &mod_symtree
, false);
5372 gcc_assert (mod_symtree
);
5373 mod_sym
= mod_symtree
->n
.sym
;
5375 mod_sym
->attr
.flavor
= FL_MODULE
;
5376 mod_sym
->attr
.intrinsic
= 1;
5377 mod_sym
->module
= gfc_get_string (mod
);
5378 mod_sym
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
5381 if (!mod_symtree
->n
.sym
->attr
.intrinsic
)
5382 gfc_error ("Use of intrinsic module '%s' at %C conflicts with "
5383 "non-intrinsic module name used previously", mod
);
5385 /* Generate the symbols for the module integer named constants. */
5387 for (u
= gfc_rename_list
; u
; u
= u
->next
)
5389 for (i
= 0; symbol
[i
].name
; i
++)
5390 if (strcmp (symbol
[i
].name
, u
->use_name
) == 0)
5393 if (symbol
[i
].name
== NULL
)
5395 gfc_error ("Symbol '%s' referenced at %L does not exist in "
5396 "intrinsic module ISO_FORTRAN_ENV", u
->use_name
,
5401 if ((gfc_option
.flag_default_integer
|| gfc_option
.flag_default_real
)
5402 && symbol
[i
].id
== ISOFORTRANENV_NUMERIC_STORAGE_SIZE
)
5403 gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
5404 "from intrinsic module ISO_FORTRAN_ENV at %L is "
5405 "incompatible with option %s", &u
->where
,
5406 gfc_option
.flag_default_integer
5407 ? "-fdefault-integer-8" : "-fdefault-real-8");
5409 if (gfc_notify_std (symbol
[i
].standard
, "The symbol '%s', referrenced "
5410 "at %C, is not in the selected standard",
5411 symbol
[i
].name
) == FAILURE
)
5414 create_int_parameter (u
->local_name
[0] ? u
->local_name
5416 symbol
[i
].value
, mod
, INTMOD_ISO_FORTRAN_ENV
,
5421 for (i
= 0; symbol
[i
].name
; i
++)
5425 for (u
= gfc_rename_list
; u
; u
= u
->next
)
5427 if (strcmp (symbol
[i
].name
, u
->use_name
) == 0)
5429 local_name
= u
->local_name
;
5435 if (u
&& gfc_notify_std (symbol
[i
].standard
, "The symbol '%s', "
5436 "referrenced at %C, is not in the selected "
5437 "standard", symbol
[i
].name
) == FAILURE
)
5439 else if ((gfc_option
.allow_std
& symbol
[i
].standard
) == 0)
5442 if ((gfc_option
.flag_default_integer
|| gfc_option
.flag_default_real
)
5443 && symbol
[i
].id
== ISOFORTRANENV_NUMERIC_STORAGE_SIZE
)
5444 gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
5445 "from intrinsic module ISO_FORTRAN_ENV at %C is "
5446 "incompatible with option %s",
5447 gfc_option
.flag_default_integer
5448 ? "-fdefault-integer-8" : "-fdefault-real-8");
5450 create_int_parameter (local_name
? local_name
: symbol
[i
].name
,
5451 symbol
[i
].value
, mod
, INTMOD_ISO_FORTRAN_ENV
,
5455 for (u
= gfc_rename_list
; u
; u
= u
->next
)
5460 gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
5461 "module ISO_FORTRAN_ENV", u
->use_name
, &u
->where
);
5467 /* Process a USE directive. */
5470 gfc_use_module (void)
5475 gfc_symtree
*mod_symtree
;
5476 gfc_use_list
*use_stmt
;
5478 filename
= (char *) alloca (strlen (module_name
) + strlen (MODULE_EXTENSION
)
5480 strcpy (filename
, module_name
);
5481 strcat (filename
, MODULE_EXTENSION
);
5483 /* First, try to find an non-intrinsic module, unless the USE statement
5484 specified that the module is intrinsic. */
5487 module_fp
= gfc_open_included_file (filename
, true, true);
5489 /* Then, see if it's an intrinsic one, unless the USE statement
5490 specified that the module is non-intrinsic. */
5491 if (module_fp
== NULL
&& !specified_nonint
)
5493 if (strcmp (module_name
, "iso_fortran_env") == 0
5494 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: ISO_FORTRAN_ENV "
5495 "intrinsic module at %C") != FAILURE
)
5497 use_iso_fortran_env_module ();
5501 if (strcmp (module_name
, "iso_c_binding") == 0
5502 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: "
5503 "ISO_C_BINDING module at %C") != FAILURE
)
5505 import_iso_c_binding_module();
5509 module_fp
= gfc_open_intrinsic_module (filename
);
5511 if (module_fp
== NULL
&& specified_int
)
5512 gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C",
5516 if (module_fp
== NULL
)
5517 gfc_fatal_error ("Can't open module file '%s' for reading at %C: %s",
5518 filename
, strerror (errno
));
5520 /* Check that we haven't already USEd an intrinsic module with the
5523 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, module_name
);
5524 if (mod_symtree
&& mod_symtree
->n
.sym
->attr
.intrinsic
)
5525 gfc_error ("Use of non-intrinsic module '%s' at %C conflicts with "
5526 "intrinsic module name used previously", module_name
);
5533 /* Skip the first two lines of the module, after checking that this is
5534 a gfortran module file. */
5540 bad_module ("Unexpected end of module");
5543 if ((start
== 1 && strcmp (atom_name
, "GFORTRAN") != 0)
5544 || (start
== 2 && strcmp (atom_name
, " module") != 0))
5545 gfc_fatal_error ("File '%s' opened at %C is not a GFORTRAN module "
5549 if (strcmp (atom_name
, " version") != 0
5550 || module_char () != ' '
5551 || parse_atom () != ATOM_STRING
)
5552 gfc_fatal_error ("Parse error when checking module version"
5553 " for file '%s' opened at %C", filename
);
5555 if (strcmp (atom_string
, MOD_VERSION
))
5557 gfc_fatal_error ("Wrong module version '%s' (expected '%s') "
5558 "for file '%s' opened at %C", atom_string
,
5559 MOD_VERSION
, filename
);
5567 /* Make sure we're not reading the same module that we may be building. */
5568 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
5569 if (p
->state
== COMP_MODULE
&& strcmp (p
->sym
->name
, module_name
) == 0)
5570 gfc_fatal_error ("Can't USE the same module we're building!");
5573 init_true_name_tree ();
5577 free_true_name (true_name_root
);
5578 true_name_root
= NULL
;
5580 free_pi_tree (pi_root
);
5585 use_stmt
= gfc_get_use_list ();
5586 use_stmt
->module_name
= gfc_get_string (module_name
);
5587 use_stmt
->only_flag
= only_flag
;
5588 use_stmt
->rename
= gfc_rename_list
;
5589 use_stmt
->where
= use_locus
;
5590 gfc_rename_list
= NULL
;
5591 use_stmt
->next
= gfc_current_ns
->use_stmts
;
5592 gfc_current_ns
->use_stmts
= use_stmt
;
5597 gfc_free_use_stmts (gfc_use_list
*use_stmts
)
5600 for (; use_stmts
; use_stmts
= next
)
5602 gfc_use_rename
*next_rename
;
5604 for (; use_stmts
->rename
; use_stmts
->rename
= next_rename
)
5606 next_rename
= use_stmts
->rename
->next
;
5607 gfc_free (use_stmts
->rename
);
5609 next
= use_stmts
->next
;
5610 gfc_free (use_stmts
);
5616 gfc_module_init_2 (void)
5618 last_atom
= ATOM_LPAREN
;
5623 gfc_module_done_2 (void)