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