1 /* Handle modules, which amounts to loading and saving symbols and
2 their attendant structures.
3 Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
23 /* The syntax of g95 modules resembles that of lisp lists, ie 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 ( <Symbol Number (in no particular order)>
48 <Module name of symbol>
49 ( <symbol information> )
58 In general, symbols refer to other symbols by their symbol number,
59 which are zero based. Symbols are written to the module in no
71 #include "parse.h" /* FIXME */
73 #define MODULE_EXTENSION ".mod"
76 /* Structure that descibes a position within a module file */
88 P_UNKNOWN
= 0, P_OTHER
, P_NAMESPACE
, P_COMPONENT
, P_SYMBOL
92 /* The fixup structure lists pointers to pointers that have to
93 be updated when a pointer value becomes known. */
95 typedef struct fixup_t
103 /* Structure for holding extra info needed for pointers being read */
105 typedef struct pointer_info
107 BBT_HEADER (pointer_info
);
111 /* The first component of each member of the union is the pointer
118 void *pointer
; /* Member for doing pointer searches */
123 char true_name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[GFC_MAX_SYMBOL_LEN
+ 1];
125 { UNUSED
, NEEDED
, USED
}
130 gfc_symtree
*symtree
;
138 { UNREFERENCED
= 0, NEEDS_WRITE
, WRITTEN
}
148 #define gfc_get_pointer_info() gfc_getmem(sizeof(pointer_info))
151 /* Lists of rename info for the USE statement */
153 typedef struct gfc_use_rename
155 char local_name
[GFC_MAX_SYMBOL_LEN
+ 1], use_name
[GFC_MAX_SYMBOL_LEN
+ 1];
156 struct gfc_use_rename
*next
;
158 gfc_intrinsic_op
operator;
163 #define gfc_get_use_rename() gfc_getmem(sizeof(gfc_use_rename))
165 /* Local variables */
167 /* The FILE for the module we're reading or writing. */
168 static FILE *module_fp
;
170 /* The name of the module we're reading (USE'ing) or writing. */
171 static char module_name
[GFC_MAX_SYMBOL_LEN
+ 1];
173 static int module_line
, module_column
, only_flag
;
175 { IO_INPUT
, IO_OUTPUT
}
178 static gfc_use_rename
*gfc_rename_list
;
179 static pointer_info
*pi_root
;
180 static int symbol_number
; /* Counter for assigning symbol numbers */
184 /*****************************************************************/
186 /* Pointer/integer conversion. Pointers between structures are stored
187 as integers in the module file. The next couple of subroutines
188 handle this translation for reading and writing. */
190 /* Recursively free the tree of pointer structures. */
193 free_pi_tree (pointer_info
* p
)
199 if (p
->fixup
!= NULL
)
200 gfc_internal_error ("free_pi_tree(): Unresolved fixup");
202 free_pi_tree (p
->left
);
203 free_pi_tree (p
->right
);
209 /* Compare pointers when searching by pointer. Used when writing a
213 compare_pointers (void * _sn1
, void * _sn2
)
215 pointer_info
*sn1
, *sn2
;
217 sn1
= (pointer_info
*) _sn1
;
218 sn2
= (pointer_info
*) _sn2
;
220 if (sn1
->u
.pointer
< sn2
->u
.pointer
)
222 if (sn1
->u
.pointer
> sn2
->u
.pointer
)
229 /* Compare integers when searching by integer. Used when reading a
233 compare_integers (void * _sn1
, void * _sn2
)
235 pointer_info
*sn1
, *sn2
;
237 sn1
= (pointer_info
*) _sn1
;
238 sn2
= (pointer_info
*) _sn2
;
240 if (sn1
->integer
< sn2
->integer
)
242 if (sn1
->integer
> sn2
->integer
)
249 /* Initialize the pointer_info tree. */
258 compare
= (iomode
== IO_INPUT
) ? compare_integers
: compare_pointers
;
260 /* Pointer 0 is the NULL pointer. */
261 p
= gfc_get_pointer_info ();
266 gfc_insert_bbt (&pi_root
, p
, compare
);
268 /* Pointer 1 is the current namespace. */
269 p
= gfc_get_pointer_info ();
270 p
->u
.pointer
= gfc_current_ns
;
272 p
->type
= P_NAMESPACE
;
274 gfc_insert_bbt (&pi_root
, p
, compare
);
280 /* During module writing, call here with a pointer to something,
281 returning the pointer_info node. */
283 static pointer_info
*
284 find_pointer (void *gp
)
291 if (p
->u
.pointer
== gp
)
293 p
= (gp
< p
->u
.pointer
) ? p
->left
: p
->right
;
300 /* Given a pointer while writing, returns the pointer_info tree node,
301 creating it if it doesn't exist. */
303 static pointer_info
*
304 get_pointer (void *gp
)
308 p
= find_pointer (gp
);
312 /* Pointer doesn't have an integer. Give it one. */
313 p
= gfc_get_pointer_info ();
316 p
->integer
= symbol_number
++;
318 gfc_insert_bbt (&pi_root
, p
, compare_pointers
);
324 /* Given an integer during reading, find it in the pointer_info tree,
325 creating the node if not found. */
327 static pointer_info
*
328 get_integer (int integer
)
338 c
= compare_integers (&t
, p
);
342 p
= (c
< 0) ? p
->left
: p
->right
;
348 p
= gfc_get_pointer_info ();
349 p
->integer
= integer
;
352 gfc_insert_bbt (&pi_root
, p
, compare_integers
);
358 /* Recursive function to find a pointer within a tree by brute force. */
360 static pointer_info
*
361 fp2 (pointer_info
* p
, const void *target
)
368 if (p
->u
.pointer
== target
)
371 q
= fp2 (p
->left
, target
);
375 return fp2 (p
->right
, target
);
379 /* During reading, find a pointer_info node from the pointer value.
380 This amounts to a brute-force search. */
382 static pointer_info
*
383 find_pointer2 (void *p
)
386 return fp2 (pi_root
, p
);
390 /* Resolve any fixups using a known pointer. */
392 resolve_fixups (fixup_t
*f
, void * gp
)
404 /* Call here during module reading when we know what pointer to
405 associate with an integer. Any fixups that exist are resolved at
409 associate_integer_pointer (pointer_info
* p
, void *gp
)
411 if (p
->u
.pointer
!= NULL
)
412 gfc_internal_error ("associate_integer_pointer(): Already associated");
416 resolve_fixups (p
->fixup
, gp
);
422 /* During module reading, given an integer and a pointer to a pointer,
423 either store the pointer from an already-known value or create a
424 fixup structure in order to store things later. Returns zero if
425 the reference has been actually stored, or nonzero if the reference
426 must be fixed later (ie associate_integer_pointer must be called
427 sometime later. Returns the pointer_info structure. */
429 static pointer_info
*
430 add_fixup (int integer
, void *gp
)
436 p
= get_integer (integer
);
438 if (p
->integer
== 0 || p
->u
.pointer
!= NULL
)
445 f
= gfc_getmem (sizeof (fixup_t
));
457 /*****************************************************************/
459 /* Parser related subroutines */
461 /* Free the rename list left behind by a USE statement. */
466 gfc_use_rename
*next
;
468 for (; gfc_rename_list
; gfc_rename_list
= next
)
470 next
= gfc_rename_list
->next
;
471 gfc_free (gfc_rename_list
);
476 /* Match a USE statement. */
481 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
482 gfc_use_rename
*tail
= NULL
, *new;
484 gfc_intrinsic_op
operator;
487 m
= gfc_match_name (module_name
);
494 if (gfc_match_eos () == MATCH_YES
)
496 if (gfc_match_char (',') != MATCH_YES
)
499 if (gfc_match (" only :") == MATCH_YES
)
502 if (gfc_match_eos () == MATCH_YES
)
507 /* Get a new rename struct and add it to the rename list. */
508 new = gfc_get_use_rename ();
509 new->where
= gfc_current_locus
;
512 if (gfc_rename_list
== NULL
)
513 gfc_rename_list
= new;
518 /* See what kind of interface we're dealing with. Asusume it is
520 new->operator = INTRINSIC_NONE
;
521 if (gfc_match_generic_spec (&type
, name
, &operator) == MATCH_ERROR
)
526 case INTERFACE_NAMELESS
:
527 gfc_error ("Missing generic specification in USE statement at %C");
530 case INTERFACE_GENERIC
:
531 m
= gfc_match (" =>");
536 strcpy (new->use_name
, name
);
539 strcpy (new->local_name
, name
);
541 m
= gfc_match_name (new->use_name
);
544 if (m
== MATCH_ERROR
)
552 strcpy (new->local_name
, name
);
554 m
= gfc_match_name (new->use_name
);
557 if (m
== MATCH_ERROR
)
563 case INTERFACE_USER_OP
:
564 strcpy (new->use_name
, name
);
567 case INTERFACE_INTRINSIC_OP
:
568 new->operator = operator;
572 if (gfc_match_eos () == MATCH_YES
)
574 if (gfc_match_char (',') != MATCH_YES
)
581 gfc_syntax_error (ST_USE
);
589 /* Given a name, return the name under which to load this symbol.
590 Returns NULL if this symbol shouldn't be loaded. */
593 find_use_name (const char *name
)
597 for (u
= gfc_rename_list
; u
; u
= u
->next
)
598 if (strcmp (u
->use_name
, name
) == 0)
602 return only_flag
? NULL
: name
;
606 return (u
->local_name
[0] != '\0') ? u
->local_name
: name
;
610 /* Try to find the operator in the current list. */
612 static gfc_use_rename
*
613 find_use_operator (gfc_intrinsic_op
operator)
617 for (u
= gfc_rename_list
; u
; u
= u
->next
)
618 if (u
->operator == operator)
625 /*****************************************************************/
627 /* The next couple of subroutines maintain a tree used to avoid a
628 brute-force search for a combination of true name and module name.
629 While symtree names, the name that a particular symbol is known by
630 can changed with USE statements, we still have to keep track of the
631 true names to generate the correct reference, and also avoid
632 loading the same real symbol twice in a program unit.
634 When we start reading, the true name tree is built and maintained
635 as symbols are read. The tree is searched as we load new symbols
636 to see if it already exists someplace in the namespace. */
638 typedef struct true_name
640 BBT_HEADER (true_name
);
645 static true_name
*true_name_root
;
648 /* Compare two true_name structures. */
651 compare_true_names (void * _t1
, void * _t2
)
656 t1
= (true_name
*) _t1
;
657 t2
= (true_name
*) _t2
;
659 c
= strcmp (t1
->sym
->module
, t2
->sym
->module
);
663 return strcmp (t1
->sym
->name
, t2
->sym
->name
);
667 /* Given a true name, search the true name tree to see if it exists
668 within the main namespace. */
671 find_true_name (const char *name
, const char *module
)
677 strcpy (sym
.name
, name
);
678 strcpy (sym
.module
, module
);
684 c
= compare_true_names ((void *)(&t
), (void *) p
);
688 p
= (c
< 0) ? p
->left
: p
->right
;
695 /* Given a gfc_symbol pointer that is not in the true name tree, add
699 add_true_name (gfc_symbol
* sym
)
703 t
= gfc_getmem (sizeof (true_name
));
706 gfc_insert_bbt (&true_name_root
, t
, compare_true_names
);
710 /* Recursive function to build the initial true name tree by
711 recursively traversing the current namespace. */
714 build_tnt (gfc_symtree
* st
)
720 build_tnt (st
->left
);
721 build_tnt (st
->right
);
723 if (find_true_name (st
->n
.sym
->name
, st
->n
.sym
->module
) != NULL
)
726 add_true_name (st
->n
.sym
);
730 /* Initialize the true name tree with the current namespace. */
733 init_true_name_tree (void)
735 true_name_root
= NULL
;
737 build_tnt (gfc_current_ns
->sym_root
);
741 /* Recursively free a true name tree node. */
744 free_true_name (true_name
* t
)
749 free_true_name (t
->left
);
750 free_true_name (t
->right
);
756 /*****************************************************************/
758 /* Module reading and writing. */
762 ATOM_NAME
, ATOM_LPAREN
, ATOM_RPAREN
, ATOM_INTEGER
, ATOM_STRING
766 static atom_type last_atom
;
769 /* The name buffer must be at least as long as a symbol name. Right
770 now it's not clear how we're going to store numeric constants--
771 probably as a hexadecimal string, since this will allow the exact
772 number to be preserved (this can't be done by a decimal
773 representation). Worry about that later. TODO! */
775 #define MAX_ATOM_SIZE 100
778 static char *atom_string
, atom_name
[MAX_ATOM_SIZE
];
781 /* Report problems with a module. Error reporting is not very
782 elaborate, since this sorts of errors shouldn't really happen.
783 This subroutine never returns. */
785 static void bad_module (const char *) ATTRIBUTE_NORETURN
;
788 bad_module (const char *message
)
807 gfc_fatal_error ("%s module %s at line %d column %d: %s", p
,
808 module_name
, module_line
, module_column
, message
);
812 /* Set the module's input pointer. */
815 set_module_locus (module_locus
* m
)
818 module_column
= m
->column
;
819 module_line
= m
->line
;
820 fsetpos (module_fp
, &m
->pos
);
824 /* Get the module's input pointer so that we can restore it later. */
827 get_module_locus (module_locus
* m
)
830 m
->column
= module_column
;
831 m
->line
= module_line
;
832 fgetpos (module_fp
, &m
->pos
);
836 /* Get the next character in the module, updating our reckoning of
844 c
= fgetc (module_fp
);
847 bad_module ("Unexpected EOF");
860 /* Parse a string constant. The delimiter is guaranteed to be a
870 get_module_locus (&start
);
874 /* See how long the string is */
879 bad_module ("Unexpected end of module in string constant");
897 set_module_locus (&start
);
899 atom_string
= p
= gfc_getmem (len
+ 1);
901 for (; len
> 0; len
--)
905 module_char (); /* Guaranteed to be another \' */
909 module_char (); /* Terminating \' */
910 *p
= '\0'; /* C-style string for debug purposes */
914 /* Parse a small integer. */
917 parse_integer (int c
)
925 get_module_locus (&m
);
931 atom_int
= 10 * atom_int
+ c
- '0';
932 if (atom_int
> 99999999)
933 bad_module ("Integer overflow");
936 set_module_locus (&m
);
954 get_module_locus (&m
);
959 if (!ISALNUM (c
) && c
!= '_' && c
!= '-')
963 if (++len
> GFC_MAX_SYMBOL_LEN
)
964 bad_module ("Name too long");
969 fseek (module_fp
, -1, SEEK_CUR
);
970 module_column
= m
.column
+ len
- 1;
977 /* Read the next atom in the module's input stream. */
988 while (c
== ' ' || c
== '\n');
1013 return ATOM_INTEGER
;
1071 bad_module ("Bad name");
1078 /* Peek at the next atom on the input. */
1086 get_module_locus (&m
);
1089 if (a
== ATOM_STRING
)
1090 gfc_free (atom_string
);
1092 set_module_locus (&m
);
1097 /* Read the next atom from the input, requiring that it be a
1101 require_atom (atom_type type
)
1107 get_module_locus (&m
);
1115 p
= "Expected name";
1118 p
= "Expected left parenthesis";
1121 p
= "Expected right parenthesis";
1124 p
= "Expected integer";
1127 p
= "Expected string";
1130 gfc_internal_error ("require_atom(): bad atom type required");
1133 set_module_locus (&m
);
1139 /* Given a pointer to an mstring array, require that the current input
1140 be one of the strings in the array. We return the enum value. */
1143 find_enum (const mstring
* m
)
1147 i
= gfc_string2code (m
, atom_name
);
1151 bad_module ("find_enum(): Enum not found");
1157 /**************** Module output subroutines ***************************/
1159 /* Output a character to a module file. */
1162 write_char (char out
)
1165 if (fputc (out
, module_fp
) == EOF
)
1166 gfc_fatal_error ("Error writing modules file: %s", strerror (errno
));
1178 /* Write an atom to a module. The line wrapping isn't perfect, but it
1179 should work most of the time. This isn't that big of a deal, since
1180 the file really isn't meant to be read by people anyway. */
1183 write_atom (atom_type atom
, const void *v
)
1205 i
= *((const int *) v
);
1207 gfc_internal_error ("write_atom(): Writing negative integer");
1209 sprintf (buffer
, "%d", i
);
1214 gfc_internal_error ("write_atom(): Trying to write dab atom");
1220 if (atom
!= ATOM_RPAREN
)
1222 if (module_column
+ len
> 72)
1227 if (last_atom
!= ATOM_LPAREN
&& module_column
!= 1)
1232 if (atom
== ATOM_STRING
)
1237 if (atom
== ATOM_STRING
&& *p
== '\'')
1242 if (atom
== ATOM_STRING
)
1250 /***************** Mid-level I/O subroutines *****************/
1252 /* These subroutines let their caller read or write atoms without
1253 caring about which of the two is actually happening. This lets a
1254 subroutine concentrate on the actual format of the data being
1257 static void mio_expr (gfc_expr
**);
1258 static void mio_symbol_ref (gfc_symbol
**);
1259 static void mio_symtree_ref (gfc_symtree
**);
1261 /* Read or write an enumerated value. On writing, we return the input
1262 value for the convenience of callers. We avoid using an integer
1263 pointer because enums are sometimes inside bitfields. */
1266 mio_name (int t
, const mstring
* m
)
1269 if (iomode
== IO_OUTPUT
)
1270 write_atom (ATOM_NAME
, gfc_code2string (m
, t
));
1273 require_atom (ATOM_NAME
);
1280 /* Specialisation of mio_name. */
1282 #define DECL_MIO_NAME(TYPE) \
1283 static inline TYPE \
1284 MIO_NAME(TYPE) (TYPE t, const mstring * m) \
1286 return (TYPE)mio_name ((int)t, m); \
1288 #define MIO_NAME(TYPE) mio_name_##TYPE
1294 if (iomode
== IO_OUTPUT
)
1295 write_atom (ATOM_LPAREN
, NULL
);
1297 require_atom (ATOM_LPAREN
);
1305 if (iomode
== IO_OUTPUT
)
1306 write_atom (ATOM_RPAREN
, NULL
);
1308 require_atom (ATOM_RPAREN
);
1313 mio_integer (int *ip
)
1316 if (iomode
== IO_OUTPUT
)
1317 write_atom (ATOM_INTEGER
, ip
);
1320 require_atom (ATOM_INTEGER
);
1326 /* Read or write a character pointer that points to a string on the
1330 mio_allocated_string (char **sp
)
1333 if (iomode
== IO_OUTPUT
)
1334 write_atom (ATOM_STRING
, *sp
);
1337 require_atom (ATOM_STRING
);
1343 /* Read or write a string that is in static memory or inside of some
1344 already-allocated structure. */
1347 mio_internal_string (char *string
)
1350 if (iomode
== IO_OUTPUT
)
1351 write_atom (ATOM_STRING
, string
);
1354 require_atom (ATOM_STRING
);
1355 strcpy (string
, atom_string
);
1356 gfc_free (atom_string
);
1363 { AB_ALLOCATABLE
, AB_DIMENSION
, AB_EXTERNAL
, AB_INTRINSIC
, AB_OPTIONAL
,
1364 AB_POINTER
, AB_SAVE
, AB_TARGET
, AB_DUMMY
, AB_COMMON
, AB_RESULT
,
1365 AB_ENTRY
, AB_DATA
, AB_IN_NAMELIST
, AB_IN_COMMON
, AB_SAVED_COMMON
,
1366 AB_FUNCTION
, AB_SUBROUTINE
, AB_SEQUENCE
, AB_ELEMENTAL
, AB_PURE
,
1367 AB_RECURSIVE
, AB_GENERIC
, AB_ALWAYS_EXPLICIT
1371 static const mstring attr_bits
[] =
1373 minit ("ALLOCATABLE", AB_ALLOCATABLE
),
1374 minit ("DIMENSION", AB_DIMENSION
),
1375 minit ("EXTERNAL", AB_EXTERNAL
),
1376 minit ("INTRINSIC", AB_INTRINSIC
),
1377 minit ("OPTIONAL", AB_OPTIONAL
),
1378 minit ("POINTER", AB_POINTER
),
1379 minit ("SAVE", AB_SAVE
),
1380 minit ("TARGET", AB_TARGET
),
1381 minit ("DUMMY", AB_DUMMY
),
1382 minit ("COMMON", AB_COMMON
),
1383 minit ("RESULT", AB_RESULT
),
1384 minit ("ENTRY", AB_ENTRY
),
1385 minit ("DATA", AB_DATA
),
1386 minit ("IN_NAMELIST", AB_IN_NAMELIST
),
1387 minit ("IN_COMMON", AB_IN_COMMON
),
1388 minit ("SAVED_COMMON", AB_SAVED_COMMON
),
1389 minit ("FUNCTION", AB_FUNCTION
),
1390 minit ("SUBROUTINE", AB_SUBROUTINE
),
1391 minit ("SEQUENCE", AB_SEQUENCE
),
1392 minit ("ELEMENTAL", AB_ELEMENTAL
),
1393 minit ("PURE", AB_PURE
),
1394 minit ("RECURSIVE", AB_RECURSIVE
),
1395 minit ("GENERIC", AB_GENERIC
),
1396 minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT
),
1400 /* Specialisation of mio_name. */
1401 DECL_MIO_NAME(ab_attribute
)
1402 DECL_MIO_NAME(ar_type
)
1403 DECL_MIO_NAME(array_type
)
1405 DECL_MIO_NAME(expr_t
)
1406 DECL_MIO_NAME(gfc_access
)
1407 DECL_MIO_NAME(gfc_intrinsic_op
)
1408 DECL_MIO_NAME(ifsrc
)
1409 DECL_MIO_NAME(procedure_type
)
1410 DECL_MIO_NAME(ref_type
)
1411 DECL_MIO_NAME(sym_flavor
)
1412 DECL_MIO_NAME(sym_intent
)
1413 #undef DECL_MIO_NAME
1415 /* Symbol attributes are stored in list with the first three elements
1416 being the enumerated fields, while the remaining elements (if any)
1417 indicate the individual attribute bits. The access field is not
1418 saved-- it controls what symbols are exported when a module is
1422 mio_symbol_attribute (symbol_attribute
* attr
)
1428 attr
->flavor
= MIO_NAME(sym_flavor
) (attr
->flavor
, flavors
);
1429 attr
->intent
= MIO_NAME(sym_intent
) (attr
->intent
, intents
);
1430 attr
->proc
= MIO_NAME(procedure_type
) (attr
->proc
, procedures
);
1431 attr
->if_source
= MIO_NAME(ifsrc
) (attr
->if_source
, ifsrc_types
);
1433 if (iomode
== IO_OUTPUT
)
1435 if (attr
->allocatable
)
1436 MIO_NAME(ab_attribute
) (AB_ALLOCATABLE
, attr_bits
);
1437 if (attr
->dimension
)
1438 MIO_NAME(ab_attribute
) (AB_DIMENSION
, attr_bits
);
1440 MIO_NAME(ab_attribute
) (AB_EXTERNAL
, attr_bits
);
1441 if (attr
->intrinsic
)
1442 MIO_NAME(ab_attribute
) (AB_INTRINSIC
, attr_bits
);
1444 MIO_NAME(ab_attribute
) (AB_OPTIONAL
, attr_bits
);
1446 MIO_NAME(ab_attribute
) (AB_POINTER
, attr_bits
);
1448 MIO_NAME(ab_attribute
) (AB_SAVE
, attr_bits
);
1450 MIO_NAME(ab_attribute
) (AB_TARGET
, attr_bits
);
1452 MIO_NAME(ab_attribute
) (AB_DUMMY
, attr_bits
);
1454 MIO_NAME(ab_attribute
) (AB_COMMON
, attr_bits
);
1456 MIO_NAME(ab_attribute
) (AB_RESULT
, attr_bits
);
1458 MIO_NAME(ab_attribute
) (AB_ENTRY
, attr_bits
);
1461 MIO_NAME(ab_attribute
) (AB_DATA
, attr_bits
);
1462 if (attr
->in_namelist
)
1463 MIO_NAME(ab_attribute
) (AB_IN_NAMELIST
, attr_bits
);
1464 if (attr
->in_common
)
1465 MIO_NAME(ab_attribute
) (AB_IN_COMMON
, attr_bits
);
1466 if (attr
->saved_common
)
1467 MIO_NAME(ab_attribute
) (AB_SAVED_COMMON
, attr_bits
);
1470 MIO_NAME(ab_attribute
) (AB_FUNCTION
, attr_bits
);
1471 if (attr
->subroutine
)
1472 MIO_NAME(ab_attribute
) (AB_SUBROUTINE
, attr_bits
);
1474 MIO_NAME(ab_attribute
) (AB_GENERIC
, attr_bits
);
1477 MIO_NAME(ab_attribute
) (AB_SEQUENCE
, attr_bits
);
1478 if (attr
->elemental
)
1479 MIO_NAME(ab_attribute
) (AB_ELEMENTAL
, attr_bits
);
1481 MIO_NAME(ab_attribute
) (AB_PURE
, attr_bits
);
1482 if (attr
->recursive
)
1483 MIO_NAME(ab_attribute
) (AB_RECURSIVE
, attr_bits
);
1484 if (attr
->always_explicit
)
1485 MIO_NAME(ab_attribute
) (AB_ALWAYS_EXPLICIT
, attr_bits
);
1496 if (t
== ATOM_RPAREN
)
1499 bad_module ("Expected attribute bit name");
1501 switch ((ab_attribute
) find_enum (attr_bits
))
1503 case AB_ALLOCATABLE
:
1504 attr
->allocatable
= 1;
1507 attr
->dimension
= 1;
1513 attr
->intrinsic
= 1;
1542 case AB_IN_NAMELIST
:
1543 attr
->in_namelist
= 1;
1546 attr
->in_common
= 1;
1548 case AB_SAVED_COMMON
:
1549 attr
->saved_common
= 1;
1555 attr
->subroutine
= 1;
1564 attr
->elemental
= 1;
1570 attr
->recursive
= 1;
1572 case AB_ALWAYS_EXPLICIT
:
1573 attr
->always_explicit
= 1;
1581 static const mstring bt_types
[] = {
1582 minit ("INTEGER", BT_INTEGER
),
1583 minit ("REAL", BT_REAL
),
1584 minit ("COMPLEX", BT_COMPLEX
),
1585 minit ("LOGICAL", BT_LOGICAL
),
1586 minit ("CHARACTER", BT_CHARACTER
),
1587 minit ("DERIVED", BT_DERIVED
),
1588 minit ("PROCEDURE", BT_PROCEDURE
),
1589 minit ("UNKNOWN", BT_UNKNOWN
),
1595 mio_charlen (gfc_charlen
** clp
)
1601 if (iomode
== IO_OUTPUT
)
1605 mio_expr (&cl
->length
);
1610 if (peek_atom () != ATOM_RPAREN
)
1612 cl
= gfc_get_charlen ();
1613 mio_expr (&cl
->length
);
1617 cl
->next
= gfc_current_ns
->cl_list
;
1618 gfc_current_ns
->cl_list
= cl
;
1626 /* Return a symtree node with a name that is guaranteed to be unique
1627 within the namespace and corresponds to an illegal fortran name. */
1629 static gfc_symtree
*
1630 get_unique_symtree (gfc_namespace
* ns
)
1632 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1633 static int serial
= 0;
1635 sprintf (name
, "@%d", serial
++);
1636 return gfc_new_symtree (&ns
->sym_root
, name
);
1640 /* See if a name is a generated name. */
1643 check_unique_name (const char *name
)
1646 return *name
== '@';
1651 mio_typespec (gfc_typespec
* ts
)
1656 ts
->type
= MIO_NAME(bt
) (ts
->type
, bt_types
);
1658 if (ts
->type
!= BT_DERIVED
)
1659 mio_integer (&ts
->kind
);
1661 mio_symbol_ref (&ts
->derived
);
1663 mio_charlen (&ts
->cl
);
1669 static const mstring array_spec_types
[] = {
1670 minit ("EXPLICIT", AS_EXPLICIT
),
1671 minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE
),
1672 minit ("DEFERRED", AS_DEFERRED
),
1673 minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE
),
1679 mio_array_spec (gfc_array_spec
** asp
)
1686 if (iomode
== IO_OUTPUT
)
1694 if (peek_atom () == ATOM_RPAREN
)
1700 *asp
= as
= gfc_get_array_spec ();
1703 mio_integer (&as
->rank
);
1704 as
->type
= MIO_NAME(array_type
) (as
->type
, array_spec_types
);
1706 for (i
= 0; i
< as
->rank
; i
++)
1708 mio_expr (&as
->lower
[i
]);
1709 mio_expr (&as
->upper
[i
]);
1717 /* Given a pointer to an array reference structure (which lives in a
1718 gfc_ref structure), find the corresponding array specification
1719 structure. Storing the pointer in the ref structure doesn't quite
1720 work when loading from a module. Generating code for an array
1721 reference also needs more infomation than just the array spec. */
1723 static const mstring array_ref_types
[] = {
1724 minit ("FULL", AR_FULL
),
1725 minit ("ELEMENT", AR_ELEMENT
),
1726 minit ("SECTION", AR_SECTION
),
1731 mio_array_ref (gfc_array_ref
* ar
)
1736 ar
->type
= MIO_NAME(ar_type
) (ar
->type
, array_ref_types
);
1737 mio_integer (&ar
->dimen
);
1745 for (i
= 0; i
< ar
->dimen
; i
++)
1746 mio_expr (&ar
->start
[i
]);
1751 for (i
= 0; i
< ar
->dimen
; i
++)
1753 mio_expr (&ar
->start
[i
]);
1754 mio_expr (&ar
->end
[i
]);
1755 mio_expr (&ar
->stride
[i
]);
1761 gfc_internal_error ("mio_array_ref(): Unknown array ref");
1764 for (i
= 0; i
< ar
->dimen
; i
++)
1765 mio_integer ((int *) &ar
->dimen_type
[i
]);
1767 if (iomode
== IO_INPUT
)
1769 ar
->where
= gfc_current_locus
;
1771 for (i
= 0; i
< ar
->dimen
; i
++)
1772 ar
->c_where
[i
] = gfc_current_locus
;
1779 /* Saves or restores a pointer. The pointer is converted back and
1780 forth from an integer. We return the pointer_info pointer so that
1781 the caller can take additional action based on the pointer type. */
1783 static pointer_info
*
1784 mio_pointer_ref (void *gp
)
1788 if (iomode
== IO_OUTPUT
)
1790 p
= get_pointer (*((char **) gp
));
1791 write_atom (ATOM_INTEGER
, &p
->integer
);
1795 require_atom (ATOM_INTEGER
);
1796 p
= add_fixup (atom_int
, gp
);
1803 /* Save and load references to components that occur within
1804 expressions. We have to describe these references by a number and
1805 by name. The number is necessary for forward references during
1806 reading, and the name is necessary if the symbol already exists in
1807 the namespace and is not loaded again. */
1810 mio_component_ref (gfc_component
** cp
, gfc_symbol
* sym
)
1812 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1816 p
= mio_pointer_ref (cp
);
1817 if (p
->type
== P_UNKNOWN
)
1818 p
->type
= P_COMPONENT
;
1820 if (iomode
== IO_OUTPUT
)
1821 mio_internal_string ((*cp
)->name
);
1824 mio_internal_string (name
);
1826 if (sym
->components
!= NULL
&& p
->u
.pointer
== NULL
)
1828 /* Symbol already loaded, so search by name. */
1829 for (q
= sym
->components
; q
; q
= q
->next
)
1830 if (strcmp (q
->name
, name
) == 0)
1834 gfc_internal_error ("mio_component_ref(): Component not found");
1836 associate_integer_pointer (p
, q
);
1839 /* Make sure this symbol will eventually be loaded. */
1840 p
= find_pointer2 (sym
);
1841 if (p
->u
.rsym
.state
== UNUSED
)
1842 p
->u
.rsym
.state
= NEEDED
;
1848 mio_component (gfc_component
* c
)
1855 if (iomode
== IO_OUTPUT
)
1857 p
= get_pointer (c
);
1858 mio_integer (&p
->integer
);
1863 p
= get_integer (n
);
1864 associate_integer_pointer (p
, c
);
1867 if (p
->type
== P_UNKNOWN
)
1868 p
->type
= P_COMPONENT
;
1870 mio_internal_string (c
->name
);
1871 mio_typespec (&c
->ts
);
1872 mio_array_spec (&c
->as
);
1874 mio_integer (&c
->dimension
);
1875 mio_integer (&c
->pointer
);
1877 mio_expr (&c
->initializer
);
1883 mio_component_list (gfc_component
** cp
)
1885 gfc_component
*c
, *tail
;
1889 if (iomode
== IO_OUTPUT
)
1891 for (c
= *cp
; c
; c
= c
->next
)
1902 if (peek_atom () == ATOM_RPAREN
)
1905 c
= gfc_get_component ();
1922 mio_actual_arg (gfc_actual_arglist
* a
)
1926 mio_internal_string (a
->name
);
1927 mio_expr (&a
->expr
);
1933 mio_actual_arglist (gfc_actual_arglist
** ap
)
1935 gfc_actual_arglist
*a
, *tail
;
1939 if (iomode
== IO_OUTPUT
)
1941 for (a
= *ap
; a
; a
= a
->next
)
1951 if (peek_atom () != ATOM_LPAREN
)
1954 a
= gfc_get_actual_arglist ();
1970 /* Read and write formal argument lists. */
1973 mio_formal_arglist (gfc_symbol
* sym
)
1975 gfc_formal_arglist
*f
, *tail
;
1979 if (iomode
== IO_OUTPUT
)
1981 for (f
= sym
->formal
; f
; f
= f
->next
)
1982 mio_symbol_ref (&f
->sym
);
1987 sym
->formal
= tail
= NULL
;
1989 while (peek_atom () != ATOM_RPAREN
)
1991 f
= gfc_get_formal_arglist ();
1992 mio_symbol_ref (&f
->sym
);
1994 if (sym
->formal
== NULL
)
2007 /* Save or restore a reference to a symbol node. */
2010 mio_symbol_ref (gfc_symbol
** symp
)
2014 p
= mio_pointer_ref (symp
);
2015 if (p
->type
== P_UNKNOWN
)
2018 if (iomode
== IO_OUTPUT
)
2020 if (p
->u
.wsym
.state
== UNREFERENCED
)
2021 p
->u
.wsym
.state
= NEEDS_WRITE
;
2025 if (p
->u
.rsym
.state
== UNUSED
)
2026 p
->u
.rsym
.state
= NEEDED
;
2031 /* Save or restore a reference to a symtree node. */
2034 mio_symtree_ref (gfc_symtree
** stp
)
2039 if (iomode
== IO_OUTPUT
)
2041 mio_symbol_ref (&(*stp
)->n
.sym
);
2045 require_atom (ATOM_INTEGER
);
2046 p
= get_integer (atom_int
);
2047 if (p
->type
== P_UNKNOWN
)
2050 if (p
->u
.rsym
.state
== UNUSED
)
2051 p
->u
.rsym
.state
= NEEDED
;
2053 if (p
->u
.rsym
.symtree
!= NULL
)
2055 *stp
= p
->u
.rsym
.symtree
;
2059 f
= gfc_getmem (sizeof (fixup_t
));
2061 f
->next
= p
->u
.rsym
.stfixup
;
2062 p
->u
.rsym
.stfixup
= f
;
2064 f
->pointer
= (void **)stp
;
2070 mio_iterator (gfc_iterator
** ip
)
2076 if (iomode
== IO_OUTPUT
)
2083 if (peek_atom () == ATOM_RPAREN
)
2089 *ip
= gfc_get_iterator ();
2094 mio_expr (&iter
->var
);
2095 mio_expr (&iter
->start
);
2096 mio_expr (&iter
->end
);
2097 mio_expr (&iter
->step
);
2106 mio_constructor (gfc_constructor
** cp
)
2108 gfc_constructor
*c
, *tail
;
2112 if (iomode
== IO_OUTPUT
)
2114 for (c
= *cp
; c
; c
= c
->next
)
2117 mio_expr (&c
->expr
);
2118 mio_iterator (&c
->iterator
);
2128 while (peek_atom () != ATOM_RPAREN
)
2130 c
= gfc_get_constructor ();
2140 mio_expr (&c
->expr
);
2141 mio_iterator (&c
->iterator
);
2151 static const mstring ref_types
[] = {
2152 minit ("ARRAY", REF_ARRAY
),
2153 minit ("COMPONENT", REF_COMPONENT
),
2154 minit ("SUBSTRING", REF_SUBSTRING
),
2160 mio_ref (gfc_ref
** rp
)
2167 r
->type
= MIO_NAME(ref_type
) (r
->type
, ref_types
);
2172 mio_array_ref (&r
->u
.ar
);
2176 mio_symbol_ref (&r
->u
.c
.sym
);
2177 mio_component_ref (&r
->u
.c
.component
, r
->u
.c
.sym
);
2181 mio_expr (&r
->u
.ss
.start
);
2182 mio_expr (&r
->u
.ss
.end
);
2183 mio_charlen (&r
->u
.ss
.length
);
2192 mio_ref_list (gfc_ref
** rp
)
2194 gfc_ref
*ref
, *head
, *tail
;
2198 if (iomode
== IO_OUTPUT
)
2200 for (ref
= *rp
; ref
; ref
= ref
->next
)
2207 while (peek_atom () != ATOM_RPAREN
)
2210 head
= tail
= gfc_get_ref ();
2213 tail
->next
= gfc_get_ref ();
2227 /* Read and write an integer value. */
2230 mio_gmp_integer (mpz_t
* integer
)
2234 if (iomode
== IO_INPUT
)
2236 if (parse_atom () != ATOM_STRING
)
2237 bad_module ("Expected integer string");
2239 mpz_init (*integer
);
2240 if (mpz_set_str (*integer
, atom_string
, 10))
2241 bad_module ("Error converting integer");
2243 gfc_free (atom_string
);
2248 p
= mpz_get_str (NULL
, 10, *integer
);
2249 write_atom (ATOM_STRING
, p
);
2256 mio_gmp_real (mpf_t
* real
)
2261 if (iomode
== IO_INPUT
)
2263 if (parse_atom () != ATOM_STRING
)
2264 bad_module ("Expected real string");
2267 mpf_set_str (*real
, atom_string
, -16);
2268 gfc_free (atom_string
);
2273 p
= mpf_get_str (NULL
, &exponent
, 16, 0, *real
);
2274 atom_string
= gfc_getmem (strlen (p
) + 20);
2276 sprintf (atom_string
, "0.%s@%ld", p
, exponent
);
2277 write_atom (ATOM_STRING
, atom_string
);
2279 gfc_free (atom_string
);
2285 /* Save and restore the shape of an array constructor. */
2288 mio_shape (mpz_t
** pshape
, int rank
)
2294 /* A NULL shape is represented by (). */
2297 if (iomode
== IO_OUTPUT
)
2309 if (t
== ATOM_RPAREN
)
2316 shape
= gfc_get_shape (rank
);
2320 for (n
= 0; n
< rank
; n
++)
2321 mio_gmp_integer (&shape
[n
]);
2327 static const mstring expr_types
[] = {
2328 minit ("OP", EXPR_OP
),
2329 minit ("FUNCTION", EXPR_FUNCTION
),
2330 minit ("CONSTANT", EXPR_CONSTANT
),
2331 minit ("VARIABLE", EXPR_VARIABLE
),
2332 minit ("SUBSTRING", EXPR_SUBSTRING
),
2333 minit ("STRUCTURE", EXPR_STRUCTURE
),
2334 minit ("ARRAY", EXPR_ARRAY
),
2335 minit ("NULL", EXPR_NULL
),
2339 /* INTRINSIC_ASSIGN is missing because it is used as an index for
2340 generic operators, not in expressions. INTRINSIC_USER is also
2341 replaced by the correct function name by the time we see it. */
2343 static const mstring intrinsics
[] =
2345 minit ("UPLUS", INTRINSIC_UPLUS
),
2346 minit ("UMINUS", INTRINSIC_UMINUS
),
2347 minit ("PLUS", INTRINSIC_PLUS
),
2348 minit ("MINUS", INTRINSIC_MINUS
),
2349 minit ("TIMES", INTRINSIC_TIMES
),
2350 minit ("DIVIDE", INTRINSIC_DIVIDE
),
2351 minit ("POWER", INTRINSIC_POWER
),
2352 minit ("CONCAT", INTRINSIC_CONCAT
),
2353 minit ("AND", INTRINSIC_AND
),
2354 minit ("OR", INTRINSIC_OR
),
2355 minit ("EQV", INTRINSIC_EQV
),
2356 minit ("NEQV", INTRINSIC_NEQV
),
2357 minit ("EQ", INTRINSIC_EQ
),
2358 minit ("NE", INTRINSIC_NE
),
2359 minit ("GT", INTRINSIC_GT
),
2360 minit ("GE", INTRINSIC_GE
),
2361 minit ("LT", INTRINSIC_LT
),
2362 minit ("LE", INTRINSIC_LE
),
2363 minit ("NOT", INTRINSIC_NOT
),
2367 /* Read and write expressions. The form "()" is allowed to indicate a
2371 mio_expr (gfc_expr
** ep
)
2379 if (iomode
== IO_OUTPUT
)
2388 MIO_NAME(expr_t
) (e
->expr_type
, expr_types
);
2394 if (t
== ATOM_RPAREN
)
2401 bad_module ("Expected expression type");
2403 e
= *ep
= gfc_get_expr ();
2404 e
->where
= gfc_current_locus
;
2405 e
->expr_type
= (expr_t
) find_enum (expr_types
);
2408 mio_typespec (&e
->ts
);
2409 mio_integer (&e
->rank
);
2411 switch (e
->expr_type
)
2414 e
->operator = MIO_NAME(gfc_intrinsic_op
) (e
->operator, intrinsics
);
2416 switch (e
->operator)
2418 case INTRINSIC_UPLUS
:
2419 case INTRINSIC_UMINUS
:
2424 case INTRINSIC_PLUS
:
2425 case INTRINSIC_MINUS
:
2426 case INTRINSIC_TIMES
:
2427 case INTRINSIC_DIVIDE
:
2428 case INTRINSIC_POWER
:
2429 case INTRINSIC_CONCAT
:
2433 case INTRINSIC_NEQV
:
2445 bad_module ("Bad operator");
2451 mio_symtree_ref (&e
->symtree
);
2452 mio_actual_arglist (&e
->value
.function
.actual
);
2454 if (iomode
== IO_OUTPUT
)
2456 mio_allocated_string (&e
->value
.function
.name
);
2457 flag
= e
->value
.function
.esym
!= NULL
;
2458 mio_integer (&flag
);
2460 mio_symbol_ref (&e
->value
.function
.esym
);
2462 write_atom (ATOM_STRING
, e
->value
.function
.isym
->name
);
2467 require_atom (ATOM_STRING
);
2468 e
->value
.function
.name
= gfc_get_string (atom_string
);
2469 gfc_free (atom_string
);
2471 mio_integer (&flag
);
2473 mio_symbol_ref (&e
->value
.function
.esym
);
2476 require_atom (ATOM_STRING
);
2477 e
->value
.function
.isym
= gfc_find_function (atom_string
);
2478 gfc_free (atom_string
);
2485 mio_symtree_ref (&e
->symtree
);
2486 mio_ref_list (&e
->ref
);
2489 case EXPR_SUBSTRING
:
2490 mio_allocated_string (&e
->value
.character
.string
);
2495 case EXPR_STRUCTURE
:
2497 mio_constructor (&e
->value
.constructor
);
2498 mio_shape (&e
->shape
, e
->rank
);
2505 mio_gmp_integer (&e
->value
.integer
);
2509 mio_gmp_real (&e
->value
.real
);
2513 mio_gmp_real (&e
->value
.complex.r
);
2514 mio_gmp_real (&e
->value
.complex.i
);
2518 mio_integer (&e
->value
.logical
);
2522 mio_integer (&e
->value
.character
.length
);
2523 mio_allocated_string (&e
->value
.character
.string
);
2527 bad_module ("Bad type in constant expression");
2540 /* Save/restore lists of gfc_interface stuctures. When loading an
2541 interface, we are really appending to the existing list of
2542 interfaces. Checking for duplicate and ambiguous interfaces has to
2543 be done later when all symbols have been loaded. */
2546 mio_interface_rest (gfc_interface
** ip
)
2548 gfc_interface
*tail
, *p
;
2550 if (iomode
== IO_OUTPUT
)
2553 for (p
= *ip
; p
; p
= p
->next
)
2554 mio_symbol_ref (&p
->sym
);
2570 if (peek_atom () == ATOM_RPAREN
)
2573 p
= gfc_get_interface ();
2574 mio_symbol_ref (&p
->sym
);
2589 /* Save/restore a nameless operator interface. */
2592 mio_interface (gfc_interface
** ip
)
2596 mio_interface_rest (ip
);
2600 /* Save/restore a named operator interface. */
2603 mio_symbol_interface (char *name
, char *module
,
2604 gfc_interface
** ip
)
2609 mio_internal_string (name
);
2610 mio_internal_string (module
);
2612 mio_interface_rest (ip
);
2617 mio_namespace_ref (gfc_namespace
** nsp
)
2622 p
= mio_pointer_ref (nsp
);
2624 if (p
->type
== P_UNKNOWN
)
2625 p
->type
= P_NAMESPACE
;
2627 if (iomode
== IO_INPUT
&& p
->integer
!= 0 && p
->u
.pointer
== NULL
)
2629 ns
= gfc_get_namespace (NULL
);
2630 associate_integer_pointer (p
, ns
);
2635 /* Unlike most other routines, the address of the symbol node is
2636 already fixed on input and the name/module has already been filled
2640 mio_symbol (gfc_symbol
* sym
)
2642 gfc_formal_arglist
*formal
;
2646 mio_symbol_attribute (&sym
->attr
);
2647 mio_typespec (&sym
->ts
);
2649 /* Contained procedures don't have formal namespaces. Instead we output the
2650 procedure namespace. The will contain the formal arguments. */
2651 if (iomode
== IO_OUTPUT
)
2653 formal
= sym
->formal
;
2654 while (formal
&& !formal
->sym
)
2655 formal
= formal
->next
;
2658 mio_namespace_ref (&formal
->sym
->ns
);
2660 mio_namespace_ref (&sym
->formal_ns
);
2664 mio_namespace_ref (&sym
->formal_ns
);
2667 sym
->formal_ns
->proc_name
= sym
;
2672 /* Save/restore common block links */
2673 mio_symbol_ref (&sym
->common_head
);
2674 mio_symbol_ref (&sym
->common_next
);
2676 mio_formal_arglist (sym
);
2678 mio_expr (&sym
->value
);
2679 mio_array_spec (&sym
->as
);
2681 mio_symbol_ref (&sym
->result
);
2683 /* Note that components are always saved, even if they are supposed
2684 to be private. Component access is checked during searching. */
2686 mio_component_list (&sym
->components
);
2688 if (sym
->components
!= NULL
)
2689 sym
->component_access
=
2690 MIO_NAME(gfc_access
) (sym
->component_access
, access_types
);
2692 mio_symbol_ref (&sym
->common_head
);
2693 mio_symbol_ref (&sym
->common_next
);
2699 /************************* Top level subroutines *************************/
2701 /* Skip a list between balanced left and right parens. */
2711 switch (parse_atom ())
2722 gfc_free (atom_string
);
2734 /* Load operator interfaces from the module. Interfaces are unusual
2735 in that they attach themselves to existing symbols. */
2738 load_operator_interfaces (void)
2741 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[GFC_MAX_SYMBOL_LEN
+ 1];
2746 while (peek_atom () != ATOM_RPAREN
)
2750 mio_internal_string (name
);
2751 mio_internal_string (module
);
2753 /* Decide if we need to load this one or not. */
2754 p
= find_use_name (name
);
2757 while (parse_atom () != ATOM_RPAREN
);
2761 uop
= gfc_get_uop (p
);
2762 mio_interface_rest (&uop
->operator);
2770 /* Load interfaces from the module. Interfaces are unusual in that
2771 they attach themselves to existing symbols. */
2774 load_generic_interfaces (void)
2777 char name
[GFC_MAX_SYMBOL_LEN
+ 1], module
[GFC_MAX_SYMBOL_LEN
+ 1];
2782 while (peek_atom () != ATOM_RPAREN
)
2786 mio_internal_string (name
);
2787 mio_internal_string (module
);
2789 /* Decide if we need to load this one or not. */
2790 p
= find_use_name (name
);
2792 if (p
== NULL
|| gfc_find_symbol (p
, NULL
, 0, &sym
))
2794 while (parse_atom () != ATOM_RPAREN
);
2800 gfc_get_symbol (p
, NULL
, &sym
);
2802 sym
->attr
.flavor
= FL_PROCEDURE
;
2803 sym
->attr
.generic
= 1;
2804 sym
->attr
.use_assoc
= 1;
2807 mio_interface_rest (&sym
->generic
);
2814 /* Recursive function to traverse the pointer_info tree and load a
2815 needed symbol. We return nonzero if we load a symbol and stop the
2816 traversal, because the act of loading can alter the tree. */
2819 load_needed (pointer_info
* p
)
2827 if (load_needed (p
->left
))
2829 if (load_needed (p
->right
))
2832 if (p
->type
!= P_SYMBOL
|| p
->u
.rsym
.state
!= NEEDED
)
2835 p
->u
.rsym
.state
= USED
;
2837 set_module_locus (&p
->u
.rsym
.where
);
2839 sym
= p
->u
.rsym
.sym
;
2842 q
= get_integer (p
->u
.rsym
.ns
);
2844 ns
= (gfc_namespace
*) q
->u
.pointer
;
2847 /* Create an interface namespace if necessary. These are
2848 the namespaces that hold the formal parameters of module
2851 ns
= gfc_get_namespace (NULL
);
2852 associate_integer_pointer (q
, ns
);
2855 sym
= gfc_new_symbol (p
->u
.rsym
.true_name
, ns
);
2856 strcpy (sym
->module
, p
->u
.rsym
.module
);
2858 associate_integer_pointer (p
, sym
);
2862 sym
->attr
.use_assoc
= 1;
2868 /* Recursive function for cleaning up things after a module has been
2872 read_cleanup (pointer_info
* p
)
2880 read_cleanup (p
->left
);
2881 read_cleanup (p
->right
);
2883 if (p
->type
== P_SYMBOL
&& p
->u
.rsym
.state
== USED
&& !p
->u
.rsym
.referenced
)
2885 /* Add hidden symbols to the symtree. */
2886 q
= get_integer (p
->u
.rsym
.ns
);
2887 st
= get_unique_symtree ((gfc_namespace
*) q
->u
.pointer
);
2889 st
->n
.sym
= p
->u
.rsym
.sym
;
2892 /* Fixup any symtree references. */
2893 p
->u
.rsym
.symtree
= st
;
2894 resolve_fixups (p
->u
.rsym
.stfixup
, st
);
2895 p
->u
.rsym
.stfixup
= NULL
;
2898 /* Free unused symbols. */
2899 if (p
->type
== P_SYMBOL
&& p
->u
.rsym
.state
== UNUSED
)
2900 gfc_free_symbol (p
->u
.rsym
.sym
);
2904 /* Read a module file. */
2909 module_locus operator_interfaces
, user_operators
;
2911 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2913 int ambiguous
, symbol
;
2919 get_module_locus (&operator_interfaces
); /* Skip these for now */
2922 get_module_locus (&user_operators
);
2928 /* Create the fixup nodes for all the symbols. */
2930 while (peek_atom () != ATOM_RPAREN
)
2932 require_atom (ATOM_INTEGER
);
2933 info
= get_integer (atom_int
);
2935 info
->type
= P_SYMBOL
;
2936 info
->u
.rsym
.state
= UNUSED
;
2938 mio_internal_string (info
->u
.rsym
.true_name
);
2939 mio_internal_string (info
->u
.rsym
.module
);
2941 require_atom (ATOM_INTEGER
);
2942 info
->u
.rsym
.ns
= atom_int
;
2944 get_module_locus (&info
->u
.rsym
.where
);
2947 /* See if the symbol has already been loaded by a previous module.
2948 If so, we reference the existing symbol and prevent it from
2949 being loaded again. */
2951 sym
= find_true_name (info
->u
.rsym
.true_name
, info
->u
.rsym
.module
);
2955 info
->u
.rsym
.state
= USED
;
2956 info
->u
.rsym
.referenced
= 1;
2957 info
->u
.rsym
.sym
= sym
;
2962 /* Parse the symtree lists. This lets us mark which symbols need to
2963 be loaded. Renaming is also done at this point by replacing the
2968 while (peek_atom () != ATOM_RPAREN
)
2970 mio_internal_string (name
);
2971 mio_integer (&ambiguous
);
2972 mio_integer (&symbol
);
2974 info
= get_integer (symbol
);
2976 /* Get the local name for this symbol. */
2977 p
= find_use_name (name
);
2979 /* Skip symtree nodes not in an ONLY caluse. */
2983 /* Check for ambiguous symbols. */
2984 st
= gfc_find_symtree (gfc_current_ns
->sym_root
, p
);
2988 if (st
->n
.sym
!= info
->u
.rsym
.sym
)
2990 info
->u
.rsym
.symtree
= st
;
2994 /* Create a symtree node in the current namespace for this symbol. */
2995 st
= check_unique_name (p
) ? get_unique_symtree (gfc_current_ns
) :
2996 gfc_new_symtree (&gfc_current_ns
->sym_root
, p
);
2998 st
->ambiguous
= ambiguous
;
3000 sym
= info
->u
.rsym
.sym
;
3002 /* Create a symbol node if it doesn't already exist. */
3005 sym
= info
->u
.rsym
.sym
=
3006 gfc_new_symbol (info
->u
.rsym
.true_name
, gfc_current_ns
);
3008 strcpy (sym
->module
, info
->u
.rsym
.module
);
3014 /* Store the symtree pointing to this symbol. */
3015 info
->u
.rsym
.symtree
= st
;
3017 if (info
->u
.rsym
.state
== UNUSED
)
3018 info
->u
.rsym
.state
= NEEDED
;
3019 info
->u
.rsym
.referenced
= 1;
3025 /* Load intrinsic operator interfaces. */
3026 set_module_locus (&operator_interfaces
);
3029 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
3031 if (i
== INTRINSIC_USER
)
3036 u
= find_use_operator (i
);
3047 mio_interface (&gfc_current_ns
->operator[i
]);
3052 /* Load generic and user operator interfaces. These must follow the
3053 loading of symtree because otherwise symbols can be marked as
3056 set_module_locus (&user_operators
);
3058 load_operator_interfaces ();
3059 load_generic_interfaces ();
3061 /* At this point, we read those symbols that are needed but haven't
3062 been loaded yet. If one symbol requires another, the other gets
3063 marked as NEEDED if its previous state was UNUSED. */
3065 while (load_needed (pi_root
));
3067 /* Make sure all elements of the rename-list were found in the
3070 for (u
= gfc_rename_list
; u
; u
= u
->next
)
3075 if (u
->operator == INTRINSIC_NONE
)
3077 gfc_error ("Symbol '%s' referenced at %L not found in module '%s'",
3078 u
->use_name
, &u
->where
, module_name
);
3082 if (u
->operator == INTRINSIC_USER
)
3085 ("User operator '%s' referenced at %L not found in module '%s'",
3086 u
->use_name
, &u
->where
, module_name
);
3091 ("Intrinsic operator '%s' referenced at %L not found in module "
3092 "'%s'", gfc_op2string (u
->operator), &u
->where
, module_name
);
3095 gfc_check_interfaces (gfc_current_ns
);
3097 /* Clean up symbol nodes that were never loaded, create references
3098 to hidden symbols. */
3100 read_cleanup (pi_root
);
3104 /* Given an access type that is specific to an entity and the default
3105 access, return nonzero if we should write the entity. */
3108 check_access (gfc_access specific_access
, gfc_access default_access
)
3111 if (specific_access
== ACCESS_PUBLIC
)
3113 if (specific_access
== ACCESS_PRIVATE
)
3116 if (gfc_option
.flag_module_access_private
)
3118 if (default_access
== ACCESS_PUBLIC
)
3123 if (default_access
!= ACCESS_PRIVATE
)
3131 /* Write a symbol to the module. */
3134 write_symbol (int n
, gfc_symbol
* sym
)
3137 if (sym
->attr
.flavor
== FL_UNKNOWN
|| sym
->attr
.flavor
== FL_LABEL
)
3138 gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym
->name
);
3141 mio_internal_string (sym
->name
);
3143 if (sym
->module
[0] == '\0')
3144 strcpy (sym
->module
, module_name
);
3146 mio_internal_string (sym
->module
);
3147 mio_pointer_ref (&sym
->ns
);
3154 /* Recursive traversal function to write the initial set of symbols to
3155 the module. We check to see if the symbol should be written
3156 according to the access specification. */
3159 write_symbol0 (gfc_symtree
* st
)
3167 write_symbol0 (st
->left
);
3168 write_symbol0 (st
->right
);
3172 if (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
3173 && !sym
->attr
.subroutine
&& !sym
->attr
.function
)
3176 if (!check_access (sym
->attr
.access
, sym
->ns
->default_access
))
3179 p
= get_pointer (sym
);
3180 if (p
->type
== P_UNKNOWN
)
3183 if (p
->u
.wsym
.state
== WRITTEN
)
3186 write_symbol (p
->integer
, sym
);
3187 p
->u
.wsym
.state
= WRITTEN
;
3193 /* Recursive traversal function to write the secondary set of symbols
3194 to the module file. These are symbols that were not public yet are
3195 needed by the public symbols or another dependent symbol. The act
3196 of writing a symbol can modify the pointer_info tree, so we cease
3197 traversal if we find a symbol to write. We return nonzero if a
3198 symbol was written and pass that information upwards. */
3201 write_symbol1 (pointer_info
* p
)
3207 if (write_symbol1 (p
->left
))
3209 if (write_symbol1 (p
->right
))
3212 if (p
->type
!= P_SYMBOL
|| p
->u
.wsym
.state
!= NEEDS_WRITE
)
3215 p
->u
.wsym
.state
= WRITTEN
;
3216 write_symbol (p
->integer
, p
->u
.wsym
.sym
);
3222 /* Write operator interfaces associated with a symbol. */
3225 write_operator (gfc_user_op
* uop
)
3227 static char nullstring
[] = "";
3229 if (uop
->operator == NULL
3230 || !check_access (uop
->access
, uop
->ns
->default_access
))
3233 mio_symbol_interface (uop
->name
, nullstring
, &uop
->operator);
3237 /* Write generic interfaces associated with a symbol. */
3240 write_generic (gfc_symbol
* sym
)
3243 if (sym
->generic
== NULL
3244 || !check_access (sym
->attr
.access
, sym
->ns
->default_access
))
3247 mio_symbol_interface (sym
->name
, sym
->module
, &sym
->generic
);
3252 write_symtree (gfc_symtree
* st
)
3258 if (!check_access (sym
->attr
.access
, sym
->ns
->default_access
)
3259 || (sym
->attr
.flavor
== FL_PROCEDURE
&& sym
->attr
.generic
3260 && !sym
->attr
.subroutine
&& !sym
->attr
.function
))
3263 if (check_unique_name (st
->name
))
3266 p
= find_pointer (sym
);
3268 gfc_internal_error ("write_symtree(): Symbol not written");
3270 mio_internal_string (st
->name
);
3271 mio_integer (&st
->ambiguous
);
3272 mio_integer (&p
->integer
);
3281 /* Write the operator interfaces. */
3284 for (i
= GFC_INTRINSIC_BEGIN
; i
!= GFC_INTRINSIC_END
; i
++)
3286 if (i
== INTRINSIC_USER
)
3289 mio_interface (check_access (gfc_current_ns
->operator_access
[i
],
3290 gfc_current_ns
->default_access
)
3291 ? &gfc_current_ns
->operator[i
] : NULL
);
3299 gfc_traverse_user_op (gfc_current_ns
, write_operator
);
3305 gfc_traverse_ns (gfc_current_ns
, write_generic
);
3310 /* Write symbol information. First we traverse all symbols in the
3311 primary namespace, writing those that need to be written.
3312 Sometimes writing one symbol will cause another to need to be
3313 written. A list of these symbols ends up on the write stack, and
3314 we end by popping the bottom of the stack and writing the symbol
3315 until the stack is empty. */
3319 write_symbol0 (gfc_current_ns
->sym_root
);
3320 while (write_symbol1 (pi_root
));
3328 gfc_traverse_symtree (gfc_current_ns
, write_symtree
);
3333 /* Given module, dump it to disk. If there was an error while
3334 processing the module, dump_flag will be set to zero and we delete
3335 the module file, even if it was already there. */
3338 gfc_dump_module (const char *name
, int dump_flag
)
3340 char filename
[PATH_MAX
], *p
;
3344 if (gfc_option
.module_dir
!= NULL
)
3345 strcpy (filename
, gfc_option
.module_dir
);
3347 strcat (filename
, name
);
3348 strcat (filename
, MODULE_EXTENSION
);
3356 module_fp
= fopen (filename
, "w");
3357 if (module_fp
== NULL
)
3358 gfc_fatal_error ("Can't open module file '%s' for writing: %s",
3359 filename
, strerror (errno
));
3364 *strchr (p
, '\n') = '\0';
3366 fprintf (module_fp
, "GFORTRAN module created from %s on %s\n",
3367 gfc_source_file
, p
);
3368 fputs ("If you edit this, you'll get what you deserve.\n\n", module_fp
);
3371 strcpy (module_name
, name
);
3377 free_pi_tree (pi_root
);
3382 if (fclose (module_fp
))
3383 gfc_fatal_error ("Error writing module file '%s' for writing: %s",
3384 filename
, strerror (errno
));
3388 /* Process a USE directive. */
3391 gfc_use_module (void)
3393 char filename
[GFC_MAX_SYMBOL_LEN
+ 5];
3397 strcpy (filename
, module_name
);
3398 strcat (filename
, MODULE_EXTENSION
);
3400 module_fp
= gfc_open_included_file (filename
);
3401 if (module_fp
== NULL
)
3402 gfc_fatal_error ("Can't open module file '%s' for reading: %s",
3403 filename
, strerror (errno
));
3409 /* Skip the first two lines of the module. */
3410 /* FIXME: Could also check for valid two lines here, instead. */
3416 bad_module ("Unexpected end of module");
3421 /* Make sure we're not reading the same module that we may be building. */
3422 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
3423 if (p
->state
== COMP_MODULE
&& strcmp (p
->sym
->name
, module_name
) == 0)
3424 gfc_fatal_error ("Can't USE the same module we're building!");
3427 init_true_name_tree ();
3431 free_true_name (true_name_root
);
3432 true_name_root
= NULL
;
3434 free_pi_tree (pi_root
);
3442 gfc_module_init_2 (void)
3445 last_atom
= ATOM_LPAREN
;
3450 gfc_module_done_2 (void)