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