Branch data Line data Source code
1 : : /* Handle modules, which amounts to loading and saving symbols and
2 : : their attendant structures.
3 : : Copyright (C) 2000-2024 Free Software Foundation, Inc.
4 : : Contributed by Andy Vaught
5 : :
6 : : This file is part of GCC.
7 : :
8 : : GCC is free software; you can redistribute it and/or modify it under
9 : : the terms of the GNU General Public License as published by the Free
10 : : Software Foundation; either version 3, or (at your option) any later
11 : : version.
12 : :
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
16 : : for more details.
17 : :
18 : : You should have received a copy of the GNU General Public License
19 : : along with GCC; see the file COPYING3. If not see
20 : : <http://www.gnu.org/licenses/>. */
21 : :
22 : : /* The syntax of gfortran modules resembles that of lisp lists, i.e. a
23 : : sequence of atoms, which can be left or right parenthesis, names,
24 : : integers or strings. Parenthesis are always matched which allows
25 : : us to skip over sections at high speed without having to know
26 : : anything about the internal structure of the lists. A "name" is
27 : : usually a fortran 95 identifier, but can also start with '@' in
28 : : order to reference a hidden symbol.
29 : :
30 : : The first line of a module is an informational message about what
31 : : created the module, the file it came from and when it was created.
32 : : The second line is a warning for people not to edit the module.
33 : : The rest of the module looks like:
34 : :
35 : : ( ( <Interface info for UPLUS> )
36 : : ( <Interface info for UMINUS> )
37 : : ...
38 : : )
39 : : ( ( <name of operator interface> <module of op interface> <i/f1> ... )
40 : : ...
41 : : )
42 : : ( ( <name of generic interface> <module of generic interface> <i/f1> ... )
43 : : ...
44 : : )
45 : : ( ( <common name> <symbol> <saved flag>)
46 : : ...
47 : : )
48 : :
49 : : ( equivalence list )
50 : :
51 : : ( <Symbol Number (in no particular order)>
52 : : <True name of symbol>
53 : : <Module name of symbol>
54 : : ( <symbol information> )
55 : : ...
56 : : )
57 : : ( <Symtree name>
58 : : <Ambiguous flag>
59 : : <Symbol number>
60 : : ...
61 : : )
62 : :
63 : : In general, symbols refer to other symbols by their symbol number,
64 : : which are zero based. Symbols are written to the module in no
65 : : particular order. */
66 : :
67 : : #include "config.h"
68 : : #include "system.h"
69 : : #include "coretypes.h"
70 : : #include "options.h"
71 : : #include "tree.h"
72 : : #include "gfortran.h"
73 : : #include "stringpool.h"
74 : : #include "arith.h"
75 : : #include "match.h"
76 : : #include "parse.h" /* FIXME */
77 : : #include "constructor.h"
78 : : #include "cpp.h"
79 : : #include "scanner.h"
80 : : #include <zlib.h>
81 : :
82 : : #define MODULE_EXTENSION ".mod"
83 : : #define SUBMODULE_EXTENSION ".smod"
84 : :
85 : : /* Don't put any single quote (') in MOD_VERSION, if you want it to be
86 : : recognized. */
87 : : #define MOD_VERSION "15"
88 : :
89 : :
90 : : /* Structure that describes a position within a module file. */
91 : :
92 : : typedef struct
93 : : {
94 : : int column, line;
95 : : long pos;
96 : : }
97 : : module_locus;
98 : :
99 : : /* Structure for list of symbols of intrinsic modules. */
100 : : typedef struct
101 : : {
102 : : int id;
103 : : const char *name;
104 : : int value;
105 : : int standard;
106 : : }
107 : : intmod_sym;
108 : :
109 : :
110 : : typedef enum
111 : : {
112 : : P_UNKNOWN = 0, P_OTHER, P_NAMESPACE, P_COMPONENT, P_SYMBOL
113 : : }
114 : : pointer_t;
115 : :
116 : : /* The fixup structure lists pointers to pointers that have to
117 : : be updated when a pointer value becomes known. */
118 : :
119 : : typedef struct fixup_t
120 : : {
121 : : void **pointer;
122 : : struct fixup_t *next;
123 : : }
124 : : fixup_t;
125 : :
126 : :
127 : : /* Structure for holding extra info needed for pointers being read. */
128 : :
129 : : enum gfc_rsym_state
130 : : {
131 : : UNUSED,
132 : : NEEDED,
133 : : USED
134 : : };
135 : :
136 : : enum gfc_wsym_state
137 : : {
138 : : UNREFERENCED = 0,
139 : : NEEDS_WRITE,
140 : : WRITTEN
141 : : };
142 : :
143 : : typedef struct pointer_info
144 : : {
145 : : BBT_HEADER (pointer_info);
146 : : HOST_WIDE_INT integer;
147 : : pointer_t type;
148 : :
149 : : /* The first component of each member of the union is the pointer
150 : : being stored. */
151 : :
152 : : fixup_t *fixup;
153 : :
154 : : union
155 : : {
156 : : void *pointer; /* Member for doing pointer searches. */
157 : :
158 : : struct
159 : : {
160 : : gfc_symbol *sym;
161 : : char *true_name, *module, *binding_label;
162 : : fixup_t *stfixup;
163 : : gfc_symtree *symtree;
164 : : enum gfc_rsym_state state;
165 : : int ns, referenced, renamed;
166 : : module_locus where;
167 : : }
168 : : rsym;
169 : :
170 : : struct
171 : : {
172 : : gfc_symbol *sym;
173 : : enum gfc_wsym_state state;
174 : : }
175 : : wsym;
176 : : }
177 : : u;
178 : :
179 : : }
180 : : pointer_info;
181 : :
182 : : #define gfc_get_pointer_info() XCNEW (pointer_info)
183 : :
184 : :
185 : : /* Local variables */
186 : :
187 : : /* The gzFile for the module we're reading or writing. */
188 : : static gzFile module_fp;
189 : :
190 : : /* Fully qualified module path */
191 : : static char *module_fullpath = NULL;
192 : :
193 : : /* The name of the module we're reading (USE'ing) or writing. */
194 : : static const char *module_name;
195 : : /* The name of the .smod file that the submodule will write to. */
196 : : static const char *submodule_name;
197 : :
198 : : /* The list of use statements to apply to the current namespace
199 : : before parsing the non-use statements. */
200 : : static gfc_use_list *module_list;
201 : : /* The end of the MODULE_LIST list above at the time the recognition
202 : : of the current statement started. */
203 : : static gfc_use_list **old_module_list_tail;
204 : :
205 : : /* If we're reading an intrinsic module, this is its ID. */
206 : : static intmod_id current_intmod;
207 : :
208 : : /* Content of module. */
209 : : static char* module_content;
210 : :
211 : : static long module_pos;
212 : : static int module_line, module_column, only_flag;
213 : : static int prev_module_line, prev_module_column;
214 : :
215 : : static enum
216 : : { IO_INPUT, IO_OUTPUT }
217 : : iomode;
218 : :
219 : : static gfc_use_rename *gfc_rename_list;
220 : : static pointer_info *pi_root;
221 : : static int symbol_number; /* Counter for assigning symbol numbers */
222 : :
223 : : /* Tells mio_expr_ref to make symbols for unused equivalence members. */
224 : : static bool in_load_equiv;
225 : :
226 : :
227 : :
228 : : /*****************************************************************/
229 : :
230 : : /* Pointer/integer conversion. Pointers between structures are stored
231 : : as integers in the module file. The next couple of subroutines
232 : : handle this translation for reading and writing. */
233 : :
234 : : /* Recursively free the tree of pointer structures. */
235 : :
236 : : static void
237 : 3318124 : free_pi_tree (pointer_info *p)
238 : : {
239 : 3318124 : if (p == NULL)
240 : : return;
241 : :
242 : 1648745 : if (p->fixup != NULL)
243 : 0 : gfc_internal_error ("free_pi_tree(): Unresolved fixup");
244 : :
245 : 1648745 : free_pi_tree (p->left);
246 : 1648745 : free_pi_tree (p->right);
247 : :
248 : 1648745 : if (iomode == IO_INPUT)
249 : : {
250 : 1308772 : XDELETEVEC (p->u.rsym.true_name);
251 : 1308772 : XDELETEVEC (p->u.rsym.module);
252 : 1308772 : XDELETEVEC (p->u.rsym.binding_label);
253 : : }
254 : :
255 : 1648745 : free (p);
256 : : }
257 : :
258 : :
259 : : /* Compare pointers when searching by pointer. Used when writing a
260 : : module. */
261 : :
262 : : static int
263 : 1930421 : compare_pointers (void *_sn1, void *_sn2)
264 : : {
265 : 1930421 : pointer_info *sn1, *sn2;
266 : :
267 : 1930421 : sn1 = (pointer_info *) _sn1;
268 : 1930421 : sn2 = (pointer_info *) _sn2;
269 : :
270 : 1930421 : if (sn1->u.pointer < sn2->u.pointer)
271 : : return -1;
272 : 1123229 : if (sn1->u.pointer > sn2->u.pointer)
273 : 1123229 : return 1;
274 : :
275 : : return 0;
276 : : }
277 : :
278 : :
279 : : /* Compare integers when searching by integer. Used when reading a
280 : : module. */
281 : :
282 : : static int
283 : 61102120 : compare_integers (void *_sn1, void *_sn2)
284 : : {
285 : 61102120 : pointer_info *sn1, *sn2;
286 : :
287 : 61102120 : sn1 = (pointer_info *) _sn1;
288 : 61102120 : sn2 = (pointer_info *) _sn2;
289 : :
290 : 9959824 : if (sn1->integer < sn2->integer)
291 : : return -1;
292 : 28057347 : if (sn1->integer > sn2->integer)
293 : 6751004 : return 1;
294 : :
295 : : return 0;
296 : : }
297 : :
298 : :
299 : : /* Initialize the pointer_info tree. */
300 : :
301 : : static void
302 : 20634 : init_pi_tree (void)
303 : : {
304 : 20634 : compare_fn compare;
305 : 20634 : pointer_info *p;
306 : :
307 : 20634 : pi_root = NULL;
308 : 20634 : compare = (iomode == IO_INPUT) ? compare_integers : compare_pointers;
309 : :
310 : : /* Pointer 0 is the NULL pointer. */
311 : 20634 : p = gfc_get_pointer_info ();
312 : 20634 : p->u.pointer = NULL;
313 : 20634 : p->integer = 0;
314 : 20634 : p->type = P_OTHER;
315 : :
316 : 20634 : gfc_insert_bbt (&pi_root, p, compare);
317 : :
318 : : /* Pointer 1 is the current namespace. */
319 : 20634 : p = gfc_get_pointer_info ();
320 : 20634 : p->u.pointer = gfc_current_ns;
321 : 20634 : p->integer = 1;
322 : 20634 : p->type = P_NAMESPACE;
323 : :
324 : 20634 : gfc_insert_bbt (&pi_root, p, compare);
325 : :
326 : 20634 : symbol_number = 2;
327 : 20634 : }
328 : :
329 : :
330 : : /* During module writing, call here with a pointer to something,
331 : : returning the pointer_info node. */
332 : :
333 : : static pointer_info *
334 : 1657647 : find_pointer (void *gp)
335 : : {
336 : 1657647 : pointer_info *p;
337 : :
338 : 1657647 : p = pi_root;
339 : 8908344 : while (p != NULL)
340 : : {
341 : 8585855 : if (p->u.pointer == gp)
342 : : break;
343 : 7250697 : p = (gp < p->u.pointer) ? p->left : p->right;
344 : : }
345 : :
346 : 1657647 : return p;
347 : : }
348 : :
349 : :
350 : : /* Given a pointer while writing, returns the pointer_info tree node,
351 : : creating it if it doesn't exist. */
352 : :
353 : : static pointer_info *
354 : 1551766 : get_pointer (void *gp)
355 : : {
356 : 1551766 : pointer_info *p;
357 : :
358 : 1551766 : p = find_pointer (gp);
359 : 1551766 : if (p != NULL)
360 : : return p;
361 : :
362 : : /* Pointer doesn't have an integer. Give it one. */
363 : 322489 : p = gfc_get_pointer_info ();
364 : :
365 : 322489 : p->u.pointer = gp;
366 : 322489 : p->integer = symbol_number++;
367 : :
368 : 322489 : gfc_insert_bbt (&pi_root, p, compare_pointers);
369 : :
370 : 322489 : return p;
371 : : }
372 : :
373 : :
374 : : /* Given an integer during reading, find it in the pointer_info tree,
375 : : creating the node if not found. */
376 : :
377 : : static pointer_info *
378 : 6548596 : get_integer (HOST_WIDE_INT integer)
379 : : {
380 : 6548596 : pointer_info *p, t;
381 : 6548596 : int c;
382 : :
383 : 6548596 : t.integer = integer;
384 : :
385 : 6548596 : p = pi_root;
386 : 52427284 : while (p != NULL)
387 : : {
388 : 51142296 : c = compare_integers (&t, p);
389 : : if (c == 0)
390 : : break;
391 : :
392 : 45878688 : p = (c < 0) ? p->left : p->right;
393 : : }
394 : :
395 : 6548596 : if (p != NULL)
396 : : return p;
397 : :
398 : 1284988 : p = gfc_get_pointer_info ();
399 : 1284988 : p->integer = integer;
400 : 1284988 : p->u.pointer = NULL;
401 : :
402 : 1284988 : gfc_insert_bbt (&pi_root, p, compare_integers);
403 : :
404 : 1284988 : return p;
405 : : }
406 : :
407 : :
408 : : /* Resolve any fixups using a known pointer. */
409 : :
410 : : static void
411 : 1379746 : resolve_fixups (fixup_t *f, void *gp)
412 : : {
413 : 1379746 : fixup_t *next;
414 : :
415 : 2072684 : for (; f; f = next)
416 : : {
417 : 692938 : next = f->next;
418 : 692938 : *(f->pointer) = gp;
419 : 692938 : free (f);
420 : : }
421 : 1379746 : }
422 : :
423 : :
424 : : /* Convert a string such that it starts with a lower-case character. Used
425 : : to convert the symtree name of a derived-type to the symbol name or to
426 : : the name of the associated generic function. */
427 : :
428 : : const char *
429 : 786413 : gfc_dt_lower_string (const char *name)
430 : : {
431 : 786413 : if (name[0] != (char) TOLOWER ((unsigned char) name[0]))
432 : 50316 : return gfc_get_string ("%c%s", (char) TOLOWER ((unsigned char) name[0]),
433 : 50316 : &name[1]);
434 : 736097 : return gfc_get_string ("%s", name);
435 : : }
436 : :
437 : :
438 : : /* Convert a string such that it starts with an upper-case character. Used to
439 : : return the symtree-name for a derived type; the symbol name itself and the
440 : : symtree/symbol name of the associated generic function start with a lower-
441 : : case character. */
442 : :
443 : : const char *
444 : 347152 : gfc_dt_upper_string (const char *name)
445 : : {
446 : 347152 : if (name[0] != (char) TOUPPER ((unsigned char) name[0]))
447 : 328585 : return gfc_get_string ("%c%s", (char) TOUPPER ((unsigned char) name[0]),
448 : 328585 : &name[1]);
449 : 18567 : return gfc_get_string ("%s", name);
450 : : }
451 : :
452 : : /* Call here during module reading when we know what pointer to
453 : : associate with an integer. Any fixups that exist are resolved at
454 : : this time. */
455 : :
456 : : static void
457 : 840214 : associate_integer_pointer (pointer_info *p, void *gp)
458 : : {
459 : 840214 : if (p->u.pointer != NULL)
460 : 0 : gfc_internal_error ("associate_integer_pointer(): Already associated");
461 : :
462 : 840214 : p->u.pointer = gp;
463 : :
464 : 840214 : resolve_fixups (p->fixup, gp);
465 : :
466 : 840214 : p->fixup = NULL;
467 : 840214 : }
468 : :
469 : :
470 : : /* During module reading, given an integer and a pointer to a pointer,
471 : : either store the pointer from an already-known value or create a
472 : : fixup structure in order to store things later. Returns zero if
473 : : the reference has been actually stored, or nonzero if the reference
474 : : must be fixed later (i.e., associate_integer_pointer must be called
475 : : sometime later. Returns the pointer_info structure. */
476 : :
477 : : static pointer_info *
478 : 4023776 : add_fixup (HOST_WIDE_INT integer, void *gp)
479 : : {
480 : 4023776 : pointer_info *p;
481 : 4023776 : fixup_t *f;
482 : 4023776 : char **cp;
483 : :
484 : 4023776 : p = get_integer (integer);
485 : :
486 : 4023776 : if (p->integer == 0 || p->u.pointer != NULL)
487 : : {
488 : 3338809 : cp = (char **) gp;
489 : 3338809 : *cp = (char *) p->u.pointer;
490 : : }
491 : : else
492 : : {
493 : 684967 : f = XCNEW (fixup_t);
494 : :
495 : 684967 : f->next = p->fixup;
496 : 684967 : p->fixup = f;
497 : :
498 : 684967 : f->pointer = (void **) gp;
499 : : }
500 : :
501 : 4023776 : return p;
502 : : }
503 : :
504 : :
505 : : /*****************************************************************/
506 : :
507 : : /* Parser related subroutines */
508 : :
509 : : /* Free the rename list left behind by a USE statement. */
510 : :
511 : : static void
512 : 83935 : free_rename (gfc_use_rename *list)
513 : : {
514 : 83935 : gfc_use_rename *next;
515 : :
516 : 92077 : for (; list; list = next)
517 : : {
518 : 8142 : next = list->next;
519 : 8142 : free (list);
520 : : }
521 : 0 : }
522 : :
523 : :
524 : : /* Match a USE statement. */
525 : :
526 : : match
527 : 20265 : gfc_match_use (void)
528 : : {
529 : 20265 : char name[GFC_MAX_SYMBOL_LEN + 1], module_nature[GFC_MAX_SYMBOL_LEN + 1];
530 : 20265 : gfc_use_rename *tail = NULL, *new_use;
531 : 20265 : interface_type type, type2;
532 : 20265 : gfc_intrinsic_op op;
533 : 20265 : match m;
534 : 20265 : gfc_use_list *use_list;
535 : 20265 : gfc_symtree *st;
536 : 20265 : locus loc;
537 : :
538 : 20265 : use_list = gfc_get_use_list ();
539 : :
540 : 20265 : if (gfc_match (" , ") == MATCH_YES)
541 : : {
542 : 2569 : if ((m = gfc_match (" %n ::", module_nature)) == MATCH_YES)
543 : : {
544 : 2567 : if (!gfc_notify_std (GFC_STD_F2003, "module "
545 : : "nature in USE statement at %C"))
546 : 0 : goto cleanup;
547 : :
548 : 2567 : if (strcmp (module_nature, "intrinsic") == 0)
549 : 2553 : use_list->intrinsic = true;
550 : : else
551 : : {
552 : 14 : if (strcmp (module_nature, "non_intrinsic") == 0)
553 : 13 : use_list->non_intrinsic = true;
554 : : else
555 : : {
556 : 1 : gfc_error ("Module nature in USE statement at %C shall "
557 : : "be either INTRINSIC or NON_INTRINSIC");
558 : 1 : goto cleanup;
559 : : }
560 : : }
561 : : }
562 : : else
563 : : {
564 : : /* Help output a better error message than "Unclassifiable
565 : : statement". */
566 : 2 : gfc_match (" %n", module_nature);
567 : 2 : if (strcmp (module_nature, "intrinsic") == 0
568 : 1 : || strcmp (module_nature, "non_intrinsic") == 0)
569 : 2 : gfc_error ("\"::\" was expected after module nature at %C "
570 : : "but was not found");
571 : 2 : free (use_list);
572 : 2 : return m;
573 : : }
574 : : }
575 : : else
576 : : {
577 : 17696 : m = gfc_match (" ::");
578 : 18027 : if (m == MATCH_YES &&
579 : 331 : !gfc_notify_std(GFC_STD_F2003, "\"USE :: module\" at %C"))
580 : 0 : goto cleanup;
581 : :
582 : 17696 : if (m != MATCH_YES)
583 : : {
584 : 17365 : m = gfc_match ("% ");
585 : 17365 : if (m != MATCH_YES)
586 : : {
587 : 15 : free (use_list);
588 : 15 : return m;
589 : : }
590 : : }
591 : : }
592 : :
593 : 20247 : use_list->where = gfc_current_locus;
594 : :
595 : 20247 : m = gfc_match_name (name);
596 : 20247 : if (m != MATCH_YES)
597 : : {
598 : 12 : free (use_list);
599 : 12 : return m;
600 : : }
601 : :
602 : 20235 : use_list->module_name = gfc_get_string ("%s", name);
603 : :
604 : 20235 : if (gfc_match_eos () == MATCH_YES)
605 : 13013 : goto done;
606 : :
607 : 7222 : if (gfc_match_char (',') != MATCH_YES)
608 : 0 : goto syntax;
609 : :
610 : 7222 : if (gfc_match (" only :") == MATCH_YES)
611 : 6982 : use_list->only_flag = true;
612 : :
613 : 7222 : if (gfc_match_eos () == MATCH_YES)
614 : 1 : goto done;
615 : :
616 : 10895 : for (;;)
617 : : {
618 : : /* Get a new rename struct and add it to the rename list. */
619 : 10895 : new_use = gfc_get_use_rename ();
620 : 10895 : new_use->where = gfc_current_locus;
621 : 10895 : new_use->found = 0;
622 : :
623 : 10895 : if (use_list->rename == NULL)
624 : 7221 : use_list->rename = new_use;
625 : : else
626 : 3674 : tail->next = new_use;
627 : 10895 : tail = new_use;
628 : :
629 : : /* See what kind of interface we're dealing with. Assume it is
630 : : not an operator. */
631 : 10895 : new_use->op = INTRINSIC_NONE;
632 : 10895 : if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR)
633 : 0 : goto cleanup;
634 : :
635 : 10895 : switch (type)
636 : : {
637 : 1 : case INTERFACE_NAMELESS:
638 : 1 : gfc_error ("Missing generic specification in USE statement at %C");
639 : 1 : goto cleanup;
640 : :
641 : 10783 : case INTERFACE_USER_OP:
642 : 10783 : case INTERFACE_GENERIC:
643 : 10783 : case INTERFACE_DTIO:
644 : 10783 : loc = gfc_current_locus;
645 : :
646 : 10783 : m = gfc_match (" =>");
647 : :
648 : 79 : if (type == INTERFACE_USER_OP && m == MATCH_YES
649 : 10829 : && (!gfc_notify_std(GFC_STD_F2003, "Renaming "
650 : : "operators in USE statements at %C")))
651 : 2 : goto cleanup;
652 : :
653 : 10781 : if (type == INTERFACE_USER_OP)
654 : 77 : new_use->op = INTRINSIC_USER;
655 : :
656 : 10781 : if (use_list->only_flag)
657 : : {
658 : 10434 : if (m != MATCH_YES)
659 : 10114 : strcpy (new_use->use_name, name);
660 : : else
661 : : {
662 : 320 : strcpy (new_use->local_name, name);
663 : 320 : m = gfc_match_generic_spec (&type2, new_use->use_name, &op);
664 : 320 : if (type != type2)
665 : 1 : goto syntax;
666 : 319 : if (m == MATCH_NO)
667 : 0 : goto syntax;
668 : 319 : if (m == MATCH_ERROR)
669 : 0 : goto cleanup;
670 : : }
671 : : }
672 : : else
673 : : {
674 : 347 : if (m != MATCH_YES)
675 : 0 : goto syntax;
676 : 347 : strcpy (new_use->local_name, name);
677 : :
678 : 347 : m = gfc_match_generic_spec (&type2, new_use->use_name, &op);
679 : 347 : if (type != type2)
680 : 2 : goto syntax;
681 : 345 : if (m == MATCH_NO)
682 : 0 : goto syntax;
683 : 345 : if (m == MATCH_ERROR)
684 : 0 : goto cleanup;
685 : : }
686 : :
687 : 10778 : st = gfc_find_symtree (gfc_current_ns->sym_root, name);
688 : 10778 : if (st && type != INTERFACE_USER_OP
689 : 13 : && (st->n.sym->module != use_list->module_name
690 : 3 : || strcmp (st->n.sym->name, new_use->use_name) != 0))
691 : : {
692 : 10 : if (m == MATCH_YES)
693 : 7 : gfc_error ("Symbol %qs at %L conflicts with the rename symbol "
694 : : "at %L", name, &st->n.sym->declared_at, &loc);
695 : : else
696 : 3 : gfc_error ("Symbol %qs at %L conflicts with the symbol "
697 : : "at %L", name, &st->n.sym->declared_at, &loc);
698 : 10 : goto cleanup;
699 : : }
700 : :
701 : 10768 : if (strcmp (new_use->use_name, use_list->module_name) == 0
702 : 10766 : || strcmp (new_use->local_name, use_list->module_name) == 0)
703 : : {
704 : 3 : gfc_error ("The name %qs at %C has already been used as "
705 : : "an external module name", use_list->module_name);
706 : 3 : goto cleanup;
707 : : }
708 : : break;
709 : :
710 : 111 : case INTERFACE_INTRINSIC_OP:
711 : 111 : new_use->op = op;
712 : 111 : break;
713 : :
714 : 0 : default:
715 : 0 : gcc_unreachable ();
716 : : }
717 : :
718 : 10876 : if (gfc_match_eos () == MATCH_YES)
719 : : break;
720 : 3676 : if (gfc_match_char (',') != MATCH_YES)
721 : 2 : goto syntax;
722 : : }
723 : :
724 : 7200 : done:
725 : 20214 : if (module_list)
726 : : {
727 : : gfc_use_list *last = module_list;
728 : 3795 : while (last->next)
729 : : last = last->next;
730 : 2966 : last->next = use_list;
731 : : }
732 : : else
733 : 17248 : module_list = use_list;
734 : :
735 : : return MATCH_YES;
736 : :
737 : 5 : syntax:
738 : 5 : gfc_syntax_error (ST_USE);
739 : :
740 : 22 : cleanup:
741 : 22 : free_rename (use_list->rename);
742 : 22 : free (use_list);
743 : 22 : return MATCH_ERROR;
744 : : }
745 : :
746 : :
747 : : /* Match a SUBMODULE statement.
748 : :
749 : : According to F2008:11.2.3.2, "The submodule identifier is the
750 : : ordered pair whose first element is the ancestor module name and
751 : : whose second element is the submodule name. 'Submodule_name' is
752 : : used for the submodule filename and uses '@' as a separator, whilst
753 : : the name of the symbol for the module uses '.' as a separator.
754 : : The reasons for these choices are:
755 : : (i) To follow another leading brand in the submodule filenames;
756 : : (ii) Since '.' is not particularly visible in the filenames; and
757 : : (iii) The linker does not permit '@' in mnemonics. */
758 : :
759 : : match
760 : 196 : gfc_match_submodule (void)
761 : : {
762 : 196 : match m;
763 : 196 : char name[GFC_MAX_SYMBOL_LEN + 1];
764 : 196 : gfc_use_list *use_list;
765 : 196 : bool seen_colon = false;
766 : :
767 : 196 : if (!gfc_notify_std (GFC_STD_F2008, "SUBMODULE declaration at %C"))
768 : : return MATCH_ERROR;
769 : :
770 : 195 : if (gfc_current_state () != COMP_NONE)
771 : : {
772 : 3 : gfc_error ("SUBMODULE declaration at %C cannot appear within "
773 : : "another scoping unit");
774 : 3 : return MATCH_ERROR;
775 : : }
776 : :
777 : 192 : gfc_new_block = NULL;
778 : 192 : gcc_assert (module_list == NULL);
779 : :
780 : 192 : if (gfc_match_char ('(') != MATCH_YES)
781 : 0 : goto syntax;
782 : :
783 : 217 : while (1)
784 : : {
785 : 217 : m = gfc_match (" %n", name);
786 : 217 : if (m != MATCH_YES)
787 : 0 : goto syntax;
788 : :
789 : 217 : use_list = gfc_get_use_list ();
790 : 217 : use_list->where = gfc_current_locus;
791 : :
792 : 217 : if (module_list)
793 : : {
794 : : gfc_use_list *last = module_list;
795 : 25 : while (last->next)
796 : : last = last->next;
797 : 25 : last->next = use_list;
798 : 25 : use_list->module_name
799 : 25 : = gfc_get_string ("%s.%s", module_list->module_name, name);
800 : 25 : use_list->submodule_name
801 : 25 : = gfc_get_string ("%s@%s", module_list->module_name, name);
802 : : }
803 : : else
804 : : {
805 : 192 : module_list = use_list;
806 : 192 : use_list->module_name = gfc_get_string ("%s", name);
807 : 192 : use_list->submodule_name = use_list->module_name;
808 : : }
809 : :
810 : 217 : if (gfc_match_char (')') == MATCH_YES)
811 : : break;
812 : :
813 : 52 : if (gfc_match_char (':') != MATCH_YES
814 : 26 : || seen_colon)
815 : 1 : goto syntax;
816 : :
817 : : seen_colon = true;
818 : : }
819 : :
820 : 191 : m = gfc_match (" %s%t", &gfc_new_block);
821 : 191 : if (m != MATCH_YES)
822 : 0 : goto syntax;
823 : :
824 : 191 : submodule_name = gfc_get_string ("%s@%s", module_list->module_name,
825 : : gfc_new_block->name);
826 : :
827 : 191 : gfc_new_block->name = gfc_get_string ("%s.%s",
828 : : module_list->module_name,
829 : : gfc_new_block->name);
830 : :
831 : 191 : if (!gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
832 : : gfc_new_block->name, NULL))
833 : : return MATCH_ERROR;
834 : :
835 : : /* Just retain the ultimate .(s)mod file for reading, since it
836 : : contains all the information in its ancestors. */
837 : 191 : use_list = module_list;
838 : 215 : for (; module_list->next; use_list = module_list)
839 : : {
840 : 24 : module_list = use_list->next;
841 : 24 : free (use_list);
842 : : }
843 : :
844 : : return MATCH_YES;
845 : :
846 : 1 : syntax:
847 : 1 : gfc_error ("Syntax error in SUBMODULE statement at %C");
848 : 1 : return MATCH_ERROR;
849 : : }
850 : :
851 : :
852 : : /* Given a name and a number, inst, return the inst name
853 : : under which to load this symbol. Returns NULL if this
854 : : symbol shouldn't be loaded. If inst is zero, returns
855 : : the number of instances of this name. If interface is
856 : : true, a user-defined operator is sought, otherwise only
857 : : non-operators are sought. */
858 : :
859 : : static const char *
860 : 800566 : find_use_name_n (const char *name, int *inst, bool interface)
861 : : {
862 : 800566 : gfc_use_rename *u;
863 : 800566 : const char *low_name = NULL;
864 : 800566 : int i;
865 : :
866 : : /* For derived types. */
867 : 800566 : if (name[0] != (char) TOLOWER ((unsigned char) name[0]))
868 : 24454 : low_name = gfc_dt_lower_string (name);
869 : :
870 : 800566 : i = 0;
871 : 925325 : for (u = gfc_rename_list; u; u = u->next)
872 : : {
873 : 128716 : if ((!low_name && strcmp (u->use_name, name) != 0)
874 : 3212 : || (low_name && strcmp (u->use_name, low_name) != 0)
875 : 7954 : || (u->op == INTRINSIC_USER && !interface)
876 : 7952 : || (u->op != INTRINSIC_USER && interface))
877 : 120764 : continue;
878 : 7952 : if (++i == *inst)
879 : : break;
880 : : }
881 : :
882 : 800566 : if (!*inst)
883 : : {
884 : 400212 : *inst = i;
885 : 400212 : return NULL;
886 : : }
887 : :
888 : 400354 : if (u == NULL)
889 : 443220 : return only_flag ? NULL : name;
890 : :
891 : 3957 : u->found = 1;
892 : :
893 : 3957 : if (low_name)
894 : : {
895 : 639 : if (u->local_name[0] == '\0')
896 : : return name;
897 : 96 : return gfc_dt_upper_string (u->local_name);
898 : : }
899 : :
900 : 3318 : return (u->local_name[0] != '\0') ? u->local_name : name;
901 : : }
902 : :
903 : :
904 : : /* Given a name, return the name under which to load this symbol.
905 : : Returns NULL if this symbol shouldn't be loaded. */
906 : :
907 : : static const char *
908 : 86 : find_use_name (const char *name, bool interface)
909 : : {
910 : 86 : int i = 1;
911 : 50 : return find_use_name_n (name, &i, interface);
912 : : }
913 : :
914 : :
915 : : /* Given a real name, return the number of use names associated with it. */
916 : :
917 : : static int
918 : 400212 : number_use_names (const char *name, bool interface)
919 : : {
920 : 400212 : int i = 0;
921 : 0 : find_use_name_n (name, &i, interface);
922 : 400212 : return i;
923 : : }
924 : :
925 : :
926 : : /* Try to find the operator in the current list. */
927 : :
928 : : static gfc_use_rename *
929 : 63420 : find_use_operator (gfc_intrinsic_op op)
930 : : {
931 : 63420 : gfc_use_rename *u;
932 : :
933 : 156735 : for (u = gfc_rename_list; u; u = u->next)
934 : 93517 : if (u->op == op)
935 : 0 : return u;
936 : :
937 : : return NULL;
938 : : }
939 : :
940 : :
941 : : /*****************************************************************/
942 : :
943 : : /* The next couple of subroutines maintain a tree used to avoid a
944 : : brute-force search for a combination of true name and module name.
945 : : While symtree names, the name that a particular symbol is known by
946 : : can changed with USE statements, we still have to keep track of the
947 : : true names to generate the correct reference, and also avoid
948 : : loading the same real symbol twice in a program unit.
949 : :
950 : : When we start reading, the true name tree is built and maintained
951 : : as symbols are read. The tree is searched as we load new symbols
952 : : to see if it already exists someplace in the namespace. */
953 : :
954 : : typedef struct true_name
955 : : {
956 : : BBT_HEADER (true_name);
957 : : const char *name;
958 : : gfc_symbol *sym;
959 : : }
960 : : true_name;
961 : :
962 : : static true_name *true_name_root;
963 : :
964 : :
965 : : /* Compare two true_name structures. */
966 : :
967 : : static int
968 : 2798707 : compare_true_names (void *_t1, void *_t2)
969 : : {
970 : 2798707 : true_name *t1, *t2;
971 : 2798707 : int c;
972 : :
973 : 2798707 : t1 = (true_name *) _t1;
974 : 2798707 : t2 = (true_name *) _t2;
975 : :
976 : 2798707 : c = ((t1->sym->module > t2->sym->module)
977 : 2798707 : - (t1->sym->module < t2->sym->module));
978 : 2798707 : if (c != 0)
979 : : return c;
980 : :
981 : 921628 : return strcmp (t1->name, t2->name);
982 : : }
983 : :
984 : :
985 : : /* Given a true name, search the true name tree to see if it exists
986 : : within the main namespace. */
987 : :
988 : : static gfc_symbol *
989 : 1031249 : find_true_name (const char *name, const char *module)
990 : : {
991 : 1031249 : true_name t, *p;
992 : 1031249 : gfc_symbol sym;
993 : 1031249 : int c;
994 : :
995 : 1031249 : t.name = gfc_get_string ("%s", name);
996 : 1031249 : if (module != NULL)
997 : 1013166 : sym.module = gfc_get_string ("%s", module);
998 : : else
999 : 18083 : sym.module = NULL;
1000 : 1031249 : t.sym = &sym;
1001 : :
1002 : 1031249 : p = true_name_root;
1003 : 3417480 : while (p != NULL)
1004 : : {
1005 : 2433975 : c = compare_true_names ((void *) (&t), (void *) p);
1006 : 2433975 : if (c == 0)
1007 : 47744 : return p->sym;
1008 : :
1009 : 2386231 : p = (c < 0) ? p->left : p->right;
1010 : : }
1011 : :
1012 : : return NULL;
1013 : : }
1014 : :
1015 : :
1016 : : /* Given a gfc_symbol pointer that is not in the true name tree, add it. */
1017 : :
1018 : : static void
1019 : 92325 : add_true_name (gfc_symbol *sym)
1020 : : {
1021 : 92325 : true_name *t;
1022 : :
1023 : 92325 : t = XCNEW (true_name);
1024 : 92325 : t->sym = sym;
1025 : 92325 : if (gfc_fl_struct (sym->attr.flavor))
1026 : 5332 : t->name = gfc_dt_upper_string (sym->name);
1027 : : else
1028 : 86993 : t->name = sym->name;
1029 : :
1030 : 92325 : gfc_insert_bbt (&true_name_root, t, compare_true_names);
1031 : 92325 : }
1032 : :
1033 : :
1034 : : /* Recursive function to build the initial true name tree by
1035 : : recursively traversing the current namespace. */
1036 : :
1037 : : static void
1038 : 197918 : build_tnt (gfc_symtree *st)
1039 : : {
1040 : 197918 : const char *name;
1041 : 197918 : if (st == NULL)
1042 : : return;
1043 : :
1044 : 93013 : build_tnt (st->left);
1045 : 93013 : build_tnt (st->right);
1046 : :
1047 : 93013 : if (gfc_fl_struct (st->n.sym->attr.flavor))
1048 : 5749 : name = gfc_dt_upper_string (st->n.sym->name);
1049 : : else
1050 : 87264 : name = st->n.sym->name;
1051 : :
1052 : 93013 : if (find_true_name (name, st->n.sym->module) != NULL)
1053 : : return;
1054 : :
1055 : 92325 : add_true_name (st->n.sym);
1056 : : }
1057 : :
1058 : :
1059 : : /* Initialize the true name tree with the current namespace. */
1060 : :
1061 : : static void
1062 : 11892 : init_true_name_tree (void)
1063 : : {
1064 : 11892 : true_name_root = NULL;
1065 : 11892 : build_tnt (gfc_current_ns->sym_root);
1066 : 11892 : }
1067 : :
1068 : :
1069 : : /* Recursively free a true name tree node. */
1070 : :
1071 : : static void
1072 : 196542 : free_true_name (true_name *t)
1073 : : {
1074 : 196542 : if (t == NULL)
1075 : : return;
1076 : 92325 : free_true_name (t->left);
1077 : 92325 : free_true_name (t->right);
1078 : :
1079 : 92325 : free (t);
1080 : : }
1081 : :
1082 : :
1083 : : /*****************************************************************/
1084 : :
1085 : : /* Module reading and writing. */
1086 : :
1087 : : /* The following are versions similar to the ones in scanner.cc, but
1088 : : for dealing with compressed module files. */
1089 : :
1090 : : static gzFile
1091 : 8221 : gzopen_included_file_1 (const char *name, gfc_directorylist *list,
1092 : : bool module, bool system)
1093 : : {
1094 : 8221 : char *fullname;
1095 : 8221 : gfc_directorylist *p;
1096 : 8221 : gzFile f;
1097 : :
1098 : 28059 : for (p = list; p; p = p->next)
1099 : : {
1100 : 21486 : if (module && !p->use_for_modules)
1101 : 3319 : continue;
1102 : :
1103 : 18167 : fullname = (char *) alloca(strlen (p->path) + strlen (name) + 2);
1104 : 18167 : strcpy (fullname, p->path);
1105 : 18167 : strcat (fullname, "/");
1106 : 18167 : strcat (fullname, name);
1107 : :
1108 : 18167 : f = gzopen (fullname, "r");
1109 : 18167 : if (f != NULL)
1110 : : {
1111 : 1648 : if (gfc_cpp_makedep ())
1112 : 0 : gfc_cpp_add_dep (fullname, system);
1113 : :
1114 : 1648 : free (module_fullpath);
1115 : 1648 : module_fullpath = xstrdup (fullname);
1116 : 1648 : return f;
1117 : : }
1118 : : }
1119 : :
1120 : : return NULL;
1121 : : }
1122 : :
1123 : : static gzFile
1124 : 17695 : gzopen_included_file (const char *name, bool include_cwd, bool module)
1125 : : {
1126 : 17695 : gzFile f = NULL;
1127 : :
1128 : 17695 : if (IS_ABSOLUTE_PATH (name) || include_cwd)
1129 : : {
1130 : 17695 : f = gzopen (name, "r");
1131 : 17695 : if (f)
1132 : : {
1133 : 10244 : if (gfc_cpp_makedep ())
1134 : 0 : gfc_cpp_add_dep (name, false);
1135 : :
1136 : 10244 : free (module_fullpath);
1137 : 10244 : module_fullpath = xstrdup (name);
1138 : : }
1139 : : }
1140 : :
1141 : 10244 : if (!f)
1142 : 7451 : f = gzopen_included_file_1 (name, include_dirs, module, false);
1143 : :
1144 : 17695 : return f;
1145 : : }
1146 : :
1147 : : static gzFile
1148 : 770 : gzopen_intrinsic_module (const char* name)
1149 : : {
1150 : 770 : gzFile f = NULL;
1151 : :
1152 : 770 : if (IS_ABSOLUTE_PATH (name))
1153 : : {
1154 : 0 : f = gzopen (name, "r");
1155 : 0 : if (f)
1156 : : {
1157 : 0 : if (gfc_cpp_makedep ())
1158 : 0 : gfc_cpp_add_dep (name, true);
1159 : :
1160 : 0 : free (module_fullpath);
1161 : 0 : module_fullpath = xstrdup (name);
1162 : : }
1163 : : }
1164 : :
1165 : 0 : if (!f)
1166 : 770 : f = gzopen_included_file_1 (name, intrinsic_modules_dirs, true, true);
1167 : :
1168 : 770 : return f;
1169 : : }
1170 : :
1171 : :
1172 : : enum atom_type
1173 : : {
1174 : : ATOM_NAME, ATOM_LPAREN, ATOM_RPAREN, ATOM_INTEGER, ATOM_STRING
1175 : : };
1176 : :
1177 : : static atom_type last_atom;
1178 : :
1179 : :
1180 : : /* The name buffer must be at least as long as a symbol name. Right
1181 : : now it's not clear how we're going to store numeric constants--
1182 : : probably as a hexadecimal string, since this will allow the exact
1183 : : number to be preserved (this can't be done by a decimal
1184 : : representation). Worry about that later. TODO! */
1185 : :
1186 : : #define MAX_ATOM_SIZE 100
1187 : :
1188 : : static HOST_WIDE_INT atom_int;
1189 : : static char *atom_string, atom_name[MAX_ATOM_SIZE];
1190 : :
1191 : :
1192 : : /* Report problems with a module. Error reporting is not very
1193 : : elaborate, since this sorts of errors shouldn't really happen.
1194 : : This subroutine never returns. */
1195 : :
1196 : : static void bad_module (const char *) ATTRIBUTE_NORETURN;
1197 : :
1198 : : static void
1199 : 0 : bad_module (const char *msgid)
1200 : : {
1201 : 0 : XDELETEVEC (module_content);
1202 : 0 : module_content = NULL;
1203 : :
1204 : 0 : switch (iomode)
1205 : : {
1206 : 0 : case IO_INPUT:
1207 : 0 : gfc_fatal_error ("Reading module %qs at line %d column %d: %s",
1208 : : module_fullpath, module_line, module_column, msgid);
1209 : 0 : break;
1210 : 0 : case IO_OUTPUT:
1211 : 0 : gfc_fatal_error ("Writing module %qs at line %d column %d: %s",
1212 : : module_name, module_line, module_column, msgid);
1213 : 0 : break;
1214 : 0 : default:
1215 : 0 : gfc_fatal_error ("Module %qs at line %d column %d: %s",
1216 : : module_name, module_line, module_column, msgid);
1217 : : break;
1218 : : }
1219 : : }
1220 : :
1221 : :
1222 : : /* Set the module's input pointer. */
1223 : :
1224 : : static void
1225 : 797684 : set_module_locus (module_locus *m)
1226 : : {
1227 : 797684 : module_column = m->column;
1228 : 797684 : module_line = m->line;
1229 : 797684 : module_pos = m->pos;
1230 : 0 : }
1231 : :
1232 : :
1233 : : /* Get the module's input pointer so that we can restore it later. */
1234 : :
1235 : : static void
1236 : 973932 : get_module_locus (module_locus *m)
1237 : : {
1238 : 973932 : m->column = module_column;
1239 : 973932 : m->line = module_line;
1240 : 973932 : m->pos = module_pos;
1241 : 0 : }
1242 : :
1243 : : /* Peek at the next character in the module. */
1244 : :
1245 : : static int
1246 : 510 : module_peek_char (void)
1247 : : {
1248 : 510 : return module_content[module_pos];
1249 : : }
1250 : :
1251 : : /* Get the next character in the module, updating our reckoning of
1252 : : where we are. */
1253 : :
1254 : : static int
1255 : 412736120 : module_char (void)
1256 : : {
1257 : 412736120 : const char c = module_content[module_pos++];
1258 : 412736120 : if (c == '\0')
1259 : 0 : bad_module ("Unexpected EOF");
1260 : :
1261 : 412736120 : prev_module_line = module_line;
1262 : 412736120 : prev_module_column = module_column;
1263 : :
1264 : 412736120 : if (c == '\n')
1265 : : {
1266 : 8748270 : module_line++;
1267 : 8748270 : module_column = 0;
1268 : : }
1269 : :
1270 : 412736120 : module_column++;
1271 : 412736120 : return c;
1272 : : }
1273 : :
1274 : : /* Unget a character while remembering the line and column. Works for
1275 : : a single character only. */
1276 : :
1277 : : static void
1278 : 60247905 : module_unget_char (void)
1279 : : {
1280 : 60247905 : module_line = prev_module_line;
1281 : 60247905 : module_column = prev_module_column;
1282 : 60247905 : module_pos--;
1283 : 0 : }
1284 : :
1285 : : /* Parse a string constant. The delimiter is guaranteed to be a
1286 : : single quote. */
1287 : :
1288 : : static void
1289 : 4172606 : parse_string (void)
1290 : : {
1291 : 4172606 : int c;
1292 : 4172606 : size_t cursz = 30;
1293 : 4172606 : size_t len = 0;
1294 : :
1295 : 4172606 : atom_string = XNEWVEC (char, cursz);
1296 : :
1297 : 60666638 : for ( ; ; )
1298 : : {
1299 : 32419622 : c = module_char ();
1300 : :
1301 : 32419622 : if (c == '\'')
1302 : : {
1303 : 4172606 : int c2 = module_char ();
1304 : 4172606 : if (c2 != '\'')
1305 : : {
1306 : 4172606 : module_unget_char ();
1307 : 4172606 : break;
1308 : : }
1309 : : }
1310 : :
1311 : 28247016 : if (len >= cursz)
1312 : : {
1313 : 46925 : cursz *= 2;
1314 : 46925 : atom_string = XRESIZEVEC (char, atom_string, cursz);
1315 : : }
1316 : 28247016 : atom_string[len] = c;
1317 : 28247016 : len++;
1318 : 28247016 : }
1319 : :
1320 : 4172606 : atom_string = XRESIZEVEC (char, atom_string, len + 1);
1321 : 4172606 : atom_string[len] = '\0'; /* C-style string for debug purposes. */
1322 : 4172606 : }
1323 : :
1324 : :
1325 : : /* Parse an integer. Should fit in a HOST_WIDE_INT. */
1326 : :
1327 : : static void
1328 : 27093584 : parse_integer (int c)
1329 : : {
1330 : 27093584 : int sign = 1;
1331 : :
1332 : 27093584 : atom_int = 0;
1333 : 27093584 : switch (c)
1334 : : {
1335 : : case ('-'):
1336 : 27093584 : sign = -1;
1337 : : case ('+'):
1338 : : break;
1339 : 27093074 : default:
1340 : 27093074 : atom_int = c - '0';
1341 : 27093074 : break;
1342 : : }
1343 : :
1344 : 41053756 : for (;;)
1345 : : {
1346 : 34073670 : c = module_char ();
1347 : 34073670 : if (!ISDIGIT (c))
1348 : : {
1349 : 27093584 : module_unget_char ();
1350 : 27093584 : break;
1351 : : }
1352 : :
1353 : 6980086 : atom_int = 10 * atom_int + c - '0';
1354 : : }
1355 : :
1356 : 27093584 : atom_int *= sign;
1357 : 27093584 : }
1358 : :
1359 : :
1360 : : /* Parse a name. */
1361 : :
1362 : : static void
1363 : 20143465 : parse_name (int c)
1364 : : {
1365 : 20143465 : char *p;
1366 : 20143465 : int len;
1367 : :
1368 : 20143465 : p = atom_name;
1369 : :
1370 : 20143465 : *p++ = c;
1371 : 20143465 : len = 1;
1372 : :
1373 : 170518943 : for (;;)
1374 : : {
1375 : 170518943 : c = module_char ();
1376 : 170518943 : if (!ISALNUM (c) && c != '_' && c != '-')
1377 : : {
1378 : 20143465 : module_unget_char ();
1379 : 20143465 : break;
1380 : : }
1381 : :
1382 : 150375478 : *p++ = c;
1383 : 150375478 : if (++len > GFC_MAX_SYMBOL_LEN)
1384 : 0 : bad_module ("Name too long");
1385 : : }
1386 : :
1387 : 20143465 : *p = '\0';
1388 : :
1389 : 20143465 : }
1390 : :
1391 : :
1392 : : /* Read the next atom in the module's input stream. */
1393 : :
1394 : : static atom_type
1395 : 96048541 : parse_atom (void)
1396 : : {
1397 : 160546483 : int c;
1398 : :
1399 : 160546483 : do
1400 : : {
1401 : 160546483 : c = module_char ();
1402 : : }
1403 : 160546483 : while (c == ' ' || c == '\r' || c == '\n');
1404 : :
1405 : 96048541 : switch (c)
1406 : : {
1407 : : case '(':
1408 : : return ATOM_LPAREN;
1409 : :
1410 : 22337271 : case ')':
1411 : 22337271 : return ATOM_RPAREN;
1412 : :
1413 : 4172606 : case '\'':
1414 : 4172606 : parse_string ();
1415 : 4172606 : return ATOM_STRING;
1416 : :
1417 : 27093074 : case '0':
1418 : 27093074 : case '1':
1419 : 27093074 : case '2':
1420 : 27093074 : case '3':
1421 : 27093074 : case '4':
1422 : 27093074 : case '5':
1423 : 27093074 : case '6':
1424 : 27093074 : case '7':
1425 : 27093074 : case '8':
1426 : 27093074 : case '9':
1427 : 27093074 : parse_integer (c);
1428 : 27093074 : return ATOM_INTEGER;
1429 : :
1430 : 510 : case '+':
1431 : 510 : case '-':
1432 : 510 : if (ISDIGIT (module_peek_char ()))
1433 : : {
1434 : 510 : parse_integer (c);
1435 : 510 : return ATOM_INTEGER;
1436 : : }
1437 : : else
1438 : 0 : bad_module ("Bad name");
1439 : :
1440 : 20107789 : case 'a':
1441 : 20107789 : case 'b':
1442 : 20107789 : case 'c':
1443 : 20107789 : case 'd':
1444 : 20107789 : case 'e':
1445 : 20107789 : case 'f':
1446 : 20107789 : case 'g':
1447 : 20107789 : case 'h':
1448 : 20107789 : case 'i':
1449 : 20107789 : case 'j':
1450 : 20107789 : case 'k':
1451 : 20107789 : case 'l':
1452 : 20107789 : case 'm':
1453 : 20107789 : case 'n':
1454 : 20107789 : case 'o':
1455 : 20107789 : case 'p':
1456 : 20107789 : case 'q':
1457 : 20107789 : case 'r':
1458 : 20107789 : case 's':
1459 : 20107789 : case 't':
1460 : 20107789 : case 'u':
1461 : 20107789 : case 'v':
1462 : 20107789 : case 'w':
1463 : 20107789 : case 'x':
1464 : 20107789 : case 'y':
1465 : 20107789 : case 'z':
1466 : 20107789 : case 'A':
1467 : 20107789 : case 'B':
1468 : 20107789 : case 'C':
1469 : 20107789 : case 'D':
1470 : 20107789 : case 'E':
1471 : 20107789 : case 'F':
1472 : 20107789 : case 'G':
1473 : 20107789 : case 'H':
1474 : 20107789 : case 'I':
1475 : 20107789 : case 'J':
1476 : 20107789 : case 'K':
1477 : 20107789 : case 'L':
1478 : 20107789 : case 'M':
1479 : 20107789 : case 'N':
1480 : 20107789 : case 'O':
1481 : 20107789 : case 'P':
1482 : 20107789 : case 'Q':
1483 : 20107789 : case 'R':
1484 : 20107789 : case 'S':
1485 : 20107789 : case 'T':
1486 : 20107789 : case 'U':
1487 : 20107789 : case 'V':
1488 : 20107789 : case 'W':
1489 : 20107789 : case 'X':
1490 : 20107789 : case 'Y':
1491 : 20107789 : case 'Z':
1492 : 20107789 : parse_name (c);
1493 : 20107789 : return ATOM_NAME;
1494 : :
1495 : 0 : default:
1496 : 0 : bad_module ("Bad name");
1497 : : }
1498 : :
1499 : : /* Not reached. */
1500 : : }
1501 : :
1502 : :
1503 : : /* Peek at the next atom on the input. */
1504 : :
1505 : : static atom_type
1506 : 8838250 : peek_atom (void)
1507 : : {
1508 : 10573060 : int c;
1509 : :
1510 : 10573060 : do
1511 : : {
1512 : 10573060 : c = module_char ();
1513 : : }
1514 : 10573060 : while (c == ' ' || c == '\r' || c == '\n');
1515 : :
1516 : 8838250 : switch (c)
1517 : : {
1518 : 240918 : case '(':
1519 : 240918 : module_unget_char ();
1520 : 240918 : return ATOM_LPAREN;
1521 : :
1522 : 6778856 : case ')':
1523 : 6778856 : module_unget_char ();
1524 : 6778856 : return ATOM_RPAREN;
1525 : :
1526 : 353293 : case '\'':
1527 : 353293 : module_unget_char ();
1528 : 353293 : return ATOM_STRING;
1529 : :
1530 : 1464560 : case '0':
1531 : 1464560 : case '1':
1532 : 1464560 : case '2':
1533 : 1464560 : case '3':
1534 : 1464560 : case '4':
1535 : 1464560 : case '5':
1536 : 1464560 : case '6':
1537 : 1464560 : case '7':
1538 : 1464560 : case '8':
1539 : 1464560 : case '9':
1540 : 1464560 : module_unget_char ();
1541 : 1464560 : return ATOM_INTEGER;
1542 : :
1543 : 0 : case '+':
1544 : 0 : case '-':
1545 : 0 : if (ISDIGIT (module_peek_char ()))
1546 : : {
1547 : 0 : module_unget_char ();
1548 : 0 : return ATOM_INTEGER;
1549 : : }
1550 : : else
1551 : 0 : bad_module ("Bad name");
1552 : :
1553 : 623 : case 'a':
1554 : 623 : case 'b':
1555 : 623 : case 'c':
1556 : 623 : case 'd':
1557 : 623 : case 'e':
1558 : 623 : case 'f':
1559 : 623 : case 'g':
1560 : 623 : case 'h':
1561 : 623 : case 'i':
1562 : 623 : case 'j':
1563 : 623 : case 'k':
1564 : 623 : case 'l':
1565 : 623 : case 'm':
1566 : 623 : case 'n':
1567 : 623 : case 'o':
1568 : 623 : case 'p':
1569 : 623 : case 'q':
1570 : 623 : case 'r':
1571 : 623 : case 's':
1572 : 623 : case 't':
1573 : 623 : case 'u':
1574 : 623 : case 'v':
1575 : 623 : case 'w':
1576 : 623 : case 'x':
1577 : 623 : case 'y':
1578 : 623 : case 'z':
1579 : 623 : case 'A':
1580 : 623 : case 'B':
1581 : 623 : case 'C':
1582 : 623 : case 'D':
1583 : 623 : case 'E':
1584 : 623 : case 'F':
1585 : 623 : case 'G':
1586 : 623 : case 'H':
1587 : 623 : case 'I':
1588 : 623 : case 'J':
1589 : 623 : case 'K':
1590 : 623 : case 'L':
1591 : 623 : case 'M':
1592 : 623 : case 'N':
1593 : 623 : case 'O':
1594 : 623 : case 'P':
1595 : 623 : case 'Q':
1596 : 623 : case 'R':
1597 : 623 : case 'S':
1598 : 623 : case 'T':
1599 : 623 : case 'U':
1600 : 623 : case 'V':
1601 : 623 : case 'W':
1602 : 623 : case 'X':
1603 : 623 : case 'Y':
1604 : 623 : case 'Z':
1605 : 623 : module_unget_char ();
1606 : 623 : return ATOM_NAME;
1607 : :
1608 : 0 : default:
1609 : 0 : bad_module ("Bad name");
1610 : : }
1611 : : }
1612 : :
1613 : :
1614 : : /* Read the next atom from the input, requiring that it be a
1615 : : particular kind. */
1616 : :
1617 : : static void
1618 : 43212718 : require_atom (atom_type type)
1619 : : {
1620 : 43212718 : atom_type t;
1621 : 43212718 : const char *p;
1622 : 43212718 : int column, line;
1623 : :
1624 : 43212718 : column = module_column;
1625 : 43212718 : line = module_line;
1626 : :
1627 : 43212718 : t = parse_atom ();
1628 : 43212718 : if (t != type)
1629 : : {
1630 : 0 : switch (type)
1631 : : {
1632 : 0 : case ATOM_NAME:
1633 : 0 : p = _("Expected name");
1634 : 0 : break;
1635 : 0 : case ATOM_LPAREN:
1636 : 0 : p = _("Expected left parenthesis");
1637 : 0 : break;
1638 : 0 : case ATOM_RPAREN:
1639 : 0 : p = _("Expected right parenthesis");
1640 : 0 : break;
1641 : 0 : case ATOM_INTEGER:
1642 : 0 : p = _("Expected integer");
1643 : 0 : break;
1644 : 0 : case ATOM_STRING:
1645 : 0 : p = _("Expected string");
1646 : 0 : break;
1647 : 0 : default:
1648 : 0 : gfc_internal_error ("require_atom(): bad atom type required");
1649 : : }
1650 : :
1651 : 0 : module_column = column;
1652 : 0 : module_line = line;
1653 : 0 : bad_module (p);
1654 : : }
1655 : 43212718 : }
1656 : :
1657 : :
1658 : : /* Given a pointer to an mstring array, require that the current input
1659 : : be one of the strings in the array. We return the enum value. */
1660 : :
1661 : : static int
1662 : 9060552 : find_enum (const mstring *m)
1663 : : {
1664 : 9060552 : int i;
1665 : :
1666 : 9060552 : i = gfc_string2code (m, atom_name);
1667 : 9060552 : if (i >= 0)
1668 : 9060552 : return i;
1669 : :
1670 : 0 : bad_module ("find_enum(): Enum not found");
1671 : :
1672 : : /* Not reached. */
1673 : : }
1674 : :
1675 : :
1676 : : /* Read a string. The caller is responsible for freeing. */
1677 : :
1678 : : static char*
1679 : 2814914 : read_string (void)
1680 : : {
1681 : 2814914 : char* p;
1682 : 0 : require_atom (ATOM_STRING);
1683 : 2814914 : p = atom_string;
1684 : 2814914 : atom_string = NULL;
1685 : 2814914 : return p;
1686 : : }
1687 : :
1688 : :
1689 : : /**************** Module output subroutines ***************************/
1690 : :
1691 : : /* Output a character to a module file. */
1692 : :
1693 : : static void
1694 : 56044332 : write_char (char out)
1695 : : {
1696 : 56044332 : if (gzputc (module_fp, out) == EOF)
1697 : 0 : gfc_fatal_error ("Error writing modules file: %s", xstrerror (errno));
1698 : :
1699 : 56044332 : if (out != '\n')
1700 : 55018743 : module_column++;
1701 : : else
1702 : : {
1703 : 1025589 : module_column = 1;
1704 : 1025589 : module_line++;
1705 : : }
1706 : 56044332 : }
1707 : :
1708 : :
1709 : : /* Write an atom to a module. The line wrapping isn't perfect, but it
1710 : : should work most of the time. This isn't that big of a deal, since
1711 : : the file really isn't meant to be read by people anyway. */
1712 : :
1713 : : static void
1714 : 14933070 : write_atom (atom_type atom, const void *v)
1715 : : {
1716 : 14933070 : char buffer[32];
1717 : :
1718 : : /* Workaround -Wmaybe-uninitialized false positive during
1719 : : profiledbootstrap by initializing them. */
1720 : 14933070 : int len;
1721 : 14933070 : HOST_WIDE_INT i = 0;
1722 : 14933070 : const char *p;
1723 : :
1724 : 14933070 : switch (atom)
1725 : : {
1726 : : case ATOM_STRING:
1727 : : case ATOM_NAME:
1728 : : p = (const char *) v;
1729 : : break;
1730 : :
1731 : : case ATOM_LPAREN:
1732 : : p = "(";
1733 : : break;
1734 : :
1735 : : case ATOM_RPAREN:
1736 : : p = ")";
1737 : : break;
1738 : :
1739 : 4042962 : case ATOM_INTEGER:
1740 : 4042962 : i = *((const HOST_WIDE_INT *) v);
1741 : :
1742 : 4042962 : snprintf (buffer, sizeof (buffer), HOST_WIDE_INT_PRINT_DEC, i);
1743 : 4042962 : p = buffer;
1744 : 4042962 : break;
1745 : :
1746 : 0 : default:
1747 : 0 : gfc_internal_error ("write_atom(): Trying to write dab atom");
1748 : :
1749 : : }
1750 : :
1751 : 14933070 : if(p == NULL || *p == '\0')
1752 : : len = 0;
1753 : : else
1754 : 14626136 : len = strlen (p);
1755 : :
1756 : 14933070 : if (atom != ATOM_RPAREN)
1757 : : {
1758 : 11502216 : if (module_column + len > 72)
1759 : 694917 : write_char ('\n');
1760 : : else
1761 : : {
1762 : :
1763 : 10807299 : if (last_atom != ATOM_LPAREN && module_column != 1)
1764 : 9389056 : write_char (' ');
1765 : : }
1766 : : }
1767 : :
1768 : 11502216 : if (atom == ATOM_STRING)
1769 : 925898 : write_char ('\'');
1770 : :
1771 : 58710961 : while (p != NULL && *p)
1772 : : {
1773 : 43777891 : if (atom == ATOM_STRING && *p == '\'')
1774 : 0 : write_char ('\'');
1775 : 43777891 : write_char (*p++);
1776 : : }
1777 : :
1778 : 14933070 : if (atom == ATOM_STRING)
1779 : 925898 : write_char ('\'');
1780 : :
1781 : 14933070 : last_atom = atom;
1782 : 14933070 : }
1783 : :
1784 : :
1785 : :
1786 : : /***************** Mid-level I/O subroutines *****************/
1787 : :
1788 : : /* These subroutines let their caller read or write atoms without
1789 : : caring about which of the two is actually happening. This lets a
1790 : : subroutine concentrate on the actual format of the data being
1791 : : written. */
1792 : :
1793 : : static void mio_expr (gfc_expr **);
1794 : : pointer_info *mio_symbol_ref (gfc_symbol **);
1795 : : pointer_info *mio_interface_rest (gfc_interface **);
1796 : : static void mio_symtree_ref (gfc_symtree **);
1797 : :
1798 : : /* Read or write an enumerated value. On writing, we return the input
1799 : : value for the convenience of callers. We avoid using an integer
1800 : : pointer because enums are sometimes inside bitfields. */
1801 : :
1802 : : static int
1803 : 10229701 : mio_name (int t, const mstring *m)
1804 : : {
1805 : 10229701 : if (iomode == IO_OUTPUT)
1806 : 3101994 : write_atom (ATOM_NAME, gfc_code2string (m, t));
1807 : : else
1808 : : {
1809 : 7127707 : require_atom (ATOM_NAME);
1810 : 7127707 : t = find_enum (m);
1811 : : }
1812 : :
1813 : 10229701 : return t;
1814 : : }
1815 : :
1816 : : /* Specialization of mio_name. */
1817 : :
1818 : : #define DECL_MIO_NAME(TYPE) \
1819 : : static inline TYPE \
1820 : : MIO_NAME(TYPE) (TYPE t, const mstring *m) \
1821 : : { \
1822 : : return (TYPE) mio_name ((int) t, m); \
1823 : : }
1824 : : #define MIO_NAME(TYPE) mio_name_##TYPE
1825 : :
1826 : : static void
1827 : 13503371 : mio_lparen (void)
1828 : : {
1829 : 13503371 : if (iomode == IO_OUTPUT)
1830 : 3430854 : write_atom (ATOM_LPAREN, NULL);
1831 : : else
1832 : 10072517 : require_atom (ATOM_LPAREN);
1833 : 13503371 : }
1834 : :
1835 : :
1836 : : static void
1837 : 12380742 : mio_rparen (void)
1838 : : {
1839 : 12380742 : if (iomode == IO_OUTPUT)
1840 : 3430854 : write_atom (ATOM_RPAREN, NULL);
1841 : : else
1842 : 8949888 : require_atom (ATOM_RPAREN);
1843 : 12380742 : }
1844 : :
1845 : :
1846 : : static void
1847 : 10039154 : mio_integer (int *ip)
1848 : : {
1849 : 10039154 : if (iomode == IO_OUTPUT)
1850 : : {
1851 : 2492374 : HOST_WIDE_INT hwi = *ip;
1852 : 2492374 : write_atom (ATOM_INTEGER, &hwi);
1853 : : }
1854 : : else
1855 : : {
1856 : 7546780 : require_atom (ATOM_INTEGER);
1857 : 7546780 : *ip = atom_int;
1858 : : }
1859 : 10039154 : }
1860 : :
1861 : : static void
1862 : 333163 : mio_hwi (HOST_WIDE_INT *hwi)
1863 : : {
1864 : 333163 : if (iomode == IO_OUTPUT)
1865 : 198379 : write_atom (ATOM_INTEGER, hwi);
1866 : : else
1867 : : {
1868 : 134784 : require_atom (ATOM_INTEGER);
1869 : 134784 : *hwi = atom_int;
1870 : : }
1871 : 333163 : }
1872 : :
1873 : :
1874 : : /* Read or write a gfc_intrinsic_op value. */
1875 : :
1876 : : static void
1877 : 1225 : mio_intrinsic_op (gfc_intrinsic_op* op)
1878 : : {
1879 : : /* FIXME: Would be nicer to do this via the operators symbolic name. */
1880 : 1225 : if (iomode == IO_OUTPUT)
1881 : : {
1882 : 653 : HOST_WIDE_INT converted = (HOST_WIDE_INT) *op;
1883 : 653 : write_atom (ATOM_INTEGER, &converted);
1884 : : }
1885 : : else
1886 : : {
1887 : 572 : require_atom (ATOM_INTEGER);
1888 : 572 : *op = (gfc_intrinsic_op) atom_int;
1889 : : }
1890 : 1225 : }
1891 : :
1892 : :
1893 : : /* Read or write a character pointer that points to a string on the heap. */
1894 : :
1895 : : static const char *
1896 : 7523 : mio_allocated_string (const char *s)
1897 : : {
1898 : 7523 : if (iomode == IO_OUTPUT)
1899 : : {
1900 : 7523 : write_atom (ATOM_STRING, s);
1901 : 7523 : return s;
1902 : : }
1903 : : else
1904 : : {
1905 : 0 : require_atom (ATOM_STRING);
1906 : 0 : return atom_string;
1907 : : }
1908 : : }
1909 : :
1910 : :
1911 : : /* Functions for quoting and unquoting strings. */
1912 : :
1913 : : static char *
1914 : 5028 : quote_string (const gfc_char_t *s, const size_t slength)
1915 : : {
1916 : 5028 : const gfc_char_t *p;
1917 : 5028 : char *res, *q;
1918 : 5028 : size_t len = 0, i;
1919 : :
1920 : : /* Calculate the length we'll need: a backslash takes two ("\\"),
1921 : : non-printable characters take 10 ("\Uxxxxxxxx") and others take 1. */
1922 : 19295 : for (p = s, i = 0; i < slength; p++, i++)
1923 : : {
1924 : 14267 : if (*p == '\\')
1925 : 1 : len += 2;
1926 : 14266 : else if (!gfc_wide_is_printable (*p))
1927 : 4096 : len += 10;
1928 : : else
1929 : 10170 : len++;
1930 : : }
1931 : :
1932 : 5028 : q = res = XCNEWVEC (char, len + 1);
1933 : 24323 : for (p = s, i = 0; i < slength; p++, i++)
1934 : : {
1935 : 14267 : if (*p == '\\')
1936 : 1 : *q++ = '\\', *q++ = '\\';
1937 : 14266 : else if (!gfc_wide_is_printable (*p))
1938 : : {
1939 : 4096 : sprintf (q, "\\U%08" HOST_WIDE_INT_PRINT "x",
1940 : 4096 : (unsigned HOST_WIDE_INT) *p);
1941 : 4096 : q += 10;
1942 : : }
1943 : : else
1944 : 10170 : *q++ = (unsigned char) *p;
1945 : : }
1946 : :
1947 : 5028 : res[len] = '\0';
1948 : 5028 : return res;
1949 : : }
1950 : :
1951 : : static gfc_char_t *
1952 : 2520 : unquote_string (const char *s)
1953 : : {
1954 : 2520 : size_t len, i;
1955 : 2520 : const char *p;
1956 : 2520 : gfc_char_t *res;
1957 : :
1958 : 13750 : for (p = s, len = 0; *p; p++, len++)
1959 : : {
1960 : 11230 : if (*p != '\\')
1961 : 9599 : continue;
1962 : :
1963 : 1631 : if (p[1] == '\\')
1964 : 0 : p++;
1965 : 1631 : else if (p[1] == 'U')
1966 : 1631 : p += 9; /* That is a "\U????????". */
1967 : : else
1968 : 0 : gfc_internal_error ("unquote_string(): got bad string");
1969 : : }
1970 : :
1971 : 2520 : res = gfc_get_wide_string (len + 1);
1972 : 13750 : for (i = 0, p = s; i < len; i++, p++)
1973 : : {
1974 : 11230 : gcc_assert (*p);
1975 : :
1976 : 11230 : if (*p != '\\')
1977 : 9599 : res[i] = (unsigned char) *p;
1978 : 1631 : else if (p[1] == '\\')
1979 : : {
1980 : 0 : res[i] = (unsigned char) '\\';
1981 : 0 : p++;
1982 : : }
1983 : : else
1984 : : {
1985 : : /* We read the 8-digits hexadecimal constant that follows. */
1986 : 1631 : int j;
1987 : 1631 : unsigned n;
1988 : 1631 : gfc_char_t c = 0;
1989 : :
1990 : 1631 : gcc_assert (p[1] == 'U');
1991 : 14679 : for (j = 0; j < 8; j++)
1992 : : {
1993 : 13048 : c = c << 4;
1994 : 13048 : gcc_assert (sscanf (&p[j+2], "%01x", &n) == 1);
1995 : 13048 : c += n;
1996 : : }
1997 : :
1998 : 1631 : res[i] = c;
1999 : 1631 : p += 9;
2000 : : }
2001 : : }
2002 : :
2003 : 2520 : res[len] = '\0';
2004 : 2520 : return res;
2005 : : }
2006 : :
2007 : :
2008 : : /* Read or write a character pointer that points to a wide string on the
2009 : : heap, performing quoting/unquoting of nonprintable characters using the
2010 : : form \U???????? (where each ? is a hexadecimal digit).
2011 : : Length is the length of the string, only known and used in output mode. */
2012 : :
2013 : : static const gfc_char_t *
2014 : 7548 : mio_allocated_wide_string (const gfc_char_t *s, const size_t length)
2015 : : {
2016 : 7548 : if (iomode == IO_OUTPUT)
2017 : : {
2018 : 5028 : char *quoted = quote_string (s, length);
2019 : 5028 : write_atom (ATOM_STRING, quoted);
2020 : 5028 : free (quoted);
2021 : 5028 : return s;
2022 : : }
2023 : : else
2024 : : {
2025 : 2520 : gfc_char_t *unquoted;
2026 : :
2027 : 2520 : require_atom (ATOM_STRING);
2028 : 2520 : unquoted = unquote_string (atom_string);
2029 : 2520 : free (atom_string);
2030 : 2520 : return unquoted;
2031 : : }
2032 : : }
2033 : :
2034 : :
2035 : : /* Read or write a string that is in static memory. */
2036 : :
2037 : : static void
2038 : 847717 : mio_pool_string (const char **stringp)
2039 : : {
2040 : : /* TODO: one could write the string only once, and refer to it via a
2041 : : fixup pointer. */
2042 : :
2043 : : /* As a special case we have to deal with a NULL string. This
2044 : : happens for the 'module' member of 'gfc_symbol's that are not in a
2045 : : module. We read / write these as the empty string. */
2046 : 847717 : if (iomode == IO_OUTPUT)
2047 : : {
2048 : 653591 : const char *p = *stringp == NULL ? "" : *stringp;
2049 : 653591 : write_atom (ATOM_STRING, p);
2050 : : }
2051 : : else
2052 : : {
2053 : 194126 : require_atom (ATOM_STRING);
2054 : 388252 : *stringp = (atom_string[0] == '\0'
2055 : 194126 : ? NULL : gfc_get_string ("%s", atom_string));
2056 : 194126 : free (atom_string);
2057 : : }
2058 : 847717 : }
2059 : :
2060 : :
2061 : : /* Read or write a string that is inside of some already-allocated
2062 : : structure. */
2063 : :
2064 : : static void
2065 : 448806 : mio_internal_string (char *string)
2066 : : {
2067 : 448806 : if (iomode == IO_OUTPUT)
2068 : 0 : write_atom (ATOM_STRING, string);
2069 : : else
2070 : : {
2071 : 448806 : require_atom (ATOM_STRING);
2072 : 448806 : strcpy (string, atom_string);
2073 : 448806 : free (atom_string);
2074 : : }
2075 : 448806 : }
2076 : :
2077 : :
2078 : : enum ab_attribute
2079 : : { AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL,
2080 : : AB_POINTER, AB_TARGET, AB_DUMMY, AB_RESULT, AB_DATA,
2081 : : AB_IN_NAMELIST, AB_IN_COMMON, AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE,
2082 : : AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT,
2083 : : AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE,
2084 : : AB_ALLOC_COMP, AB_POINTER_COMP, AB_PROC_POINTER_COMP, AB_PRIVATE_COMP,
2085 : : AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_LOCK_COMP, AB_EVENT_COMP,
2086 : : AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
2087 : : AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
2088 : : AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER,
2089 : : AB_IMPLICIT_PURE, AB_ARTIFICIAL, AB_UNLIMITED_POLY, AB_OMP_DECLARE_TARGET,
2090 : : AB_ARRAY_OUTER_DEPENDENCY, AB_MODULE_PROCEDURE, AB_OACC_DECLARE_CREATE,
2091 : : AB_OACC_DECLARE_COPYIN, AB_OACC_DECLARE_DEVICEPTR,
2092 : : AB_OACC_DECLARE_DEVICE_RESIDENT, AB_OACC_DECLARE_LINK,
2093 : : AB_OMP_DECLARE_TARGET_LINK, AB_PDT_KIND, AB_PDT_LEN, AB_PDT_TYPE,
2094 : : AB_PDT_TEMPLATE, AB_PDT_ARRAY, AB_PDT_STRING,
2095 : : AB_OACC_ROUTINE_LOP_GANG, AB_OACC_ROUTINE_LOP_WORKER,
2096 : : AB_OACC_ROUTINE_LOP_VECTOR, AB_OACC_ROUTINE_LOP_SEQ,
2097 : : AB_OACC_ROUTINE_NOHOST,
2098 : : AB_OMP_REQ_REVERSE_OFFLOAD, AB_OMP_REQ_UNIFIED_ADDRESS,
2099 : : AB_OMP_REQ_UNIFIED_SHARED_MEMORY, AB_OMP_REQ_DYNAMIC_ALLOCATORS,
2100 : : AB_OMP_REQ_MEM_ORDER_SEQ_CST, AB_OMP_REQ_MEM_ORDER_ACQ_REL,
2101 : : AB_OMP_REQ_MEM_ORDER_ACQUIRE, AB_OMP_REQ_MEM_ORDER_RELEASE,
2102 : : AB_OMP_REQ_MEM_ORDER_RELAXED, AB_OMP_DEVICE_TYPE_NOHOST,
2103 : : AB_OMP_DEVICE_TYPE_HOST, AB_OMP_DEVICE_TYPE_ANY
2104 : : };
2105 : :
2106 : : static const mstring attr_bits[] =
2107 : : {
2108 : : minit ("ALLOCATABLE", AB_ALLOCATABLE),
2109 : : minit ("ARTIFICIAL", AB_ARTIFICIAL),
2110 : : minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS),
2111 : : minit ("DIMENSION", AB_DIMENSION),
2112 : : minit ("CODIMENSION", AB_CODIMENSION),
2113 : : minit ("CONTIGUOUS", AB_CONTIGUOUS),
2114 : : minit ("EXTERNAL", AB_EXTERNAL),
2115 : : minit ("INTRINSIC", AB_INTRINSIC),
2116 : : minit ("OPTIONAL", AB_OPTIONAL),
2117 : : minit ("POINTER", AB_POINTER),
2118 : : minit ("VOLATILE", AB_VOLATILE),
2119 : : minit ("TARGET", AB_TARGET),
2120 : : minit ("THREADPRIVATE", AB_THREADPRIVATE),
2121 : : minit ("DUMMY", AB_DUMMY),
2122 : : minit ("RESULT", AB_RESULT),
2123 : : minit ("DATA", AB_DATA),
2124 : : minit ("IN_NAMELIST", AB_IN_NAMELIST),
2125 : : minit ("IN_COMMON", AB_IN_COMMON),
2126 : : minit ("FUNCTION", AB_FUNCTION),
2127 : : minit ("SUBROUTINE", AB_SUBROUTINE),
2128 : : minit ("SEQUENCE", AB_SEQUENCE),
2129 : : minit ("ELEMENTAL", AB_ELEMENTAL),
2130 : : minit ("PURE", AB_PURE),
2131 : : minit ("RECURSIVE", AB_RECURSIVE),
2132 : : minit ("GENERIC", AB_GENERIC),
2133 : : minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT),
2134 : : minit ("CRAY_POINTER", AB_CRAY_POINTER),
2135 : : minit ("CRAY_POINTEE", AB_CRAY_POINTEE),
2136 : : minit ("IS_BIND_C", AB_IS_BIND_C),
2137 : : minit ("IS_C_INTEROP", AB_IS_C_INTEROP),
2138 : : minit ("IS_ISO_C", AB_IS_ISO_C),
2139 : : minit ("VALUE", AB_VALUE),
2140 : : minit ("ALLOC_COMP", AB_ALLOC_COMP),
2141 : : minit ("COARRAY_COMP", AB_COARRAY_COMP),
2142 : : minit ("LOCK_COMP", AB_LOCK_COMP),
2143 : : minit ("EVENT_COMP", AB_EVENT_COMP),
2144 : : minit ("POINTER_COMP", AB_POINTER_COMP),
2145 : : minit ("PROC_POINTER_COMP", AB_PROC_POINTER_COMP),
2146 : : minit ("PRIVATE_COMP", AB_PRIVATE_COMP),
2147 : : minit ("ZERO_COMP", AB_ZERO_COMP),
2148 : : minit ("PROTECTED", AB_PROTECTED),
2149 : : minit ("ABSTRACT", AB_ABSTRACT),
2150 : : minit ("IS_CLASS", AB_IS_CLASS),
2151 : : minit ("PROCEDURE", AB_PROCEDURE),
2152 : : minit ("PROC_POINTER", AB_PROC_POINTER),
2153 : : minit ("VTYPE", AB_VTYPE),
2154 : : minit ("VTAB", AB_VTAB),
2155 : : minit ("CLASS_POINTER", AB_CLASS_POINTER),
2156 : : minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE),
2157 : : minit ("UNLIMITED_POLY", AB_UNLIMITED_POLY),
2158 : : minit ("OMP_DECLARE_TARGET", AB_OMP_DECLARE_TARGET),
2159 : : minit ("ARRAY_OUTER_DEPENDENCY", AB_ARRAY_OUTER_DEPENDENCY),
2160 : : minit ("MODULE_PROCEDURE", AB_MODULE_PROCEDURE),
2161 : : minit ("OACC_DECLARE_CREATE", AB_OACC_DECLARE_CREATE),
2162 : : minit ("OACC_DECLARE_COPYIN", AB_OACC_DECLARE_COPYIN),
2163 : : minit ("OACC_DECLARE_DEVICEPTR", AB_OACC_DECLARE_DEVICEPTR),
2164 : : minit ("OACC_DECLARE_DEVICE_RESIDENT", AB_OACC_DECLARE_DEVICE_RESIDENT),
2165 : : minit ("OACC_DECLARE_LINK", AB_OACC_DECLARE_LINK),
2166 : : minit ("OMP_DECLARE_TARGET_LINK", AB_OMP_DECLARE_TARGET_LINK),
2167 : : minit ("PDT_KIND", AB_PDT_KIND),
2168 : : minit ("PDT_LEN", AB_PDT_LEN),
2169 : : minit ("PDT_TYPE", AB_PDT_TYPE),
2170 : : minit ("PDT_TEMPLATE", AB_PDT_TEMPLATE),
2171 : : minit ("PDT_ARRAY", AB_PDT_ARRAY),
2172 : : minit ("PDT_STRING", AB_PDT_STRING),
2173 : : minit ("OACC_ROUTINE_LOP_GANG", AB_OACC_ROUTINE_LOP_GANG),
2174 : : minit ("OACC_ROUTINE_LOP_WORKER", AB_OACC_ROUTINE_LOP_WORKER),
2175 : : minit ("OACC_ROUTINE_LOP_VECTOR", AB_OACC_ROUTINE_LOP_VECTOR),
2176 : : minit ("OACC_ROUTINE_LOP_SEQ", AB_OACC_ROUTINE_LOP_SEQ),
2177 : : minit ("OACC_ROUTINE_NOHOST", AB_OACC_ROUTINE_NOHOST),
2178 : : minit ("OMP_REQ_REVERSE_OFFLOAD", AB_OMP_REQ_REVERSE_OFFLOAD),
2179 : : minit ("OMP_REQ_UNIFIED_ADDRESS", AB_OMP_REQ_UNIFIED_ADDRESS),
2180 : : minit ("OMP_REQ_UNIFIED_SHARED_MEMORY", AB_OMP_REQ_UNIFIED_SHARED_MEMORY),
2181 : : minit ("OMP_REQ_DYNAMIC_ALLOCATORS", AB_OMP_REQ_DYNAMIC_ALLOCATORS),
2182 : : minit ("OMP_REQ_MEM_ORDER_SEQ_CST", AB_OMP_REQ_MEM_ORDER_SEQ_CST),
2183 : : minit ("OMP_REQ_MEM_ORDER_ACQ_REL", AB_OMP_REQ_MEM_ORDER_ACQ_REL),
2184 : : minit ("OMP_REQ_MEM_ORDER_ACQUIRE", AB_OMP_REQ_MEM_ORDER_ACQUIRE),
2185 : : minit ("OMP_REQ_MEM_ORDER_RELAXED", AB_OMP_REQ_MEM_ORDER_RELAXED),
2186 : : minit ("OMP_REQ_MEM_ORDER_RELEASE", AB_OMP_REQ_MEM_ORDER_RELEASE),
2187 : : minit ("OMP_DEVICE_TYPE_HOST", AB_OMP_DEVICE_TYPE_HOST),
2188 : : minit ("OMP_DEVICE_TYPE_NOHOST", AB_OMP_DEVICE_TYPE_NOHOST),
2189 : : minit ("OMP_DEVICE_TYPE_ANYHOST", AB_OMP_DEVICE_TYPE_ANY),
2190 : : minit (NULL, -1)
2191 : : };
2192 : :
2193 : : /* For binding attributes. */
2194 : : static const mstring binding_passing[] =
2195 : : {
2196 : : minit ("PASS", 0),
2197 : : minit ("NOPASS", 1),
2198 : : minit (NULL, -1)
2199 : : };
2200 : : static const mstring binding_overriding[] =
2201 : : {
2202 : : minit ("OVERRIDABLE", 0),
2203 : : minit ("NON_OVERRIDABLE", 1),
2204 : : minit ("DEFERRED", 2),
2205 : : minit (NULL, -1)
2206 : : };
2207 : : static const mstring binding_generic[] =
2208 : : {
2209 : : minit ("SPECIFIC", 0),
2210 : : minit ("GENERIC", 1),
2211 : : minit (NULL, -1)
2212 : : };
2213 : : static const mstring binding_ppc[] =
2214 : : {
2215 : : minit ("NO_PPC", 0),
2216 : : minit ("PPC", 1),
2217 : : minit (NULL, -1)
2218 : : };
2219 : :
2220 : : /* Specialization of mio_name. */
2221 : 524812 : DECL_MIO_NAME (ab_attribute)
2222 : 3386 : DECL_MIO_NAME (ar_type)
2223 : 134378 : DECL_MIO_NAME (array_type)
2224 : 5876076 : DECL_MIO_NAME (bt)
2225 : 85652 : DECL_MIO_NAME (expr_t)
2226 : 511412 : DECL_MIO_NAME (gfc_access)
2227 : 1444 : DECL_MIO_NAME (gfc_intrinsic_op)
2228 : 1181264 : DECL_MIO_NAME (ifsrc)
2229 : 1181264 : DECL_MIO_NAME (save_state)
2230 : 1181264 : DECL_MIO_NAME (procedure_type)
2231 : 4126 : DECL_MIO_NAME (ref_type)
2232 : 1181264 : DECL_MIO_NAME (sym_flavor)
2233 : 1181264 : DECL_MIO_NAME (sym_intent)
2234 : 0 : DECL_MIO_NAME (inquiry_type)
2235 : : #undef DECL_MIO_NAME
2236 : :
2237 : : /* Verify OACC_ROUTINE_LOP_NONE. */
2238 : :
2239 : : static void
2240 : 94 : verify_OACC_ROUTINE_LOP_NONE (enum oacc_routine_lop lop)
2241 : : {
2242 : 0 : if (lop != OACC_ROUTINE_LOP_NONE)
2243 : 0 : bad_module ("Unsupported: multiple OpenACC 'routine' levels of parallelism");
2244 : 0 : }
2245 : :
2246 : : /* Symbol attributes are stored in list with the first three elements
2247 : : being the enumerated fields, while the remaining elements (if any)
2248 : : indicate the individual attribute bits. The access field is not
2249 : : saved-- it controls what symbols are exported when a module is
2250 : : written. */
2251 : :
2252 : : static void
2253 : 1181264 : mio_symbol_attribute (symbol_attribute *attr)
2254 : : {
2255 : 1181264 : atom_type t;
2256 : 1181264 : unsigned ext_attr,extension_level;
2257 : :
2258 : 1181264 : mio_lparen ();
2259 : :
2260 : 1181264 : attr->flavor = MIO_NAME (sym_flavor) (attr->flavor, flavors);
2261 : 1181264 : attr->intent = MIO_NAME (sym_intent) (attr->intent, intents);
2262 : 1181264 : attr->proc = MIO_NAME (procedure_type) (attr->proc, procedures);
2263 : 1181264 : attr->if_source = MIO_NAME (ifsrc) (attr->if_source, ifsrc_types);
2264 : 1181264 : attr->save = MIO_NAME (save_state) (attr->save, save_status);
2265 : :
2266 : 1181264 : ext_attr = attr->ext_attr;
2267 : 1181264 : mio_integer ((int *) &ext_attr);
2268 : 1181264 : attr->ext_attr = ext_attr;
2269 : :
2270 : 1181264 : extension_level = attr->extension;
2271 : 1181264 : mio_integer ((int *) &extension_level);
2272 : 1181264 : attr->extension = extension_level;
2273 : :
2274 : 1181264 : if (iomode == IO_OUTPUT)
2275 : : {
2276 : 287012 : if (attr->allocatable)
2277 : 3830 : MIO_NAME (ab_attribute) (AB_ALLOCATABLE, attr_bits);
2278 : 287012 : if (attr->artificial)
2279 : 56848 : MIO_NAME (ab_attribute) (AB_ARTIFICIAL, attr_bits);
2280 : 287012 : if (attr->asynchronous)
2281 : 0 : MIO_NAME (ab_attribute) (AB_ASYNCHRONOUS, attr_bits);
2282 : 287012 : if (attr->dimension)
2283 : 15532 : MIO_NAME (ab_attribute) (AB_DIMENSION, attr_bits);
2284 : 287012 : if (attr->codimension)
2285 : 57 : MIO_NAME (ab_attribute) (AB_CODIMENSION, attr_bits);
2286 : 287012 : if (attr->contiguous)
2287 : 2525 : MIO_NAME (ab_attribute) (AB_CONTIGUOUS, attr_bits);
2288 : 287012 : if (attr->external)
2289 : 12455 : MIO_NAME (ab_attribute) (AB_EXTERNAL, attr_bits);
2290 : 287012 : if (attr->intrinsic)
2291 : 3965 : MIO_NAME (ab_attribute) (AB_INTRINSIC, attr_bits);
2292 : 287012 : if (attr->optional)
2293 : 3016 : MIO_NAME (ab_attribute) (AB_OPTIONAL, attr_bits);
2294 : 287012 : if (attr->pointer)
2295 : 27230 : MIO_NAME (ab_attribute) (AB_POINTER, attr_bits);
2296 : 287012 : if (attr->class_pointer)
2297 : 422 : MIO_NAME (ab_attribute) (AB_CLASS_POINTER, attr_bits);
2298 : 287012 : if (attr->is_protected)
2299 : 61 : MIO_NAME (ab_attribute) (AB_PROTECTED, attr_bits);
2300 : 287012 : if (attr->value)
2301 : 8242 : MIO_NAME (ab_attribute) (AB_VALUE, attr_bits);
2302 : 287012 : if (attr->volatile_)
2303 : 39 : MIO_NAME (ab_attribute) (AB_VOLATILE, attr_bits);
2304 : 287012 : if (attr->target)
2305 : 16594 : MIO_NAME (ab_attribute) (AB_TARGET, attr_bits);
2306 : 287012 : if (attr->threadprivate)
2307 : 42 : MIO_NAME (ab_attribute) (AB_THREADPRIVATE, attr_bits);
2308 : 287012 : if (attr->dummy)
2309 : 66768 : MIO_NAME (ab_attribute) (AB_DUMMY, attr_bits);
2310 : 287012 : if (attr->result)
2311 : 3879 : MIO_NAME (ab_attribute) (AB_RESULT, attr_bits);
2312 : : /* We deliberately don't preserve the "entry" flag. */
2313 : :
2314 : 287012 : if (attr->data)
2315 : 19 : MIO_NAME (ab_attribute) (AB_DATA, attr_bits);
2316 : 287012 : if (attr->in_namelist)
2317 : 76 : MIO_NAME (ab_attribute) (AB_IN_NAMELIST, attr_bits);
2318 : 287012 : if (attr->in_common)
2319 : 383 : MIO_NAME (ab_attribute) (AB_IN_COMMON, attr_bits);
2320 : :
2321 : 287012 : if (attr->function)
2322 : 28024 : MIO_NAME (ab_attribute) (AB_FUNCTION, attr_bits);
2323 : 287012 : if (attr->subroutine)
2324 : 42221 : MIO_NAME (ab_attribute) (AB_SUBROUTINE, attr_bits);
2325 : 287012 : if (attr->generic)
2326 : 7873 : MIO_NAME (ab_attribute) (AB_GENERIC, attr_bits);
2327 : 287012 : if (attr->abstract)
2328 : 2507 : MIO_NAME (ab_attribute) (AB_ABSTRACT, attr_bits);
2329 : :
2330 : 287012 : if (attr->sequence)
2331 : 125 : MIO_NAME (ab_attribute) (AB_SEQUENCE, attr_bits);
2332 : 287012 : if (attr->elemental)
2333 : 21629 : MIO_NAME (ab_attribute) (AB_ELEMENTAL, attr_bits);
2334 : 287012 : if (attr->pure)
2335 : 23967 : MIO_NAME (ab_attribute) (AB_PURE, attr_bits);
2336 : 287012 : if (attr->implicit_pure)
2337 : 3661 : MIO_NAME (ab_attribute) (AB_IMPLICIT_PURE, attr_bits);
2338 : 287012 : if (attr->unlimited_polymorphic)
2339 : 276 : MIO_NAME (ab_attribute) (AB_UNLIMITED_POLY, attr_bits);
2340 : 287012 : if (attr->recursive)
2341 : 1980 : MIO_NAME (ab_attribute) (AB_RECURSIVE, attr_bits);
2342 : 287012 : if (attr->always_explicit)
2343 : 31810 : MIO_NAME (ab_attribute) (AB_ALWAYS_EXPLICIT, attr_bits);
2344 : 287012 : if (attr->cray_pointer)
2345 : 13 : MIO_NAME (ab_attribute) (AB_CRAY_POINTER, attr_bits);
2346 : 287012 : if (attr->cray_pointee)
2347 : 13 : MIO_NAME (ab_attribute) (AB_CRAY_POINTEE, attr_bits);
2348 : 287012 : if (attr->is_bind_c)
2349 : 5624 : MIO_NAME(ab_attribute) (AB_IS_BIND_C, attr_bits);
2350 : 287012 : if (attr->is_c_interop)
2351 : 26380 : MIO_NAME(ab_attribute) (AB_IS_C_INTEROP, attr_bits);
2352 : 287012 : if (attr->is_iso_c)
2353 : 23252 : MIO_NAME(ab_attribute) (AB_IS_ISO_C, attr_bits);
2354 : 287012 : if (attr->alloc_comp)
2355 : 2215 : MIO_NAME (ab_attribute) (AB_ALLOC_COMP, attr_bits);
2356 : 287012 : if (attr->pointer_comp)
2357 : 853 : MIO_NAME (ab_attribute) (AB_POINTER_COMP, attr_bits);
2358 : 287012 : if (attr->proc_pointer_comp)
2359 : 235 : MIO_NAME (ab_attribute) (AB_PROC_POINTER_COMP, attr_bits);
2360 : 287012 : if (attr->private_comp)
2361 : 2931 : MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits);
2362 : 287012 : if (attr->coarray_comp)
2363 : 26 : MIO_NAME (ab_attribute) (AB_COARRAY_COMP, attr_bits);
2364 : 287012 : if (attr->lock_comp)
2365 : 3 : MIO_NAME (ab_attribute) (AB_LOCK_COMP, attr_bits);
2366 : 287012 : if (attr->event_comp)
2367 : 0 : MIO_NAME (ab_attribute) (AB_EVENT_COMP, attr_bits);
2368 : 287012 : if (attr->zero_comp)
2369 : 1904 : MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits);
2370 : 287012 : if (attr->is_class)
2371 : 3988 : MIO_NAME (ab_attribute) (AB_IS_CLASS, attr_bits);
2372 : 287012 : if (attr->procedure)
2373 : 4798 : MIO_NAME (ab_attribute) (AB_PROCEDURE, attr_bits);
2374 : 287012 : if (attr->proc_pointer)
2375 : 31395 : MIO_NAME (ab_attribute) (AB_PROC_POINTER, attr_bits);
2376 : 287012 : if (attr->vtype)
2377 : 8977 : MIO_NAME (ab_attribute) (AB_VTYPE, attr_bits);
2378 : 287012 : if (attr->vtab)
2379 : 8462 : MIO_NAME (ab_attribute) (AB_VTAB, attr_bits);
2380 : 287012 : if (attr->omp_declare_target)
2381 : 447 : MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET, attr_bits);
2382 : 287012 : if (attr->array_outer_dependency)
2383 : 15234 : MIO_NAME (ab_attribute) (AB_ARRAY_OUTER_DEPENDENCY, attr_bits);
2384 : 287012 : if (attr->module_procedure)
2385 : 1211 : MIO_NAME (ab_attribute) (AB_MODULE_PROCEDURE, attr_bits);
2386 : 287012 : if (attr->oacc_declare_create)
2387 : 39 : MIO_NAME (ab_attribute) (AB_OACC_DECLARE_CREATE, attr_bits);
2388 : 287012 : if (attr->oacc_declare_copyin)
2389 : 3 : MIO_NAME (ab_attribute) (AB_OACC_DECLARE_COPYIN, attr_bits);
2390 : 287012 : if (attr->oacc_declare_deviceptr)
2391 : 1 : MIO_NAME (ab_attribute) (AB_OACC_DECLARE_DEVICEPTR, attr_bits);
2392 : 287012 : if (attr->oacc_declare_device_resident)
2393 : 31 : MIO_NAME (ab_attribute) (AB_OACC_DECLARE_DEVICE_RESIDENT, attr_bits);
2394 : 287012 : if (attr->oacc_declare_link)
2395 : 1 : MIO_NAME (ab_attribute) (AB_OACC_DECLARE_LINK, attr_bits);
2396 : 287012 : if (attr->omp_declare_target_link)
2397 : 18 : MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET_LINK, attr_bits);
2398 : 287012 : if (attr->pdt_kind)
2399 : 136 : MIO_NAME (ab_attribute) (AB_PDT_KIND, attr_bits);
2400 : 287012 : if (attr->pdt_len)
2401 : 205 : MIO_NAME (ab_attribute) (AB_PDT_LEN, attr_bits);
2402 : 287012 : if (attr->pdt_type)
2403 : 62 : MIO_NAME (ab_attribute) (AB_PDT_TYPE, attr_bits);
2404 : 287012 : if (attr->pdt_template)
2405 : 82 : MIO_NAME (ab_attribute) (AB_PDT_TEMPLATE, attr_bits);
2406 : 287012 : if (attr->pdt_array)
2407 : 19 : MIO_NAME (ab_attribute) (AB_PDT_ARRAY, attr_bits);
2408 : 287012 : if (attr->pdt_string)
2409 : 2 : MIO_NAME (ab_attribute) (AB_PDT_STRING, attr_bits);
2410 : 287012 : switch (attr->oacc_routine_lop)
2411 : : {
2412 : : case OACC_ROUTINE_LOP_NONE:
2413 : : /* This is the default anyway, and for maintaining compatibility with
2414 : : the current MOD_VERSION, we're not emitting anything in that
2415 : : case. */
2416 : : break;
2417 : 12 : case OACC_ROUTINE_LOP_GANG:
2418 : 12 : MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_LOP_GANG, attr_bits);
2419 : 12 : break;
2420 : 10 : case OACC_ROUTINE_LOP_WORKER:
2421 : 10 : MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_LOP_WORKER, attr_bits);
2422 : 10 : break;
2423 : 8 : case OACC_ROUTINE_LOP_VECTOR:
2424 : 8 : MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_LOP_VECTOR, attr_bits);
2425 : 8 : break;
2426 : 79 : case OACC_ROUTINE_LOP_SEQ:
2427 : 79 : MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_LOP_SEQ, attr_bits);
2428 : 79 : break;
2429 : 0 : case OACC_ROUTINE_LOP_ERROR:
2430 : : /* ... intentionally omitted here; it's only used internally. */
2431 : 0 : default:
2432 : 0 : gcc_unreachable ();
2433 : : }
2434 : 287012 : if (attr->oacc_routine_nohost)
2435 : 21 : MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_NOHOST, attr_bits);
2436 : :
2437 : 287012 : if (attr->flavor == FL_MODULE && gfc_current_ns->omp_requires)
2438 : : {
2439 : 28 : if (gfc_current_ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD)
2440 : 15 : MIO_NAME (ab_attribute) (AB_OMP_REQ_REVERSE_OFFLOAD, attr_bits);
2441 : 28 : if (gfc_current_ns->omp_requires & OMP_REQ_UNIFIED_ADDRESS)
2442 : 1 : MIO_NAME (ab_attribute) (AB_OMP_REQ_UNIFIED_ADDRESS, attr_bits);
2443 : 28 : if (gfc_current_ns->omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY)
2444 : 3 : MIO_NAME (ab_attribute) (AB_OMP_REQ_UNIFIED_SHARED_MEMORY, attr_bits);
2445 : 28 : if (gfc_current_ns->omp_requires & OMP_REQ_DYNAMIC_ALLOCATORS)
2446 : 2 : MIO_NAME (ab_attribute) (AB_OMP_REQ_DYNAMIC_ALLOCATORS, attr_bits);
2447 : 28 : if ((gfc_current_ns->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
2448 : : == OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST)
2449 : 3 : MIO_NAME (ab_attribute) (AB_OMP_REQ_MEM_ORDER_SEQ_CST, attr_bits);
2450 : 28 : if ((gfc_current_ns->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
2451 : : == OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL)
2452 : 3 : MIO_NAME (ab_attribute) (AB_OMP_REQ_MEM_ORDER_ACQ_REL, attr_bits);
2453 : 28 : if ((gfc_current_ns->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
2454 : : == OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE)
2455 : 0 : MIO_NAME (ab_attribute) (AB_OMP_REQ_MEM_ORDER_ACQUIRE, attr_bits);
2456 : 28 : if ((gfc_current_ns->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
2457 : : == OMP_REQ_ATOMIC_MEM_ORDER_RELAXED)
2458 : 3 : MIO_NAME (ab_attribute) (AB_OMP_REQ_MEM_ORDER_RELAXED, attr_bits);
2459 : 28 : if ((gfc_current_ns->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
2460 : : == OMP_REQ_ATOMIC_MEM_ORDER_RELEASE)
2461 : 0 : MIO_NAME (ab_attribute) (AB_OMP_REQ_MEM_ORDER_RELEASE, attr_bits);
2462 : : }
2463 : 287012 : switch (attr->omp_device_type)
2464 : : {
2465 : : case OMP_DEVICE_TYPE_UNSET:
2466 : : break;
2467 : 12 : case OMP_DEVICE_TYPE_HOST:
2468 : 12 : MIO_NAME (ab_attribute) (AB_OMP_DEVICE_TYPE_HOST, attr_bits);
2469 : 12 : break;
2470 : 12 : case OMP_DEVICE_TYPE_NOHOST:
2471 : 12 : MIO_NAME (ab_attribute) (AB_OMP_DEVICE_TYPE_NOHOST, attr_bits);
2472 : 12 : break;
2473 : 12 : case OMP_DEVICE_TYPE_ANY:
2474 : 12 : MIO_NAME (ab_attribute) (AB_OMP_DEVICE_TYPE_ANY, attr_bits);
2475 : 12 : break;
2476 : 0 : default:
2477 : 0 : gcc_unreachable ();
2478 : : }
2479 : 287012 : mio_rparen ();
2480 : : }
2481 : : else
2482 : : {
2483 : 2625130 : for (;;)
2484 : : {
2485 : 2625130 : t = parse_atom ();
2486 : 2625130 : if (t == ATOM_RPAREN)
2487 : : break;
2488 : 1730878 : if (t != ATOM_NAME)
2489 : 0 : bad_module ("Expected attribute bit name");
2490 : :
2491 : 1730878 : switch ((ab_attribute) find_enum (attr_bits))
2492 : : {
2493 : 3750 : case AB_ALLOCATABLE:
2494 : 3750 : attr->allocatable = 1;
2495 : 3750 : break;
2496 : 79137 : case AB_ARTIFICIAL:
2497 : 79137 : attr->artificial = 1;
2498 : 79137 : break;
2499 : 0 : case AB_ASYNCHRONOUS:
2500 : 0 : attr->asynchronous = 1;
2501 : 0 : break;
2502 : 51549 : case AB_DIMENSION:
2503 : 51549 : attr->dimension = 1;
2504 : 51549 : break;
2505 : 66 : case AB_CODIMENSION:
2506 : 66 : attr->codimension = 1;
2507 : 66 : break;
2508 : 6514 : case AB_CONTIGUOUS:
2509 : 6514 : attr->contiguous = 1;
2510 : 6514 : break;
2511 : 150919 : case AB_EXTERNAL:
2512 : 150919 : attr->external = 1;
2513 : 150919 : break;
2514 : 2409 : case AB_INTRINSIC:
2515 : 2409 : attr->intrinsic = 1;
2516 : 2409 : break;
2517 : 4932 : case AB_OPTIONAL:
2518 : 4932 : attr->optional = 1;
2519 : 4932 : break;
2520 : 33885 : case AB_POINTER:
2521 : 33885 : attr->pointer = 1;
2522 : 33885 : break;
2523 : 355 : case AB_CLASS_POINTER:
2524 : 355 : attr->class_pointer = 1;
2525 : 355 : break;
2526 : 55 : case AB_PROTECTED:
2527 : 55 : attr->is_protected = 1;
2528 : 55 : break;
2529 : 52941 : case AB_VALUE:
2530 : 52941 : attr->value = 1;
2531 : 52941 : break;
2532 : 45 : case AB_VOLATILE:
2533 : 45 : attr->volatile_ = 1;
2534 : 45 : break;
2535 : 23470 : case AB_TARGET:
2536 : 23470 : attr->target = 1;
2537 : 23470 : break;
2538 : 52 : case AB_THREADPRIVATE:
2539 : 52 : attr->threadprivate = 1;
2540 : 52 : break;
2541 : 331800 : case AB_DUMMY:
2542 : 331800 : attr->dummy = 1;
2543 : 331800 : break;
2544 : 26844 : case AB_RESULT:
2545 : 26844 : attr->result = 1;
2546 : 26844 : break;
2547 : 19 : case AB_DATA:
2548 : 19 : attr->data = 1;
2549 : 19 : break;
2550 : 81 : case AB_IN_NAMELIST:
2551 : 81 : attr->in_namelist = 1;
2552 : 81 : break;
2553 : 301 : case AB_IN_COMMON:
2554 : 301 : attr->in_common = 1;
2555 : 301 : break;
2556 : 149524 : case AB_FUNCTION:
2557 : 149524 : attr->function = 1;
2558 : 149524 : break;
2559 : 95766 : case AB_SUBROUTINE:
2560 : 95766 : attr->subroutine = 1;
2561 : 95766 : break;
2562 : 20411 : case AB_GENERIC:
2563 : 20411 : attr->generic = 1;
2564 : 20411 : break;
2565 : 1922 : case AB_ABSTRACT:
2566 : 1922 : attr->abstract = 1;
2567 : 1922 : break;
2568 : 137 : case AB_SEQUENCE:
2569 : 137 : attr->sequence = 1;
2570 : 137 : break;
2571 : 91776 : case AB_ELEMENTAL:
2572 : 91776 : attr->elemental = 1;
2573 : 91776 : break;
2574 : 113149 : case AB_PURE:
2575 : 113149 : attr->pure = 1;
2576 : 113149 : break;
2577 : 3743 : case AB_IMPLICIT_PURE:
2578 : 3743 : attr->implicit_pure = 1;
2579 : 3743 : break;
2580 : 249 : case AB_UNLIMITED_POLY:
2581 : 249 : attr->unlimited_polymorphic = 1;
2582 : 249 : break;
2583 : 1947 : case AB_RECURSIVE:
2584 : 1947 : attr->recursive = 1;
2585 : 1947 : break;
2586 : 135927 : case AB_ALWAYS_EXPLICIT:
2587 : 135927 : attr->always_explicit = 1;
2588 : 135927 : break;
2589 : 13 : case AB_CRAY_POINTER:
2590 : 13 : attr->cray_pointer = 1;
2591 : 13 : break;
2592 : 13 : case AB_CRAY_POINTEE:
2593 : 13 : attr->cray_pointee = 1;
2594 : 13 : break;
2595 : 29186 : case AB_IS_BIND_C:
2596 : 29186 : attr->is_bind_c = 1;
2597 : 29186 : break;
2598 : 42288 : case AB_IS_C_INTEROP:
2599 : 42288 : attr->is_c_interop = 1;
2600 : 42288 : break;
2601 : 13717 : case AB_IS_ISO_C:
2602 : 13717 : attr->is_iso_c = 1;
2603 : 13717 : break;
2604 : 2105 : case AB_ALLOC_COMP:
2605 : 2105 : attr->alloc_comp = 1;
2606 : 2105 : break;
2607 : 18 : case AB_COARRAY_COMP:
2608 : 18 : attr->coarray_comp = 1;
2609 : 18 : break;
2610 : 4 : case AB_LOCK_COMP:
2611 : 4 : attr->lock_comp = 1;
2612 : 4 : break;
2613 : 0 : case AB_EVENT_COMP:
2614 : 0 : attr->event_comp = 1;
2615 : 0 : break;
2616 : 795 : case AB_POINTER_COMP:
2617 : 795 : attr->pointer_comp = 1;
2618 : 795 : break;
2619 : 220 : case AB_PROC_POINTER_COMP:
2620 : 220 : attr->proc_pointer_comp = 1;
2621 : 220 : break;
2622 : 16049 : case AB_PRIVATE_COMP:
2623 : 16049 : attr->private_comp = 1;
2624 : 16049 : break;
2625 : 1617 : case AB_ZERO_COMP:
2626 : 1617 : attr->zero_comp = 1;
2627 : 1617 : break;
2628 : 3589 : case AB_IS_CLASS:
2629 : 3589 : attr->is_class = 1;
2630 : 3589 : break;
2631 : 4389 : case AB_PROCEDURE:
2632 : 4389 : attr->procedure = 1;
2633 : 4389 : break;
2634 : 42485 : case AB_PROC_POINTER:
2635 : 42485 : attr->proc_pointer = 1;
2636 : 42485 : break;
2637 : 12789 : case AB_VTYPE:
2638 : 12789 : attr->vtype = 1;
2639 : 12789 : break;
2640 : 12493 : case AB_VTAB:
2641 : 12493 : attr->vtab = 1;
2642 : 12493 : break;
2643 : 511 : case AB_OMP_DECLARE_TARGET:
2644 : 511 : attr->omp_declare_target = 1;
2645 : 511 : break;
2646 : 9 : case AB_OMP_DECLARE_TARGET_LINK:
2647 : 9 : attr->omp_declare_target_link = 1;
2648 : 9 : break;
2649 : 163323 : case AB_ARRAY_OUTER_DEPENDENCY:
2650 : 163323 : attr->array_outer_dependency =1;
2651 : 163323 : break;
2652 : 845 : case AB_MODULE_PROCEDURE:
2653 : 845 : attr->module_procedure =1;
2654 : 845 : break;
2655 : 110 : case AB_OACC_DECLARE_CREATE:
2656 : 110 : attr->oacc_declare_create = 1;
2657 : 110 : break;
2658 : 2 : case AB_OACC_DECLARE_COPYIN:
2659 : 2 : attr->oacc_declare_copyin = 1;
2660 : 2 : break;
2661 : 0 : case AB_OACC_DECLARE_DEVICEPTR:
2662 : 0 : attr->oacc_declare_deviceptr = 1;
2663 : 0 : break;
2664 : 32 : case AB_OACC_DECLARE_DEVICE_RESIDENT:
2665 : 32 : attr->oacc_declare_device_resident = 1;
2666 : 32 : break;
2667 : 2 : case AB_OACC_DECLARE_LINK:
2668 : 2 : attr->oacc_declare_link = 1;
2669 : 2 : break;
2670 : 108 : case AB_PDT_KIND:
2671 : 108 : attr->pdt_kind = 1;
2672 : 108 : break;
2673 : 183 : case AB_PDT_LEN:
2674 : 183 : attr->pdt_len = 1;
2675 : 183 : break;
2676 : 50 : case AB_PDT_TYPE:
2677 : 50 : attr->pdt_type = 1;
2678 : 50 : break;
2679 : 71 : case AB_PDT_TEMPLATE:
2680 : 71 : attr->pdt_template = 1;
2681 : 71 : break;
2682 : 19 : case AB_PDT_ARRAY:
2683 : 19 : attr->pdt_array = 1;
2684 : 19 : break;
2685 : 0 : case AB_PDT_STRING:
2686 : 0 : attr->pdt_string = 1;
2687 : 0 : break;
2688 : 8 : case AB_OACC_ROUTINE_LOP_GANG:
2689 : 8 : verify_OACC_ROUTINE_LOP_NONE (attr->oacc_routine_lop);
2690 : 8 : attr->oacc_routine_lop = OACC_ROUTINE_LOP_GANG;
2691 : 8 : break;
2692 : 8 : case AB_OACC_ROUTINE_LOP_WORKER:
2693 : 8 : verify_OACC_ROUTINE_LOP_NONE (attr->oacc_routine_lop);
2694 : 8 : attr->oacc_routine_lop = OACC_ROUTINE_LOP_WORKER;
2695 : 8 : break;
2696 : 8 : case AB_OACC_ROUTINE_LOP_VECTOR:
2697 : 8 : verify_OACC_ROUTINE_LOP_NONE (attr->oacc_routine_lop);
2698 : 8 : attr->oacc_routine_lop = OACC_ROUTINE_LOP_VECTOR;
2699 : 8 : break;
2700 : 70 : case AB_OACC_ROUTINE_LOP_SEQ:
2701 : 70 : verify_OACC_ROUTINE_LOP_NONE (attr->oacc_routine_lop);
2702 : 70 : attr->oacc_routine_lop = OACC_ROUTINE_LOP_SEQ;
2703 : 70 : break;
2704 : 20 : case AB_OACC_ROUTINE_NOHOST:
2705 : 20 : attr->oacc_routine_nohost = 1;
2706 : 20 : break;
2707 : 24 : case AB_OMP_REQ_REVERSE_OFFLOAD:
2708 : 24 : gfc_omp_requires_add_clause (OMP_REQ_REVERSE_OFFLOAD,
2709 : : "reverse_offload",
2710 : : &gfc_current_locus,
2711 : : module_name);
2712 : 24 : break;
2713 : 0 : case AB_OMP_REQ_UNIFIED_ADDRESS:
2714 : 0 : gfc_omp_requires_add_clause (OMP_REQ_UNIFIED_ADDRESS,
2715 : : "unified_address",
2716 : : &gfc_current_locus,
2717 : : module_name);
2718 : 0 : break;
2719 : 0 : case AB_OMP_REQ_UNIFIED_SHARED_MEMORY:
2720 : 0 : gfc_omp_requires_add_clause (OMP_REQ_UNIFIED_SHARED_MEMORY,
2721 : : "unified_shared_memory",
2722 : : &gfc_current_locus,
2723 : : module_name);
2724 : 0 : break;
2725 : 0 : case AB_OMP_REQ_DYNAMIC_ALLOCATORS:
2726 : 0 : gfc_omp_requires_add_clause (OMP_REQ_DYNAMIC_ALLOCATORS,
2727 : : "dynamic_allocators",
2728 : : &gfc_current_locus,
2729 : : module_name);
2730 : 0 : break;
2731 : 2 : case AB_OMP_REQ_MEM_ORDER_SEQ_CST:
2732 : 2 : gfc_omp_requires_add_clause (OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST,
2733 : : "seq_cst", &gfc_current_locus,
2734 : : module_name);
2735 : 2 : break;
2736 : 2 : case AB_OMP_REQ_MEM_ORDER_ACQ_REL:
2737 : 2 : gfc_omp_requires_add_clause (OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL,
2738 : : "acq_rel", &gfc_current_locus,
2739 : : module_name);
2740 : 2 : break;
2741 : 0 : case AB_OMP_REQ_MEM_ORDER_ACQUIRE:
2742 : 0 : gfc_omp_requires_add_clause (OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE,
2743 : : "acquires", &gfc_current_locus,
2744 : : module_name);
2745 : 0 : break;
2746 : 2 : case AB_OMP_REQ_MEM_ORDER_RELAXED:
2747 : 2 : gfc_omp_requires_add_clause (OMP_REQ_ATOMIC_MEM_ORDER_RELAXED,
2748 : : "relaxed", &gfc_current_locus,
2749 : : module_name);
2750 : 2 : break;
2751 : 0 : case AB_OMP_REQ_MEM_ORDER_RELEASE:
2752 : 0 : gfc_omp_requires_add_clause (OMP_REQ_ATOMIC_MEM_ORDER_RELEASE,
2753 : : "release", &gfc_current_locus,
2754 : : module_name);
2755 : 0 : break;
2756 : 8 : case AB_OMP_DEVICE_TYPE_HOST:
2757 : 8 : attr->omp_device_type = OMP_DEVICE_TYPE_HOST;
2758 : 8 : break;
2759 : 8 : case AB_OMP_DEVICE_TYPE_NOHOST:
2760 : 8 : attr->omp_device_type = OMP_DEVICE_TYPE_NOHOST;
2761 : 8 : break;
2762 : 8 : case AB_OMP_DEVICE_TYPE_ANY:
2763 : 8 : attr->omp_device_type = OMP_DEVICE_TYPE_ANY;
2764 : 8 : break;
2765 : : }
2766 : : }
2767 : : }
2768 : 1181264 : }
2769 : :
2770 : :
2771 : : static const mstring bt_types[] = {
2772 : : minit ("INTEGER", BT_INTEGER),
2773 : : minit ("REAL", BT_REAL),
2774 : : minit ("COMPLEX", BT_COMPLEX),
2775 : : minit ("LOGICAL", BT_LOGICAL),
2776 : : minit ("CHARACTER", BT_CHARACTER),
2777 : : minit ("UNION", BT_UNION),
2778 : : minit ("DERIVED", BT_DERIVED),
2779 : : minit ("CLASS", BT_CLASS),
2780 : : minit ("PROCEDURE", BT_PROCEDURE),
2781 : : minit ("UNKNOWN", BT_UNKNOWN),
2782 : : minit ("VOID", BT_VOID),
2783 : : minit ("ASSUMED", BT_ASSUMED),
2784 : : minit (NULL, -1)
2785 : : };
2786 : :
2787 : :
2788 : : static void
2789 : 29923 : mio_charlen (gfc_charlen **clp)
2790 : : {
2791 : 29923 : gfc_charlen *cl;
2792 : :
2793 : 29923 : mio_lparen ();
2794 : :
2795 : 29923 : if (iomode == IO_OUTPUT)
2796 : : {
2797 : 15919 : cl = *clp;
2798 : 15919 : if (cl != NULL)
2799 : 15769 : mio_expr (&cl->length);
2800 : : }
2801 : : else
2802 : : {
2803 : 14004 : if (peek_atom () != ATOM_RPAREN)
2804 : : {
2805 : 13854 : cl = gfc_new_charlen (gfc_current_ns, NULL);
2806 : 13854 : mio_expr (&cl->length);
2807 : 13854 : *clp = cl;
2808 : : }
2809 : : }
2810 : :
2811 : 29923 : mio_rparen ();
2812 : 29923 : }
2813 : :
2814 : :
2815 : : /* See if a name is a generated name. */
2816 : :
2817 : : static int
2818 : 554662 : check_unique_name (const char *name)
2819 : : {
2820 : 554662 : return *name == '@';
2821 : : }
2822 : :
2823 : :
2824 : : static void
2825 : 1469019 : mio_typespec (gfc_typespec *ts)
2826 : : {
2827 : 1469019 : mio_lparen ();
2828 : :
2829 : 1469019 : ts->type = MIO_NAME (bt) (ts->type, bt_types);
2830 : :
2831 : 1469019 : if (!gfc_bt_struct (ts->type) && ts->type != BT_CLASS)
2832 : 1216515 : mio_integer (&ts->kind);
2833 : : else
2834 : 252504 : mio_symbol_ref (&ts->u.derived);
2835 : :
2836 : 1469019 : mio_symbol_ref (&ts->interface);
2837 : :
2838 : : /* Add info for C interop and is_iso_c. */
2839 : 1469019 : mio_integer (&ts->is_c_interop);
2840 : 1469019 : mio_integer (&ts->is_iso_c);
2841 : :
2842 : : /* If the typespec is for an identifier either from iso_c_binding, or
2843 : : a constant that was initialized to an identifier from it, use the
2844 : : f90_type. Otherwise, use the ts->type, since it shouldn't matter. */
2845 : 1469019 : if (ts->is_iso_c)
2846 : 86267 : ts->f90_type = MIO_NAME (bt) (ts->f90_type, bt_types);
2847 : : else
2848 : 1382752 : ts->f90_type = MIO_NAME (bt) (ts->type, bt_types);
2849 : :
2850 : 1469019 : if (ts->type != BT_CHARACTER)
2851 : : {
2852 : : /* ts->u.cl is only valid for BT_CHARACTER. */
2853 : 1439102 : mio_lparen ();
2854 : 1439102 : mio_rparen ();
2855 : : }
2856 : : else
2857 : 29917 : mio_charlen (&ts->u.cl);
2858 : :
2859 : : /* So as not to disturb the existing API, use an ATOM_NAME to
2860 : : transmit deferred characteristic for characters (F2003). */
2861 : 1469019 : if (iomode == IO_OUTPUT)
2862 : : {
2863 : 372738 : if (ts->type == BT_CHARACTER && ts->deferred)
2864 : 424 : write_atom (ATOM_NAME, "DEFERRED_CL");
2865 : : }
2866 : 1096281 : else if (peek_atom () != ATOM_RPAREN)
2867 : : {
2868 : 398 : if (parse_atom () != ATOM_NAME)
2869 : 0 : bad_module ("Expected string");
2870 : 398 : ts->deferred = 1;
2871 : : }
2872 : :
2873 : 1469019 : mio_rparen ();
2874 : 1469019 : }
2875 : :
2876 : :
2877 : : static const mstring array_spec_types[] = {
2878 : : minit ("EXPLICIT", AS_EXPLICIT),
2879 : : minit ("ASSUMED_RANK", AS_ASSUMED_RANK),
2880 : : minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE),
2881 : : minit ("DEFERRED", AS_DEFERRED),
2882 : : minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE),
2883 : : minit (NULL, -1)
2884 : : };
2885 : :
2886 : :
2887 : : static void
2888 : 1181244 : mio_array_spec (gfc_array_spec **asp)
2889 : : {
2890 : 1181244 : gfc_array_spec *as;
2891 : 1181244 : int i;
2892 : :
2893 : 1181244 : mio_lparen ();
2894 : :
2895 : 1181244 : if (iomode == IO_OUTPUT)
2896 : : {
2897 : 287012 : int rank;
2898 : :
2899 : 287012 : if (*asp == NULL)
2900 : 271433 : goto done;
2901 : 15579 : as = *asp;
2902 : :
2903 : : /* mio_integer expects nonnegative values. */
2904 : 15579 : rank = as->rank > 0 ? as->rank : 0;
2905 : 15579 : mio_integer (&rank);
2906 : : }
2907 : : else
2908 : : {
2909 : 894232 : if (peek_atom () == ATOM_RPAREN)
2910 : : {
2911 : 842622 : *asp = NULL;
2912 : 842622 : goto done;
2913 : : }
2914 : :
2915 : 51610 : *asp = as = gfc_get_array_spec ();
2916 : 51610 : mio_integer (&as->rank);
2917 : : }
2918 : :
2919 : 67189 : mio_integer (&as->corank);
2920 : 67189 : as->type = MIO_NAME (array_type) (as->type, array_spec_types);
2921 : :
2922 : 67189 : if (iomode == IO_INPUT && as->type == AS_ASSUMED_RANK)
2923 : 18889 : as->rank = -1;
2924 : 67189 : if (iomode == IO_INPUT && as->corank)
2925 : 111 : as->cotype = (as->type == AS_DEFERRED) ? AS_DEFERRED : AS_EXPLICIT;
2926 : :
2927 : 67189 : if (as->rank + as->corank > 0)
2928 : 94487 : for (i = 0; i < as->rank + as->corank; i++)
2929 : : {
2930 : 49525 : mio_expr (&as->lower[i]);
2931 : 49525 : mio_expr (&as->upper[i]);
2932 : : }
2933 : :
2934 : 22227 : done:
2935 : 1181244 : mio_rparen ();
2936 : 1181244 : }
2937 : :
2938 : :
2939 : : /* Given a pointer to an array reference structure (which lives in a
2940 : : gfc_ref structure), find the corresponding array specification
2941 : : structure. Storing the pointer in the ref structure doesn't quite
2942 : : work when loading from a module. Generating code for an array
2943 : : reference also needs more information than just the array spec. */
2944 : :
2945 : : static const mstring array_ref_types[] = {
2946 : : minit ("FULL", AR_FULL),
2947 : : minit ("ELEMENT", AR_ELEMENT),
2948 : : minit ("SECTION", AR_SECTION),
2949 : : minit (NULL, -1)
2950 : : };
2951 : :
2952 : :
2953 : : static void
2954 : 1693 : mio_array_ref (gfc_array_ref *ar)
2955 : : {
2956 : 1693 : int i;
2957 : :
2958 : 1693 : mio_lparen ();
2959 : 1693 : ar->type = MIO_NAME (ar_type) (ar->type, array_ref_types);
2960 : 1693 : mio_integer (&ar->dimen);
2961 : :
2962 : 1693 : switch (ar->type)
2963 : : {
2964 : : case AR_FULL:
2965 : : break;
2966 : :
2967 : : case AR_ELEMENT:
2968 : 812 : for (i = 0; i < ar->dimen; i++)
2969 : 408 : mio_expr (&ar->start[i]);
2970 : :
2971 : : break;
2972 : :
2973 : : case AR_SECTION:
2974 : 0 : for (i = 0; i < ar->dimen; i++)
2975 : : {
2976 : 0 : mio_expr (&ar->start[i]);
2977 : 0 : mio_expr (&ar->end[i]);
2978 : 0 : mio_expr (&ar->stride[i]);
2979 : : }
2980 : :
2981 : : break;
2982 : :
2983 : 0 : case AR_UNKNOWN:
2984 : 0 : gfc_internal_error ("mio_array_ref(): Unknown array ref");
2985 : : }
2986 : :
2987 : : /* Unfortunately, ar->dimen_type is an anonymous enumerated type so
2988 : : we can't call mio_integer directly. Instead loop over each element
2989 : : and cast it to/from an integer. */
2990 : 1693 : if (iomode == IO_OUTPUT)
2991 : : {
2992 : 1902 : for (i = 0; i < ar->dimen; i++)
2993 : : {
2994 : 1062 : HOST_WIDE_INT tmp = (HOST_WIDE_INT)ar->dimen_type[i];
2995 : 1062 : write_atom (ATOM_INTEGER, &tmp);
2996 : : }
2997 : : }
2998 : : else
2999 : : {
3000 : 1960 : for (i = 0; i < ar->dimen; i++)
3001 : : {
3002 : 1107 : require_atom (ATOM_INTEGER);
3003 : 1107 : ar->dimen_type[i] = (enum gfc_array_ref_dimen_type) atom_int;
3004 : : }
3005 : : }
3006 : :
3007 : 1693 : if (iomode == IO_INPUT)
3008 : : {
3009 : 853 : ar->where = gfc_current_locus;
3010 : :
3011 : 1960 : for (i = 0; i < ar->dimen; i++)
3012 : 1107 : ar->c_where[i] = gfc_current_locus;
3013 : : }
3014 : :
3015 : 1693 : mio_rparen ();
3016 : 1693 : }
3017 : :
3018 : :
3019 : : /* Saves or restores a pointer. The pointer is converted back and
3020 : : forth from an integer. We return the pointer_info pointer so that
3021 : : the caller can take additional action based on the pointer type. */
3022 : :
3023 : : static pointer_info *
3024 : 5374258 : mio_pointer_ref (void *gp)
3025 : : {
3026 : 5374258 : pointer_info *p;
3027 : :
3028 : 5374258 : if (iomode == IO_OUTPUT)
3029 : : {
3030 : 1350494 : p = get_pointer (*((char **) gp));
3031 : 1350494 : HOST_WIDE_INT hwi = p->integer;
3032 : 1350494 : write_atom (ATOM_INTEGER, &hwi);
3033 : : }
3034 : : else
3035 : : {
3036 : 4023764 : require_atom (ATOM_INTEGER);
3037 : 4023764 : p = add_fixup (atom_int, gp);
3038 : : }
3039 : :
3040 : 5374258 : return p;
3041 : : }
3042 : :
3043 : :
3044 : : /* Save and load references to components that occur within
3045 : : expressions. We have to describe these references by a number and
3046 : : by name. The number is necessary for forward references during
3047 : : reading, and the name is necessary if the symbol already exists in
3048 : : the namespace and is not loaded again. */
3049 : :
3050 : : static void
3051 : 364 : mio_component_ref (gfc_component **cp)
3052 : : {
3053 : 364 : pointer_info *p;
3054 : :
3055 : 364 : p = mio_pointer_ref (cp);
3056 : 364 : if (p->type == P_UNKNOWN)
3057 : 57 : p->type = P_COMPONENT;
3058 : 364 : }
3059 : :
3060 : :
3061 : : static void mio_namespace_ref (gfc_namespace **nsp);
3062 : : static void mio_formal_arglist (gfc_formal_arglist **formal);
3063 : : static void mio_typebound_proc (gfc_typebound_proc** proc);
3064 : : static void mio_actual_arglist (gfc_actual_arglist **ap, bool pdt);
3065 : :
3066 : : static void
3067 : 219734 : mio_component (gfc_component *c, int vtype)
3068 : : {
3069 : 219734 : pointer_info *p;
3070 : :
3071 : 219734 : mio_lparen ();
3072 : :
3073 : 219734 : if (iomode == IO_OUTPUT)
3074 : : {
3075 : 87470 : p = get_pointer (c);
3076 : 87470 : mio_hwi (&p->integer);
3077 : : }
3078 : : else
3079 : : {
3080 : 132264 : HOST_WIDE_INT n;
3081 : 132264 : mio_hwi (&n);
3082 : 132264 : p = get_integer (n);
3083 : 132264 : associate_integer_pointer (p, c);
3084 : : }
3085 : :
3086 : 219734 : if (p->type == P_UNKNOWN)
3087 : 219704 : p->type = P_COMPONENT;
3088 : :
3089 : 219734 : mio_pool_string (&c->name);
3090 : 219734 : mio_typespec (&c->ts);
3091 : 219734 : mio_array_spec (&c->as);
3092 : :
3093 : : /* PDT templates store the expression for the kind of a component here. */
3094 : 219734 : mio_expr (&c->kind_expr);
3095 : :
3096 : : /* PDT types store the component specification list here. */
3097 : 219734 : mio_actual_arglist (&c->param_list, true);
3098 : :
3099 : 219734 : mio_symbol_attribute (&c->attr);
3100 : 219734 : if (c->ts.type == BT_CLASS)
3101 : 1935 : c->attr.class_ok = 1;
3102 : 219734 : c->attr.access = MIO_NAME (gfc_access) (c->attr.access, access_types);
3103 : :
3104 : 219734 : if (!vtype || strcmp (c->name, "_final") == 0
3105 : 138453 : || strcmp (c->name, "_hash") == 0)
3106 : 103047 : mio_expr (&c->initializer);
3107 : :
3108 : 219734 : if (c->attr.proc_pointer)
3109 : 73563 : mio_typebound_proc (&c->tb);
3110 : :
3111 : 219734 : c->loc = gfc_current_locus;
3112 : :
3113 : 219734 : mio_rparen ();
3114 : 219734 : }
3115 : :
3116 : :
3117 : : static void
3118 : 961510 : mio_component_list (gfc_component **cp, int vtype)
3119 : : {
3120 : 961510 : gfc_component *c, *tail;
3121 : :
3122 : 961510 : mio_lparen ();
3123 : :
3124 : 961510 : if (iomode == IO_OUTPUT)
3125 : : {
3126 : 287012 : for (c = *cp; c; c = c->next)
3127 : 87470 : mio_component (c, vtype);
3128 : : }
3129 : : else
3130 : : {
3131 : 761968 : *cp = NULL;
3132 : 761968 : tail = NULL;
3133 : :
3134 : 894232 : for (;;)
3135 : : {
3136 : 894232 : if (peek_atom () == ATOM_RPAREN)
3137 : : break;
3138 : :
3139 : 132264 : c = gfc_get_component ();
3140 : 132264 : mio_component (c, vtype);
3141 : :
3142 : 132264 : if (tail == NULL)
3143 : 40518 : *cp = c;
3144 : : else
3145 : 91746 : tail->next = c;
3146 : :
3147 : : tail = c;
3148 : : }
3149 : : }
3150 : :
3151 : 961510 : mio_rparen ();
3152 : 961510 : }
3153 : :
3154 : :
3155 : : static void
3156 : 5847 : mio_actual_arg (gfc_actual_arglist *a, bool pdt)
3157 : : {
3158 : 5847 : mio_lparen ();
3159 : 5847 : mio_pool_string (&a->name);
3160 : 5847 : mio_expr (&a->expr);
3161 : 5847 : if (pdt)
3162 : 432 : mio_integer ((int *)&a->spec_type);
3163 : 5847 : mio_rparen ();
3164 : 5847 : }
3165 : :
3166 : :
3167 : : static void
3168 : 1471129 : mio_actual_arglist (gfc_actual_arglist **ap, bool pdt)
3169 : : {
3170 : 1471129 : gfc_actual_arglist *a, *tail;
3171 : :
3172 : 1471129 : mio_lparen ();
3173 : :
3174 : 1471129 : if (iomode == IO_OUTPUT)
3175 : : {
3176 : 376765 : for (a = *ap; a; a = a->next)
3177 : 2957 : mio_actual_arg (a, pdt);
3178 : :
3179 : : }
3180 : : else
3181 : : {
3182 : : tail = NULL;
3183 : :
3184 : 1103101 : for (;;)
3185 : : {
3186 : 1100211 : if (peek_atom () != ATOM_LPAREN)
3187 : : break;
3188 : :
3189 : 2890 : a = gfc_get_actual_arglist ();
3190 : :
3191 : 2890 : if (tail == NULL)
3192 : 1237 : *ap = a;
3193 : : else
3194 : 1653 : tail->next = a;
3195 : :
3196 : 2890 : tail = a;
3197 : 2890 : mio_actual_arg (a, pdt);
3198 : : }
3199 : : }
3200 : :
3201 : 1471129 : mio_rparen ();
3202 : 1471129 : }
3203 : :
3204 : :
3205 : : /* Read and write formal argument lists. */
3206 : :
3207 : : static void
3208 : 961510 : mio_formal_arglist (gfc_formal_arglist **formal)
3209 : : {
3210 : 961510 : gfc_formal_arglist *f, *tail;
3211 : :
3212 : 961510 : mio_lparen ();
3213 : :
3214 : 961510 : if (iomode == IO_OUTPUT)
3215 : : {
3216 : 266521 : for (f = *formal; f; f = f->next)
3217 : 66979 : mio_symbol_ref (&f->sym);
3218 : : }
3219 : : else
3220 : : {
3221 : 761968 : *formal = tail = NULL;
3222 : :
3223 : 1093884 : while (peek_atom () != ATOM_RPAREN)
3224 : : {
3225 : 331916 : f = gfc_get_formal_arglist ();
3226 : 331916 : mio_symbol_ref (&f->sym);
3227 : :
3228 : 331916 : if (*formal == NULL)
3229 : 177598 : *formal = f;
3230 : : else
3231 : 154318 : tail->next = f;
3232 : :
3233 : : tail = f;
3234 : : }
3235 : : }
3236 : :
3237 : 961510 : mio_rparen ();
3238 : 961510 : }
3239 : :
3240 : :
3241 : : /* Save or restore a reference to a symbol node. */
3242 : :
3243 : : pointer_info *
3244 : 4212842 : mio_symbol_ref (gfc_symbol **symp)
3245 : : {
3246 : 4212842 : pointer_info *p;
3247 : :
3248 : 4212842 : p = mio_pointer_ref (symp);
3249 : 4212842 : if (p->type == P_UNKNOWN)
3250 : 113441 : p->type = P_SYMBOL;
3251 : :
3252 : 4212842 : if (iomode == IO_OUTPUT)
3253 : : {
3254 : 951179 : if (p->u.wsym.state == UNREFERENCED)
3255 : 127867 : p->u.wsym.state = NEEDS_WRITE;
3256 : : }
3257 : : else
3258 : : {
3259 : 3261663 : if (p->u.rsym.state == UNUSED)
3260 : 503652 : p->u.rsym.state = NEEDED;
3261 : : }
3262 : 4212842 : return p;
3263 : : }
3264 : :
3265 : :
3266 : : /* Save or restore a reference to a symtree node. */
3267 : :
3268 : : static void
3269 : 22882 : mio_symtree_ref (gfc_symtree **stp)
3270 : : {
3271 : 22882 : pointer_info *p;
3272 : 22882 : fixup_t *f;
3273 : :
3274 : 22882 : if (iomode == IO_OUTPUT)
3275 : 11907 : mio_symbol_ref (&(*stp)->n.sym);
3276 : : else
3277 : : {
3278 : 10975 : require_atom (ATOM_INTEGER);
3279 : 10975 : p = get_integer (atom_int);
3280 : :
3281 : : /* An unused equivalence member; make a symbol and a symtree
3282 : : for it. */
3283 : 10975 : if (in_load_equiv && p->u.rsym.symtree == NULL)
3284 : : {
3285 : : /* Since this is not used, it must have a unique name. */
3286 : 87 : p->u.rsym.symtree = gfc_get_unique_symtree (gfc_current_ns);
3287 : :
3288 : : /* Make the symbol. */
3289 : 87 : if (p->u.rsym.sym == NULL)
3290 : : {
3291 : 75 : p->u.rsym.sym = gfc_new_symbol (p->u.rsym.true_name,
3292 : : gfc_current_ns);
3293 : 75 : p->u.rsym.sym->module = gfc_get_string ("%s", p->u.rsym.module);
3294 : : }
3295 : :
3296 : 87 : p->u.rsym.symtree->n.sym = p->u.rsym.sym;
3297 : 87 : p->u.rsym.symtree->n.sym->refs++;
3298 : 87 : p->u.rsym.referenced = 1;
3299 : :
3300 : : /* If the symbol is PRIVATE and in COMMON, load_commons will
3301 : : generate a fixup symbol, which must be associated. */
3302 : 87 : if (p->fixup)
3303 : 2 : resolve_fixups (p->fixup, p->u.rsym.sym);
3304 : 87 : p->fixup = NULL;
3305 : : }
3306 : :
3307 : 10975 : if (p->type == P_UNKNOWN)
3308 : 0 : p->type = P_SYMBOL;
3309 : :
3310 : 10975 : if (p->u.rsym.state == UNUSED)
3311 : 2124 : p->u.rsym.state = NEEDED;
3312 : :
3313 : 10975 : if (p->u.rsym.symtree != NULL)
3314 : : {
3315 : 3000 : *stp = p->u.rsym.symtree;
3316 : : }
3317 : : else
3318 : : {
3319 : 7975 : f = XCNEW (fixup_t);
3320 : :
3321 : 7975 : f->next = p->u.rsym.stfixup;
3322 : 7975 : p->u.rsym.stfixup = f;
3323 : :
3324 : 7975 : f->pointer = (void **) stp;
3325 : : }
3326 : : }
3327 : 22882 : }
3328 : :
3329 : :
3330 : : static void
3331 : 30108 : mio_iterator (gfc_iterator **ip)
3332 : : {
3333 : 30108 : gfc_iterator *iter;
3334 : :
3335 : 30108 : mio_lparen ();
3336 : :
3337 : 30108 : if (iomode == IO_OUTPUT)
3338 : : {
3339 : 8456 : if (*ip == NULL)
3340 : 8450 : goto done;
3341 : : }
3342 : : else
3343 : : {
3344 : 21652 : if (peek_atom () == ATOM_RPAREN)
3345 : : {
3346 : 21646 : *ip = NULL;
3347 : 21646 : goto done;
3348 : : }
3349 : :
3350 : 6 : *ip = gfc_get_iterator ();
3351 : : }
3352 : :
3353 : 12 : iter = *ip;
3354 : :
3355 : 12 : mio_expr (&iter->var);
3356 : 12 : mio_expr (&iter->start);
3357 : 12 : mio_expr (&iter->end);
3358 : 12 : mio_expr (&iter->step);
3359 : :
3360 : 30108 : done:
3361 : 30108 : mio_rparen ();
3362 : 30108 : }
3363 : :
3364 : :
3365 : : static void
3366 : 18037 : mio_constructor (gfc_constructor_base *cp)
3367 : : {
3368 : 18037 : gfc_constructor *c;
3369 : :
3370 : 18037 : mio_lparen ();
3371 : :
3372 : 18037 : if (iomode == IO_OUTPUT)
3373 : : {
3374 : 11863 : for (c = gfc_constructor_first (*cp); c; c = gfc_constructor_next (c))
3375 : : {
3376 : 8456 : mio_lparen ();
3377 : 8456 : mio_expr (&c->expr);
3378 : 8456 : mio_iterator (&c->iterator);
3379 : 8456 : mio_rparen ();
3380 : : }
3381 : : }
3382 : : else
3383 : : {
3384 : 36282 : while (peek_atom () != ATOM_RPAREN)
3385 : : {
3386 : 21652 : c = gfc_constructor_append_expr (cp, NULL, NULL);
3387 : :
3388 : 21652 : mio_lparen ();
3389 : 21652 : mio_expr (&c->expr);
3390 : 21652 : mio_iterator (&c->iterator);
3391 : 21652 : mio_rparen ();
3392 : : }
3393 : : }
3394 : :
3395 : 18037 : mio_rparen ();
3396 : 18037 : }
3397 : :
3398 : :
3399 : : static const mstring ref_types[] = {
3400 : : minit ("ARRAY", REF_ARRAY),
3401 : : minit ("COMPONENT", REF_COMPONENT),
3402 : : minit ("SUBSTRING", REF_SUBSTRING),
3403 : : minit ("INQUIRY", REF_INQUIRY),
3404 : : minit (NULL, -1)
3405 : : };
3406 : :
3407 : : static const mstring inquiry_types[] = {
3408 : : minit ("RE", INQUIRY_RE),
3409 : : minit ("IM", INQUIRY_IM),
3410 : : minit ("KIND", INQUIRY_KIND),
3411 : : minit ("LEN", INQUIRY_LEN),
3412 : : minit (NULL, -1)
3413 : : };
3414 : :
3415 : :
3416 : : static void
3417 : 2063 : mio_ref (gfc_ref **rp)
3418 : : {
3419 : 2063 : gfc_ref *r;
3420 : :
3421 : 2063 : mio_lparen ();
3422 : :
3423 : 2063 : r = *rp;
3424 : 2063 : r->type = MIO_NAME (ref_type) (r->type, ref_types);
3425 : :
3426 : 2063 : switch (r->type)
3427 : : {
3428 : 1693 : case REF_ARRAY:
3429 : 1693 : mio_array_ref (&r->u.ar);
3430 : 1693 : break;
3431 : :
3432 : 364 : case REF_COMPONENT:
3433 : 364 : mio_symbol_ref (&r->u.c.sym);
3434 : 364 : mio_component_ref (&r->u.c.component);
3435 : 364 : break;
3436 : :
3437 : 6 : case REF_SUBSTRING:
3438 : 6 : mio_expr (&r->u.ss.start);
3439 : 6 : mio_expr (&r->u.ss.end);
3440 : 6 : mio_charlen (&r->u.ss.length);
3441 : 6 : break;
3442 : :
3443 : 0 : case REF_INQUIRY:
3444 : 0 : r->u.i = MIO_NAME (inquiry_type) (r->u.i, inquiry_types);
3445 : 0 : break;
3446 : : }
3447 : :
3448 : 2063 : mio_rparen ();
3449 : 2063 : }
3450 : :
3451 : :
3452 : : static void
3453 : 11724 : mio_ref_list (gfc_ref **rp)
3454 : : {
3455 : 11724 : gfc_ref *ref, *head, *tail;
3456 : :
3457 : 11724 : mio_lparen ();
3458 : :
3459 : 11724 : if (iomode == IO_OUTPUT)
3460 : : {
3461 : 7196 : for (ref = *rp; ref; ref = ref->next)
3462 : 1075 : mio_ref (&ref);
3463 : : }
3464 : : else
3465 : : {
3466 : 5603 : head = tail = NULL;
3467 : :
3468 : 6591 : while (peek_atom () != ATOM_RPAREN)
3469 : : {
3470 : 988 : if (head == NULL)
3471 : 923 : head = tail = gfc_get_ref ();
3472 : : else
3473 : : {
3474 : 65 : tail->next = gfc_get_ref ();
3475 : 65 : tail = tail->next;
3476 : : }
3477 : :
3478 : 988 : mio_ref (&tail);
3479 : : }
3480 : :
3481 : 5603 : *rp = head;
3482 : : }
3483 : :
3484 : 11724 : mio_rparen ();
3485 : 11724 : }
3486 : :
3487 : :
3488 : : /* Read and write an integer value. */
3489 : :
3490 : : static void
3491 : 226804 : mio_gmp_integer (mpz_t *integer)
3492 : : {
3493 : 226804 : char *p;
3494 : :
3495 : 226804 : if (iomode == IO_INPUT)
3496 : : {
3497 : 165986 : if (parse_atom () != ATOM_STRING)
3498 : 0 : bad_module ("Expected integer string");
3499 : :
3500 : 165986 : mpz_init (*integer);
3501 : 165986 : if (mpz_set_str (*integer, atom_string, 10))
3502 : 0 : bad_module ("Error converting integer");
3503 : :
3504 : 165986 : free (atom_string);
3505 : : }
3506 : : else
3507 : : {
3508 : 60818 : p = mpz_get_str (NULL, 10, *integer);
3509 : 60818 : write_atom (ATOM_STRING, p);
3510 : 60818 : free (p);
3511 : : }
3512 : 226804 : }
3513 : :
3514 : :
3515 : : static void
3516 : 1458 : mio_gmp_real (mpfr_t *real)
3517 : : {
3518 : 1458 : mpfr_exp_t exponent;
3519 : 1458 : char *p;
3520 : :
3521 : 1458 : if (iomode == IO_INPUT)
3522 : : {
3523 : 690 : if (parse_atom () != ATOM_STRING)
3524 : 0 : bad_module ("Expected real string");
3525 : :
3526 : 690 : mpfr_init (*real);
3527 : 690 : mpfr_set_str (*real, atom_string, 16, GFC_RND_MODE);
3528 : 690 : free (atom_string);
3529 : : }
3530 : : else
3531 : : {
3532 : 768 : p = mpfr_get_str (NULL, &exponent, 16, 0, *real, GFC_RND_MODE);
3533 : :
3534 : 768 : if (mpfr_nan_p (*real) || mpfr_inf_p (*real))
3535 : : {
3536 : 18 : write_atom (ATOM_STRING, p);
3537 : 18 : free (p);
3538 : 18 : return;
3539 : : }
3540 : :
3541 : 750 : atom_string = XCNEWVEC (char, strlen (p) + 20);
3542 : :
3543 : 750 : sprintf (atom_string, "0.%s@%ld", p, exponent);
3544 : :
3545 : : /* Fix negative numbers. */
3546 : 750 : if (atom_string[2] == '-')
3547 : : {
3548 : 15 : atom_string[0] = '-';
3549 : 15 : atom_string[1] = '0';
3550 : 15 : atom_string[2] = '.';
3551 : : }
3552 : :
3553 : 750 : write_atom (ATOM_STRING, atom_string);
3554 : :
3555 : 750 : free (atom_string);
3556 : 750 : free (p);
3557 : : }
3558 : : }
3559 : :
3560 : :
3561 : : /* Save and restore the shape of an array constructor. */
3562 : :
3563 : : static void
3564 : 18037 : mio_shape (mpz_t **pshape, int rank)
3565 : : {
3566 : 18037 : mpz_t *shape;
3567 : 18037 : atom_type t;
3568 : 18037 : int n;
3569 : :
3570 : : /* A NULL shape is represented by (). */
3571 : 18037 : mio_lparen ();
3572 : :
3573 : 18037 : if (iomode == IO_OUTPUT)
3574 : : {
3575 : 3407 : shape = *pshape;
3576 : 3407 : if (!shape)
3577 : : {
3578 : 2839 : mio_rparen ();
3579 : 2839 : return;
3580 : : }
3581 : : }
3582 : : else
3583 : : {
3584 : 14630 : t = peek_atom ();
3585 : 14630 : if (t == ATOM_RPAREN)
3586 : : {
3587 : 13391 : *pshape = NULL;
3588 : 13391 : mio_rparen ();
3589 : 13391 : return;
3590 : : }
3591 : :
3592 : 1239 : shape = gfc_get_shape (rank);
3593 : 1239 : *pshape = shape;
3594 : : }
3595 : :
3596 : 3741 : for (n = 0; n < rank; n++)
3597 : 1934 : mio_gmp_integer (&shape[n]);
3598 : :
3599 : 1807 : mio_rparen ();
3600 : : }
3601 : :
3602 : :
3603 : : static const mstring expr_types[] = {
3604 : : minit ("OP", EXPR_OP),
3605 : : minit ("FUNCTION", EXPR_FUNCTION),
3606 : : minit ("CONSTANT", EXPR_CONSTANT),
3607 : : minit ("VARIABLE", EXPR_VARIABLE),
3608 : : minit ("SUBSTRING", EXPR_SUBSTRING),
3609 : : minit ("STRUCTURE", EXPR_STRUCTURE),
3610 : : minit ("ARRAY", EXPR_ARRAY),
3611 : : minit ("NULL", EXPR_NULL),
3612 : : minit ("COMPCALL", EXPR_COMPCALL),
3613 : : minit (NULL, -1)
3614 : : };
3615 : :
3616 : : /* INTRINSIC_ASSIGN is missing because it is used as an index for
3617 : : generic operators, not in expressions. INTRINSIC_USER is also
3618 : : replaced by the correct function name by the time we see it. */
3619 : :
3620 : : static const mstring intrinsics[] =
3621 : : {
3622 : : minit ("UPLUS", INTRINSIC_UPLUS),
3623 : : minit ("UMINUS", INTRINSIC_UMINUS),
3624 : : minit ("PLUS", INTRINSIC_PLUS),
3625 : : minit ("MINUS", INTRINSIC_MINUS),
3626 : : minit ("TIMES", INTRINSIC_TIMES),
3627 : : minit ("DIVIDE", INTRINSIC_DIVIDE),
3628 : : minit ("POWER", INTRINSIC_POWER),
3629 : : minit ("CONCAT", INTRINSIC_CONCAT),
3630 : : minit ("AND", INTRINSIC_AND),
3631 : : minit ("OR", INTRINSIC_OR),
3632 : : minit ("EQV", INTRINSIC_EQV),
3633 : : minit ("NEQV", INTRINSIC_NEQV),
3634 : : minit ("EQ_SIGN", INTRINSIC_EQ),
3635 : : minit ("EQ", INTRINSIC_EQ_OS),
3636 : : minit ("NE_SIGN", INTRINSIC_NE),
3637 : : minit ("NE", INTRINSIC_NE_OS),
3638 : : minit ("GT_SIGN", INTRINSIC_GT),
3639 : : minit ("GT", INTRINSIC_GT_OS),
3640 : : minit ("GE_SIGN", INTRINSIC_GE),
3641 : : minit ("GE", INTRINSIC_GE_OS),
3642 : : minit ("LT_SIGN", INTRINSIC_LT),
3643 : : minit ("LT", INTRINSIC_LT_OS),
3644 : : minit ("LE_SIGN", INTRINSIC_LE),
3645 : : minit ("LE", INTRINSIC_LE_OS),
3646 : : minit ("NOT", INTRINSIC_NOT),
3647 : : minit ("PARENTHESES", INTRINSIC_PARENTHESES),
3648 : : minit ("USER", INTRINSIC_USER),
3649 : : minit (NULL, -1)
3650 : : };
3651 : :
3652 : :
3653 : : /* Remedy a couple of situations where the gfc_expr's can be defective. */
3654 : :
3655 : : static void
3656 : 287619 : fix_mio_expr (gfc_expr *e)
3657 : : {
3658 : 287619 : gfc_symtree *ns_st = NULL;
3659 : 287619 : const char *fname;
3660 : :
3661 : 287619 : if (iomode != IO_OUTPUT)
3662 : : return;
3663 : :
3664 : 85652 : if (e->symtree)
3665 : : {
3666 : : /* If this is a symtree for a symbol that came from a contained module
3667 : : namespace, it has a unique name and we should look in the current
3668 : : namespace to see if the required, non-contained symbol is available
3669 : : yet. If so, the latter should be written. */
3670 : 8333 : if (e->symtree->n.sym && check_unique_name (e->symtree->name))
3671 : : {
3672 : 514 : const char *name = e->symtree->n.sym->name;
3673 : 514 : if (gfc_fl_struct (e->symtree->n.sym->attr.flavor))
3674 : 0 : name = gfc_dt_upper_string (name);
3675 : 514 : ns_st = gfc_find_symtree (gfc_current_ns->sym_root, name);
3676 : : }
3677 : :
3678 : : /* On the other hand, if the existing symbol is the module name or the
3679 : : new symbol is a dummy argument, do not do the promotion. */
3680 : 514 : if (ns_st && ns_st->n.sym
3681 : 21 : && ns_st->n.sym->attr.flavor != FL_MODULE
3682 : 20 : && !e->symtree->n.sym->attr.dummy)
3683 : 19 : e->symtree = ns_st;
3684 : : }
3685 : 77319 : else if (e->expr_type == EXPR_FUNCTION
3686 : 2 : && (e->value.function.name || e->value.function.isym))
3687 : : {
3688 : 2 : gfc_symbol *sym;
3689 : :
3690 : : /* In some circumstances, a function used in an initialization
3691 : : expression, in one use associated module, can fail to be
3692 : : coupled to its symtree when used in a specification
3693 : : expression in another module. */
3694 : 2 : fname = e->value.function.esym ? e->value.function.esym->name
3695 : 2 : : e->value.function.isym->name;
3696 : 2 : e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
3697 : :
3698 : 2 : if (e->symtree)
3699 : 1 : return;
3700 : :
3701 : : /* This is probably a reference to a private procedure from another
3702 : : module. To prevent a segfault, make a generic with no specific
3703 : : instances. If this module is used, without the required
3704 : : specific coming from somewhere, the appropriate error message
3705 : : is issued. */
3706 : 1 : gfc_get_symbol (fname, gfc_current_ns, &sym);
3707 : 1 : sym->attr.flavor = FL_PROCEDURE;
3708 : 1 : sym->attr.generic = 1;
3709 : 1 : e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
3710 : 1 : gfc_commit_symbol (sym);
3711 : : }
3712 : : }
3713 : :
3714 : :
3715 : : /* Read and write expressions. The form "()" is allowed to indicate a
3716 : : NULL expression. */
3717 : :
3718 : : static void
3719 : 625694 : mio_expr (gfc_expr **ep)
3720 : : {
3721 : 625694 : HOST_WIDE_INT hwi;
3722 : 625694 : gfc_expr *e;
3723 : 625694 : atom_type t;
3724 : 625694 : int flag;
3725 : :
3726 : 625694 : mio_lparen ();
3727 : :
3728 : 625694 : if (iomode == IO_OUTPUT)
3729 : : {
3730 : 212523 : if (*ep == NULL)
3731 : : {
3732 : 126871 : mio_rparen ();
3733 : 464946 : return;
3734 : : }
3735 : :
3736 : 85652 : e = *ep;
3737 : 85652 : MIO_NAME (expr_t) (e->expr_type, expr_types);
3738 : : }
3739 : : else
3740 : : {
3741 : 413171 : t = parse_atom ();
3742 : 413171 : if (t == ATOM_RPAREN)
3743 : : {
3744 : 211204 : *ep = NULL;
3745 : 211204 : return;
3746 : : }
3747 : :
3748 : 201967 : if (t != ATOM_NAME)
3749 : 0 : bad_module ("Expected expression type");
3750 : :
3751 : 201967 : e = *ep = gfc_get_expr ();
3752 : 201967 : e->where = gfc_current_locus;
3753 : 201967 : e->expr_type = (expr_t) find_enum (expr_types);
3754 : : }
3755 : :
3756 : 287619 : mio_typespec (&e->ts);
3757 : 287619 : mio_integer (&e->rank);
3758 : :
3759 : 287619 : fix_mio_expr (e);
3760 : :
3761 : 287619 : switch (e->expr_type)
3762 : : {
3763 : 1444 : case EXPR_OP:
3764 : 1444 : e->value.op.op
3765 : 1444 : = MIO_NAME (gfc_intrinsic_op) (e->value.op.op, intrinsics);
3766 : :
3767 : 1444 : switch (e->value.op.op)
3768 : : {
3769 : 445 : case INTRINSIC_UPLUS:
3770 : 445 : case INTRINSIC_UMINUS:
3771 : 445 : case INTRINSIC_NOT:
3772 : 445 : case INTRINSIC_PARENTHESES:
3773 : 445 : mio_expr (&e->value.op.op1);
3774 : 445 : break;
3775 : :
3776 : 929 : case INTRINSIC_PLUS:
3777 : 929 : case INTRINSIC_MINUS:
3778 : 929 : case INTRINSIC_TIMES:
3779 : 929 : case INTRINSIC_DIVIDE:
3780 : 929 : case INTRINSIC_POWER:
3781 : 929 : case INTRINSIC_CONCAT:
3782 : 929 : case INTRINSIC_AND:
3783 : 929 : case INTRINSIC_OR:
3784 : 929 : case INTRINSIC_EQV:
3785 : 929 : case INTRINSIC_NEQV:
3786 : 929 : case INTRINSIC_EQ:
3787 : 929 : case INTRINSIC_EQ_OS:
3788 : 929 : case INTRINSIC_NE:
3789 : 929 : case INTRINSIC_NE_OS:
3790 : 929 : case INTRINSIC_GT:
3791 : 929 : case INTRINSIC_GT_OS:
3792 : 929 : case INTRINSIC_GE:
3793 : 929 : case INTRINSIC_GE_OS:
3794 : 929 : case INTRINSIC_LT:
3795 : 929 : case INTRINSIC_LT_OS:
3796 : 929 : case INTRINSIC_LE:
3797 : 929 : case INTRINSIC_LE_OS:
3798 : 929 : mio_expr (&e->value.op.op1);
3799 : 929 : mio_expr (&e->value.op.op2);
3800 : 929 : break;
3801 : :
3802 : 70 : case INTRINSIC_USER:
3803 : : /* INTRINSIC_USER should not appear in resolved expressions,
3804 : : though for UDRs we need to stream unresolved ones. */
3805 : 70 : if (iomode == IO_OUTPUT)
3806 : 34 : write_atom (ATOM_STRING, e->value.op.uop->name);
3807 : : else
3808 : : {
3809 : 36 : char *name = read_string ();
3810 : 36 : const char *uop_name = find_use_name (name, true);
3811 : 36 : if (uop_name == NULL)
3812 : : {
3813 : 0 : size_t len = strlen (name);
3814 : 0 : char *name2 = XCNEWVEC (char, len + 2);
3815 : 0 : memcpy (name2, name, len);
3816 : 0 : name2[len] = ' ';
3817 : 0 : name2[len + 1] = '\0';
3818 : 0 : free (name);
3819 : 0 : uop_name = name = name2;
3820 : : }
3821 : 36 : e->value.op.uop = gfc_get_uop (uop_name);
3822 : 36 : free (name);
3823 : : }
3824 : 70 : mio_expr (&e->value.op.op1);
3825 : 70 : mio_expr (&e->value.op.op2);
3826 : 70 : break;
3827 : :
3828 : 0 : default:
3829 : 0 : bad_module ("Bad operator");
3830 : : }
3831 : :
3832 : : break;
3833 : :
3834 : 2158 : case EXPR_FUNCTION:
3835 : 2158 : mio_symtree_ref (&e->symtree);
3836 : 2158 : mio_actual_arglist (&e->value.function.actual, false);
3837 : :
3838 : 2158 : if (iomode == IO_OUTPUT)
3839 : : {
3840 : 1090 : e->value.function.name
3841 : 1090 : = mio_allocated_string (e->value.function.name);
3842 : 1090 : if (e->value.function.esym)
3843 : 126 : flag = 1;
3844 : 964 : else if (e->ref)
3845 : 11 : flag = 2;
3846 : 953 : else if (e->value.function.isym == NULL)
3847 : 44 : flag = 3;
3848 : : else
3849 : 909 : flag = 0;
3850 : 1090 : mio_integer (&flag);
3851 : 1090 : switch (flag)
3852 : : {
3853 : 126 : case 1:
3854 : 126 : mio_symbol_ref (&e->value.function.esym);
3855 : 126 : break;
3856 : 11 : case 2:
3857 : 11 : mio_ref_list (&e->ref);
3858 : 11 : break;
3859 : : case 3:
3860 : : break;
3861 : 909 : default:
3862 : 909 : write_atom (ATOM_STRING, e->value.function.isym->name);
3863 : : }
3864 : : }
3865 : : else
3866 : : {
3867 : 1068 : require_atom (ATOM_STRING);
3868 : 1068 : if (atom_string[0] == '\0')
3869 : 560 : e->value.function.name = NULL;
3870 : : else
3871 : 508 : e->value.function.name = gfc_get_string ("%s", atom_string);
3872 : 1068 : free (atom_string);
3873 : :
3874 : 1068 : mio_integer (&flag);
3875 : 1068 : switch (flag)
3876 : : {
3877 : 131 : case 1:
3878 : 131 : mio_symbol_ref (&e->value.function.esym);
3879 : 131 : break;
3880 : 0 : case 2:
3881 : 0 : mio_ref_list (&e->ref);
3882 : 0 : break;
3883 : : case 3:
3884 : : break;
3885 : 889 : default:
3886 : 889 : require_atom (ATOM_STRING);
3887 : 889 : e->value.function.isym = gfc_find_function (atom_string);
3888 : 889 : free (atom_string);
3889 : : }
3890 : : }
3891 : :
3892 : : break;
3893 : :
3894 : 11713 : case EXPR_VARIABLE:
3895 : 11713 : mio_symtree_ref (&e->symtree);
3896 : 11713 : mio_ref_list (&e->ref);
3897 : 11713 : break;
3898 : :
3899 : 0 : case EXPR_SUBSTRING:
3900 : 0 : e->value.character.string
3901 : 0 : = CONST_CAST (gfc_char_t *,
3902 : : mio_allocated_wide_string (e->value.character.string,
3903 : : e->value.character.length));
3904 : 0 : mio_ref_list (&e->ref);
3905 : 0 : break;
3906 : :
3907 : 18037 : case EXPR_STRUCTURE:
3908 : 18037 : case EXPR_ARRAY:
3909 : 18037 : mio_constructor (&e->value.constructor);
3910 : 18037 : mio_shape (&e->shape, e->rank);
3911 : 18037 : break;
3912 : :
3913 : 233907 : case EXPR_CONSTANT:
3914 : 233907 : switch (e->ts.type)
3915 : : {
3916 : 224870 : case BT_INTEGER:
3917 : 224870 : mio_gmp_integer (&e->value.integer);
3918 : 224870 : break;
3919 : :
3920 : 1406 : case BT_REAL:
3921 : 1406 : gfc_set_model_kind (e->ts.kind);
3922 : 1406 : mio_gmp_real (&e->value.real);
3923 : 1406 : break;
3924 : :
3925 : 26 : case BT_COMPLEX:
3926 : 26 : gfc_set_model_kind (e->ts.kind);
3927 : 26 : mio_gmp_real (&mpc_realref (e->value.complex));
3928 : 26 : mio_gmp_real (&mpc_imagref (e->value.complex));
3929 : 26 : break;
3930 : :
3931 : 57 : case BT_LOGICAL:
3932 : 57 : mio_integer (&e->value.logical);
3933 : 57 : break;
3934 : :
3935 : 7548 : case BT_CHARACTER:
3936 : 7548 : hwi = e->value.character.length;
3937 : 7548 : mio_hwi (&hwi);
3938 : 7548 : e->value.character.length = hwi;
3939 : 7548 : e->value.character.string
3940 : 7548 : = CONST_CAST (gfc_char_t *,
3941 : : mio_allocated_wide_string (e->value.character.string,
3942 : : e->value.character.length));
3943 : 7548 : break;
3944 : :
3945 : 0 : default:
3946 : 0 : bad_module ("Bad type in constant expression");
3947 : : }
3948 : :
3949 : : break;
3950 : :
3951 : : case EXPR_NULL:
3952 : : break;
3953 : :
3954 : 0 : case EXPR_COMPCALL:
3955 : 0 : case EXPR_PPC:
3956 : 0 : case EXPR_UNKNOWN:
3957 : 0 : gcc_unreachable ();
3958 : 287619 : break;
3959 : : }
3960 : :
3961 : : /* PDT types store the expression specification list here. */
3962 : 287619 : mio_actual_arglist (&e->param_list, true);
3963 : :
3964 : 287619 : mio_rparen ();
3965 : : }
3966 : :
3967 : :
3968 : : /* Read and write namelists. */
3969 : :
3970 : : static void
3971 : 961510 : mio_namelist (gfc_symbol *sym)
3972 : : {
3973 : 961510 : gfc_namelist *n, *m;
3974 : :
3975 : 961510 : mio_lparen ();
3976 : :
3977 : 961510 : if (iomode == IO_OUTPUT)
3978 : : {
3979 : 199624 : for (n = sym->namelist; n; n = n->next)
3980 : 82 : mio_symbol_ref (&n->sym);
3981 : : }
3982 : : else
3983 : : {
3984 : : m = NULL;
3985 : 762055 : while (peek_atom () != ATOM_RPAREN)
3986 : : {
3987 : 87 : n = gfc_get_namelist ();
3988 : 87 : mio_symbol_ref (&n->sym);
3989 : :
3990 : 87 : if (sym->namelist == NULL)
3991 : 51 : sym->namelist = n;
3992 : : else
3993 : 36 : m->next = n;
3994 : :
3995 : : m = n;
3996 : : }
3997 : 761968 : sym->namelist_tail = m;
3998 : : }
3999 : :
4000 : 961510 : mio_rparen ();
4001 : 961510 : }
4002 : :
4003 : :
4004 : : /* Save/restore lists of gfc_interface structures. When loading an
4005 : : interface, we are really appending to the existing list of
4006 : : interfaces. Checking for duplicate and ambiguous interfaces has to
4007 : : be done later when all symbols have been loaded. */
4008 : :
4009 : : pointer_info *
4010 : 569474 : mio_interface_rest (gfc_interface **ip)
4011 : : {
4012 : 569474 : gfc_interface *tail, *p;
4013 : 569474 : pointer_info *pi = NULL;
4014 : :
4015 : 569474 : if (iomode == IO_OUTPUT)
4016 : : {
4017 : 245359 : if (ip != NULL)
4018 : 239151 : for (p = *ip; p; p = p->next)
4019 : 14496 : mio_symbol_ref (&p->sym);
4020 : : }
4021 : : else
4022 : : {
4023 : 324115 : if (*ip == NULL)
4024 : : tail = NULL;
4025 : : else
4026 : : {
4027 : : tail = *ip;
4028 : 5087 : while (tail->next)
4029 : : tail = tail->next;
4030 : : }
4031 : :
4032 : 465027 : for (;;)
4033 : : {
4034 : 465027 : if (peek_atom () == ATOM_RPAREN)
4035 : : break;
4036 : :
4037 : 140912 : p = gfc_get_interface ();
4038 : 140912 : p->where = gfc_current_locus;
4039 : 140912 : pi = mio_symbol_ref (&p->sym);
4040 : :
4041 : 140912 : if (tail == NULL)
4042 : 45912 : *ip = p;
4043 : : else
4044 : 95000 : tail->next = p;
4045 : :
4046 : : tail = p;
4047 : : }
4048 : : }
4049 : :
4050 : 569474 : mio_rparen ();
4051 : 569474 : return pi;
4052 : : }
4053 : :
4054 : :
4055 : : /* Save/restore a nameless operator interface. */
4056 : :
4057 : : static void
4058 : 513360 : mio_interface (gfc_interface **ip)
4059 : : {
4060 : 236034 : mio_lparen ();
4061 : 277326 : mio_interface_rest (ip);
4062 : 236034 : }
4063 : :
4064 : :
4065 : : /* Save/restore a named operator interface. */
4066 : :
4067 : : static void
4068 : 9325 : mio_symbol_interface (const char **name, const char **module,
4069 : : gfc_interface **ip)
4070 : : {
4071 : 9325 : mio_lparen ();
4072 : 9325 : mio_pool_string (name);
4073 : 9325 : mio_pool_string (module);
4074 : 9325 : mio_interface_rest (ip);
4075 : 9325 : }
4076 : :
4077 : :
4078 : : static void
4079 : 961510 : mio_namespace_ref (gfc_namespace **nsp)
4080 : : {
4081 : 961510 : gfc_namespace *ns;
4082 : 961510 : pointer_info *p;
4083 : :
4084 : 961510 : p = mio_pointer_ref (nsp);
4085 : :
4086 : 961510 : if (p->type == P_UNKNOWN)
4087 : 208860 : p->type = P_NAMESPACE;
4088 : :
4089 : 961510 : if (iomode == IO_INPUT && p->integer != 0)
4090 : : {
4091 : 184995 : ns = (gfc_namespace *) p->u.pointer;
4092 : 184995 : if (ns == NULL)
4093 : : {
4094 : 184759 : ns = gfc_get_namespace (NULL, 0);
4095 : 184759 : associate_integer_pointer (p, ns);
4096 : : }
4097 : : else
4098 : 236 : ns->refs++;
4099 : : }
4100 : 961510 : }
4101 : :
4102 : :
4103 : : /* Save/restore the f2k_derived namespace of a derived-type symbol. */
4104 : :
4105 : : static gfc_namespace* current_f2k_derived;
4106 : :
4107 : : static void
4108 : 84079 : mio_typebound_proc (gfc_typebound_proc** proc)
4109 : : {
4110 : 84079 : int flag;
4111 : 84079 : int overriding_flag;
4112 : :
4113 : 84079 : if (iomode == IO_INPUT)
4114 : : {
4115 : 47339 : *proc = gfc_get_typebound_proc (NULL);
4116 : 47339 : (*proc)->where = gfc_current_locus;
4117 : : }
4118 : 84079 : gcc_assert (*proc);
4119 : :
4120 : 84079 : mio_lparen ();
4121 : :
4122 : 84079 : (*proc)->access = MIO_NAME (gfc_access) ((*proc)->access, access_types);
4123 : :
4124 : : /* IO the NON_OVERRIDABLE/DEFERRED combination. */
4125 : 84079 : gcc_assert (!((*proc)->deferred && (*proc)->non_overridable));
4126 : 84079 : overriding_flag = ((*proc)->deferred << 1) | (*proc)->non_overridable;
4127 : 84079 : overriding_flag = mio_name (overriding_flag, binding_overriding);
4128 : 84079 : (*proc)->deferred = ((overriding_flag & 2) != 0);
4129 : 84079 : (*proc)->non_overridable = ((overriding_flag & 1) != 0);
4130 : 84079 : gcc_assert (!((*proc)->deferred && (*proc)->non_overridable));
4131 : :
4132 : 84079 : (*proc)->nopass = mio_name ((*proc)->nopass, binding_passing);
4133 : 84079 : (*proc)->is_generic = mio_name ((*proc)->is_generic, binding_generic);
4134 : 84079 : (*proc)->ppc = mio_name((*proc)->ppc, binding_ppc);
4135 : :
4136 : 84079 : mio_pool_string (&((*proc)->pass_arg));
4137 : :
4138 : 84079 : flag = (int) (*proc)->pass_arg_num;
4139 : 84079 : mio_integer (&flag);
4140 : 84079 : (*proc)->pass_arg_num = (unsigned) flag;
4141 : :
4142 : 84079 : if ((*proc)->is_generic)
4143 : : {
4144 : 2463 : gfc_tbp_generic* g;
4145 : 2463 : int iop;
4146 : :
4147 : 2463 : mio_lparen ();
4148 : :
4149 : 2463 : if (iomode == IO_OUTPUT)
4150 : 2697 : for (g = (*proc)->u.generic; g; g = g->next)
4151 : : {
4152 : 1418 : iop = (int) g->is_operator;
4153 : 1418 : mio_integer (&iop);
4154 : 1418 : mio_allocated_string (g->specific_st->name);
4155 : : }
4156 : : else
4157 : : {
4158 : 1184 : (*proc)->u.generic = NULL;
4159 : 2495 : while (peek_atom () != ATOM_RPAREN)
4160 : : {
4161 : 1311 : gfc_symtree** sym_root;
4162 : :
4163 : 1311 : g = gfc_get_tbp_generic ();
4164 : 1311 : g->specific = NULL;
4165 : :
4166 : 1311 : mio_integer (&iop);
4167 : 1311 : g->is_operator = (bool) iop;
4168 : :
4169 : 1311 : require_atom (ATOM_STRING);
4170 : 1311 : sym_root = ¤t_f2k_derived->tb_sym_root;
4171 : 1311 : g->specific_st = gfc_get_tbp_symtree (sym_root, atom_string);
4172 : 1311 : free (atom_string);
4173 : :
4174 : 1311 : g->next = (*proc)->u.generic;
4175 : 1311 : (*proc)->u.generic = g;
4176 : : }
4177 : : }
4178 : :
4179 : 2463 : mio_rparen ();
4180 : : }
4181 : 81616 : else if (!(*proc)->ppc)
4182 : 8053 : mio_symtree_ref (&(*proc)->u.specific);
4183 : :
4184 : 84079 : mio_rparen ();
4185 : 84079 : }
4186 : :
4187 : : /* Walker-callback function for this purpose. */
4188 : : static void
4189 : 9291 : mio_typebound_symtree (gfc_symtree* st)
4190 : : {
4191 : 9291 : if (iomode == IO_OUTPUT && !st->n.tb)
4192 : : return;
4193 : :
4194 : 9291 : if (iomode == IO_OUTPUT)
4195 : : {
4196 : 4851 : mio_lparen ();
4197 : 4851 : mio_allocated_string (st->name);
4198 : : }
4199 : : /* For IO_INPUT, the above is done in mio_f2k_derived. */
4200 : :
4201 : 9291 : mio_typebound_proc (&st->n.tb);
4202 : 9291 : mio_rparen ();
4203 : : }
4204 : :
4205 : : /* IO a full symtree (in all depth). */
4206 : : static void
4207 : 53592 : mio_full_typebound_tree (gfc_symtree** root)
4208 : : {
4209 : 53592 : mio_lparen ();
4210 : :
4211 : 53592 : if (iomode == IO_OUTPUT)
4212 : 22926 : gfc_traverse_symtree (*root, &mio_typebound_symtree);
4213 : : else
4214 : : {
4215 : 35106 : while (peek_atom () == ATOM_LPAREN)
4216 : : {
4217 : 4440 : gfc_symtree* st;
4218 : :
4219 : 4440 : mio_lparen ();
4220 : :
4221 : 4440 : require_atom (ATOM_STRING);
4222 : 4440 : st = gfc_get_tbp_symtree (root, atom_string);
4223 : 4440 : free (atom_string);
4224 : :
4225 : 4440 : mio_typebound_symtree (st);
4226 : : }
4227 : : }
4228 : :
4229 : 53592 : mio_rparen ();
4230 : 53592 : }
4231 : :
4232 : : static void
4233 : 850 : mio_finalizer (gfc_finalizer **f)
4234 : : {
4235 : 850 : if (iomode == IO_OUTPUT)
4236 : : {
4237 : 428 : gcc_assert (*f);
4238 : 428 : gcc_assert ((*f)->proc_tree); /* Should already be resolved. */
4239 : 428 : mio_symtree_ref (&(*f)->proc_tree);
4240 : : }
4241 : : else
4242 : : {
4243 : 422 : *f = gfc_get_finalizer ();
4244 : 422 : (*f)->where = gfc_current_locus; /* Value should not matter. */
4245 : 422 : (*f)->next = NULL;
4246 : :
4247 : 422 : mio_symtree_ref (&(*f)->proc_tree);
4248 : 422 : (*f)->proc_sym = NULL;
4249 : : }
4250 : 850 : }
4251 : :
4252 : : static void
4253 : 26796 : mio_f2k_derived (gfc_namespace *f2k)
4254 : : {
4255 : 26796 : current_f2k_derived = f2k;
4256 : :
4257 : : /* Handle the list of finalizer procedures. */
4258 : 26796 : mio_lparen ();
4259 : 26796 : if (iomode == IO_OUTPUT)
4260 : : {
4261 : 11463 : gfc_finalizer *f;
4262 : 11891 : for (f = f2k->finalizers; f; f = f->next)
4263 : 428 : mio_finalizer (&f);
4264 : : }
4265 : : else
4266 : : {
4267 : 15333 : f2k->finalizers = NULL;
4268 : 15755 : while (peek_atom () != ATOM_RPAREN)
4269 : : {
4270 : 422 : gfc_finalizer *cur = NULL;
4271 : 422 : mio_finalizer (&cur);
4272 : 422 : cur->next = f2k->finalizers;
4273 : 422 : f2k->finalizers = cur;
4274 : : }
4275 : : }
4276 : 26796 : mio_rparen ();
4277 : :
4278 : : /* Handle type-bound procedures. */
4279 : 26796 : mio_full_typebound_tree (&f2k->tb_sym_root);
4280 : :
4281 : : /* Type-bound user operators. */
4282 : 26796 : mio_full_typebound_tree (&f2k->tb_uop_root);
4283 : :
4284 : : /* Type-bound intrinsic operators. */
4285 : 26796 : mio_lparen ();
4286 : 26796 : if (iomode == IO_OUTPUT)
4287 : : {
4288 : : int op;
4289 : 332427 : for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; ++op)
4290 : : {
4291 : 320964 : gfc_intrinsic_op realop;
4292 : :
4293 : 320964 : if (op == INTRINSIC_USER || !f2k->tb_op[op])
4294 : 320311 : continue;
4295 : :
4296 : 653 : mio_lparen ();
4297 : 653 : realop = (gfc_intrinsic_op) op;
4298 : 653 : mio_intrinsic_op (&realop);
4299 : 653 : mio_typebound_proc (&f2k->tb_op[op]);
4300 : 653 : mio_rparen ();
4301 : : }
4302 : : }
4303 : : else
4304 : 15905 : while (peek_atom () != ATOM_RPAREN)
4305 : : {
4306 : 572 : gfc_intrinsic_op op = GFC_INTRINSIC_BEGIN; /* Silence GCC. */
4307 : :
4308 : 572 : mio_lparen ();
4309 : 572 : mio_intrinsic_op (&op);
4310 : 572 : mio_typebound_proc (&f2k->tb_op[op]);
4311 : 572 : mio_rparen ();
4312 : : }
4313 : 26796 : mio_rparen ();
4314 : 26796 : }
4315 : :
4316 : : static void
4317 : 961510 : mio_full_f2k_derived (gfc_symbol *sym)
4318 : : {
4319 : 961510 : mio_lparen ();
4320 : :
4321 : 961510 : if (iomode == IO_OUTPUT)
4322 : : {
4323 : 199542 : if (sym->f2k_derived)
4324 : 11463 : mio_f2k_derived (sym->f2k_derived);
4325 : : }
4326 : : else
4327 : : {
4328 : 761968 : if (peek_atom () != ATOM_RPAREN)
4329 : : {
4330 : 15333 : gfc_namespace *ns;
4331 : :
4332 : 15333 : sym->f2k_derived = gfc_get_namespace (NULL, 0);
4333 : :
4334 : : /* PDT templates make use of the mechanisms for formal args
4335 : : and so the parameter symbols are stored in the formal
4336 : : namespace. Transfer the sym_root to f2k_derived and then
4337 : : free the formal namespace since it is uneeded. */
4338 : 15333 : if (sym->attr.pdt_template && sym->formal && sym->formal->sym)
4339 : : {
4340 : 6 : ns = sym->formal->sym->ns;
4341 : 6 : sym->f2k_derived->sym_root = ns->sym_root;
4342 : 6 : ns->sym_root = NULL;
4343 : 6 : ns->refs++;
4344 : 6 : gfc_free_namespace (ns);
4345 : 6 : ns = NULL;
4346 : : }
4347 : :
4348 : 15333 : mio_f2k_derived (sym->f2k_derived);
4349 : : }
4350 : : else
4351 : 746635 : gcc_assert (!sym->f2k_derived);
4352 : : }
4353 : :
4354 : 961510 : mio_rparen ();
4355 : 961510 : }
4356 : :
4357 : : static const mstring omp_declare_simd_clauses[] =
4358 : : {
4359 : : minit ("INBRANCH", 0),
4360 : : minit ("NOTINBRANCH", 1),
4361 : : minit ("SIMDLEN", 2),
4362 : : minit ("UNIFORM", 3),
4363 : : minit ("LINEAR", 4),
4364 : : minit ("ALIGNED", 5),
4365 : : minit ("LINEAR_REF", 33),
4366 : : minit ("LINEAR_VAL", 34),
4367 : : minit ("LINEAR_UVAL", 35),
4368 : : minit (NULL, -1)
4369 : : };
4370 : :
4371 : : /* Handle !$omp declare simd. */
4372 : :
4373 : : static void
4374 : 208893 : mio_omp_declare_simd (gfc_namespace *ns, gfc_omp_declare_simd **odsp)
4375 : : {
4376 : 208893 : if (iomode == IO_OUTPUT)
4377 : : {
4378 : 23824 : if (*odsp == NULL)
4379 : : return;
4380 : : }
4381 : 185069 : else if (peek_atom () != ATOM_LPAREN)
4382 : : return;
4383 : :
4384 : 158 : gfc_omp_declare_simd *ods = *odsp;
4385 : :
4386 : 158 : mio_lparen ();
4387 : 158 : if (iomode == IO_OUTPUT)
4388 : : {
4389 : 84 : write_atom (ATOM_NAME, "OMP_DECLARE_SIMD");
4390 : 84 : if (ods->clauses)
4391 : : {
4392 : 84 : gfc_omp_namelist *n;
4393 : :
4394 : 84 : if (ods->clauses->inbranch)
4395 : 6 : mio_name (0, omp_declare_simd_clauses);
4396 : 84 : if (ods->clauses->notinbranch)
4397 : 18 : mio_name (1, omp_declare_simd_clauses);
4398 : 84 : if (ods->clauses->simdlen_expr)
4399 : : {
4400 : 23 : mio_name (2, omp_declare_simd_clauses);
4401 : 23 : mio_expr (&ods->clauses->simdlen_expr);
4402 : : }
4403 : 138 : for (n = ods->clauses->lists[OMP_LIST_UNIFORM]; n; n = n->next)
4404 : : {
4405 : 54 : mio_name (3, omp_declare_simd_clauses);
4406 : 54 : mio_symbol_ref (&n->sym);
4407 : : }
4408 : 135 : for (n = ods->clauses->lists[OMP_LIST_LINEAR]; n; n = n->next)
4409 : : {
4410 : 51 : if (n->u.linear.op == OMP_LINEAR_DEFAULT)
4411 : 32 : mio_name (4, omp_declare_simd_clauses);
4412 : : else
4413 : 19 : mio_name (32 + n->u.linear.op, omp_declare_simd_clauses);
4414 : 51 : mio_symbol_ref (&n->sym);
4415 : 51 : mio_expr (&n->expr);
4416 : : }
4417 : 84 : for (n = ods->clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
4418 : : {
4419 : 0 : mio_name (5, omp_declare_simd_clauses);
4420 : 0 : mio_symbol_ref (&n->sym);
4421 : 0 : mio_expr (&n->expr);
4422 : : }
4423 : : }
4424 : : }
4425 : : else
4426 : : {
4427 : 74 : gfc_omp_namelist **ptrs[3] = { NULL, NULL, NULL };
4428 : :
4429 : 74 : require_atom (ATOM_NAME);
4430 : 74 : *odsp = ods = gfc_get_omp_declare_simd ();
4431 : 74 : ods->where = gfc_current_locus;
4432 : 74 : ods->proc_name = ns->proc_name;
4433 : 74 : if (peek_atom () == ATOM_NAME)
4434 : : {
4435 : 56 : ods->clauses = gfc_get_omp_clauses ();
4436 : 56 : ptrs[0] = &ods->clauses->lists[OMP_LIST_UNIFORM];
4437 : 56 : ptrs[1] = &ods->clauses->lists[OMP_LIST_LINEAR];
4438 : 56 : ptrs[2] = &ods->clauses->lists[OMP_LIST_ALIGNED];
4439 : : }
4440 : 243 : while (peek_atom () == ATOM_NAME)
4441 : : {
4442 : 169 : gfc_omp_namelist *n;
4443 : 169 : int t = mio_name (0, omp_declare_simd_clauses);
4444 : :
4445 : 169 : switch (t)
4446 : : {
4447 : 0 : case 0: ods->clauses->inbranch = true; break;
4448 : 30 : case 1: ods->clauses->notinbranch = true; break;
4449 : 19 : case 2: mio_expr (&ods->clauses->simdlen_expr); break;
4450 : 117 : case 3:
4451 : 117 : case 4:
4452 : 117 : case 5:
4453 : 117 : *ptrs[t - 3] = n = gfc_get_omp_namelist ();
4454 : 120 : finish_namelist:
4455 : 120 : n->where = gfc_current_locus;
4456 : 120 : ptrs[t - 3] = &n->next;
4457 : 120 : mio_symbol_ref (&n->sym);
4458 : 120 : if (t != 3)
4459 : 52 : mio_expr (&n->expr);
4460 : : break;
4461 : 3 : case 33:
4462 : 3 : case 34:
4463 : 3 : case 35:
4464 : 3 : *ptrs[1] = n = gfc_get_omp_namelist ();
4465 : 3 : n->u.linear.op = (enum gfc_omp_linear_op) (t - 32);
4466 : 3 : t = 4;
4467 : 3 : goto finish_namelist;
4468 : : }
4469 : : }
4470 : : }
4471 : :
4472 : 158 : mio_omp_declare_simd (ns, &ods->next);
4473 : :
4474 : 158 : mio_rparen ();
4475 : : }
4476 : :
4477 : :
4478 : : static const mstring omp_declare_reduction_stmt[] =
4479 : : {
4480 : : minit ("ASSIGN", 0),
4481 : : minit ("CALL", 1),
4482 : : minit (NULL, -1)
4483 : : };
4484 : :
4485 : :
4486 : : static void
4487 : 280 : mio_omp_udr_expr (gfc_omp_udr *udr, gfc_symbol **sym1, gfc_symbol **sym2,
4488 : : gfc_namespace *ns, bool is_initializer)
4489 : : {
4490 : 280 : if (iomode == IO_OUTPUT)
4491 : : {
4492 : 136 : if ((*sym1)->module == NULL)
4493 : : {
4494 : 100 : (*sym1)->module = module_name;
4495 : 100 : (*sym2)->module = module_name;
4496 : : }
4497 : 136 : mio_symbol_ref (sym1);
4498 : 136 : mio_symbol_ref (sym2);
4499 : 136 : if (ns->code->op == EXEC_ASSIGN)
4500 : : {
4501 : 82 : mio_name (0, omp_declare_reduction_stmt);
4502 : 82 : mio_expr (&ns->code->expr1);
4503 : 82 : mio_expr (&ns->code->expr2);
4504 : : }
4505 : : else
4506 : : {
4507 : 54 : int flag;
4508 : 54 : mio_name (1, omp_declare_reduction_stmt);
4509 : 54 : mio_symtree_ref (&ns->code->symtree);
4510 : 54 : mio_actual_arglist (&ns->code->ext.actual, false);
4511 : :
4512 : 54 : flag = ns->code->resolved_isym != NULL;
4513 : 54 : mio_integer (&flag);
4514 : 54 : if (flag)
4515 : 0 : write_atom (ATOM_STRING, ns->code->resolved_isym->name);
4516 : : else
4517 : 54 : mio_symbol_ref (&ns->code->resolved_sym);
4518 : : }
4519 : : }
4520 : : else
4521 : : {
4522 : 144 : pointer_info *p1 = mio_symbol_ref (sym1);
4523 : 144 : pointer_info *p2 = mio_symbol_ref (sym2);
4524 : 144 : gfc_symbol *sym;
4525 : 144 : gcc_assert (p1->u.rsym.ns == p2->u.rsym.ns);
4526 : 144 : gcc_assert (p1->u.rsym.sym == NULL);
4527 : : /* Add hidden symbols to the symtree. */
4528 : 144 : pointer_info *q = get_integer (p1->u.rsym.ns);
4529 : 144 : q->u.pointer = (void *) ns;
4530 : 222 : sym = gfc_new_symbol (is_initializer ? "omp_priv" : "omp_out", ns);
4531 : 144 : sym->ts = udr->ts;
4532 : 144 : sym->module = gfc_get_string ("%s", p1->u.rsym.module);
4533 : 144 : associate_integer_pointer (p1, sym);
4534 : 144 : sym->attr.omp_udr_artificial_var = 1;
4535 : 144 : gcc_assert (p2->u.rsym.sym == NULL);
4536 : 222 : sym = gfc_new_symbol (is_initializer ? "omp_orig" : "omp_in", ns);
4537 : 144 : sym->ts = udr->ts;
4538 : 144 : sym->module = gfc_get_string ("%s", p2->u.rsym.module);
4539 : 144 : associate_integer_pointer (p2, sym);
4540 : 144 : sym->attr.omp_udr_artificial_var = 1;
4541 : 144 : if (mio_name (0, omp_declare_reduction_stmt) == 0)
4542 : : {
4543 : 90 : ns->code = gfc_get_code (EXEC_ASSIGN);
4544 : 90 : mio_expr (&ns->code->expr1);
4545 : 90 : mio_expr (&ns->code->expr2);
4546 : : }
4547 : : else
4548 : : {
4549 : 54 : int flag;
4550 : 54 : ns->code = gfc_get_code (EXEC_CALL);
4551 : 54 : mio_symtree_ref (&ns->code->symtree);
4552 : 54 : mio_actual_arglist (&ns->code->ext.actual, false);
4553 : :
4554 : 54 : mio_integer (&flag);
4555 : 54 : if (flag)
4556 : : {
4557 : 0 : require_atom (ATOM_STRING);
4558 : 0 : ns->code->resolved_isym = gfc_find_subroutine (atom_string);
4559 : 0 : free (atom_string);
4560 : : }
4561 : : else
4562 : 54 : mio_symbol_ref (&ns->code->resolved_sym);
4563 : : }
4564 : 144 : ns->code->loc = gfc_current_locus;
4565 : 144 : ns->omp_udr_ns = 1;
4566 : : }
4567 : 280 : }
4568 : :
4569 : :
4570 : : /* Unlike most other routines, the address of the symbol node is already
4571 : : fixed on input and the name/module has already been filled in.
4572 : : If you update the symbol format here, don't forget to update read_module
4573 : : as well (look for "seek to the symbol's component list"). */
4574 : :
4575 : : static void
4576 : 961510 : mio_symbol (gfc_symbol *sym)
4577 : : {
4578 : 961510 : int intmod = INTMOD_NONE;
4579 : :
4580 : 961510 : mio_lparen ();
4581 : :
4582 : 961510 : mio_symbol_attribute (&sym->attr);
4583 : :
4584 : 961510 : if (sym->attr.pdt_type)
4585 : 112 : sym->name = gfc_dt_upper_string (sym->name);
4586 : :
4587 : : /* Note that components are always saved, even if they are supposed
4588 : : to be private. Component access is checked during searching. */
4589 : 961510 : mio_component_list (&sym->components, sym->attr.vtype);
4590 : 961510 : if (sym->components != NULL)
4591 : 61760 : sym->component_access
4592 : 61760 : = MIO_NAME (gfc_access) (sym->component_access, access_types);
4593 : :
4594 : 961510 : mio_typespec (&sym->ts);
4595 : 961510 : if (sym->ts.type == BT_CLASS)
4596 : 13369 : sym->attr.class_ok = 1;
4597 : :
4598 : 961510 : if (iomode == IO_OUTPUT)
4599 : 199542 : mio_namespace_ref (&sym->formal_ns);
4600 : : else
4601 : : {
4602 : 761968 : mio_namespace_ref (&sym->formal_ns);
4603 : 761968 : if (sym->formal_ns)
4604 : 184995 : sym->formal_ns->proc_name = sym;
4605 : : }
4606 : :
4607 : : /* Save/restore common block links. */
4608 : 961510 : mio_symbol_ref (&sym->common_next);
4609 : :
4610 : 961510 : mio_formal_arglist (&sym->formal);
4611 : :
4612 : 961510 : if (sym->attr.flavor == FL_PARAMETER)
4613 : 134455 : mio_expr (&sym->value);
4614 : :
4615 : 961510 : mio_array_spec (&sym->as);
4616 : :
4617 : 961510 : mio_symbol_ref (&sym->result);
4618 : :
4619 : 961510 : if (sym->attr.cray_pointee)
4620 : 26 : mio_symbol_ref (&sym->cp_pointer);
4621 : :
4622 : : /* Load/save the f2k_derived namespace of a derived-type symbol. */
4623 : 961510 : mio_full_f2k_derived (sym);
4624 : :
4625 : : /* PDT types store the symbol specification list here. */
4626 : 961510 : mio_actual_arglist (&sym->param_list, true);
4627 : :
4628 : 961510 : mio_namelist (sym);
4629 : :
4630 : : /* Add the fields that say whether this is from an intrinsic module,
4631 : : and if so, what symbol it is within the module. */
4632 : : /* mio_integer (&(sym->from_intmod)); */
4633 : 961510 : if (iomode == IO_OUTPUT)
4634 : : {
4635 : 199542 : intmod = sym->from_intmod;
4636 : 199542 : mio_integer (&intmod);
4637 : : }
4638 : : else
4639 : : {
4640 : 761968 : mio_integer (&intmod);
4641 : 761968 : if (current_intmod)
4642 : 271334 : sym->from_intmod = current_intmod;
4643 : : else
4644 : 490634 : sym->from_intmod = (intmod_id) intmod;
4645 : : }
4646 : :
4647 : 961510 : mio_integer (&(sym->intmod_sym_id));
4648 : :
4649 : 961510 : if (gfc_fl_struct (sym->attr.flavor))
4650 : 64756 : mio_integer (&(sym->hash_value));
4651 : :
4652 : 961510 : if (sym->formal_ns
4653 : 209132 : && sym->formal_ns->proc_name == sym
4654 : 208735 : && sym->formal_ns->entries == NULL)
4655 : 208735 : mio_omp_declare_simd (sym->formal_ns, &sym->formal_ns->omp_declare_simd);
4656 : :
4657 : 961510 : mio_rparen ();
4658 : 961510 : }
4659 : :
4660 : :
4661 : : /************************* Top level subroutines *************************/
4662 : :
4663 : : /* A recursive function to look for a specific symbol by name and by
4664 : : module. Whilst several symtrees might point to one symbol, its
4665 : : is sufficient for the purposes here than one exist. Note that
4666 : : generic interfaces are distinguished as are symbols that have been
4667 : : renamed in another module. */
4668 : : static gfc_symtree *
4669 : 23668578 : find_symbol (gfc_symtree *st, const char *name,
4670 : : const char *module, int generic)
4671 : : {
4672 : 46993980 : int c;
4673 : 46993980 : gfc_symtree *retval, *s;
4674 : :
4675 : 46993980 : if (st == NULL || st->n.sym == NULL)
4676 : : return NULL;
4677 : :
4678 : 23327922 : c = strcmp (name, st->n.sym->name);
4679 : 85609 : if (c == 0 && st->n.sym->module
4680 : 85603 : && strcmp (module, st->n.sym->module) == 0
4681 : 23360569 : && !check_unique_name (st->name))
4682 : : {
4683 : 32563 : s = gfc_find_symtree (gfc_current_ns->sym_root, name);
4684 : :
4685 : : /* Detect symbols that are renamed by use association in another
4686 : : module by the absence of a symtree and null attr.use_rename,
4687 : : since the latter is not transmitted in the module file. */
4688 : 32563 : if (((!generic && !st->n.sym->attr.generic)
4689 : 25109 : || (generic && st->n.sym->attr.generic))
4690 : 7498 : && !(s == NULL && !st->n.sym->attr.use_rename))
4691 : : return st;
4692 : : }
4693 : :
4694 : 23327333 : retval = find_symbol (st->left, name, module, generic);
4695 : :
4696 : 23327333 : if (retval == NULL)
4697 : 23325402 : retval = find_symbol (st->right, name, module, generic);
4698 : :
4699 : : return retval;
4700 : : }
4701 : :
4702 : :
4703 : : /* Skip a list between balanced left and right parens.
4704 : : By setting NEST_LEVEL one assumes that a number of NEST_LEVEL opening parens
4705 : : have been already parsed by hand, and the remaining of the content is to be
4706 : : skipped here. The default value is 0 (balanced parens). */
4707 : :
4708 : : static void
4709 : 1068864 : skip_list (int nest_level = 0)
4710 : : {
4711 : 1068864 : int level;
4712 : :
4713 : 1068864 : level = nest_level;
4714 : 49611065 : do
4715 : : {
4716 : 49611065 : switch (parse_atom ())
4717 : : {
4718 : 12264774 : case ATOM_LPAREN:
4719 : 12264774 : level++;
4720 : 12264774 : break;
4721 : :
4722 : 12280292 : case ATOM_RPAREN:
4723 : 12280292 : level--;
4724 : 12280292 : break;
4725 : :
4726 : 525964 : case ATOM_STRING:
4727 : 525964 : free (atom_string);
4728 : 525964 : break;
4729 : :
4730 : : case ATOM_NAME:
4731 : : case ATOM_INTEGER:
4732 : : break;
4733 : : }
4734 : : }
4735 : 49611065 : while (level > 0);
4736 : 1068864 : }
4737 : :
4738 : :
4739 : : /* Load operator interfaces from the module. Interfaces are unusual
4740 : : in that they attach themselves to existing symbols. */
4741 : :
4742 : : static void
4743 : 11892 : load_operator_interfaces (void)
4744 : : {
4745 : 11892 : const char *p;
4746 : : /* "module" must be large enough for the case of submodules in which the name
4747 : : has the form module.submodule */
4748 : 11892 : char name[GFC_MAX_SYMBOL_LEN + 1], module[2 * GFC_MAX_SYMBOL_LEN + 2];
4749 : 11892 : gfc_user_op *uop;
4750 : 11892 : pointer_info *pi = NULL;
4751 : 11892 : int n, i;
4752 : :
4753 : 11892 : mio_lparen ();
4754 : :
4755 : 23935 : while (peek_atom () != ATOM_RPAREN)
4756 : : {
4757 : 151 : mio_lparen ();
4758 : :
4759 : 151 : mio_internal_string (name);
4760 : 151 : mio_internal_string (module);
4761 : :
4762 : 151 : n = number_use_names (name, true);
4763 : 151 : n = n ? n : 1;
4764 : :
4765 : 320 : for (i = 1; i <= n; i++)
4766 : : {
4767 : : /* Decide if we need to load this one or not. */
4768 : 169 : p = find_use_name_n (name, &i, true);
4769 : :
4770 : 169 : if (p == NULL)
4771 : : {
4772 : 14 : while (parse_atom () != ATOM_RPAREN);
4773 : 7 : continue;
4774 : : }
4775 : :
4776 : 162 : if (i == 1)
4777 : : {
4778 : 144 : uop = gfc_get_uop (p);
4779 : 144 : pi = mio_interface_rest (&uop->op);
4780 : : }
4781 : : else
4782 : : {
4783 : 18 : if (gfc_find_uop (p, NULL))
4784 : 6 : continue;
4785 : 12 : uop = gfc_get_uop (p);
4786 : 12 : uop->op = gfc_get_interface ();
4787 : 12 : uop->op->where = gfc_current_locus;
4788 : 12 : add_fixup (pi->integer, &uop->op->sym);
4789 : : }
4790 : : }
4791 : : }
4792 : :
4793 : 11892 : mio_rparen ();
4794 : 11892 : }
4795 : :
4796 : :
4797 : : /* Load interfaces from the module. Interfaces are unusual in that
4798 : : they attach themselves to existing symbols. */
4799 : :
4800 : : static void
4801 : 11892 : load_generic_interfaces (void)
4802 : : {
4803 : 11892 : const char *p;
4804 : : /* "module" must be large enough for the case of submodules in which the name
4805 : : has the form module.submodule */
4806 : 11892 : char name[GFC_MAX_SYMBOL_LEN + 1], module[2 * GFC_MAX_SYMBOL_LEN + 2];
4807 : 11892 : gfc_symbol *sym;
4808 : 11892 : gfc_interface *generic = NULL, *gen = NULL;
4809 : 11892 : int n, i, renamed;
4810 : 11892 : bool ambiguous_set = false;
4811 : :
4812 : 11892 : mio_lparen ();
4813 : :
4814 : 72057 : while (peek_atom () != ATOM_RPAREN)
4815 : : {
4816 : 48273 : mio_lparen ();
4817 : :
4818 : 48273 : mio_internal_string (name);
4819 : 48273 : mio_internal_string (module);
4820 : :
4821 : 48273 : n = number_use_names (name, false);
4822 : 48273 : renamed = n ? 1 : 0;
4823 : 47567 : n = n ? n : 1;
4824 : :
4825 : 96550 : for (i = 1; i <= n; i++)
4826 : : {
4827 : 48277 : gfc_symtree *st;
4828 : : /* Decide if we need to load this one or not. */
4829 : 48277 : p = find_use_name_n (name, &i, false);
4830 : :
4831 : 48277 : if (!p || gfc_find_symbol (p, NULL, 0, &sym))
4832 : : {
4833 : : /* Skip the specific names for these cases. */
4834 : 9105 : while (i == 1 && parse_atom () != ATOM_RPAREN);
4835 : :
4836 : 1628 : continue;
4837 : : }
4838 : :
4839 : 46649 : st = find_symbol (gfc_current_ns->sym_root,
4840 : : name, module_name, 1);
4841 : :
4842 : : /* If the symbol exists already and is being USEd without being
4843 : : in an ONLY clause, do not load a new symtree(11.3.2). */
4844 : 46649 : if (!only_flag && st)
4845 : 43 : sym = st->n.sym;
4846 : :
4847 : 46649 : if (!sym)
4848 : : {
4849 : 23975 : if (st)
4850 : : {
4851 : 1 : sym = st->n.sym;
4852 : 1 : if (strcmp (st->name, p) != 0)
4853 : : {
4854 : 1 : st = gfc_new_symtree (&gfc_current_ns->sym_root, p);
4855 : 1 : st->n.sym = sym;
4856 : 1 : sym->refs++;
4857 : : }
4858 : : }
4859 : :
4860 : : /* Since we haven't found a valid generic interface, we had
4861 : : better make one. */
4862 : 23975 : if (!sym)
4863 : : {
4864 : 23974 : gfc_get_symbol (p, NULL, &sym);
4865 : 23974 : sym->name = gfc_get_string ("%s", name);
4866 : 23974 : sym->module = module_name;
4867 : 23974 : sym->attr.flavor = FL_PROCEDURE;
4868 : 23974 : sym->attr.generic = 1;
4869 : 23974 : sym->attr.use_assoc = 1;
4870 : : }
4871 : : }
4872 : : else
4873 : : {
4874 : : /* Unless sym is a generic interface, this reference
4875 : : is ambiguous. */
4876 : 22674 : if (st == NULL)
4877 : 22630 : st = gfc_find_symtree (gfc_current_ns->sym_root, p);
4878 : :
4879 : 22674 : sym = st->n.sym;
4880 : :
4881 : 22674 : if (st && !sym->attr.generic
4882 : 20372 : && !st->ambiguous
4883 : 20372 : && sym->module
4884 : 20371 : && strcmp (module, sym->module))
4885 : : {
4886 : 1 : ambiguous_set = true;
4887 : 1 : st->ambiguous = 1;
4888 : : }
4889 : : }
4890 : :
4891 : 46649 : sym->attr.use_only = only_flag;
4892 : 46649 : sym->attr.use_rename = renamed;
4893 : :
4894 : 46649 : if (i == 1)
4895 : : {
4896 : 46645 : mio_interface_rest (&sym->generic);
4897 : 46645 : generic = sym->generic;
4898 : : }
4899 : 4 : else if (!sym->generic)
4900 : : {
4901 : 0 : sym->generic = generic;
4902 : 0 : sym->attr.generic_copy = 1;
4903 : : }
4904 : :
4905 : : /* If a procedure that is not generic has generic interfaces
4906 : : that include itself, it is generic! We need to take care
4907 : : to retain symbols ambiguous that were already so. */
4908 : 46649 : if (sym->attr.use_assoc
4909 : 46649 : && !sym->attr.generic
4910 : 2 : && sym->attr.flavor == FL_PROCEDURE)
4911 : : {
4912 : 4 : for (gen = generic; gen; gen = gen->next)
4913 : : {
4914 : 3 : if (gen->sym == sym)
4915 : : {
4916 : 1 : sym->attr.generic = 1;
4917 : 1 : if (ambiguous_set)
4918 : 0 : st->ambiguous = 0;
4919 : : break;
4920 : : }
4921 : : }
4922 : : }
4923 : :
4924 : : }
4925 : : }
4926 : :
4927 : 11892 : mio_rparen ();
4928 : 11892 : }
4929 : :
4930 : :
4931 : : /* Load common blocks. */
4932 : :
4933 : : static void
4934 : 11892 : load_commons (void)
4935 : : {
4936 : 11892 : char name[GFC_MAX_SYMBOL_LEN + 1];
4937 : 11892 : gfc_common_head *p;
4938 : :
4939 : 11892 : mio_lparen ();
4940 : :
4941 : 23954 : while (peek_atom () != ATOM_RPAREN)
4942 : : {
4943 : 170 : int flags = 0;
4944 : 170 : char* label;
4945 : 170 : mio_lparen ();
4946 : 170 : mio_internal_string (name);
4947 : :
4948 : 170 : p = gfc_get_common (name, 1);
4949 : :
4950 : 170 : mio_symbol_ref (&p->head);
4951 : 170 : mio_integer (&flags);
4952 : 170 : if (flags & 1)
4953 : 0 : p->saved = 1;
4954 : 170 : if (flags & 2)
4955 : 0 : p->threadprivate = 1;
4956 : 170 : p->omp_device_type = (gfc_omp_device_type) ((flags >> 2) & 3);
4957 : 170 : p->use_assoc = 1;
4958 : :
4959 : : /* Get whether this was a bind(c) common or not. */
4960 : 170 : mio_integer (&p->is_bind_c);
4961 : : /* Get the binding label. */
4962 : 170 : label = read_string ();
4963 : 170 : if (strlen (label))
4964 : 22 : p->binding_label = IDENTIFIER_POINTER (get_identifier (label));
4965 : 170 : XDELETEVEC (label);
4966 : :
4967 : 170 : mio_rparen ();
4968 : : }
4969 : :
4970 : 11892 : mio_rparen ();
4971 : 11892 : }
4972 : :
4973 : :
4974 : : /* Load equivalences. The flag in_load_equiv informs mio_expr_ref of this
4975 : : so that unused variables are not loaded and so that the expression can
4976 : : be safely freed. */
4977 : :
4978 : : static void
4979 : 11892 : load_equiv (void)
4980 : : {
4981 : 11892 : gfc_equiv *head, *tail, *end, *eq, *equiv;
4982 : 11892 : bool duplicate;
4983 : :
4984 : 11892 : mio_lparen ();
4985 : 11892 : in_load_equiv = true;
4986 : :
4987 : 11892 : end = gfc_current_ns->equiv;
4988 : 11898 : while (end != NULL && end->next != NULL)
4989 : : end = end->next;
4990 : :
4991 : 12025 : while (peek_atom () != ATOM_RPAREN) {
4992 : 133 : mio_lparen ();
4993 : 133 : head = tail = NULL;
4994 : :
4995 : 532 : while(peek_atom () != ATOM_RPAREN)
4996 : : {
4997 : 266 : if (head == NULL)
4998 : 133 : head = tail = gfc_get_equiv ();
4999 : : else
5000 : : {
5001 : 133 : tail->eq = gfc_get_equiv ();
5002 : 133 : tail = tail->eq;
5003 : : }
5004 : :
5005 : 266 : mio_pool_string (&tail->module);
5006 : 266 : mio_expr (&tail->expr);
5007 : : }
5008 : :
5009 : : /* Check for duplicate equivalences being loaded from different modules */
5010 : 133 : duplicate = false;
5011 : 192 : for (equiv = gfc_current_ns->equiv; equiv; equiv = equiv->next)
5012 : : {
5013 : 65 : if (equiv->module && head->module
5014 : 65 : && strcmp (equiv->module, head->module) == 0)
5015 : : {
5016 : : duplicate = true;
5017 : : break;
5018 : : }
5019 : : }
5020 : :
5021 : 133 : if (duplicate)
5022 : : {
5023 : 18 : for (eq = head; eq; eq = head)
5024 : : {
5025 : 12 : head = eq->eq;
5026 : 12 : gfc_free_expr (eq->expr);
5027 : 12 : free (eq);
5028 : : }
5029 : : }
5030 : :
5031 : 133 : if (end == NULL)
5032 : 80 : gfc_current_ns->equiv = head;
5033 : : else
5034 : 53 : end->next = head;
5035 : :
5036 : 133 : if (head != NULL)
5037 : 127 : end = head;
5038 : :
5039 : 133 : mio_rparen ();
5040 : : }
5041 : :
5042 : 11892 : mio_rparen ();
5043 : 11892 : in_load_equiv = false;
5044 : 11892 : }
5045 : :
5046 : :
5047 : : /* This function loads OpenMP user defined reductions. */
5048 : : static void
5049 : 11892 : load_omp_udrs (void)
5050 : : {
5051 : 11892 : mio_lparen ();
5052 : 23866 : while (peek_atom () != ATOM_RPAREN)
5053 : : {
5054 : 82 : const char *name = NULL, *newname;
5055 : 82 : char *altname;
5056 : 82 : gfc_typespec ts;
5057 : 82 : gfc_symtree *st;
5058 : 82 : gfc_omp_reduction_op rop = OMP_REDUCTION_USER;
5059 : :
5060 : 82 : mio_lparen ();
5061 : 82 : mio_pool_string (&name);
5062 : 82 : gfc_clear_ts (&ts);
5063 : 82 : mio_typespec (&ts);
5064 : 82 : if (startswith (name, "operator "))
5065 : : {
5066 : 32 : const char *p = name + sizeof ("operator ") - 1;
5067 : 32 : if (strcmp (p, "+") == 0)
5068 : : rop = OMP_REDUCTION_PLUS;
5069 : 0 : else if (strcmp (p, "*") == 0)
5070 : : rop = OMP_REDUCTION_TIMES;
5071 : 0 : else if (strcmp (p, "-") == 0)
5072 : : rop = OMP_REDUCTION_MINUS;
5073 : 0 : else if (strcmp (p, ".and.") == 0)
5074 : : rop = OMP_REDUCTION_AND;
5075 : 0 : else if (strcmp (p, ".or.") == 0)
5076 : : rop = OMP_REDUCTION_OR;
5077 : 0 : else if (strcmp (p, ".eqv.") == 0)
5078 : : rop = OMP_REDUCTION_EQV;
5079 : 0 : else if (strcmp (p, ".neqv.") == 0)
5080 : : rop = OMP_REDUCTION_NEQV;
5081 : : }
5082 : 50 : altname = NULL;
5083 : 50 : if (rop == OMP_REDUCTION_USER && name[0] == '.')
5084 : : {
5085 : 50 : size_t len = strlen (name + 1);
5086 : 50 : altname = XALLOCAVEC (char, len);
5087 : 50 : gcc_assert (name[len] == '.');
5088 : 50 : memcpy (altname, name + 1, len - 1);
5089 : 50 : altname[len - 1] = '\0';
5090 : : }
5091 : 82 : newname = name;
5092 : 82 : if (rop == OMP_REDUCTION_USER)
5093 : 100 : newname = find_use_name (altname ? altname : name, !!altname);
5094 : 38 : else if (only_flag && find_use_operator ((gfc_intrinsic_op) rop) == NULL)
5095 : : newname = NULL;
5096 : 82 : if (newname == NULL)
5097 : : {
5098 : 0 : skip_list (1);
5099 : 4 : continue;
5100 : : }
5101 : 82 : if (altname && newname != altname)
5102 : : {
5103 : 18 : size_t len = strlen (newname);
5104 : 18 : altname = XALLOCAVEC (char, len + 3);
5105 : 18 : altname[0] = '.';
5106 : 18 : memcpy (altname + 1, newname, len);
5107 : 18 : altname[len + 1] = '.';
5108 : 18 : altname[len + 2] = '\0';
5109 : 18 : name = gfc_get_string ("%s", altname);
5110 : : }
5111 : 82 : st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name);
5112 : 82 : gfc_omp_udr *udr = gfc_omp_udr_find (st, &ts);
5113 : 82 : if (udr)
5114 : : {
5115 : 4 : require_atom (ATOM_INTEGER);
5116 : 4 : pointer_info *p = get_integer (atom_int);
5117 : 4 : if (strcmp (p->u.rsym.module, udr->omp_out->module))
5118 : : {
5119 : 4 : gfc_error ("Ambiguous !$OMP DECLARE REDUCTION from "
5120 : : "module %s at %L",
5121 : : p->u.rsym.module, &gfc_current_locus);
5122 : 4 : gfc_error ("Previous !$OMP DECLARE REDUCTION from module "
5123 : : "%s at %L",
5124 : 4 : udr->omp_out->module, &udr->where);
5125 : : }
5126 : 4 : skip_list (1);
5127 : 4 : continue;
5128 : 4 : }
5129 : 78 : udr = gfc_get_omp_udr ();
5130 : 78 : udr->name = name;
5131 : 78 : udr->rop = rop;
5132 : 78 : udr->ts = ts;
5133 : 78 : udr->where = gfc_current_locus;
5134 : 78 : udr->combiner_ns = gfc_get_namespace (gfc_current_ns, 1);
5135 : 78 : udr->combiner_ns->proc_name = gfc_current_ns->proc_name;
5136 : 78 : mio_omp_udr_expr (udr, &udr->omp_out, &udr->omp_in, udr->combiner_ns,
5137 : : false);
5138 : 78 : if (peek_atom () != ATOM_RPAREN)
5139 : : {
5140 : 66 : udr->initializer_ns = gfc_get_namespace (gfc_current_ns, 1);
5141 : 66 : udr->initializer_ns->proc_name = gfc_current_ns->proc_name;
5142 : 66 : mio_omp_udr_expr (udr, &udr->omp_priv, &udr->omp_orig,
5143 : : udr->initializer_ns, true);
5144 : : }
5145 : 78 : if (st)
5146 : : {
5147 : 0 : udr->next = st->n.omp_udr;
5148 : 0 : st->n.omp_udr = udr;
5149 : : }
5150 : : else
5151 : : {
5152 : 78 : st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name);
5153 : 78 : st->n.omp_udr = udr;
5154 : : }
5155 : 78 : mio_rparen ();
5156 : : }
5157 : 11892 : mio_rparen ();
5158 : 11892 : }
5159 : :
5160 : :
5161 : : /* Recursive function to traverse the pointer_info tree and load a
5162 : : needed symbol. We return nonzero if we load a symbol and stop the
5163 : : traversal, because the act of loading can alter the tree. */
5164 : :
5165 : : static int
5166 : 7522741 : load_needed (pointer_info *p)
5167 : : {
5168 : 7522741 : gfc_namespace *ns;
5169 : 7522741 : pointer_info *q;
5170 : 7522741 : gfc_symbol *sym;
5171 : 7522741 : int rv;
5172 : :
5173 : 7522741 : rv = 0;
5174 : 7522741 : if (p == NULL)
5175 : : return rv;
5176 : :
5177 : 3744968 : rv |= load_needed (p->left);
5178 : 3744968 : rv |= load_needed (p->right);
5179 : :
5180 : 3744968 : if (p->type != P_SYMBOL || p->u.rsym.state != NEEDED)
5181 : : return rv;
5182 : :
5183 : 761968 : p->u.rsym.state = USED;
5184 : :
5185 : 761968 : set_module_locus (&p->u.rsym.where);
5186 : :
5187 : 761968 : sym = p->u.rsym.sym;
5188 : 761968 : if (sym == NULL)
5189 : : {
5190 : 493563 : q = get_integer (p->u.rsym.ns);
5191 : :
5192 : 493563 : ns = (gfc_namespace *) q->u.pointer;
5193 : 493563 : if (ns == NULL)
5194 : : {
5195 : : /* Create an interface namespace if necessary. These are
5196 : : the namespaces that hold the formal parameters of module
5197 : : procedures. */
5198 : :
5199 : 18055 : ns = gfc_get_namespace (NULL, 0);
5200 : 18055 : associate_integer_pointer (q, ns);
5201 : : }
5202 : :
5203 : : /* Use the module sym as 'proc_name' so that gfc_get_symbol_decl
5204 : : doesn't go pear-shaped if the symbol is used. */
5205 : 493563 : if (!ns->proc_name)
5206 : 25344 : gfc_find_symbol (p->u.rsym.module, gfc_current_ns,
5207 : : 1, &ns->proc_name);
5208 : :
5209 : 493563 : sym = gfc_new_symbol (p->u.rsym.true_name, ns);
5210 : 493563 : sym->name = gfc_dt_lower_string (p->u.rsym.true_name);
5211 : 493563 : sym->module = gfc_get_string ("%s", p->u.rsym.module);
5212 : 493563 : if (p->u.rsym.binding_label)
5213 : 19 : sym->binding_label = IDENTIFIER_POINTER (get_identifier
5214 : : (p->u.rsym.binding_label));
5215 : :
5216 : 493563 : associate_integer_pointer (p, sym);
5217 : : }
5218 : :
5219 : 761968 : mio_symbol (sym);
5220 : 761968 : sym->attr.use_assoc = 1;
5221 : :
5222 : : /* Unliked derived types, a STRUCTURE may share names with other symbols.
5223 : : We greedily converted the symbol name to lowercase before we knew its
5224 : : type, so now we must fix it. */
5225 : 761968 : if (sym->attr.flavor == FL_STRUCT)
5226 : 60 : sym->name = gfc_dt_upper_string (sym->name);
5227 : :
5228 : : /* Mark as only or rename for later diagnosis for explicitly imported
5229 : : but not used warnings; don't mark internal symbols such as __vtab,
5230 : : __def_init etc. Only mark them if they have been explicitly loaded. */
5231 : :
5232 : 761968 : if (only_flag && sym->name[0] != '_' && sym->name[1] != '_')
5233 : : {
5234 : 10735 : gfc_use_rename *u;
5235 : :
5236 : : /* Search the use/rename list for the variable; if the variable is
5237 : : found, mark it. */
5238 : 26735 : for (u = gfc_rename_list; u; u = u->next)
5239 : : {
5240 : 18695 : if (strcmp (u->use_name, sym->name) == 0)
5241 : : {
5242 : 2695 : sym->attr.use_only = 1;
5243 : 2695 : break;
5244 : : }
5245 : : }
5246 : : }
5247 : :
5248 : 761968 : if (p->u.rsym.renamed)
5249 : 3081 : sym->attr.use_rename = 1;
5250 : :
5251 : : return 1;
5252 : : }
5253 : :
5254 : :
5255 : : /* Recursive function for cleaning up things after a module has been read. */
5256 : :
5257 : : static void
5258 : 2629436 : read_cleanup (pointer_info *p)
5259 : : {
5260 : 2629436 : gfc_symtree *st;
5261 : 2629436 : pointer_info *q;
5262 : :
5263 : 2629436 : if (p == NULL)
5264 : : return;
5265 : :
5266 : 1308772 : read_cleanup (p->left);
5267 : 1308772 : read_cleanup (p->right);
5268 : :
5269 : 1308772 : if (p->type == P_SYMBOL && p->u.rsym.state == USED && !p->u.rsym.referenced)
5270 : : {
5271 : 539530 : gfc_namespace *ns;
5272 : : /* Add hidden symbols to the symtree. */
5273 : 539530 : q = get_integer (p->u.rsym.ns);
5274 : 539530 : ns = (gfc_namespace *) q->u.pointer;
5275 : :
5276 : 539530 : if (!p->u.rsym.sym->attr.vtype
5277 : 539530 : && !p->u.rsym.sym->attr.vtab)
5278 : 537700 : st = gfc_get_unique_symtree (ns);
5279 : : else
5280 : : {
5281 : : /* There is no reason to use 'unique_symtrees' for vtabs or
5282 : : vtypes - their name is fine for a symtree and reduces the
5283 : : namespace pollution. */
5284 : 1830 : st = gfc_find_symtree (ns->sym_root, p->u.rsym.sym->name);
5285 : 1830 : if (!st)
5286 : 290 : st = gfc_new_symtree (&ns->sym_root, p->u.rsym.sym->name);
5287 : : }
5288 : :
5289 : 539530 : st->n.sym = p->u.rsym.sym;
5290 : 539530 : st->n.sym->refs++;
5291 : :
5292 : : /* Fixup any symtree references. */
5293 : 539530 : p->u.rsym.symtree = st;
5294 : 539530 : resolve_fixups (p->u.rsym.stfixup, st);
5295 : 539530 : p->u.rsym.stfixup = NULL;
5296 : : }
5297 : :
5298 : : /* Free unused symbols. */
5299 : 1308772 : if (p->type == P_SYMBOL && p->u.rsym.state == UNUSED)
5300 : 129237 : gfc_free_symbol (p->u.rsym.sym);
5301 : : }
5302 : :
5303 : :
5304 : : /* It is not quite enough to check for ambiguity in the symbols by
5305 : : the loaded symbol and the new symbol not being identical. */
5306 : : static bool
5307 : 41227 : check_for_ambiguous (gfc_symtree *st, pointer_info *info)
5308 : : {
5309 : 41227 : gfc_symbol *rsym;
5310 : 41227 : module_locus locus;
5311 : 41227 : symbol_attribute attr;
5312 : 41227 : gfc_symbol *st_sym;
5313 : :
5314 : 41227 : if (gfc_current_ns->proc_name && st->name == gfc_current_ns->proc_name->name)
5315 : : {
5316 : 6 : gfc_error ("%qs of module %qs, imported at %C, is also the name of the "
5317 : : "current program unit", st->name, module_name);
5318 : 6 : return true;
5319 : : }
5320 : :
5321 : 41221 : st_sym = st->n.sym;
5322 : 41221 : rsym = info->u.rsym.sym;
5323 : 41221 : if (st_sym == rsym)
5324 : : return false;
5325 : :
5326 : 447 : if (st_sym->attr.vtab || st_sym->attr.vtype)
5327 : : return false;
5328 : :
5329 : : /* If the existing symbol is generic from a different module and
5330 : : the new symbol is generic there can be no ambiguity. */
5331 : 295 : if (st_sym->attr.generic
5332 : 20 : && st_sym->module
5333 : 20 : && st_sym->module != module_name)
5334 : : {
5335 : : /* The new symbol's attributes have not yet been read. Since
5336 : : we need attr.generic, read it directly. */
5337 : 20 : get_module_locus (&locus);
5338 : 20 : set_module_locus (&info->u.rsym.where);
5339 : 20 : mio_lparen ();
5340 : 20 : attr.generic = 0;
5341 : 20 : mio_symbol_attribute (&attr);
5342 : 20 : set_module_locus (&locus);
5343 : 20 : if (attr.generic)
5344 : : return false;
5345 : : }
5346 : :
5347 : : return true;
5348 : : }
5349 : :
5350 : :
5351 : : /* Read a module file. */
5352 : :
5353 : : static void
5354 : 11892 : read_module (void)
5355 : : {
5356 : 11892 : module_locus operator_interfaces, user_operators, omp_udrs;
5357 : 11892 : const char *p;
5358 : 11892 : char name[GFC_MAX_SYMBOL_LEN + 1];
5359 : 11892 : int i;
5360 : : /* Workaround -Wmaybe-uninitialized false positive during
5361 : : profiledbootstrap by initializing them. */
5362 : 11892 : int ambiguous = 0, j, nuse, symbol = 0;
5363 : 11892 : pointer_info *info, *q;
5364 : 11892 : gfc_use_rename *u = NULL;
5365 : 11892 : gfc_symtree *st;
5366 : 11892 : gfc_symbol *sym;
5367 : :
5368 : 11892 : get_module_locus (&operator_interfaces); /* Skip these for now. */
5369 : 11892 : skip_list ();
5370 : :
5371 : 11892 : get_module_locus (&user_operators);
5372 : 11892 : skip_list ();
5373 : 11892 : skip_list ();
5374 : :
5375 : : /* Skip commons and equivalences for now. */
5376 : 11892 : skip_list ();
5377 : 11892 : skip_list ();
5378 : :
5379 : : /* Skip OpenMP UDRs. */
5380 : 11892 : get_module_locus (&omp_udrs);
5381 : 11892 : skip_list ();
5382 : :
5383 : 11892 : mio_lparen ();
5384 : :
5385 : : /* Create the fixup nodes for all the symbols. */
5386 : :
5387 : 962020 : while (peek_atom () != ATOM_RPAREN)
5388 : : {
5389 : 938236 : char* bind_label;
5390 : 938236 : require_atom (ATOM_INTEGER);
5391 : 938236 : info = get_integer (atom_int);
5392 : :
5393 : 938236 : info->type = P_SYMBOL;
5394 : 938236 : info->u.rsym.state = UNUSED;
5395 : :
5396 : 938236 : info->u.rsym.true_name = read_string ();
5397 : 938236 : info->u.rsym.module = read_string ();
5398 : 938236 : bind_label = read_string ();
5399 : 938236 : if (strlen (bind_label))
5400 : 23797 : info->u.rsym.binding_label = bind_label;
5401 : : else
5402 : 914439 : XDELETEVEC (bind_label);
5403 : :
5404 : 938236 : require_atom (ATOM_INTEGER);
5405 : 938236 : info->u.rsym.ns = atom_int;
5406 : :
5407 : 938236 : get_module_locus (&info->u.rsym.where);
5408 : :
5409 : : /* See if the symbol has already been loaded by a previous module.
5410 : : If so, we reference the existing symbol and prevent it from
5411 : : being loaded again. This should not happen if the symbol being
5412 : : read is an index for an assumed shape dummy array (ns != 1). */
5413 : :
5414 : 938236 : sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module);
5415 : :
5416 : 938236 : if (sym == NULL
5417 : 47056 : || (sym->attr.flavor == FL_VARIABLE && info->u.rsym.ns !=1))
5418 : : {
5419 : 891205 : skip_list ();
5420 : 891205 : continue;
5421 : : }
5422 : :
5423 : 47031 : info->u.rsym.state = USED;
5424 : 47031 : info->u.rsym.sym = sym;
5425 : : /* The current symbol has already been loaded, so we can avoid loading
5426 : : it again. However, if it is a derived type, some of its components
5427 : : can be used in expressions in the module. To avoid the module loading
5428 : : failing, we need to associate the module's component pointer indexes
5429 : : with the existing symbol's component pointers. */
5430 : 47031 : if (gfc_fl_struct (sym->attr.flavor))
5431 : : {
5432 : 4229 : gfc_component *c;
5433 : :
5434 : : /* First seek to the symbol's component list. */
5435 : 4229 : mio_lparen (); /* symbol opening. */
5436 : 4229 : skip_list (); /* skip symbol attribute. */
5437 : :
5438 : 4229 : mio_lparen (); /* component list opening. */
5439 : 15514 : for (c = sym->components; c; c = c->next)
5440 : : {
5441 : 11285 : pointer_info *p;
5442 : 11285 : const char *comp_name = NULL;
5443 : 11285 : int n = 0;
5444 : :
5445 : 11285 : mio_lparen (); /* component opening. */
5446 : 11285 : mio_integer (&n);
5447 : 11285 : p = get_integer (n);
5448 : 11285 : if (p->u.pointer == NULL)
5449 : 11285 : associate_integer_pointer (p, c);
5450 : 11285 : mio_pool_string (&comp_name);
5451 : 11285 : if (comp_name != c->name)
5452 : : {
5453 : 0 : gfc_fatal_error ("Mismatch in components of derived type "
5454 : : "%qs from %qs at %C: expecting %qs, "
5455 : : "but got %qs", sym->name, sym->module,
5456 : : c->name, comp_name);
5457 : : }
5458 : 11285 : skip_list (1); /* component end. */
5459 : : }
5460 : 4229 : mio_rparen (); /* component list closing. */
5461 : :
5462 : 4229 : skip_list (1); /* symbol end. */
5463 : 4229 : }
5464 : : else
5465 : 42802 : skip_list ();
5466 : :
5467 : : /* Some symbols do not have a namespace (eg. formal arguments),
5468 : : so the automatic "unique symtree" mechanism must be suppressed
5469 : : by marking them as referenced. */
5470 : 47031 : q = get_integer (info->u.rsym.ns);
5471 : 47031 : if (q->u.pointer == NULL)
5472 : : {
5473 : 1239 : info->u.rsym.referenced = 1;
5474 : 1239 : continue;
5475 : : }
5476 : : }
5477 : :
5478 : 11892 : mio_rparen ();
5479 : :
5480 : : /* Parse the symtree lists. This lets us mark which symbols need to
5481 : : be loaded. Renaming is also done at this point by replacing the
5482 : : symtree name. */
5483 : :
5484 : 11892 : mio_lparen ();
5485 : :
5486 : 375572 : while (peek_atom () != ATOM_RPAREN)
5487 : : {
5488 : 351788 : mio_internal_string (name);
5489 : 351788 : mio_integer (&ambiguous);
5490 : 351788 : mio_integer (&symbol);
5491 : :
5492 : 351788 : info = get_integer (symbol);
5493 : :
5494 : : /* See how many use names there are. If none, go through the start
5495 : : of the loop at least once. */
5496 : 351788 : nuse = number_use_names (name, false);
5497 : 351788 : info->u.rsym.renamed = nuse ? 1 : 0;
5498 : :
5499 : 351788 : if (nuse == 0)
5500 : 348684 : nuse = 1;
5501 : :
5502 : 703610 : for (j = 1; j <= nuse; j++)
5503 : : {
5504 : : /* Get the jth local name for this symbol. */
5505 : 351822 : p = find_use_name_n (name, &j, false);
5506 : :
5507 : 351822 : if (p == NULL && strcmp (name, module_name) == 0)
5508 : : p = name;
5509 : :
5510 : : /* Exception: Always import vtabs & vtypes. */
5511 : 43882 : if (p == NULL && name[0] == '_'
5512 : 2986 : && (startswith (name, "__vtab_")
5513 : 1974 : || startswith (name, "__vtype_")))
5514 : : p = name;
5515 : :
5516 : : /* Skip symtree nodes not in an ONLY clause, unless there
5517 : : is an existing symtree loaded from another USE statement. */
5518 : 349798 : if (p == NULL)
5519 : : {
5520 : 41858 : st = gfc_find_symtree (gfc_current_ns->sym_root, name);
5521 : 41858 : if (st != NULL
5522 : 533 : && strcmp (st->n.sym->name, info->u.rsym.true_name) == 0
5523 : 475 : && st->n.sym->module != NULL
5524 : 198 : && strcmp (st->n.sym->module, info->u.rsym.module) == 0)
5525 : : {
5526 : 190 : info->u.rsym.symtree = st;
5527 : 190 : info->u.rsym.sym = st->n.sym;
5528 : : }
5529 : 41858 : continue;
5530 : : }
5531 : :
5532 : : /* If a symbol of the same name and module exists already,
5533 : : this symbol, which is not in an ONLY clause, must not be
5534 : : added to the namespace(11.3.2). Note that find_symbol
5535 : : only returns the first occurrence that it finds. */
5536 : 303857 : if (!only_flag && !info->u.rsym.renamed
5537 : 303496 : && strcmp (name, module_name) != 0
5538 : 604560 : && find_symbol (gfc_current_ns->sym_root, name,
5539 : : module_name, 0))
5540 : 544 : continue;
5541 : :
5542 : 309420 : st = gfc_find_symtree (gfc_current_ns->sym_root, p);
5543 : :
5544 : 309420 : if (st != NULL
5545 : 41263 : && !(st->n.sym && st->n.sym->attr.used_in_submodule))
5546 : : {
5547 : : /* Check for ambiguous symbols. */
5548 : 41227 : if (check_for_ambiguous (st, info))
5549 : 282 : st->ambiguous = 1;
5550 : : else
5551 : 40945 : info->u.rsym.symtree = st;
5552 : : }
5553 : : else
5554 : : {
5555 : 268193 : if (st)
5556 : : {
5557 : : /* This symbol is host associated from a module in a
5558 : : submodule. Hide it with a unique symtree. */
5559 : 36 : gfc_symtree *s = gfc_get_unique_symtree (gfc_current_ns);
5560 : 36 : s->n.sym = st->n.sym;
5561 : 36 : st->n.sym = NULL;
5562 : : }
5563 : : else
5564 : : {
5565 : : /* Create a symtree node in the current namespace for this
5566 : : symbol. */
5567 : 536314 : st = check_unique_name (p)
5568 : 268157 : ? gfc_get_unique_symtree (gfc_current_ns)
5569 : 268157 : : gfc_new_symtree (&gfc_current_ns->sym_root, p);
5570 : 268157 : st->ambiguous = ambiguous;
5571 : : }
5572 : :
5573 : 268193 : sym = info->u.rsym.sym;
5574 : :
5575 : : /* Create a symbol node if it doesn't already exist. */
5576 : 268193 : if (sym == NULL)
5577 : : {
5578 : 268042 : info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name,
5579 : : gfc_current_ns);
5580 : 268042 : info->u.rsym.sym->name = gfc_dt_lower_string (info->u.rsym.true_name);
5581 : 268042 : sym = info->u.rsym.sym;
5582 : 268042 : sym->module = gfc_get_string ("%s", info->u.rsym.module);
5583 : :
5584 : 268042 : if (info->u.rsym.binding_label)
5585 : : {
5586 : 14695 : tree id = get_identifier (info->u.rsym.binding_label);
5587 : 14695 : sym->binding_label = IDENTIFIER_POINTER (id);
5588 : : }
5589 : : }
5590 : :
5591 : 268193 : st->n.sym = sym;
5592 : 268193 : st->n.sym->refs++;
5593 : :
5594 : 268193 : if (strcmp (name, p) != 0)
5595 : 509 : sym->attr.use_rename = 1;
5596 : :
5597 : 268193 : if (name[0] != '_'
5598 : 268193 : || (!startswith (name, "__vtab_")
5599 : 26129 : && !startswith (name, "__vtype_")))
5600 : 243207 : sym->attr.use_only = only_flag;
5601 : :
5602 : : /* Store the symtree pointing to this symbol. */
5603 : 268193 : info->u.rsym.symtree = st;
5604 : :
5605 : 268193 : if (info->u.rsym.state == UNUSED)
5606 : 268042 : info->u.rsym.state = NEEDED;
5607 : 268193 : info->u.rsym.referenced = 1;
5608 : : }
5609 : : }
5610 : : }
5611 : :
5612 : 11892 : mio_rparen ();
5613 : :
5614 : : /* Load intrinsic operator interfaces. */
5615 : 11892 : set_module_locus (&operator_interfaces);
5616 : 11892 : mio_lparen ();
5617 : :
5618 : 344868 : for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
5619 : : {
5620 : 332976 : gfc_use_rename *u = NULL, *v = NULL;
5621 : 332976 : int j = i;
5622 : :
5623 : 332976 : if (i == INTRINSIC_USER)
5624 : 11892 : continue;
5625 : :
5626 : 321084 : if (only_flag)
5627 : : {
5628 : 43902 : u = find_use_operator ((gfc_intrinsic_op) i);
5629 : :
5630 : : /* F2018:10.1.5.5.1 requires same interpretation of old and new-style
5631 : : relational operators. Special handling for USE, ONLY. */
5632 : 43902 : switch (i)
5633 : : {
5634 : : case INTRINSIC_EQ:
5635 : : j = INTRINSIC_EQ_OS;
5636 : : break;
5637 : : case INTRINSIC_EQ_OS:
5638 : : j = INTRINSIC_EQ;
5639 : : break;
5640 : : case INTRINSIC_NE:
5641 : : j = INTRINSIC_NE_OS;
5642 : : break;
5643 : : case INTRINSIC_NE_OS:
5644 : : j = INTRINSIC_NE;
5645 : : break;
5646 : : case INTRINSIC_GT:
5647 : : j = INTRINSIC_GT_OS;
5648 : : break;
5649 : : case INTRINSIC_GT_OS:
5650 : : j = INTRINSIC_GT;
5651 : : break;
5652 : : case INTRINSIC_GE:
5653 : : j = INTRINSIC_GE_OS;
5654 : : break;
5655 : : case INTRINSIC_GE_OS:
5656 : : j = INTRINSIC_GE;
5657 : : break;
5658 : : case INTRINSIC_LT:
5659 : : j = INTRINSIC_LT_OS;
5660 : : break;
5661 : : case INTRINSIC_LT_OS:
5662 : : j = INTRINSIC_LT;
5663 : : break;
5664 : : case INTRINSIC_LE:
5665 : : j = INTRINSIC_LE_OS;
5666 : : break;
5667 : : case INTRINSIC_LE_OS:
5668 : : j = INTRINSIC_LE;
5669 : : break;
5670 : : default:
5671 : : break;
5672 : : }
5673 : :
5674 : : if (j != i)
5675 : 19512 : v = find_use_operator ((gfc_intrinsic_op) j);
5676 : :
5677 : 43902 : if (u == NULL && v == NULL)
5678 : : {
5679 : 43758 : skip_list ();
5680 : 43758 : continue;
5681 : : }
5682 : :
5683 : 144 : if (u)
5684 : 107 : u->found = 1;
5685 : 144 : if (v)
5686 : 89 : v->found = 1;
5687 : : }
5688 : :
5689 : 277326 : mio_interface (&gfc_current_ns->op[i]);
5690 : 277326 : if (!gfc_current_ns->op[i] && !gfc_current_ns->op[j])
5691 : : {
5692 : 275791 : if (u)
5693 : 15 : u->found = 0;
5694 : 275791 : if (v)
5695 : 26 : v->found = 0;
5696 : : }
5697 : : }
5698 : :
5699 : 11892 : mio_rparen ();
5700 : :
5701 : : /* Load generic and user operator interfaces. These must follow the
5702 : : loading of symtree because otherwise symbols can be marked as
5703 : : ambiguous. */
5704 : :
5705 : 11892 : set_module_locus (&user_operators);
5706 : :
5707 : 11892 : load_operator_interfaces ();
5708 : 11892 : load_generic_interfaces ();
5709 : :
5710 : 11892 : load_commons ();
5711 : 11892 : load_equiv ();
5712 : :
5713 : : /* Load OpenMP user defined reductions. */
5714 : 11892 : set_module_locus (&omp_udrs);
5715 : 11892 : load_omp_udrs ();
5716 : :
5717 : : /* At this point, we read those symbols that are needed but haven't
5718 : : been loaded yet. If one symbol requires another, the other gets
5719 : : marked as NEEDED if its previous state was UNUSED. */
5720 : :
5721 : 44697 : while (load_needed (pi_root));
5722 : :
5723 : : /* Make sure all elements of the rename-list were found in the module. */
5724 : :
5725 : 14643 : for (u = gfc_rename_list; u; u = u->next)
5726 : : {
5727 : 2751 : if (u->found)
5728 : 2744 : continue;
5729 : :
5730 : 7 : if (u->op == INTRINSIC_NONE)
5731 : : {
5732 : 2 : gfc_error ("Symbol %qs referenced at %L not found in module %qs",
5733 : 2 : u->use_name, &u->where, module_name);
5734 : 2 : continue;
5735 : : }
5736 : :
5737 : 5 : if (u->op == INTRINSIC_USER)
5738 : : {
5739 : 2 : gfc_error ("User operator %qs referenced at %L not found "
5740 : 2 : "in module %qs", u->use_name, &u->where, module_name);
5741 : 2 : continue;
5742 : : }
5743 : :
5744 : 3 : gfc_error ("Intrinsic operator %qs referenced at %L not found "
5745 : : "in module %qs", gfc_op2string (u->op), &u->where,
5746 : : module_name);
5747 : : }
5748 : :
5749 : : /* Clean up symbol nodes that were never loaded, create references
5750 : : to hidden symbols. */
5751 : :
5752 : 11892 : read_cleanup (pi_root);
5753 : 11892 : }
5754 : :
5755 : :
5756 : : /* Given an access type that is specific to an entity and the default
5757 : : access, return nonzero if the entity is publicly accessible. If the
5758 : : element is declared as PUBLIC, then it is public; if declared
5759 : : PRIVATE, then private, and otherwise it is public unless the default
5760 : : access in this context has been declared PRIVATE. */
5761 : :
5762 : : static bool dump_smod = false;
5763 : :
5764 : : static bool
5765 : 886270 : check_access (gfc_access specific_access, gfc_access default_access)
5766 : : {
5767 : 886270 : if (dump_smod)
5768 : : return true;
5769 : :
5770 : 869741 : if (specific_access == ACCESS_PUBLIC)
5771 : : return true;
5772 : 843618 : if (specific_access == ACCESS_PRIVATE)
5773 : : return false;
5774 : :
5775 : 841388 : if (flag_module_private)
5776 : 91 : return default_access == ACCESS_PUBLIC;
5777 : : else
5778 : 841297 : return default_access != ACCESS_PRIVATE;
5779 : : }
5780 : :
5781 : :
5782 : : bool
5783 : 740726 : gfc_check_symbol_access (gfc_symbol *sym)
5784 : : {
5785 : 740726 : if (sym->attr.vtab || sym->attr.vtype)
5786 : : return true;
5787 : : else
5788 : 650058 : return check_access (sym->attr.access, sym->ns->default_access);
5789 : : }
5790 : :
5791 : :
5792 : : /* A structure to remember which commons we've already written. */
5793 : :
5794 : : struct written_common
5795 : : {
5796 : : BBT_HEADER(written_common);
5797 : : const char *name, *label;
5798 : : };
5799 : :
5800 : : static struct written_common *written_commons = NULL;
5801 : :
5802 : : /* Comparison function used for balancing the binary tree. */
5803 : :
5804 : : static int
5805 : 86 : compare_written_commons (void *a1, void *b1)
5806 : : {
5807 : 86 : const char *aname = ((struct written_common *) a1)->name;
5808 : 86 : const char *alabel = ((struct written_common *) a1)->label;
5809 : 86 : const char *bname = ((struct written_common *) b1)->name;
5810 : 86 : const char *blabel = ((struct written_common *) b1)->label;
5811 : 86 : int c = strcmp (aname, bname);
5812 : :
5813 : 86 : return (c != 0 ? c : strcmp (alabel, blabel));
5814 : : }
5815 : :
5816 : : /* Free a list of written commons. */
5817 : :
5818 : : static void
5819 : 8805 : free_written_common (struct written_common *w)
5820 : : {
5821 : 8805 : if (!w)
5822 : : return;
5823 : :
5824 : 203 : if (w->left)
5825 : 32 : free_written_common (w->left);
5826 : 203 : if (w->right)
5827 : 31 : free_written_common (w->right);
5828 : :
5829 : 203 : free (w);
5830 : : }
5831 : :
5832 : : /* Write a common block to the module -- recursive helper function. */
5833 : :
5834 : : static void
5835 : 18392 : write_common_0 (gfc_symtree *st, bool this_module)
5836 : : {
5837 : 18392 : gfc_common_head *p;
5838 : 18392 : const char * name;
5839 : 18392 : int flags;
5840 : 18392 : const char *label;
5841 : 18392 : struct written_common *w;
5842 : 18392 : bool write_me = true;
5843 : :
5844 : 18392 : if (st == NULL)
5845 : 17938 : return;
5846 : :
5847 : 454 : write_common_0 (st->left, this_module);
5848 : :
5849 : : /* We will write out the binding label, or "" if no label given. */
5850 : 454 : name = st->n.common->name;
5851 : 454 : p = st->n.common;
5852 : 454 : label = (p->is_bind_c && p->binding_label) ? p->binding_label : "";
5853 : :
5854 : : /* Check if we've already output this common. */
5855 : 454 : w = written_commons;
5856 : 857 : while (w)
5857 : : {
5858 : 403 : int c = strcmp (name, w->name);
5859 : 403 : c = (c != 0 ? c : strcmp (label, w->label));
5860 : 198 : if (c == 0)
5861 : : write_me = false;
5862 : :
5863 : 403 : w = (c < 0) ? w->left : w->right;
5864 : : }
5865 : :
5866 : 454 : if (this_module && p->use_assoc)
5867 : : write_me = false;
5868 : :
5869 : 401 : if (write_me)
5870 : : {
5871 : : /* Write the common to the module. */
5872 : 203 : mio_lparen ();
5873 : 203 : mio_pool_string (&name);
5874 : :
5875 : 203 : mio_symbol_ref (&p->head);
5876 : 203 : flags = p->saved ? 1 : 0;
5877 : 203 : if (p->threadprivate)
5878 : 0 : flags |= 2;
5879 : 203 : flags |= p->omp_device_type << 2;
5880 : 203 : mio_integer (&flags);
5881 : :
5882 : : /* Write out whether the common block is bind(c) or not. */
5883 : 203 : mio_integer (&(p->is_bind_c));
5884 : :
5885 : 203 : mio_pool_string (&label);
5886 : 203 : mio_rparen ();
5887 : :
5888 : : /* Record that we have written this common. */
5889 : 203 : w = XCNEW (struct written_common);
5890 : 203 : w->name = p->name;
5891 : 203 : w->label = label;
5892 : 203 : gfc_insert_bbt (&written_commons, w, compare_written_commons);
5893 : : }
5894 : :
5895 : 454 : write_common_0 (st->right, this_module);
5896 : : }
5897 : :
5898 : :
5899 : : /* Write a common, by initializing the list of written commons, calling
5900 : : the recursive function write_common_0() and cleaning up afterwards. */
5901 : :
5902 : : static void
5903 : 8742 : write_common (gfc_symtree *st)
5904 : : {
5905 : 8742 : written_commons = NULL;
5906 : 8742 : write_common_0 (st, true);
5907 : 8742 : write_common_0 (st, false);
5908 : 8742 : free_written_common (written_commons);
5909 : 8742 : written_commons = NULL;
5910 : 8742 : }
5911 : :
5912 : :
5913 : : /* Write the blank common block to the module. */
5914 : :
5915 : : static void
5916 : 8742 : write_blank_common (void)
5917 : : {
5918 : 8742 : const char * name = BLANK_COMMON_NAME;
5919 : 8742 : int saved;
5920 : : /* TODO: Blank commons are not bind(c). The F2003 standard probably says
5921 : : this, but it hasn't been checked. Just making it so for now. */
5922 : 8742 : int is_bind_c = 0;
5923 : :
5924 : 8742 : if (gfc_current_ns->blank_common.head == NULL)
5925 : 8735 : return;
5926 : :
5927 : 7 : mio_lparen ();
5928 : :
5929 : 7 : mio_pool_string (&name);
5930 : :
5931 : 7 : mio_symbol_ref (&gfc_current_ns->blank_common.head);
5932 : 7 : saved = gfc_current_ns->blank_common.saved;
5933 : 7 : mio_integer (&saved);
5934 : :
5935 : : /* Write out whether the common block is bind(c) or not. */
5936 : 7 : mio_integer (&is_bind_c);
5937 : :
5938 : : /* Write out an empty binding label. */
5939 : 7 : write_atom (ATOM_STRING, "");
5940 : :
5941 : 7 : mio_rparen ();
5942 : : }
5943 : :
5944 : :
5945 : : /* Write equivalences to the module. */
5946 : :
5947 : : static void
5948 : 8742 : write_equiv (void)
5949 : : {
5950 : 8742 : gfc_equiv *eq, *e;
5951 : 8742 : int num;
5952 : :
5953 : 8742 : num = 0;
5954 : 8824 : for (eq = gfc_current_ns->equiv; eq; eq = eq->next)
5955 : : {
5956 : 82 : mio_lparen ();
5957 : :
5958 : 328 : for (e = eq; e; e = e->eq)
5959 : : {
5960 : 164 : if (e->module == NULL)
5961 : 142 : e->module = gfc_get_string ("%s.eq.%d", module_name, num);
5962 : 164 : mio_allocated_string (e->module);
5963 : 164 : mio_expr (&e->expr);
5964 : : }
5965 : :
5966 : 82 : num++;
5967 : 82 : mio_rparen ();
5968 : : }
5969 : 8742 : }
5970 : :
5971 : :
5972 : : /* Write a symbol to the module. */
5973 : :
5974 : : static void
5975 : 199542 : write_symbol (int n, gfc_symbol *sym)
5976 : : {
5977 : 199542 : const char *label;
5978 : :
5979 : 199542 : if (sym->attr.flavor == FL_UNKNOWN || sym->attr.flavor == FL_LABEL)
5980 : 0 : gfc_internal_error ("write_symbol(): bad module symbol %qs", sym->name);
5981 : :
5982 : 199542 : mio_integer (&n);
5983 : :
5984 : 199542 : if (gfc_fl_struct (sym->attr.flavor))
5985 : : {
5986 : 22870 : const char *name;
5987 : 22870 : name = gfc_dt_upper_string (sym->name);
5988 : 22870 : mio_pool_string (&name);
5989 : 22870 : }
5990 : : else
5991 : 176672 : mio_pool_string (&sym->name);
5992 : :
5993 : 199542 : mio_pool_string (&sym->module);
5994 : 199542 : if ((sym->attr.is_bind_c || sym->attr.is_iso_c) && sym->binding_label)
5995 : : {
5996 : 2322 : label = sym->binding_label;
5997 : 2322 : mio_pool_string (&label);
5998 : : }
5999 : : else
6000 : 197220 : write_atom (ATOM_STRING, "");
6001 : :
6002 : 199542 : mio_pointer_ref (&sym->ns);
6003 : :
6004 : 199542 : mio_symbol (sym);
6005 : 199542 : write_char ('\n');
6006 : 199542 : }
6007 : :
6008 : :
6009 : : /* Recursive traversal function to write the initial set of symbols to
6010 : : the module. We check to see if the symbol should be written
6011 : : according to the access specification. */
6012 : :
6013 : : static void
6014 : 140465 : write_symbol0 (gfc_symtree *st)
6015 : : {
6016 : 272188 : gfc_symbol *sym;
6017 : 272188 : pointer_info *p;
6018 : 272188 : bool dont_write = false;
6019 : :
6020 : 272188 : if (st == NULL)
6021 : 140465 : return;
6022 : :
6023 : 131723 : write_symbol0 (st->left);
6024 : :
6025 : 131723 : sym = st->n.sym;
6026 : 131723 : if (sym->module == NULL)
6027 : 61693 : sym->module = module_name;
6028 : :
6029 : 131723 : if (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
6030 : 43291 : && !sym->attr.subroutine && !sym->attr.function)
6031 : 131723 : dont_write = true;
6032 : :
6033 : 131723 : if (!gfc_check_symbol_access (sym))
6034 : : dont_write = true;
6035 : :
6036 : 115119 : if (!dont_write)
6037 : : {
6038 : 113802 : p = get_pointer (sym);
6039 : 113802 : if (p->type == P_UNKNOWN)
6040 : 86101 : p->type = P_SYMBOL;
6041 : :
6042 : 113802 : if (p->u.wsym.state != WRITTEN)
6043 : : {
6044 : 110973 : write_symbol (p->integer, sym);
6045 : 110973 : p->u.wsym.state = WRITTEN;
6046 : : }
6047 : : }
6048 : :
6049 : 131723 : write_symbol0 (st->right);
6050 : : }
6051 : :
6052 : :
6053 : : static void
6054 : 94 : write_omp_udr (gfc_omp_udr *udr)
6055 : : {
6056 : 94 : switch (udr->rop)
6057 : : {
6058 : 65 : case OMP_REDUCTION_USER:
6059 : : /* Non-operators can't be used outside of the module. */
6060 : 65 : if (udr->name[0] != '.')
6061 : : return;
6062 : : else
6063 : : {
6064 : 47 : gfc_symtree *st;
6065 : 47 : size_t len = strlen (udr->name + 1);
6066 : 47 : char *name = XALLOCAVEC (char, len);
6067 : 47 : memcpy (name, udr->name, len - 1);
6068 : 47 : name[len - 1] = '\0';
6069 : 47 : st = gfc_find_symtree (gfc_current_ns->uop_root, name);
6070 : : /* If corresponding user operator is private, don't write
6071 : : the UDR. */
6072 : 47 : if (st != NULL)
6073 : : {
6074 : 0 : gfc_user_op *uop = st->n.uop;
6075 : 0 : if (!check_access (uop->access, uop->ns->default_access))
6076 : : return;
6077 : : }
6078 : : }
6079 : : break;
6080 : 29 : case OMP_REDUCTION_PLUS:
6081 : 29 : case OMP_REDUCTION_MINUS:
6082 : 29 : case OMP_REDUCTION_TIMES:
6083 : 29 : case OMP_REDUCTION_AND:
6084 : 29 : case OMP_REDUCTION_OR:
6085 : 29 : case OMP_REDUCTION_EQV:
6086 : 29 : case OMP_REDUCTION_NEQV:
6087 : : /* If corresponding operator is private, don't write the UDR. */
6088 : 29 : if (!check_access (gfc_current_ns->operator_access[udr->rop],
6089 : : gfc_current_ns->default_access))
6090 : : return;
6091 : : break;
6092 : : default:
6093 : : break;
6094 : : }
6095 : 75 : if (udr->ts.type == BT_DERIVED || udr->ts.type == BT_CLASS)
6096 : : {
6097 : : /* If derived type is private, don't write the UDR. */
6098 : 39 : if (!gfc_check_symbol_access (udr->ts.u.derived))
6099 : : return;
6100 : : }
6101 : :
6102 : 74 : mio_lparen ();
6103 : 74 : mio_pool_string (&udr->name);
6104 : 74 : mio_typespec (&udr->ts);
6105 : 74 : mio_omp_udr_expr (udr, &udr->omp_out, &udr->omp_in, udr->combiner_ns, false);
6106 : 74 : if (udr->initializer_ns)
6107 : 62 : mio_omp_udr_expr (udr, &udr->omp_priv, &udr->omp_orig,
6108 : : udr->initializer_ns, true);
6109 : 74 : mio_rparen ();
6110 : : }
6111 : :
6112 : :
6113 : : static void
6114 : 8836 : write_omp_udrs (gfc_symtree *st)
6115 : : {
6116 : 8930 : if (st == NULL)
6117 : 8836 : return;
6118 : :
6119 : 94 : write_omp_udrs (st->left);
6120 : 94 : gfc_omp_udr *udr;
6121 : 188 : for (udr = st->n.omp_udr; udr; udr = udr->next)
6122 : 94 : write_omp_udr (udr);
6123 : 94 : write_omp_udrs (st->right);
6124 : : }
6125 : :
6126 : :
6127 : : /* Type for the temporary tree used when writing secondary symbols. */
6128 : :
6129 : : struct sorted_pointer_info
6130 : : {
6131 : : BBT_HEADER (sorted_pointer_info);
6132 : :
6133 : : pointer_info *p;
6134 : : };
6135 : :
6136 : : #define gfc_get_sorted_pointer_info() XCNEW (sorted_pointer_info)
6137 : :
6138 : : /* Recursively traverse the temporary tree, free its contents. */
6139 : :
6140 : : static void
6141 : 190327 : free_sorted_pointer_info_tree (sorted_pointer_info *p)
6142 : : {
6143 : 190327 : if (!p)
6144 : : return;
6145 : :
6146 : 88569 : free_sorted_pointer_info_tree (p->left);
6147 : 88569 : free_sorted_pointer_info_tree (p->right);
6148 : :
6149 : 88569 : free (p);
6150 : : }
6151 : :
6152 : : /* Comparison function for the temporary tree. */
6153 : :
6154 : : static int
6155 : 300321 : compare_sorted_pointer_info (void *_spi1, void *_spi2)
6156 : : {
6157 : 300321 : sorted_pointer_info *spi1, *spi2;
6158 : 300321 : spi1 = (sorted_pointer_info *)_spi1;
6159 : 300321 : spi2 = (sorted_pointer_info *)_spi2;
6160 : :
6161 : 300321 : if (spi1->p->integer < spi2->p->integer)
6162 : : return -1;
6163 : 168242 : if (spi1->p->integer > spi2->p->integer)
6164 : 168242 : return 1;
6165 : : return 0;
6166 : : }
6167 : :
6168 : :
6169 : : /* Finds the symbols that need to be written and collects them in the
6170 : : sorted_pi tree so that they can be traversed in an order
6171 : : independent of memory addresses. */
6172 : :
6173 : : static void
6174 : 1028082 : find_symbols_to_write(sorted_pointer_info **tree, pointer_info *p)
6175 : : {
6176 : 2034233 : if (!p)
6177 : 1028082 : return;
6178 : :
6179 : 1006151 : if (p->type == P_SYMBOL && p->u.wsym.state == NEEDS_WRITE)
6180 : : {
6181 : 88569 : sorted_pointer_info *sp = gfc_get_sorted_pointer_info();
6182 : 88569 : sp->p = p;
6183 : :
6184 : 88569 : gfc_insert_bbt (tree, sp, compare_sorted_pointer_info);
6185 : : }
6186 : :
6187 : 1006151 : find_symbols_to_write (tree, p->left);
6188 : 1006151 : find_symbols_to_write (tree, p->right);
6189 : : }
6190 : :
6191 : :
6192 : : /* Recursive function that traverses the tree of symbols that need to be
6193 : : written and writes them in order. */
6194 : :
6195 : : static void
6196 : 101758 : write_symbol1_recursion (sorted_pointer_info *sp)
6197 : : {
6198 : 190327 : if (!sp)
6199 : 101758 : return;
6200 : :
6201 : 88569 : write_symbol1_recursion (sp->left);
6202 : :
6203 : 88569 : pointer_info *p1 = sp->p;
6204 : 88569 : gcc_assert (p1->type == P_SYMBOL && p1->u.wsym.state == NEEDS_WRITE);
6205 : :
6206 : 88569 : p1->u.wsym.state = WRITTEN;
6207 : 88569 : write_symbol (p1->integer, p1->u.wsym.sym);
6208 : 88569 : p1->u.wsym.sym->attr.public_used = 1;
6209 : :
6210 : 88569 : write_symbol1_recursion (sp->right);
6211 : : }
6212 : :
6213 : :
6214 : : /* Write the secondary set of symbols to the module file. These are
6215 : : symbols that were not public yet are needed by the public symbols
6216 : : or another dependent symbol. The act of writing a symbol can add
6217 : : symbols to the pointer_info tree, so we return nonzero if a symbol
6218 : : was written and pass that information upwards. The caller will
6219 : : then call this function again until nothing was written. It uses
6220 : : the utility functions and a temporary tree to ensure a reproducible
6221 : : ordering of the symbol output and thus the module file. */
6222 : :
6223 : : static int
6224 : 21931 : write_symbol1 (pointer_info *p)
6225 : : {
6226 : 21931 : if (!p)
6227 : : return 0;
6228 : :
6229 : : /* Put symbols that need to be written into a tree sorted on the
6230 : : integer field. */
6231 : :
6232 : 21931 : sorted_pointer_info *spi_root = NULL;
6233 : 21931 : find_symbols_to_write (&spi_root, p);
6234 : :
6235 : : /* No symbols to write, return. */
6236 : 21931 : if (!spi_root)
6237 : : return 0;
6238 : :
6239 : : /* Otherwise, write and free the tree again. */
6240 : 13189 : write_symbol1_recursion (spi_root);
6241 : 13189 : free_sorted_pointer_info_tree (spi_root);
6242 : :
6243 : 13189 : return 1;
6244 : : }
6245 : :
6246 : :
6247 : : /* Write operator interfaces associated with a symbol. */
6248 : :
6249 : : static void
6250 : 149 : write_operator (gfc_user_op *uop)
6251 : : {
6252 : 149 : static char nullstring[] = "";
6253 : 149 : const char *p = nullstring;
6254 : :
6255 : 149 : if (uop->op == NULL || !check_access (uop->access, uop->ns->default_access))
6256 : 1 : return;
6257 : :
6258 : 148 : mio_symbol_interface (&uop->name, &p, &uop->op);
6259 : : }
6260 : :
6261 : :
6262 : : /* Write generic interfaces from the namespace sym_root. */
6263 : :
6264 : : static void
6265 : 140465 : write_generic (gfc_symtree *st)
6266 : : {
6267 : 272188 : gfc_symbol *sym;
6268 : :
6269 : 272188 : if (st == NULL)
6270 : 140465 : return;
6271 : :
6272 : 131723 : write_generic (st->left);
6273 : :
6274 : 131723 : sym = st->n.sym;
6275 : 131723 : if (sym && !check_unique_name (st->name)
6276 : 256377 : && sym->generic && gfc_check_symbol_access (sym))
6277 : : {
6278 : 9177 : if (!sym->module)
6279 : 6119 : sym->module = module_name;
6280 : :
6281 : 9177 : mio_symbol_interface (&st->name, &sym->module, &sym->generic);
6282 : : }
6283 : :
6284 : 131723 : write_generic (st->right);
6285 : : }
6286 : :
6287 : :
6288 : : static void
6289 : 131724 : write_symtree (gfc_symtree *st)
6290 : : {
6291 : 131724 : gfc_symbol *sym;
6292 : 131724 : pointer_info *p;
6293 : :
6294 : 131724 : sym = st->n.sym;
6295 : :
6296 : : /* A symbol in an interface body must not be visible in the
6297 : : module file. */
6298 : 131724 : if (sym->ns != gfc_current_ns
6299 : 435 : && sym->ns->proc_name
6300 : 435 : && sym->ns->proc_name->attr.if_source == IFSRC_IFBODY)
6301 : : return;
6302 : :
6303 : 131724 : if (!gfc_check_symbol_access (sym)
6304 : 131724 : || (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
6305 : 37386 : && !sym->attr.subroutine && !sym->attr.function))
6306 : : return;
6307 : :
6308 : 113802 : if (check_unique_name (st->name))
6309 : : return;
6310 : :
6311 : : /* From F2003 onwards, intrinsic procedures are no longer subject to
6312 : : the restriction, "that an elemental intrinsic function here be of
6313 : : type integer or character and each argument must be an initialization
6314 : : expr of type integer or character" is lifted so that intrinsic
6315 : : procedures can be over-ridden. This requires that the intrinsic
6316 : : symbol not appear in the module file, thereby preventing ambiguity
6317 : : when USEd. */
6318 : 107588 : if (strcmp (sym->module, "(intrinsic)") == 0
6319 : 1708 : && (gfc_option.allow_std & GFC_STD_F2003))
6320 : : return;
6321 : :
6322 : 105881 : p = find_pointer (sym);
6323 : 105881 : if (p == NULL)
6324 : 0 : gfc_internal_error ("write_symtree(): Symbol not written");
6325 : :
6326 : 105881 : mio_pool_string (&st->name);
6327 : 105881 : mio_integer (&st->ambiguous);
6328 : 105881 : mio_hwi (&p->integer);
6329 : : }
6330 : :
6331 : :
6332 : : static void
6333 : 8742 : write_module (void)
6334 : : {
6335 : 8742 : int i;
6336 : :
6337 : : /* Initialize the column counter. */
6338 : 8742 : module_column = 1;
6339 : :
6340 : : /* Write the operator interfaces. */
6341 : 8742 : mio_lparen ();
6342 : :
6343 : 262260 : for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
6344 : : {
6345 : 244776 : if (i == INTRINSIC_USER)
6346 : 8742 : continue;
6347 : :
6348 : 472068 : mio_interface (check_access (gfc_current_ns->operator_access[i],
6349 : : gfc_current_ns->default_access)
6350 : : ? &gfc_current_ns->op[i] : NULL);
6351 : : }
6352 : :
6353 : 8742 : mio_rparen ();
6354 : 8742 : write_char ('\n');
6355 : 8742 : write_char ('\n');
6356 : :
6357 : 8742 : mio_lparen ();
6358 : 8742 : gfc_traverse_user_op (gfc_current_ns, write_operator);
6359 : 8742 : mio_rparen ();
6360 : 8742 : write_char ('\n');
6361 : 8742 : write_char ('\n');
6362 : :
6363 : 8742 : mio_lparen ();
6364 : 8742 : write_generic (gfc_current_ns->sym_root);
6365 : 8742 : mio_rparen ();
6366 : 8742 : write_char ('\n');
6367 : 8742 : write_char ('\n');
6368 : :
6369 : 8742 : mio_lparen ();
6370 : 8742 : write_blank_common ();
6371 : 8742 : write_common (gfc_current_ns->common_root);
6372 : 8742 : mio_rparen ();
6373 : 8742 : write_char ('\n');
6374 : 8742 : write_char ('\n');
6375 : :
6376 : 8742 : mio_lparen ();
6377 : 8742 : write_equiv ();
6378 : 8742 : mio_rparen ();
6379 : 8742 : write_char ('\n');
6380 : 8742 : write_char ('\n');
6381 : :
6382 : 8742 : mio_lparen ();
6383 : 8742 : write_omp_udrs (gfc_current_ns->omp_udr_root);
6384 : 8742 : mio_rparen ();
6385 : 8742 : write_char ('\n');
6386 : 8742 : write_char ('\n');
6387 : :
6388 : : /* Write symbol information. First we traverse all symbols in the
6389 : : primary namespace, writing those that need to be written.
6390 : : Sometimes writing one symbol will cause another to need to be
6391 : : written. A list of these symbols ends up on the write stack, and
6392 : : we end by popping the bottom of the stack and writing the symbol
6393 : : until the stack is empty. */
6394 : :
6395 : 8742 : mio_lparen ();
6396 : :
6397 : 8742 : write_symbol0 (gfc_current_ns->sym_root);
6398 : 30673 : while (write_symbol1 (pi_root))
6399 : : /* Nothing. */;
6400 : :
6401 : 8742 : mio_rparen ();
6402 : :
6403 : 8742 : write_char ('\n');
6404 : 8742 : write_char ('\n');
6405 : :
6406 : 8742 : mio_lparen ();
6407 : 8742 : gfc_traverse_symtree (gfc_current_ns->sym_root, write_symtree);
6408 : 8742 : mio_rparen ();
6409 : 8742 : }
6410 : :
6411 : :
6412 : : /* Read a CRC32 sum from the gzip trailer of a module file. Returns
6413 : : true on success, false on failure. */
6414 : :
6415 : : static bool
6416 : 17484 : read_crc32_from_module_file (const char* filename, uLong* crc)
6417 : : {
6418 : 17484 : FILE *file;
6419 : 17484 : char buf[4];
6420 : 17484 : unsigned int val;
6421 : :
6422 : : /* Open the file in binary mode. */
6423 : 17484 : if ((file = fopen (filename, "rb")) == NULL)
6424 : : return false;
6425 : :
6426 : : /* The gzip crc32 value is found in the [END-8, END-4] bytes of the
6427 : : file. See RFC 1952. */
6428 : 8935 : if (fseek (file, -8, SEEK_END) != 0)
6429 : : {
6430 : 0 : fclose (file);
6431 : 0 : return false;
6432 : : }
6433 : :
6434 : : /* Read the CRC32. */
6435 : 8935 : if (fread (buf, 1, 4, file) != 4)
6436 : : {
6437 : 0 : fclose (file);
6438 : 0 : return false;
6439 : : }
6440 : :
6441 : : /* Close the file. */
6442 : 8935 : fclose (file);
6443 : :
6444 : 8935 : val = (buf[0] & 0xFF) + ((buf[1] & 0xFF) << 8) + ((buf[2] & 0xFF) << 16)
6445 : 8935 : + ((buf[3] & 0xFF) << 24);
6446 : 8935 : *crc = val;
6447 : :
6448 : : /* For debugging, the CRC value printed in hexadecimal should match
6449 : : the CRC printed by "zcat -l -v filename".
6450 : : printf("CRC of file %s is %x\n", filename, val); */
6451 : :
6452 : 8935 : return true;
6453 : : }
6454 : :
6455 : :
6456 : : /* Given module, dump it to disk. If there was an error while
6457 : : processing the module, dump_flag will be set to zero and we delete
6458 : : the module file, even if it was already there. */
6459 : :
6460 : : static void
6461 : 9187 : dump_module (const char *name, int dump_flag)
6462 : : {
6463 : 9187 : int n;
6464 : 9187 : char *filename, *filename_tmp;
6465 : 9187 : uLong crc, crc_old;
6466 : :
6467 : 9187 : module_name = gfc_get_string ("%s", name);
6468 : :
6469 : 9187 : if (dump_smod)
6470 : : {
6471 : 385 : name = submodule_name;
6472 : 385 : n = strlen (name) + strlen (SUBMODULE_EXTENSION) + 1;
6473 : : }
6474 : : else
6475 : 8802 : n = strlen (name) + strlen (MODULE_EXTENSION) + 1;
6476 : :
6477 : 9187 : if (gfc_option.module_dir != NULL)
6478 : : {
6479 : 0 : n += strlen (gfc_option.module_dir);
6480 : 0 : filename = (char *) alloca (n);
6481 : 0 : strcpy (filename, gfc_option.module_dir);
6482 : 0 : strcat (filename, name);
6483 : : }
6484 : : else
6485 : : {
6486 : 9187 : filename = (char *) alloca (n);
6487 : 9187 : strcpy (filename, name);
6488 : : }
6489 : :
6490 : 9187 : if (dump_smod)
6491 : 385 : strcat (filename, SUBMODULE_EXTENSION);
6492 : : else
6493 : 8802 : strcat (filename, MODULE_EXTENSION);
6494 : :
6495 : : /* Name of the temporary file used to write the module. */
6496 : 9187 : filename_tmp = (char *) alloca (n + 1);
6497 : 9187 : strcpy (filename_tmp, filename);
6498 : 9187 : strcat (filename_tmp, "0");
6499 : :
6500 : : /* There was an error while processing the module. We delete the
6501 : : module file, even if it was already there. */
6502 : 9187 : if (!dump_flag)
6503 : : {
6504 : 445 : remove (filename);
6505 : 445 : return;
6506 : : }
6507 : :
6508 : 8742 : if (gfc_cpp_makedep ())
6509 : 0 : gfc_cpp_add_target (filename);
6510 : :
6511 : : /* Write the module to the temporary file. */
6512 : 8742 : module_fp = gzopen (filename_tmp, "w");
6513 : 8742 : if (module_fp == NULL)
6514 : 0 : gfc_fatal_error ("Cannot open module file %qs for writing at %C: %s",
6515 : 0 : filename_tmp, xstrerror (errno));
6516 : :
6517 : : /* Use lbasename to ensure module files are reproducible regardless
6518 : : of the build path (see the reproducible builds project). */
6519 : 8742 : gzprintf (module_fp, "GFORTRAN module version '%s' created from %s\n",
6520 : : MOD_VERSION, lbasename (gfc_source_file));
6521 : :
6522 : : /* Write the module itself. */
6523 : 8742 : iomode = IO_OUTPUT;
6524 : :
6525 : 8742 : init_pi_tree ();
6526 : :
6527 : 8742 : write_module ();
6528 : :
6529 : 8742 : free_pi_tree (pi_root);
6530 : 8742 : pi_root = NULL;
6531 : :
6532 : 8742 : write_char ('\n');
6533 : :
6534 : 8742 : if (gzclose (module_fp))
6535 : 0 : gfc_fatal_error ("Error writing module file %qs for writing: %s",
6536 : 0 : filename_tmp, xstrerror (errno));
6537 : :
6538 : : /* Read the CRC32 from the gzip trailers of the module files and
6539 : : compare. */
6540 : 8742 : if (!read_crc32_from_module_file (filename_tmp, &crc)
6541 : 8742 : || !read_crc32_from_module_file (filename, &crc_old)
6542 : 8935 : || crc_old != crc)
6543 : : {
6544 : : /* Module file have changed, replace the old one. */
6545 : 8554 : if (remove (filename) && errno != ENOENT)
6546 : 0 : gfc_fatal_error ("Cannot delete module file %qs: %s", filename,
6547 : : xstrerror (errno));
6548 : 8554 : if (rename (filename_tmp, filename))
6549 : 0 : gfc_fatal_error ("Cannot rename module file %qs to %qs: %s",
6550 : 0 : filename_tmp, filename, xstrerror (errno));
6551 : : }
6552 : : else
6553 : : {
6554 : 188 : if (remove (filename_tmp))
6555 : 0 : gfc_fatal_error ("Cannot delete temporary module file %qs: %s",
6556 : 0 : filename_tmp, xstrerror (errno));
6557 : : }
6558 : : }
6559 : :
6560 : :
6561 : : /* Suppress the output of a .smod file by module, if no module
6562 : : procedures have been seen. */
6563 : : static bool no_module_procedures;
6564 : :
6565 : : static void
6566 : 131958 : check_for_module_procedures (gfc_symbol *sym)
6567 : : {
6568 : 131958 : if (sym && sym->attr.module_procedure)
6569 : 886 : no_module_procedures = false;
6570 : 131958 : }
6571 : :
6572 : :
6573 : : void
6574 : 8992 : gfc_dump_module (const char *name, int dump_flag)
6575 : : {
6576 : 8992 : if (gfc_state_stack->state == COMP_SUBMODULE)
6577 : 190 : dump_smod = true;
6578 : : else
6579 : 8802 : dump_smod =false;
6580 : :
6581 : 8992 : no_module_procedures = true;
6582 : 8992 : gfc_traverse_ns (gfc_current_ns, check_for_module_procedures);
6583 : :
6584 : 8992 : dump_module (name, dump_flag);
6585 : :
6586 : 8992 : if (no_module_procedures || dump_smod)
6587 : : return;
6588 : :
6589 : : /* Write a submodule file from a module. The 'dump_smod' flag switches
6590 : : off the check for PRIVATE entities. */
6591 : 195 : dump_smod = true;
6592 : 195 : submodule_name = module_name;
6593 : 195 : dump_module (name, dump_flag);
6594 : 195 : dump_smod = false;
6595 : : }
6596 : :
6597 : : static void
6598 : 18136 : create_intrinsic_function (const char *name, int id,
6599 : : const char *modname, intmod_id module,
6600 : : bool subroutine, gfc_symbol *result_type)
6601 : : {
6602 : 18136 : gfc_intrinsic_sym *isym;
6603 : 18136 : gfc_symtree *tmp_symtree;
6604 : 18136 : gfc_symbol *sym;
6605 : :
6606 : 18136 : tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
6607 : 18136 : if (tmp_symtree)
6608 : : {
6609 : 36 : if (tmp_symtree->n.sym && tmp_symtree->n.sym->module
6610 : 36 : && strcmp (modname, tmp_symtree->n.sym->module) == 0)
6611 : 36 : return;
6612 : 0 : gfc_error ("Symbol %qs at %C already declared", name);
6613 : 0 : return;
6614 : : }
6615 : :
6616 : 18100 : gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
6617 : 18100 : sym = tmp_symtree->n.sym;
6618 : :
6619 : 18100 : if (subroutine)
6620 : : {
6621 : 5811 : gfc_isym_id isym_id = gfc_isym_id_by_intmod (module, id);
6622 : 5811 : isym = gfc_intrinsic_subroutine_by_id (isym_id);
6623 : 5811 : sym->attr.subroutine = 1;
6624 : : }
6625 : : else
6626 : : {
6627 : 12289 : gfc_isym_id isym_id = gfc_isym_id_by_intmod (module, id);
6628 : 12289 : isym = gfc_intrinsic_function_by_id (isym_id);
6629 : :
6630 : 12289 : sym->attr.function = 1;
6631 : 12289 : if (result_type)
6632 : : {
6633 : 5907 : sym->ts.type = BT_DERIVED;
6634 : 5907 : sym->ts.u.derived = result_type;
6635 : 5907 : sym->ts.is_c_interop = 1;
6636 : 5907 : isym->ts.f90_type = BT_VOID;
6637 : 5907 : isym->ts.type = BT_DERIVED;
6638 : 5907 : isym->ts.f90_type = BT_VOID;
6639 : 5907 : isym->ts.u.derived = result_type;
6640 : 5907 : isym->ts.is_c_interop = 1;
6641 : : }
6642 : : }
6643 : 18100 : gcc_assert (isym);
6644 : :
6645 : 18100 : sym->attr.flavor = FL_PROCEDURE;
6646 : 18100 : sym->attr.intrinsic = 1;
6647 : :
6648 : 18100 : sym->module = gfc_get_string ("%s", modname);
6649 : 18100 : sym->attr.use_assoc = 1;
6650 : 18100 : sym->from_intmod = module;
6651 : 18100 : sym->intmod_sym_id = id;
6652 : : }
6653 : :
6654 : :
6655 : : /* Import the intrinsic ISO_C_BINDING module, generating symbols in
6656 : : the current namespace for all named constants, pointer types, and
6657 : : procedures in the module unless the only clause was used or a rename
6658 : : list was provided. */
6659 : :
6660 : : static void
6661 : 7866 : import_iso_c_binding_module (void)
6662 : : {
6663 : 7866 : gfc_symbol *mod_sym = NULL, *return_type;
6664 : 7866 : gfc_symtree *mod_symtree = NULL, *tmp_symtree;
6665 : 7866 : gfc_symtree *c_ptr = NULL, *c_funptr = NULL;
6666 : 7866 : const char *iso_c_module_name = "__iso_c_binding";
6667 : 7866 : gfc_use_rename *u;
6668 : 7866 : int i;
6669 : 7866 : bool want_c_ptr = false, want_c_funptr = false;
6670 : :
6671 : : /* Look only in the current namespace. */
6672 : 7866 : mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, iso_c_module_name);
6673 : :
6674 : 7866 : if (mod_symtree == NULL)
6675 : : {
6676 : : /* symtree doesn't already exist in current namespace. */
6677 : 7800 : gfc_get_sym_tree (iso_c_module_name, gfc_current_ns, &mod_symtree,
6678 : : false);
6679 : :
6680 : 7800 : if (mod_symtree != NULL)
6681 : 7800 : mod_sym = mod_symtree->n.sym;
6682 : : else
6683 : 0 : gfc_internal_error ("import_iso_c_binding_module(): Unable to "
6684 : : "create symbol for %s", iso_c_module_name);
6685 : :
6686 : 7800 : mod_sym->attr.flavor = FL_MODULE;
6687 : 7800 : mod_sym->attr.intrinsic = 1;
6688 : 7800 : mod_sym->module = gfc_get_string ("%s", iso_c_module_name);
6689 : 7800 : mod_sym->from_intmod = INTMOD_ISO_C_BINDING;
6690 : : }
6691 : :
6692 : : /* Check whether C_PTR or C_FUNPTR are in the include list, if so, load it;
6693 : : check also whether C_NULL_(FUN)PTR or C_(FUN)LOC are requested, which
6694 : : need C_(FUN)PTR. */
6695 : 15678 : for (u = gfc_rename_list; u; u = u->next)
6696 : : {
6697 : 7812 : if (strcmp (c_interop_kinds_table[ISOCBINDING_NULL_PTR].name,
6698 : 7812 : u->use_name) == 0)
6699 : : want_c_ptr = true;
6700 : 7760 : else if (strcmp (c_interop_kinds_table[ISOCBINDING_LOC].name,
6701 : : u->use_name) == 0)
6702 : : want_c_ptr = true;
6703 : 7638 : else if (strcmp (c_interop_kinds_table[ISOCBINDING_NULL_FUNPTR].name,
6704 : : u->use_name) == 0)
6705 : : want_c_funptr = true;
6706 : 7638 : else if (strcmp (c_interop_kinds_table[ISOCBINDING_FUNLOC].name,
6707 : : u->use_name) == 0)
6708 : : want_c_funptr = true;
6709 : 7605 : else if (strcmp (c_interop_kinds_table[ISOCBINDING_PTR].name,
6710 : : u->use_name) == 0)
6711 : : {
6712 : 1735 : c_ptr = generate_isocbinding_symbol (iso_c_module_name,
6713 : : (iso_c_binding_symbol)
6714 : : ISOCBINDING_PTR,
6715 : 1735 : u->local_name[0] ? u->local_name
6716 : : : u->use_name,
6717 : : NULL, false);
6718 : : }
6719 : 5870 : else if (strcmp (c_interop_kinds_table[ISOCBINDING_FUNPTR].name,
6720 : : u->use_name) == 0)
6721 : : {
6722 : 95 : c_funptr
6723 : 95 : = generate_isocbinding_symbol (iso_c_module_name,
6724 : : (iso_c_binding_symbol)
6725 : : ISOCBINDING_FUNPTR,
6726 : 95 : u->local_name[0] ? u->local_name
6727 : : : u->use_name,
6728 : : NULL, false);
6729 : : }
6730 : : }
6731 : :
6732 : 7866 : if ((want_c_ptr || !only_flag) && !c_ptr)
6733 : 2919 : c_ptr = generate_isocbinding_symbol (iso_c_module_name,
6734 : : (iso_c_binding_symbol)
6735 : : ISOCBINDING_PTR,
6736 : : NULL, NULL, only_flag);
6737 : 7866 : if ((want_c_funptr || !only_flag) && !c_funptr)
6738 : 2883 : c_funptr = generate_isocbinding_symbol (iso_c_module_name,
6739 : : (iso_c_binding_symbol)
6740 : : ISOCBINDING_FUNPTR,
6741 : : NULL, NULL, only_flag);
6742 : :
6743 : : /* Generate the symbols for the named constants representing
6744 : : the kinds for intrinsic data types. */
6745 : 416898 : for (i = 0; i < ISOCBINDING_NUMBER; i++)
6746 : : {
6747 : 409032 : bool found = false;
6748 : 815256 : for (u = gfc_rename_list; u; u = u->next)
6749 : 406224 : if (strcmp (c_interop_kinds_table[i].name, u->use_name) == 0)
6750 : : {
6751 : 7810 : bool not_in_std;
6752 : 7810 : const char *name;
6753 : 7810 : u->found = 1;
6754 : 7810 : found = true;
6755 : :
6756 : 7810 : switch (i)
6757 : : {
6758 : : #define NAMED_FUNCTION(a,b,c,d) \
6759 : : case a: \
6760 : : not_in_std = (gfc_option.allow_std & d) == 0; \
6761 : : name = b; \
6762 : : break;
6763 : : #define NAMED_SUBROUTINE(a,b,c,d) \
6764 : : case a: \
6765 : : not_in_std = (gfc_option.allow_std & d) == 0; \
6766 : : name = b; \
6767 : : break;
6768 : : #define NAMED_INTCST(a,b,c,d) \
6769 : : case a: \
6770 : : not_in_std = (gfc_option.allow_std & d) == 0; \
6771 : : name = b; \
6772 : : break;
6773 : : #define NAMED_REALCST(a,b,c,d) \
6774 : : case a: \
6775 : : not_in_std = (gfc_option.allow_std & d) == 0; \
6776 : : name = b; \
6777 : : break;
6778 : : #define NAMED_CMPXCST(a,b,c,d) \
6779 : : case a: \
6780 : : not_in_std = (gfc_option.allow_std & d) == 0; \
6781 : : name = b; \
6782 : : break;
6783 : : #include "iso-c-binding.def"
6784 : : default:
6785 : : not_in_std = false;
6786 : : name = "";
6787 : : }
6788 : :
6789 : 5616 : if (not_in_std)
6790 : : {
6791 : 6 : gfc_error ("The symbol %qs, referenced at %L, is not "
6792 : : "in the selected standard", name, &u->where);
6793 : 6 : continue;
6794 : : }
6795 : :
6796 : 7804 : switch (i)
6797 : : {
6798 : : #define NAMED_FUNCTION(a,b,c,d) \
6799 : : case a: \
6800 : : if (a == ISOCBINDING_LOC) \
6801 : : return_type = c_ptr->n.sym; \
6802 : : else if (a == ISOCBINDING_FUNLOC) \
6803 : : return_type = c_funptr->n.sym; \
6804 : : else \
6805 : : return_type = NULL; \
6806 : : create_intrinsic_function (u->local_name[0] \
6807 : : ? u->local_name : u->use_name, \
6808 : : a, iso_c_module_name, \
6809 : : INTMOD_ISO_C_BINDING, false, \
6810 : : return_type); \
6811 : : break;
6812 : : #define NAMED_SUBROUTINE(a,b,c,d) \
6813 : : case a: \
6814 : : create_intrinsic_function (u->local_name[0] ? u->local_name \
6815 : : : u->use_name, \
6816 : : a, iso_c_module_name, \
6817 : : INTMOD_ISO_C_BINDING, true, NULL); \
6818 : : break;
6819 : : #include "iso-c-binding.def"
6820 : :
6821 : : case ISOCBINDING_PTR:
6822 : : case ISOCBINDING_FUNPTR:
6823 : : /* Already handled above. */
6824 : : break;
6825 : 5640 : default:
6826 : 5640 : if (i == ISOCBINDING_NULL_PTR)
6827 : : tmp_symtree = c_ptr;
6828 : 5588 : else if (i == ISOCBINDING_NULL_FUNPTR)
6829 : : tmp_symtree = c_funptr;
6830 : : else
6831 : 5588 : tmp_symtree = NULL;
6832 : 5640 : generate_isocbinding_symbol (iso_c_module_name,
6833 : : (iso_c_binding_symbol) i,
6834 : 5640 : u->local_name[0]
6835 : : ? u->local_name : u->use_name,
6836 : : tmp_symtree, false);
6837 : : }
6838 : : }
6839 : :
6840 : 409032 : if (!found && !only_flag)
6841 : : {
6842 : : /* Skip, if the symbol is not in the enabled standard. */
6843 : 149823 : switch (i)
6844 : : {
6845 : : #define NAMED_FUNCTION(a,b,c,d) \
6846 : : case a: \
6847 : : if ((gfc_option.allow_std & d) == 0) \
6848 : : continue; \
6849 : : break;
6850 : : #define NAMED_SUBROUTINE(a,b,c,d) \
6851 : : case a: \
6852 : : if ((gfc_option.allow_std & d) == 0) \
6853 : : continue; \
6854 : : break;
6855 : : #define NAMED_INTCST(a,b,c,d) \
6856 : : case a: \
6857 : : if ((gfc_option.allow_std & d) == 0) \
6858 : : continue; \
6859 : : break;
6860 : : #define NAMED_REALCST(a,b,c,d) \
6861 : : case a: \
6862 : : if ((gfc_option.allow_std & d) == 0) \
6863 : : continue; \
6864 : : break;
6865 : : #define NAMED_CMPXCST(a,b,c,d) \
6866 : : case a: \
6867 : : if ((gfc_option.allow_std & d) == 0) \
6868 : : continue; \
6869 : : break;
6870 : : #include "iso-c-binding.def"
6871 : 149561 : default:
6872 : 149561 : ; /* Not GFC_STD_* versioned. */
6873 : : }
6874 : :
6875 : 149561 : switch (i)
6876 : : {
6877 : : #define NAMED_FUNCTION(a,b,c,d) \
6878 : : case a: \
6879 : : if (a == ISOCBINDING_LOC) \
6880 : : return_type = c_ptr->n.sym; \
6881 : : else if (a == ISOCBINDING_FUNLOC) \
6882 : : return_type = c_funptr->n.sym; \
6883 : : else \
6884 : : return_type = NULL; \
6885 : : create_intrinsic_function (b, a, iso_c_module_name, \
6886 : : INTMOD_ISO_C_BINDING, false, \
6887 : : return_type); \
6888 : : break;
6889 : : #define NAMED_SUBROUTINE(a,b,c,d) \
6890 : : case a: \
6891 : : create_intrinsic_function (b, a, iso_c_module_name, \
6892 : : INTMOD_ISO_C_BINDING, true, NULL); \
6893 : : break;
6894 : : #include "iso-c-binding.def"
6895 : :
6896 : : case ISOCBINDING_PTR:
6897 : : case ISOCBINDING_FUNPTR:
6898 : : /* Already handled above. */
6899 : : break;
6900 : 126547 : default:
6901 : 126547 : if (i == ISOCBINDING_NULL_PTR)
6902 : : tmp_symtree = c_ptr;
6903 : 123665 : else if (i == ISOCBINDING_NULL_FUNPTR)
6904 : : tmp_symtree = c_funptr;
6905 : : else
6906 : 120783 : tmp_symtree = NULL;
6907 : 126547 : generate_isocbinding_symbol (iso_c_module_name,
6908 : : (iso_c_binding_symbol) i, NULL,
6909 : : tmp_symtree, false);
6910 : : }
6911 : : }
6912 : : }
6913 : :
6914 : 15678 : for (u = gfc_rename_list; u; u = u->next)
6915 : : {
6916 : 7812 : if (u->found)
6917 : 7810 : continue;
6918 : :
6919 : 2 : gfc_error ("Symbol %qs referenced at %L not found in intrinsic "
6920 : 2 : "module ISO_C_BINDING", u->use_name, &u->where);
6921 : : }
6922 : 7866 : }
6923 : :
6924 : :
6925 : : /* Add an integer named constant from a given module. */
6926 : :
6927 : : static void
6928 : 6302 : create_int_parameter (const char *name, int value, const char *modname,
6929 : : intmod_id module, int id)
6930 : : {
6931 : 6302 : gfc_symtree *tmp_symtree;
6932 : 6302 : gfc_symbol *sym;
6933 : :
6934 : 6302 : tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
6935 : 6302 : if (tmp_symtree != NULL)
6936 : : {
6937 : 0 : if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
6938 : 0 : return;
6939 : : else
6940 : 0 : gfc_error ("Symbol %qs already declared", name);
6941 : : }
6942 : :
6943 : 6302 : gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
6944 : 6302 : sym = tmp_symtree->n.sym;
6945 : :
6946 : 6302 : sym->module = gfc_get_string ("%s", modname);
6947 : 6302 : sym->attr.flavor = FL_PARAMETER;
6948 : 6302 : sym->ts.type = BT_INTEGER;
6949 : 6302 : sym->ts.kind = gfc_default_integer_kind;
6950 : 6302 : sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL, value);
6951 : 6302 : sym->attr.use_assoc = 1;
6952 : 6302 : sym->from_intmod = module;
6953 : 6302 : sym->intmod_sym_id = id;
6954 : : }
6955 : :
6956 : :
6957 : : /* Value is already contained by the array constructor, but not
6958 : : yet the shape. */
6959 : :
6960 : : static void
6961 : 1092 : create_int_parameter_array (const char *name, int size, gfc_expr *value,
6962 : : const char *modname, intmod_id module, int id)
6963 : : {
6964 : 1092 : gfc_symtree *tmp_symtree;
6965 : 1092 : gfc_symbol *sym;
6966 : :
6967 : 1092 : tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
6968 : 1092 : if (tmp_symtree != NULL)
6969 : : {
6970 : 0 : if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
6971 : 0 : return;
6972 : : else
6973 : 0 : gfc_error ("Symbol %qs already declared", name);
6974 : : }
6975 : :
6976 : 1092 : gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
6977 : 1092 : sym = tmp_symtree->n.sym;
6978 : :
6979 : 1092 : sym->module = gfc_get_string ("%s", modname);
6980 : 1092 : sym->attr.flavor = FL_PARAMETER;
6981 : 1092 : sym->ts.type = BT_INTEGER;
6982 : 1092 : sym->ts.kind = gfc_default_integer_kind;
6983 : 1092 : sym->attr.use_assoc = 1;
6984 : 1092 : sym->from_intmod = module;
6985 : 1092 : sym->intmod_sym_id = id;
6986 : 1092 : sym->attr.dimension = 1;
6987 : 1092 : sym->as = gfc_get_array_spec ();
6988 : 1092 : sym->as->rank = 1;
6989 : 1092 : sym->as->type = AS_EXPLICIT;
6990 : 1092 : sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
6991 : 1092 : sym->as->upper[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, size);
6992 : :
6993 : 1092 : sym->value = value;
6994 : 1092 : sym->value->shape = gfc_get_shape (1);
6995 : 1092 : mpz_init_set_ui (sym->value->shape[0], size);
6996 : : }
6997 : :
6998 : :
6999 : : /* Add an derived type for a given module. */
7000 : :
7001 : : static void
7002 : 824 : create_derived_type (const char *name, const char *modname,
7003 : : intmod_id module, int id)
7004 : : {
7005 : 824 : gfc_symtree *tmp_symtree;
7006 : 824 : gfc_symbol *sym, *dt_sym;
7007 : 824 : gfc_interface *intr, *head;
7008 : :
7009 : 824 : tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
7010 : 824 : if (tmp_symtree != NULL)
7011 : : {
7012 : 0 : if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
7013 : 0 : return;
7014 : : else
7015 : 0 : gfc_error ("Symbol %qs already declared", name);
7016 : : }
7017 : :
7018 : 824 : gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
7019 : 824 : sym = tmp_symtree->n.sym;
7020 : 824 : sym->module = gfc_get_string ("%s", modname);
7021 : 824 : sym->from_intmod = module;
7022 : 824 : sym->intmod_sym_id = id;
7023 : 824 : sym->attr.flavor = FL_PROCEDURE;
7024 : 824 : sym->attr.function = 1;
7025 : 824 : sym->attr.generic = 1;
7026 : :
7027 : 824 : gfc_get_sym_tree (gfc_dt_upper_string (sym->name),
7028 : : gfc_current_ns, &tmp_symtree, false);
7029 : 824 : dt_sym = tmp_symtree->n.sym;
7030 : 824 : dt_sym->name = gfc_get_string ("%s", sym->name);
7031 : 824 : dt_sym->attr.flavor = FL_DERIVED;
7032 : 824 : dt_sym->attr.private_comp = 1;
7033 : 824 : dt_sym->attr.zero_comp = 1;
7034 : 824 : dt_sym->attr.use_assoc = 1;
7035 : 824 : dt_sym->module = gfc_get_string ("%s", modname);
7036 : 824 : dt_sym->from_intmod = module;
7037 : 824 : dt_sym->intmod_sym_id = id;
7038 : :
7039 : 824 : head = sym->generic;
7040 : 824 : intr = gfc_get_interface ();
7041 : 824 : intr->sym = dt_sym;
7042 : 824 : intr->where = gfc_current_locus;
7043 : 824 : intr->next = head;
7044 : 824 : sym->generic = intr;
7045 : 824 : sym->attr.if_source = IFSRC_DECL;
7046 : : }
7047 : :
7048 : :
7049 : : /* Read the contents of the module file into a temporary buffer. */
7050 : :
7051 : : static void
7052 : 11892 : read_module_to_tmpbuf ()
7053 : : {
7054 : : /* We don't know the uncompressed size, so enlarge the buffer as
7055 : : needed. */
7056 : 11892 : int cursz = 4096;
7057 : 11892 : int rsize = cursz;
7058 : 11892 : int len = 0;
7059 : :
7060 : 11892 : module_content = XNEWVEC (char, cursz);
7061 : :
7062 : 46036 : while (1)
7063 : : {
7064 : 28964 : int nread = gzread (module_fp, module_content + len, rsize);
7065 : 28964 : len += nread;
7066 : 28964 : if (nread < rsize)
7067 : : break;
7068 : 17072 : cursz *= 2;
7069 : 17072 : module_content = XRESIZEVEC (char, module_content, cursz);
7070 : 17072 : rsize = cursz - len;
7071 : 17072 : }
7072 : :
7073 : 11892 : module_content = XRESIZEVEC (char, module_content, len + 1);
7074 : 11892 : module_content[len] = '\0';
7075 : :
7076 : 11892 : module_pos = 0;
7077 : 11892 : }
7078 : :
7079 : :
7080 : : /* USE the ISO_FORTRAN_ENV intrinsic module. */
7081 : :
7082 : : static void
7083 : 445 : use_iso_fortran_env_module (void)
7084 : : {
7085 : 445 : static char mod[] = "iso_fortran_env";
7086 : 445 : gfc_use_rename *u;
7087 : 445 : gfc_symbol *mod_sym;
7088 : 445 : gfc_symtree *mod_symtree;
7089 : 445 : gfc_expr *expr;
7090 : 445 : int i, j;
7091 : :
7092 : 445 : intmod_sym symbol[] = {
7093 : : #define NAMED_INTCST(a,b,c,d) { a, b, 0, d },
7094 : : #define NAMED_KINDARRAY(a,b,c,d) { a, b, 0, d },
7095 : : #define NAMED_DERIVED_TYPE(a,b,c,d) { a, b, 0, d },
7096 : : #define NAMED_FUNCTION(a,b,c,d) { a, b, c, d },
7097 : : #define NAMED_SUBROUTINE(a,b,c,d) { a, b, c, d },
7098 : : #include "iso-fortran-env.def"
7099 : : { ISOFORTRANENV_INVALID, NULL, -1234, 0 } };
7100 : :
7101 : 445 : i = 0;
7102 : : #define NAMED_INTCST(a,b,c,d) symbol[i++].value = c;
7103 : : #include "iso-fortran-env.def"
7104 : :
7105 : : /* Generate the symbol for the module itself. */
7106 : 445 : mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, mod);
7107 : 445 : if (mod_symtree == NULL)
7108 : : {
7109 : 444 : gfc_get_sym_tree (mod, gfc_current_ns, &mod_symtree, false);
7110 : 444 : gcc_assert (mod_symtree);
7111 : 444 : mod_sym = mod_symtree->n.sym;
7112 : :
7113 : 444 : mod_sym->attr.flavor = FL_MODULE;
7114 : 444 : mod_sym->attr.intrinsic = 1;
7115 : 444 : mod_sym->module = gfc_get_string ("%s", mod);
7116 : 444 : mod_sym->from_intmod = INTMOD_ISO_FORTRAN_ENV;
7117 : : }
7118 : : else
7119 : 1 : if (!mod_symtree->n.sym->attr.intrinsic)
7120 : 1 : gfc_error ("Use of intrinsic module %qs at %C conflicts with "
7121 : : "non-intrinsic module name used previously", mod);
7122 : :
7123 : : /* Generate the symbols for the module integer named constants. */
7124 : :
7125 : 14685 : for (i = 0; symbol[i].name; i++)
7126 : : {
7127 : 14240 : bool found = false;
7128 : 24064 : for (u = gfc_rename_list; u; u = u->next)
7129 : : {
7130 : 9824 : if (strcmp (symbol[i].name, u->use_name) == 0)
7131 : : {
7132 : 307 : found = true;
7133 : 307 : u->found = 1;
7134 : :
7135 : 307 : if (!gfc_notify_std (symbol[i].standard, "The symbol %qs, "
7136 : : "referenced at %L, is not in the selected "
7137 : : "standard", symbol[i].name, &u->where))
7138 : 5 : continue;
7139 : :
7140 : 302 : if ((flag_default_integer || flag_default_real_8)
7141 : 2 : && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
7142 : 0 : gfc_warning_now (0, "Use of the NUMERIC_STORAGE_SIZE named "
7143 : : "constant from intrinsic module "
7144 : : "ISO_FORTRAN_ENV at %L is incompatible with "
7145 : : "option %qs", &u->where,
7146 : : flag_default_integer
7147 : : ? "-fdefault-integer-8"
7148 : : : "-fdefault-real-8");
7149 : 302 : switch (symbol[i].id)
7150 : : {
7151 : : #define NAMED_INTCST(a,b,c,d) \
7152 : : case a:
7153 : : #include "iso-fortran-env.def"
7154 : 219 : create_int_parameter (u->local_name[0] ? u->local_name
7155 : : : u->use_name,
7156 : : symbol[i].value, mod,
7157 : : INTMOD_ISO_FORTRAN_ENV, symbol[i].id);
7158 : 219 : break;
7159 : :
7160 : : #define NAMED_KINDARRAY(a,b,KINDS,d) \
7161 : : case a:\
7162 : : expr = gfc_get_array_expr (BT_INTEGER, \
7163 : : gfc_default_integer_kind,\
7164 : : NULL); \
7165 : : for (j = 0; KINDS[j].kind != 0; j++) \
7166 : : gfc_constructor_append_expr (&expr->value.constructor, \
7167 : : gfc_get_int_expr (gfc_default_integer_kind, NULL, \
7168 : : KINDS[j].kind), NULL); \
7169 : : create_int_parameter_array (u->local_name[0] ? u->local_name \
7170 : : : u->use_name, \
7171 : : j, expr, mod, \
7172 : : INTMOD_ISO_FORTRAN_ENV, \
7173 : : symbol[i].id); \
7174 : : break;
7175 : : #include "iso-fortran-env.def"
7176 : :
7177 : : #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
7178 : : case a:
7179 : : #include "iso-fortran-env.def"
7180 : 32 : create_derived_type (u->local_name[0] ? u->local_name
7181 : : : u->use_name,
7182 : : mod, INTMOD_ISO_FORTRAN_ENV,
7183 : : symbol[i].id);
7184 : 32 : break;
7185 : :
7186 : : #define NAMED_FUNCTION(a,b,c,d) \
7187 : : case a:
7188 : : #include "iso-fortran-env.def"
7189 : 15 : create_intrinsic_function (u->local_name[0] ? u->local_name
7190 : : : u->use_name,
7191 : : symbol[i].id, mod,
7192 : : INTMOD_ISO_FORTRAN_ENV, false,
7193 : : NULL);
7194 : 15 : break;
7195 : :
7196 : 0 : default:
7197 : 0 : gcc_unreachable ();
7198 : : }
7199 : : }
7200 : : }
7201 : :
7202 : 14240 : if (!found && !only_flag)
7203 : : {
7204 : 8529 : if ((gfc_option.allow_std & symbol[i].standard) == 0)
7205 : 71 : continue;
7206 : :
7207 : 8458 : if ((flag_default_integer || flag_default_real_8)
7208 : 0 : && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
7209 : 0 : gfc_warning_now (0,
7210 : : "Use of the NUMERIC_STORAGE_SIZE named constant "
7211 : : "from intrinsic module ISO_FORTRAN_ENV at %C is "
7212 : : "incompatible with option %s",
7213 : : flag_default_integer
7214 : : ? "-fdefault-integer-8" : "-fdefault-real-8");
7215 : :
7216 : 8458 : switch (symbol[i].id)
7217 : : {
7218 : : #define NAMED_INTCST(a,b,c,d) \
7219 : : case a:
7220 : : #include "iso-fortran-env.def"
7221 : 6083 : create_int_parameter (symbol[i].name, symbol[i].value, mod,
7222 : : INTMOD_ISO_FORTRAN_ENV, symbol[i].id);
7223 : 6083 : break;
7224 : :
7225 : : #define NAMED_KINDARRAY(a,b,KINDS,d) \
7226 : : case a:\
7227 : : expr = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, \
7228 : : NULL); \
7229 : : for (j = 0; KINDS[j].kind != 0; j++) \
7230 : : gfc_constructor_append_expr (&expr->value.constructor, \
7231 : : gfc_get_int_expr (gfc_default_integer_kind, NULL, \
7232 : : KINDS[j].kind), NULL); \
7233 : : create_int_parameter_array (symbol[i].name, j, expr, mod, \
7234 : : INTMOD_ISO_FORTRAN_ENV, symbol[i].id);\
7235 : : break;
7236 : : #include "iso-fortran-env.def"
7237 : :
7238 : : #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
7239 : : case a:
7240 : : #include "iso-fortran-env.def"
7241 : 792 : create_derived_type (symbol[i].name, mod, INTMOD_ISO_FORTRAN_ENV,
7242 : : symbol[i].id);
7243 : 792 : break;
7244 : :
7245 : : #define NAMED_FUNCTION(a,b,c,d) \
7246 : : case a:
7247 : : #include "iso-fortran-env.def"
7248 : 527 : create_intrinsic_function (symbol[i].name, symbol[i].id, mod,
7249 : : INTMOD_ISO_FORTRAN_ENV, false,
7250 : : NULL);
7251 : 527 : break;
7252 : :
7253 : 0 : default:
7254 : 0 : gcc_unreachable ();
7255 : : }
7256 : : }
7257 : : }
7258 : :
7259 : 752 : for (u = gfc_rename_list; u; u = u->next)
7260 : : {
7261 : 307 : if (u->found)
7262 : 307 : continue;
7263 : :
7264 : 0 : gfc_error ("Symbol %qs referenced at %L not found in intrinsic "
7265 : 0 : "module ISO_FORTRAN_ENV", u->use_name, &u->where);
7266 : : }
7267 : 445 : }
7268 : :
7269 : :
7270 : : /* Process a USE directive. */
7271 : :
7272 : : static void
7273 : 20206 : gfc_use_module (gfc_use_list *module)
7274 : : {
7275 : 20206 : char *filename;
7276 : 20206 : gfc_state_data *p;
7277 : 20206 : int c, line, start;
7278 : 20206 : gfc_symtree *mod_symtree;
7279 : 20206 : gfc_use_list *use_stmt;
7280 : 20206 : locus old_locus = gfc_current_locus;
7281 : :
7282 : 20206 : gfc_current_locus = module->where;
7283 : 20206 : module_name = module->module_name;
7284 : 20206 : gfc_rename_list = module->rename;
7285 : 20206 : only_flag = module->only_flag;
7286 : 20206 : current_intmod = INTMOD_NONE;
7287 : :
7288 : 20206 : if (!only_flag)
7289 : 13418 : gfc_warning_now (OPT_Wuse_without_only,
7290 : : "USE statement at %C has no ONLY qualifier");
7291 : :
7292 : 20206 : if (gfc_state_stack->state == COMP_MODULE
7293 : 17906 : || module->submodule_name == NULL)
7294 : : {
7295 : 20015 : filename = XALLOCAVEC (char, strlen (module_name)
7296 : : + strlen (MODULE_EXTENSION) + 1);
7297 : 20015 : strcpy (filename, module_name);
7298 : 20015 : strcat (filename, MODULE_EXTENSION);
7299 : : }
7300 : : else
7301 : : {
7302 : 191 : filename = XALLOCAVEC (char, strlen (module->submodule_name)
7303 : : + strlen (SUBMODULE_EXTENSION) + 1);
7304 : 191 : strcpy (filename, module->submodule_name);
7305 : 191 : strcat (filename, SUBMODULE_EXTENSION);
7306 : : }
7307 : :
7308 : : /* First, try to find an non-intrinsic module, unless the USE statement
7309 : : specified that the module is intrinsic. */
7310 : 20206 : module_fp = NULL;
7311 : 20206 : if (!module->intrinsic)
7312 : 17695 : module_fp = gzopen_included_file (filename, true, true);
7313 : :
7314 : : /* Then, see if it's an intrinsic one, unless the USE statement
7315 : : specified that the module is non-intrinsic. */
7316 : 20206 : if (module_fp == NULL && !module->non_intrinsic)
7317 : : {
7318 : 9081 : if (strcmp (module_name, "iso_fortran_env") == 0
7319 : 9081 : && gfc_notify_std (GFC_STD_F2003, "ISO_FORTRAN_ENV "
7320 : : "intrinsic module at %C"))
7321 : : {
7322 : 445 : use_iso_fortran_env_module ();
7323 : 445 : free_rename (module->rename);
7324 : 445 : module->rename = NULL;
7325 : 445 : gfc_current_locus = old_locus;
7326 : 445 : module->intrinsic = true;
7327 : 445 : return;
7328 : : }
7329 : :
7330 : 8636 : if (strcmp (module_name, "iso_c_binding") == 0
7331 : 8636 : && gfc_notify_std (GFC_STD_F2003, "ISO_C_BINDING module at %C"))
7332 : : {
7333 : 7866 : import_iso_c_binding_module();
7334 : 7866 : free_rename (module->rename);
7335 : 7866 : module->rename = NULL;
7336 : 7866 : gfc_current_locus = old_locus;
7337 : 7866 : module->intrinsic = true;
7338 : 7866 : return;
7339 : : }
7340 : :
7341 : 770 : module_fp = gzopen_intrinsic_module (filename);
7342 : :
7343 : 770 : if (module_fp == NULL && module->intrinsic)
7344 : 0 : gfc_fatal_error ("Cannot find an intrinsic module named %qs at %C",
7345 : : module_name);
7346 : :
7347 : : /* Check for the IEEE modules, so we can mark their symbols
7348 : : accordingly when we read them. */
7349 : 770 : if (strcmp (module_name, "ieee_features") == 0
7350 : 770 : && gfc_notify_std (GFC_STD_F2003, "IEEE_FEATURES module at %C"))
7351 : : {
7352 : 61 : current_intmod = INTMOD_IEEE_FEATURES;
7353 : : }
7354 : 709 : else if (strcmp (module_name, "ieee_exceptions") == 0
7355 : 709 : && gfc_notify_std (GFC_STD_F2003,
7356 : : "IEEE_EXCEPTIONS module at %C"))
7357 : : {
7358 : 60 : current_intmod = INTMOD_IEEE_EXCEPTIONS;
7359 : : }
7360 : 649 : else if (strcmp (module_name, "ieee_arithmetic") == 0
7361 : 649 : && gfc_notify_std (GFC_STD_F2003,
7362 : : "IEEE_ARITHMETIC module at %C"))
7363 : : {
7364 : 350 : current_intmod = INTMOD_IEEE_ARITHMETIC;
7365 : : }
7366 : : }
7367 : :
7368 : 11895 : if (module_fp == NULL)
7369 : : {
7370 : 3 : if (gfc_state_stack->state != COMP_SUBMODULE
7371 : 2 : && module->submodule_name == NULL)
7372 : 2 : gfc_fatal_error ("Cannot open module file %qs for reading at %C: %s",
7373 : 2 : filename, xstrerror (errno));
7374 : : else
7375 : 1 : gfc_fatal_error ("Module file %qs has not been generated, either "
7376 : : "because the module does not contain a MODULE "
7377 : : "PROCEDURE or there is an error in the module.",
7378 : : filename);
7379 : : }
7380 : :
7381 : : /* Check that we haven't already USEd an intrinsic module with the
7382 : : same name. */
7383 : :
7384 : 11892 : mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, module_name);
7385 : 11892 : if (mod_symtree && mod_symtree->n.sym->attr.intrinsic)
7386 : 1 : gfc_error ("Use of non-intrinsic module %qs at %C conflicts with "
7387 : : "intrinsic module name used previously", module_name);
7388 : :
7389 : 11892 : iomode = IO_INPUT;
7390 : 11892 : module_line = 1;
7391 : 11892 : module_column = 1;
7392 : 11892 : start = 0;
7393 : :
7394 : 11892 : read_module_to_tmpbuf ();
7395 : 11892 : gzclose (module_fp);
7396 : :
7397 : : /* Skip the first line of the module, after checking that this is
7398 : : a gfortran module file. */
7399 : 11892 : line = 0;
7400 : 443628 : while (line < 1)
7401 : : {
7402 : 419844 : c = module_char ();
7403 : 419844 : if (c == EOF)
7404 : 0 : bad_module ("Unexpected end of module");
7405 : 419844 : if (start++ < 3)
7406 : 35676 : parse_name (c);
7407 : 419844 : if ((start == 1 && strcmp (atom_name, "GFORTRAN") != 0)
7408 : 419844 : || (start == 2 && strcmp (atom_name, " module") != 0))
7409 : 0 : gfc_fatal_error ("File %qs opened at %C is not a GNU Fortran"
7410 : : " module file", module_fullpath);
7411 : 419844 : if (start == 3)
7412 : : {
7413 : 11892 : if (strcmp (atom_name, " version") != 0
7414 : 11892 : || module_char () != ' '
7415 : 11892 : || parse_atom () != ATOM_STRING
7416 : 23784 : || strcmp (atom_string, MOD_VERSION))
7417 : 0 : gfc_fatal_error ("Cannot read module file %qs opened at %C,"
7418 : : " because it was created by a different"
7419 : : " version of GNU Fortran", module_fullpath);
7420 : :
7421 : 11892 : free (atom_string);
7422 : : }
7423 : :
7424 : 419844 : if (c == '\n')
7425 : 11892 : line++;
7426 : : }
7427 : :
7428 : : /* Make sure we're not reading the same module that we may be building. */
7429 : 39587 : for (p = gfc_state_stack; p; p = p->previous)
7430 : 27695 : if ((p->state == COMP_MODULE || p->state == COMP_SUBMODULE)
7431 : 2072 : && strcmp (p->sym->name, module_name) == 0)
7432 : : {
7433 : 0 : if (p->state == COMP_SUBMODULE)
7434 : 0 : gfc_fatal_error ("Cannot USE a submodule that is currently built");
7435 : : else
7436 : 0 : gfc_fatal_error ("Cannot USE a module that is currently built");
7437 : : }
7438 : :
7439 : 11892 : init_pi_tree ();
7440 : 11892 : init_true_name_tree ();
7441 : :
7442 : 11892 : read_module ();
7443 : :
7444 : 11892 : free_true_name (true_name_root);
7445 : 11892 : true_name_root = NULL;
7446 : :
7447 : 11892 : free_pi_tree (pi_root);
7448 : 11892 : pi_root = NULL;
7449 : :
7450 : 11892 : XDELETEVEC (module_content);
7451 : 11892 : module_content = NULL;
7452 : :
7453 : 11892 : use_stmt = gfc_get_use_list ();
7454 : 11892 : *use_stmt = *module;
7455 : 11892 : use_stmt->next = gfc_current_ns->use_stmts;
7456 : 11892 : gfc_current_ns->use_stmts = use_stmt;
7457 : :
7458 : 11892 : gfc_current_locus = old_locus;
7459 : : }
7460 : :
7461 : :
7462 : : /* Remove duplicated intrinsic operators from the rename list. */
7463 : :
7464 : : static void
7465 : 20206 : rename_list_remove_duplicate (gfc_use_rename *list)
7466 : : {
7467 : 20206 : gfc_use_rename *seek, *last;
7468 : :
7469 : 31076 : for (; list; list = list->next)
7470 : 10870 : if (list->op != INTRINSIC_USER && list->op != INTRINSIC_NONE)
7471 : : {
7472 : 107 : last = list;
7473 : 453 : for (seek = list->next; seek; seek = last->next)
7474 : : {
7475 : 346 : if (list->op == seek->op)
7476 : : {
7477 : 2 : last->next = seek->next;
7478 : 2 : free (seek);
7479 : : }
7480 : : else
7481 : : last = seek;
7482 : : }
7483 : : }
7484 : 20206 : }
7485 : :
7486 : :
7487 : : /* Process all USE directives. */
7488 : :
7489 : : void
7490 : 17439 : gfc_use_modules (void)
7491 : : {
7492 : 17439 : gfc_use_list *next, *seek, *last;
7493 : :
7494 : 37645 : for (next = module_list; next; next = next->next)
7495 : : {
7496 : 20206 : bool non_intrinsic = next->non_intrinsic;
7497 : 20206 : bool intrinsic = next->intrinsic;
7498 : 20206 : bool neither = !non_intrinsic && !intrinsic;
7499 : :
7500 : 23758 : for (seek = next->next; seek; seek = seek->next)
7501 : : {
7502 : 3552 : if (next->module_name != seek->module_name)
7503 : 3356 : continue;
7504 : :
7505 : 196 : if (seek->non_intrinsic)
7506 : : non_intrinsic = true;
7507 : 195 : else if (seek->intrinsic)
7508 : : intrinsic = true;
7509 : : else
7510 : 155 : neither = true;
7511 : : }
7512 : :
7513 : 20206 : if (intrinsic && neither && !non_intrinsic)
7514 : : {
7515 : 1 : char *filename;
7516 : 1 : FILE *fp;
7517 : :
7518 : 1 : filename = XALLOCAVEC (char,
7519 : : strlen (next->module_name)
7520 : : + strlen (MODULE_EXTENSION) + 1);
7521 : 1 : strcpy (filename, next->module_name);
7522 : 1 : strcat (filename, MODULE_EXTENSION);
7523 : 1 : fp = gfc_open_included_file (filename, true, true);
7524 : 1 : if (fp != NULL)
7525 : : {
7526 : 0 : non_intrinsic = true;
7527 : 0 : fclose (fp);
7528 : : }
7529 : : }
7530 : :
7531 : 20206 : last = next;
7532 : 23758 : for (seek = next->next; seek; seek = last->next)
7533 : : {
7534 : 3552 : if (next->module_name != seek->module_name)
7535 : : {
7536 : 3356 : last = seek;
7537 : 3356 : continue;
7538 : : }
7539 : :
7540 : 196 : if ((!next->intrinsic && !seek->intrinsic)
7541 : 41 : || (next->intrinsic && seek->intrinsic)
7542 : 3 : || !non_intrinsic)
7543 : : {
7544 : 194 : if (!seek->only_flag)
7545 : 33 : next->only_flag = false;
7546 : 194 : if (seek->rename)
7547 : : {
7548 : : gfc_use_rename *r = seek->rename;
7549 : 321 : while (r->next)
7550 : : r = r->next;
7551 : 174 : r->next = next->rename;
7552 : 174 : next->rename = seek->rename;
7553 : : }
7554 : 194 : last->next = seek->next;
7555 : 194 : free (seek);
7556 : 194 : }
7557 : : else
7558 : : last = seek;
7559 : : }
7560 : : }
7561 : :
7562 : 37642 : for (; module_list; module_list = next)
7563 : : {
7564 : 20206 : next = module_list->next;
7565 : 20206 : rename_list_remove_duplicate (module_list->rename);
7566 : 20206 : gfc_use_module (module_list);
7567 : 20203 : free (module_list);
7568 : : }
7569 : 17436 : module_list = NULL;
7570 : 17436 : old_module_list_tail = &module_list;
7571 : 17436 : gfc_rename_list = NULL;
7572 : 17436 : }
7573 : :
7574 : :
7575 : : void
7576 : 7910344 : gfc_free_use_stmts (gfc_use_list *use_stmts)
7577 : : {
7578 : 7910344 : gfc_use_list *next;
7579 : 7922241 : for (; use_stmts; use_stmts = next)
7580 : : {
7581 : : gfc_use_rename *next_rename;
7582 : :
7583 : 14648 : for (; use_stmts->rename; use_stmts->rename = next_rename)
7584 : : {
7585 : 2751 : next_rename = use_stmts->rename->next;
7586 : 2751 : free (use_stmts->rename);
7587 : : }
7588 : 11897 : next = use_stmts->next;
7589 : 11897 : free (use_stmts);
7590 : : }
7591 : 7910344 : }
7592 : :
7593 : :
7594 : : /* Remember the end of the MODULE_LIST list, so that the list can be restored
7595 : : to its previous state if the current statement is erroneous. */
7596 : :
7597 : : void
7598 : 1180864 : gfc_save_module_list ()
7599 : : {
7600 : 1180864 : gfc_use_list **tail = &module_list;
7601 : 1206616 : while (*tail != NULL)
7602 : 25752 : tail = &(*tail)->next;
7603 : 1180864 : old_module_list_tail = tail;
7604 : 1180864 : }
7605 : :
7606 : :
7607 : : /* Restore the MODULE_LIST list to its previous value and free the use
7608 : : statements that are no longer part of the list. */
7609 : :
7610 : : void
7611 : 7468108 : gfc_restore_old_module_list ()
7612 : : {
7613 : 7468108 : gfc_free_use_stmts (*old_module_list_tail);
7614 : 7468108 : *old_module_list_tail = NULL;
7615 : 7468108 : }
7616 : :
7617 : :
7618 : : void
7619 : 75305 : gfc_module_init_2 (void)
7620 : : {
7621 : 75305 : last_atom = ATOM_LPAREN;
7622 : 75305 : gfc_rename_list = NULL;
7623 : 75305 : module_list = NULL;
7624 : 75305 : }
7625 : :
7626 : :
7627 : : void
7628 : 75602 : gfc_module_done_2 (void)
7629 : : {
7630 : 75602 : free_rename (gfc_rename_list);
7631 : 75602 : gfc_rename_list = NULL;
7632 : 75602 : }
|