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