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