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