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
4 Free Software Foundation, Inc.
5 Contributed by Andy Vaught
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* The syntax of gfortran modules resembles that of lisp lists, i.e. a
24 sequence of atoms, which can be left or right parenthesis, names,
25 integers or strings. Parenthesis are always matched which allows
26 us to skip over sections at high speed without having to know
27 anything about the internal structure of the lists. A "name" is
28 usually a fortran 95 identifier, but can also start with '@' in
29 order to reference a hidden symbol.
31 The first line of a module is an informational message about what
32 created the module, the file it came from and when it was created.
33 The second line is a warning for people not to edit the module.
34 The rest of the module looks like:
36 ( ( <Interface info for UPLUS> )
37 ( <Interface info for UMINUS> )
40 ( ( <name of operator interface> <module of op interface> <i/f1> ... )
43 ( ( <name of generic interface> <module of generic interface> <i/f1> ... )
46 ( ( <common name> <symbol> <saved flag>)
52 ( <Symbol Number (in no particular order)>
54 <Module name of symbol>
55 ( <symbol information> )
64 In general, symbols refer to other symbols by their symbol number,
65 which are zero based. Symbols are written to the module in no
73 #include "parse.h" /* FIXME */
76 #define MODULE_EXTENSION ".mod"
79 /* Structure that describes a position within a module file. */
88 /* Structure for list of symbols of intrinsic modules. */
101 P_UNKNOWN
= 0, P_OTHER
, P_NAMESPACE
, P_COMPONENT
, P_SYMBOL
105 /* The fixup structure lists pointers to pointers that have to
106 be updated when a pointer value becomes known. */
108 typedef struct fixup_t
111 struct fixup_t
*next
;
116 /* Structure for holding extra info needed for pointers being read. */
118 typedef struct pointer_info
120 BBT_HEADER (pointer_info
);
124 /* The first component of each member of the union is the pointer
131 void *pointer
; /* Member for doing pointer searches. */
136 char true_name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[GFC_MAX_SYMBOL_LEN
+ 1];
138 { UNUSED
, NEEDED
, USED
}
140 int ns
, referenced
, renamed
;
143 gfc_symtree
*symtree
;
144 char binding_label
[GFC_MAX_SYMBOL_LEN
+ 1];
152 { UNREFERENCED
= 0, NEEDS_WRITE
, WRITTEN
}
162 #define gfc_get_pointer_info() XCNEW (pointer_info)
165 /* Local variables */
167 /* The FILE for the module we're reading or writing. */
168 static FILE *module_fp
;
170 /* MD5 context structure. */
171 static struct md5_ctx ctx
;
173 /* The name of the module we're reading (USE'ing) or writing. */
174 static char module_name
[GFC_MAX_SYMBOL_LEN
+ 1];
176 /* The way the module we're reading was specified. */
177 static bool specified_nonint
, specified_int
;
179 static int module_line
, module_column
, only_flag
;
181 { IO_INPUT
, IO_OUTPUT
}
184 static gfc_use_rename
*gfc_rename_list
;
185 static pointer_info
*pi_root
;
186 static int symbol_number
; /* Counter for assigning symbol numbers */
188 /* Tells mio_expr_ref to make symbols for unused equivalence members. */
189 static bool in_load_equiv
;
193 /*****************************************************************/
195 /* Pointer/integer conversion. Pointers between structures are stored
196 as integers in the module file. The next couple of subroutines
197 handle this translation for reading and writing. */
199 /* Recursively free the tree of pointer structures. */
202 free_pi_tree (pointer_info
*p
)
207 if (p
->fixup
!= NULL
)
208 gfc_internal_error ("free_pi_tree(): Unresolved fixup");
210 free_pi_tree (p
->left
);
211 free_pi_tree (p
->right
);
217 /* Compare pointers when searching by pointer. Used when writing a
221 compare_pointers (void *_sn1
, void *_sn2
)
223 pointer_info
*sn1
, *sn2
;
225 sn1
= (pointer_info
*) _sn1
;
226 sn2
= (pointer_info
*) _sn2
;
228 if (sn1
->u
.pointer
< sn2
->u
.pointer
)
230 if (sn1
->u
.pointer
> sn2
->u
.pointer
)
237 /* Compare integers when searching by integer. Used when reading a
241 compare_integers (void *_sn1
, void *_sn2
)
243 pointer_info
*sn1
, *sn2
;
245 sn1
= (pointer_info
*) _sn1
;
246 sn2
= (pointer_info
*) _sn2
;
248 if (sn1
->integer
< sn2
->integer
)
250 if (sn1
->integer
> sn2
->integer
)
257 /* Initialize the pointer_info tree. */
266 compare
= (iomode
== IO_INPUT
) ? compare_integers
: compare_pointers
;
268 /* Pointer 0 is the NULL pointer. */
269 p
= gfc_get_pointer_info ();
274 gfc_insert_bbt (&pi_root
, p
, compare
);
276 /* Pointer 1 is the current namespace. */
277 p
= gfc_get_pointer_info ();
278 p
->u
.pointer
= gfc_current_ns
;
280 p
->type
= P_NAMESPACE
;
282 gfc_insert_bbt (&pi_root
, p
, compare
);
288 /* During module writing, call here with a pointer to something,
289 returning the pointer_info node. */
291 static pointer_info
*
292 find_pointer (void *gp
)
299 if (p
->u
.pointer
== gp
)
301 p
= (gp
< p
->u
.pointer
) ? p
->left
: p
->right
;
308 /* Given a pointer while writing, returns the pointer_info tree node,
309 creating it if it doesn't exist. */
311 static pointer_info
*
312 get_pointer (void *gp
)
316 p
= find_pointer (gp
);
320 /* Pointer doesn't have an integer. Give it one. */
321 p
= gfc_get_pointer_info ();
324 p
->integer
= symbol_number
++;
326 gfc_insert_bbt (&pi_root
, p
, compare_pointers
);
332 /* Given an integer during reading, find it in the pointer_info tree,
333 creating the node if not found. */
335 static pointer_info
*
336 get_integer (int integer
)
346 c
= compare_integers (&t
, p
);
350 p
= (c
< 0) ? p
->left
: p
->right
;
356 p
= gfc_get_pointer_info ();
357 p
->integer
= integer
;
360 gfc_insert_bbt (&pi_root
, p
, compare_integers
);
366 /* Recursive function to find a pointer within a tree by brute force. */
368 static pointer_info
*
369 fp2 (pointer_info
*p
, const void *target
)
376 if (p
->u
.pointer
== target
)
379 q
= fp2 (p
->left
, target
);
383 return fp2 (p
->right
, target
);
387 /* During reading, find a pointer_info node from the pointer value.
388 This amounts to a brute-force search. */
390 static pointer_info
*
391 find_pointer2 (void *p
)
393 return fp2 (pi_root
, p
);
397 /* Resolve any fixups using a known pointer. */
400 resolve_fixups (fixup_t
*f
, void *gp
)
413 /* Call here during module reading when we know what pointer to
414 associate with an integer. Any fixups that exist are resolved at
418 associate_integer_pointer (pointer_info
*p
, void *gp
)
420 if (p
->u
.pointer
!= NULL
)
421 gfc_internal_error ("associate_integer_pointer(): Already associated");
425 resolve_fixups (p
->fixup
, gp
);
431 /* During module reading, given an integer and a pointer to a pointer,
432 either store the pointer from an already-known value or create a
433 fixup structure in order to store things later. Returns zero if
434 the reference has been actually stored, or nonzero if the reference
435 must be fixed later (i.e., associate_integer_pointer must be called
436 sometime later. Returns the pointer_info structure. */
438 static pointer_info
*
439 add_fixup (int integer
, void *gp
)
445 p
= get_integer (integer
);
447 if (p
->integer
== 0 || p
->u
.pointer
!= NULL
)
450 *cp
= (char *) p
->u
.pointer
;
459 f
->pointer
= (void **) gp
;
466 /*****************************************************************/
468 /* Parser related subroutines */
470 /* Free the rename list left behind by a USE statement. */
475 gfc_use_rename
*next
;
477 for (; gfc_rename_list
; gfc_rename_list
= next
)
479 next
= gfc_rename_list
->next
;
480 gfc_free (gfc_rename_list
);
485 /* Match a USE statement. */
490 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module_nature
[GFC_MAX_SYMBOL_LEN
+ 1];
491 gfc_use_rename
*tail
= NULL
, *new_use
;
492 interface_type type
, type2
;
496 specified_int
= false;
497 specified_nonint
= false;
499 if (gfc_match (" , ") == MATCH_YES
)
501 if ((m
= gfc_match (" %n ::", module_nature
)) == MATCH_YES
)
503 if (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: module "
504 "nature in USE statement at %C") == FAILURE
)
507 if (strcmp (module_nature
, "intrinsic") == 0)
508 specified_int
= true;
511 if (strcmp (module_nature
, "non_intrinsic") == 0)
512 specified_nonint
= true;
515 gfc_error ("Module nature in USE statement at %C shall "
516 "be either INTRINSIC or NON_INTRINSIC");
523 /* Help output a better error message than "Unclassifiable
525 gfc_match (" %n", module_nature
);
526 if (strcmp (module_nature
, "intrinsic") == 0
527 || strcmp (module_nature
, "non_intrinsic") == 0)
528 gfc_error ("\"::\" was expected after module nature at %C "
529 "but was not found");
535 m
= gfc_match (" ::");
536 if (m
== MATCH_YES
&&
537 gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: "
538 "\"USE :: module\" at %C") == FAILURE
)
543 m
= gfc_match ("% ");
549 m
= gfc_match_name (module_name
);
556 if (gfc_match_eos () == MATCH_YES
)
558 if (gfc_match_char (',') != MATCH_YES
)
561 if (gfc_match (" only :") == MATCH_YES
)
564 if (gfc_match_eos () == MATCH_YES
)
569 /* Get a new rename struct and add it to the rename list. */
570 new_use
= gfc_get_use_rename ();
571 new_use
->where
= gfc_current_locus
;
574 if (gfc_rename_list
== NULL
)
575 gfc_rename_list
= new_use
;
577 tail
->next
= new_use
;
580 /* See what kind of interface we're dealing with. Assume it is
582 new_use
->op
= INTRINSIC_NONE
;
583 if (gfc_match_generic_spec (&type
, name
, &op
) == MATCH_ERROR
)
588 case INTERFACE_NAMELESS
:
589 gfc_error ("Missing generic specification in USE statement at %C");
592 case INTERFACE_USER_OP
:
593 case INTERFACE_GENERIC
:
594 m
= gfc_match (" =>");
596 if (type
== INTERFACE_USER_OP
&& m
== MATCH_YES
597 && (gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: Renaming "
598 "operators in USE statements at %C")
602 if (type
== INTERFACE_USER_OP
)
603 new_use
->op
= INTRINSIC_USER
;
608 strcpy (new_use
->use_name
, name
);
611 strcpy (new_use
->local_name
, name
);
612 m
= gfc_match_generic_spec (&type2
, new_use
->use_name
, &op
);
617 if (m
== MATCH_ERROR
)
625 strcpy (new_use
->local_name
, name
);
627 m
= gfc_match_generic_spec (&type2
, new_use
->use_name
, &op
);
632 if (m
== MATCH_ERROR
)
636 if (strcmp (new_use
->use_name
, module_name
) == 0
637 || strcmp (new_use
->local_name
, module_name
) == 0)
639 gfc_error ("The name '%s' at %C has already been used as "
640 "an external module name.", module_name
);
645 case INTERFACE_INTRINSIC_OP
:
653 if (gfc_match_eos () == MATCH_YES
)
655 if (gfc_match_char (',') != MATCH_YES
)
662 gfc_syntax_error (ST_USE
);
670 /* Given a name and a number, inst, return the inst name
671 under which to load this symbol. Returns NULL if this
672 symbol shouldn't be loaded. If inst is zero, returns
673 the number of instances of this name. If interface is
674 true, a user-defined operator is sought, otherwise only
675 non-operators are sought. */
678 find_use_name_n (const char *name
, int *inst
, bool interface
)
684 for (u
= gfc_rename_list
; u
; u
= u
->next
)
686 if (strcmp (u
->use_name
, name
) != 0
687 || (u
->op
== INTRINSIC_USER
&& !interface
)
688 || (u
->op
!= INTRINSIC_USER
&& interface
))
701 return only_flag
? NULL
: name
;
705 return (u
->local_name
[0] != '\0') ? u
->local_name
: name
;
709 /* Given a name, return the name under which to load this symbol.
710 Returns NULL if this symbol shouldn't be loaded. */
713 find_use_name (const char *name
, bool interface
)
716 return find_use_name_n (name
, &i
, interface
);
720 /* Given a real name, return the number of use names associated with it. */
723 number_use_names (const char *name
, bool interface
)
727 c
= find_use_name_n (name
, &i
, interface
);
732 /* Try to find the operator in the current list. */
734 static gfc_use_rename
*
735 find_use_operator (gfc_intrinsic_op op
)
739 for (u
= gfc_rename_list
; u
; u
= u
->next
)
747 /*****************************************************************/
749 /* The next couple of subroutines maintain a tree used to avoid a
750 brute-force search for a combination of true name and module name.
751 While symtree names, the name that a particular symbol is known by
752 can changed with USE statements, we still have to keep track of the
753 true names to generate the correct reference, and also avoid
754 loading the same real symbol twice in a program unit.
756 When we start reading, the true name tree is built and maintained
757 as symbols are read. The tree is searched as we load new symbols
758 to see if it already exists someplace in the namespace. */
760 typedef struct true_name
762 BBT_HEADER (true_name
);
767 static true_name
*true_name_root
;
770 /* Compare two true_name structures. */
773 compare_true_names (void *_t1
, void *_t2
)
778 t1
= (true_name
*) _t1
;
779 t2
= (true_name
*) _t2
;
781 c
= ((t1
->sym
->module
> t2
->sym
->module
)
782 - (t1
->sym
->module
< t2
->sym
->module
));
786 return strcmp (t1
->sym
->name
, t2
->sym
->name
);
790 /* Given a true name, search the true name tree to see if it exists
791 within the main namespace. */
794 find_true_name (const char *name
, const char *module
)
800 sym
.name
= gfc_get_string (name
);
802 sym
.module
= gfc_get_string (module
);
810 c
= compare_true_names ((void *) (&t
), (void *) p
);
814 p
= (c
< 0) ? p
->left
: p
->right
;
821 /* Given a gfc_symbol pointer that is not in the true name tree, add it. */
824 add_true_name (gfc_symbol
*sym
)
828 t
= XCNEW (true_name
);
831 gfc_insert_bbt (&true_name_root
, t
, compare_true_names
);
835 /* Recursive function to build the initial true name tree by
836 recursively traversing the current namespace. */
839 build_tnt (gfc_symtree
*st
)
844 build_tnt (st
->left
);
845 build_tnt (st
->right
);
847 if (find_true_name (st
->n
.sym
->name
, st
->n
.sym
->module
) != NULL
)
850 add_true_name (st
->n
.sym
);
854 /* Initialize the true name tree with the current namespace. */
857 init_true_name_tree (void)
859 true_name_root
= NULL
;
860 build_tnt (gfc_current_ns
->sym_root
);
864 /* Recursively free a true name tree node. */
867 free_true_name (true_name
*t
)
871 free_true_name (t
->left
);
872 free_true_name (t
->right
);
878 /*****************************************************************/
880 /* Module reading and writing. */
884 ATOM_NAME
, ATOM_LPAREN
, ATOM_RPAREN
, ATOM_INTEGER
, ATOM_STRING
888 static atom_type last_atom
;
891 /* The name buffer must be at least as long as a symbol name. Right
892 now it's not clear how we're going to store numeric constants--
893 probably as a hexadecimal string, since this will allow the exact
894 number to be preserved (this can't be done by a decimal
895 representation). Worry about that later. TODO! */
897 #define MAX_ATOM_SIZE 100
900 static char *atom_string
, atom_name
[MAX_ATOM_SIZE
];
903 /* Report problems with a module. Error reporting is not very
904 elaborate, since this sorts of errors shouldn't really happen.
905 This subroutine never returns. */
907 static void bad_module (const char *) ATTRIBUTE_NORETURN
;
910 bad_module (const char *msgid
)
917 gfc_fatal_error ("Reading module %s at line %d column %d: %s",
918 module_name
, module_line
, module_column
, msgid
);
921 gfc_fatal_error ("Writing module %s at line %d column %d: %s",
922 module_name
, module_line
, module_column
, msgid
);
925 gfc_fatal_error ("Module %s at line %d column %d: %s",
926 module_name
, module_line
, module_column
, msgid
);
932 /* Set the module's input pointer. */
935 set_module_locus (module_locus
*m
)
937 module_column
= m
->column
;
938 module_line
= m
->line
;
939 fsetpos (module_fp
, &m
->pos
);
943 /* Get the module's input pointer so that we can restore it later. */
946 get_module_locus (module_locus
*m
)
948 m
->column
= module_column
;
949 m
->line
= module_line
;
950 fgetpos (module_fp
, &m
->pos
);
954 /* Get the next character in the module, updating our reckoning of
962 c
= getc (module_fp
);
965 bad_module ("Unexpected EOF");
978 /* Parse a string constant. The delimiter is guaranteed to be a
988 get_module_locus (&start
);
992 /* See how long the string is. */
997 bad_module ("Unexpected end of module in string constant");
1015 set_module_locus (&start
);
1017 atom_string
= p
= XCNEWVEC (char, len
+ 1);
1019 for (; len
> 0; len
--)
1023 module_char (); /* Guaranteed to be another \'. */
1027 module_char (); /* Terminating \'. */
1028 *p
= '\0'; /* C-style string for debug purposes. */
1032 /* Parse a small integer. */
1035 parse_integer (int c
)
1043 get_module_locus (&m
);
1049 atom_int
= 10 * atom_int
+ c
- '0';
1050 if (atom_int
> 99999999)
1051 bad_module ("Integer overflow");
1054 set_module_locus (&m
);
1072 get_module_locus (&m
);
1077 if (!ISALNUM (c
) && c
!= '_' && c
!= '-')
1081 if (++len
> GFC_MAX_SYMBOL_LEN
)
1082 bad_module ("Name too long");
1087 fseek (module_fp
, -1, SEEK_CUR
);
1088 module_column
= m
.column
+ len
- 1;
1095 /* Read the next atom in the module's input stream. */
1106 while (c
== ' ' || c
== '\r' || c
== '\n');
1131 return ATOM_INTEGER
;
1189 bad_module ("Bad name");
1196 /* Peek at the next atom on the input. */
1204 get_module_locus (&m
);
1207 if (a
== ATOM_STRING
)
1208 gfc_free (atom_string
);
1210 set_module_locus (&m
);
1215 /* Read the next atom from the input, requiring that it be a
1219 require_atom (atom_type type
)
1225 get_module_locus (&m
);
1233 p
= _("Expected name");
1236 p
= _("Expected left parenthesis");
1239 p
= _("Expected right parenthesis");
1242 p
= _("Expected integer");
1245 p
= _("Expected string");
1248 gfc_internal_error ("require_atom(): bad atom type required");
1251 set_module_locus (&m
);
1257 /* Given a pointer to an mstring array, require that the current input
1258 be one of the strings in the array. We return the enum value. */
1261 find_enum (const mstring
*m
)
1265 i
= gfc_string2code (m
, atom_name
);
1269 bad_module ("find_enum(): Enum not found");
1275 /**************** Module output subroutines ***************************/
1277 /* Output a character to a module file. */
1280 write_char (char out
)
1282 if (putc (out
, module_fp
) == EOF
)
1283 gfc_fatal_error ("Error writing modules file: %s", strerror (errno
));
1285 /* Add this to our MD5. */
1286 md5_process_bytes (&out
, sizeof (out
), &ctx
);
1298 /* Write an atom to a module. The line wrapping isn't perfect, but it
1299 should work most of the time. This isn't that big of a deal, since
1300 the file really isn't meant to be read by people anyway. */
1303 write_atom (atom_type atom
, const void *v
)
1313 p
= (const char *) v
;
1325 i
= *((const int *) v
);
1327 gfc_internal_error ("write_atom(): Writing negative integer");
1329 sprintf (buffer
, "%d", i
);
1334 gfc_internal_error ("write_atom(): Trying to write dab atom");
1338 if(p
== NULL
|| *p
== '\0')
1343 if (atom
!= ATOM_RPAREN
)
1345 if (module_column
+ len
> 72)
1350 if (last_atom
!= ATOM_LPAREN
&& module_column
!= 1)
1355 if (atom
== ATOM_STRING
)
1358 while (p
!= NULL
&& *p
)
1360 if (atom
== ATOM_STRING
&& *p
== '\'')
1365 if (atom
== ATOM_STRING
)
1373 /***************** Mid-level I/O subroutines *****************/
1375 /* These subroutines let their caller read or write atoms without
1376 caring about which of the two is actually happening. This lets a
1377 subroutine concentrate on the actual format of the data being
1380 static void mio_expr (gfc_expr
**);
1381 pointer_info
*mio_symbol_ref (gfc_symbol
**);
1382 pointer_info
*mio_interface_rest (gfc_interface
**);
1383 static void mio_symtree_ref (gfc_symtree
**);
1385 /* Read or write an enumerated value. On writing, we return the input
1386 value for the convenience of callers. We avoid using an integer
1387 pointer because enums are sometimes inside bitfields. */
1390 mio_name (int t
, const mstring
*m
)
1392 if (iomode
== IO_OUTPUT
)
1393 write_atom (ATOM_NAME
, gfc_code2string (m
, t
));
1396 require_atom (ATOM_NAME
);
1403 /* Specialization of mio_name. */
1405 #define DECL_MIO_NAME(TYPE) \
1406 static inline TYPE \
1407 MIO_NAME(TYPE) (TYPE t, const mstring *m) \
1409 return (TYPE) mio_name ((int) t, m); \
1411 #define MIO_NAME(TYPE) mio_name_##TYPE
1416 if (iomode
== IO_OUTPUT
)
1417 write_atom (ATOM_LPAREN
, NULL
);
1419 require_atom (ATOM_LPAREN
);
1426 if (iomode
== IO_OUTPUT
)
1427 write_atom (ATOM_RPAREN
, NULL
);
1429 require_atom (ATOM_RPAREN
);
1434 mio_integer (int *ip
)
1436 if (iomode
== IO_OUTPUT
)
1437 write_atom (ATOM_INTEGER
, ip
);
1440 require_atom (ATOM_INTEGER
);
1446 /* Read or write a character pointer that points to a string on the heap. */
1449 mio_allocated_string (const char *s
)
1451 if (iomode
== IO_OUTPUT
)
1453 write_atom (ATOM_STRING
, s
);
1458 require_atom (ATOM_STRING
);
1464 /* Functions for quoting and unquoting strings. */
1467 quote_string (const gfc_char_t
*s
, const size_t slength
)
1469 const gfc_char_t
*p
;
1473 /* Calculate the length we'll need: a backslash takes two ("\\"),
1474 non-printable characters take 10 ("\Uxxxxxxxx") and others take 1. */
1475 for (p
= s
, i
= 0; i
< slength
; p
++, i
++)
1479 else if (!gfc_wide_is_printable (*p
))
1485 q
= res
= XCNEWVEC (char, len
+ 1);
1486 for (p
= s
, i
= 0; i
< slength
; p
++, i
++)
1489 *q
++ = '\\', *q
++ = '\\';
1490 else if (!gfc_wide_is_printable (*p
))
1492 sprintf (q
, "\\U%08" HOST_WIDE_INT_PRINT
"x",
1493 (unsigned HOST_WIDE_INT
) *p
);
1497 *q
++ = (unsigned char) *p
;
1505 unquote_string (const char *s
)
1511 for (p
= s
, len
= 0; *p
; p
++, len
++)
1518 else if (p
[1] == 'U')
1519 p
+= 9; /* That is a "\U????????". */
1521 gfc_internal_error ("unquote_string(): got bad string");
1524 res
= gfc_get_wide_string (len
+ 1);
1525 for (i
= 0, p
= s
; i
< len
; i
++, p
++)
1530 res
[i
] = (unsigned char) *p
;
1531 else if (p
[1] == '\\')
1533 res
[i
] = (unsigned char) '\\';
1538 /* We read the 8-digits hexadecimal constant that follows. */
1543 gcc_assert (p
[1] == 'U');
1544 for (j
= 0; j
< 8; j
++)
1547 gcc_assert (sscanf (&p
[j
+2], "%01x", &n
) == 1);
1561 /* Read or write a character pointer that points to a wide string on the
1562 heap, performing quoting/unquoting of nonprintable characters using the
1563 form \U???????? (where each ? is a hexadecimal digit).
1564 Length is the length of the string, only known and used in output mode. */
1566 static const gfc_char_t
*
1567 mio_allocated_wide_string (const gfc_char_t
*s
, const size_t length
)
1569 if (iomode
== IO_OUTPUT
)
1571 char *quoted
= quote_string (s
, length
);
1572 write_atom (ATOM_STRING
, quoted
);
1578 gfc_char_t
*unquoted
;
1580 require_atom (ATOM_STRING
);
1581 unquoted
= unquote_string (atom_string
);
1582 gfc_free (atom_string
);
1588 /* Read or write a string that is in static memory. */
1591 mio_pool_string (const char **stringp
)
1593 /* TODO: one could write the string only once, and refer to it via a
1596 /* As a special case we have to deal with a NULL string. This
1597 happens for the 'module' member of 'gfc_symbol's that are not in a
1598 module. We read / write these as the empty string. */
1599 if (iomode
== IO_OUTPUT
)
1601 const char *p
= *stringp
== NULL
? "" : *stringp
;
1602 write_atom (ATOM_STRING
, p
);
1606 require_atom (ATOM_STRING
);
1607 *stringp
= atom_string
[0] == '\0' ? NULL
: gfc_get_string (atom_string
);
1608 gfc_free (atom_string
);
1613 /* Read or write a string that is inside of some already-allocated
1617 mio_internal_string (char *string
)
1619 if (iomode
== IO_OUTPUT
)
1620 write_atom (ATOM_STRING
, string
);
1623 require_atom (ATOM_STRING
);
1624 strcpy (string
, atom_string
);
1625 gfc_free (atom_string
);
1631 { AB_ALLOCATABLE
, AB_DIMENSION
, AB_EXTERNAL
, AB_INTRINSIC
, AB_OPTIONAL
,
1632 AB_POINTER
, AB_TARGET
, AB_DUMMY
, AB_RESULT
, AB_DATA
,
1633 AB_IN_NAMELIST
, AB_IN_COMMON
, AB_FUNCTION
, AB_SUBROUTINE
, AB_SEQUENCE
,
1634 AB_ELEMENTAL
, AB_PURE
, AB_RECURSIVE
, AB_GENERIC
, AB_ALWAYS_EXPLICIT
,
1635 AB_CRAY_POINTER
, AB_CRAY_POINTEE
, AB_THREADPRIVATE
, AB_ALLOC_COMP
,
1636 AB_POINTER_COMP
, AB_PRIVATE_COMP
, AB_VALUE
, AB_VOLATILE
, AB_PROTECTED
,
1637 AB_IS_BIND_C
, AB_IS_C_INTEROP
, AB_IS_ISO_C
, AB_ABSTRACT
, AB_ZERO_COMP
,
1638 AB_EXTENSION
, AB_PROCEDURE
, AB_PROC_POINTER
1642 static const mstring attr_bits
[] =
1644 minit ("ALLOCATABLE", AB_ALLOCATABLE
),
1645 minit ("DIMENSION", AB_DIMENSION
),
1646 minit ("EXTERNAL", AB_EXTERNAL
),
1647 minit ("INTRINSIC", AB_INTRINSIC
),
1648 minit ("OPTIONAL", AB_OPTIONAL
),
1649 minit ("POINTER", AB_POINTER
),
1650 minit ("VOLATILE", AB_VOLATILE
),
1651 minit ("TARGET", AB_TARGET
),
1652 minit ("THREADPRIVATE", AB_THREADPRIVATE
),
1653 minit ("DUMMY", AB_DUMMY
),
1654 minit ("RESULT", AB_RESULT
),
1655 minit ("DATA", AB_DATA
),
1656 minit ("IN_NAMELIST", AB_IN_NAMELIST
),
1657 minit ("IN_COMMON", AB_IN_COMMON
),
1658 minit ("FUNCTION", AB_FUNCTION
),
1659 minit ("SUBROUTINE", AB_SUBROUTINE
),
1660 minit ("SEQUENCE", AB_SEQUENCE
),
1661 minit ("ELEMENTAL", AB_ELEMENTAL
),
1662 minit ("PURE", AB_PURE
),
1663 minit ("RECURSIVE", AB_RECURSIVE
),
1664 minit ("GENERIC", AB_GENERIC
),
1665 minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT
),
1666 minit ("CRAY_POINTER", AB_CRAY_POINTER
),
1667 minit ("CRAY_POINTEE", AB_CRAY_POINTEE
),
1668 minit ("IS_BIND_C", AB_IS_BIND_C
),
1669 minit ("IS_C_INTEROP", AB_IS_C_INTEROP
),
1670 minit ("IS_ISO_C", AB_IS_ISO_C
),
1671 minit ("VALUE", AB_VALUE
),
1672 minit ("ALLOC_COMP", AB_ALLOC_COMP
),
1673 minit ("POINTER_COMP", AB_POINTER_COMP
),
1674 minit ("PRIVATE_COMP", AB_PRIVATE_COMP
),
1675 minit ("ZERO_COMP", AB_ZERO_COMP
),
1676 minit ("PROTECTED", AB_PROTECTED
),
1677 minit ("ABSTRACT", AB_ABSTRACT
),
1678 minit ("EXTENSION", AB_EXTENSION
),
1679 minit ("PROCEDURE", AB_PROCEDURE
),
1680 minit ("PROC_POINTER", AB_PROC_POINTER
),
1684 /* For binding attributes. */
1685 static const mstring binding_passing
[] =
1688 minit ("NOPASS", 1),
1691 static const mstring binding_overriding
[] =
1693 minit ("OVERRIDABLE", 0),
1694 minit ("NON_OVERRIDABLE", 1),
1699 /* Specialization of mio_name. */
1700 DECL_MIO_NAME (ab_attribute
)
1701 DECL_MIO_NAME (ar_type
)
1702 DECL_MIO_NAME (array_type
)
1704 DECL_MIO_NAME (expr_t
)
1705 DECL_MIO_NAME (gfc_access
)
1706 DECL_MIO_NAME (gfc_intrinsic_op
)
1707 DECL_MIO_NAME (ifsrc
)
1708 DECL_MIO_NAME (save_state
)
1709 DECL_MIO_NAME (procedure_type
)
1710 DECL_MIO_NAME (ref_type
)
1711 DECL_MIO_NAME (sym_flavor
)
1712 DECL_MIO_NAME (sym_intent
)
1713 #undef DECL_MIO_NAME
1715 /* Symbol attributes are stored in list with the first three elements
1716 being the enumerated fields, while the remaining elements (if any)
1717 indicate the individual attribute bits. The access field is not
1718 saved-- it controls what symbols are exported when a module is
1722 mio_symbol_attribute (symbol_attribute
*attr
)
1728 attr
->flavor
= MIO_NAME (sym_flavor
) (attr
->flavor
, flavors
);
1729 attr
->intent
= MIO_NAME (sym_intent
) (attr
->intent
, intents
);
1730 attr
->proc
= MIO_NAME (procedure_type
) (attr
->proc
, procedures
);
1731 attr
->if_source
= MIO_NAME (ifsrc
) (attr
->if_source
, ifsrc_types
);
1732 attr
->save
= MIO_NAME (save_state
) (attr
->save
, save_status
);
1734 if (iomode
== IO_OUTPUT
)
1736 if (attr
->allocatable
)
1737 MIO_NAME (ab_attribute
) (AB_ALLOCATABLE
, attr_bits
);
1738 if (attr
->dimension
)
1739 MIO_NAME (ab_attribute
) (AB_DIMENSION
, attr_bits
);
1741 MIO_NAME (ab_attribute
) (AB_EXTERNAL
, attr_bits
);
1742 if (attr
->intrinsic
)
1743 MIO_NAME (ab_attribute
) (AB_INTRINSIC
, attr_bits
);
1745 MIO_NAME (ab_attribute
) (AB_OPTIONAL
, attr_bits
);
1747 MIO_NAME (ab_attribute
) (AB_POINTER
, attr_bits
);
1748 if (attr
->is_protected
)
1749 MIO_NAME (ab_attribute
) (AB_PROTECTED
, attr_bits
);
1751 MIO_NAME (ab_attribute
) (AB_VALUE
, attr_bits
);
1752 if (attr
->volatile_
)
1753 MIO_NAME (ab_attribute
) (AB_VOLATILE
, attr_bits
);
1755 MIO_NAME (ab_attribute
) (AB_TARGET
, attr_bits
);
1756 if (attr
->threadprivate
)
1757 MIO_NAME (ab_attribute
) (AB_THREADPRIVATE
, attr_bits
);
1759 MIO_NAME (ab_attribute
) (AB_DUMMY
, attr_bits
);
1761 MIO_NAME (ab_attribute
) (AB_RESULT
, attr_bits
);
1762 /* We deliberately don't preserve the "entry" flag. */
1765 MIO_NAME (ab_attribute
) (AB_DATA
, attr_bits
);
1766 if (attr
->in_namelist
)
1767 MIO_NAME (ab_attribute
) (AB_IN_NAMELIST
, attr_bits
);
1768 if (attr
->in_common
)
1769 MIO_NAME (ab_attribute
) (AB_IN_COMMON
, attr_bits
);
1772 MIO_NAME (ab_attribute
) (AB_FUNCTION
, attr_bits
);
1773 if (attr
->subroutine
)
1774 MIO_NAME (ab_attribute
) (AB_SUBROUTINE
, attr_bits
);
1776 MIO_NAME (ab_attribute
) (AB_GENERIC
, attr_bits
);
1778 MIO_NAME (ab_attribute
) (AB_ABSTRACT
, attr_bits
);
1781 MIO_NAME (ab_attribute
) (AB_SEQUENCE
, attr_bits
);
1782 if (attr
->elemental
)
1783 MIO_NAME (ab_attribute
) (AB_ELEMENTAL
, attr_bits
);
1785 MIO_NAME (ab_attribute
) (AB_PURE
, attr_bits
);
1786 if (attr
->recursive
)
1787 MIO_NAME (ab_attribute
) (AB_RECURSIVE
, attr_bits
);
1788 if (attr
->always_explicit
)
1789 MIO_NAME (ab_attribute
) (AB_ALWAYS_EXPLICIT
, attr_bits
);
1790 if (attr
->cray_pointer
)
1791 MIO_NAME (ab_attribute
) (AB_CRAY_POINTER
, attr_bits
);
1792 if (attr
->cray_pointee
)
1793 MIO_NAME (ab_attribute
) (AB_CRAY_POINTEE
, attr_bits
);
1794 if (attr
->is_bind_c
)
1795 MIO_NAME(ab_attribute
) (AB_IS_BIND_C
, attr_bits
);
1796 if (attr
->is_c_interop
)
1797 MIO_NAME(ab_attribute
) (AB_IS_C_INTEROP
, attr_bits
);
1799 MIO_NAME(ab_attribute
) (AB_IS_ISO_C
, attr_bits
);
1800 if (attr
->alloc_comp
)
1801 MIO_NAME (ab_attribute
) (AB_ALLOC_COMP
, attr_bits
);
1802 if (attr
->pointer_comp
)
1803 MIO_NAME (ab_attribute
) (AB_POINTER_COMP
, attr_bits
);
1804 if (attr
->private_comp
)
1805 MIO_NAME (ab_attribute
) (AB_PRIVATE_COMP
, attr_bits
);
1806 if (attr
->zero_comp
)
1807 MIO_NAME (ab_attribute
) (AB_ZERO_COMP
, attr_bits
);
1808 if (attr
->extension
)
1809 MIO_NAME (ab_attribute
) (AB_EXTENSION
, attr_bits
);
1810 if (attr
->procedure
)
1811 MIO_NAME (ab_attribute
) (AB_PROCEDURE
, attr_bits
);
1812 if (attr
->proc_pointer
)
1813 MIO_NAME (ab_attribute
) (AB_PROC_POINTER
, attr_bits
);
1823 if (t
== ATOM_RPAREN
)
1826 bad_module ("Expected attribute bit name");
1828 switch ((ab_attribute
) find_enum (attr_bits
))
1830 case AB_ALLOCATABLE
:
1831 attr
->allocatable
= 1;
1834 attr
->dimension
= 1;
1840 attr
->intrinsic
= 1;
1849 attr
->is_protected
= 1;
1855 attr
->volatile_
= 1;
1860 case AB_THREADPRIVATE
:
1861 attr
->threadprivate
= 1;
1872 case AB_IN_NAMELIST
:
1873 attr
->in_namelist
= 1;
1876 attr
->in_common
= 1;
1882 attr
->subroutine
= 1;
1894 attr
->elemental
= 1;
1900 attr
->recursive
= 1;
1902 case AB_ALWAYS_EXPLICIT
:
1903 attr
->always_explicit
= 1;
1905 case AB_CRAY_POINTER
:
1906 attr
->cray_pointer
= 1;
1908 case AB_CRAY_POINTEE
:
1909 attr
->cray_pointee
= 1;
1912 attr
->is_bind_c
= 1;
1914 case AB_IS_C_INTEROP
:
1915 attr
->is_c_interop
= 1;
1921 attr
->alloc_comp
= 1;
1923 case AB_POINTER_COMP
:
1924 attr
->pointer_comp
= 1;
1926 case AB_PRIVATE_COMP
:
1927 attr
->private_comp
= 1;
1930 attr
->zero_comp
= 1;
1933 attr
->extension
= 1;
1936 attr
->procedure
= 1;
1938 case AB_PROC_POINTER
:
1939 attr
->proc_pointer
= 1;
1947 static const mstring bt_types
[] = {
1948 minit ("INTEGER", BT_INTEGER
),
1949 minit ("REAL", BT_REAL
),
1950 minit ("COMPLEX", BT_COMPLEX
),
1951 minit ("LOGICAL", BT_LOGICAL
),
1952 minit ("CHARACTER", BT_CHARACTER
),
1953 minit ("DERIVED", BT_DERIVED
),
1954 minit ("PROCEDURE", BT_PROCEDURE
),
1955 minit ("UNKNOWN", BT_UNKNOWN
),
1956 minit ("VOID", BT_VOID
),
1962 mio_charlen (gfc_charlen
**clp
)
1968 if (iomode
== IO_OUTPUT
)
1972 mio_expr (&cl
->length
);
1976 if (peek_atom () != ATOM_RPAREN
)
1978 cl
= gfc_get_charlen ();
1979 mio_expr (&cl
->length
);
1983 cl
->next
= gfc_current_ns
->cl_list
;
1984 gfc_current_ns
->cl_list
= cl
;
1992 /* See if a name is a generated name. */
1995 check_unique_name (const char *name
)
1997 return *name
== '@';
2002 mio_typespec (gfc_typespec
*ts
)
2006 ts
->type
= MIO_NAME (bt
) (ts
->type
, bt_types
);
2008 if (ts
->type
!= BT_DERIVED
)
2009 mio_integer (&ts
->kind
);
2011 mio_symbol_ref (&ts
->derived
);
2013 /* Add info for C interop and is_iso_c. */
2014 mio_integer (&ts
->is_c_interop
);
2015 mio_integer (&ts
->is_iso_c
);
2017 /* If the typespec is for an identifier either from iso_c_binding, or
2018 a constant that was initialized to an identifier from it, use the
2019 f90_type. Otherwise, use the ts->type, since it shouldn't matter. */
2021 ts
->f90_type
= MIO_NAME (bt
) (ts
->f90_type
, bt_types
);
2023 ts
->f90_type
= MIO_NAME (bt
) (ts
->type
, bt_types
);
2025 if (ts
->type
!= BT_CHARACTER
)
2027 /* ts->cl is only valid for BT_CHARACTER. */
2032 mio_charlen (&ts
->cl
);
2038 static const mstring array_spec_types
[] = {
2039 minit ("EXPLICIT", AS_EXPLICIT
),
2040 minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE
),
2041 minit ("DEFERRED", AS_DEFERRED
),
2042 minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE
),
2048 mio_array_spec (gfc_array_spec
**asp
)
2055 if (iomode
== IO_OUTPUT
)
2063 if (peek_atom () == ATOM_RPAREN
)
2069 *asp
= as
= gfc_get_array_spec ();
2072 mio_integer (&as
->rank
);
2073 as
->type
= MIO_NAME (array_type
) (as
->type
, array_spec_types
);
2075 for (i
= 0; i
< as
->rank
; i
++)
2077 mio_expr (&as
->lower
[i
]);
2078 mio_expr (&as
->upper
[i
]);
2086 /* Given a pointer to an array reference structure (which lives in a
2087 gfc_ref structure), find the corresponding array specification
2088 structure. Storing the pointer in the ref structure doesn't quite
2089 work when loading from a module. Generating code for an array
2090 reference also needs more information than just the array spec. */
2092 static const mstring array_ref_types
[] = {
2093 minit ("FULL", AR_FULL
),
2094 minit ("ELEMENT", AR_ELEMENT
),
2095 minit ("SECTION", AR_SECTION
),
2101 mio_array_ref (gfc_array_ref
*ar
)
2106 ar
->type
= MIO_NAME (ar_type
) (ar
->type
, array_ref_types
);
2107 mio_integer (&ar
->dimen
);
2115 for (i
= 0; i
< ar
->dimen
; i
++)
2116 mio_expr (&ar
->start
[i
]);
2121 for (i
= 0; i
< ar
->dimen
; i
++)
2123 mio_expr (&ar
->start
[i
]);
2124 mio_expr (&ar
->end
[i
]);
2125 mio_expr (&ar
->stride
[i
]);
2131 gfc_internal_error ("mio_array_ref(): Unknown array ref");
2134 /* Unfortunately, ar->dimen_type is an anonymous enumerated type so
2135 we can't call mio_integer directly. Instead loop over each element
2136 and cast it to/from an integer. */
2137 if (iomode
== IO_OUTPUT
)
2139 for (i
= 0; i
< ar
->dimen
; i
++)
2141 int tmp
= (int)ar
->dimen_type
[i
];
2142 write_atom (ATOM_INTEGER
, &tmp
);
2147 for (i
= 0; i
< ar
->dimen
; i
++)
2149 require_atom (ATOM_INTEGER
);
2150 ar
->dimen_type
[i
] = atom_int
;
2154 if (iomode
== IO_INPUT
)
2156 ar
->where
= gfc_current_locus
;
2158 for (i
= 0; i
< ar
->dimen
; i
++)
2159 ar
->c_where
[i
] = gfc_current_locus
;
2166 /* Saves or restores a pointer. The pointer is converted back and
2167 forth from an integer. We return the pointer_info pointer so that
2168 the caller can take additional action based on the pointer type. */
2170 static pointer_info
*
2171 mio_pointer_ref (void *gp
)
2175 if (iomode
== IO_OUTPUT
)
2177 p
= get_pointer (*((char **) gp
));
2178 write_atom (ATOM_INTEGER
, &p
->integer
);
2182 require_atom (ATOM_INTEGER
);
2183 p
= add_fixup (atom_int
, gp
);
2190 /* Save and load references to components that occur within
2191 expressions. We have to describe these references by a number and
2192 by name. The number is necessary for forward references during
2193 reading, and the name is necessary if the symbol already exists in
2194 the namespace and is not loaded again. */
2197 mio_component_ref (gfc_component
**cp
, gfc_symbol
*sym
)
2199 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2203 p
= mio_pointer_ref (cp
);
2204 if (p
->type
== P_UNKNOWN
)
2205 p
->type
= P_COMPONENT
;
2207 if (iomode
== IO_OUTPUT
)
2208 mio_pool_string (&(*cp
)->name
);
2211 mio_internal_string (name
);
2213 /* It can happen that a component reference can be read before the
2214 associated derived type symbol has been loaded. Return now and
2215 wait for a later iteration of load_needed. */
2219 if (sym
->components
!= NULL
&& p
->u
.pointer
== NULL
)
2221 /* Symbol already loaded, so search by name. */
2222 for (q
= sym
->components
; q
; q
= q
->next
)
2223 if (strcmp (q
->name
, name
) == 0)
2227 gfc_internal_error ("mio_component_ref(): Component not found");
2229 associate_integer_pointer (p
, q
);
2232 /* Make sure this symbol will eventually be loaded. */
2233 p
= find_pointer2 (sym
);
2234 if (p
->u
.rsym
.state
== UNUSED
)
2235 p
->u
.rsym
.state
= NEEDED
;
2241 mio_component (gfc_component
*c
)
2248 if (iomode
== IO_OUTPUT
)
2250 p
= get_pointer (c
);
2251 mio_integer (&p
->integer
);
2256 p
= get_integer (n
);
2257 associate_integer_pointer (p
, c
);
2260 if (p
->type
== P_UNKNOWN
)
2261 p
->type
= P_COMPONENT
;
2263 mio_pool_string (&c
->name
);
2264 mio_typespec (&c
->ts
);
2265 mio_array_spec (&c
->as
);
2267 mio_symbol_attribute (&c
->attr
);
2268 c
->attr
.access
= MIO_NAME (gfc_access
) (c
->attr
.access
, access_types
);
2270 mio_expr (&c
->initializer
);
2276 mio_component_list (gfc_component
**cp
)
2278 gfc_component
*c
, *tail
;
2282 if (iomode
== IO_OUTPUT
)
2284 for (c
= *cp
; c
; c
= c
->next
)
2294 if (peek_atom () == ATOM_RPAREN
)
2297 c
= gfc_get_component ();
2314 mio_actual_arg (gfc_actual_arglist
*a
)
2317 mio_pool_string (&a
->name
);
2318 mio_expr (&a
->expr
);
2324 mio_actual_arglist (gfc_actual_arglist
**ap
)
2326 gfc_actual_arglist
*a
, *tail
;
2330 if (iomode
== IO_OUTPUT
)
2332 for (a
= *ap
; a
; a
= a
->next
)
2342 if (peek_atom () != ATOM_LPAREN
)
2345 a
= gfc_get_actual_arglist ();
2361 /* Read and write formal argument lists. */
2364 mio_formal_arglist (gfc_symbol
*sym
)
2366 gfc_formal_arglist
*f
, *tail
;
2370 if (iomode
== IO_OUTPUT
)
2372 for (f
= sym
->formal
; f
; f
= f
->next
)
2373 mio_symbol_ref (&f
->sym
);
2377 sym
->formal
= tail
= NULL
;
2379 while (peek_atom () != ATOM_RPAREN
)
2381 f
= gfc_get_formal_arglist ();
2382 mio_symbol_ref (&f
->sym
);
2384 if (sym
->formal
== NULL
)
2397 /* Save or restore a reference to a symbol node. */
2400 mio_symbol_ref (gfc_symbol
**symp
)
2404 p
= mio_pointer_ref (symp
);
2405 if (p
->type
== P_UNKNOWN
)
2408 if (iomode
== IO_OUTPUT
)
2410 if (p
->u
.wsym
.state
== UNREFERENCED
)
2411 p
->u
.wsym
.state
= NEEDS_WRITE
;
2415 if (p
->u
.rsym
.state
== UNUSED
)
2416 p
->u
.rsym
.state
= NEEDED
;
2422 /* Save or restore a reference to a symtree node. */
2425 mio_symtree_ref (gfc_symtree
**stp
)
2430 if (iomode
== IO_OUTPUT
)
2431 mio_symbol_ref (&(*stp
)->n
.sym
);
2434 require_atom (ATOM_INTEGER
);
2435 p
= get_integer (atom_int
);
2437 /* An unused equivalence member; make a symbol and a symtree
2439 if (in_load_equiv
&& p
->u
.rsym
.symtree
== NULL
)
2441 /* Since this is not used, it must have a unique name. */
2442 p
->u
.rsym
.symtree
= gfc_get_unique_symtree (gfc_current_ns
);
2444 /* Make the symbol. */
2445 if (p
->u
.rsym
.sym
== NULL
)
2447 p
->u
.rsym
.sym
= gfc_new_symbol (p
->u
.rsym
.true_name
,
2449 p
->u
.rsym
.sym
->module
= gfc_get_string (p
->u
.rsym
.module
);
2452 p
->u
.rsym
.symtree
->n
.sym
= p
->u
.rsym
.sym
;
2453 p
->u
.rsym
.symtree
->n
.sym
->refs
++;
2454 p
->u
.rsym
.referenced
= 1;
2456 /* If the symbol is PRIVATE and in COMMON, load_commons will
2457 generate a fixup symbol, which must be associated. */
2459 resolve_fixups (p
->fixup
, p
->u
.rsym
.sym
);
2463 if (p
->type
== P_UNKNOWN
)
2466 if (p
->u
.rsym
.state
== UNUSED
)
2467 p
->u
.rsym
.state
= NEEDED
;
2469 if (p
->u
.rsym
.symtree
!= NULL
)
2471 *stp
= p
->u
.rsym
.symtree
;
2475 f
= XCNEW (fixup_t
);
2477 f
->next
= p
->u
.rsym
.stfixup
;
2478 p
->u
.rsym
.stfixup
= f
;
2480 f
->pointer
= (void **) stp
;
2487 mio_iterator (gfc_iterator
**ip
)
2493 if (iomode
== IO_OUTPUT
)
2500 if (peek_atom () == ATOM_RPAREN
)
2506 *ip
= gfc_get_iterator ();
2511 mio_expr (&iter
->var
);
2512 mio_expr (&iter
->start
);
2513 mio_expr (&iter
->end
);
2514 mio_expr (&iter
->step
);
2522 mio_constructor (gfc_constructor
**cp
)
2524 gfc_constructor
*c
, *tail
;
2528 if (iomode
== IO_OUTPUT
)
2530 for (c
= *cp
; c
; c
= c
->next
)
2533 mio_expr (&c
->expr
);
2534 mio_iterator (&c
->iterator
);
2543 while (peek_atom () != ATOM_RPAREN
)
2545 c
= gfc_get_constructor ();
2555 mio_expr (&c
->expr
);
2556 mio_iterator (&c
->iterator
);
2565 static const mstring ref_types
[] = {
2566 minit ("ARRAY", REF_ARRAY
),
2567 minit ("COMPONENT", REF_COMPONENT
),
2568 minit ("SUBSTRING", REF_SUBSTRING
),
2574 mio_ref (gfc_ref
**rp
)
2581 r
->type
= MIO_NAME (ref_type
) (r
->type
, ref_types
);
2586 mio_array_ref (&r
->u
.ar
);
2590 mio_symbol_ref (&r
->u
.c
.sym
);
2591 mio_component_ref (&r
->u
.c
.component
, r
->u
.c
.sym
);
2595 mio_expr (&r
->u
.ss
.start
);
2596 mio_expr (&r
->u
.ss
.end
);
2597 mio_charlen (&r
->u
.ss
.length
);
2606 mio_ref_list (gfc_ref
**rp
)
2608 gfc_ref
*ref
, *head
, *tail
;
2612 if (iomode
== IO_OUTPUT
)
2614 for (ref
= *rp
; ref
; ref
= ref
->next
)
2621 while (peek_atom () != ATOM_RPAREN
)
2624 head
= tail
= gfc_get_ref ();
2627 tail
->next
= gfc_get_ref ();
2641 /* Read and write an integer value. */
2644 mio_gmp_integer (mpz_t
*integer
)
2648 if (iomode
== IO_INPUT
)
2650 if (parse_atom () != ATOM_STRING
)
2651 bad_module ("Expected integer string");
2653 mpz_init (*integer
);
2654 if (mpz_set_str (*integer
, atom_string
, 10))
2655 bad_module ("Error converting integer");
2657 gfc_free (atom_string
);
2661 p
= mpz_get_str (NULL
, 10, *integer
);
2662 write_atom (ATOM_STRING
, p
);
2669 mio_gmp_real (mpfr_t
*real
)
2674 if (iomode
== IO_INPUT
)
2676 if (parse_atom () != ATOM_STRING
)
2677 bad_module ("Expected real string");
2680 mpfr_set_str (*real
, atom_string
, 16, GFC_RND_MODE
);
2681 gfc_free (atom_string
);
2685 p
= mpfr_get_str (NULL
, &exponent
, 16, 0, *real
, GFC_RND_MODE
);
2687 if (mpfr_nan_p (*real
) || mpfr_inf_p (*real
))
2689 write_atom (ATOM_STRING
, p
);
2694 atom_string
= XCNEWVEC (char, strlen (p
) + 20);
2696 sprintf (atom_string
, "0.%s@%ld", p
, exponent
);
2698 /* Fix negative numbers. */
2699 if (atom_string
[2] == '-')
2701 atom_string
[0] = '-';
2702 atom_string
[1] = '0';
2703 atom_string
[2] = '.';
2706 write_atom (ATOM_STRING
, atom_string
);
2708 gfc_free (atom_string
);
2714 /* Save and restore the shape of an array constructor. */
2717 mio_shape (mpz_t
**pshape
, int rank
)
2723 /* A NULL shape is represented by (). */
2726 if (iomode
== IO_OUTPUT
)
2738 if (t
== ATOM_RPAREN
)
2745 shape
= gfc_get_shape (rank
);
2749 for (n
= 0; n
< rank
; n
++)
2750 mio_gmp_integer (&shape
[n
]);
2756 static const mstring expr_types
[] = {
2757 minit ("OP", EXPR_OP
),
2758 minit ("FUNCTION", EXPR_FUNCTION
),
2759 minit ("CONSTANT", EXPR_CONSTANT
),
2760 minit ("VARIABLE", EXPR_VARIABLE
),
2761 minit ("SUBSTRING", EXPR_SUBSTRING
),
2762 minit ("STRUCTURE", EXPR_STRUCTURE
),
2763 minit ("ARRAY", EXPR_ARRAY
),
2764 minit ("NULL", EXPR_NULL
),
2765 minit ("COMPCALL", EXPR_COMPCALL
),
2769 /* INTRINSIC_ASSIGN is missing because it is used as an index for
2770 generic operators, not in expressions. INTRINSIC_USER is also
2771 replaced by the correct function name by the time we see it. */
2773 static const mstring intrinsics
[] =
2775 minit ("UPLUS", INTRINSIC_UPLUS
),
2776 minit ("UMINUS", INTRINSIC_UMINUS
),
2777 minit ("PLUS", INTRINSIC_PLUS
),
2778 minit ("MINUS", INTRINSIC_MINUS
),
2779 minit ("TIMES", INTRINSIC_TIMES
),
2780 minit ("DIVIDE", INTRINSIC_DIVIDE
),
2781 minit ("POWER", INTRINSIC_POWER
),
2782 minit ("CONCAT", INTRINSIC_CONCAT
),
2783 minit ("AND", INTRINSIC_AND
),
2784 minit ("OR", INTRINSIC_OR
),
2785 minit ("EQV", INTRINSIC_EQV
),
2786 minit ("NEQV", INTRINSIC_NEQV
),
2787 minit ("EQ_SIGN", INTRINSIC_EQ
),
2788 minit ("EQ", INTRINSIC_EQ_OS
),
2789 minit ("NE_SIGN", INTRINSIC_NE
),
2790 minit ("NE", INTRINSIC_NE_OS
),
2791 minit ("GT_SIGN", INTRINSIC_GT
),
2792 minit ("GT", INTRINSIC_GT_OS
),
2793 minit ("GE_SIGN", INTRINSIC_GE
),
2794 minit ("GE", INTRINSIC_GE_OS
),
2795 minit ("LT_SIGN", INTRINSIC_LT
),
2796 minit ("LT", INTRINSIC_LT_OS
),
2797 minit ("LE_SIGN", INTRINSIC_LE
),
2798 minit ("LE", INTRINSIC_LE_OS
),
2799 minit ("NOT", INTRINSIC_NOT
),
2800 minit ("PARENTHESES", INTRINSIC_PARENTHESES
),
2805 /* Remedy a couple of situations where the gfc_expr's can be defective. */
2808 fix_mio_expr (gfc_expr
*e
)
2810 gfc_symtree
*ns_st
= NULL
;
2813 if (iomode
!= IO_OUTPUT
)
2818 /* If this is a symtree for a symbol that came from a contained module
2819 namespace, it has a unique name and we should look in the current
2820 namespace to see if the required, non-contained symbol is available
2821 yet. If so, the latter should be written. */
2822 if (e
->symtree
->n
.sym
&& check_unique_name (e
->symtree
->name
))
2823 ns_st
= gfc_find_symtree (gfc_current_ns
->sym_root
,
2824 e
->symtree
->n
.sym
->name
);
2826 /* On the other hand, if the existing symbol is the module name or the
2827 new symbol is a dummy argument, do not do the promotion. */
2828 if (ns_st
&& ns_st
->n
.sym
2829 && ns_st
->n
.sym
->attr
.flavor
!= FL_MODULE
2830 && !e
->symtree
->n
.sym
->attr
.dummy
)
2833 else if (e
->expr_type
== EXPR_FUNCTION
&& e
->value
.function
.name
)
2835 /* In some circumstances, a function used in an initialization
2836 expression, in one use associated module, can fail to be
2837 coupled to its symtree when used in a specification
2838 expression in another module. */
2839 fname
= e
->value
.function
.esym
? e
->value
.function
.esym
->name
2840 : e
->value
.function
.isym
->name
;
2841 e
->symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, fname
);
2846 /* Read and write expressions. The form "()" is allowed to indicate a
2850 mio_expr (gfc_expr
**ep
)
2858 if (iomode
== IO_OUTPUT
)
2867 MIO_NAME (expr_t
) (e
->expr_type
, expr_types
);
2872 if (t
== ATOM_RPAREN
)
2879 bad_module ("Expected expression type");
2881 e
= *ep
= gfc_get_expr ();
2882 e
->where
= gfc_current_locus
;
2883 e
->expr_type
= (expr_t
) find_enum (expr_types
);
2886 mio_typespec (&e
->ts
);
2887 mio_integer (&e
->rank
);
2891 switch (e
->expr_type
)
2895 = MIO_NAME (gfc_intrinsic_op
) (e
->value
.op
.op
, intrinsics
);
2897 switch (e
->value
.op
.op
)
2899 case INTRINSIC_UPLUS
:
2900 case INTRINSIC_UMINUS
:
2902 case INTRINSIC_PARENTHESES
:
2903 mio_expr (&e
->value
.op
.op1
);
2906 case INTRINSIC_PLUS
:
2907 case INTRINSIC_MINUS
:
2908 case INTRINSIC_TIMES
:
2909 case INTRINSIC_DIVIDE
:
2910 case INTRINSIC_POWER
:
2911 case INTRINSIC_CONCAT
:
2915 case INTRINSIC_NEQV
:
2917 case INTRINSIC_EQ_OS
:
2919 case INTRINSIC_NE_OS
:
2921 case INTRINSIC_GT_OS
:
2923 case INTRINSIC_GE_OS
:
2925 case INTRINSIC_LT_OS
:
2927 case INTRINSIC_LE_OS
:
2928 mio_expr (&e
->value
.op
.op1
);
2929 mio_expr (&e
->value
.op
.op2
);
2933 bad_module ("Bad operator");
2939 mio_symtree_ref (&e
->symtree
);
2940 mio_actual_arglist (&e
->value
.function
.actual
);
2942 if (iomode
== IO_OUTPUT
)
2944 e
->value
.function
.name
2945 = mio_allocated_string (e
->value
.function
.name
);
2946 flag
= e
->value
.function
.esym
!= NULL
;
2947 mio_integer (&flag
);
2949 mio_symbol_ref (&e
->value
.function
.esym
);
2951 write_atom (ATOM_STRING
, e
->value
.function
.isym
->name
);
2955 require_atom (ATOM_STRING
);
2956 e
->value
.function
.name
= gfc_get_string (atom_string
);
2957 gfc_free (atom_string
);
2959 mio_integer (&flag
);
2961 mio_symbol_ref (&e
->value
.function
.esym
);
2964 require_atom (ATOM_STRING
);
2965 e
->value
.function
.isym
= gfc_find_function (atom_string
);
2966 gfc_free (atom_string
);
2973 mio_symtree_ref (&e
->symtree
);
2974 mio_ref_list (&e
->ref
);
2977 case EXPR_SUBSTRING
:
2978 e
->value
.character
.string
2979 = CONST_CAST (gfc_char_t
*,
2980 mio_allocated_wide_string (e
->value
.character
.string
,
2981 e
->value
.character
.length
));
2982 mio_ref_list (&e
->ref
);
2985 case EXPR_STRUCTURE
:
2987 mio_constructor (&e
->value
.constructor
);
2988 mio_shape (&e
->shape
, e
->rank
);
2995 mio_gmp_integer (&e
->value
.integer
);
2999 gfc_set_model_kind (e
->ts
.kind
);
3000 mio_gmp_real (&e
->value
.real
);
3004 gfc_set_model_kind (e
->ts
.kind
);
3005 mio_gmp_real (&e
->value
.complex.r
);
3006 mio_gmp_real (&e
->value
.complex.i
);
3010 mio_integer (&e
->value
.logical
);
3014 mio_integer (&e
->value
.character
.length
);
3015 e
->value
.character
.string
3016 = CONST_CAST (gfc_char_t
*,
3017 mio_allocated_wide_string (e
->value
.character
.string
,
3018 e
->value
.character
.length
));
3022 bad_module ("Bad type in constant expression");
3039 /* Read and write namelists. */
3042 mio_namelist (gfc_symbol
*sym
)
3044 gfc_namelist
*n
, *m
;
3045 const char *check_name
;
3049 if (iomode
== IO_OUTPUT
)
3051 for (n
= sym
->namelist
; n
; n
= n
->next
)
3052 mio_symbol_ref (&n
->sym
);
3056 /* This departure from the standard is flagged as an error.
3057 It does, in fact, work correctly. TODO: Allow it
3059 if (sym
->attr
.flavor
== FL_NAMELIST
)
3061 check_name
= find_use_name (sym
->name
, false);
3062 if (check_name
&& strcmp (check_name
, sym
->name
) != 0)
3063 gfc_error ("Namelist %s cannot be renamed by USE "
3064 "association to %s", sym
->name
, check_name
);
3068 while (peek_atom () != ATOM_RPAREN
)
3070 n
= gfc_get_namelist ();
3071 mio_symbol_ref (&n
->sym
);
3073 if (sym
->namelist
== NULL
)
3080 sym
->namelist_tail
= m
;
3087 /* Save/restore lists of gfc_interface structures. When loading an
3088 interface, we are really appending to the existing list of
3089 interfaces. Checking for duplicate and ambiguous interfaces has to
3090 be done later when all symbols have been loaded. */
3093 mio_interface_rest (gfc_interface
**ip
)
3095 gfc_interface
*tail
, *p
;
3096 pointer_info
*pi
= NULL
;
3098 if (iomode
== IO_OUTPUT
)
3101 for (p
= *ip
; p
; p
= p
->next
)
3102 mio_symbol_ref (&p
->sym
);
3117 if (peek_atom () == ATOM_RPAREN
)
3120 p
= gfc_get_interface ();
3121 p
->where
= gfc_current_locus
;
3122 pi
= mio_symbol_ref (&p
->sym
);
3138 /* Save/restore a nameless operator interface. */
3141 mio_interface (gfc_interface
**ip
)
3144 mio_interface_rest (ip
);
3148 /* Save/restore a named operator interface. */
3151 mio_symbol_interface (const char **name
, const char **module
,
3155 mio_pool_string (name
);
3156 mio_pool_string (module
);
3157 mio_interface_rest (ip
);
3162 mio_namespace_ref (gfc_namespace
**nsp
)
3167 p
= mio_pointer_ref (nsp
);
3169 if (p
->type
== P_UNKNOWN
)
3170 p
->type
= P_NAMESPACE
;
3172 if (iomode
== IO_INPUT
&& p
->integer
!= 0)
3174 ns
= (gfc_namespace
*) p
->u
.pointer
;
3177 ns
= gfc_get_namespace (NULL
, 0);
3178 associate_integer_pointer (p
, ns
);
3186 /* Save/restore the f2k_derived namespace of a derived-type symbol. */
3189 mio_typebound_proc (gfc_typebound_proc
** proc
)
3193 if (iomode
== IO_INPUT
)
3195 *proc
= gfc_get_typebound_proc ();
3196 (*proc
)->where
= gfc_current_locus
;
3201 mio_symtree_ref (&(*proc
)->target
);
3203 (*proc
)->access
= MIO_NAME (gfc_access
) ((*proc
)->access
, access_types
);
3205 (*proc
)->nopass
= mio_name ((*proc
)->nopass
, binding_passing
);
3206 (*proc
)->non_overridable
= mio_name ((*proc
)->non_overridable
,
3207 binding_overriding
);
3209 if (iomode
== IO_INPUT
)
3210 (*proc
)->pass_arg
= NULL
;
3212 flag
= (int) (*proc
)->pass_arg_num
;
3213 mio_integer (&flag
);
3214 (*proc
)->pass_arg_num
= (unsigned) flag
;
3220 mio_typebound_symtree (gfc_symtree
* st
)
3222 if (iomode
== IO_OUTPUT
&& !st
->typebound
)
3225 if (iomode
== IO_OUTPUT
)
3228 mio_allocated_string (st
->name
);
3230 /* For IO_INPUT, the above is done in mio_f2k_derived. */
3232 mio_typebound_proc (&st
->typebound
);
3237 mio_finalizer (gfc_finalizer
**f
)
3239 if (iomode
== IO_OUTPUT
)
3242 gcc_assert ((*f
)->proc_tree
); /* Should already be resolved. */
3243 mio_symtree_ref (&(*f
)->proc_tree
);
3247 *f
= gfc_get_finalizer ();
3248 (*f
)->where
= gfc_current_locus
; /* Value should not matter. */
3251 mio_symtree_ref (&(*f
)->proc_tree
);
3252 (*f
)->proc_sym
= NULL
;
3257 mio_f2k_derived (gfc_namespace
*f2k
)
3259 /* Handle the list of finalizer procedures. */
3261 if (iomode
== IO_OUTPUT
)
3264 for (f
= f2k
->finalizers
; f
; f
= f
->next
)
3269 f2k
->finalizers
= NULL
;
3270 while (peek_atom () != ATOM_RPAREN
)
3273 mio_finalizer (&cur
);
3274 cur
->next
= f2k
->finalizers
;
3275 f2k
->finalizers
= cur
;
3280 /* Handle type-bound procedures. */
3282 if (iomode
== IO_OUTPUT
)
3283 gfc_traverse_symtree (f2k
->sym_root
, &mio_typebound_symtree
);
3286 while (peek_atom () == ATOM_LPAREN
)
3292 require_atom (ATOM_STRING
);
3293 gfc_get_sym_tree (atom_string
, f2k
, &st
);
3294 gfc_free (atom_string
);
3296 mio_typebound_symtree (st
);
3303 mio_full_f2k_derived (gfc_symbol
*sym
)
3307 if (iomode
== IO_OUTPUT
)
3309 if (sym
->f2k_derived
)
3310 mio_f2k_derived (sym
->f2k_derived
);
3314 if (peek_atom () != ATOM_RPAREN
)
3316 sym
->f2k_derived
= gfc_get_namespace (NULL
, 0);
3317 mio_f2k_derived (sym
->f2k_derived
);
3320 gcc_assert (!sym
->f2k_derived
);
3327 /* Unlike most other routines, the address of the symbol node is already
3328 fixed on input and the name/module has already been filled in. */
3331 mio_symbol (gfc_symbol
*sym
)
3333 int intmod
= INTMOD_NONE
;
3335 gfc_formal_arglist
*formal
;
3339 mio_symbol_attribute (&sym
->attr
);
3340 mio_typespec (&sym
->ts
);
3342 /* Contained procedures don't have formal namespaces. Instead we output the
3343 procedure namespace. The will contain the formal arguments. */
3344 if (iomode
== IO_OUTPUT
)
3346 formal
= sym
->formal
;
3347 while (formal
&& !formal
->sym
)
3348 formal
= formal
->next
;
3351 mio_namespace_ref (&formal
->sym
->ns
);
3353 mio_namespace_ref (&sym
->formal_ns
);
3357 mio_namespace_ref (&sym
->formal_ns
);
3360 sym
->formal_ns
->proc_name
= sym
;
3365 /* Save/restore common block links. */
3366 mio_symbol_ref (&sym
->common_next
);
3368 mio_formal_arglist (sym
);
3370 if (sym
->attr
.flavor
== FL_PARAMETER
)
3371 mio_expr (&sym
->value
);
3373 mio_array_spec (&sym
->as
);
3375 mio_symbol_ref (&sym
->result
);
3377 if (sym
->attr
.cray_pointee
)
3378 mio_symbol_ref (&sym
->cp_pointer
);
3380 /* Note that components are always saved, even if they are supposed
3381 to be private. Component access is checked during searching. */
3383 mio_component_list (&sym
->components
);
3385 if (sym
->components
!= NULL
)
3386 sym
->component_access
3387 = MIO_NAME (gfc_access
) (sym
->component_access
, access_types
);
3389 /* Load/save the f2k_derived namespace of a derived-type symbol. */
3390 mio_full_f2k_derived (sym
);
3394 /* Add the fields that say whether this is from an intrinsic module,
3395 and if so, what symbol it is within the module. */
3396 /* mio_integer (&(sym->from_intmod)); */
3397 if (iomode
== IO_OUTPUT
)
3399 intmod
= sym
->from_intmod
;
3400 mio_integer (&intmod
);
3404 mio_integer (&intmod
);
3405 sym
->from_intmod
= intmod
;
3408 mio_integer (&(sym
->intmod_sym_id
));
3414 /************************* Top level subroutines *************************/
3416 /* Given a root symtree node and a symbol, try to find a symtree that
3417 references the symbol that is not a unique name. */
3419 static gfc_symtree
*
3420 find_symtree_for_symbol (gfc_symtree
*st
, gfc_symbol
*sym
)
3422 gfc_symtree
*s
= NULL
;
3427 s
= find_symtree_for_symbol (st
->right
, sym
);
3430 s
= find_symtree_for_symbol (st
->left
, sym
);
3434 if (st
->n
.sym
== sym
&& !check_unique_name (st
->name
))
3441 /* A recursive function to look for a specific symbol by name and by
3442 module. Whilst several symtrees might point to one symbol, its
3443 is sufficient for the purposes here than one exist. Note that
3444 generic interfaces are distinguished as are symbols that have been
3445 renamed in another module. */
3446 static gfc_symtree
*
3447 find_symbol (gfc_symtree
*st
, const char *name
,
3448 const char *module
, int generic
)
3451 gfc_symtree
*retval
, *s
;
3453 if (st
== NULL
|| st
->n
.sym
== NULL
)
3456 c
= strcmp (name
, st
->n
.sym
->name
);
3457 if (c
== 0 && st
->n
.sym
->module
3458 && strcmp (module
, st
->n
.sym
->module
) == 0
3459 && !check_unique_name (st
->name
))
3461 s
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
3463 /* Detect symbols that are renamed by use association in another
3464 module by the absence of a symtree and null attr.use_rename,
3465 since the latter is not transmitted in the module file. */
3466 if (((!generic
&& !st
->n
.sym
->attr
.generic
)
3467 || (generic
&& st
->n
.sym
->attr
.generic
))
3468 && !(s
== NULL
&& !st
->n
.sym
->attr
.use_rename
))
3472 retval
= find_symbol (st
->left
, name
, module
, generic
);
3475 retval
= find_symbol (st
->right
, name
, module
, generic
);
3481 /* Skip a list between balanced left and right parens. */
3491 switch (parse_atom ())
3502 gfc_free (atom_string
);
3514 /* Load operator interfaces from the module. Interfaces are unusual
3515 in that they attach themselves to existing symbols. */
3518 load_operator_interfaces (void)
3521 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[GFC_MAX_SYMBOL_LEN
+ 1];
3523 pointer_info
*pi
= NULL
;
3528 while (peek_atom () != ATOM_RPAREN
)
3532 mio_internal_string (name
);
3533 mio_internal_string (module
);
3535 n
= number_use_names (name
, true);
3538 for (i
= 1; i
<= n
; i
++)
3540 /* Decide if we need to load this one or not. */
3541 p
= find_use_name_n (name
, &i
, true);
3545 while (parse_atom () != ATOM_RPAREN
);
3551 uop
= gfc_get_uop (p
);
3552 pi
= mio_interface_rest (&uop
->op
);
3556 if (gfc_find_uop (p
, NULL
))
3558 uop
= gfc_get_uop (p
);
3559 uop
->op
= gfc_get_interface ();
3560 uop
->op
->where
= gfc_current_locus
;
3561 add_fixup (pi
->integer
, &uop
->op
->sym
);
3570 /* Load interfaces from the module. Interfaces are unusual in that
3571 they attach themselves to existing symbols. */
3574 load_generic_interfaces (void)
3577 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[GFC_MAX_SYMBOL_LEN
+ 1];
3579 gfc_interface
*generic
= NULL
;
3584 while (peek_atom () != ATOM_RPAREN
)
3588 mio_internal_string (name
);
3589 mio_internal_string (module
);
3591 n
= number_use_names (name
, false);
3592 renamed
= n
? 1 : 0;
3595 for (i
= 1; i
<= n
; i
++)
3598 /* Decide if we need to load this one or not. */
3599 p
= find_use_name_n (name
, &i
, false);
3601 st
= find_symbol (gfc_current_ns
->sym_root
,
3602 name
, module_name
, 1);
3604 if (!p
|| gfc_find_symbol (p
, NULL
, 0, &sym
))
3606 /* Skip the specific names for these cases. */
3607 while (i
== 1 && parse_atom () != ATOM_RPAREN
);
3612 /* If the symbol exists already and is being USEd without being
3613 in an ONLY clause, do not load a new symtree(11.3.2). */
3614 if (!only_flag
&& st
)
3619 /* Make the symbol inaccessible if it has been added by a USE
3620 statement without an ONLY(11.3.2). */
3622 && !st
->n
.sym
->attr
.use_only
3623 && !st
->n
.sym
->attr
.use_rename
3624 && strcmp (st
->n
.sym
->module
, module_name
) == 0)
3627 gfc_delete_symtree (&gfc_current_ns
->sym_root
, name
);
3628 st
= gfc_get_unique_symtree (gfc_current_ns
);
3635 if (strcmp (st
->name
, p
) != 0)
3637 st
= gfc_new_symtree (&gfc_current_ns
->sym_root
, p
);
3643 /* Since we haven't found a valid generic interface, we had
3647 gfc_get_symbol (p
, NULL
, &sym
);
3648 sym
->name
= gfc_get_string (name
);
3649 sym
->module
= gfc_get_string (module_name
);
3650 sym
->attr
.flavor
= FL_PROCEDURE
;
3651 sym
->attr
.generic
= 1;
3652 sym
->attr
.use_assoc
= 1;
3657 /* Unless sym is a generic interface, this reference
3660 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
3664 if (st
&& !sym
->attr
.generic
3666 && strcmp(module
, sym
->module
))
3670 sym
->attr
.use_only
= only_flag
;
3671 sym
->attr
.use_rename
= renamed
;
3675 mio_interface_rest (&sym
->generic
);
3676 generic
= sym
->generic
;
3678 else if (!sym
->generic
)
3680 sym
->generic
= generic
;
3681 sym
->attr
.generic_copy
= 1;
3690 /* Load common blocks. */
3695 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3700 while (peek_atom () != ATOM_RPAREN
)
3704 mio_internal_string (name
);
3706 p
= gfc_get_common (name
, 1);
3708 mio_symbol_ref (&p
->head
);
3709 mio_integer (&flags
);
3713 p
->threadprivate
= 1;
3716 /* Get whether this was a bind(c) common or not. */
3717 mio_integer (&p
->is_bind_c
);
3718 /* Get the binding label. */
3719 mio_internal_string (p
->binding_label
);
3728 /* Load equivalences. The flag in_load_equiv informs mio_expr_ref of this
3729 so that unused variables are not loaded and so that the expression can
3735 gfc_equiv
*head
, *tail
, *end
, *eq
;
3739 in_load_equiv
= true;
3741 end
= gfc_current_ns
->equiv
;
3742 while (end
!= NULL
&& end
->next
!= NULL
)
3745 while (peek_atom () != ATOM_RPAREN
) {
3749 while(peek_atom () != ATOM_RPAREN
)
3752 head
= tail
= gfc_get_equiv ();
3755 tail
->eq
= gfc_get_equiv ();
3759 mio_pool_string (&tail
->module
);
3760 mio_expr (&tail
->expr
);
3763 /* Unused equivalence members have a unique name. */
3765 for (eq
= head
; eq
; eq
= eq
->eq
)
3767 if (!check_unique_name (eq
->expr
->symtree
->name
))
3776 for (eq
= head
; eq
; eq
= head
)
3779 gfc_free_expr (eq
->expr
);
3785 gfc_current_ns
->equiv
= head
;
3796 in_load_equiv
= false;
3800 /* Recursive function to traverse the pointer_info tree and load a
3801 needed symbol. We return nonzero if we load a symbol and stop the
3802 traversal, because the act of loading can alter the tree. */
3805 load_needed (pointer_info
*p
)
3816 rv
|= load_needed (p
->left
);
3817 rv
|= load_needed (p
->right
);
3819 if (p
->type
!= P_SYMBOL
|| p
->u
.rsym
.state
!= NEEDED
)
3822 p
->u
.rsym
.state
= USED
;
3824 set_module_locus (&p
->u
.rsym
.where
);
3826 sym
= p
->u
.rsym
.sym
;
3829 q
= get_integer (p
->u
.rsym
.ns
);
3831 ns
= (gfc_namespace
*) q
->u
.pointer
;
3834 /* Create an interface namespace if necessary. These are
3835 the namespaces that hold the formal parameters of module
3838 ns
= gfc_get_namespace (NULL
, 0);
3839 associate_integer_pointer (q
, ns
);
3842 /* Use the module sym as 'proc_name' so that gfc_get_symbol_decl
3843 doesn't go pear-shaped if the symbol is used. */
3845 gfc_find_symbol (p
->u
.rsym
.module
, gfc_current_ns
,
3848 sym
= gfc_new_symbol (p
->u
.rsym
.true_name
, ns
);
3849 sym
->module
= gfc_get_string (p
->u
.rsym
.module
);
3850 strcpy (sym
->binding_label
, p
->u
.rsym
.binding_label
);
3852 associate_integer_pointer (p
, sym
);
3856 sym
->attr
.use_assoc
= 1;
3858 sym
->attr
.use_only
= 1;
3859 if (p
->u
.rsym
.renamed
)
3860 sym
->attr
.use_rename
= 1;
3866 /* Recursive function for cleaning up things after a module has been read. */
3869 read_cleanup (pointer_info
*p
)
3877 read_cleanup (p
->left
);
3878 read_cleanup (p
->right
);
3880 if (p
->type
== P_SYMBOL
&& p
->u
.rsym
.state
== USED
&& !p
->u
.rsym
.referenced
)
3882 /* Add hidden symbols to the symtree. */
3883 q
= get_integer (p
->u
.rsym
.ns
);
3884 st
= gfc_get_unique_symtree ((gfc_namespace
*) q
->u
.pointer
);
3886 st
->n
.sym
= p
->u
.rsym
.sym
;
3889 /* Fixup any symtree references. */
3890 p
->u
.rsym
.symtree
= st
;
3891 resolve_fixups (p
->u
.rsym
.stfixup
, st
);
3892 p
->u
.rsym
.stfixup
= NULL
;
3895 /* Free unused symbols. */
3896 if (p
->type
== P_SYMBOL
&& p
->u
.rsym
.state
== UNUSED
)
3897 gfc_free_symbol (p
->u
.rsym
.sym
);
3901 /* Read a module file. */
3906 module_locus operator_interfaces
, user_operators
;
3908 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3910 int ambiguous
, j
, nuse
, symbol
;
3911 pointer_info
*info
, *q
;
3916 get_module_locus (&operator_interfaces
); /* Skip these for now. */
3919 get_module_locus (&user_operators
);
3923 /* Skip commons and equivalences for now. */
3929 /* Create the fixup nodes for all the symbols. */
3931 while (peek_atom () != ATOM_RPAREN
)
3933 require_atom (ATOM_INTEGER
);
3934 info
= get_integer (atom_int
);
3936 info
->type
= P_SYMBOL
;
3937 info
->u
.rsym
.state
= UNUSED
;
3939 mio_internal_string (info
->u
.rsym
.true_name
);
3940 mio_internal_string (info
->u
.rsym
.module
);
3941 mio_internal_string (info
->u
.rsym
.binding_label
);
3944 require_atom (ATOM_INTEGER
);
3945 info
->u
.rsym
.ns
= atom_int
;
3947 get_module_locus (&info
->u
.rsym
.where
);
3950 /* See if the symbol has already been loaded by a previous module.
3951 If so, we reference the existing symbol and prevent it from
3952 being loaded again. This should not happen if the symbol being
3953 read is an index for an assumed shape dummy array (ns != 1). */
3955 sym
= find_true_name (info
->u
.rsym
.true_name
, info
->u
.rsym
.module
);
3958 || (sym
->attr
.flavor
== FL_VARIABLE
&& info
->u
.rsym
.ns
!=1))
3961 info
->u
.rsym
.state
= USED
;
3962 info
->u
.rsym
.sym
= sym
;
3964 /* Some symbols do not have a namespace (eg. formal arguments),
3965 so the automatic "unique symtree" mechanism must be suppressed
3966 by marking them as referenced. */
3967 q
= get_integer (info
->u
.rsym
.ns
);
3968 if (q
->u
.pointer
== NULL
)
3970 info
->u
.rsym
.referenced
= 1;
3974 /* If possible recycle the symtree that references the symbol.
3975 If a symtree is not found and the module does not import one,
3976 a unique-name symtree is found by read_cleanup. */
3977 st
= find_symtree_for_symbol (gfc_current_ns
->sym_root
, sym
);
3980 info
->u
.rsym
.symtree
= st
;
3981 info
->u
.rsym
.referenced
= 1;
3987 /* Parse the symtree lists. This lets us mark which symbols need to
3988 be loaded. Renaming is also done at this point by replacing the
3993 while (peek_atom () != ATOM_RPAREN
)
3995 mio_internal_string (name
);
3996 mio_integer (&ambiguous
);
3997 mio_integer (&symbol
);
3999 info
= get_integer (symbol
);
4001 /* See how many use names there are. If none, go through the start
4002 of the loop at least once. */
4003 nuse
= number_use_names (name
, false);
4004 info
->u
.rsym
.renamed
= nuse
? 1 : 0;
4009 for (j
= 1; j
<= nuse
; j
++)
4011 /* Get the jth local name for this symbol. */
4012 p
= find_use_name_n (name
, &j
, false);
4014 if (p
== NULL
&& strcmp (name
, module_name
) == 0)
4017 /* Skip symtree nodes not in an ONLY clause, unless there
4018 is an existing symtree loaded from another USE statement. */
4021 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
4023 info
->u
.rsym
.symtree
= st
;
4027 /* If a symbol of the same name and module exists already,
4028 this symbol, which is not in an ONLY clause, must not be
4029 added to the namespace(11.3.2). Note that find_symbol
4030 only returns the first occurrence that it finds. */
4031 if (!only_flag
&& !info
->u
.rsym
.renamed
4032 && strcmp (name
, module_name
) != 0
4033 && find_symbol (gfc_current_ns
->sym_root
, name
,
4037 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
4041 /* Check for ambiguous symbols. */
4042 if (st
->n
.sym
!= info
->u
.rsym
.sym
)
4044 info
->u
.rsym
.symtree
= st
;
4048 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
4050 /* Delete the symtree if the symbol has been added by a USE
4051 statement without an ONLY(11.3.2). Remember that the rsym
4052 will be the same as the symbol found in the symtree, for
4054 if (st
&& (only_flag
|| info
->u
.rsym
.renamed
)
4055 && !st
->n
.sym
->attr
.use_only
4056 && !st
->n
.sym
->attr
.use_rename
4057 && info
->u
.rsym
.sym
== st
->n
.sym
)
4058 gfc_delete_symtree (&gfc_current_ns
->sym_root
, name
);
4060 /* Create a symtree node in the current namespace for this
4062 st
= check_unique_name (p
)
4063 ? gfc_get_unique_symtree (gfc_current_ns
)
4064 : gfc_new_symtree (&gfc_current_ns
->sym_root
, p
);
4065 st
->ambiguous
= ambiguous
;
4067 sym
= info
->u
.rsym
.sym
;
4069 /* Create a symbol node if it doesn't already exist. */
4072 info
->u
.rsym
.sym
= gfc_new_symbol (info
->u
.rsym
.true_name
,
4074 sym
= info
->u
.rsym
.sym
;
4075 sym
->module
= gfc_get_string (info
->u
.rsym
.module
);
4077 /* TODO: hmm, can we test this? Do we know it will be
4078 initialized to zeros? */
4079 if (info
->u
.rsym
.binding_label
[0] != '\0')
4080 strcpy (sym
->binding_label
, info
->u
.rsym
.binding_label
);
4086 if (strcmp (name
, p
) != 0)
4087 sym
->attr
.use_rename
= 1;
4089 /* Store the symtree pointing to this symbol. */
4090 info
->u
.rsym
.symtree
= st
;
4092 if (info
->u
.rsym
.state
== UNUSED
)
4093 info
->u
.rsym
.state
= NEEDED
;
4094 info
->u
.rsym
.referenced
= 1;
4101 /* Load intrinsic operator interfaces. */
4102 set_module_locus (&operator_interfaces
);
4105 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
4107 if (i
== INTRINSIC_USER
)
4112 u
= find_use_operator (i
);
4123 mio_interface (&gfc_current_ns
->op
[i
]);
4128 /* Load generic and user operator interfaces. These must follow the
4129 loading of symtree because otherwise symbols can be marked as
4132 set_module_locus (&user_operators
);
4134 load_operator_interfaces ();
4135 load_generic_interfaces ();
4140 /* At this point, we read those symbols that are needed but haven't
4141 been loaded yet. If one symbol requires another, the other gets
4142 marked as NEEDED if its previous state was UNUSED. */
4144 while (load_needed (pi_root
));
4146 /* Make sure all elements of the rename-list were found in the module. */
4148 for (u
= gfc_rename_list
; u
; u
= u
->next
)
4153 if (u
->op
== INTRINSIC_NONE
)
4155 gfc_error ("Symbol '%s' referenced at %L not found in module '%s'",
4156 u
->use_name
, &u
->where
, module_name
);
4160 if (u
->op
== INTRINSIC_USER
)
4162 gfc_error ("User operator '%s' referenced at %L not found "
4163 "in module '%s'", u
->use_name
, &u
->where
, module_name
);
4167 gfc_error ("Intrinsic operator '%s' referenced at %L not found "
4168 "in module '%s'", gfc_op2string (u
->op
), &u
->where
,
4172 gfc_check_interfaces (gfc_current_ns
);
4174 /* Clean up symbol nodes that were never loaded, create references
4175 to hidden symbols. */
4177 read_cleanup (pi_root
);
4181 /* Given an access type that is specific to an entity and the default
4182 access, return nonzero if the entity is publicly accessible. If the
4183 element is declared as PUBLIC, then it is public; if declared
4184 PRIVATE, then private, and otherwise it is public unless the default
4185 access in this context has been declared PRIVATE. */
4188 gfc_check_access (gfc_access specific_access
, gfc_access default_access
)
4190 if (specific_access
== ACCESS_PUBLIC
)
4192 if (specific_access
== ACCESS_PRIVATE
)
4195 if (gfc_option
.flag_module_private
)
4196 return default_access
== ACCESS_PUBLIC
;
4198 return default_access
!= ACCESS_PRIVATE
;
4202 /* A structure to remember which commons we've already written. */
4204 struct written_common
4206 BBT_HEADER(written_common
);
4207 const char *name
, *label
;
4210 static struct written_common
*written_commons
= NULL
;
4212 /* Comparison function used for balancing the binary tree. */
4215 compare_written_commons (void *a1
, void *b1
)
4217 const char *aname
= ((struct written_common
*) a1
)->name
;
4218 const char *alabel
= ((struct written_common
*) a1
)->label
;
4219 const char *bname
= ((struct written_common
*) b1
)->name
;
4220 const char *blabel
= ((struct written_common
*) b1
)->label
;
4221 int c
= strcmp (aname
, bname
);
4223 return (c
!= 0 ? c
: strcmp (alabel
, blabel
));
4226 /* Free a list of written commons. */
4229 free_written_common (struct written_common
*w
)
4235 free_written_common (w
->left
);
4237 free_written_common (w
->right
);
4242 /* Write a common block to the module -- recursive helper function. */
4245 write_common_0 (gfc_symtree
*st
)
4251 struct written_common
*w
;
4252 bool write_me
= true;
4257 write_common_0 (st
->left
);
4259 /* We will write out the binding label, or the name if no label given. */
4260 name
= st
->n
.common
->name
;
4262 label
= p
->is_bind_c
? p
->binding_label
: p
->name
;
4264 /* Check if we've already output this common. */
4265 w
= written_commons
;
4268 int c
= strcmp (name
, w
->name
);
4269 c
= (c
!= 0 ? c
: strcmp (label
, w
->label
));
4273 w
= (c
< 0) ? w
->left
: w
->right
;
4278 /* Write the common to the module. */
4280 mio_pool_string (&name
);
4282 mio_symbol_ref (&p
->head
);
4283 flags
= p
->saved
? 1 : 0;
4284 if (p
->threadprivate
)
4286 mio_integer (&flags
);
4288 /* Write out whether the common block is bind(c) or not. */
4289 mio_integer (&(p
->is_bind_c
));
4291 mio_pool_string (&label
);
4294 /* Record that we have written this common. */
4295 w
= XCNEW (struct written_common
);
4298 gfc_insert_bbt (&written_commons
, w
, compare_written_commons
);
4301 write_common_0 (st
->right
);
4305 /* Write a common, by initializing the list of written commons, calling
4306 the recursive function write_common_0() and cleaning up afterwards. */
4309 write_common (gfc_symtree
*st
)
4311 written_commons
= NULL
;
4312 write_common_0 (st
);
4313 free_written_common (written_commons
);
4314 written_commons
= NULL
;
4318 /* Write the blank common block to the module. */
4321 write_blank_common (void)
4323 const char * name
= BLANK_COMMON_NAME
;
4325 /* TODO: Blank commons are not bind(c). The F2003 standard probably says
4326 this, but it hasn't been checked. Just making it so for now. */
4329 if (gfc_current_ns
->blank_common
.head
== NULL
)
4334 mio_pool_string (&name
);
4336 mio_symbol_ref (&gfc_current_ns
->blank_common
.head
);
4337 saved
= gfc_current_ns
->blank_common
.saved
;
4338 mio_integer (&saved
);
4340 /* Write out whether the common block is bind(c) or not. */
4341 mio_integer (&is_bind_c
);
4343 /* Write out the binding label, which is BLANK_COMMON_NAME, though
4344 it doesn't matter because the label isn't used. */
4345 mio_pool_string (&name
);
4351 /* Write equivalences to the module. */
4360 for (eq
= gfc_current_ns
->equiv
; eq
; eq
= eq
->next
)
4364 for (e
= eq
; e
; e
= e
->eq
)
4366 if (e
->module
== NULL
)
4367 e
->module
= gfc_get_string ("%s.eq.%d", module_name
, num
);
4368 mio_allocated_string (e
->module
);
4369 mio_expr (&e
->expr
);
4378 /* Write a symbol to the module. */
4381 write_symbol (int n
, gfc_symbol
*sym
)
4385 if (sym
->attr
.flavor
== FL_UNKNOWN
|| sym
->attr
.flavor
== FL_LABEL
)
4386 gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym
->name
);
4389 mio_pool_string (&sym
->name
);
4391 mio_pool_string (&sym
->module
);
4392 if (sym
->attr
.is_bind_c
|| sym
->attr
.is_iso_c
)
4394 label
= sym
->binding_label
;
4395 mio_pool_string (&label
);
4398 mio_pool_string (&sym
->name
);
4400 mio_pointer_ref (&sym
->ns
);
4407 /* Recursive traversal function to write the initial set of symbols to
4408 the module. We check to see if the symbol should be written
4409 according to the access specification. */
4412 write_symbol0 (gfc_symtree
*st
)
4416 bool dont_write
= false;
4421 write_symbol0 (st
->left
);
4424 if (sym
->module
== NULL
)
4425 sym
->module
= gfc_get_string (module_name
);
4427 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
4428 && !sym
->attr
.subroutine
&& !sym
->attr
.function
)
4431 if (!gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
))
4436 p
= get_pointer (sym
);
4437 if (p
->type
== P_UNKNOWN
)
4440 if (p
->u
.wsym
.state
!= WRITTEN
)
4442 write_symbol (p
->integer
, sym
);
4443 p
->u
.wsym
.state
= WRITTEN
;
4447 write_symbol0 (st
->right
);
4451 /* Recursive traversal function to write the secondary set of symbols
4452 to the module file. These are symbols that were not public yet are
4453 needed by the public symbols or another dependent symbol. The act
4454 of writing a symbol can modify the pointer_info tree, so we cease
4455 traversal if we find a symbol to write. We return nonzero if a
4456 symbol was written and pass that information upwards. */
4459 write_symbol1 (pointer_info
*p
)
4466 result
= write_symbol1 (p
->left
);
4468 if (!(p
->type
!= P_SYMBOL
|| p
->u
.wsym
.state
!= NEEDS_WRITE
))
4470 p
->u
.wsym
.state
= WRITTEN
;
4471 write_symbol (p
->integer
, p
->u
.wsym
.sym
);
4475 result
|= write_symbol1 (p
->right
);
4480 /* Write operator interfaces associated with a symbol. */
4483 write_operator (gfc_user_op
*uop
)
4485 static char nullstring
[] = "";
4486 const char *p
= nullstring
;
4489 || !gfc_check_access (uop
->access
, uop
->ns
->default_access
))
4492 mio_symbol_interface (&uop
->name
, &p
, &uop
->op
);
4496 /* Write generic interfaces from the namespace sym_root. */
4499 write_generic (gfc_symtree
*st
)
4506 write_generic (st
->left
);
4507 write_generic (st
->right
);
4510 if (!sym
|| check_unique_name (st
->name
))
4513 if (sym
->generic
== NULL
4514 || !gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
))
4517 if (sym
->module
== NULL
)
4518 sym
->module
= gfc_get_string (module_name
);
4520 mio_symbol_interface (&st
->name
, &sym
->module
, &sym
->generic
);
4525 write_symtree (gfc_symtree
*st
)
4531 if (!gfc_check_access (sym
->attr
.access
, sym
->ns
->default_access
)
4532 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
4533 && !sym
->attr
.subroutine
&& !sym
->attr
.function
))
4536 if (check_unique_name (st
->name
))
4539 p
= find_pointer (sym
);
4541 gfc_internal_error ("write_symtree(): Symbol not written");
4543 mio_pool_string (&st
->name
);
4544 mio_integer (&st
->ambiguous
);
4545 mio_integer (&p
->integer
);
4554 /* Write the operator interfaces. */
4557 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
4559 if (i
== INTRINSIC_USER
)
4562 mio_interface (gfc_check_access (gfc_current_ns
->operator_access
[i
],
4563 gfc_current_ns
->default_access
)
4564 ? &gfc_current_ns
->op
[i
] : NULL
);
4572 gfc_traverse_user_op (gfc_current_ns
, write_operator
);
4578 write_generic (gfc_current_ns
->sym_root
);
4584 write_blank_common ();
4585 write_common (gfc_current_ns
->common_root
);
4596 /* Write symbol information. First we traverse all symbols in the
4597 primary namespace, writing those that need to be written.
4598 Sometimes writing one symbol will cause another to need to be
4599 written. A list of these symbols ends up on the write stack, and
4600 we end by popping the bottom of the stack and writing the symbol
4601 until the stack is empty. */
4605 write_symbol0 (gfc_current_ns
->sym_root
);
4606 while (write_symbol1 (pi_root
))
4615 gfc_traverse_symtree (gfc_current_ns
->sym_root
, write_symtree
);
4620 /* Read a MD5 sum from the header of a module file. If the file cannot
4621 be opened, or we have any other error, we return -1. */
4624 read_md5_from_module_file (const char * filename
, unsigned char md5
[16])
4630 /* Open the file. */
4631 if ((file
= fopen (filename
, "r")) == NULL
)
4634 /* Read two lines. */
4635 if (fgets (buf
, sizeof (buf
) - 1, file
) == NULL
4636 || fgets (buf
, sizeof (buf
) - 1, file
) == NULL
)
4642 /* Close the file. */
4645 /* If the header is not what we expect, or is too short, bail out. */
4646 if (strncmp (buf
, "MD5:", 4) != 0 || strlen (buf
) < 4 + 16)
4649 /* Now, we have a real MD5, read it into the array. */
4650 for (n
= 0; n
< 16; n
++)
4654 if (sscanf (&(buf
[4+2*n
]), "%02x", &x
) != 1)
4664 /* Given module, dump it to disk. If there was an error while
4665 processing the module, dump_flag will be set to zero and we delete
4666 the module file, even if it was already there. */
4669 gfc_dump_module (const char *name
, int dump_flag
)
4672 char *filename
, *filename_tmp
, *p
;
4675 unsigned char md5_new
[16], md5_old
[16];
4677 n
= strlen (name
) + strlen (MODULE_EXTENSION
) + 1;
4678 if (gfc_option
.module_dir
!= NULL
)
4680 n
+= strlen (gfc_option
.module_dir
);
4681 filename
= (char *) alloca (n
);
4682 strcpy (filename
, gfc_option
.module_dir
);
4683 strcat (filename
, name
);
4687 filename
= (char *) alloca (n
);
4688 strcpy (filename
, name
);
4690 strcat (filename
, MODULE_EXTENSION
);
4692 /* Name of the temporary file used to write the module. */
4693 filename_tmp
= (char *) alloca (n
+ 1);
4694 strcpy (filename_tmp
, filename
);
4695 strcat (filename_tmp
, "0");
4697 /* There was an error while processing the module. We delete the
4698 module file, even if it was already there. */
4705 /* Write the module to the temporary file. */
4706 module_fp
= fopen (filename_tmp
, "w");
4707 if (module_fp
== NULL
)
4708 gfc_fatal_error ("Can't open module file '%s' for writing at %C: %s",
4709 filename_tmp
, strerror (errno
));
4711 /* Write the header, including space reserved for the MD5 sum. */
4715 *strchr (p
, '\n') = '\0';
4717 fprintf (module_fp
, "GFORTRAN module created from %s on %s\nMD5:",
4718 gfc_source_file
, p
);
4719 fgetpos (module_fp
, &md5_pos
);
4720 fputs ("00000000000000000000000000000000 -- "
4721 "If you edit this, you'll get what you deserve.\n\n", module_fp
);
4723 /* Initialize the MD5 context that will be used for output. */
4724 md5_init_ctx (&ctx
);
4726 /* Write the module itself. */
4728 strcpy (module_name
, name
);
4734 free_pi_tree (pi_root
);
4739 /* Write the MD5 sum to the header of the module file. */
4740 md5_finish_ctx (&ctx
, md5_new
);
4741 fsetpos (module_fp
, &md5_pos
);
4742 for (n
= 0; n
< 16; n
++)
4743 fprintf (module_fp
, "%02x", md5_new
[n
]);
4745 if (fclose (module_fp
))
4746 gfc_fatal_error ("Error writing module file '%s' for writing: %s",
4747 filename_tmp
, strerror (errno
));
4749 /* Read the MD5 from the header of the old module file and compare. */
4750 if (read_md5_from_module_file (filename
, md5_old
) != 0
4751 || memcmp (md5_old
, md5_new
, sizeof (md5_old
)) != 0)
4753 /* Module file have changed, replace the old one. */
4755 rename (filename_tmp
, filename
);
4758 unlink (filename_tmp
);
4763 sort_iso_c_rename_list (void)
4765 gfc_use_rename
*tmp_list
= NULL
;
4766 gfc_use_rename
*curr
;
4767 gfc_use_rename
*kinds_used
[ISOCBINDING_NUMBER
] = {NULL
};
4771 for (curr
= gfc_rename_list
; curr
; curr
= curr
->next
)
4773 c_kind
= get_c_kind (curr
->use_name
, c_interop_kinds_table
);
4774 if (c_kind
== ISOCBINDING_INVALID
|| c_kind
== ISOCBINDING_LAST
)
4776 gfc_error ("Symbol '%s' referenced at %L does not exist in "
4777 "intrinsic module ISO_C_BINDING.", curr
->use_name
,
4781 /* Put it in the list. */
4782 kinds_used
[c_kind
] = curr
;
4785 /* Make a new (sorted) rename list. */
4787 while (i
< ISOCBINDING_NUMBER
&& kinds_used
[i
] == NULL
)
4790 if (i
< ISOCBINDING_NUMBER
)
4792 tmp_list
= kinds_used
[i
];
4796 for (; i
< ISOCBINDING_NUMBER
; i
++)
4797 if (kinds_used
[i
] != NULL
)
4799 curr
->next
= kinds_used
[i
];
4805 gfc_rename_list
= tmp_list
;
4809 /* Import the intrinsic ISO_C_BINDING module, generating symbols in
4810 the current namespace for all named constants, pointer types, and
4811 procedures in the module unless the only clause was used or a rename
4812 list was provided. */
4815 import_iso_c_binding_module (void)
4817 gfc_symbol
*mod_sym
= NULL
;
4818 gfc_symtree
*mod_symtree
= NULL
;
4819 const char *iso_c_module_name
= "__iso_c_binding";
4824 /* Look only in the current namespace. */
4825 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, iso_c_module_name
);
4827 if (mod_symtree
== NULL
)
4829 /* symtree doesn't already exist in current namespace. */
4830 gfc_get_sym_tree (iso_c_module_name
, gfc_current_ns
, &mod_symtree
);
4832 if (mod_symtree
!= NULL
)
4833 mod_sym
= mod_symtree
->n
.sym
;
4835 gfc_internal_error ("import_iso_c_binding_module(): Unable to "
4836 "create symbol for %s", iso_c_module_name
);
4838 mod_sym
->attr
.flavor
= FL_MODULE
;
4839 mod_sym
->attr
.intrinsic
= 1;
4840 mod_sym
->module
= gfc_get_string (iso_c_module_name
);
4841 mod_sym
->from_intmod
= INTMOD_ISO_C_BINDING
;
4844 /* Generate the symbols for the named constants representing
4845 the kinds for intrinsic data types. */
4848 /* Sort the rename list because there are dependencies between types
4849 and procedures (e.g., c_loc needs c_ptr). */
4850 sort_iso_c_rename_list ();
4852 for (u
= gfc_rename_list
; u
; u
= u
->next
)
4854 i
= get_c_kind (u
->use_name
, c_interop_kinds_table
);
4856 if (i
== ISOCBINDING_INVALID
|| i
== ISOCBINDING_LAST
)
4858 gfc_error ("Symbol '%s' referenced at %L does not exist in "
4859 "intrinsic module ISO_C_BINDING.", u
->use_name
,
4864 generate_isocbinding_symbol (iso_c_module_name
, i
, u
->local_name
);
4869 for (i
= 0; i
< ISOCBINDING_NUMBER
; i
++)
4872 for (u
= gfc_rename_list
; u
; u
= u
->next
)
4874 if (strcmp (c_interop_kinds_table
[i
].name
, u
->use_name
) == 0)
4876 local_name
= u
->local_name
;
4881 generate_isocbinding_symbol (iso_c_module_name
, i
, local_name
);
4884 for (u
= gfc_rename_list
; u
; u
= u
->next
)
4889 gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
4890 "module ISO_C_BINDING", u
->use_name
, &u
->where
);
4896 /* Add an integer named constant from a given module. */
4899 create_int_parameter (const char *name
, int value
, const char *modname
,
4900 intmod_id module
, int id
)
4902 gfc_symtree
*tmp_symtree
;
4905 tmp_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, name
);
4906 if (tmp_symtree
!= NULL
)
4908 if (strcmp (modname
, tmp_symtree
->n
.sym
->module
) == 0)
4911 gfc_error ("Symbol '%s' already declared", name
);
4914 gfc_get_sym_tree (name
, gfc_current_ns
, &tmp_symtree
);
4915 sym
= tmp_symtree
->n
.sym
;
4917 sym
->module
= gfc_get_string (modname
);
4918 sym
->attr
.flavor
= FL_PARAMETER
;
4919 sym
->ts
.type
= BT_INTEGER
;
4920 sym
->ts
.kind
= gfc_default_integer_kind
;
4921 sym
->value
= gfc_int_expr (value
);
4922 sym
->attr
.use_assoc
= 1;
4923 sym
->from_intmod
= module
;
4924 sym
->intmod_sym_id
= id
;
4928 /* USE the ISO_FORTRAN_ENV intrinsic module. */
4931 use_iso_fortran_env_module (void)
4933 static char mod
[] = "iso_fortran_env";
4934 const char *local_name
;
4936 gfc_symbol
*mod_sym
;
4937 gfc_symtree
*mod_symtree
;
4940 intmod_sym symbol
[] = {
4941 #define NAMED_INTCST(a,b,c,d) { a, b, 0, d },
4942 #include "iso-fortran-env.def"
4944 { ISOFORTRANENV_INVALID
, NULL
, -1234, 0 } };
4947 #define NAMED_INTCST(a,b,c,d) symbol[i++].value = c;
4948 #include "iso-fortran-env.def"
4951 /* Generate the symbol for the module itself. */
4952 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, mod
);
4953 if (mod_symtree
== NULL
)
4955 gfc_get_sym_tree (mod
, gfc_current_ns
, &mod_symtree
);
4956 gcc_assert (mod_symtree
);
4957 mod_sym
= mod_symtree
->n
.sym
;
4959 mod_sym
->attr
.flavor
= FL_MODULE
;
4960 mod_sym
->attr
.intrinsic
= 1;
4961 mod_sym
->module
= gfc_get_string (mod
);
4962 mod_sym
->from_intmod
= INTMOD_ISO_FORTRAN_ENV
;
4965 if (!mod_symtree
->n
.sym
->attr
.intrinsic
)
4966 gfc_error ("Use of intrinsic module '%s' at %C conflicts with "
4967 "non-intrinsic module name used previously", mod
);
4969 /* Generate the symbols for the module integer named constants. */
4971 for (u
= gfc_rename_list
; u
; u
= u
->next
)
4973 for (i
= 0; symbol
[i
].name
; i
++)
4974 if (strcmp (symbol
[i
].name
, u
->use_name
) == 0)
4977 if (symbol
[i
].name
== NULL
)
4979 gfc_error ("Symbol '%s' referenced at %L does not exist in "
4980 "intrinsic module ISO_FORTRAN_ENV", u
->use_name
,
4985 if ((gfc_option
.flag_default_integer
|| gfc_option
.flag_default_real
)
4986 && symbol
[i
].id
== ISOFORTRANENV_NUMERIC_STORAGE_SIZE
)
4987 gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
4988 "from intrinsic module ISO_FORTRAN_ENV at %L is "
4989 "incompatible with option %s", &u
->where
,
4990 gfc_option
.flag_default_integer
4991 ? "-fdefault-integer-8" : "-fdefault-real-8");
4993 create_int_parameter (u
->local_name
[0] ? u
->local_name
4995 symbol
[i
].value
, mod
, INTMOD_ISO_FORTRAN_ENV
,
5000 for (i
= 0; symbol
[i
].name
; i
++)
5003 for (u
= gfc_rename_list
; u
; u
= u
->next
)
5005 if (strcmp (symbol
[i
].name
, u
->use_name
) == 0)
5007 local_name
= u
->local_name
;
5013 if ((gfc_option
.flag_default_integer
|| gfc_option
.flag_default_real
)
5014 && symbol
[i
].id
== ISOFORTRANENV_NUMERIC_STORAGE_SIZE
)
5015 gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
5016 "from intrinsic module ISO_FORTRAN_ENV at %C is "
5017 "incompatible with option %s",
5018 gfc_option
.flag_default_integer
5019 ? "-fdefault-integer-8" : "-fdefault-real-8");
5021 create_int_parameter (local_name
? local_name
: symbol
[i
].name
,
5022 symbol
[i
].value
, mod
, INTMOD_ISO_FORTRAN_ENV
,
5026 for (u
= gfc_rename_list
; u
; u
= u
->next
)
5031 gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
5032 "module ISO_FORTRAN_ENV", u
->use_name
, &u
->where
);
5038 /* Process a USE directive. */
5041 gfc_use_module (void)
5046 gfc_symtree
*mod_symtree
;
5047 gfc_use_list
*use_stmt
;
5049 filename
= (char *) alloca (strlen (module_name
) + strlen (MODULE_EXTENSION
)
5051 strcpy (filename
, module_name
);
5052 strcat (filename
, MODULE_EXTENSION
);
5054 /* First, try to find an non-intrinsic module, unless the USE statement
5055 specified that the module is intrinsic. */
5058 module_fp
= gfc_open_included_file (filename
, true, true);
5060 /* Then, see if it's an intrinsic one, unless the USE statement
5061 specified that the module is non-intrinsic. */
5062 if (module_fp
== NULL
&& !specified_nonint
)
5064 if (strcmp (module_name
, "iso_fortran_env") == 0
5065 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: ISO_FORTRAN_ENV "
5066 "intrinsic module at %C") != FAILURE
)
5068 use_iso_fortran_env_module ();
5072 if (strcmp (module_name
, "iso_c_binding") == 0
5073 && gfc_notify_std (GFC_STD_F2003
, "Fortran 2003: "
5074 "ISO_C_BINDING module at %C") != FAILURE
)
5076 import_iso_c_binding_module();
5080 module_fp
= gfc_open_intrinsic_module (filename
);
5082 if (module_fp
== NULL
&& specified_int
)
5083 gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C",
5087 if (module_fp
== NULL
)
5088 gfc_fatal_error ("Can't open module file '%s' for reading at %C: %s",
5089 filename
, strerror (errno
));
5091 /* Check that we haven't already USEd an intrinsic module with the
5094 mod_symtree
= gfc_find_symtree (gfc_current_ns
->sym_root
, module_name
);
5095 if (mod_symtree
&& mod_symtree
->n
.sym
->attr
.intrinsic
)
5096 gfc_error ("Use of non-intrinsic module '%s' at %C conflicts with "
5097 "intrinsic module name used previously", module_name
);
5104 /* Skip the first two lines of the module, after checking that this is
5105 a gfortran module file. */
5111 bad_module ("Unexpected end of module");
5114 if ((start
== 1 && strcmp (atom_name
, "GFORTRAN") != 0)
5115 || (start
== 2 && strcmp (atom_name
, " module") != 0))
5116 gfc_fatal_error ("File '%s' opened at %C is not a GFORTRAN module "
5123 /* Make sure we're not reading the same module that we may be building. */
5124 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
5125 if (p
->state
== COMP_MODULE
&& strcmp (p
->sym
->name
, module_name
) == 0)
5126 gfc_fatal_error ("Can't USE the same module we're building!");
5129 init_true_name_tree ();
5133 free_true_name (true_name_root
);
5134 true_name_root
= NULL
;
5136 free_pi_tree (pi_root
);
5141 use_stmt
= gfc_get_use_list ();
5142 use_stmt
->module_name
= gfc_get_string (module_name
);
5143 use_stmt
->only_flag
= only_flag
;
5144 use_stmt
->rename
= gfc_rename_list
;
5145 gfc_rename_list
= NULL
;
5146 use_stmt
->next
= gfc_current_ns
->use_stmts
;
5147 gfc_current_ns
->use_stmts
= use_stmt
;
5152 gfc_free_use_stmts (gfc_use_list
*use_stmts
)
5155 for (; use_stmts
; use_stmts
= next
)
5157 gfc_use_rename
*next_rename
;
5159 for (; use_stmts
->rename
; use_stmts
->rename
= next_rename
)
5161 next_rename
= use_stmts
->rename
->next
;
5162 gfc_free (use_stmts
->rename
);
5164 next
= use_stmts
->next
;
5165 gfc_free (use_stmts
);
5171 gfc_module_init_2 (void)
5173 last_atom
= ATOM_LPAREN
;
5178 gfc_module_done_2 (void)