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