Bug Summary

File:build/gcc/fortran/module.cc
Warning:line 862, column 25
The left operand of '&' is a garbage value

Annotated Source Code

Press '?' to see keyboard shortcuts

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