1 /* Handle modules, which amounts to loading and saving symbols and
2 their attendant structures.
3 Copyright (C) 2000, 2001, 2002, 2003, 2004 Free Software Foundation,
5 Contributed by Andy Vaught
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 2, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING. If not, write to the Free
21 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
24 /* The syntax of gfortran modules resembles that of lisp lists, ie a
25 sequence of atoms, which can be left or right parenthesis, names,
26 integers or strings. Parenthesis are always matched which allows
27 us to skip over sections at high speed without having to know
28 anything about the internal structure of the lists. A "name" is
29 usually a fortran 95 identifier, but can also start with '@' in
30 order to reference a hidden symbol.
32 The first line of a module is an informational message about what
33 created the module, the file it came from and when it was created.
34 The second line is a warning for people not to edit the module.
35 The rest of the module looks like:
37 ( ( <Interface info for UPLUS> )
38 ( <Interface info for UMINUS> )
41 ( ( <name of operator interface> <module of op interface> <i/f1> ... )
44 ( ( <name of generic interface> <module of generic interface> <i/f1> ... )
47 ( ( <common name> <symbol> <saved flag>)
50 ( <Symbol Number (in no particular order)>
52 <Module name of symbol>
53 ( <symbol information> )
62 In general, symbols refer to other symbols by their symbol number,
63 which are zero based. Symbols are written to the module in no
76 #include "parse.h" /* FIXME */
78 #define MODULE_EXTENSION ".mod"
81 /* Structure that descibes a position within a module file */
93 P_UNKNOWN
= 0, P_OTHER
, P_NAMESPACE
, P_COMPONENT
, P_SYMBOL
97 /* The fixup structure lists pointers to pointers that have to
98 be updated when a pointer value becomes known. */
100 typedef struct fixup_t
103 struct fixup_t
*next
;
108 /* Structure for holding extra info needed for pointers being read */
110 typedef struct pointer_info
112 BBT_HEADER (pointer_info
);
116 /* The first component of each member of the union is the pointer
123 void *pointer
; /* Member for doing pointer searches */
128 char true_name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[GFC_MAX_SYMBOL_LEN
+ 1];
130 { UNUSED
, NEEDED
, USED
}
135 gfc_symtree
*symtree
;
143 { UNREFERENCED
= 0, NEEDS_WRITE
, WRITTEN
}
153 #define gfc_get_pointer_info() gfc_getmem(sizeof(pointer_info))
156 /* Lists of rename info for the USE statement */
158 typedef struct gfc_use_rename
160 char local_name
[GFC_MAX_SYMBOL_LEN
+ 1], use_name
[GFC_MAX_SYMBOL_LEN
+ 1];
161 struct gfc_use_rename
*next
;
163 gfc_intrinsic_op
operator;
168 #define gfc_get_use_rename() gfc_getmem(sizeof(gfc_use_rename))
170 /* Local variables */
172 /* The FILE for the module we're reading or writing. */
173 static FILE *module_fp
;
175 /* The name of the module we're reading (USE'ing) or writing. */
176 static char module_name
[GFC_MAX_SYMBOL_LEN
+ 1];
178 static int module_line
, module_column
, only_flag
;
180 { IO_INPUT
, IO_OUTPUT
}
183 static gfc_use_rename
*gfc_rename_list
;
184 static pointer_info
*pi_root
;
185 static int symbol_number
; /* Counter for assigning symbol numbers */
189 /*****************************************************************/
191 /* Pointer/integer conversion. Pointers between structures are stored
192 as integers in the module file. The next couple of subroutines
193 handle this translation for reading and writing. */
195 /* Recursively free the tree of pointer structures. */
198 free_pi_tree (pointer_info
* p
)
204 if (p
->fixup
!= NULL
)
205 gfc_internal_error ("free_pi_tree(): Unresolved fixup");
207 free_pi_tree (p
->left
);
208 free_pi_tree (p
->right
);
214 /* Compare pointers when searching by pointer. Used when writing a
218 compare_pointers (void * _sn1
, void * _sn2
)
220 pointer_info
*sn1
, *sn2
;
222 sn1
= (pointer_info
*) _sn1
;
223 sn2
= (pointer_info
*) _sn2
;
225 if (sn1
->u
.pointer
< sn2
->u
.pointer
)
227 if (sn1
->u
.pointer
> sn2
->u
.pointer
)
234 /* Compare integers when searching by integer. Used when reading a
238 compare_integers (void * _sn1
, void * _sn2
)
240 pointer_info
*sn1
, *sn2
;
242 sn1
= (pointer_info
*) _sn1
;
243 sn2
= (pointer_info
*) _sn2
;
245 if (sn1
->integer
< sn2
->integer
)
247 if (sn1
->integer
> sn2
->integer
)
254 /* Initialize the pointer_info tree. */
263 compare
= (iomode
== IO_INPUT
) ? compare_integers
: compare_pointers
;
265 /* Pointer 0 is the NULL pointer. */
266 p
= gfc_get_pointer_info ();
271 gfc_insert_bbt (&pi_root
, p
, compare
);
273 /* Pointer 1 is the current namespace. */
274 p
= gfc_get_pointer_info ();
275 p
->u
.pointer
= gfc_current_ns
;
277 p
->type
= P_NAMESPACE
;
279 gfc_insert_bbt (&pi_root
, p
, compare
);
285 /* During module writing, call here with a pointer to something,
286 returning the pointer_info node. */
288 static pointer_info
*
289 find_pointer (void *gp
)
296 if (p
->u
.pointer
== gp
)
298 p
= (gp
< p
->u
.pointer
) ? p
->left
: p
->right
;
305 /* Given a pointer while writing, returns the pointer_info tree node,
306 creating it if it doesn't exist. */
308 static pointer_info
*
309 get_pointer (void *gp
)
313 p
= find_pointer (gp
);
317 /* Pointer doesn't have an integer. Give it one. */
318 p
= gfc_get_pointer_info ();
321 p
->integer
= symbol_number
++;
323 gfc_insert_bbt (&pi_root
, p
, compare_pointers
);
329 /* Given an integer during reading, find it in the pointer_info tree,
330 creating the node if not found. */
332 static pointer_info
*
333 get_integer (int integer
)
343 c
= compare_integers (&t
, p
);
347 p
= (c
< 0) ? p
->left
: p
->right
;
353 p
= gfc_get_pointer_info ();
354 p
->integer
= integer
;
357 gfc_insert_bbt (&pi_root
, p
, compare_integers
);
363 /* Recursive function to find a pointer within a tree by brute force. */
365 static pointer_info
*
366 fp2 (pointer_info
* p
, const void *target
)
373 if (p
->u
.pointer
== target
)
376 q
= fp2 (p
->left
, target
);
380 return fp2 (p
->right
, target
);
384 /* During reading, find a pointer_info node from the pointer value.
385 This amounts to a brute-force search. */
387 static pointer_info
*
388 find_pointer2 (void *p
)
391 return fp2 (pi_root
, p
);
395 /* Resolve any fixups using a known pointer. */
397 resolve_fixups (fixup_t
*f
, void * gp
)
409 /* Call here during module reading when we know what pointer to
410 associate with an integer. Any fixups that exist are resolved at
414 associate_integer_pointer (pointer_info
* p
, void *gp
)
416 if (p
->u
.pointer
!= NULL
)
417 gfc_internal_error ("associate_integer_pointer(): Already associated");
421 resolve_fixups (p
->fixup
, gp
);
427 /* During module reading, given an integer and a pointer to a pointer,
428 either store the pointer from an already-known value or create a
429 fixup structure in order to store things later. Returns zero if
430 the reference has been actually stored, or nonzero if the reference
431 must be fixed later (ie associate_integer_pointer must be called
432 sometime later. Returns the pointer_info structure. */
434 static pointer_info
*
435 add_fixup (int integer
, void *gp
)
441 p
= get_integer (integer
);
443 if (p
->integer
== 0 || p
->u
.pointer
!= NULL
)
450 f
= gfc_getmem (sizeof (fixup_t
));
462 /*****************************************************************/
464 /* Parser related subroutines */
466 /* Free the rename list left behind by a USE statement. */
471 gfc_use_rename
*next
;
473 for (; gfc_rename_list
; gfc_rename_list
= next
)
475 next
= gfc_rename_list
->next
;
476 gfc_free (gfc_rename_list
);
481 /* Match a USE statement. */
486 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
487 gfc_use_rename
*tail
= NULL
, *new;
489 gfc_intrinsic_op
operator;
492 m
= gfc_match_name (module_name
);
499 if (gfc_match_eos () == MATCH_YES
)
501 if (gfc_match_char (',') != MATCH_YES
)
504 if (gfc_match (" only :") == MATCH_YES
)
507 if (gfc_match_eos () == MATCH_YES
)
512 /* Get a new rename struct and add it to the rename list. */
513 new = gfc_get_use_rename ();
514 new->where
= gfc_current_locus
;
517 if (gfc_rename_list
== NULL
)
518 gfc_rename_list
= new;
523 /* See what kind of interface we're dealing with. Assume it is
525 new->operator = INTRINSIC_NONE
;
526 if (gfc_match_generic_spec (&type
, name
, &operator) == MATCH_ERROR
)
531 case INTERFACE_NAMELESS
:
532 gfc_error ("Missing generic specification in USE statement at %C");
535 case INTERFACE_GENERIC
:
536 m
= gfc_match (" =>");
541 strcpy (new->use_name
, name
);
544 strcpy (new->local_name
, name
);
546 m
= gfc_match_name (new->use_name
);
549 if (m
== MATCH_ERROR
)
557 strcpy (new->local_name
, name
);
559 m
= gfc_match_name (new->use_name
);
562 if (m
== MATCH_ERROR
)
568 case INTERFACE_USER_OP
:
569 strcpy (new->use_name
, name
);
572 case INTERFACE_INTRINSIC_OP
:
573 new->operator = operator;
577 if (gfc_match_eos () == MATCH_YES
)
579 if (gfc_match_char (',') != MATCH_YES
)
586 gfc_syntax_error (ST_USE
);
594 /* Given a name, return the name under which to load this symbol.
595 Returns NULL if this symbol shouldn't be loaded. */
598 find_use_name (const char *name
)
602 for (u
= gfc_rename_list
; u
; u
= u
->next
)
603 if (strcmp (u
->use_name
, name
) == 0)
607 return only_flag
? NULL
: name
;
611 return (u
->local_name
[0] != '\0') ? u
->local_name
: name
;
615 /* Try to find the operator in the current list. */
617 static gfc_use_rename
*
618 find_use_operator (gfc_intrinsic_op
operator)
622 for (u
= gfc_rename_list
; u
; u
= u
->next
)
623 if (u
->operator == operator)
630 /*****************************************************************/
632 /* The next couple of subroutines maintain a tree used to avoid a
633 brute-force search for a combination of true name and module name.
634 While symtree names, the name that a particular symbol is known by
635 can changed with USE statements, we still have to keep track of the
636 true names to generate the correct reference, and also avoid
637 loading the same real symbol twice in a program unit.
639 When we start reading, the true name tree is built and maintained
640 as symbols are read. The tree is searched as we load new symbols
641 to see if it already exists someplace in the namespace. */
643 typedef struct true_name
645 BBT_HEADER (true_name
);
650 static true_name
*true_name_root
;
653 /* Compare two true_name structures. */
656 compare_true_names (void * _t1
, void * _t2
)
661 t1
= (true_name
*) _t1
;
662 t2
= (true_name
*) _t2
;
664 c
= strcmp (t1
->sym
->module
, t2
->sym
->module
);
668 return strcmp (t1
->sym
->name
, t2
->sym
->name
);
672 /* Given a true name, search the true name tree to see if it exists
673 within the main namespace. */
676 find_true_name (const char *name
, const char *module
)
682 strcpy (sym
.name
, name
);
683 strcpy (sym
.module
, module
);
689 c
= compare_true_names ((void *)(&t
), (void *) p
);
693 p
= (c
< 0) ? p
->left
: p
->right
;
700 /* Given a gfc_symbol pointer that is not in the true name tree, add
704 add_true_name (gfc_symbol
* sym
)
708 t
= gfc_getmem (sizeof (true_name
));
711 gfc_insert_bbt (&true_name_root
, t
, compare_true_names
);
715 /* Recursive function to build the initial true name tree by
716 recursively traversing the current namespace. */
719 build_tnt (gfc_symtree
* st
)
725 build_tnt (st
->left
);
726 build_tnt (st
->right
);
728 if (find_true_name (st
->n
.sym
->name
, st
->n
.sym
->module
) != NULL
)
731 add_true_name (st
->n
.sym
);
735 /* Initialize the true name tree with the current namespace. */
738 init_true_name_tree (void)
740 true_name_root
= NULL
;
742 build_tnt (gfc_current_ns
->sym_root
);
746 /* Recursively free a true name tree node. */
749 free_true_name (true_name
* t
)
754 free_true_name (t
->left
);
755 free_true_name (t
->right
);
761 /*****************************************************************/
763 /* Module reading and writing. */
767 ATOM_NAME
, ATOM_LPAREN
, ATOM_RPAREN
, ATOM_INTEGER
, ATOM_STRING
771 static atom_type last_atom
;
774 /* The name buffer must be at least as long as a symbol name. Right
775 now it's not clear how we're going to store numeric constants--
776 probably as a hexadecimal string, since this will allow the exact
777 number to be preserved (this can't be done by a decimal
778 representation). Worry about that later. TODO! */
780 #define MAX_ATOM_SIZE 100
783 static char *atom_string
, atom_name
[MAX_ATOM_SIZE
];
786 /* Report problems with a module. Error reporting is not very
787 elaborate, since this sorts of errors shouldn't really happen.
788 This subroutine never returns. */
790 static void bad_module (const char *) ATTRIBUTE_NORETURN
;
793 bad_module (const char *message
)
812 gfc_fatal_error ("%s module %s at line %d column %d: %s", p
,
813 module_name
, module_line
, module_column
, message
);
817 /* Set the module's input pointer. */
820 set_module_locus (module_locus
* m
)
823 module_column
= m
->column
;
824 module_line
= m
->line
;
825 fsetpos (module_fp
, &m
->pos
);
829 /* Get the module's input pointer so that we can restore it later. */
832 get_module_locus (module_locus
* m
)
835 m
->column
= module_column
;
836 m
->line
= module_line
;
837 fgetpos (module_fp
, &m
->pos
);
841 /* Get the next character in the module, updating our reckoning of
849 c
= fgetc (module_fp
);
852 bad_module ("Unexpected EOF");
865 /* Parse a string constant. The delimiter is guaranteed to be a
875 get_module_locus (&start
);
879 /* See how long the string is */
884 bad_module ("Unexpected end of module in string constant");
902 set_module_locus (&start
);
904 atom_string
= p
= gfc_getmem (len
+ 1);
906 for (; len
> 0; len
--)
910 module_char (); /* Guaranteed to be another \' */
914 module_char (); /* Terminating \' */
915 *p
= '\0'; /* C-style string for debug purposes */
919 /* Parse a small integer. */
922 parse_integer (int c
)
930 get_module_locus (&m
);
936 atom_int
= 10 * atom_int
+ c
- '0';
937 if (atom_int
> 99999999)
938 bad_module ("Integer overflow");
941 set_module_locus (&m
);
959 get_module_locus (&m
);
964 if (!ISALNUM (c
) && c
!= '_' && c
!= '-')
968 if (++len
> GFC_MAX_SYMBOL_LEN
)
969 bad_module ("Name too long");
974 fseek (module_fp
, -1, SEEK_CUR
);
975 module_column
= m
.column
+ len
- 1;
982 /* Read the next atom in the module's input stream. */
993 while (c
== ' ' || c
== '\n');
1018 return ATOM_INTEGER
;
1076 bad_module ("Bad name");
1083 /* Peek at the next atom on the input. */
1091 get_module_locus (&m
);
1094 if (a
== ATOM_STRING
)
1095 gfc_free (atom_string
);
1097 set_module_locus (&m
);
1102 /* Read the next atom from the input, requiring that it be a
1106 require_atom (atom_type type
)
1112 get_module_locus (&m
);
1120 p
= "Expected name";
1123 p
= "Expected left parenthesis";
1126 p
= "Expected right parenthesis";
1129 p
= "Expected integer";
1132 p
= "Expected string";
1135 gfc_internal_error ("require_atom(): bad atom type required");
1138 set_module_locus (&m
);
1144 /* Given a pointer to an mstring array, require that the current input
1145 be one of the strings in the array. We return the enum value. */
1148 find_enum (const mstring
* m
)
1152 i
= gfc_string2code (m
, atom_name
);
1156 bad_module ("find_enum(): Enum not found");
1162 /**************** Module output subroutines ***************************/
1164 /* Output a character to a module file. */
1167 write_char (char out
)
1170 if (fputc (out
, module_fp
) == EOF
)
1171 gfc_fatal_error ("Error writing modules file: %s", strerror (errno
));
1183 /* Write an atom to a module. The line wrapping isn't perfect, but it
1184 should work most of the time. This isn't that big of a deal, since
1185 the file really isn't meant to be read by people anyway. */
1188 write_atom (atom_type atom
, const void *v
)
1210 i
= *((const int *) v
);
1212 gfc_internal_error ("write_atom(): Writing negative integer");
1214 sprintf (buffer
, "%d", i
);
1219 gfc_internal_error ("write_atom(): Trying to write dab atom");
1225 if (atom
!= ATOM_RPAREN
)
1227 if (module_column
+ len
> 72)
1232 if (last_atom
!= ATOM_LPAREN
&& module_column
!= 1)
1237 if (atom
== ATOM_STRING
)
1242 if (atom
== ATOM_STRING
&& *p
== '\'')
1247 if (atom
== ATOM_STRING
)
1255 /***************** Mid-level I/O subroutines *****************/
1257 /* These subroutines let their caller read or write atoms without
1258 caring about which of the two is actually happening. This lets a
1259 subroutine concentrate on the actual format of the data being
1262 static void mio_expr (gfc_expr
**);
1263 static void mio_symbol_ref (gfc_symbol
**);
1264 static void mio_symtree_ref (gfc_symtree
**);
1266 /* Read or write an enumerated value. On writing, we return the input
1267 value for the convenience of callers. We avoid using an integer
1268 pointer because enums are sometimes inside bitfields. */
1271 mio_name (int t
, const mstring
* m
)
1274 if (iomode
== IO_OUTPUT
)
1275 write_atom (ATOM_NAME
, gfc_code2string (m
, t
));
1278 require_atom (ATOM_NAME
);
1285 /* Specialisation of mio_name. */
1287 #define DECL_MIO_NAME(TYPE) \
1288 static inline TYPE \
1289 MIO_NAME(TYPE) (TYPE t, const mstring * m) \
1291 return (TYPE)mio_name ((int)t, m); \
1293 #define MIO_NAME(TYPE) mio_name_##TYPE
1299 if (iomode
== IO_OUTPUT
)
1300 write_atom (ATOM_LPAREN
, NULL
);
1302 require_atom (ATOM_LPAREN
);
1310 if (iomode
== IO_OUTPUT
)
1311 write_atom (ATOM_RPAREN
, NULL
);
1313 require_atom (ATOM_RPAREN
);
1318 mio_integer (int *ip
)
1321 if (iomode
== IO_OUTPUT
)
1322 write_atom (ATOM_INTEGER
, ip
);
1325 require_atom (ATOM_INTEGER
);
1331 /* Read or write a character pointer that points to a string on the
1335 mio_allocated_string (char **sp
)
1338 if (iomode
== IO_OUTPUT
)
1339 write_atom (ATOM_STRING
, *sp
);
1342 require_atom (ATOM_STRING
);
1348 /* Read or write a string that is in static memory or inside of some
1349 already-allocated structure. */
1352 mio_internal_string (char *string
)
1355 if (iomode
== IO_OUTPUT
)
1356 write_atom (ATOM_STRING
, string
);
1359 require_atom (ATOM_STRING
);
1360 strcpy (string
, atom_string
);
1361 gfc_free (atom_string
);
1368 { AB_ALLOCATABLE
, AB_DIMENSION
, AB_EXTERNAL
, AB_INTRINSIC
, AB_OPTIONAL
,
1369 AB_POINTER
, AB_SAVE
, AB_TARGET
, AB_DUMMY
, AB_RESULT
,
1370 AB_DATA
, AB_IN_NAMELIST
, AB_IN_COMMON
,
1371 AB_FUNCTION
, AB_SUBROUTINE
, AB_SEQUENCE
, AB_ELEMENTAL
, AB_PURE
,
1372 AB_RECURSIVE
, AB_GENERIC
, AB_ALWAYS_EXPLICIT
1376 static const mstring attr_bits
[] =
1378 minit ("ALLOCATABLE", AB_ALLOCATABLE
),
1379 minit ("DIMENSION", AB_DIMENSION
),
1380 minit ("EXTERNAL", AB_EXTERNAL
),
1381 minit ("INTRINSIC", AB_INTRINSIC
),
1382 minit ("OPTIONAL", AB_OPTIONAL
),
1383 minit ("POINTER", AB_POINTER
),
1384 minit ("SAVE", AB_SAVE
),
1385 minit ("TARGET", AB_TARGET
),
1386 minit ("DUMMY", AB_DUMMY
),
1387 minit ("RESULT", AB_RESULT
),
1388 minit ("DATA", AB_DATA
),
1389 minit ("IN_NAMELIST", AB_IN_NAMELIST
),
1390 minit ("IN_COMMON", AB_IN_COMMON
),
1391 minit ("FUNCTION", AB_FUNCTION
),
1392 minit ("SUBROUTINE", AB_SUBROUTINE
),
1393 minit ("SEQUENCE", AB_SEQUENCE
),
1394 minit ("ELEMENTAL", AB_ELEMENTAL
),
1395 minit ("PURE", AB_PURE
),
1396 minit ("RECURSIVE", AB_RECURSIVE
),
1397 minit ("GENERIC", AB_GENERIC
),
1398 minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT
),
1402 /* Specialisation of mio_name. */
1403 DECL_MIO_NAME(ab_attribute
)
1404 DECL_MIO_NAME(ar_type
)
1405 DECL_MIO_NAME(array_type
)
1407 DECL_MIO_NAME(expr_t
)
1408 DECL_MIO_NAME(gfc_access
)
1409 DECL_MIO_NAME(gfc_intrinsic_op
)
1410 DECL_MIO_NAME(ifsrc
)
1411 DECL_MIO_NAME(procedure_type
)
1412 DECL_MIO_NAME(ref_type
)
1413 DECL_MIO_NAME(sym_flavor
)
1414 DECL_MIO_NAME(sym_intent
)
1415 #undef DECL_MIO_NAME
1417 /* Symbol attributes are stored in list with the first three elements
1418 being the enumerated fields, while the remaining elements (if any)
1419 indicate the individual attribute bits. The access field is not
1420 saved-- it controls what symbols are exported when a module is
1424 mio_symbol_attribute (symbol_attribute
* attr
)
1430 attr
->flavor
= MIO_NAME(sym_flavor
) (attr
->flavor
, flavors
);
1431 attr
->intent
= MIO_NAME(sym_intent
) (attr
->intent
, intents
);
1432 attr
->proc
= MIO_NAME(procedure_type
) (attr
->proc
, procedures
);
1433 attr
->if_source
= MIO_NAME(ifsrc
) (attr
->if_source
, ifsrc_types
);
1435 if (iomode
== IO_OUTPUT
)
1437 if (attr
->allocatable
)
1438 MIO_NAME(ab_attribute
) (AB_ALLOCATABLE
, attr_bits
);
1439 if (attr
->dimension
)
1440 MIO_NAME(ab_attribute
) (AB_DIMENSION
, attr_bits
);
1442 MIO_NAME(ab_attribute
) (AB_EXTERNAL
, attr_bits
);
1443 if (attr
->intrinsic
)
1444 MIO_NAME(ab_attribute
) (AB_INTRINSIC
, attr_bits
);
1446 MIO_NAME(ab_attribute
) (AB_OPTIONAL
, attr_bits
);
1448 MIO_NAME(ab_attribute
) (AB_POINTER
, attr_bits
);
1450 MIO_NAME(ab_attribute
) (AB_SAVE
, attr_bits
);
1452 MIO_NAME(ab_attribute
) (AB_TARGET
, attr_bits
);
1454 MIO_NAME(ab_attribute
) (AB_DUMMY
, attr_bits
);
1456 MIO_NAME(ab_attribute
) (AB_RESULT
, attr_bits
);
1457 /* We deliberately don't preserve the "entry" flag. */
1460 MIO_NAME(ab_attribute
) (AB_DATA
, attr_bits
);
1461 if (attr
->in_namelist
)
1462 MIO_NAME(ab_attribute
) (AB_IN_NAMELIST
, attr_bits
);
1463 if (attr
->in_common
)
1464 MIO_NAME(ab_attribute
) (AB_IN_COMMON
, attr_bits
);
1467 MIO_NAME(ab_attribute
) (AB_FUNCTION
, attr_bits
);
1468 if (attr
->subroutine
)
1469 MIO_NAME(ab_attribute
) (AB_SUBROUTINE
, attr_bits
);
1471 MIO_NAME(ab_attribute
) (AB_GENERIC
, attr_bits
);
1474 MIO_NAME(ab_attribute
) (AB_SEQUENCE
, attr_bits
);
1475 if (attr
->elemental
)
1476 MIO_NAME(ab_attribute
) (AB_ELEMENTAL
, attr_bits
);
1478 MIO_NAME(ab_attribute
) (AB_PURE
, attr_bits
);
1479 if (attr
->recursive
)
1480 MIO_NAME(ab_attribute
) (AB_RECURSIVE
, attr_bits
);
1481 if (attr
->always_explicit
)
1482 MIO_NAME(ab_attribute
) (AB_ALWAYS_EXPLICIT
, attr_bits
);
1493 if (t
== ATOM_RPAREN
)
1496 bad_module ("Expected attribute bit name");
1498 switch ((ab_attribute
) find_enum (attr_bits
))
1500 case AB_ALLOCATABLE
:
1501 attr
->allocatable
= 1;
1504 attr
->dimension
= 1;
1510 attr
->intrinsic
= 1;
1533 case AB_IN_NAMELIST
:
1534 attr
->in_namelist
= 1;
1537 attr
->in_common
= 1;
1543 attr
->subroutine
= 1;
1552 attr
->elemental
= 1;
1558 attr
->recursive
= 1;
1560 case AB_ALWAYS_EXPLICIT
:
1561 attr
->always_explicit
= 1;
1569 static const mstring bt_types
[] = {
1570 minit ("INTEGER", BT_INTEGER
),
1571 minit ("REAL", BT_REAL
),
1572 minit ("COMPLEX", BT_COMPLEX
),
1573 minit ("LOGICAL", BT_LOGICAL
),
1574 minit ("CHARACTER", BT_CHARACTER
),
1575 minit ("DERIVED", BT_DERIVED
),
1576 minit ("PROCEDURE", BT_PROCEDURE
),
1577 minit ("UNKNOWN", BT_UNKNOWN
),
1583 mio_charlen (gfc_charlen
** clp
)
1589 if (iomode
== IO_OUTPUT
)
1593 mio_expr (&cl
->length
);
1598 if (peek_atom () != ATOM_RPAREN
)
1600 cl
= gfc_get_charlen ();
1601 mio_expr (&cl
->length
);
1605 cl
->next
= gfc_current_ns
->cl_list
;
1606 gfc_current_ns
->cl_list
= cl
;
1614 /* Return a symtree node with a name that is guaranteed to be unique
1615 within the namespace and corresponds to an illegal fortran name. */
1617 static gfc_symtree
*
1618 get_unique_symtree (gfc_namespace
* ns
)
1620 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1621 static int serial
= 0;
1623 sprintf (name
, "@%d", serial
++);
1624 return gfc_new_symtree (&ns
->sym_root
, name
);
1628 /* See if a name is a generated name. */
1631 check_unique_name (const char *name
)
1634 return *name
== '@';
1639 mio_typespec (gfc_typespec
* ts
)
1644 ts
->type
= MIO_NAME(bt
) (ts
->type
, bt_types
);
1646 if (ts
->type
!= BT_DERIVED
)
1647 mio_integer (&ts
->kind
);
1649 mio_symbol_ref (&ts
->derived
);
1651 mio_charlen (&ts
->cl
);
1657 static const mstring array_spec_types
[] = {
1658 minit ("EXPLICIT", AS_EXPLICIT
),
1659 minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE
),
1660 minit ("DEFERRED", AS_DEFERRED
),
1661 minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE
),
1667 mio_array_spec (gfc_array_spec
** asp
)
1674 if (iomode
== IO_OUTPUT
)
1682 if (peek_atom () == ATOM_RPAREN
)
1688 *asp
= as
= gfc_get_array_spec ();
1691 mio_integer (&as
->rank
);
1692 as
->type
= MIO_NAME(array_type
) (as
->type
, array_spec_types
);
1694 for (i
= 0; i
< as
->rank
; i
++)
1696 mio_expr (&as
->lower
[i
]);
1697 mio_expr (&as
->upper
[i
]);
1705 /* Given a pointer to an array reference structure (which lives in a
1706 gfc_ref structure), find the corresponding array specification
1707 structure. Storing the pointer in the ref structure doesn't quite
1708 work when loading from a module. Generating code for an array
1709 reference also needs more infomation than just the array spec. */
1711 static const mstring array_ref_types
[] = {
1712 minit ("FULL", AR_FULL
),
1713 minit ("ELEMENT", AR_ELEMENT
),
1714 minit ("SECTION", AR_SECTION
),
1719 mio_array_ref (gfc_array_ref
* ar
)
1724 ar
->type
= MIO_NAME(ar_type
) (ar
->type
, array_ref_types
);
1725 mio_integer (&ar
->dimen
);
1733 for (i
= 0; i
< ar
->dimen
; i
++)
1734 mio_expr (&ar
->start
[i
]);
1739 for (i
= 0; i
< ar
->dimen
; i
++)
1741 mio_expr (&ar
->start
[i
]);
1742 mio_expr (&ar
->end
[i
]);
1743 mio_expr (&ar
->stride
[i
]);
1749 gfc_internal_error ("mio_array_ref(): Unknown array ref");
1752 for (i
= 0; i
< ar
->dimen
; i
++)
1753 mio_integer ((int *) &ar
->dimen_type
[i
]);
1755 if (iomode
== IO_INPUT
)
1757 ar
->where
= gfc_current_locus
;
1759 for (i
= 0; i
< ar
->dimen
; i
++)
1760 ar
->c_where
[i
] = gfc_current_locus
;
1767 /* Saves or restores a pointer. The pointer is converted back and
1768 forth from an integer. We return the pointer_info pointer so that
1769 the caller can take additional action based on the pointer type. */
1771 static pointer_info
*
1772 mio_pointer_ref (void *gp
)
1776 if (iomode
== IO_OUTPUT
)
1778 p
= get_pointer (*((char **) gp
));
1779 write_atom (ATOM_INTEGER
, &p
->integer
);
1783 require_atom (ATOM_INTEGER
);
1784 p
= add_fixup (atom_int
, gp
);
1791 /* Save and load references to components that occur within
1792 expressions. We have to describe these references by a number and
1793 by name. The number is necessary for forward references during
1794 reading, and the name is necessary if the symbol already exists in
1795 the namespace and is not loaded again. */
1798 mio_component_ref (gfc_component
** cp
, gfc_symbol
* sym
)
1800 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1804 p
= mio_pointer_ref (cp
);
1805 if (p
->type
== P_UNKNOWN
)
1806 p
->type
= P_COMPONENT
;
1808 if (iomode
== IO_OUTPUT
)
1809 mio_internal_string ((*cp
)->name
);
1812 mio_internal_string (name
);
1814 if (sym
->components
!= NULL
&& p
->u
.pointer
== NULL
)
1816 /* Symbol already loaded, so search by name. */
1817 for (q
= sym
->components
; q
; q
= q
->next
)
1818 if (strcmp (q
->name
, name
) == 0)
1822 gfc_internal_error ("mio_component_ref(): Component not found");
1824 associate_integer_pointer (p
, q
);
1827 /* Make sure this symbol will eventually be loaded. */
1828 p
= find_pointer2 (sym
);
1829 if (p
->u
.rsym
.state
== UNUSED
)
1830 p
->u
.rsym
.state
= NEEDED
;
1836 mio_component (gfc_component
* c
)
1843 if (iomode
== IO_OUTPUT
)
1845 p
= get_pointer (c
);
1846 mio_integer (&p
->integer
);
1851 p
= get_integer (n
);
1852 associate_integer_pointer (p
, c
);
1855 if (p
->type
== P_UNKNOWN
)
1856 p
->type
= P_COMPONENT
;
1858 mio_internal_string (c
->name
);
1859 mio_typespec (&c
->ts
);
1860 mio_array_spec (&c
->as
);
1862 mio_integer (&c
->dimension
);
1863 mio_integer (&c
->pointer
);
1865 mio_expr (&c
->initializer
);
1871 mio_component_list (gfc_component
** cp
)
1873 gfc_component
*c
, *tail
;
1877 if (iomode
== IO_OUTPUT
)
1879 for (c
= *cp
; c
; c
= c
->next
)
1890 if (peek_atom () == ATOM_RPAREN
)
1893 c
= gfc_get_component ();
1910 mio_actual_arg (gfc_actual_arglist
* a
)
1914 mio_internal_string (a
->name
);
1915 mio_expr (&a
->expr
);
1921 mio_actual_arglist (gfc_actual_arglist
** ap
)
1923 gfc_actual_arglist
*a
, *tail
;
1927 if (iomode
== IO_OUTPUT
)
1929 for (a
= *ap
; a
; a
= a
->next
)
1939 if (peek_atom () != ATOM_LPAREN
)
1942 a
= gfc_get_actual_arglist ();
1958 /* Read and write formal argument lists. */
1961 mio_formal_arglist (gfc_symbol
* sym
)
1963 gfc_formal_arglist
*f
, *tail
;
1967 if (iomode
== IO_OUTPUT
)
1969 for (f
= sym
->formal
; f
; f
= f
->next
)
1970 mio_symbol_ref (&f
->sym
);
1975 sym
->formal
= tail
= NULL
;
1977 while (peek_atom () != ATOM_RPAREN
)
1979 f
= gfc_get_formal_arglist ();
1980 mio_symbol_ref (&f
->sym
);
1982 if (sym
->formal
== NULL
)
1995 /* Save or restore a reference to a symbol node. */
1998 mio_symbol_ref (gfc_symbol
** symp
)
2002 p
= mio_pointer_ref (symp
);
2003 if (p
->type
== P_UNKNOWN
)
2006 if (iomode
== IO_OUTPUT
)
2008 if (p
->u
.wsym
.state
== UNREFERENCED
)
2009 p
->u
.wsym
.state
= NEEDS_WRITE
;
2013 if (p
->u
.rsym
.state
== UNUSED
)
2014 p
->u
.rsym
.state
= NEEDED
;
2019 /* Save or restore a reference to a symtree node. */
2022 mio_symtree_ref (gfc_symtree
** stp
)
2027 if (iomode
== IO_OUTPUT
)
2029 mio_symbol_ref (&(*stp
)->n
.sym
);
2033 require_atom (ATOM_INTEGER
);
2034 p
= get_integer (atom_int
);
2035 if (p
->type
== P_UNKNOWN
)
2038 if (p
->u
.rsym
.state
== UNUSED
)
2039 p
->u
.rsym
.state
= NEEDED
;
2041 if (p
->u
.rsym
.symtree
!= NULL
)
2043 *stp
= p
->u
.rsym
.symtree
;
2047 f
= gfc_getmem (sizeof (fixup_t
));
2049 f
->next
= p
->u
.rsym
.stfixup
;
2050 p
->u
.rsym
.stfixup
= f
;
2052 f
->pointer
= (void **)stp
;
2058 mio_iterator (gfc_iterator
** ip
)
2064 if (iomode
== IO_OUTPUT
)
2071 if (peek_atom () == ATOM_RPAREN
)
2077 *ip
= gfc_get_iterator ();
2082 mio_expr (&iter
->var
);
2083 mio_expr (&iter
->start
);
2084 mio_expr (&iter
->end
);
2085 mio_expr (&iter
->step
);
2094 mio_constructor (gfc_constructor
** cp
)
2096 gfc_constructor
*c
, *tail
;
2100 if (iomode
== IO_OUTPUT
)
2102 for (c
= *cp
; c
; c
= c
->next
)
2105 mio_expr (&c
->expr
);
2106 mio_iterator (&c
->iterator
);
2116 while (peek_atom () != ATOM_RPAREN
)
2118 c
= gfc_get_constructor ();
2128 mio_expr (&c
->expr
);
2129 mio_iterator (&c
->iterator
);
2139 static const mstring ref_types
[] = {
2140 minit ("ARRAY", REF_ARRAY
),
2141 minit ("COMPONENT", REF_COMPONENT
),
2142 minit ("SUBSTRING", REF_SUBSTRING
),
2148 mio_ref (gfc_ref
** rp
)
2155 r
->type
= MIO_NAME(ref_type
) (r
->type
, ref_types
);
2160 mio_array_ref (&r
->u
.ar
);
2164 mio_symbol_ref (&r
->u
.c
.sym
);
2165 mio_component_ref (&r
->u
.c
.component
, r
->u
.c
.sym
);
2169 mio_expr (&r
->u
.ss
.start
);
2170 mio_expr (&r
->u
.ss
.end
);
2171 mio_charlen (&r
->u
.ss
.length
);
2180 mio_ref_list (gfc_ref
** rp
)
2182 gfc_ref
*ref
, *head
, *tail
;
2186 if (iomode
== IO_OUTPUT
)
2188 for (ref
= *rp
; ref
; ref
= ref
->next
)
2195 while (peek_atom () != ATOM_RPAREN
)
2198 head
= tail
= gfc_get_ref ();
2201 tail
->next
= gfc_get_ref ();
2215 /* Read and write an integer value. */
2218 mio_gmp_integer (mpz_t
* integer
)
2222 if (iomode
== IO_INPUT
)
2224 if (parse_atom () != ATOM_STRING
)
2225 bad_module ("Expected integer string");
2227 mpz_init (*integer
);
2228 if (mpz_set_str (*integer
, atom_string
, 10))
2229 bad_module ("Error converting integer");
2231 gfc_free (atom_string
);
2236 p
= mpz_get_str (NULL
, 10, *integer
);
2237 write_atom (ATOM_STRING
, p
);
2244 mio_gmp_real (mpfr_t
* real
)
2249 if (iomode
== IO_INPUT
)
2251 if (parse_atom () != ATOM_STRING
)
2252 bad_module ("Expected real string");
2255 mpfr_set_str (*real
, atom_string
, 16, GFC_RND_MODE
);
2256 gfc_free (atom_string
);
2261 p
= mpfr_get_str (NULL
, &exponent
, 16, 0, *real
, GFC_RND_MODE
);
2262 atom_string
= gfc_getmem (strlen (p
) + 20);
2264 sprintf (atom_string
, "0.%s@%ld", p
, exponent
);
2266 /* Fix negative numbers. */
2267 if (atom_string
[2] == '-')
2269 atom_string
[0] = '-';
2270 atom_string
[1] = '0';
2271 atom_string
[2] = '.';
2274 write_atom (ATOM_STRING
, atom_string
);
2276 gfc_free (atom_string
);
2282 /* Save and restore the shape of an array constructor. */
2285 mio_shape (mpz_t
** pshape
, int rank
)
2291 /* A NULL shape is represented by (). */
2294 if (iomode
== IO_OUTPUT
)
2306 if (t
== ATOM_RPAREN
)
2313 shape
= gfc_get_shape (rank
);
2317 for (n
= 0; n
< rank
; n
++)
2318 mio_gmp_integer (&shape
[n
]);
2324 static const mstring expr_types
[] = {
2325 minit ("OP", EXPR_OP
),
2326 minit ("FUNCTION", EXPR_FUNCTION
),
2327 minit ("CONSTANT", EXPR_CONSTANT
),
2328 minit ("VARIABLE", EXPR_VARIABLE
),
2329 minit ("SUBSTRING", EXPR_SUBSTRING
),
2330 minit ("STRUCTURE", EXPR_STRUCTURE
),
2331 minit ("ARRAY", EXPR_ARRAY
),
2332 minit ("NULL", EXPR_NULL
),
2336 /* INTRINSIC_ASSIGN is missing because it is used as an index for
2337 generic operators, not in expressions. INTRINSIC_USER is also
2338 replaced by the correct function name by the time we see it. */
2340 static const mstring intrinsics
[] =
2342 minit ("UPLUS", INTRINSIC_UPLUS
),
2343 minit ("UMINUS", INTRINSIC_UMINUS
),
2344 minit ("PLUS", INTRINSIC_PLUS
),
2345 minit ("MINUS", INTRINSIC_MINUS
),
2346 minit ("TIMES", INTRINSIC_TIMES
),
2347 minit ("DIVIDE", INTRINSIC_DIVIDE
),
2348 minit ("POWER", INTRINSIC_POWER
),
2349 minit ("CONCAT", INTRINSIC_CONCAT
),
2350 minit ("AND", INTRINSIC_AND
),
2351 minit ("OR", INTRINSIC_OR
),
2352 minit ("EQV", INTRINSIC_EQV
),
2353 minit ("NEQV", INTRINSIC_NEQV
),
2354 minit ("EQ", INTRINSIC_EQ
),
2355 minit ("NE", INTRINSIC_NE
),
2356 minit ("GT", INTRINSIC_GT
),
2357 minit ("GE", INTRINSIC_GE
),
2358 minit ("LT", INTRINSIC_LT
),
2359 minit ("LE", INTRINSIC_LE
),
2360 minit ("NOT", INTRINSIC_NOT
),
2364 /* Read and write expressions. The form "()" is allowed to indicate a
2368 mio_expr (gfc_expr
** ep
)
2376 if (iomode
== IO_OUTPUT
)
2385 MIO_NAME(expr_t
) (e
->expr_type
, expr_types
);
2391 if (t
== ATOM_RPAREN
)
2398 bad_module ("Expected expression type");
2400 e
= *ep
= gfc_get_expr ();
2401 e
->where
= gfc_current_locus
;
2402 e
->expr_type
= (expr_t
) find_enum (expr_types
);
2405 mio_typespec (&e
->ts
);
2406 mio_integer (&e
->rank
);
2408 switch (e
->expr_type
)
2411 e
->operator = MIO_NAME(gfc_intrinsic_op
) (e
->operator, intrinsics
);
2413 switch (e
->operator)
2415 case INTRINSIC_UPLUS
:
2416 case INTRINSIC_UMINUS
:
2421 case INTRINSIC_PLUS
:
2422 case INTRINSIC_MINUS
:
2423 case INTRINSIC_TIMES
:
2424 case INTRINSIC_DIVIDE
:
2425 case INTRINSIC_POWER
:
2426 case INTRINSIC_CONCAT
:
2430 case INTRINSIC_NEQV
:
2442 bad_module ("Bad operator");
2448 mio_symtree_ref (&e
->symtree
);
2449 mio_actual_arglist (&e
->value
.function
.actual
);
2451 if (iomode
== IO_OUTPUT
)
2453 mio_allocated_string (&e
->value
.function
.name
);
2454 flag
= e
->value
.function
.esym
!= NULL
;
2455 mio_integer (&flag
);
2457 mio_symbol_ref (&e
->value
.function
.esym
);
2459 write_atom (ATOM_STRING
, e
->value
.function
.isym
->name
);
2464 require_atom (ATOM_STRING
);
2465 e
->value
.function
.name
= gfc_get_string (atom_string
);
2466 gfc_free (atom_string
);
2468 mio_integer (&flag
);
2470 mio_symbol_ref (&e
->value
.function
.esym
);
2473 require_atom (ATOM_STRING
);
2474 e
->value
.function
.isym
= gfc_find_function (atom_string
);
2475 gfc_free (atom_string
);
2482 mio_symtree_ref (&e
->symtree
);
2483 mio_ref_list (&e
->ref
);
2486 case EXPR_SUBSTRING
:
2487 mio_allocated_string (&e
->value
.character
.string
);
2492 case EXPR_STRUCTURE
:
2494 mio_constructor (&e
->value
.constructor
);
2495 mio_shape (&e
->shape
, e
->rank
);
2502 mio_gmp_integer (&e
->value
.integer
);
2506 gfc_set_model_kind (e
->ts
.kind
);
2507 mio_gmp_real (&e
->value
.real
);
2511 gfc_set_model_kind (e
->ts
.kind
);
2512 mio_gmp_real (&e
->value
.complex.r
);
2513 mio_gmp_real (&e
->value
.complex.i
);
2517 mio_integer (&e
->value
.logical
);
2521 mio_integer (&e
->value
.character
.length
);
2522 mio_allocated_string (&e
->value
.character
.string
);
2526 bad_module ("Bad type in constant expression");
2539 /* Save/restore lists of gfc_interface stuctures. When loading an
2540 interface, we are really appending to the existing list of
2541 interfaces. Checking for duplicate and ambiguous interfaces has to
2542 be done later when all symbols have been loaded. */
2545 mio_interface_rest (gfc_interface
** ip
)
2547 gfc_interface
*tail
, *p
;
2549 if (iomode
== IO_OUTPUT
)
2552 for (p
= *ip
; p
; p
= p
->next
)
2553 mio_symbol_ref (&p
->sym
);
2569 if (peek_atom () == ATOM_RPAREN
)
2572 p
= gfc_get_interface ();
2573 mio_symbol_ref (&p
->sym
);
2588 /* Save/restore a nameless operator interface. */
2591 mio_interface (gfc_interface
** ip
)
2595 mio_interface_rest (ip
);
2599 /* Save/restore a named operator interface. */
2602 mio_symbol_interface (char *name
, char *module
,
2603 gfc_interface
** ip
)
2608 mio_internal_string (name
);
2609 mio_internal_string (module
);
2611 mio_interface_rest (ip
);
2616 mio_namespace_ref (gfc_namespace
** nsp
)
2621 p
= mio_pointer_ref (nsp
);
2623 if (p
->type
== P_UNKNOWN
)
2624 p
->type
= P_NAMESPACE
;
2626 if (iomode
== IO_INPUT
&& p
->integer
!= 0)
2628 ns
= (gfc_namespace
*)p
->u
.pointer
;
2631 ns
= gfc_get_namespace (NULL
);
2632 associate_integer_pointer (p
, ns
);
2640 /* Unlike most other routines, the address of the symbol node is
2641 already fixed on input and the name/module has already been filled
2645 mio_symbol (gfc_symbol
* sym
)
2647 gfc_formal_arglist
*formal
;
2651 mio_symbol_attribute (&sym
->attr
);
2652 mio_typespec (&sym
->ts
);
2654 /* Contained procedures don't have formal namespaces. Instead we output the
2655 procedure namespace. The will contain the formal arguments. */
2656 if (iomode
== IO_OUTPUT
)
2658 formal
= sym
->formal
;
2659 while (formal
&& !formal
->sym
)
2660 formal
= formal
->next
;
2663 mio_namespace_ref (&formal
->sym
->ns
);
2665 mio_namespace_ref (&sym
->formal_ns
);
2669 mio_namespace_ref (&sym
->formal_ns
);
2672 sym
->formal_ns
->proc_name
= sym
;
2677 /* Save/restore common block links */
2678 mio_symbol_ref (&sym
->common_next
);
2680 mio_formal_arglist (sym
);
2682 if (sym
->attr
.flavor
== FL_PARAMETER
)
2683 mio_expr (&sym
->value
);
2685 mio_array_spec (&sym
->as
);
2687 mio_symbol_ref (&sym
->result
);
2689 /* Note that components are always saved, even if they are supposed
2690 to be private. Component access is checked during searching. */
2692 mio_component_list (&sym
->components
);
2694 if (sym
->components
!= NULL
)
2695 sym
->component_access
=
2696 MIO_NAME(gfc_access
) (sym
->component_access
, access_types
);
2702 /************************* Top level subroutines *************************/
2704 /* Skip a list between balanced left and right parens. */
2714 switch (parse_atom ())
2725 gfc_free (atom_string
);
2737 /* Load operator interfaces from the module. Interfaces are unusual
2738 in that they attach themselves to existing symbols. */
2741 load_operator_interfaces (void)
2744 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[GFC_MAX_SYMBOL_LEN
+ 1];
2749 while (peek_atom () != ATOM_RPAREN
)
2753 mio_internal_string (name
);
2754 mio_internal_string (module
);
2756 /* Decide if we need to load this one or not. */
2757 p
= find_use_name (name
);
2760 while (parse_atom () != ATOM_RPAREN
);
2764 uop
= gfc_get_uop (p
);
2765 mio_interface_rest (&uop
->operator);
2773 /* Load interfaces from the module. Interfaces are unusual in that
2774 they attach themselves to existing symbols. */
2777 load_generic_interfaces (void)
2780 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[GFC_MAX_SYMBOL_LEN
+ 1];
2785 while (peek_atom () != ATOM_RPAREN
)
2789 mio_internal_string (name
);
2790 mio_internal_string (module
);
2792 /* Decide if we need to load this one or not. */
2793 p
= find_use_name (name
);
2795 if (p
== NULL
|| gfc_find_symbol (p
, NULL
, 0, &sym
))
2797 while (parse_atom () != ATOM_RPAREN
);
2803 gfc_get_symbol (p
, NULL
, &sym
);
2805 sym
->attr
.flavor
= FL_PROCEDURE
;
2806 sym
->attr
.generic
= 1;
2807 sym
->attr
.use_assoc
= 1;
2810 mio_interface_rest (&sym
->generic
);
2817 /* Load common blocks. */
2822 char name
[GFC_MAX_SYMBOL_LEN
+1];
2827 while (peek_atom () != ATOM_RPAREN
)
2830 mio_internal_string (name
);
2832 p
= gfc_get_common (name
, 1);
2834 mio_symbol_ref (&p
->head
);
2835 mio_integer (&p
->saved
);
2845 /* Recursive function to traverse the pointer_info tree and load a
2846 needed symbol. We return nonzero if we load a symbol and stop the
2847 traversal, because the act of loading can alter the tree. */
2850 load_needed (pointer_info
* p
)
2858 if (load_needed (p
->left
))
2860 if (load_needed (p
->right
))
2863 if (p
->type
!= P_SYMBOL
|| p
->u
.rsym
.state
!= NEEDED
)
2866 p
->u
.rsym
.state
= USED
;
2868 set_module_locus (&p
->u
.rsym
.where
);
2870 sym
= p
->u
.rsym
.sym
;
2873 q
= get_integer (p
->u
.rsym
.ns
);
2875 ns
= (gfc_namespace
*) q
->u
.pointer
;
2878 /* Create an interface namespace if necessary. These are
2879 the namespaces that hold the formal parameters of module
2882 ns
= gfc_get_namespace (NULL
);
2883 associate_integer_pointer (q
, ns
);
2886 sym
= gfc_new_symbol (p
->u
.rsym
.true_name
, ns
);
2887 strcpy (sym
->module
, p
->u
.rsym
.module
);
2889 associate_integer_pointer (p
, sym
);
2893 sym
->attr
.use_assoc
= 1;
2899 /* Recursive function for cleaning up things after a module has been
2903 read_cleanup (pointer_info
* p
)
2911 read_cleanup (p
->left
);
2912 read_cleanup (p
->right
);
2914 if (p
->type
== P_SYMBOL
&& p
->u
.rsym
.state
== USED
&& !p
->u
.rsym
.referenced
)
2916 /* Add hidden symbols to the symtree. */
2917 q
= get_integer (p
->u
.rsym
.ns
);
2918 st
= get_unique_symtree ((gfc_namespace
*) q
->u
.pointer
);
2920 st
->n
.sym
= p
->u
.rsym
.sym
;
2923 /* Fixup any symtree references. */
2924 p
->u
.rsym
.symtree
= st
;
2925 resolve_fixups (p
->u
.rsym
.stfixup
, st
);
2926 p
->u
.rsym
.stfixup
= NULL
;
2929 /* Free unused symbols. */
2930 if (p
->type
== P_SYMBOL
&& p
->u
.rsym
.state
== UNUSED
)
2931 gfc_free_symbol (p
->u
.rsym
.sym
);
2935 /* Read a module file. */
2940 module_locus operator_interfaces
, user_operators
;
2942 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2944 int ambiguous
, symbol
;
2950 get_module_locus (&operator_interfaces
); /* Skip these for now */
2953 get_module_locus (&user_operators
);
2960 /* Create the fixup nodes for all the symbols. */
2962 while (peek_atom () != ATOM_RPAREN
)
2964 require_atom (ATOM_INTEGER
);
2965 info
= get_integer (atom_int
);
2967 info
->type
= P_SYMBOL
;
2968 info
->u
.rsym
.state
= UNUSED
;
2970 mio_internal_string (info
->u
.rsym
.true_name
);
2971 mio_internal_string (info
->u
.rsym
.module
);
2973 require_atom (ATOM_INTEGER
);
2974 info
->u
.rsym
.ns
= atom_int
;
2976 get_module_locus (&info
->u
.rsym
.where
);
2979 /* See if the symbol has already been loaded by a previous module.
2980 If so, we reference the existing symbol and prevent it from
2981 being loaded again. */
2983 sym
= find_true_name (info
->u
.rsym
.true_name
, info
->u
.rsym
.module
);
2987 info
->u
.rsym
.state
= USED
;
2988 info
->u
.rsym
.referenced
= 1;
2989 info
->u
.rsym
.sym
= sym
;
2994 /* Parse the symtree lists. This lets us mark which symbols need to
2995 be loaded. Renaming is also done at this point by replacing the
3000 while (peek_atom () != ATOM_RPAREN
)
3002 mio_internal_string (name
);
3003 mio_integer (&ambiguous
);
3004 mio_integer (&symbol
);
3006 info
= get_integer (symbol
);
3008 /* Get the local name for this symbol. */
3009 p
= find_use_name (name
);
3011 /* Skip symtree nodes not in an ONLY caluse. */
3015 /* Check for ambiguous symbols. */
3016 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
3020 if (st
->n
.sym
!= info
->u
.rsym
.sym
)
3022 info
->u
.rsym
.symtree
= st
;
3026 /* Create a symtree node in the current namespace for this symbol. */
3027 st
= check_unique_name (p
) ? get_unique_symtree (gfc_current_ns
) :
3028 gfc_new_symtree (&gfc_current_ns
->sym_root
, p
);
3030 st
->ambiguous
= ambiguous
;
3032 sym
= info
->u
.rsym
.sym
;
3034 /* Create a symbol node if it doesn't already exist. */
3037 sym
= info
->u
.rsym
.sym
=
3038 gfc_new_symbol (info
->u
.rsym
.true_name
, gfc_current_ns
);
3040 strcpy (sym
->module
, info
->u
.rsym
.module
);
3046 /* Store the symtree pointing to this symbol. */
3047 info
->u
.rsym
.symtree
= st
;
3049 if (info
->u
.rsym
.state
== UNUSED
)
3050 info
->u
.rsym
.state
= NEEDED
;
3051 info
->u
.rsym
.referenced
= 1;
3057 /* Load intrinsic operator interfaces. */
3058 set_module_locus (&operator_interfaces
);
3061 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
3063 if (i
== INTRINSIC_USER
)
3068 u
= find_use_operator (i
);
3079 mio_interface (&gfc_current_ns
->operator[i
]);
3084 /* Load generic and user operator interfaces. These must follow the
3085 loading of symtree because otherwise symbols can be marked as
3088 set_module_locus (&user_operators
);
3090 load_operator_interfaces ();
3091 load_generic_interfaces ();
3095 /* At this point, we read those symbols that are needed but haven't
3096 been loaded yet. If one symbol requires another, the other gets
3097 marked as NEEDED if its previous state was UNUSED. */
3099 while (load_needed (pi_root
));
3101 /* Make sure all elements of the rename-list were found in the
3104 for (u
= gfc_rename_list
; u
; u
= u
->next
)
3109 if (u
->operator == INTRINSIC_NONE
)
3111 gfc_error ("Symbol '%s' referenced at %L not found in module '%s'",
3112 u
->use_name
, &u
->where
, module_name
);
3116 if (u
->operator == INTRINSIC_USER
)
3119 ("User operator '%s' referenced at %L not found in module '%s'",
3120 u
->use_name
, &u
->where
, module_name
);
3125 ("Intrinsic operator '%s' referenced at %L not found in module "
3126 "'%s'", gfc_op2string (u
->operator), &u
->where
, module_name
);
3129 gfc_check_interfaces (gfc_current_ns
);
3131 /* Clean up symbol nodes that were never loaded, create references
3132 to hidden symbols. */
3134 read_cleanup (pi_root
);
3138 /* Given an access type that is specific to an entity and the default
3139 access, return nonzero if we should write the entity. */
3142 check_access (gfc_access specific_access
, gfc_access default_access
)
3145 if (specific_access
== ACCESS_PUBLIC
)
3147 if (specific_access
== ACCESS_PRIVATE
)
3150 if (gfc_option
.flag_module_access_private
)
3152 if (default_access
== ACCESS_PUBLIC
)
3157 if (default_access
!= ACCESS_PRIVATE
)
3165 /* Write a common block to the module */
3168 write_common (gfc_symtree
*st
)
3175 write_common(st
->left
);
3176 write_common(st
->right
);
3179 mio_internal_string(st
->name
);
3182 mio_symbol_ref(&p
->head
);
3183 mio_integer(&p
->saved
);
3189 /* Write a symbol to the module. */
3192 write_symbol (int n
, gfc_symbol
* sym
)
3195 if (sym
->attr
.flavor
== FL_UNKNOWN
|| sym
->attr
.flavor
== FL_LABEL
)
3196 gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym
->name
);
3199 mio_internal_string (sym
->name
);
3201 if (sym
->module
[0] == '\0')
3202 strcpy (sym
->module
, module_name
);
3204 mio_internal_string (sym
->module
);
3205 mio_pointer_ref (&sym
->ns
);
3212 /* Recursive traversal function to write the initial set of symbols to
3213 the module. We check to see if the symbol should be written
3214 according to the access specification. */
3217 write_symbol0 (gfc_symtree
* st
)
3225 write_symbol0 (st
->left
);
3226 write_symbol0 (st
->right
);
3230 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
3231 && !sym
->attr
.subroutine
&& !sym
->attr
.function
)
3234 if (!check_access (sym
->attr
.access
, sym
->ns
->default_access
))
3237 p
= get_pointer (sym
);
3238 if (p
->type
== P_UNKNOWN
)
3241 if (p
->u
.wsym
.state
== WRITTEN
)
3244 write_symbol (p
->integer
, sym
);
3245 p
->u
.wsym
.state
= WRITTEN
;
3251 /* Recursive traversal function to write the secondary set of symbols
3252 to the module file. These are symbols that were not public yet are
3253 needed by the public symbols or another dependent symbol. The act
3254 of writing a symbol can modify the pointer_info tree, so we cease
3255 traversal if we find a symbol to write. We return nonzero if a
3256 symbol was written and pass that information upwards. */
3259 write_symbol1 (pointer_info
* p
)
3265 if (write_symbol1 (p
->left
))
3267 if (write_symbol1 (p
->right
))
3270 if (p
->type
!= P_SYMBOL
|| p
->u
.wsym
.state
!= NEEDS_WRITE
)
3273 p
->u
.wsym
.state
= WRITTEN
;
3274 write_symbol (p
->integer
, p
->u
.wsym
.sym
);
3280 /* Write operator interfaces associated with a symbol. */
3283 write_operator (gfc_user_op
* uop
)
3285 static char nullstring
[] = "";
3287 if (uop
->operator == NULL
3288 || !check_access (uop
->access
, uop
->ns
->default_access
))
3291 mio_symbol_interface (uop
->name
, nullstring
, &uop
->operator);
3295 /* Write generic interfaces associated with a symbol. */
3298 write_generic (gfc_symbol
* sym
)
3301 if (sym
->generic
== NULL
3302 || !check_access (sym
->attr
.access
, sym
->ns
->default_access
))
3305 mio_symbol_interface (sym
->name
, sym
->module
, &sym
->generic
);
3310 write_symtree (gfc_symtree
* st
)
3316 if (!check_access (sym
->attr
.access
, sym
->ns
->default_access
)
3317 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
3318 && !sym
->attr
.subroutine
&& !sym
->attr
.function
))
3321 if (check_unique_name (st
->name
))
3324 p
= find_pointer (sym
);
3326 gfc_internal_error ("write_symtree(): Symbol not written");
3328 mio_internal_string (st
->name
);
3329 mio_integer (&st
->ambiguous
);
3330 mio_integer (&p
->integer
);
3339 /* Write the operator interfaces. */
3342 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
3344 if (i
== INTRINSIC_USER
)
3347 mio_interface (check_access (gfc_current_ns
->operator_access
[i
],
3348 gfc_current_ns
->default_access
)
3349 ? &gfc_current_ns
->operator[i
] : NULL
);
3357 gfc_traverse_user_op (gfc_current_ns
, write_operator
);
3363 gfc_traverse_ns (gfc_current_ns
, write_generic
);
3369 write_common (gfc_current_ns
->common_root
);
3374 /* Write symbol information. First we traverse all symbols in the
3375 primary namespace, writing those that need to be written.
3376 Sometimes writing one symbol will cause another to need to be
3377 written. A list of these symbols ends up on the write stack, and
3378 we end by popping the bottom of the stack and writing the symbol
3379 until the stack is empty. */
3383 write_symbol0 (gfc_current_ns
->sym_root
);
3384 while (write_symbol1 (pi_root
));
3392 gfc_traverse_symtree (gfc_current_ns
->sym_root
, write_symtree
);
3397 /* Given module, dump it to disk. If there was an error while
3398 processing the module, dump_flag will be set to zero and we delete
3399 the module file, even if it was already there. */
3402 gfc_dump_module (const char *name
, int dump_flag
)
3404 char filename
[PATH_MAX
], *p
;
3408 if (gfc_option
.module_dir
!= NULL
)
3409 strcpy (filename
, gfc_option
.module_dir
);
3411 strcat (filename
, name
);
3412 strcat (filename
, MODULE_EXTENSION
);
3420 module_fp
= fopen (filename
, "w");
3421 if (module_fp
== NULL
)
3422 gfc_fatal_error ("Can't open module file '%s' for writing at %C: %s",
3423 filename
, strerror (errno
));
3428 *strchr (p
, '\n') = '\0';
3430 fprintf (module_fp
, "GFORTRAN module created from %s on %s\n",
3431 gfc_source_file
, p
);
3432 fputs ("If you edit this, you'll get what you deserve.\n\n", module_fp
);
3435 strcpy (module_name
, name
);
3441 free_pi_tree (pi_root
);
3446 if (fclose (module_fp
))
3447 gfc_fatal_error ("Error writing module file '%s' for writing: %s",
3448 filename
, strerror (errno
));
3452 /* Process a USE directive. */
3455 gfc_use_module (void)
3457 char filename
[GFC_MAX_SYMBOL_LEN
+ 5];
3461 strcpy (filename
, module_name
);
3462 strcat (filename
, MODULE_EXTENSION
);
3464 module_fp
= gfc_open_included_file (filename
);
3465 if (module_fp
== NULL
)
3466 gfc_fatal_error ("Can't open module file '%s' for reading at %C: %s",
3467 filename
, strerror (errno
));
3473 /* Skip the first two lines of the module. */
3474 /* FIXME: Could also check for valid two lines here, instead. */
3480 bad_module ("Unexpected end of module");
3485 /* Make sure we're not reading the same module that we may be building. */
3486 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
3487 if (p
->state
== COMP_MODULE
&& strcmp (p
->sym
->name
, module_name
) == 0)
3488 gfc_fatal_error ("Can't USE the same module we're building!");
3491 init_true_name_tree ();
3495 free_true_name (true_name_root
);
3496 true_name_root
= NULL
;
3498 free_pi_tree (pi_root
);
3506 gfc_module_init_2 (void)
3509 last_atom
= ATOM_LPAREN
;
3514 gfc_module_done_2 (void)