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