1 /*
2 * Copyright (c) 1995-2019, NVIDIA CORPORATION. All rights reserved.
3 *
4 * Licensed under the Apache License, Version 2.0 (the "License");
5 * you may not use this file except in compliance with the License.
6 * You may obtain a copy of the License at
7 *
8 * http://www.apache.org/licenses/LICENSE-2.0
9 *
10 * Unless required by applicable law or agreed to in writing, software
11 * distributed under the License is distributed on an "AS IS" BASIS,
12 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13 * See the License for the specific language governing permissions and
14 * limitations under the License.
15 *
16 */
17
18 /**
19 \file interf.c
20 \brief Routines for importing symbols from .mod files and from IPA.
21 */
22
23 #include "gbldefs.h"
24 #include "global.h"
25 #include "error.h"
26 #include "symtab.h"
27 #include "dtypeutl.h"
28 #include "machar.h"
29 #include "semant.h"
30 #include "ast.h"
31 #include "dinit.h"
32 #include "soc.h"
33 #include "state.h"
34 #include "lz.h"
35 #include "rtlRtns.h"
36
37 #define INSIDE_INTERF
38 #define INTERFH_RCSID
39 #include "interf.h"
40
41 #define TRACEFLAG 48
42 #define TRACEBIT 1
43 #define TRACESTRING "interf-"
44 #include "trace.h"
45 #include "fih.h"
46 #include "symutl.h"
47 #include "lower.h"
48 #include "extern.h"
49
50 /* true, if reading in a module file for a 'contained' subprogram. */
51 static LOGICAL inmodulecontains = FALSE;
52
53 static int for_module = 0;
54 static LOGICAL for_inliner = FALSE;
55 static LOGICAL for_interproc = FALSE;
56 static LOGICAL for_static = FALSE;
57 static LOGICAL for_host = FALSE;
58 static LOGICAL old_astversion = FALSE;
59 static int top_scope_level = 0;
60
61 static int import_errno = 0;
62 static int import_osym = 0;
63
64 static void put_dinit_record(int, INT);
65 static void put_data_statement(int, int, int, lzhandle *, char *, int);
66 static int import_mk_newsym(char *name, int stype);
67
68 static int BASEsym, BASEast, BASEdty, BASEmod, ADJmod;
69 static int HOST_OLDSCOPE = 0, HOST_NEWSCOPE = 0;
70
71 static char **modinclist = NULL;
72 static int modinclistsize = 0, modinclistavl = 0;
73
74 #define MAX_FNAME_LEN 258
75 #define MOD_SUFFIX ".mod"
76
77 /** \brief 'interface' initialization, called once per compilation
78 * (source file).
79 */
80 void
interf_init()81 interf_init()
82 {
83 #if DEBUG
84 assert(sizeof(SYM) / sizeof(INT) == 44, "bad SYM size",
85 sizeof(SYM) / sizeof(INT), 4);
86 assert(sizeof(AST) / sizeof(int) == 19, "interf_init:inconsistent AST size",
87 sizeof(AST) / sizeof(int), 2);
88 #endif
89 }
90
91 /* ------------------------------------------------------------------ */
92 /* ----------------------- Import Utilities ------------------------- */
93 /* ------------------------------------------------------------------ */
94
95 /* ------------------------------------------------------------------ */
96 /* Read symbols from export file */
97 /* This is used for:
98 * module interface files
99 * interprocedural analysis
100 * procedure inlining
101 * static variable initialization
102 */
103
104 /* getitem area for module temp storage; pick an area not used by
105 * the caller of export/import.
106 */
107 #define MOD_AREA 18
108 #define PERM_AREA 8
109 #define MOD_USE_AREA 4
110
111 /* ------------------------------------------------------------------ */
112 /* ----------------------- Import Utilities ------------------------- */
113 /* ------------------------------------------------------------------ */
114
115 /* ----------------------------------------------------------- */
116
117 typedef struct { /* info on data type read from encoded file */
118 int id; /* number of this dtype when mod file created */
119 int ty; /* type of dtype, TY_PTR, etc. */
120 int new_id; /* dtype number for this compilation */
121 LOGICAL dtypeinstalled; /* set if dtype complete */
122 int hashnext; /* in hash table linked list */
123 } DITEM;
124
125 typedef struct symitem {/* info on symbol read from encoded mod file */
126 int sptr; /* symbol table pointer when mod file created */
127 int stype; /* STYPE(sptr) */
128 int sc;
129 int dtype; /* (old) pointer to dtype */
130 int ty; /* TY_ value of dtype (constants only) */
131 /* used to stash namelist pointer also */
132 int symlk;
133 int flags1, flags2, flags3, flags4;
134 int new_sptr; /* symbol table pointer for this compilation */
135 SYM sym;
136 char name[MAXIDLEN + 1]; /* symbol name (only certain stypes) */
137 char *strptr; /* pointer to char string (constant) */
138 struct symitem *next;
139 struct symitem *hashnext; /* next item from hash table */
140 int socptr; /* overlap region pointer */
141 int shadowptr; /* new shadow region pointer */
142 } SYMITEM;
143
144 typedef struct alnitem {/* info on align descriptor from encoded file */
145 int aln; /* pointer when descriptor exported */
146 int new_aln; /* pointer after import */
147 int r_target;
148 int r_alignee;
149 LOGICAL aligninstalled; /* if set, descriptor has been installed */
150 struct alnitem *next;
151 } ALNITEM;
152
153 typedef struct dstitem {/* info on distribute descr from encoded file */
154 int dst; /* pointer when descriptor exported */
155 int new_dst; /* pointer after import */
156 int rank;
157 LOGICAL distinstalled; /* if set, descriptor has been installed */
158 struct dstitem *next;
159 } DSTITEM;
160
161 typedef struct {/* info on ast read from mod file */
162 int type; /* A_TYPE(ast) */
163 AST a; /* AST data */
164 int new_ast, old_ast;
165 int link; /* link to next ast in hash table */
166 int list, flags, shape;
167 } ASTITEM;
168
169 typedef struct {/* info on STDs read from file */
170 int old; /* old STD index */
171 int ast;
172 int label;
173 int lineno;
174 int findex;
175 int flags;
176 int new; /* new STD index */
177 } STDITEM;
178
179 typedef struct {/* info on a shd item read from file */
180 int old; /* old shd index */
181 int new; /* new shd index */
182 int ndim; /* number of dimensions */
183 struct { /* for each dimension lwb:upb:stride */
184 int lwb;
185 int upb;
186 int stride;
187 } shp[7];
188 } SHDITEM;
189
190 typedef struct { /* info on argt item read from file */
191 int old; /* old argt index */
192 int callfg; /* 1 if any args has call flag set */
193 int new; /* new argt index */
194 LOGICAL installed; /* this entry has been processed */
195 } ARGTITEM;
196
197 typedef struct { /* info on ASD item read from file */
198 int old; /* old asd index */
199 LOGICAL installed; /* this entry has been processed */
200 int ndim; /* number of dimensions */
201 int subs[7]; /* subscripts */
202 } ASDITEM;
203
204 typedef struct { /* info on astli list read file */
205 int new; /* new astli index */
206 LOGICAL installed; /* this entry has been processed */
207 } ASTLIITEM;
208
209 typedef struct {/* module procedure record */
210 int modp; /* old sym pointer of module procedure */
211 int syml; /* symitem list of generics/operators */
212 } MODPITEM;
213
214 static struct {/* table of dtypes read from mod file */
215 DITEM *base;
216 int avl;
217 int sz;
218 } dtz;
219
220 static struct {/* table of formal arguments */
221 int *base;
222 int avl;
223 int sz;
224 } flz;
225
226 static struct {/* table of overloaded functions */
227 int *base;
228 int avl;
229 int sz;
230 } ovz;
231
232 static struct {/* table of derived mangled symbols */
233 int *base;
234 int avl;
235 int sz;
236 } mdz;
237 #define MN_NENTRIES 2
238
239 static struct { /* table of asts read from mod file */
240 ASTITEM *base; /* NOTE: index of ASTITEM + firstuast == ast index */
241 int avl;
242 int sz;
243 } astz;
244
245 /* hash size is 1024 entries = 2^10, so HASHMASK has 10 lower-order bits on */
246 #define ASTZHASHSIZE 1024
247 #define ASTZHASHMASK 0x03ff
248 static int astzhash[ASTZHASHSIZE];
249
250 static struct {/* table of stds read from file */
251 STDITEM *base;
252 int avl;
253 int sz;
254 } stdz;
255
256 static struct {/* table of shds read from file */
257 SHDITEM *base;
258 int avl;
259 int sz;
260 } shdz;
261
262 static struct {/* table of argts read from file */
263 ARGTITEM *base;
264 int avl;
265 int sz;
266 } argtz;
267
268 static struct {/* table of asds read from file */
269 ASDITEM *base;
270 int avl;
271 int sz;
272 } asdz;
273
274 static struct {/* table of astlis read from file */
275 ASTLIITEM *base;
276 int avl;
277 int sz;
278 } astliz;
279
280 static struct {/* table of module procedure records read */
281 MODPITEM *base;
282 int avl;
283 int sz;
284 } modpz;
285
286 static SYMITEM *symbol_list; /* list of symbols read from mod file */
287 static ALNITEM *align_list; /* list of align descrs read from mod file */
288 static DSTITEM *dist_list; /* list of dist descrs read from mod file */
289
290 #define SYMHASHSIZE 521
291 static SYMITEM *symhash[SYMHASHSIZE];
292 #define DTHASHSIZE 521
293 static int dthash[DTHASHSIZE];
294
295 #define BUFF_LEN 4096
296 static char *buff = NULL;
297 static int buff_sz;
298 static char *currp;
299 static char import_name[MAXIDLEN + 1];
300
301 static int curr_platform = MOD_ANY;
302
303 static char *import_sourcename = NULL;
304 static int import_sourcename_len = 0;
305 static LOGICAL ignore_private = FALSE;
306 static int curr_import_findex = 0;
307 static int top_import_findex = 0;
308
309 static char *read_line(FILE *);
310 static ISZ_T get_num(int);
311 static void get_string(char *);
312 static void get_nstring(char *, int);
313
314 static void new_dtypes(void);
315 static int dtype_ivsn = 0;
316 static int new_dtype(int);
317
318 static void new_asts(void);
319 static int new_ast(int);
320 static void new_stds(void);
321 static int new_std(int);
322 static int new_argt(int);
323 static int new_asd(int);
324 static int new_astli(int, int);
325 static int new_shape(int);
326
327 static int new_symbol(int);
328 static int new_symbol_if_module(int old_sptr);
329 static void new_symbol_and_link(int, int *, SYMITEM **);
330 static void fill_links_symbol(SYMITEM *, WantPrivates);
331 static int can_find_symbol(int);
332 static int can_find_dtype(int);
333 static SYMITEM *find_symbol(int);
334 static int common_conflict(void);
335 static int install_common(SYMITEM *, int);
336 static LOGICAL common_mem_eq(int, int);
337 static int new_installed_dtype(int old_dt);
338 static DITEM * finddthash(int old_dt);
339
340 static char *import_file_name;
341 static void import_constant(SYMITEM *ps);
342 static void import_symbol(SYMITEM *ps);
343 static void import_ptr_constant(SYMITEM *ps);
344 static void import(lzhandle *fdlz, WantPrivates, int ivsn);
345 static int import_skip_use_stmts(lzhandle *fdlz);
346 static void import_done(lzhandle *, int nested);
347 static lzhandle *import_header_only(FILE *fd, char *file_name,
348 int import_which, int* ivsn_return);
349 static void get_component_init(lzhandle *, char *, char *, int);
350
351 struct imported_modules_struct imported_modules = {NULL, 0, 0, 0, 0};
352
353 /** \brief Initialize import of module symbols, etc. */
354 void
import_init(void)355 import_init(void)
356 {
357 imported_modules.avail = 0;
358 if (imported_modules.size == 0) {
359 imported_modules.size = 10;
360 NEW(imported_modules.list, IMPORT_LIST, imported_modules.size);
361 }
362 exterf_init();
363 } /* import_init */
364
365 /** \brief Wrap-up module symbol import phase */
366 void
import_fini(void)367 import_fini(void)
368 {
369 FREE(imported_modules.list);
370 imported_modules.avail = 0;
371 imported_modules.size = 0;
372 } /* import_fini */
373
374 static void
add_imported(int modulesym)375 add_imported(int modulesym)
376 {
377 int il;
378 char *modulename;
379
380 modulename = SYMNAME(modulesym);
381 Trace(("add %s to imported module list", modulename));
382 il = imported_modules.avail++;
383 NEED(il + 1, imported_modules.list, IMPORT_LIST, imported_modules.size,
384 imported_modules.size + 10);
385 imported_modules.list[il].modulesym = modulesym;
386 imported_modules.list[il].modulename =
387 (char *)getitem(PERM_AREA, strlen(modulename) + 1);
388 strcpy(imported_modules.list[il].modulename, modulename);
389 } /* add_imported */
390
391 #undef READ_LINE
392 #define READ_LINE p = read_line(fd)
393 #define READ_LZLINE currp = p = ulz(fdlz)
394
395 static char *import_corrupt_msg;
396 static char *import_oldfile_msg;
397 static char *import_incompatible_msg;
398
399 #define IMPORT_WHICH_PRELINK -1
400 #define IMPORT_WHICH_IPA -2
401 #define IMPORT_WHICH_INLINE -3
402 #define IMPORT_WHICH_HOST -4
403 #define IMPORT_WHICH_NESTED -5
404
405 static void
set_message(int import_which,char * file_name)406 set_message(int import_which, char *file_name)
407 {
408 import_file_name = file_name;
409 switch (import_which) {
410 case IMPORT_WHICH_PRELINK:
411 for_static = TRUE;
412 import_corrupt_msg = "Corrupt Prelink file";
413 import_oldfile_msg = "Corrupt Prelink file";
414 import_incompatible_msg = "Corrupt Prelink file";
415 break;
416 case IMPORT_WHICH_IPA:
417 for_interproc = TRUE;
418 import_corrupt_msg = "Corrupt or Old IPA file";
419 import_oldfile_msg = "Old IPA file";
420 import_incompatible_msg = "Incompatible or Old IPA file";
421 break;
422 case IMPORT_WHICH_INLINE:
423 for_inliner = TRUE;
424 import_corrupt_msg = "Corrupt or Old Inline file";
425 import_oldfile_msg = "Old Inline file";
426 import_incompatible_msg = "Incompatible or Old Inline file";
427 break;
428 case IMPORT_WHICH_HOST:
429 for_host = 1;
430 import_corrupt_msg = "Corrupt";
431 import_oldfile_msg = "Corrupt";
432 import_incompatible_msg = "Corrupt";
433 break;
434 default: /* must be for a module */
435 for_module = import_which;
436 import_corrupt_msg = "Corrupt or Old Module file";
437 import_oldfile_msg = "Old Module file";
438 import_incompatible_msg = "Incompatible Module file";
439 }
440 } /* set_message */
441
442 /**
443 * The USE processing builds a 'use-graph'; each module that is directly or
444 * indirectly used is a node in the graph, with an edge to all the modules used
445 * by that node. If a module is used publicly and privately, or used with
446 * different 'except' lists, each is a different node in the graph. The USE
447 * graph must be acyclic (this is checked). Each module file is read in once
448 * for each node in the graph (this could be optimized with some work to be once
449 * for each module, but we expect the effect to be small). A depth-first
450 * traversal of the graph gives a topological order of the nodes, giving a legal
451 * order in which to import the USES_LIST is the list of modules used by this
452 * module
453 */
454 typedef struct uses_list {
455 struct uses_list *next;
456 struct to_be_imported *use_module;
457 int directlyused;
458 } USES_LIST;
459
460 typedef struct to_be_imported {
461 struct to_be_imported *prev; /* used only by the to_be_used_list_head list */
462 struct to_be_imported *next; /* used only by the to_be_used_list_head list */
463 struct to_be_imported
464 *order; /* used only by the to_be_used_list_order_head list */
465 USES_LIST *uses;
466 LOGICAL public;
467 int exceptlist;
468 char *modulename;
469 char *modulefilename;
470 char *fullfilename;
471 LOGICAL visited;
472 int sl;
473 } TOBE_IMPORTED_LIST;
474
475 static TOBE_IMPORTED_LIST *to_be_used_list_head, *to_be_used_list_tail;
476 static TOBE_IMPORTED_LIST *to_be_used_list_order_head,
477 *to_be_used_list_order_tail;
478 static USES_LIST *use_tree = NULL, /* this list is the root of the use_tree */
479 *use_tree_end = NULL;
480
481 static int import_use_stmts(lzhandle *fdlz, TOBE_IMPORTED_LIST *, char *, int,
482 int);
483 static int get_module_file_name_from_user(TOBE_IMPORTED_LIST *il,
484 char *from_file_name);
485
486 static void
dump_list_node(USES_LIST * node,int indent)487 dump_list_node(USES_LIST *node, int indent)
488 {
489 int i;
490 USES_LIST *n;
491
492 for (n = node; n; n = n->next) {
493 if (!n->directlyused) {
494 continue;
495 }
496 for (i = indent; i; i--)
497 printf(" ");
498 printf("module %s[%p]: exceptlist %d, sl %d", n->use_module->modulename,
499 n->use_module, n->use_module->exceptlist, n->use_module->sl);
500 if (n->use_module->public && n->use_module->uses) {
501 printf(", uses:\n");
502 dump_list_node(n->use_module->uses, indent + 1);
503 } else {
504 printf(":\n");
505 }
506 }
507 }
508
509 void
dump_use_tree(void)510 dump_use_tree(void)
511 {
512 if (use_tree) {
513 printf("USE TREE:\n");
514 dump_list_node(use_tree, 1);
515 }
516 }
517
518 void
init_use_tree(void)519 init_use_tree(void)
520 {
521 use_tree = use_tree_end = 0;
522 }
523
524 static TOBE_IMPORTED_LIST *
already_to_be_used(char * modulename,int public,int except)525 already_to_be_used(char *modulename, int public, int except)
526 {
527 TOBE_IMPORTED_LIST *il;
528 for (il = to_be_used_list_head; il; il = il->next) {
529 if (il->public == public && strcmp(modulename, il->modulename) == 0) {
530 if (except == 0 && il->exceptlist == 0) {
531 return il;
532 } else if (except != 0 && il->exceptlist != 0) {
533 if (same_sym_list(except, il->exceptlist)) {
534 return il;
535 }
536 }
537 }
538 }
539 return NULL;
540 } /* already_to_be_used */
541
542 /** \brief Clear visited nodes in the module use_tree.
543 *
544 * Intended to operate on the use_tree only. Does not follow indirect links
545 * nor does it recurse through private modules uses.
546 */
547 static void
clear_list_nodes_visited(USES_LIST * list)548 clear_list_nodes_visited(USES_LIST *list)
549 {
550 USES_LIST *l;
551 for (l = list; l; l = l->next) {
552 if (!l->directlyused) {
553 continue;
554 }
555 l->use_module->visited = 0;
556 if (l->use_module->public && l->use_module->uses) {
557 clear_list_nodes_visited(l->use_module->uses);
558 }
559 }
560 }
561
562 static USES_LIST *
find_next_modname_in_list(char * name,USES_LIST * list)563 find_next_modname_in_list(char *name, USES_LIST *list)
564 {
565 USES_LIST *l;
566
567 for (l = list; l; l = l->next) {
568 if (strcmp(l->use_module->modulename, name) == 0) {
569 return l;
570 }
571 }
572 return NULL;
573 }
574
575 /** \brief Search list on name (only)
576 *
577 * Use ONLY if it is guaranteed that the module can be on the list only once or
578 * the first item on the list is the desired item.
579 */
580 static TOBE_IMPORTED_LIST *
find_modname_in_list(char * name,USES_LIST * list)581 find_modname_in_list(char *name, USES_LIST *list)
582 {
583 USES_LIST *l;
584
585 for (l = list; l; l = l->next) {
586 if (l->use_module->public && strcmp(l->use_module->modulename, name) == 0) {
587 return l->use_module;
588 }
589 }
590 return NULL;
591 }
592
593 /** \brief Search list for use node using name and exception list */
594 static TOBE_IMPORTED_LIST *
find_use_node_in_list(char * name,int exception,USES_LIST * ul)595 find_use_node_in_list(char *name, int exception, USES_LIST *ul)
596 {
597 USES_LIST *mun;
598
599 for (mun = ul; mun; mun = mun->next) {
600 if (mun->use_module->public &&
601 strcmp(mun->use_module->modulename, name) == 0 &&
602 (mun->use_module->exceptlist == exception ||
603 same_sym_list(mun->use_module->exceptlist, exception))) {
604 break;
605 }
606 }
607 return (mun ? mun->use_module : NULL);
608 }
609
610 LOGICAL
imported_directly(char * name,int except)611 imported_directly(char *name, int except)
612 {
613
614 return (find_use_node_in_list(name, except, use_tree) != NULL);
615 }
616
617 /** \brief Add a TOBE_IMPORTED_LIST item to the end of the use_tree list */
618 static void
add_to_use_tree(TOBE_IMPORTED_LIST * um)619 add_to_use_tree(TOBE_IMPORTED_LIST *um)
620 {
621 USES_LIST *ul = (USES_LIST *)getitem(MOD_USE_AREA, sizeof(USES_LIST));
622 ul->use_module = um;
623 ul->directlyused = 1;
624 ul->next = NULL;
625
626 if (!use_tree) {
627 use_tree = ul;
628 } else {
629 use_tree_end->next = ul;
630 }
631 use_tree_end = ul;
632 }
633
634 /** \brief Create and insert a TOBE_IMPORTED_LIST item into the beginning of
635 * the use_tree
636 */
637 static TOBE_IMPORTED_LIST *
insert_node_into_use_tree(char * modulename)638 insert_node_into_use_tree(char *modulename)
639 {
640 TOBE_IMPORTED_LIST *il;
641 USES_LIST *ul;
642
643 #if DEBUG
644 if (DBGBIT(0, 0x10000))
645 fprintf(gbl.dbgfil, "add_node_to_use_tree( %s )\n", modulename);
646 #endif
647
648 ul = (USES_LIST *)getitem(MOD_USE_AREA, sizeof(USES_LIST));
649 if (!use_tree) {
650 use_tree = ul;
651 use_tree->next = NULL;
652 use_tree_end = ul;
653 } else {
654 ul->next = use_tree;
655 }
656 use_tree = ul;
657 ul->directlyused = 1;
658
659 il = (TOBE_IMPORTED_LIST *)getitem(MOD_USE_AREA, sizeof(TOBE_IMPORTED_LIST));
660 ul->use_module = il;
661
662 il->prev = NULL;
663 il->next = NULL;
664 il->uses = NULL;
665 il->order = NULL;
666 il->public = 1;
667 il->exceptlist = 0; /* will be set after "apply_use" rename processing */
668 il->visited = FALSE; /* initialize for depth-first search */
669 il->modulename = (char *)getitem(MOD_USE_AREA, strlen(modulename) + 1);
670 strcpy(il->modulename, modulename);
671 il->modulefilename = NULL;
672 il->fullfilename = NULL;
673 il->sl = 0;
674
675 return il;
676 }
677
678 /** \brief Add il into curr_use_list after *curr_use_list item */
679 static USES_LIST **
add_use_tree_uses(USES_LIST ** curr_use_list,TOBE_IMPORTED_LIST * il)680 add_use_tree_uses(USES_LIST **curr_use_list, TOBE_IMPORTED_LIST *il)
681 {
682 USES_LIST *ul = (USES_LIST *)getitem(MOD_USE_AREA, sizeof(USES_LIST));
683 USES_LIST *tmp;
684
685 ul->directlyused = 1;
686 if (!*curr_use_list) {
687 *curr_use_list = ul;
688 ul->next = NULL;
689 } else {
690 tmp = (*curr_use_list)->next;
691 ul->next = tmp;
692 (*curr_use_list)->next = ul;
693 }
694 ul->use_module = il;
695 return &(ul->next);
696 }
697
698 static TOBE_IMPORTED_LIST *
add_to_be_used_list(char * modulename,int public,int except,TOBE_IMPORTED_LIST * ilfrom,char * from_file_name)699 add_to_be_used_list(char *modulename, int public, int except,
700 TOBE_IMPORTED_LIST *ilfrom, char *from_file_name)
701 {
702 TOBE_IMPORTED_LIST *il;
703 il = already_to_be_used(modulename, public, except);
704 if (il)
705 return il;
706 #if DEBUG
707 if (DBGBIT(0, 0x10000))
708 fprintf(gbl.dbgfil, "add_to_be_used_list( %s, %d )\n", modulename, public);
709 #endif
710 il = (TOBE_IMPORTED_LIST *)getitem(MOD_USE_AREA, sizeof(TOBE_IMPORTED_LIST));
711 il->prev = to_be_used_list_tail;
712 il->next = NULL;
713 il->uses = NULL;
714 il->order = NULL;
715 il->public = public; /* save 'public' bit here */
716 il->exceptlist = except;
717 il->visited = FALSE;
718 il->sl = 0;
719 il->modulename = (char *)getitem(MOD_USE_AREA, strlen(modulename) + 1);
720 strcpy(il->modulename, modulename);
721 if (from_file_name) {
722 il->modulefilename = (char *)getitem(
723 MOD_USE_AREA, strlen(il->modulename) + strlen(MOD_SUFFIX) + 1);
724 il->fullfilename = (char *)getitem(MOD_USE_AREA, MAX_FNAME_LEN + 1);
725 strcpy(il->modulefilename, il->modulename);
726 convert_2dollar_signs_to_hyphen(il->modulefilename);
727 strcat(il->modulefilename, MOD_SUFFIX);
728 if (!get_module_file_name_from_user(il, from_file_name)) {
729 if (!get_module_file_name(il->modulefilename, il->fullfilename,
730 MAX_FNAME_LEN)) {
731 error(4, 0, gbl.lineno, "Unable to open MODULE file",
732 il->modulefilename);
733 return NULL;
734 }
735 }
736 }
737 if (to_be_used_list_tail == NULL) {
738 to_be_used_list_head = il;
739 } else {
740 to_be_used_list_tail->next = il;
741 }
742 to_be_used_list_tail = il;
743
744 if (public && strcmp(modulename, "iso_c_binding") == 0) {
745 add_isoc_intrinsics();
746 }
747
748 return il;
749 } /* add_to_be_used_list */
750
751 static int
alreadyused(char * modulename)752 alreadyused(char *modulename)
753 {
754 int il, sptr;
755 for (il = 0; il < imported_modules.avail; ++il) {
756 if (strcmp(modulename, imported_modules.list[il].modulename) == 0) {
757 return imported_modules.list[il].modulesym;
758 }
759 }
760 /* if we are compiling a routine contained in a module,
761 * see if the module name is the same as the module we are compiling */
762 for (sptr = gbl.currsub; sptr; sptr = SCOPEG(sptr)) {
763 if (STYPEG(sptr) == ST_MODULE) {
764 if (strcmp(modulename, SYMNAME(sptr)) == 0) {
765 return sptr;
766 }
767 }
768 if (SCOPEG(sptr) == sptr)
769 break; /* prevent infinite loop */
770 }
771 return 0;
772 } /* alreadyused */
773
774 static void
add_use_edge(TOBE_IMPORTED_LIST * ilfrom,TOBE_IMPORTED_LIST * il,int directlyused)775 add_use_edge(TOBE_IMPORTED_LIST *ilfrom, TOBE_IMPORTED_LIST *il,
776 int directlyused)
777 {
778 USES_LIST *ul;
779 if (ilfrom == NULL)
780 return;
781 for (ul = ilfrom->uses; ul; ul = ul->next) {
782 if (ul->use_module == il)
783 return;
784 }
785 ul = (USES_LIST *)getitem(MOD_USE_AREA, sizeof(USES_LIST));
786 ul->next = ilfrom->uses;
787 ul->use_module = il;
788 ul->directlyused = directlyused;
789 ilfrom->uses = ul;
790 } /* add_use_edge */
791
792 static void
update_list_exceptions(USES_LIST * list)793 update_list_exceptions(USES_LIST *list)
794 {
795 USES_LIST *l;
796
797 for (l = list; l; l = l->next) {
798 if (!l->directlyused || !l->use_module->public) {
799 continue;
800 }
801 if (l->use_module->sl >= sem.scope_size) {
802 /* FS#22824: should not be indexing above sem.scope_level.
803 When it's >= sem.scope_size it would access random memory.
804 interr("bad saved scope level", l->use_module->sl, ERR_Severe);
805 */
806 } else {
807 l->use_module->exceptlist = get_scope(l->use_module->sl)->except;
808 }
809 update_list_exceptions(l->use_module->uses);
810 }
811 }
812
813 void
update_use_tree_exceptions(void)814 update_use_tree_exceptions(void)
815 {
816 update_list_exceptions(use_tree);
817 }
818
819 static int
get_module_file_name_from_user(TOBE_IMPORTED_LIST * il,char * from_file_name)820 get_module_file_name_from_user(TOBE_IMPORTED_LIST *il, char *from_file_name)
821 {
822 char *chfrom, *slash, saveslash;
823
824 /* try the directory from from_file_name */
825 slash = NULL;
826 for (chfrom = from_file_name; *chfrom; ++chfrom) {
827 if (*chfrom == '/')
828 slash = chfrom;
829 #ifdef HOST_WIN
830 if (*chfrom == '\\')
831 slash = chfrom;
832 #endif
833 }
834 if (slash) {
835 saveslash = *slash;
836 *slash = '\0'; /* have a directory, terminate the string */
837 if (fndpath(il->modulefilename, il->fullfilename, MAX_FNAME_LEN,
838 from_file_name) == 0) {
839 *slash = saveslash;
840 return 1;
841 }
842 *slash = saveslash;
843 }
844 return 0;
845 } /* get_module_file_name_from_user */
846
847 int
get_module_file_name(char * module_file_name,char * full_file_name,int len)848 get_module_file_name(char *module_file_name, char *full_file_name, int len)
849 {
850 if (module_directory_list) {
851 moddir_list *ml;
852 for (ml = module_directory_list; ml; ml = ml->next) {
853 if (fndpath(module_file_name, full_file_name, len,
854 ml->module_directory) == 0) {
855 return 1;
856 }
857 }
858 } else {
859 /* look in current directory before include directories */
860 if (fndpath(module_file_name, full_file_name, len, ".") == 0) {
861 return 1;
862 }
863 }
864 if (flg.idir) {
865 int i;
866 char *chp;
867 for (i = 0; (chp = flg.idir[i]); ++i) {
868 if (fndpath(module_file_name, full_file_name, len, chp) == 0) {
869 return 1;
870 }
871 }
872 }
873 if (fndpath(module_file_name, full_file_name, len, DIRWORK) == 0) {
874 return 1;
875 }
876 if (flg.stdinc == 0) {
877 if (fndpath(module_file_name, full_file_name, len, DIRSINCS) == 0) {
878 return 1;
879 }
880 } else if (flg.stdinc != (char *)1) {
881 if (fndpath(module_file_name, full_file_name, len, flg.stdinc) == 0) {
882 return 1;
883 }
884 }
885 return 0;
886 } /* get_module_file_name */
887
888 static void
topsort(TOBE_IMPORTED_LIST * il)889 topsort(TOBE_IMPORTED_LIST *il)
890 {
891 USES_LIST *ul;
892 TOBE_IMPORTED_LIST *ulil;
893
894 il->visited = TRUE;
895 for (ul = il->uses; ul; ul = ul->next) {
896 ulil = ul->use_module;
897 if (ulil->visited == FALSE) {
898 topsort(ulil);
899 }
900 }
901 if (to_be_used_list_order_tail == NULL) {
902 to_be_used_list_order_head = il;
903 } else {
904 to_be_used_list_order_tail->order = il;
905 }
906 to_be_used_list_order_tail = il;
907 } /* topsort */
908
909 static int
sym_visible_in_scope(USES_LIST * list,int sptrsym,char * symscopenm)910 sym_visible_in_scope(USES_LIST *list, int sptrsym, char *symscopenm)
911 {
912 USES_LIST *l;
913 int scopesptr = 0;
914 int sl;
915 SCOPESTACK *scope;
916
917 /* breath first search of USE tree */
918 l = list;
919 while ((l = find_next_modname_in_list(symscopenm, l))) {
920 TOBE_IMPORTED_LIST *n = l->use_module;
921 if (n->visited) {
922 l = l->next;
923 continue;
924 }
925
926 sl = n->sl;
927 if (!sl || sl >= sem.scope_level) {
928 l = l->next;
929 continue;
930 }
931
932 /*
933 * This use_tree node ("l") is an instance of the the sptrsym's defining
934 * module and
935 * nothing above it (no USEing scope) has aliased (renamed) it. If this
936 * scope is public
937 * and symsptr is not on the exception list or if this scope is private and
938 * symsptr in on
939 * the only list, then this module/scope provides a visible instance of
940 * sptrsym.
941 */
942 scope = get_scope(sl);
943 if (!is_except_in_scope(scope, sptrsym) &&
944 !is_private_in_scope(scope, sptrsym)) {
945 return scope->sptr;
946 }
947 l = l->next;
948 }
949
950 /* not found, recurse through the rest of the use_tree looking for aliases of
951 * sptrsym */
952 for (l = list; l; l = l->next) {
953 int symavl, sptrloop;
954 LOGICAL hidden;
955 if (!l->directlyused) {
956 continue;
957 }
958 sl = l->use_module->sl;
959 if (l->use_module->visited || !sl || sl >= sem.scope_level) {
960 continue;
961 }
962 l->use_module->visited = 1;
963 hidden = FALSE;
964 symavl =
965 sl == sem.scope_level - 1 ? stb.stg_avail : sem.scope_stack[sl + 1].symavl;
966
967 for (sptrloop = sem.scope_stack[sl].symavl; sptrloop < symavl; sptrloop++) {
968 /* if an alias of sptrsym is found in the the current (sl) scope,
969 * then the symbol is hidden */
970 if (STYPEG(sptrloop) == ST_ALIAS && SYMLKG(sptrloop) == sptrsym &&
971 SCOPEG(sptrloop) == sem.scope_stack[sl].sptr) {
972 hidden = TRUE;
973 break; /* out of the alias search loop */
974 }
975 }
976 if (hidden)
977 continue; /* with the next item on list */
978
979 if (l->use_module->public &&
980 (scopesptr =
981 sym_visible_in_scope(l->use_module->uses, sptrsym, symscopenm))) {
982 break;
983 }
984 }
985
986 return scopesptr;
987 }
988
989 static LOGICAL
scope_in_scope_stack(int sptr)990 scope_in_scope_stack(int sptr)
991 {
992 SCOPESTACK *iface_scope =
993 sem.interface ? next_scope_kind(curr_scope(), SCOPE_INTERFACE) : 0;
994 SCOPESTACK *sptr_scope = next_scope_sptr(curr_scope(), sptr);
995 return sptr_scope > iface_scope;
996 }
997
998 /** \brief Determine if there is a path through the USEs that makes
999 * the symbol aliased by sptralias visible.
1000 *
1001 * If so, return the sptr of the module containing the symbol definition or, in
1002 * some cases, the sptr of the module containing the exposing alias.
1003 * Otherwise return 0.
1004 */
1005 int
aliased_sym_visible(int sptralias)1006 aliased_sym_visible(int sptralias)
1007 {
1008 int sptrsym = SYMLKG(sptralias);
1009 int scopesym = 0;
1010 int sptr;
1011
1012 if (STYPEG(sptrsym) != ST_PROC) {
1013 scopesym = SCOPEG(sptrsym);
1014 sptr = sptrsym;
1015 } else {
1016 scopesym = ENCLFUNCG(sptrsym);
1017 sptr = sptralias;
1018 }
1019
1020 if (!scope_in_scope_stack(scopesym)) {
1021 if (!PRIVATEG(sptralias)) {
1022 /* happens when the the original symbol has been indirectly use associate
1023 * through
1024 * a module the exposes the symbol with a "USE ..., ONLY:" clause.
1025 */
1026 return SCOPEG(sptralias);
1027 } else {
1028 return 0;
1029 }
1030 }
1031
1032 clear_list_nodes_visited(use_tree);
1033 return sym_visible_in_scope(use_tree, sptr, SYMNAME(scopesym));
1034 }
1035
1036 static LOGICAL
alias_may_need_adjustment(int sptralias,int currmod)1037 alias_may_need_adjustment(int sptralias, int currmod)
1038 {
1039 int sptrsym = SYMLKG(sptralias);
1040 int scopesym = 0;
1041 int scopealias = SCOPEG(sptralias);
1042
1043 if (STYPEG(sptrsym) != ST_PROC) {
1044 scopesym = SCOPEG(sptrsym);
1045 } else {
1046 scopesym = ENCLFUNCG(sptrsym);
1047 }
1048
1049 /*
1050 don't check normal contain'd subroutine/function aliases unless it is
1051 the module being processed
1052 */
1053 if (scopealias != currmod &&
1054 (STYPEG(sptrsym) == ST_PROC || STYPEG(sptrsym) == ST_ENTRY) &&
1055 scopesym == scopealias)
1056 return FALSE;
1057
1058 /*
1059 If this func/subr alias is private and from a different scope than the
1060 func/subr (see
1061 previous if stmt), then this symbol is private in the alias scope. Don't
1062 check.
1063 */
1064 if ((STYPEG(sptrsym) == ST_PROC || STYPEG(sptrsym) == ST_ENTRY) &&
1065 PRIVATEG(sptralias) && scopesym == scopealias)
1066 return FALSE;
1067
1068 /* don't check compiler generated symbols */
1069 if (CCSYMG(sptrsym) || HCCSYMG(sptrsym) || CFUNCG(sptralias))
1070 return FALSE;
1071
1072 /* don't check symbols not defined in a module */
1073 if (!scopesym || STYPEG(scopesym) != ST_MODULE)
1074 return FALSE;
1075
1076 /* don't check aliases in the current module */
1077 if (scopealias == gbl.currmod)
1078 return FALSE;
1079
1080 /* don't check private symbols from an included module */
1081 if (PRIVATEG(sptralias) && PRIVATEG(sptrsym) && scopesym == scopealias)
1082 return FALSE;
1083
1084 /* don't check if in an interface block and the alias is PRIVATE */
1085 if (sem.interface && PRIVATEG(sptralias))
1086 return FALSE;
1087
1088 return TRUE;
1089 }
1090
1091 void
adjust_symbol_accessibility(int currmod)1092 adjust_symbol_accessibility(int currmod)
1093 {
1094 int sptr;
1095 int sptrmodscope;
1096
1097 if (!use_tree) {
1098 return;
1099 }
1100
1101 sptr = gbl.internal > 1 ? stb.firstosym : stb.firstusym;
1102 for (; sptr < stb.stg_avail; sptr++) {
1103 if (STYPEG(sptr) == ST_ALIAS && alias_may_need_adjustment(sptr, currmod)) {
1104 sptrmodscope = aliased_sym_visible(sptr);
1105 if (sptrmodscope) {
1106 HIDDENP(SYMLKG(sptr), 0);
1107 if (STYPEG(SYMLKG(sptr)) == ST_PROC) {
1108 PRIVATEP(SCOPEG(SYMLKG(sptr)), 0); /* fix-up proc's original alias */
1109 }
1110 } else {
1111 HIDDENP(SYMLKG(sptr), 1);
1112 if (STYPEG(SYMLKG(sptr)) == ST_PROC &&
1113 ENCLFUNCG(SYMLKG(sptr)) != currmod) {
1114 PRIVATEP(SCOPEG(SYMLKG(sptr)), 1); /* fix-up proc's original alias */
1115 }
1116 }
1117 }
1118 }
1119 }
1120
1121 static void
do_nested_uses(WantPrivates wantPrivates)1122 do_nested_uses(WantPrivates wantPrivates)
1123 {
1124 TOBE_IMPORTED_LIST *il;
1125 LOGICAL nested_in_host = FALSE;
1126 int saveBASEsym, saveBASEast, saveBASEdty;
1127 int sl, ivsn;
1128 int save_import_osym;
1129
1130 if (for_module || for_host) {
1131 nested_in_host = TRUE;
1132 saveBASEsym = BASEsym;
1133 saveBASEast = BASEast;
1134 saveBASEdty = BASEdty;
1135 BASEsym = stb.firstusym;
1136 BASEast = astb.firstuast;
1137 BASEdty = DT_MAX;
1138 }
1139
1140 #if DEBUG
1141 if (DBGBIT(0, 0x10000))
1142 fprintf(gbl.dbgfil, "Enter do_nested_uses\n");
1143 #endif
1144
1145 if (to_be_used_list_head == NULL)
1146 return;
1147
1148 for (il = to_be_used_list_head; il; il = il->next) {
1149 FILE *fd;
1150 lzhandle *fdlz;
1151 int i;
1152 /* open this file */
1153 if (il->modulefilename == NULL) {
1154 il->modulefilename = (char *)getitem(
1155 MOD_USE_AREA, strlen(il->modulename) + strlen(MOD_SUFFIX) + 1);
1156 il->fullfilename = (char *)getitem(MOD_USE_AREA, MAX_FNAME_LEN + 1);
1157 strcpy(il->modulefilename, il->modulename);
1158 strcat(il->modulefilename, MOD_SUFFIX);
1159
1160 if (!get_module_file_name(il->modulefilename, il->fullfilename,
1161 MAX_FNAME_LEN)) {
1162 error(4, 0, gbl.lineno, "Unable to open MODULE file",
1163 il->modulefilename);
1164 continue;
1165 }
1166 }
1167
1168 #if DEBUG
1169 if (DBGBIT(0, 0x10000))
1170 fprintf(gbl.dbgfil, "Open nested module file: %s\n", il->fullfilename);
1171 #endif
1172 fd = fopen(il->fullfilename, "r");
1173 if (fd == NULL) {
1174 error(4, 0, gbl.lineno, "Unable to open MODULE file", il->modulefilename);
1175 continue;
1176 }
1177 save_import_osym = import_osym;
1178 fdlz = import_header_only(fd, il->modulefilename, 999, NULL);
1179 if (fdlz) {
1180 i = import_use_stmts(fdlz, il, il->fullfilename, IMPORT_WHICH_NESTED,
1181 il->public);
1182 }
1183 import_osym = save_import_osym;
1184 import_done(fdlz, 1);
1185 fclose(fd);
1186 }
1187
1188 /* create a topological sort of the modules */
1189 to_be_used_list_order_head = to_be_used_list_order_tail = NULL;
1190 for (il = to_be_used_list_head; il; il = il->next) {
1191 if (il->visited == FALSE) {
1192 topsort(il);
1193 }
1194 }
1195
1196 for (il = to_be_used_list_order_head; il; il = il->order) {
1197 int modulesym;
1198 modulesym = alreadyused(il->modulename);
1199 if (modulesym) {
1200 if (il->public && nested_in_host) {
1201 sl = have_use_scope(modulesym);
1202 if (il->exceptlist != 0 || sl < top_scope_level) {
1203 int ex, base, s;
1204 ;
1205 /* public USE, no uses near enough open the module scope */
1206 save_scope_level();
1207 push_scope_level(modulesym, SCOPE_USE);
1208 il->sl = sem.scope_level;
1209 il->visited = FALSE;
1210 /* fill in the except list */
1211 curr_scope()->except = il->exceptlist;
1212 s = modulesym;
1213 if (STYPEG(s) == ST_ALIAS)
1214 s = SYMLKG(s);
1215 base = CMEMFG(s);
1216 for (ex = il->exceptlist; ex; ex = SYMI_NEXT(ex))
1217 SYMI_SPTR(ex) += base;
1218 restore_scope_level();
1219 } else if (sl >= top_scope_level) {
1220 il->sl = sl;
1221 }
1222 }
1223 } else {
1224 /* do the 'USE' */
1225 FILE *fd;
1226 lzhandle *fdlz;
1227 int module_sym, savescope;
1228
1229 #if DEBUG
1230 if (DBGBIT(0, 0x10000))
1231 fprintf(gbl.dbgfil, "Do nested use: %s\n", il->fullfilename);
1232 #endif
1233 fd = fopen(il->fullfilename, "r");
1234 if (fd == NULL)
1235 continue;
1236 module_sym = import_mk_newsym(il->modulename, ST_MODULE);
1237
1238 savescope = stb.curr_scope;
1239 if (nested_in_host) {
1240 save_scope_level();
1241 push_scope_level(module_sym, SCOPE_USE);
1242 curr_scope()->except = il->exceptlist;
1243 il->sl = sem.scope_level;
1244 il->visited = FALSE;
1245 restore_scope_level();
1246 }
1247 stb.curr_scope = module_sym;
1248
1249 save_import_osym = import_osym;
1250 /* import_header_only function sets the original fortran source code */
1251 fdlz = import_header_only(fd, il->modulefilename, module_sym, &ivsn);
1252 if (fdlz) {
1253 if (import_skip_use_stmts(fdlz) == 0) {
1254 import(fdlz, wantPrivates, ivsn);
1255 }
1256 }
1257 import_osym = save_import_osym;
1258 import_done(fdlz, 1);
1259 fclose(fd);
1260 if (nested_in_host) {
1261 if (!(il->public) && save_import_osym != ANCESTORG(savescope)) {
1262 /* pop off the 'use' from the scope list */
1263 save_scope_level();
1264 pop_scope_level(SCOPE_USE);
1265 il->sl = 0;
1266 restore_scope_level();
1267 } else {
1268 int ex, base;
1269 int s = module_sym;
1270 if (STYPEG(s) == ST_ALIAS)
1271 s = SYMLKG(s);
1272 base = CMEMFG(s);
1273 for (ex = il->exceptlist; ex; ex = SYMI_NEXT(ex))
1274 SYMI_SPTR(ex) += base;
1275 }
1276 }
1277 /* restore curr_scope symbol */
1278 stb.curr_scope = savescope;
1279 add_imported(module_sym);
1280 }
1281 }
1282 #if DEBUG
1283 if (DBGBIT(0, 0x10000))
1284 fprintf(gbl.dbgfil, "Exit do_nested_uses\n");
1285 #endif
1286 if (for_module || for_host) {
1287 BASEsym = saveBASEsym;
1288 BASEast = saveBASEast;
1289 BASEdty = saveBASEdty;
1290 }
1291 } /* do_nested_uses */
1292
1293 static lzhandle *
import_header_only(FILE * fd,char * file_name,int import_which,int * ivsn_return)1294 import_header_only(FILE *fd, char *file_name, int import_which, int* ivsn_return)
1295 {
1296 int j, compress;
1297 char *p;
1298 lzhandle *fdlz;
1299 int ivsn;
1300 int in_platform = 0;
1301
1302 #if DEBUG
1303 if (DBGBIT(0, 0x10000))
1304 fprintf(gbl.dbgfil, "import_header_only(%s)\n", file_name);
1305 #endif
1306 import_errno = 0;
1307 if (buff == NULL) {
1308 buff_sz = BUFF_LEN;
1309 NEW(buff, char, buff_sz);
1310 }
1311
1312 set_message(import_which, file_name);
1313
1314 /* read the first line */
1315 READ_LINE; /* IVSN name-of-module */
1316 if (for_static && p == NULL) {
1317 import_errno = -1;
1318 FREE(buff);
1319 buff = 0;
1320 return NULL;
1321 }
1322 if (p == NULL) {
1323 error(4, 0, gbl.lineno, import_corrupt_msg, import_file_name);
1324 return NULL;
1325 }
1326
1327 if (*currp != 'V') {
1328 error(4, 0, gbl.lineno, import_corrupt_msg, import_file_name);
1329 return NULL;
1330 }
1331 ++currp;
1332 /* get info from the first line */
1333 ivsn = get_num(10);
1334 if (ivsn < IVSN_24) {
1335 error(4, 3, gbl.lineno, import_oldfile_msg, import_file_name);
1336 error(4, 0, gbl.lineno, "Recompile source file", import_sourcename);
1337 return NULL;
1338 }
1339 if (ivsn_return)
1340 *ivsn_return = ivsn;
1341 if (ivsn == IVSN_24) {
1342 if (BASEdty == DT_MAX) {
1343 /* ivsn == 24 => before adding DT_DEFER[N]CHAR and increasing
1344 * the SYM flags & fields
1345 */
1346 BASEdty = DT_MAX_43; /* DT_MAX before adding DT_DEFER[N]CHAR */
1347 }
1348 }
1349 /*
1350 * Three cases:
1351 * o V25 was never released.
1352 * o V24 & V26 can procede wihout any additional checks.
1353 * o >= V27 needs further checks.
1354 */
1355 if (ivsn >= IVSN_27) {
1356 while (*currp == ' ')
1357 ++currp;
1358 if (ivsn > IVSN_27) {
1359 if (ivsn > IVSN) {
1360 /*
1361 * old compiler reading new .mod file ??
1362 */
1363 error(4, 3, gbl.lineno, import_oldfile_msg, import_file_name);
1364 error(4, 0, gbl.lineno, "Recompile source file", import_sourcename);
1365 return NULL;
1366 }
1367 if (*currp != ':') {
1368 error(4, 0, gbl.lineno, import_corrupt_msg, import_file_name);
1369 return NULL;
1370 }
1371 ++currp;
1372 }
1373 if (*currp != '0') {
1374 error(4, 0, gbl.lineno, import_corrupt_msg, import_file_name);
1375 return NULL;
1376 }
1377 ++currp;
1378 if (*currp != 'x') {
1379 error(4, 0, gbl.lineno, import_corrupt_msg, import_file_name);
1380 return NULL;
1381 }
1382 ++currp;
1383 if (XBIT(124, 0x10)) {
1384 curr_platform = curr_platform | MOD_I8;
1385 }
1386 if (XBIT(124, 0x8)) {
1387 curr_platform = curr_platform | MOD_R8;
1388 }
1389 if (XBIT(68, 0x1)) {
1390 curr_platform = curr_platform | MOD_LA;
1391 }
1392
1393 in_platform = get_num(16);
1394 #if DO_MODULE_OPTION_CHECK
1395 if (ivsn >= IVSN && curr_platform != in_platform) {
1396 if (!(in_platform & MOD_PG)) {
1397 if ((curr_platform | MOD_I8 | MOD_R8 | MOD_PG) !=
1398 (in_platform | MOD_I8 | MOD_R8 | MOD_PG)) {
1399 error(4, 3, gbl.lineno, import_incompatible_msg, import_file_name);
1400 error(4, 0, gbl.lineno,
1401 "Compile source file with the same compiler options",
1402 import_sourcename);
1403 return NULL;
1404 }
1405 }
1406 }
1407 #endif
1408 }
1409 get_string(import_name);
1410
1411 READ_LINE; /* source-filename-len source-filename firstosym compress */
1412 if (p == NULL) {
1413 error(4, 0, gbl.lineno, import_corrupt_msg, import_file_name);
1414 return NULL;
1415 }
1416
1417 j = get_num(10); /* length of file name */
1418 if (import_sourcename == NULL || import_sourcename_len < j + 1) {
1419 import_sourcename =
1420 getitem(8, j + 1); /*area 8 is freed at the end of main()*/
1421 }
1422 if (j == 0) {
1423 import_sourcename[0] = '\0';
1424 } else {
1425 get_nstring(import_sourcename, j);
1426 /* put the file names in the fihb */
1427 }
1428
1429 if (*currp == ' ' && *(currp + 1) == 'S') {
1430 ++currp;
1431 ++currp;
1432 import_osym = get_num(10);
1433 if (!can_map_initsym(import_osym)) {
1434 error(4, 3, gbl.lineno, import_incompatible_msg, import_file_name);
1435 error(4, 0, gbl.lineno, "Compile source file with the same compiler",
1436 import_sourcename);
1437 return NULL;
1438 }
1439 } else {
1440 error(4, 3, gbl.lineno, import_incompatible_msg, import_file_name);
1441 error(4, 0, gbl.lineno, "Compile source file with the same compiler",
1442 import_sourcename);
1443 return NULL;
1444 }
1445 compress = 0;
1446 if (*currp == ' ') {
1447 compress = get_num(10);
1448 }
1449 fdlz = ulzinit(fd, 0 /*compress*/);
1450 READ_LZLINE; /* time-date stamp */
1451 if (p == NULL) {
1452 error(4, 0, gbl.lineno, import_corrupt_msg, import_file_name);
1453 ulzfini(fdlz);
1454 return NULL;
1455 }
1456 return fdlz;
1457 } /* import_header_only */
1458
1459 /* nested_public is usually one; it is zero if this is a nested use statement
1460 * where the module in which the use appears is itself private */
1461 static int
import_use_stmts(lzhandle * fdlz,TOBE_IMPORTED_LIST * ilfrom,char * from_file_name,int import_which,int nested_public)1462 import_use_stmts(lzhandle *fdlz, TOBE_IMPORTED_LIST *ilfrom,
1463 char *from_file_name, int import_which, int nested_public)
1464 {
1465 char *p;
1466 TOBE_IMPORTED_LIST *il;
1467 TOBE_IMPORTED_LIST *n;
1468 USES_LIST **curr_use_list;
1469
1470 #if DEBUG
1471 if (DBGBIT(0, 0x10000))
1472 fprintf(gbl.dbgfil, "LOOK FOR USE STATEMENTS\n");
1473 #endif
1474 if (import_which > 0) {
1475 n = insert_node_into_use_tree(SYMNAME(
1476 import_which)); /* add module from USE statement to the use tree root
1477 list */
1478 curr_use_list = &(n->uses);
1479 }
1480
1481 /* look for any 'use' statements */
1482 while (1) {
1483 char modulename[MAXIDLEN + 1], private[10], direct[10];
1484 int publicflag = 0;
1485 int directflag = 0;
1486 int ex = 0;
1487 int n;
1488
1489 READ_LZLINE; /* "use module" or "enduse" */
1490 if (p == NULL) {
1491 error(4, 0, gbl.lineno, import_corrupt_msg, import_file_name);
1492 return 1;
1493 }
1494 if (*currp == 'e') /* "enduse" */
1495 break;
1496 currp += 4; /* past 'use ' */
1497 get_string(modulename);
1498 get_string(private);
1499 publicflag = !strcmp(private, "public");
1500 /* get the 'except' list, if any */
1501 n = get_num(10);
1502 while (n--) {
1503 int s;
1504 s = get_num(10);
1505 ex = add_symitem(s, ex);
1506 }
1507 get_string(direct);
1508 directflag = !strcmp(direct, "direct");
1509 if (sem.scope_stack != NULL) {
1510 SCOPESTACK *scope = next_scope_kind_symname(0, SCOPE_MODULE, modulename);
1511 if (scope != 0) {
1512 error(500, 3, gbl.lineno, modulename, SYMNAME(import_which));
1513 if (import_which && directflag) {
1514 il = already_to_be_used(modulename, publicflag, scope->except);
1515 if (publicflag) {
1516 curr_use_list = add_use_tree_uses(curr_use_list, il);
1517 il->sl = get_scope_level(scope);
1518 }
1519 }
1520 continue; /* already processed this 'use' */
1521 }
1522 }
1523 if (!publicflag || !nested_public) {
1524 il = add_to_be_used_list(modulename, 0, 0, ilfrom, from_file_name);
1525 } else {
1526 il = add_to_be_used_list(modulename, 1, ex, ilfrom, from_file_name);
1527 }
1528 if (il) {
1529 add_use_edge(ilfrom, il, directflag);
1530 if (import_which > 0 && directflag && publicflag) {
1531 curr_use_list = add_use_tree_uses(curr_use_list, il);
1532 }
1533 }
1534 if (strcmp(modulename, "ieee_features") == 0) {
1535 sem.ieee_features = TRUE;
1536 }
1537 }
1538
1539 #if DEBUG
1540 if (DBGBIT(0, 0x10000))
1541 fprintf(gbl.dbgfil, "DONE ADDING USE STMTS\n");
1542 #endif
1543 return 0;
1544 } /* import_use_stmts */
1545
1546 /** \brief Look for any 'use' statements and skip over them */
1547 static int
import_skip_use_stmts(lzhandle * fdlz)1548 import_skip_use_stmts(lzhandle *fdlz)
1549 {
1550 char *p;
1551
1552 while (1) {
1553 READ_LZLINE; /* "use module" or "enduse" */
1554 if (p == NULL) {
1555 error(4, 0, gbl.lineno, import_corrupt_msg, import_file_name);
1556 return 1;
1557 }
1558 if (*currp == 'e') /* "enduse" */
1559 break;
1560 }
1561 return 0;
1562 } /* import_skip_use_stmts */
1563
1564 /** \brief Add .mod file to list of .mod files used */
1565 static void
addmodfile(char * filename)1566 addmodfile(char *filename)
1567 {
1568 int m;
1569 for (m = 0; m < modinclistavl; ++m) {
1570 if (strcmp(filename, modinclist[m]) == 0)
1571 return; /* got it */
1572 }
1573 NEED(modinclistavl + 1, modinclist, char *, modinclistsize,
1574 modinclistsize + 40);
1575 /* allocate space to keep the name */
1576 modinclist[modinclistavl] = (char *)sccalloc(strlen(filename) + 1);
1577 strcpy(modinclist[modinclistavl], filename);
1578 ++modinclistavl;
1579 } /* addmodfile */
1580
1581 static lzhandle *
import_header(FILE * fd,char * file_name,int import_which,int * ivsn_return)1582 import_header(FILE *fd, char *file_name, int import_which, int* ivsn_return)
1583 {
1584 lzhandle *fdlz;
1585 int i;
1586 int cur_findex_backup = 0;
1587
1588 fdlz = import_header_only(fd, file_name, import_which, ivsn_return);
1589 if (fdlz == NULL)
1590 return fdlz;
1591 to_be_used_list_head = to_be_used_list_tail = NULL;
1592 i = import_use_stmts(fdlz, NULL, file_name, import_which, 1);
1593 if (i != 0) {
1594 ulzfini(fdlz);
1595 return NULL;
1596 }
1597 /* save curr_import_findex which will be likely changed in
1598 * function do_nested_uses. */
1599 cur_findex_backup = curr_import_findex;
1600 if (to_be_used_list_head != NULL) {
1601 /* do USEs of modules */
1602 do_nested_uses(INCLUDE_PRIVATES);
1603 }
1604 /* restore file index after do_nested_uses */
1605 curr_import_findex = cur_findex_backup;
1606 if (import_which > 0 && XBIT(123, 0x30000)) {
1607 TOBE_IMPORTED_LIST *il;
1608 if (modinclist == NULL) {
1609 modinclistsize = 40;
1610 modinclistavl = 0;
1611 NEW(modinclist, char *, modinclistsize);
1612 }
1613 /* do each of the nested uses */
1614 for (il = to_be_used_list_head; il; il = il->next) {
1615 addmodfile(il->fullfilename);
1616 }
1617 /* do this file */
1618 addmodfile(file_name);
1619 }
1620 /* have to do this again, in case any modules were imported between
1621 * then and now */
1622 set_message(import_which, file_name);
1623 return fdlz;
1624 } /* import_header */
1625
1626 static void
import_done(lzhandle * fdlz,int nested)1627 import_done(lzhandle *fdlz, int nested)
1628 {
1629 if (fdlz)
1630 ulzfini(fdlz);
1631 freearea(MOD_AREA);
1632 if (!nested) {
1633 if (buff) {
1634 FREE(buff);
1635 buff = 0;
1636 }
1637 freearea(MOD_USE_AREA);
1638 init_use_tree();
1639 }
1640 for_static = FALSE;
1641 for_interproc = FALSE;
1642 for_inliner = FALSE;
1643 for_module = 0;
1644 inmodulecontains = FALSE;
1645 import_corrupt_msg = NULL;
1646 import_oldfile_msg = NULL;
1647 import_incompatible_msg = NULL;
1648 import_file_name = NULL;
1649 } /* import_done */
1650
1651 /** \brief Find a NMPTR that shares NMPTR for different symbols with the same
1652 * name.
1653 *
1654 * Note that putsname always inserts a new name into the name table.
1655 */
1656 static int
find_nmptr(char * symname)1657 find_nmptr(char *symname)
1658 {
1659 int hash, hptr, len;
1660 len = strlen(symname);
1661 HASH_ID(hash, symname, len);
1662 for (hptr = stb.hashtb[hash]; hptr; hptr = HASHLKG(hptr)) {
1663 if (strcmp(SYMNAME(hptr), symname) == 0) {
1664 return NMPTRG(hptr);
1665 }
1666 }
1667 return putsname(symname, len);
1668 } /* find_nmptr */
1669
1670 /** \brief Find a nmptr index for this name, then link this symbol into
1671 * the stb.hashtb hash links.
1672 */
1673 static void
hash_link_name(int sptr,char * symname)1674 hash_link_name(int sptr, char *symname)
1675 {
1676 int hash, hptr, len, nmptr;
1677 len = strlen(symname);
1678 HASH_ID(hash, symname, len);
1679 nmptr = 0;
1680 for (hptr = stb.hashtb[hash]; hptr; hptr = HASHLKG(hptr)) {
1681 if (strcmp(SYMNAME(hptr), symname) == 0) {
1682 nmptr = NMPTRG(hptr);
1683 break;
1684 }
1685 }
1686 if (!nmptr)
1687 nmptr = putsname(symname, len);
1688 NMPTRP(sptr, nmptr);
1689 HASHLKP(sptr, stb.hashtb[hash]);
1690 stb.hashtb[hash] = sptr;
1691 } /* hash_link_name */
1692
1693 static int
find_member_name(char * symname,int stype,int scopesym,int offset)1694 find_member_name(char *symname, int stype, int scopesym, int offset)
1695 {
1696 int sptr, base;
1697 int hash, len;
1698 int dtype = 0;
1699
1700 base = CMEMFG(scopesym);
1701
1702 if (STYPEG(scopesym) == ST_TYPEDEF) {
1703 int scope;
1704 dtype = DTYPEG(scopesym);
1705 for (scope = SCOPEG(scopesym); scope; scope = SCOPEG(scope)) {
1706 scopesym = scope;
1707 }
1708 }
1709
1710 if (base == 0 || scopesym == gbl.currmod || offset < 0) {
1711 /* check hash table */
1712 len = strlen(symname);
1713 HASH_ID(hash, symname, len);
1714 for (sptr = stb.hashtb[hash]; sptr; sptr = HASHLKG(sptr)) {
1715 if (STYPEG(sptr) == stype && strcmp(SYMNAME(sptr), symname) == 0) {
1716 int scope;
1717 for (scope = SCOPEG(sptr); scope; scope = SCOPEG(scope)) {
1718 if (dtype && (!CLASSG(sptr) && !VTABLEG(sptr))) {
1719 if (scope == scopesym && dtype == ENCLDTYPEG(sptr))
1720 return sptr;
1721 } else {
1722 if (scope == scopesym)
1723 return sptr;
1724 }
1725 if (SCOPEG(scope) == scope)
1726 break;
1727 }
1728 if (stype == ST_PROC && ENCLFUNCG(sptr) == scopesym) {
1729 /* when module A uses module B, the ST_PROC symbol for a function
1730 * Bfunc has its ENCLFUNC set to A. Check the SCOPE of the ST_ALIAS
1731 */
1732 if (STYPEG(ENCLFUNCG(sptr)) == ST_MODULE) {
1733 if (STYPEG(SCOPEG(sptr)) == ST_ALIAS &&
1734 SCOPEG(SCOPEG(sptr)) != scope) {
1735 continue;
1736 }
1737 }
1738 return sptr;
1739 }
1740 }
1741 }
1742 return 0;
1743 }
1744 /* check first at 'base+offset' */
1745 sptr = base + offset;
1746 if (sptr >= stb.stg_avail)
1747 return 0;
1748 if (STYPEG(sptr) == stype && strcmp(SYMNAME(sptr), symname) == 0) {
1749 int scope;
1750 for (scope = SCOPEG(sptr); scope; scope = SCOPEG(scope)) {
1751 if (scope == scopesym)
1752 return sptr;
1753 if (SCOPEG(scope) == scope)
1754 break;
1755 }
1756 }
1757 for (sptr = base + offset - 10;
1758 sptr <= stb.stg_avail && sptr <= base + offset + 10; ++sptr) {
1759 if (STYPEG(sptr) == stype && strcmp(SYMNAME(sptr), symname) == 0) {
1760 int scope;
1761 for (scope = SCOPEG(sptr); scope; scope = SCOPEG(scope)) {
1762 if (scope == scopesym)
1763 return sptr;
1764 if (SCOPEG(scope) == scope)
1765 break;
1766 }
1767 if (stype == ST_PROC && ENCLFUNCG(sptr) == scopesym)
1768 return sptr;
1769 }
1770 }
1771 /* check hash table */
1772 len = strlen(symname);
1773 HASH_ID(hash, symname, len);
1774 for (sptr = stb.hashtb[hash]; sptr; sptr = HASHLKG(sptr)) {
1775 if (STYPEG(sptr) == stype && strcmp(SYMNAME(sptr), symname) == 0) {
1776 int scope;
1777 for (scope = SCOPEG(sptr); scope; scope = SCOPEG(scope)) {
1778 if (scope == scopesym)
1779 return sptr;
1780 if (SCOPEG(scope) == scope)
1781 break;
1782 }
1783 }
1784 }
1785 return 0;
1786 } /* find_member_name */
1787
1788 static int module_base = 0; /* base symbol for modules */
1789
1790 /* The following routines manage the symbol_list hash table.
1791 * Note: Searching down the symbol_list is way way too expensive
1792 */
1793 static void
inithash(void)1794 inithash(void)
1795 {
1796 int i;
1797 for (i = 0; i < SYMHASHSIZE; ++i) {
1798 symhash[i] = NULL;
1799 }
1800 for (i = 0; i < DTHASHSIZE; ++i) {
1801 dthash[i] = 0;
1802 }
1803 } /* inithash */
1804
1805 static void
inserthash(int sptr,SYMITEM * ps)1806 inserthash(int sptr, SYMITEM *ps)
1807 {
1808 int h;
1809 h = sptr % SYMHASHSIZE;
1810 ps->hashnext = symhash[h];
1811 symhash[h] = ps;
1812 } /* inserthash */
1813
1814 static SYMITEM *
findhash(int sptr)1815 findhash(int sptr)
1816 {
1817 int h;
1818 SYMITEM *ps;
1819 h = sptr % SYMHASHSIZE;
1820 for (ps = symhash[h]; ps; ps = ps->hashnext) {
1821 if (ps->sptr == sptr)
1822 return ps;
1823 }
1824 return NULL;
1825 } /* findhash */
1826
1827 static void
insertdthash(int old_dt,int d)1828 insertdthash(int old_dt, int d)
1829 {
1830 int h;
1831 h = old_dt % DTHASHSIZE;
1832 dtz.base[d].hashnext = dthash[h];
1833 dthash[h] = d + 1; /* offset hash links by one, since zero is legal */
1834 } /* insertdthash */
1835
1836 static DITEM *
finddthash(int old_dt)1837 finddthash(int old_dt)
1838 {
1839 int h;
1840 int d;
1841 h = old_dt % SYMHASHSIZE;
1842 for (d = dthash[h]; d; d = dtz.base[d - 1].hashnext) {
1843 DITEM *pd;
1844 pd = dtz.base + (d - 1);
1845 if (pd->id == old_dt)
1846 return pd;
1847 }
1848 return NULL;
1849 } /* finddthash */
1850
1851 /*
1852 * \brief Adjust type code for IVSN < 34
1853 * had inserted TY_HALF and TY_HCMPLX
1854 */
1855 static int
adjust_pre34_dty(int dty)1856 adjust_pre34_dty(int dty)
1857 {
1858 /* pre-half precision, adjust datatypes */
1859 if (dty < TY_HALF) {
1860 /* no changes */
1861 } else if (dty < TY_HCMPLX - 1) {
1862 /* TY_REAL to TY_QUAD increment by 1 to add TY_HALF */
1863 dty += 1;
1864 } else {
1865 /* increment by 2 to add TY_HALF and TY_HCMPLX */
1866 dty += 2;
1867 }
1868 return dty;
1869 } /* adjust_pre34_dty */
1870
1871 static int
adjust_pre34_dtype(int dtype)1872 adjust_pre34_dtype(int dtype)
1873 {
1874 /* pre-half precision, adjust datatypes */
1875 if (dtype < DT_REAL2) {
1876 /* no changes */
1877 } else if (dtype < DT_CMPLX4 - 1) {
1878 /* DT_REAL4 to DT_QUAD increment by 1 to add DT_REAL2 */
1879 dtype += 1;
1880 } else {
1881 /* increment by 2 to add DT_REAL2 and DT_CMPLX4 */
1882 dtype += 2;
1883 }
1884 return dtype;
1885 } /* adjust_pre34_dtype */
1886
1887 static int original_symavl = 0;
1888 static unsigned A_IDSTR_mask = (1 << 5); /* A_IDSTR is AST bit flag f5 */
1889 static LOGICAL any_ptr_constant = FALSE;
1890
1891 /** \brief This is the main module import function.
1892 *
1893 * Below is the file format and order in which fields are read in.
1894 <pre>
1895 version Vnn modulename
1896 file len filename firstosymbol compress
1897 date mm/dd/yyyy hh:mm:ss
1898 uses* use modulename public/private exceptcount except*
1899 direct/indirect
1900 enduse
1901 astline A astndx type flags shape hashlk w3 w4 w5 w6 w7 w8 w9 w10 hw21
1902 hw22 w12 opt1 opt2 repl visit w18
1903 container C hostsptr hoststype
1904 datatype D datatype ty_val [type-specific information]
1905 dtyper d datatype sptrstype symboloffset modulename symbolname
1906 dtyper e datatype sptrstype scopestype scopename symbolname
1907 equiv E lineno sptr first substring subscript* 0
1908 formal F functionsptr numargs arg*
1909 align G alignptr target alignee aligntype alignsym ...
1910 shadow H sptr dims
1911 overlap L sptr overlapsptr
1912 mangled M sptr nmangled [mangledsptr mangledmember]*
1913 overload O sptr noverloaded overloaded*
1914 predecl P sptr
1915 generic Q sptr modproc* 0
1916 renamesym R sptr stype modoffset modname symname
1917 sym S sptr stype sc b3 b4 dtype symlk scope nmptr flags1 flags2 ...
1918 shape T count [lwb upb stride]*
1919 distrib U dist rank targettype isstar inherit formattype proc dynamic
1920 orig...
1921 std V stdidx astidx label lineno flags
1922 argt W nargs [arg]*
1923 asd X ndim [subscript]*
1924 astli Y [sptr triplet]* -1
1925 endsection Z
1926 </pre>
1927 */
1928 static void
import(lzhandle * fdlz,WantPrivates wantPrivates,int ivsn)1929 import(lzhandle *fdlz, WantPrivates wantPrivates, int ivsn)
1930 {
1931 char *p;
1932 int i, j;
1933 int sptr, nmlsptr, nmlline, nml, prevnml, ovlp;
1934 DITEM *pd;
1935 SYMITEM *ps, *qs, *previoussymbol;
1936 SYMITEM *last_symitem;
1937 ASTITEM *pa;
1938 int *pf;
1939 int evp, last_evp, first_evp;
1940 int dscptr;
1941 STDITEM *p_std;
1942 SHDITEM *p_shd;
1943 ARGTITEM *p_argt;
1944 ASDITEM *p_asd;
1945 ASTLIITEM *p_astli;
1946 int stringlen;
1947 int new_id, subtype, ndims, stype;
1948 int paramct, save_dtype_ivsn;
1949 char module_name[MAXIDLEN + 1], rename_name[MAXIDLEN + 1],
1950 idname[MAXIDLEN + 1], scope_name[MAXIDLEN + 1];
1951 int module_sym, scope_sym, rename_sym, offset, scope_stype;
1952 int hash;
1953 int first_ast;
1954 int currrout = 0;
1955
1956 save_dtype_ivsn = dtype_ivsn;
1957 dtype_ivsn = ivsn;
1958 module_base = 0;
1959 original_symavl = stb.stg_avail;
1960
1961 dtz.sz = 64;
1962 NEW(dtz.base, DITEM, dtz.sz);
1963 dtz.avl = 0;
1964
1965 flz.sz = 64;
1966 NEW(flz.base, int, flz.sz);
1967 flz.avl = 0;
1968
1969 ovz.sz = 64;
1970 NEW(ovz.base, int, ovz.sz);
1971 ovz.avl = 0;
1972
1973 mdz.sz = 64;
1974 NEW(mdz.base, int, mdz.sz);
1975 mdz.avl = 0;
1976
1977 astz.sz = 64;
1978 NEW(astz.base, ASTITEM, astz.sz);
1979 astz.avl = 0;
1980 BZERO(astzhash, int, ASTZHASHSIZE);
1981
1982 stdz.sz = 64;
1983 NEW(stdz.base, STDITEM, stdz.sz);
1984 stdz.avl = 0;
1985
1986 shdz.sz = 64;
1987 NEW(shdz.base, SHDITEM, shdz.sz);
1988 shdz.avl = 1;
1989
1990 argtz.sz = 64;
1991 NEW(argtz.base, ARGTITEM, argtz.sz);
1992 BZERO(argtz.base + 0, ARGTITEM, 1); /* entry 0 is the empty arg table */
1993 argtz.base[0].installed = TRUE;
1994 argtz.avl = 1;
1995
1996 asdz.sz = 64;
1997 NEW(asdz.base, ASDITEM, asdz.sz);
1998 asdz.avl = 0;
1999
2000 astliz.sz = 64;
2001 NEW(astliz.base, ASTLIITEM, astliz.sz);
2002 astliz.avl = 0;
2003
2004 modpz.sz = 64;
2005 NEW(modpz.base, MODPITEM, modpz.sz);
2006 modpz.avl = 0;
2007
2008 /* add symbols to the end of the symbol_list so they get
2009 * added to the symbol table in the correct order.
2010 * allocate an item whose next field will become the head of the list.
2011 */
2012 symbol_list = last_symitem = (SYMITEM *)getitem(MOD_AREA, sizeof(SYMITEM));
2013 BZERO(symbol_list, SYMITEM, 1);
2014 last_symitem->next = NULL;
2015 inithash();
2016
2017 align_list = NULL;
2018 dist_list = NULL;
2019
2020 first_evp = last_evp = 0;
2021
2022 previoussymbol = NULL;
2023
2024 first_ast = 0;
2025 old_astversion = FALSE;
2026
2027 while (1) { /* read remainder of lines in file: */
2028 READ_LZLINE;
2029 #if DEBUG
2030 assert(p, "import: can't read line", 0, 4);
2031 #else
2032 if (p == NULL)
2033 error(4, 0, gbl.lineno, import_corrupt_msg, import_file_name);
2034 #endif
2035 currp++;
2036 switch (p[0]) {
2037 case '-': /* info only line */
2038 break;
2039
2040 case 'A': /* ast definition line */
2041 astz.avl++;
2042 NEED(astz.avl, astz.base, ASTITEM, astz.sz, astz.sz + 64);
2043 pa = astz.base + (astz.avl - 1);
2044 BZERO(pa, ASTITEM, 1);
2045 pa->old_ast = get_num(10);
2046 pa->type = get_num(10);
2047 pa->flags = get_num(16);
2048 pa->a.shape = get_num(10);
2049 pa->a.hshlk = get_num(10);
2050 pa->a.w3 = get_num(10);
2051 pa->a.w4 = get_num(10);
2052 pa->a.w5 = get_num(10);
2053 pa->a.w6 = get_num(10);
2054 pa->a.w7 = get_num(10);
2055 pa->a.w8 = get_num(10);
2056 pa->a.w9 = get_num(10);
2057 pa->a.w10 = get_num(10);
2058 pa->a.hw21 = get_num(10);
2059 pa->a.hw22 = get_num(10);
2060 pa->a.w12 = get_num(10);
2061 pa->a.opt1 = get_num(10);
2062 pa->a.opt2 = get_num(10);
2063 pa->a.repl = get_num(10);
2064 pa->a.visit = get_num(10);
2065 pa->a.w18 = get_num(10); /* IVSN 30 */
2066 pa->a.w19 = get_num(10);
2067 if (pa->flags & A_IDSTR_mask) {
2068 get_string(idname);
2069 sptr = getsymbol(idname);
2070 pa->a.w4 = sptr;
2071 }
2072 hash = pa->old_ast & ASTZHASHMASK;
2073 pa->link = astzhash[hash];
2074 astzhash[hash] = astz.avl;
2075 if (!first_ast) {
2076 if (astb.firstuast == 12 && pa->old_ast < 12) {
2077 /* older versions of the compiler reserved ASTs numbered
2078 * 1-9, inclusive; 10 was the first avail for user ASTs).
2079 */
2080 old_astversion = TRUE;
2081 }
2082 first_ast = pa->old_ast;
2083 }
2084 break;
2085
2086 case 'B': /* iso_c intrinsic function ST_ISOC */
2087 sptr = get_num(10);
2088 assert(sptr < stb.firstusym, "Invalid sptr in mod file B record", 0,
2089 ERR_Fatal);
2090 get_string(module_name);
2091 if (strcmp(module_name, "iso_c_binding") == 0) {
2092 if (strcmp(SYMNAME(sptr), "c_sizeof") == 0) {
2093 STYPEP(sptr, ST_PD);
2094 } else {
2095 STYPEP(sptr, ST_INTRIN);
2096 }
2097 } else if (strcmp(module_name, "ieee_arithmetic") == 0) {
2098 STYPEP(sptr, ST_PD);
2099 } else if (strcmp(module_name, "iso_fortran_env") == 0) {
2100 STYPEP(sptr, ST_PD);
2101 }
2102 break;
2103
2104 case 'C': /* containing subprogram symbol */
2105 sptr = get_num(10);
2106 stype = get_num(10);
2107 get_string(rename_name);
2108 /* look for this symbol */
2109 if (STYPEG(sptr) != stype || strcmp(rename_name, SYMNAME(sptr))) {
2110 interrf(ERR_Severe, "import: host program symbol %s (%d) not found!",
2111 rename_name, sptr);
2112 continue;
2113 }
2114 ps = (SYMITEM *)getitem(MOD_AREA, sizeof(SYMITEM));
2115 BZERO(ps, SYMITEM, 1);
2116 Trace(("Add host symbol %d to symbol list", sptr));
2117 last_symitem->next = ps;
2118 last_symitem = ps;
2119 ps->next = NULL;
2120 ps->sptr = sptr;
2121 ps->new_sptr = sptr;
2122 ps->sc = -1; /* don't change this symbol, already done */
2123 inserthash(sptr, ps);
2124 break;
2125
2126 case 'D': /* data type defn line */
2127 dtz.avl++;
2128 NEED(dtz.avl, dtz.base, DITEM, dtz.sz, dtz.sz + 64);
2129 pd = dtz.base + (dtz.avl - 1);
2130 pd->dtypeinstalled = FALSE;
2131
2132 pd->id = get_num(10);
2133 pd->ty = get_num(10);
2134 if (ivsn < 34)
2135 pd->ty = adjust_pre34_dty(pd->ty);
2136 insertdthash(pd->id, dtz.avl - 1);
2137 switch (pd->ty) {
2138 case TY_PTR:
2139 subtype = get_num(10);
2140 new_id = get_type(2, TY_PTR, subtype);
2141 break;
2142 case TY_ARRAY:
2143 subtype = get_num(10); /* array of dty */
2144 ndims = get_num(10); /* ndims */
2145 if (ndims == 0) {
2146 new_id = get_type(3, TY_ARRAY, subtype);
2147 DTY(new_id + 2) = 0;
2148 } else {
2149 new_id = get_array_dtype(ndims, subtype);
2150 ADD_ZBASE(new_id) = get_num(10); /* zbase */
2151 ADD_NUMELM(new_id) = get_num(10);
2152 ADD_ASSUMSHP(new_id) = get_num(10);
2153 ADD_DEFER(new_id) = get_num(10);
2154 ADD_ADJARR(new_id) = get_num(10);
2155 ADD_ASSUMSZ(new_id) = get_num(10);
2156 ADD_NOBOUNDS(new_id) = get_num(10);
2157 for (i = 0; i < ndims; ++i) {
2158 READ_LZLINE;
2159 #if DEBUG
2160 assert(p, "import: can't read arr line", 0, 4);
2161 #else
2162 if (p == NULL)
2163 error(4, 0, gbl.lineno, import_corrupt_msg, import_file_name);
2164 #endif
2165 ADD_LWBD(new_id, i) = get_num(10);
2166 ADD_UPBD(new_id, i) = get_num(10);
2167 ADD_MLPYR(new_id, i) = get_num(10);
2168 ADD_LWAST(new_id, i) = get_num(10);
2169 ADD_UPAST(new_id, i) = get_num(10);
2170 ADD_EXTNTAST(new_id, i) = get_num(10);
2171 }
2172 }
2173 break;
2174 case TY_UNION:
2175 case TY_STRUCT:
2176 case TY_DERIVED:
2177 new_id = get_type(6, pd->ty, 0);
2178 DTY(new_id + 1) = get_num(10); /* (old) first member */
2179 DTY(new_id + 2) = get_num(10); /* size */
2180 DTY(new_id + 3) = get_num(10); /* (old) tag */
2181 DTY(new_id + 4) = get_num(10); /* align */
2182 DTY(new_id + 5) = 0; /* ICT */
2183 break;
2184 case TY_CHAR:
2185 case TY_NCHAR:
2186 stringlen = get_num(10);
2187 new_id = get_type(2, TY_NONE, stringlen);
2188 /* use TY_NONE to avoid 'sharing' character data types */
2189 DTY(new_id) = pd->ty;
2190 break;
2191 case TY_PROC:
2192 subtype = get_num(10);
2193 new_id = get_type(6, TY_PROC, subtype);
2194 DTY(new_id + 2) = get_num(10); /* (old) interface */
2195 paramct = get_num(10);
2196 DTY(new_id + 3) = paramct;
2197 dscptr = ++aux.dpdsc_avl; /* one more for implicit arg */
2198 DTY(new_id + 4) = dscptr; /* dpdsc */
2199 aux.dpdsc_avl += paramct;
2200 NEED(aux.dpdsc_avl, aux.dpdsc_base, int, aux.dpdsc_size,
2201 aux.dpdsc_avl + 100);
2202 for (i = 0; i < paramct; i++) {
2203 aux.dpdsc_base[dscptr + i] = get_num(10); /* (old) arg */
2204 }
2205 DTY(new_id + 5) = get_num(10); /* (old) fval */
2206 break;
2207 }
2208 /* new_id is already filled in! */
2209 pd->new_id = new_id;
2210 break;
2211
2212 case 'd': /* data type rename line, for 'used' derived types */
2213 dtz.avl++;
2214 NEED(dtz.avl, dtz.base, DITEM, dtz.sz, dtz.sz + 64);
2215 pd = dtz.base + (dtz.avl - 1);
2216 pd->dtypeinstalled = FALSE;
2217
2218 pd->id = get_num(10);
2219 insertdthash(pd->id, dtz.avl - 1);
2220 stype = get_num(10);
2221 offset = get_num(10);
2222 get_string(module_name);
2223 get_string(rename_name);
2224 /* look for a symbol with name 'rename' in a module with
2225 * name 'module_name' and STYPE of 'stype' */
2226 module_sym = findByNameStypeScope(module_name, ST_MODULE, 0);
2227 if (module_sym == 0) {
2228 interrf(ERR_Severe, "import: module %s: not found!", module_name);
2229 continue;
2230 }
2231 rename_sym = find_member_name(rename_name, stype, module_sym, offset);
2232 if (rename_sym == 0) {
2233 interrf(ERR_Severe,
2234 "import: module %s (%d,base=%d) member symbol %s (offset=%d): not found!",
2235 module_name, module_sym, CMEMFG(module_sym), rename_name, offset);
2236 continue;
2237 }
2238 new_id = DTYPEG(rename_sym);
2239 pd->ty = 0;
2240 pd->new_id = new_id;
2241 pd->dtypeinstalled = TRUE;
2242 break;
2243
2244 case 'e': /* data type rename line, for 'used' derived types */
2245 dtz.avl++;
2246 NEED(dtz.avl, dtz.base, DITEM, dtz.sz, dtz.sz + 64);
2247 pd = dtz.base + (dtz.avl - 1);
2248 pd->dtypeinstalled = FALSE;
2249
2250 pd->id = get_num(10);
2251 insertdthash(pd->id, dtz.avl - 1);
2252 stype = get_num(10);
2253 scope_stype = get_num(10);
2254 get_string(module_name);
2255 get_string(rename_name);
2256 /* look for a symbol with name 'rename' in a module with
2257 * name 'module_name' and STYPE of 'stype' */
2258 scope_sym = findByNameStypeScope(module_name, scope_stype, 0);
2259 if (scope_sym == 0) {
2260 interrf(ERR_Severe, "import: subprogram %s: not found!", module_name);
2261 continue;
2262 }
2263 rename_sym = findByNameStypeScope(rename_name, stype, scope_sym);
2264 if (rename_sym == 0) {
2265 interrf(ERR_Severe, "import: subprogram %s (%d) symbol %s: not found!",
2266 module_name, scope_sym, rename_name);
2267 continue;
2268 }
2269 new_id = DTYPEG(rename_sym);
2270 pd->ty = 0;
2271 pd->new_id = new_id;
2272 pd->dtypeinstalled = TRUE;
2273 break;
2274
2275 case 'E': /* equivalence line */
2276 /* E private lineno sptr substring [subscripts] -1 */
2277 if (sem.interface == 0) {
2278 j = get_num(10); /* is it private */
2279 if (!ignore_private || wantPrivates == INCLUDE_PRIVATES || j == 0) {
2280 ITEM *lastitemp;
2281 int ss, numss, ess;
2282 evp = sem.eqv_avail;
2283 ++sem.eqv_avail;
2284 NEED(sem.eqv_avail, sem.eqv_base, EQVV, sem.eqv_size,
2285 sem.eqv_size + 20);
2286
2287 if (last_evp) {
2288 EQV(last_evp).next = evp;
2289 } else {
2290 first_evp = evp;
2291 }
2292 EQV(evp).next = 0;
2293 EQV(evp).ps = 0;
2294 EQV(evp).lineno = get_num(10);
2295 EQV(evp).sptr = get_num(10);
2296 /* set negative to avoid redoing it: */
2297 EQV(evp).is_first = -get_num(10);
2298 EQV(evp).byte_offset = 0;
2299 EQV(evp).substring = get_num(10);
2300 EQV(evp).subscripts = 0;
2301 numss = 0;
2302 do {
2303 ss = get_num(10);
2304 if (ss >= 0) {
2305 Trace(("Equivalence subscript for sym %d at ast %d",
2306 EQV(evp).sptr, ss));
2307 if (numss == 0) {
2308 ess = sem.eqv_ss_avail;
2309 sem.eqv_ss_avail += 2;
2310 NEED(sem.eqv_ss_avail, sem.eqv_ss_base, int, sem.eqv_ss_size,
2311 sem.eqv_ss_size + 50);
2312 EQV(evp).subscripts = ess;
2313 numss = 1;
2314 } else {
2315 ++sem.eqv_ss_avail;
2316 NEED(sem.eqv_ss_avail, sem.eqv_ss_base, int, sem.eqv_ss_size,
2317 sem.eqv_ss_size + 50);
2318 ++numss;
2319 }
2320 EQV_NUMSS(ess) = numss;
2321 EQV_SS(ess, numss - 1) = ss;
2322 }
2323 } while (ss > 0);
2324 last_evp = evp;
2325 }
2326 }
2327 break;
2328
2329 case 'F': /* formal arguments: subprogram cnt arg ... */
2330 sptr = get_num(10); /* function sptr */
2331 i = get_num(10); /* number of arguments */
2332 j = flz.avl;
2333 flz.avl += (i + 2);
2334 NEED(flz.avl, flz.base, int, flz.sz, flz.avl + 32);
2335 pf = flz.base + j;
2336 *pf++ = sptr;
2337 *pf++ = i;
2338 while (i--)
2339 *pf++ = get_num(10);
2340 break;
2341
2342 case 'L': /* storage overlap list */
2343 sptr = get_num(10);
2344 if (previoussymbol && previoussymbol->sptr == sptr) {
2345 ps = previoussymbol; /* should be here */
2346 } else {
2347 ps = findhash(sptr);
2348 }
2349 /* overlap list line must follow symbol line */
2350 if (!ps)
2351 break;
2352 ps->socptr = soc.avail;
2353 ovlp = get_num(10);
2354 while (ovlp > 0) {
2355 /* link the list forwards */
2356 NEED(soc.avail + 1, soc.base, SOC_ITEM, soc.size, soc.size + 1000);
2357 SOC_SPTR(soc.avail) = ovlp;
2358 SOC_NEXT(soc.avail) = soc.avail + 1;
2359 ++soc.avail;
2360 ovlp = get_num(10);
2361 }
2362 /* unlink the last one entered */
2363 SOC_NEXT(soc.avail - 1) = 0;
2364 break;
2365
2366 case 'm': /* mr for ACCROUT info, mt for DEVTYPE info */
2367 break;
2368
2369 case 'M': /* mangled derived symbols: derived cnt symbols ... */
2370 sptr = get_num(10); /* derived sptr */
2371 /*
2372 * get the number of mangled symbols - careful, the number of
2373 * symbols present is actually three times this number.
2374 */
2375 i = get_num(10);
2376 j = mdz.avl;
2377 mdz.avl += (MN_NENTRIES * i + 2);
2378 NEED(mdz.avl, mdz.base, int, mdz.sz, mdz.avl + 32);
2379 pf = mdz.base + j;
2380 *pf++ = sptr;
2381 *pf++ = i;
2382 while (i--) {
2383 READ_LZLINE;
2384 *pf++ = get_num(10); /* mangled - MN_SPTR */
2385 *pf++ = get_num(10); /* member - MN_MEM */
2386 }
2387 break;
2388
2389 case 'O': /* overloaded functions: generic/operator cnt function ... */
2390 sptr = get_num(10); /* generic sptr */
2391 i = get_num(10); /* number of overloaded functions */
2392 j = ovz.avl;
2393 ovz.avl += (i + 2);
2394 NEED(ovz.avl, ovz.base, int, ovz.sz, ovz.avl + 32);
2395 pf = ovz.base + j;
2396 *pf++ = sptr;
2397 *pf++ = i;
2398 while (i--)
2399 *pf++ = get_num(10);
2400 break;
2401
2402 case 'P': /* module predeclared (ST_HL, ST_HLL) is predeclared (ST_PD) */
2403 sptr = get_num(10);
2404 STYPEP(sptr, ST_PD);
2405 break;
2406
2407 case 'Q': /* module procedures: generic/operator ... */
2408 sptr = get_num(10); /* module procedure sptr */
2409 j = modpz.avl++;
2410 NEED(modpz.avl, modpz.base, MODPITEM, modpz.sz, modpz.avl + 32);
2411 modpz.base[j].modp = sptr;
2412 modpz.base[j].syml = 0;
2413 while (TRUE) {
2414 int s;
2415 s = get_num(10);
2416 if (s == 0)
2417 break;
2418 modpz.base[j].syml = add_symitem(s, modpz.base[j].syml);
2419 }
2420 break;
2421
2422 case 'R': /* symbol rename line, for 'used' modules */
2423 sptr = get_num(10);
2424 stype = get_num(10);
2425 offset = get_num(10) - 1;
2426 get_string(module_name);
2427 get_string(rename_name);
2428 get_string(scope_name);
2429 /* look for a symbol with name 'rename' in a module with
2430 * name 'module_name' and STYPE of 'stype' */
2431 module_sym = findByNameStypeScope(module_name, ST_MODULE, 0);
2432 if (module_sym == 0) {
2433 interrf(ERR_Severe, "import: module %s: not found!", module_name);
2434 continue;
2435 }
2436 if (offset < 0 && strlen(scope_name) != 0 &&
2437 strcmp(scope_name, ".") != 0) {
2438 int tsym = find_member_name(scope_name, ST_TYPEDEF, module_sym, -1);
2439 if (tsym) {
2440 module_sym = tsym;
2441 }
2442 }
2443 rename_sym = find_member_name(rename_name, stype, module_sym, offset);
2444 if (rename_sym == 0) {
2445 interrf(ERR_Severe,
2446 "import: module %s (%d,base=%d) member symbol %s (offset=%d): not found!",
2447 module_name, module_sym, CMEMFG(module_sym), rename_name, offset);
2448 continue;
2449 }
2450 ps = (SYMITEM *)getitem(MOD_AREA, sizeof(SYMITEM));
2451 BZERO(ps, SYMITEM, 1);
2452 Trace(("Add renamed symbol %d to symbol list", sptr));
2453 last_symitem->next = ps;
2454 last_symitem = ps;
2455 ps->next = NULL;
2456 ps->sptr = sptr;
2457 ps->new_sptr = rename_sym;
2458 ps->sc = -1; /* don't change this symbol, already done */
2459 inserthash(sptr, ps);
2460 break;
2461
2462 case 'S': /* symbol definition line */
2463 sptr = get_num(10);
2464 qs = findhash(sptr);
2465 if (qs) {
2466 Trace(("Symbol %d(%s) already in symbol list as %s\n", sptr, qs->name,
2467 stb.stypes[qs->stype]));
2468 if (qs->stype != ST_UNKNOWN)
2469 goto skip_sym;
2470 ps = qs;
2471 } else {
2472 ps = (SYMITEM *)getitem(MOD_AREA, sizeof(SYMITEM));
2473 BZERO(ps, SYMITEM, 1);
2474 Trace(("Add symbol %d to symbol list", sptr));
2475 last_symitem->next = ps;
2476 last_symitem = ps;
2477 ps->next = NULL;
2478 inserthash(sptr, ps);
2479 }
2480 previoussymbol = ps;
2481 ps->name[0] = '\0'; /* no name */
2482 ps->sptr = sptr;
2483 ps->stype = get_num(10);
2484 ps->sc = get_num(10);
2485 ps->sym.b3 = get_num(10);
2486 ps->sym.b4 = get_num(10);
2487 ps->dtype = get_num(10);
2488 ps->symlk = get_num(10);
2489 ps->sym.scope = get_num(10);
2490 ps->sym.nmptr = get_num(10);
2491 ps->flags1 = get_num(16);
2492 ps->flags2 = get_num(16);
2493
2494 #undef GETFIELD
2495 #define GETFIELD(f) ps->sym.f = get_num(10)
2496 if (currp[1] == 'A') {
2497 /*
2498 * New flags & fields were added for IVSN 26. exterf prefixed
2499 * the new set of flags & fields with ' A'. So if ' A' is
2500 * present, read the new fields; otherwise, an old version of
2501 * the .mod file is being read.
2502 *
2503 * IVSN 26 flags & fields:
2504 */
2505 currp += 2; /* skip passed ' A' */
2506 ps->flags3 = get_num(16);
2507 GETFIELD(w34);
2508 GETFIELD(w35);
2509 GETFIELD(w36);
2510 }
2511 if (currp[1] == 'B') {
2512 /*
2513 * New flags & fields were added for IVSN 28. exterf prefixed
2514 * the new set of flags & fields with ' B'. So if ' B' is
2515 * present, read the new fields; otherwise, an old version of
2516 * the .mod file is being read.
2517 *
2518 * IVSN 28 flags & fields:
2519 */
2520 currp += 2; /* skip passed ' B' */
2521 ps->flags4 = get_num(16);
2522 GETFIELD(lineno);
2523 GETFIELD(w39);
2524 GETFIELD(w40);
2525 }
2526 GETFIELD(w9);
2527 GETFIELD(w10);
2528 GETFIELD(w11);
2529 GETFIELD(w12);
2530 GETFIELD(w13);
2531 GETFIELD(w14);
2532 GETFIELD(w15);
2533 GETFIELD(w16);
2534 GETFIELD(w17);
2535 GETFIELD(w18);
2536 GETFIELD(w19);
2537 GETFIELD(w20);
2538 GETFIELD(w21);
2539 GETFIELD(w22);
2540 GETFIELD(w23);
2541 GETFIELD(w24);
2542 GETFIELD(w25);
2543 GETFIELD(w26);
2544 GETFIELD(w27);
2545 GETFIELD(w28);
2546 GETFIELD(uname);
2547 GETFIELD(w30);
2548 GETFIELD(w31);
2549 GETFIELD(w32);
2550 #undef GETFIELD
2551 ps->new_sptr = 0;
2552 ps->strptr = NULL;
2553
2554 Trace(("Importing symbol %d with stype %d", ps->sptr, ps->stype));
2555
2556 /* read additional tokens from line depending on symbol type: */
2557
2558 switch (ps->stype) {
2559 case ST_CONST:
2560 ps->ty = get_num(10);
2561 if (ivsn < 34)
2562 ps->ty = adjust_pre34_dty(ps->ty);
2563 switch (ps->ty) {
2564 case TY_BINT:
2565 case TY_SINT:
2566 case TY_INT:
2567 case TY_INT8:
2568 case TY_BLOG:
2569 case TY_SLOG:
2570 case TY_LOG:
2571 case TY_LOG8:
2572 case TY_REAL:
2573 case TY_CMPLX:
2574 case TY_DBLE:
2575 case TY_QUAD:
2576 case TY_NCHAR:
2577 case TY_DCMPLX:
2578 case TY_QCMPLX:
2579 if (ps->sym.nmptr) {
2580 get_string(ps->name);
2581 }
2582 break;
2583 case TY_CHAR:
2584 stringlen = get_num(10);
2585 ps->strptr = (char *)getitem(MOD_AREA, stringlen + 1);
2586 for (i = 0; i < stringlen; i++)
2587 ps->strptr[i] = get_num(16);
2588 ps->strptr[i] = '\0';
2589 break;
2590 case TY_NONE:
2591 break;
2592 }
2593 break;
2594
2595 case ST_UNKNOWN:
2596 case ST_IDENT:
2597 case ST_PARAM:
2598 case ST_PROC:
2599 case ST_MEMBER:
2600 case ST_STRUCT:
2601 case ST_VAR:
2602 case ST_ARRAY:
2603 case ST_DESCRIPTOR:
2604 case ST_CMBLK:
2605 case ST_ENTRY:
2606 case ST_ALIAS:
2607 case ST_ARRDSC:
2608 case ST_USERGENERIC:
2609 case ST_OPERATOR:
2610 case ST_TYPEDEF:
2611 case ST_STAG:
2612 case ST_MODULE:
2613 case ST_MODPROC:
2614 case ST_PLIST:
2615 case ST_LABEL:
2616 case ST_CONSTRUCT:
2617 case ST_BLOCK:
2618 get_string(ps->name);
2619 break;
2620
2621 case ST_NML:
2622 get_string(ps->name);
2623 prevnml = 0;
2624 while (1) {
2625 READ_LZLINE;
2626 if (p == NULL || p[0] != 'N') {
2627 error(4, 0, gbl.lineno, import_corrupt_msg, import_file_name);
2628 }
2629 currp++;
2630 nmlsptr = get_num(10);
2631 nmlline = get_num(10);
2632 if (nmlsptr < 0)
2633 break;
2634 nml = aux.nml_avl++;
2635 NEED(aux.nml_avl, aux.nml_base, NMLDSC, aux.nml_size,
2636 aux.nml_size + 100);
2637 NML_SPTR(nml) = nmlsptr;
2638 NML_NEXT(nml) = 0;
2639 NML_LINENO(nml) = nmlline;
2640 if (prevnml) {
2641 NML_NEXT(prevnml) = nml;
2642 } else {
2643 /* stash it */
2644 ps->ty = nml;
2645 }
2646 prevnml = nml;
2647 }
2648 break;
2649
2650 default:
2651 interr("import:unrec stype", ps->stype, 3);
2652 i = 0;
2653 }
2654 if (exportb.hmark.maxsptr < ps->sptr)
2655 exportb.hmark.maxsptr = ps->sptr; /* max (old) sptr read */
2656 skip_sym:
2657 break;
2658
2659 case 'T': /* shape record: cnt, <lwb : upb : stride> ... */
2660 i = shdz.avl++;
2661 NEED(shdz.avl, shdz.base, SHDITEM, shdz.sz, shdz.sz + 64);
2662 pa->shape = i;
2663 p_shd = shdz.base + i;
2664 j = get_num(10);
2665 p_shd->ndim = j;
2666 for (i = 0; i < j; i++) {
2667 p_shd->shp[i].lwb = get_num(10);
2668 p_shd->shp[i].upb = get_num(10);
2669 p_shd->shp[i].stride = get_num(10);
2670 }
2671 p_shd->new = 0;
2672 break;
2673
2674 case 'V': /* std record: std, ast, label, lineno, flags */
2675 i = stdz.avl++;
2676 NEED(stdz.avl, stdz.base, STDITEM, stdz.sz, stdz.sz + 64);
2677 p_std = stdz.base + i;
2678 p_std->old = get_num(10);
2679 p_std->ast = get_num(10);
2680 p_std->label = get_num(10);
2681 p_std->lineno = get_num(10);
2682 p_std->flags = get_num(16);
2683 p_std->new = i;
2684 break;
2685
2686 case 'W': /* argt record: cnt, args ... */
2687 i = argtz.avl++;
2688 NEED(argtz.avl, argtz.base, ARGTITEM, argtz.sz, argtz.sz + 64);
2689 /* ARGT record follows an AST record */
2690 pa->list = i;
2691 p_argt = argtz.base + i;
2692 p_argt->callfg = 0;
2693 j = get_num(10);
2694 /*
2695 * allocate the space for the argt; copy in the 'old' values
2696 * and we'll fix up when references occur.
2697 */
2698 p_argt->new = mk_argt(j);
2699 for (i = 0; i < j; i++)
2700 ARGT_ARG(p_argt->new, i) = get_num(10);
2701 p_argt->installed = FALSE;
2702 break;
2703
2704 case 'X': /* asd record: ndim, subs ... */
2705 i = asdz.avl++;
2706 NEED(asdz.avl, asdz.base, ASDITEM, asdz.sz, asdz.sz + 64);
2707 p_asd = asdz.base + i;
2708 p_asd->ndim = get_num(10);
2709 /* ASD record follows an AST record */
2710 pa->list = i;
2711 /*
2712 * stash the 'old' values of the subscripts and we'll fix up
2713 * when references occur.
2714 */
2715 for (i = 0; i < p_asd->ndim; i++)
2716 p_asd->subs[i] = get_num(10);
2717 p_asd->installed = FALSE;
2718 break;
2719
2720 case 'Y': /* astli record:
2721 * <sptr, triple>... -1
2722 */
2723 i = astliz.avl++;
2724 NEED(astliz.avl, astliz.base, ASTLIITEM, astliz.sz, astliz.sz + 64);
2725 p_astli = astliz.base + i;
2726 /* ASTLI record follows an AST record */
2727 pa->list = i;
2728 /*
2729 * allocate the space for the astli; copy in the 'old' values
2730 * and we'll fix up when references occur.
2731 */
2732 start_astli();
2733 while (TRUE) {
2734 j = get_num(10);
2735 if (j < 0)
2736 break;
2737 i = add_astli();
2738 ASTLI_SPTR(i) = j; /* already got the damn thing */
2739 ASTLI_TRIPLE(i) = get_num(10);
2740 ASTLI_FLAGS(i) = 0;
2741 }
2742 p_astli->new = ASTLI_HEAD;
2743 p_astli->installed = FALSE;
2744 break;
2745
2746 case 'Z': /* EOF */
2747 goto exit_loop;
2748
2749 default:
2750 Trace(("unrecognized line in file %s: %s", import_file_name, p));
2751 interr("import: unrec line", p[0], 4);
2752 }
2753 }
2754
2755 exit_loop:
2756 symbol_list = symbol_list->next;
2757
2758 any_ptr_constant = FALSE;
2759 if (for_module) {
2760 /* install all simple constant symbols first */
2761 for (ps = symbol_list; ps != NULL; ps = ps->next) {
2762 if (ps->stype == ST_CONST)
2763 import_constant(ps);
2764 }
2765 module_base = stb.stg_avail;
2766 }
2767 /* install all symbols */
2768 for (ps = symbol_list; ps != NULL; ps = ps->next) {
2769 if (!for_module && ps->stype == ST_CONST) {
2770 import_constant(ps);
2771 } else if (ps->new_sptr == 0 && ps->sc >= 0) {
2772 import_symbol(ps);
2773 }
2774 if (for_module && sem.scope_stack) {
2775 switch (ps->stype) {
2776 case ST_DESCRIPTOR:
2777 if (stb.curr_scope != curr_scope()->sptr &&
2778 DLLG(ps->new_sptr) == DLL_EXPORT && CLASSG(ps->new_sptr) &&
2779 SCG(ps->new_sptr) == SC_EXTERN) {
2780 /* import type descriptor */
2781 DLLP(ps->new_sptr, DLL_IMPORT);
2782 }
2783 break;
2784 case ST_ENTRY:
2785 case ST_PROC:
2786 if (stb.curr_scope != curr_scope()->sptr &&
2787 SCG(ps->new_sptr) == SC_EXTERN &&
2788 DLLG(ps->new_sptr) == DLL_EXPORT) {
2789 DLLP(ps->new_sptr, DLL_IMPORT);
2790 }
2791 case ST_CMBLK:
2792 if (stb.curr_scope != curr_scope()->sptr &&
2793 DLLG(ps->new_sptr) == DLL_EXPORT) {
2794 DLLP(ps->new_sptr, DLL_IMPORT);
2795 }
2796 break;
2797 case ST_IDENT:
2798 case ST_VAR:
2799 case ST_ARRAY:
2800 case ST_STRUCT:
2801 if (stb.curr_scope != curr_scope()->sptr &&
2802 SCG(ps->new_sptr) == SC_CMBLK && DLLG(ps->new_sptr) == DLL_EXPORT) {
2803 DLLP(ps->new_sptr, DLL_IMPORT);
2804 }
2805 break;
2806 }
2807 }
2808 }
2809 if (for_module) {
2810 if (any_ptr_constant) {
2811 for (ps = symbol_list; ps != NULL; ps = ps->next) {
2812 if (ps->stype == ST_CONST)
2813 import_ptr_constant(ps);
2814 }
2815 }
2816 CMEMFP(for_module, module_base);
2817 }
2818 BZERO(stb.stg_base, SYM, 1);
2819 /* postprocess imported symbols */
2820 for (ps = symbol_list; ps != NULL; ps = ps->next) {
2821 if (ps->sc >= 0) {
2822 fill_links_symbol(ps, wantPrivates);
2823 }
2824 }
2825
2826 new_dtypes();
2827
2828 new_asts();
2829 old_astversion = FALSE;
2830
2831 if (for_static) {
2832 /* read the data initialization info, change the symbol pointers,
2833 * and write it to the real data initialization file */
2834 while (1) {
2835 int ptype, lineno, anyivl, anyict;
2836 INT pcon;
2837 READ_LZLINE;
2838 if (p == NULL) {
2839 error(4, 0, gbl.lineno, import_corrupt_msg, import_file_name);
2840 }
2841 ++currp;
2842 if (p[0] == 'Z')
2843 break;
2844 switch (p[0]) {
2845 case 'I': /* initialization info */
2846 ptype = get_num(10);
2847 pcon = get_num(16);
2848 put_dinit_record(ptype, pcon);
2849 break;
2850 case 'J': /* data initialization file record */
2851 lineno = get_num(10);
2852 anyivl = get_num(10);
2853 anyict = get_num(10);
2854 put_data_statement(lineno, anyivl, anyict, fdlz, import_file_name, 0);
2855 break;
2856 case 'V': /* varref record */
2857 case 'W': /* varref subtype record */
2858 case 'D': /* dostart record */
2859 case 'E': /* doend record */
2860 case 'A': /* ict ast record */
2861 case 'S': /* ict subtype record */
2862 default:
2863 /* bad file */
2864 error(4, 0, gbl.lineno, import_corrupt_msg, import_file_name);
2865 break;
2866 } /* switch p[0] */
2867 } /* while */
2868 } else if (for_module) {
2869 /* read the data initialization info, change the symbol pointers,
2870 * and rebuild the IVL/ACL initialization structs */
2871 while (1) {
2872 int ptype, lineno, anyivl, anyict;
2873 INT pcon;
2874 READ_LZLINE;
2875 if (p == NULL) {
2876 error(4, 0, gbl.lineno, import_corrupt_msg, import_file_name);
2877 }
2878 ++currp;
2879 if (p[0] == 'Z')
2880 break;
2881 switch (p[0]) {
2882 case 'I': /* initialization info */
2883 /* ignore the I entries, just consume them */
2884 ptype = get_num(10);
2885 pcon = get_num(16);
2886 break;
2887 case 'J': /* data initialization file record */
2888 lineno = get_num(10);
2889 anyivl = get_num(10);
2890 anyict = get_num(10);
2891 put_data_statement(lineno, anyivl, anyict, fdlz, import_file_name, 0);
2892 break;
2893 case 'T': /* derived type component init */
2894 get_component_init(fdlz, import_file_name, p, 0);
2895 break;
2896 case 'V': /* varref record */
2897 case 'W': /* varref subtype record */
2898 case 'D': /* dostart record */
2899 case 'E': /* doend record */
2900 case 'A': /* ict ast record */
2901 case 'S': /* ict subtype record */
2902 default:
2903 /* bad file */
2904 error(4, 0, gbl.lineno, import_corrupt_msg, import_file_name);
2905 break;
2906 } /* switch p[0] */
2907 } /* while */
2908 }
2909
2910 /* fill in asts & symbols for equivalences; also, add equivalences to
2911 * semant's equivalence list.
2912 */
2913 for (evp = first_evp; evp != 0; evp = EQV(evp).next) {
2914 int ss, numss, j;
2915 EQV(evp).sptr = new_symbol(EQV(evp).sptr);
2916 if (EQV(evp).substring) {
2917 EQV(evp).substring = new_ast(EQV(evp).substring);
2918 EQV(evp)
2919 .byte_offset = get_int_cval(A_SPTRG(A_ALIASG(EQV(evp).substring)));
2920 }
2921 ss = EQV(evp).subscripts;
2922 if (ss > 0) {
2923 numss = EQV_NUMSS(ss);
2924 for (j = 0; j < numss; ++j) {
2925 EQV_SS(ss, j) = new_ast(EQV_SS(ss, j));
2926 Trace(("equivalence subscript for new symbol %d at new ast %d",
2927 EQV(evp).sptr, EQV_SS(ss, j)));
2928 /* subscripts must be a constant, or would have gotten an error */
2929 if (A_TYPEG(EQV_SS(ss, j)) != A_CNST) {
2930 Trace(("UNKNOWN EQUIVALENCE IMPORTED"));
2931 }
2932 }
2933 }
2934 }
2935 /* link in list of equivalences */
2936 if (first_evp) {
2937 EQV(last_evp).next = sem.eqvlist;
2938 sem.eqvlist = first_evp;
2939 }
2940
2941 /* Fix up formal argument (parameter) descriptors. Mimic the semantic
2942 * actions needed to create a subprogram/function ST_PROC within an
2943 * interface block; this implies that the arguments are created in another
2944 * scope.
2945 */
2946 pf = flz.base;
2947 for (j = 0; j < flz.avl;) {
2948 sptr = *pf++; /* function/subroutine (old) sptr */
2949 sptr = new_symbol(sptr);
2950 dscptr = ++aux.dpdsc_avl; /* one more for implicit argument */
2951 DPDSCP(sptr, dscptr);
2952 i = *pf++; /* # of arguments */
2953 PARAMCTP(sptr, i);
2954 aux.dpdsc_avl += i;
2955 NEED(aux.dpdsc_avl, aux.dpdsc_base, int, aux.dpdsc_size,
2956 aux.dpdsc_avl + 100);
2957 aux.dpdsc_base[dscptr - 1] = 0;
2958 j += (i + 2);
2959 while (i--) {
2960 int s;
2961 s = *pf++; /* argument (old) sptr */
2962 if (s) {
2963 s = new_symbol(s);
2964 {
2965 HIDDENP(s, 1);
2966 IGNOREP(s, 1);
2967 }
2968 }
2969 aux.dpdsc_base[dscptr++] = s;
2970 }
2971 }
2972
2973 /* Fix up overloaded function (generic) descriptors. */
2974
2975 pf = ovz.base;
2976 for (j = 0; j < ovz.avl;) {
2977 int s;
2978 int oldcnt;
2979 sptr = *pf++; /* generic/operator (old) sptr */
2980 sptr = new_symbol(sptr);
2981
2982 i = *pf++; /* # of functions */
2983 oldcnt = GNCNTG(sptr);
2984 GNCNTP(sptr, oldcnt + i);
2985 j += (i + 2);
2986 dscptr = GNDSCG(sptr);
2987 while (i--) {
2988 s = *pf++; /* function (old) sptr */
2989 s = new_symbol(s);
2990 if (STYPEG(s) == ST_MODPROC && SYMLKG(s))
2991 s = SYMLKG(s);
2992 if (STYPEG(s) == ST_ALIAS)
2993 s = SYMLKG(s);
2994 dscptr = add_symitem(s, dscptr);
2995 }
2996 GNDSCP(sptr, dscptr);
2997 if (STYPEG(sptr) == ST_USERGENERIC) {
2998 if (GSAMEG(sptr)) {
2999 s = new_symbol(GSAMEG(sptr));
3000 if (STYPEG(s) == ST_MODPROC && SYMLKG(s) > NOSYM)
3001 s = SYMLKG(s);
3002 if (STYPEG(s) == ST_ALIAS)
3003 s = SYMLKG(s);
3004 GSAMEP(sptr, s);
3005 GSAMEP(s, sptr);
3006 }
3007 if (GTYPEG(sptr)) {
3008 s = new_symbol(GTYPEG(sptr));
3009 GTYPEP(sptr, s);
3010 }
3011 }
3012 }
3013
3014 /* Fix up module procedure descriptors. */
3015
3016 for (j = 0; j < modpz.avl; j++) {
3017 for (i = modpz.base[j].syml; i; i = SYMI_NEXT(i)) {
3018 int s;
3019 s = SYMI_SPTR(i);
3020 SYMI_SPTR(i) = new_symbol(s);
3021 }
3022 sptr = new_symbol(modpz.base[j].modp);
3023 SYMIP(sptr, modpz.base[j].syml);
3024 }
3025
3026 /* fix up statements (stds) */
3027
3028 if (!for_module && !for_host)
3029 new_stds();
3030
3031 FREE(dtz.base);
3032 FREE(flz.base);
3033 FREE(ovz.base);
3034 FREE(mdz.base);
3035 FREE(astz.base);
3036 FREE(stdz.base);
3037 FREE(shdz.base);
3038 FREE(argtz.base);
3039 FREE(asdz.base);
3040 FREE(astliz.base);
3041 FREE(modpz.base);
3042 original_symavl = 0;
3043
3044 #if DEBUG
3045 if (DBGBIT(5, 0x800)) {
3046 fprintf(gbl.dbgfil, "****** After Importing %s ******\n", import_file_name);
3047 symdmp(gbl.dbgfil, 0);
3048 }
3049 #endif
3050 dtype_ivsn = save_dtype_ivsn;
3051 }
3052
3053 static char *
read_line(FILE * fd)3054 read_line(FILE *fd)
3055 {
3056 int i;
3057 int ch;
3058
3059 i = 0;
3060 while (TRUE) {
3061 ch = getc(fd);
3062 if (ch == EOF)
3063 return NULL;
3064 if (i + 1 >= buff_sz) {
3065 buff_sz += BUFF_LEN;
3066 buff = sccrelal(buff, buff_sz);
3067 }
3068 buff[i++] = ch;
3069 if (ch == '\n')
3070 break;
3071 }
3072 buff[i] = '\0';
3073 currp = buff;
3074 return buff;
3075 }
3076
3077 int
import_inline(FILE * fd,char * file_name)3078 import_inline(FILE *fd, char *file_name)
3079 {
3080 int saveSym, saveAst, saveDty, saveCmblk, ivsn;
3081 lzhandle *fdlz;
3082 ADJmod = 0;
3083 BASEmod = 0;
3084 BASEsym = stb.firstusym;
3085 BASEast = astb.firstuast;
3086 BASEdty = DT_MAX;
3087 saveSym = stb.stg_avail;
3088 saveAst = astb.stg_avail;
3089 saveDty = stb.dt.stg_avail;
3090 saveCmblk = gbl.cmblks;
3091 fdlz = import_header(fd, file_name, IMPORT_WHICH_INLINE, &ivsn);
3092 if (fdlz) {
3093 import(fdlz, INCLUDE_PRIVATES, ivsn);
3094 }
3095 import_done(fdlz, 0);
3096 fclose(fd);
3097 if (import_errno) {
3098 stb.stg_avail = saveSym;
3099 astb.stg_avail = saveAst;
3100 stb.dt.stg_avail = saveDty;
3101 gbl.cmblks = saveCmblk;
3102 }
3103 #if DEBUG
3104 if (DBGBIT(4, 16384) || DBGBIT(5, 16384)) {
3105 fprintf(gbl.dbgfil, "\n>>>>>> import_line begin\n");
3106 if (DBGBIT(4, 16384))
3107 dump_ast();
3108 if (DBGBIT(5, 16384)) {
3109 symdmp(gbl.dbgfil, DBGBIT(5, 8));
3110 dmp_dtype();
3111 }
3112 fprintf(gbl.dbgfil, "\n>>>>>> import_line end\n");
3113 }
3114 #endif
3115 return import_errno;
3116 }
3117
3118 /** \brief import a routine for static analysis */
3119 int
import_static(FILE * fd,char * file_name)3120 import_static(FILE *fd, char *file_name)
3121 {
3122 lzhandle *fdlz;
3123 int ivsn;
3124 ADJmod = 0;
3125 BASEmod = 0;
3126 BASEsym = stb.firstusym;
3127 BASEast = astb.firstuast;
3128 BASEdty = DT_MAX;
3129 fdlz = import_header(fd, file_name, IMPORT_WHICH_PRELINK, &ivsn);
3130 if (fdlz) {
3131 import(fdlz, INCLUDE_PRIVATES, ivsn);
3132 }
3133 import_done(fdlz, 0);
3134 return import_errno;
3135 } /* import_static */
3136
3137 static int IPARECOMPILE = FALSE;
3138
3139 /** \brief This is called either for a USE statement, or to import the
3140 * specification part of a module for the contained subprograms.
3141 */
3142 SPTR
import_module(FILE * fd,char * file_name,SPTR modsym,WantPrivates wantPrivates,int scope_level)3143 import_module(FILE *fd, char *file_name, SPTR modsym, WantPrivates wantPrivates,
3144 int scope_level)
3145 {
3146 SPTR modulesym;
3147 lzhandle *fdlz;
3148 int savescope = stb.curr_scope, ivsn;
3149 ADJmod = 0;
3150 BASEmod = 0;
3151 BASEsym = stb.firstusym;
3152 BASEast = astb.firstuast;
3153 BASEdty = DT_MAX;
3154 top_scope_level = scope_level;
3155 /* for a USE statement, push the module scope between
3156 * the outer scope and its outer scope */
3157 /* We can't optimize away the 'import_header' even if the
3158 * module is already used; it may have been used with ONLY
3159 * or rename clauses, and the renaming clauses can give any
3160 * name in that module or in modules indirectly used. The only
3161 * way we have to find which names can be used is to put the
3162 * directly and indirectly used modules on the scope stack */
3163 fdlz = import_header(fd, file_name, modsym, &ivsn);
3164 if (fdlz) {
3165 TOBE_IMPORTED_LIST *l;
3166 modulesym = 0;
3167 if (!IPARECOMPILE) {
3168 save_scope_level();
3169 modulesym = alreadyused(SYMNAME(modsym));
3170 if (modulesym != 0) {
3171 push_scope_level(modulesym, SCOPE_USE);
3172 l = find_modname_in_list(SYMNAME(modulesym), use_tree);
3173 } else {
3174 modsym = import_mk_newsym(SYMNAME(modsym), ST_MODULE);
3175 push_scope_level(modsym, SCOPE_USE);
3176 l = find_modname_in_list(SYMNAME(modsym), use_tree);
3177 }
3178 l->sl = sem.scope_level;
3179 restore_scope_level();
3180 }
3181 if (modulesym == 0) {
3182 /* set 'curr_scope' for symbols created when the module is imported */
3183 modulesym = modsym;
3184 stb.curr_scope = modulesym;
3185 import(fdlz, wantPrivates, ivsn);
3186 add_imported(modulesym);
3187 stb.curr_scope = savescope;
3188 }
3189 }
3190 import_done(fdlz, 1);
3191
3192 top_scope_level = 0; /* restore to zero */
3193 return modulesym;
3194 }
3195
3196 void
import_module_end(void)3197 import_module_end(void)
3198 {
3199 }
3200
3201 void
import_module_print(void)3202 import_module_print(void)
3203 {
3204 if (modinclistavl > 0) {
3205 int m, c;
3206 char *fname;
3207 FILE *fp;
3208 if (!XBIT(123, 0x20000)) {
3209 fp = stdout;
3210 } else {
3211 char *f, *g;
3212 /* leave enough room for '.m' */
3213 fname = (char *)sccalloc(strlen(gbl.src_file) + 3);
3214 basenam(gbl.src_file, "", fname);
3215 g = NULL;
3216 for (f = fname; *f; ++f) {
3217 if (*f == '.')
3218 g = f;
3219 }
3220 if (!g)
3221 g = f; /* last char in string */
3222 *g++ = '.';
3223 *g++ = 'm';
3224 *g = '\0';
3225 fp = fopen(fname, "w");
3226 if (fp == NULL) {
3227 error(213, 4, 0, fname, CNULL);
3228 }
3229 }
3230 c = fprintf(fp, "%s :", gbl.src_file);
3231 for (m = 0; m < modinclistavl; ++m) {
3232 if (c + strlen(modinclist[m]) >= 80) {
3233 fprintf(fp, " \\\n ");
3234 c = 3;
3235 }
3236 c += fprintf(fp, " %s", modinclist[m]);
3237 }
3238 fprintf(fp, "\n");
3239 }
3240 }
3241
3242 /** \brief This is called to restore symbol table, etc., data for contained
3243 * subprograms.
3244 */
3245 void
import_host(FILE * fd,char * file_name,int oldsymavl,int oldastavl,int olddtyavl,int modbase,int moddiff,int oldscope,int newscope)3246 import_host(FILE *fd, char *file_name, int oldsymavl, int oldastavl,
3247 int olddtyavl, int modbase, int moddiff, int oldscope, int newscope)
3248 {
3249 lzhandle *fdlz;
3250 int ivsn;
3251 for_host = TRUE;
3252 /* push the a 'NORMAL' outer scope */
3253 ADJmod = moddiff;
3254 BASEmod = modbase;
3255 BASEsym = oldsymavl;
3256 BASEast = oldastavl;
3257 BASEdty = olddtyavl;
3258 HOST_OLDSCOPE = oldscope;
3259 HOST_NEWSCOPE = newscope;
3260 fdlz = import_header(fd, file_name, IMPORT_WHICH_HOST, &ivsn);
3261 if (fdlz) {
3262 import(fdlz, INCLUDE_PRIVATES, ivsn);
3263 }
3264 import_done(fdlz, 1);
3265 for_host = FALSE;
3266 HOST_OLDSCOPE = 0;
3267 HOST_NEWSCOPE = 0;
3268 }
3269
3270 extern void export_fix_host_append_list(int (*)(int));
3271
3272 /** \brief This is called to restore symbol table, etc., data for contained
3273 * subprograms.
3274 */
3275 void
import_host_subprogram(FILE * fd,char * file_name,int oldsymavl,int oldastavl,int olddtyavl,int modbase,int moddiff)3276 import_host_subprogram(FILE *fd, char *file_name, int oldsymavl, int oldastavl,
3277 int olddtyavl, int modbase, int moddiff)
3278 {
3279 lzhandle *fdlz;
3280 int ivsn;
3281 for_host = TRUE;
3282 /* push the a 'NORMAL' outer scope */
3283 ADJmod = moddiff;
3284 BASEmod = modbase;
3285 BASEsym = oldsymavl;
3286 BASEast = oldastavl;
3287 BASEdty = olddtyavl;
3288 fdlz = import_header(fd, file_name, IMPORT_WHICH_HOST, &ivsn);
3289 if (fdlz) {
3290 import(fdlz, INCLUDE_PRIVATES, ivsn);
3291 }
3292 export_fix_host_append_list(new_symbol);
3293 import_done(fdlz, 1);
3294 for_host = FALSE;
3295 } /* import_host_subprogram */
3296
3297 static ISZ_T
get_num(int radix)3298 get_num(int radix)
3299 {
3300 char *chp;
3301 ISZ_T val = 0;
3302 INT num[2];
3303
3304 while (*currp == ' ')
3305 currp++;
3306 if (*currp == '\n')
3307 return 0;
3308 chp = currp;
3309 while (*currp != ' ' && *currp != '\n' && *currp != '\0' && *currp != ':')
3310 currp++;
3311 /*
3312 * atoxi64 will 'fail' if it doesn't find a number in which case
3313 * num is not set; need to ensure that val remains 0.
3314 */
3315 if (atoxi64(chp, num, (int)(currp - chp), radix) >= 0) {
3316 INT64_2_ISZ(num, val);
3317 }
3318 return val;
3319 }
3320
3321 static void
get_string(char * dest)3322 get_string(char *dest)
3323 {
3324 int i;
3325 char ch;
3326
3327 while (*currp == ' ')
3328 currp++;
3329 i = 0;
3330 while ((ch = *currp) != ' ' && ch != '\n' && ch != '\0') {
3331 dest[i++] = ch;
3332 currp++;
3333 }
3334 dest[i] = '\0';
3335 }
3336
3337 /** \brief read 'len' characters */
3338 static void
get_nstring(char * dest,int len)3339 get_nstring(char *dest, int len)
3340 {
3341 int i;
3342 char ch;
3343
3344 while (*currp == ' ')
3345 currp++;
3346 i = 0;
3347 while (len-- && (ch = *currp) != '\n' && ch != '\0') {
3348 dest[i++] = ch;
3349 currp++;
3350 }
3351 dest[i] = '\0';
3352 }
3353
3354 static char *
getlstring(int area)3355 getlstring(int area)
3356 {
3357 char *p;
3358 int len, i;
3359 char *s;
3360 len = get_num(10);
3361 p = currp;
3362 if (*p != ':') {
3363 return NULL;
3364 }
3365 ++p;
3366 if (len == 0) {
3367 currp = p;
3368 return NULL;
3369 }
3370 s = getitem(area, len + 1);
3371 strncpy(s, p, len);
3372 s[len] = '\0';
3373 p += len;
3374 currp = p;
3375 return s;
3376 } /* getlstring */
3377
3378 static int ipa_ast(int a);
3379 static int dindex(int dtype);
3380 static int get_symbolxref(int sptr);
3381
3382 static int dsize;
3383 static int *dtindex;
3384
3385 /** \brief Change symbol number, if necessary, and write record to data init
3386 * file
3387 */
3388 static void
put_dinit_record(int ptype,INT pcon)3389 put_dinit_record(int ptype, INT pcon)
3390 {
3391 INT sptr;
3392 switch (ptype) {
3393 case DINIT_FMT: /* should not happen */
3394 break;
3395
3396 case DINIT_END: /* write this unchanged */
3397 case DINIT_ENDTYPE: /* write this unchanged */
3398 case DINIT_STARTARY: /* write this unchanged */
3399 case DINIT_ENDARY: /* write this unchanged */
3400 case 0: /* write this unchanged */
3401 case DINIT_ZEROES: /* write this unchanged */
3402 case DINIT_OFFSET: /* write this unchanged */
3403 case DINIT_REPEAT: /* write this unchanged */
3404 dinit_put(ptype, pcon);
3405 break;
3406 case DINIT_STR: /* change symbol number */
3407 case DINIT_NML: /* change symbol number */
3408 case DINIT_LABEL: /* change symbol number */
3409 case DINIT_TYPEDEF: /* change symbol number */
3410 case DINIT_LOC: /* change symbol number */
3411 sptr = new_symbol((int)pcon);
3412 dinit_put(ptype, sptr);
3413 break;
3414 default:
3415 switch (DTY(ptype)) {
3416 case TY_DBLE:
3417 case TY_CMPLX:
3418 case TY_DCMPLX:
3419 case TY_QUAD:
3420 case TY_QCMPLX:
3421 case TY_INT8:
3422 case TY_LOG8:
3423 case TY_CHAR:
3424 case TY_NCHAR:
3425 /* update sptr */
3426 sptr = new_symbol((int)pcon);
3427 dinit_put(ptype, sptr);
3428 break;
3429
3430 case TY_INT: /* actual constant value stays the same */
3431 case TY_SINT: /* actual constant value stays the same */
3432 case TY_BINT: /* actual constant value stays the same */
3433 case TY_LOG: /* actual constant value stays the same */
3434 case TY_SLOG: /* actual constant value stays the same */
3435 case TY_BLOG: /* actual constant value stays the same */
3436 case TY_FLOAT: /* actual constant value stays the same */
3437 case TY_PTR: /* should not happen */
3438 default: /* should not happen */
3439 /* write out unchanged */
3440 dinit_put(ptype, pcon);
3441 break;
3442 } /* switch */
3443 break;
3444 } /* switch */
3445 } /* put_dinit_record */
3446
3447 static VAR *
getivl(lzhandle * fdlz,char * file_name,int ipa)3448 getivl(lzhandle *fdlz, char *file_name, int ipa)
3449 {
3450 char *p;
3451 VAR *first = NULL;
3452 VAR *prev = NULL;
3453 VAR *thisone;
3454 VAR *lastone;
3455 int more;
3456 static int doendmore;
3457
3458 do {
3459 int ast, dtype, id;
3460 int astvar, astlowbd, astupbd, aststep;
3461 VAR *subone;
3462 READ_LZLINE;
3463 if (p == NULL) {
3464 error(4, 0, gbl.lineno, import_corrupt_msg, import_file_name);
3465 }
3466 ++currp;
3467 if (p[0] == 'Z') {
3468 error(4, 0, gbl.lineno, import_corrupt_msg, import_file_name);
3469 break;
3470 }
3471 switch (p[0]) {
3472 case 'V': /* varref: V ast.varref.ptr dtype more */
3473 ast = get_num(10);
3474 dtype = get_num(10);
3475 id = get_num(10);
3476 more = get_num(10);
3477 thisone = (VAR *)getitem(PERM_AREA, sizeof(VAR));
3478 memset(thisone, 0, sizeof(VAR));
3479 thisone->id = Varref;
3480 thisone->next = NULL;
3481 thisone->u.varref.id = id;
3482 thisone->u.varref.subt = NULL;
3483 if (ipa == 1) {
3484 thisone->u.varref.ptr = ast;
3485 thisone->u.varref.dtype = dtype;
3486 } else if (ipa == 2) {
3487 thisone->u.varref.ptr = ipa_ast(ast);
3488 thisone->u.varref.dtype = dindex(dtype);
3489 } else {
3490 thisone->u.varref.ptr = new_ast(ast);
3491 thisone->u.varref.dtype = new_dtype(dtype);
3492 }
3493 lastone = thisone;
3494 break;
3495 case 'W': /* subtype: W dtype more */
3496 dtype = get_num(10);
3497 more = get_num(10);
3498 subone = getivl(fdlz, file_name, ipa);
3499 thisone = (VAR *)getitem(PERM_AREA, sizeof(VAR));
3500 memset(thisone, 0, sizeof(VAR));
3501 thisone->next = NULL;
3502 thisone->id = Varref;
3503 thisone->u.varref.subt = subone;
3504 if (ipa == 1) {
3505 thisone->u.varref.dtype = dtype;
3506 } else if (ipa == 2) {
3507 thisone->u.varref.dtype = dindex(dtype);
3508 } else {
3509 thisone->u.varref.dtype = new_dtype(dtype);
3510 }
3511 lastone = thisone;
3512 break;
3513 case 'D': /* do: D ast.indvar ast.lowbd ast.upbd ast.step more */
3514 astvar = get_num(10);
3515 astlowbd = get_num(10);
3516 astupbd = get_num(10);
3517 aststep = get_num(10);
3518 more = get_num(10);
3519 subone = getivl(fdlz, file_name, ipa);
3520 more = doendmore;
3521 thisone = (VAR *)getitem(PERM_AREA, sizeof(VAR));
3522 memset(thisone, 0, sizeof(VAR));
3523 thisone->id = Dostart;
3524 if (ipa == 1) {
3525 thisone->u.dostart.indvar = astvar;
3526 thisone->u.dostart.lowbd = astlowbd;
3527 thisone->u.dostart.upbd = astupbd;
3528 thisone->u.dostart.step = aststep;
3529 } else if (ipa == 2) {
3530 thisone->u.dostart.indvar = ipa_ast(astvar);
3531 thisone->u.dostart.lowbd = ipa_ast(astlowbd);
3532 thisone->u.dostart.upbd = ipa_ast(astupbd);
3533 thisone->u.dostart.step = ipa_ast(aststep);
3534 } else {
3535 thisone->u.dostart.indvar = new_ast(astvar);
3536 thisone->u.dostart.lowbd = new_ast(astlowbd);
3537 thisone->u.dostart.upbd = new_ast(astupbd);
3538 thisone->u.dostart.step = new_ast(aststep);
3539 }
3540 thisone->next = subone;
3541 for (lastone = subone; lastone->next; lastone = lastone->next)
3542 ;
3543 lastone->next = (VAR *)getitem(PERM_AREA, sizeof(VAR));
3544 lastone = lastone->next;
3545 lastone->id = Doend;
3546 lastone->u.doend.dostart = thisone;
3547 lastone->next = NULL;
3548 break;
3549 case 'E': /* doend: E more */
3550 doendmore = get_num(10);
3551 return first;
3552 default:
3553 error(4, 0, gbl.lineno, import_corrupt_msg, import_file_name);
3554 }
3555 if (prev) {
3556 prev->next = thisone;
3557 } else {
3558 first = thisone;
3559 }
3560 prev = lastone;
3561 } while (more);
3562 return first;
3563 } /* getivl */
3564
3565 static ACL *
getict(lzhandle * fdlz,char * file_name,int ipa)3566 getict(lzhandle *fdlz, char *file_name, int ipa)
3567 {
3568 char *p;
3569 ACL *first = NULL;
3570 ACL *thisone;
3571 ACL *prev = NULL;
3572 int more;
3573 int i;
3574
3575 do {
3576 int op;
3577 int init_ast, limit_ast, step_ast;
3578 int sptr, dtype, ptrdtype, repeatc, is_const, ast;
3579 ACL *subone;
3580 READ_LZLINE;
3581 if (p == NULL) {
3582 error(4, 0, gbl.lineno, import_corrupt_msg, import_file_name);
3583 }
3584 ++currp;
3585 if (p[0] == 'Z') {
3586 error(4, 0, gbl.lineno, import_corrupt_msg, import_file_name);
3587 break;
3588 }
3589 switch (p[0]) {
3590 case 'A': /* ast initializer: A sptr dtype ptrdtype repeat is_const value
3591 more */
3592 sptr = get_num(10);
3593 dtype = get_num(10);
3594 ptrdtype = get_num(10);
3595 repeatc = get_num(10);
3596 is_const = get_num(10);
3597 ast = get_num(10);
3598 more = get_num(10);
3599 thisone = GET_ACL(PERM_AREA);
3600 memset(thisone, 0, sizeof(ACL));
3601 thisone->id = AC_AST;
3602 thisone->subc = NULL;
3603 thisone->next = NULL;
3604 if (ipa == 1) {
3605 thisone->sptr = sptr;
3606 thisone->dtype = dtype;
3607 thisone->ptrdtype = ptrdtype;
3608 thisone->repeatc = repeatc;
3609 thisone->is_const = is_const;
3610 thisone->u1.ast = ast;
3611 } else if (ipa == 2) {
3612 thisone->sptr = get_symbolxref(sptr);
3613 thisone->dtype = dindex(dtype);
3614 thisone->ptrdtype = dindex(ptrdtype);
3615 thisone->repeatc = ipa_ast(repeatc);
3616 thisone->is_const = is_const;
3617 thisone->u1.ast = ipa_ast(ast);
3618 } else {
3619 thisone->sptr = new_symbol(sptr);
3620 thisone->dtype = new_dtype(dtype);
3621 thisone->ptrdtype = new_dtype(ptrdtype);
3622 thisone->repeatc = new_ast(repeatc);
3623 thisone->is_const = is_const;
3624 thisone->u1.ast = new_ast(ast);
3625 }
3626 Trace(("reading ict at %x with ast=%d,repeat=%d", thisone, ast, repeatc));
3627 break;
3628 case 'I': /* ident initializer: I sptr dtype ptrdtype repeat value more */
3629 sptr = get_num(10);
3630 dtype = get_num(10);
3631 ptrdtype = get_num(10);
3632 repeatc = get_num(10);
3633 ast = get_num(10);
3634 more = get_num(10);
3635 thisone = GET_ACL(PERM_AREA);
3636 memset(thisone, 0, sizeof(ACL));
3637 thisone->id = AC_AST;
3638 thisone->subc = NULL;
3639 thisone->next = NULL;
3640 if (ipa == 1) {
3641 thisone->sptr = sptr;
3642 thisone->dtype = dtype;
3643 thisone->ptrdtype = ptrdtype;
3644 thisone->repeatc = repeatc;
3645 thisone->u1.ast = ast;
3646 } else if (ipa == 2) {
3647 thisone->sptr = get_symbolxref(sptr);
3648 thisone->dtype = dindex(dtype);
3649 thisone->ptrdtype = dindex(ptrdtype);
3650 thisone->repeatc = ipa_ast(repeatc);
3651 thisone->u1.ast = ipa_ast(ast);
3652 } else {
3653 thisone->sptr = new_symbol(sptr);
3654 thisone->dtype = new_dtype(dtype);
3655 thisone->ptrdtype = new_dtype(ptrdtype);
3656 thisone->repeatc = new_ast(repeatc);
3657 thisone->u1.ast = new_ast(ast);
3658 }
3659 Trace(("reading ict at %x with ast=%d,repeat=%d", thisone, ast, repeatc));
3660 break;
3661 case 'L': /* literal integer */
3662 i = get_num(10);
3663 more = get_num(10);
3664 thisone = GET_ACL(PERM_AREA);
3665 memset(thisone, 0, sizeof(ACL));
3666 thisone->id = AC_ICONST;
3667 thisone->u1.i = i;
3668 break;
3669 case 'N': /* NULL ROP */
3670 if (first == NULL)
3671 return NULL;
3672 break;
3673 case 'O': /* implied do initializer */
3674 sptr = get_num(10);
3675 init_ast = get_num(10);
3676 limit_ast = get_num(10);
3677 step_ast = get_num(10);
3678 more = get_num(10);
3679 subone = getict(fdlz, file_name, ipa);
3680 thisone = GET_ACL(PERM_AREA);
3681 memset(thisone, 0, sizeof(ACL));
3682 thisone->id = AC_IDO;
3683 thisone->subc = subone;
3684 thisone->next = NULL;
3685 /* alloc do struct */
3686 thisone->u1.doinfo = (DOINFO *)getitem(PERM_AREA, sizeof(DOINFO));
3687 memset(thisone->u1.doinfo, 0, sizeof(DOINFO));
3688 if (ipa == 1) {
3689 thisone->u1.doinfo->index_var = sptr;
3690 thisone->u1.doinfo->init_expr = init_ast;
3691 thisone->u1.doinfo->limit_expr = limit_ast;
3692 thisone->u1.doinfo->step_expr = step_ast;
3693 } else if (ipa == 2) {
3694 thisone->u1.doinfo->index_var = get_symbolxref(sptr);
3695 thisone->u1.doinfo->init_expr = ipa_ast(init_ast);
3696 thisone->u1.doinfo->limit_expr = ipa_ast(limit_ast);
3697 thisone->u1.doinfo->step_expr = ipa_ast(step_ast);
3698 } else {
3699 thisone->u1.doinfo->index_var = new_symbol(sptr);
3700 thisone->u1.doinfo->init_expr = new_ast(init_ast);
3701 thisone->u1.doinfo->limit_expr = new_ast(limit_ast);
3702 thisone->u1.doinfo->step_expr = new_ast(step_ast);
3703 }
3704 break;
3705 case 'P': /* repeat initializer: P sptr dtype ptrdtype value more */
3706 sptr = get_num(10);
3707 dtype = get_num(10);
3708 ptrdtype = get_num(10);
3709 ast = get_num(10);
3710 more = get_num(10);
3711 thisone = GET_ACL(PERM_AREA);
3712 memset(thisone, 0, sizeof(ACL));
3713 thisone->id = AC_AST;
3714 thisone->subc = NULL;
3715 thisone->next = NULL;
3716 if (ipa == 1) {
3717 thisone->sptr = sptr;
3718 thisone->dtype = dtype;
3719 thisone->ptrdtype = ptrdtype;
3720 thisone->u1.ast = ast;
3721 } else if (ipa == 2) {
3722 thisone->sptr = get_symbolxref(sptr);
3723 thisone->dtype = dindex(dtype);
3724 thisone->ptrdtype = dindex(ptrdtype);
3725 thisone->u1.ast = ipa_ast(ast);
3726 } else {
3727 thisone->sptr = new_symbol(sptr);
3728 thisone->dtype = new_dtype(dtype);
3729 thisone->ptrdtype = new_dtype(ptrdtype);
3730 thisone->u1.ast = new_ast(ast);
3731 }
3732 Trace(("reading ict at %x with ast=%d", thisone, ast));
3733 break;
3734 case 'S': /* struct (typedef) initializer sptr dtype ptrdtype repeat more */
3735 sptr = get_num(10);
3736 dtype = get_num(10);
3737 ptrdtype = get_num(10);
3738 repeatc = get_num(10);
3739 more = get_num(10);
3740 subone = getict(fdlz, file_name, ipa);
3741 thisone = GET_ACL(PERM_AREA);
3742 memset(thisone, 0, sizeof(ACL));
3743 thisone->id = AC_SCONST;
3744 thisone->subc = subone;
3745 thisone->next = NULL;
3746 if (ipa == 1) {
3747 thisone->sptr = sptr;
3748 thisone->dtype = dtype;
3749 thisone->ptrdtype = ptrdtype;
3750 thisone->repeatc = repeatc;
3751 } else if (ipa == 2) {
3752 thisone->sptr = get_symbolxref(sptr);
3753 thisone->dtype = dindex(dtype);
3754 thisone->ptrdtype = dindex(ptrdtype);
3755 thisone->repeatc = ipa_ast(repeatc);
3756 } else {
3757 thisone->sptr = new_symbol(sptr);
3758 thisone->dtype = new_dtype(dtype);
3759 thisone->ptrdtype = new_dtype(ptrdtype);
3760 thisone->repeatc = new_ast(repeatc);
3761 }
3762
3763 Trace(("reading Struct ict at %x with sub-ict at %x", thisone, subone));
3764 break;
3765 case 'R': /* Array initializer sptr dtype ptrdtype more */
3766 sptr = get_num(10);
3767 dtype = get_num(10);
3768 ptrdtype = get_num(10);
3769 more = get_num(10);
3770 subone = getict(fdlz, file_name, ipa);
3771 thisone = GET_ACL(PERM_AREA);
3772 memset(thisone, 0, sizeof(ACL));
3773 thisone->id = AC_ACONST;
3774 thisone->subc = subone;
3775 thisone->next = NULL;
3776 if (ipa == 1) {
3777 thisone->sptr = sptr;
3778 thisone->dtype = dtype;
3779 thisone->ptrdtype = ptrdtype;
3780 } else if (ipa == 2) {
3781 thisone->sptr = get_symbolxref(sptr);
3782 thisone->dtype = dindex(dtype);
3783 thisone->ptrdtype = dindex(ptrdtype);
3784 } else {
3785 thisone->sptr = new_symbol(sptr);
3786 thisone->dtype = new_dtype(dtype);
3787 thisone->ptrdtype = new_dtype(ptrdtype);
3788 }
3789 Trace(("reading Array ict at %x with sub-ict at %x", thisone, subone));
3790 break;
3791 case 'U': /* union/struct initializer: U sptr dtype ptrdtype repeat value
3792 more */
3793 case 'V':
3794 case 'T':
3795 sptr = get_num(10);
3796 dtype = get_num(10);
3797 ptrdtype = get_num(10);
3798 repeatc = get_num(10);
3799 ast = get_num(10);
3800 more = get_num(10);
3801 thisone = GET_ACL(PERM_AREA);
3802 memset(thisone, 0, sizeof(ACL));
3803 switch (p[0]) {
3804 case 'U':
3805 thisone->id = AC_VMSUNION;
3806 break;
3807 case 'V':
3808 thisone->id = AC_VMSSTRUCT;
3809 break;
3810 case 'T':
3811 thisone->id = AC_TYPEINIT;
3812 break;
3813 }
3814 subone = getict(fdlz, file_name, ipa);
3815 thisone->subc = subone;
3816 thisone->next = NULL;
3817 if (ipa == 1) {
3818 thisone->sptr = sptr;
3819 thisone->dtype = dtype;
3820 thisone->ptrdtype = ptrdtype;
3821 thisone->repeatc = repeatc;
3822 thisone->u1.ast = ast;
3823 } else if (ipa == 2) {
3824 thisone->sptr = get_symbolxref(sptr);
3825 thisone->dtype = dindex(dtype);
3826 thisone->ptrdtype = dindex(ptrdtype);
3827 thisone->repeatc = ipa_ast(repeatc);
3828 thisone->u1.ast = ipa_ast(ast);
3829 } else {
3830 thisone->sptr = new_symbol(sptr);
3831 thisone->dtype = new_dtype(dtype);
3832 thisone->ptrdtype = new_dtype(ptrdtype);
3833 thisone->repeatc = new_ast(repeatc);
3834 thisone->u1.ast = new_ast(ast);
3835 }
3836 Trace(("reading ict at %x with ast=%d,repeat=%d", thisone, ast, repeatc));
3837 break;
3838 case 'X': /* expression initializer expr->op sptr dtype ptrdtype more*/
3839 op = get_num(10);
3840 sptr = get_num(10);
3841 dtype = get_num(10);
3842 ptrdtype = get_num(10);
3843 repeatc = get_num(10);
3844 thisone = GET_ACL(PERM_AREA);
3845 memset(thisone, 0, sizeof(ACL));
3846 thisone->id = AC_IEXPR;
3847 thisone->subc = NULL;
3848 thisone->next = NULL;
3849 thisone->u1.expr = (AEXPR *)getitem(PERM_AREA, sizeof(AEXPR));
3850 memset(thisone->u1.expr, 0, sizeof(AEXPR));
3851 thisone->u1.expr->op = op;
3852 if (ipa == 1) {
3853 thisone->sptr = sptr;
3854 thisone->dtype = dtype;
3855 thisone->ptrdtype = ptrdtype;
3856 thisone->repeatc = repeatc;
3857 } else if (ipa == 2) {
3858 thisone->sptr = get_symbolxref(sptr);
3859 thisone->dtype = dindex(dtype);
3860 thisone->ptrdtype = dindex(ptrdtype);
3861 thisone->repeatc = ipa_ast(repeatc);
3862 } else {
3863 thisone->sptr = new_symbol(sptr);
3864 thisone->dtype = new_dtype(dtype);
3865 thisone->ptrdtype = new_dtype(ptrdtype);
3866 thisone->repeatc = new_ast(repeatc);
3867 }
3868 more = get_num(10);
3869 thisone->u1.expr->lop = getict(fdlz, file_name, ipa);
3870 if (BINOP(thisone->u1.expr)) {
3871 thisone->u1.expr->rop = getict(fdlz, file_name, ipa);
3872 } else {
3873 thisone->u1.expr->rop = NULL;
3874 }
3875 break;
3876 default:
3877 error(4, 0, gbl.lineno, import_corrupt_msg, import_file_name);
3878 }
3879 if (prev) {
3880 prev->next = thisone;
3881 } else {
3882 first = thisone;
3883 }
3884 if (thisone->sptr)
3885 save_struct_init(thisone);
3886 prev = thisone;
3887 } while (more);
3888 Trace(("getict returning ict %x", first));
3889 return first;
3890 } /* getict */
3891
3892 static void
put_data_statement(int lineno,int anyivl,int anyict,lzhandle * fdlz,char * file_name,int ipa)3893 put_data_statement(int lineno, int anyivl, int anyict, lzhandle *fdlz,
3894 char *file_name, int ipa)
3895 {
3896 int nw;
3897 char *ptr;
3898 VAR *ivl;
3899 ACL *ict;
3900
3901 if (astb.df == NULL) {
3902 astb.df = tmpf("b");
3903 if (astb.df == NULL)
3904 errfatal(5);
3905 }
3906 if (anyivl) {
3907 ivl = getivl(fdlz, file_name, ipa);
3908 } else {
3909 ivl = NULL;
3910 }
3911 if (anyict) {
3912 ict = getict(fdlz, file_name, ipa);
3913 } else {
3914 ict = NULL;
3915 }
3916
3917 /* For modules, insure that only one ICT/IVL list is put out for each named
3918 * constant
3919 * by building the initialization lists only if we are importing the module
3920 * that
3921 * defines this named constant. */
3922 if (for_module && SCOPEG(sym_of_ast(ivl->u.varref.ptr)) != stb.curr_scope) {
3923 return;
3924 }
3925 if (ivl && ict) {
3926 if (ivl->id == Varref && ivl->u.varref.ptr) {
3927 int sptr = A_SPTRG(ivl->u.varref.ptr);
3928 if (PARAMG(sptr)) {
3929 if (STYPEG(sptr) != ST_PARAM) {
3930 sptr = NMCNSTG(sptr);
3931 }
3932 CONVAL2P(sptr, put_getitem_p(ict));
3933 }
3934 }
3935 }
3936 Trace(("Writing ICL record at line %d, ivl %x, ict %x", lineno, ivl, ict));
3937 nw = fwrite(&lineno, sizeof(lineno), 1, astb.df);
3938 if (nw != 1)
3939 error(10, 40, 0, "(data init file)", CNULL);
3940 nw = fwrite(&gbl.findex, sizeof(gbl.findex), 1, astb.df);
3941 if (nw != 1)
3942 error(10, 40, 0, "(data init file)", CNULL);
3943 ptr = (char *)ivl;
3944 nw = fwrite(&ptr, sizeof(ptr), 1, astb.df);
3945 if (nw != 1)
3946 error(10, 40, 0, "(data init file)", CNULL);
3947 ptr = (char *)ict;
3948 nw = fwrite(&ptr, sizeof(ptr), 1, astb.df);
3949 if (nw != 1)
3950 error(10, 40, 0, "(data init file)", CNULL);
3951
3952 if (!for_interproc) {
3953 sem.dinit_nbr_inits++;
3954 }
3955 } /* put_data_statement */
3956
3957 static void
get_component_init(lzhandle * fdlz,char * file_name,char * p,int ipa)3958 get_component_init(lzhandle *fdlz, char *file_name, char *p, int ipa)
3959 {
3960 ACL *ict;
3961 int sptr;
3962 int dtype;
3963 int ptrdtype;
3964 int tag;
3965 int repeatc;
3966 int ast;
3967
3968 #if DEBUG
3969 assert(p[0] == 'T', "get_component_init: invalid input record (%c)\n", p[0],
3970 2);
3971 #endif
3972
3973 sptr = get_num(10);
3974 dtype = get_num(10);
3975 ptrdtype = get_num(10);
3976 repeatc = get_num(10);
3977 ast = get_num(10);
3978 if (ipa == 1) {
3979 } else if (ipa == 2) {
3980 sptr = get_symbolxref(sptr);
3981 dtype = dindex(dtype);
3982 if (ptrdtype)
3983 ptrdtype = dindex(ptrdtype);
3984 ast = ipa_ast(ast);
3985 } else {
3986 sptr = new_symbol(sptr);
3987 dtype = new_dtype(dtype);
3988 ast = new_ast(ast);
3989 if (ptrdtype)
3990 ptrdtype = new_dtype(ptrdtype);
3991 }
3992
3993 tag = DTY(dtype + 3);
3994 if (DTYPEG(tag) != dtype) {
3995 DTY(dtype + 5) = DTY(DTYPEG(tag) + 5);
3996 getict(fdlz, file_name, ipa); /* consume it */
3997 } else {
3998 ict = GET_ACL(PERM_AREA);
3999 ict->id = AC_TYPEINIT;
4000 ict->sptr = sptr;
4001 ict->dtype = dtype;
4002 ict->ptrdtype = ptrdtype;
4003 ict->repeatc = repeatc;
4004 ict->u1.ast = ast;
4005 ict->subc = getict(fdlz, file_name, ipa);
4006 DTY(ict->dtype + 5) = put_getitem_p(ict);
4007 }
4008 } /* get_component_init */
4009
4010 static int
install_dtype(DITEM * pd)4011 install_dtype(DITEM *pd)
4012 {
4013 int dtype, nd, na, ns;
4014 int paramct, dpdsc;
4015 int i;
4016
4017 dtype = pd->new_id;
4018 if (pd->dtypeinstalled)
4019 return dtype;
4020 pd->dtypeinstalled = TRUE; /* set flag now just in case recursion occurs */
4021 switch (pd->ty) {
4022 case TY_PTR:
4023 nd = new_dtype(DTY(dtype + 1));
4024 DTY(dtype + 1) = nd;
4025 break;
4026 case TY_ARRAY:
4027 nd = new_dtype(DTY(dtype + 1));
4028 DTY(dtype + 1) = nd;
4029 if (DTY(dtype + 2) == 0)
4030 break;
4031 na = new_ast(ADD_ZBASE(dtype));
4032 ADD_ZBASE(dtype) = na;
4033 /* fill in array dtypes with the new asts */
4034 for (i = 0; i < ADD_NUMDIM(dtype); i++) {
4035 na = new_ast(ADD_LWBD(dtype, i));
4036 ADD_LWBD(dtype, i) = na;
4037 na = new_ast(ADD_UPBD(dtype, i));
4038 ADD_UPBD(dtype, i) = na;
4039 na = new_ast(ADD_MLPYR(dtype, i));
4040 ADD_MLPYR(dtype, i) = na;
4041 na = new_ast(ADD_LWAST(dtype, i));
4042 ADD_LWAST(dtype, i) = na;
4043 na = new_ast(ADD_UPAST(dtype, i));
4044 ADD_UPAST(dtype, i) = na;
4045 na = new_ast(ADD_EXTNTAST(dtype, i));
4046 ADD_EXTNTAST(dtype, i) = na;
4047 }
4048 na = new_ast(ADD_NUMELM(dtype));
4049 ADD_NUMELM(dtype) = na;
4050 break;
4051 case TY_UNION:
4052 case TY_STRUCT:
4053 case TY_DERIVED:
4054 /* because we dump all dtypes, we may get some dtype records that
4055 aren't needed. If we can't find the members, we'll assume that
4056 this dtype wasn't really needed */
4057 if (can_find_symbol(DTY(dtype + 1))) {
4058 ns = new_symbol(DTY(dtype + 1)); /* first member */
4059 DTY(dtype + 1) = ns;
4060 /* the tag is updated later, in 'new_dtypes()' */
4061 } else {
4062 /* kill the tag field, too. */
4063 DTY(dtype + 1) = NOSYM;
4064 }
4065 break;
4066 case TY_CHAR:
4067 case TY_NCHAR:
4068 na = new_ast(DTY(dtype + 1));
4069 DTY(dtype + 1) = na;
4070 break;
4071 case TY_PROC:
4072 nd = new_dtype(DTY(dtype + 1));
4073 DTY(dtype + 1) = nd;
4074 ns = DTY(dtype + 2); /* interface */
4075 if (ns) {
4076 ns = new_symbol(ns);
4077 DTY(dtype + 2) = ns;
4078 }
4079 paramct = DTY(dtype + 3);
4080 dpdsc = DTY(dtype + 4);
4081 if (paramct) {
4082 for (i = 0; i < paramct; i++) {
4083 ns = new_symbol(aux.dpdsc_base[dpdsc + i]);
4084 aux.dpdsc_base[dpdsc + i] = ns;
4085 }
4086 }
4087 ns = DTY(dtype + 5); /* fval */
4088 if (ns) {
4089 ns = new_symbol(ns);
4090 DTY(dtype + 5) = ns;
4091 aux.dpdsc_base[dpdsc - 1] = ns;
4092 }
4093 break;
4094 default:
4095 interr("module:new_dtype, illegal type", pd->ty, 0);
4096 return DT_INT;
4097 }
4098 return dtype;
4099 } /* install_dtype */
4100
4101 static int
new_dtype(int old_dt)4102 new_dtype(int old_dt)
4103 {
4104 DITEM *pd;
4105 int j;
4106
4107 pd = finddthash(old_dt);
4108 if (pd == NULL) {
4109 if (dtype_ivsn < 34)
4110 old_dt = adjust_pre34_dtype(old_dt);
4111 if (old_dt < BASEdty)
4112 return old_dt;
4113 interr("module:new_dtype, dt nfd", old_dt, 0);
4114 return DT_INT;
4115 }
4116 return pd->new_id;
4117 } /* new_dtype */
4118
4119 static int
new_installed_dtype(int old_dt)4120 new_installed_dtype(int old_dt)
4121 {
4122 DITEM *pd;
4123 int j, dtype;
4124
4125 pd = finddthash(old_dt);
4126 if (pd == NULL) {
4127 if (dtype_ivsn < 34)
4128 old_dt = adjust_pre34_dtype(old_dt);
4129 if (old_dt < BASEdty)
4130 return old_dt;
4131 interr("module:new_installed_dtype, dt nfd", old_dt, 0);
4132 return DT_INT;
4133 }
4134 if (pd->dtypeinstalled) {
4135 dtype = pd->new_id;
4136 } else {
4137 dtype = install_dtype(pd);
4138 }
4139 return dtype;
4140 } /* new_installed_dtype */
4141
4142 static void
new_dtypes(void)4143 new_dtypes(void)
4144 {
4145 DITEM *pd;
4146 int j, dtype;
4147
4148 for (j = 0; j < dtz.avl; j++) {
4149 pd = dtz.base + j;
4150 if (pd->dtypeinstalled) {
4151 dtype = pd->new_id;
4152 } else {
4153 dtype = install_dtype(pd);
4154 }
4155 switch (DTY(dtype)) {
4156 case TY_UNION:
4157 case TY_STRUCT:
4158 case TY_DERIVED:
4159 if (pd->ty != 0 && DTY(dtype + 3)) {
4160 int ns;
4161 ns = new_symbol(DTY(dtype + 3));
4162 DTY(dtype + 3) = ns;
4163 }
4164 }
4165 }
4166 if (inmodulecontains)
4167 exportb.hmark.dt = stb.dt.stg_avail; /* for subsequent 'export_dtypes()' */
4168 }
4169
4170 static int
fill_ast(ASTITEM * pa)4171 fill_ast(ASTITEM *pa)
4172 {
4173 int type;
4174 int alias;
4175 int ast;
4176 int sptr, osptr;
4177 int lop, rop, left, right;
4178 int stride;
4179 int optype;
4180 int dtype;
4181 int count;
4182 int argt;
4183 int shape;
4184 int asd;
4185 int astli;
4186 int std;
4187 int l1, l2, l3, l4;
4188 int i, j;
4189 SYMITEM *ps;
4190 /* WARNING, recursive calls (possibly thru other procedures) may
4191 * clobber this area. Grab what you need first.
4192 */
4193 BZERO(astb.stg_base, AST, 1);
4194 astb.stg_base[0].type = pa->type;
4195
4196 #define GETFIELD(f) astb.stg_base[0].f = pa->a.f
4197 GETFIELD(f2);
4198 GETFIELD(shape);
4199 GETFIELD(w3);
4200 GETFIELD(w4);
4201 GETFIELD(w5);
4202 GETFIELD(w6);
4203 GETFIELD(w7);
4204 GETFIELD(w8);
4205 GETFIELD(w9);
4206 GETFIELD(w10);
4207 GETFIELD(hw21);
4208 GETFIELD(hw22);
4209 GETFIELD(w12);
4210 GETFIELD(opt1);
4211 GETFIELD(opt2);
4212 GETFIELD(repl);
4213 GETFIELD(visit);
4214 GETFIELD(w18); /* IVSN 30 */
4215 GETFIELD(w19);
4216 #undef GETFIELD
4217
4218 switch (type = A_TYPEG(0)) {
4219 case A_ID:
4220 ps = NULL;
4221 alias = A_ALIASG(0);
4222 osptr = A_SPTRG(0);
4223 if (pa->flags & A_IDSTR_mask) {
4224 sptr = osptr; /* This is one when we import already */
4225 } else {
4226 new_symbol_and_link(osptr, &sptr, &ps);
4227 }
4228 /* not all symbols were installed, so dtype may be wrong */
4229 if (ps && ps->sc >= 0) {
4230 dtype = new_installed_dtype(ps->dtype);
4231 DTYPEP(sptr, dtype);
4232 }
4233 ast = mk_id(sptr);
4234 if (STYPEG(sptr) == ST_PARAM && alias) {
4235 alias = new_ast(alias);
4236 A_ALIASP(ast, alias);
4237 }
4238 break;
4239 case A_CNST:
4240 dtype = A_DTYPEG(0);
4241 osptr = A_SPTRG(0);
4242 new_symbol_and_link(osptr, &sptr, &ps);
4243 /* not all symbols were installed, so dtype may be wrong */
4244 if (ps) {
4245 dtype = new_dtype(ps->dtype);
4246 DTYPEP(sptr, dtype);
4247 }
4248 ast = mk_cnst(sptr);
4249 break;
4250 case A_LABEL:
4251 sptr = new_symbol((int)A_SPTRG(0));
4252 ast = mk_label(sptr);
4253 break;
4254 case A_BINOP:
4255 lop = A_LOPG(0);
4256 rop = A_ROPG(0);
4257 optype = A_OPTYPEG(0);
4258 dtype = new_dtype((int)A_DTYPEG(0));
4259 lop = new_ast(lop);
4260 rop = new_ast(rop);
4261 ast = mk_binop(optype, lop, rop, dtype);
4262 break;
4263 case A_UNOP:
4264 lop = A_LOPG(0);
4265 optype = A_OPTYPEG(0);
4266 dtype = new_dtype((int)A_DTYPEG(0));
4267 lop = new_ast(lop);
4268 ast = mk_unop(optype, lop, dtype);
4269 break;
4270 case A_CMPLXC:
4271 lop = A_LOPG(0);
4272 rop = A_ROPG(0);
4273 dtype = new_dtype((int)A_DTYPEG(0));
4274 lop = new_ast(lop);
4275 rop = new_ast(rop);
4276 ast = mk_cmplxc(lop, rop, dtype);
4277 break;
4278 case A_PAREN:
4279 lop = A_LOPG(0);
4280 dtype = new_dtype((int)A_DTYPEG(0));
4281 lop = new_ast(lop);
4282 ast = mk_paren(lop, dtype);
4283 break;
4284 case A_CONV:
4285 lop = A_LOPG(0);
4286 dtype = new_dtype((int)A_DTYPEG(0));
4287 lop = new_ast(lop);
4288 ast = mk_convert(lop, dtype);
4289 break;
4290 case A_MEM:
4291 lop = A_PARENTG(0);
4292 rop = A_MEMG(0);
4293 dtype = new_installed_dtype((int)A_DTYPEG(0));
4294 lop = new_ast(lop);
4295 rop = new_ast(rop);
4296 ast = mk_member(lop, rop, dtype);
4297 break;
4298 case A_SUBSTR:
4299 lop = A_LOPG(0);
4300 left = A_LEFTG(0);
4301 right = A_RIGHTG(0);
4302 alias = A_ALIASG(0);
4303 dtype = new_dtype((int)A_DTYPEG(0));
4304 lop = new_ast(lop);
4305 left = new_ast(left);
4306 right = new_ast(right);
4307 if (alias)
4308 alias = new_ast(alias);
4309 ast = mk_substr(lop, left, right, dtype);
4310 break;
4311 case A_INIT:
4312 sptr = A_SPTRG(0);
4313 left = A_LEFTG(0);
4314 right = A_RIGHTG(0);
4315 dtype = new_dtype((int)A_DTYPEG(0));
4316 if (sptr)
4317 sptr = new_symbol(sptr);
4318 left = new_ast(left);
4319 if (right)
4320 right = new_ast(right);
4321 ast = mk_init(left, dtype);
4322 A_RIGHTP(ast, right);
4323 A_SPTRP(ast, sptr);
4324 break;
4325 case A_SUBSCR:
4326 lop = A_LOPG(0);
4327 asd = A_ASDG(0);
4328 dtype = A_DTYPEG(0);
4329 lop = new_ast(lop);
4330 i = new_asd(pa->list);
4331 dtype = new_dtype(dtype);
4332 ast = mk_subscr(lop, asdz.base[i].subs, asdz.base[i].ndim, dtype);
4333 break;
4334 case A_TRIPLE:
4335 lop = A_LBDG(0);
4336 rop = A_UPBDG(0);
4337 stride = A_STRIDEG(0);
4338 lop = new_ast(lop);
4339 rop = new_ast(rop);
4340 stride = new_ast(stride);
4341 ast = mk_triple(lop, rop, stride);
4342 break;
4343 case A_FUNC:
4344 case A_CALL:
4345 lop = A_LOPG(0);
4346 count = A_ARGCNTG(0);
4347 argt = 0;
4348 if (type == A_FUNC) {
4349 dtype = A_DTYPEG(0);
4350 shape = A_SHAPEG(0);
4351 dtype = new_dtype(dtype);
4352 shape = new_shape(pa->shape);
4353 }
4354 lop = new_ast(lop);
4355 argt = new_argt(pa->list);
4356 /* 'simulate' everything which begin_call does */
4357 ast = new_node(type);
4358 A_LOPP(ast, lop);
4359 A_ARGCNTP(ast, count);
4360 A_ARGSP(ast, argt);
4361 A_DTYPEP(ast, dtype);
4362 if (type == A_FUNC) {
4363 A_CALLFGP(ast, argtz.base[pa->list].callfg);
4364 A_SHAPEP(ast, shape);
4365 }
4366 if (for_inliner) {
4367 /* simulate what we would have done in semfin had we seen this
4368 * function call before the inliner.
4369 * put the procedure on the aux.list[ST_PROC] list.
4370 * expose the FVAL in the argument list for array valued functions */
4371 if (A_TYPEG(lop) == A_ID) {
4372 int fval, dpdsc;
4373 sptr = A_SPTRG(lop);
4374 if (STYPEG(sptr) == ST_PROC && SLNKG(sptr) == 0) {
4375 SLNKP(sptr, aux.list[ST_PROC]);
4376 aux.list[ST_PROC] = sptr;
4377 }
4378 dtype = DTYPEG(sptr);
4379 dpdsc = DPDSCG(sptr);
4380 fval = FVALG(sptr);
4381 if (DTY(dtype) == TY_ARRAY && dpdsc && fval) {
4382 if (aux.dpdsc_base[dpdsc] != fval && aux.dpdsc_base[dpdsc - 1] == 0) {
4383 aux.dpdsc_base[dpdsc - 1] = fval;
4384 DPDSCP(sptr, dpdsc - 1);
4385 PARAMCTP(sptr, PARAMCTG(sptr) + 1);
4386 FUNCP(sptr, 0);
4387 }
4388 }
4389 }
4390 }
4391 break;
4392 case A_INTR:
4393 case A_ICALL:
4394 optype = A_OPTYPEG(0);
4395 lop = A_LOPG(0);
4396 count = A_ARGCNTG(0);
4397 if (type == A_INTR) {
4398 dtype = A_DTYPEG(0);
4399 shape = A_SHAPEG(0);
4400 dtype = new_dtype(dtype);
4401 shape = new_shape(pa->shape);
4402 }
4403 lop = new_ast(lop);
4404 argt = new_argt(pa->list);
4405 /* 'simulate' everything which begin_call does */
4406 ast = new_node(type);
4407 A_LOPP(ast, lop);
4408 A_ARGCNTP(ast, count);
4409 A_ARGSP(ast, argt);
4410 A_DTYPEP(ast, dtype);
4411 A_OPTYPEP(ast, optype);
4412 if (type == A_INTR) {
4413 A_CALLFGP(ast, argtz.base[pa->list].callfg);
4414 A_SHAPEP(ast, shape);
4415 /* make sure the runtime library functions are declared */
4416 switch (optype) {
4417 case I_SIZE:
4418 (void)sym_mkfunc_nodesc(mkRteRtnNm(RTE_size), stb.user.dt_int);
4419 break;
4420 case I_LBOUND:
4421 (void)sym_mkfunc_nodesc(mkRteRtnNm(RTE_lb), stb.user.dt_int);
4422 break;
4423 case I_UBOUND:
4424 (void)sym_mkfunc_nodesc(mkRteRtnNm(RTE_ub), stb.user.dt_int);
4425 break;
4426 }
4427 }
4428 break;
4429 case A_ASN:
4430 lop = A_DESTG(0);
4431 rop = A_SRCG(0);
4432 dtype = A_DTYPEG(0);
4433 lop = new_ast(lop);
4434 rop = new_ast(rop);
4435 dtype = new_dtype(dtype);
4436 ast = mk_assn_stmt(lop, rop, dtype);
4437 break;
4438 case A_IF:
4439 lop = A_IFEXPRG(0);
4440 rop = A_IFSTMTG(0);
4441 lop = new_ast(lop);
4442 rop = new_ast(rop);
4443 ast = mk_stmt(A_IF, 0);
4444 A_IFEXPRP(ast, lop);
4445 A_IFSTMTP(ast, rop);
4446 break;
4447 case A_IFTHEN:
4448 case A_ELSEIF:
4449 lop = A_IFEXPRG(0);
4450 lop = new_ast(lop);
4451 ast = mk_stmt(type, 0);
4452 A_IFEXPRP(ast, lop);
4453 break;
4454 case A_AIF:
4455 lop = A_IFEXPRG(0);
4456 l1 = A_L1G(0);
4457 l2 = A_L2G(0);
4458 l3 = A_L3G(0);
4459 lop = new_ast(lop);
4460 l1 = new_ast(l1);
4461 l2 = new_ast(l2);
4462 l3 = new_ast(l3);
4463 ast = mk_stmt(A_AIF, 0);
4464 A_IFEXPRP(ast, lop);
4465 A_L1P(ast, l1);
4466 A_L2P(ast, l2);
4467 A_L3P(ast, l3);
4468 break;
4469 case A_GOTO:
4470 l1 = A_L1G(0);
4471 l1 = new_ast(l1);
4472 ast = mk_stmt(A_GOTO, 0);
4473 A_L1P(ast, l1);
4474 break;
4475 case A_CGOTO:
4476 case A_AGOTO:
4477 lop = A_LOPG(0);
4478 lop = new_ast(lop);
4479 astli = new_astli(pa->list, pa->type);
4480 ast = mk_stmt(type, 0);
4481 A_LISTP(ast, astli);
4482 A_LOPP(ast, lop);
4483 break;
4484 case A_ASNGOTO:
4485 Trace(("assigned goto at ast %d cannot be imported from file %s",
4486 pa->old_ast, import_file_name));
4487 interr("new_ast:ast type not supported", type, 3);
4488 ast = 0;
4489 break;
4490 case A_DO:
4491 lop = A_DOLABG(0);
4492 rop = A_DOVARG(0);
4493 l1 = A_M1G(0);
4494 l2 = A_M2G(0);
4495 l3 = A_M3G(0);
4496 l4 = A_M4G(0);
4497 lop = new_ast(lop);
4498 rop = new_ast(rop);
4499 l1 = new_ast(l1);
4500 l2 = new_ast(l2);
4501 l3 = new_ast(l3);
4502 l4 = new_ast(l4);
4503 ast = mk_stmt(A_DO, 0);
4504 A_DOLABP(ast, lop);
4505 A_DOVARP(ast, rop);
4506 A_M1P(ast, l1);
4507 A_M2P(ast, l2);
4508 A_M3P(ast, l3);
4509 A_M4P(ast, l4);
4510 break;
4511 case A_DOWHILE:
4512 lop = A_DOLABG(0);
4513 rop = A_IFEXPRG(0);
4514 lop = new_ast(lop);
4515 rop = new_ast(rop);
4516 ast = mk_stmt(A_DOWHILE, 0);
4517 A_DOLABP(ast, lop);
4518 A_IFEXPRP(ast, rop);
4519 break;
4520 case A_STOP:
4521 case A_PAUSE:
4522 case A_RETURN:
4523 lop = A_LOPG(0);
4524 lop = new_ast(lop);
4525 ast = mk_stmt(type, 0);
4526 A_LOPP(ast, lop);
4527 break;
4528 case A_ALLOC:
4529 optype = A_TKNG(0);
4530 lop = A_LOPG(0);
4531 rop = A_SRCG(0);
4532 l1 = A_DESTG(0);
4533 l2 = A_STARTG(0);
4534 l3 = A_M3G(0);
4535 l4 = A_DTYPEG(0);
4536 i = A_FIRSTALLOCG(0);
4537 lop = new_ast(lop);
4538 rop = new_ast(rop);
4539 l1 = new_ast(l1);
4540 l2 = new_ast(l2);
4541 l3 = new_ast(l3);
4542 l4 = new_installed_dtype(l4);
4543 ast = mk_stmt(A_ALLOC, 0);
4544 A_SRCP(ast, rop);
4545 A_LOPP(ast, lop);
4546 A_DESTP(ast, l1);
4547 A_STARTP(ast, l2);
4548 A_M3P(ast, l3);
4549 A_TKNP(ast, optype);
4550 A_DTYPEP(ast, l4);
4551 A_FIRSTALLOCP(ast, i);
4552 break;
4553 case A_WHERE:
4554 lop = A_IFEXPRG(0);
4555 rop = A_IFSTMTG(0);
4556 lop = new_ast(lop);
4557 rop = new_ast(rop);
4558 ast = mk_stmt(A_WHERE, 0);
4559 A_IFEXPRP(ast, lop);
4560 A_IFSTMTP(ast, rop);
4561 break;
4562 case A_FORALL:
4563 lop = A_IFEXPRG(0);
4564 rop = A_IFSTMTG(0);
4565 std = A_SRCG(0);
4566 lop = new_ast(lop);
4567 rop = new_ast(rop);
4568 astli = new_astli(pa->list, pa->type);
4569 std = new_std(std);
4570 ast = mk_stmt(A_FORALL, 0);
4571 A_LISTP(ast, astli);
4572 A_IFEXPRP(ast, lop);
4573 A_IFSTMTP(ast, rop);
4574 A_SRCP(ast, std);
4575 break;
4576 case A_REDIM:
4577 lop = A_SRCG(0);
4578 lop = new_ast(lop);
4579 ast = mk_stmt(A_REDIM, 0);
4580 A_SRCP(ast, lop);
4581 break;
4582 case A_ENTRY:
4583 sptr = A_SPTRG(0);
4584 sptr = new_symbol(sptr);
4585 ast = mk_stmt(type, 0);
4586 A_SPTRP(ast, sptr);
4587 break;
4588 case A_COMSTR:
4589 Trace(("comment at ast %d cannot be imported from file %s", pa->old_ast,
4590 import_file_name));
4591 interr("new_ast:ast type not supported", type, 3);
4592 ast = 0;
4593 break;
4594 case A_COMMENT:
4595 case A_ELSE:
4596 case A_ENDIF:
4597 case A_ELSEFORALL:
4598 case A_ELSEWHERE:
4599 case A_ENDWHERE:
4600 case A_ENDFORALL:
4601 case A_ENDDO:
4602 case A_CONTINUE:
4603 case A_END:
4604 ast = mk_stmt(type, 0);
4605 break;
4606 case A_HLOCALIZEBNDS:
4607 lop = A_LOPG(0);
4608 rop = A_ITRIPLEG(0);
4609 l1 = A_OTRIPLEG(0);
4610 l2 = A_DIMG(0);
4611 lop = new_ast(lop);
4612 rop = new_ast(rop);
4613 l1 = new_ast(l1);
4614 l2 = new_ast(l2);
4615 ast = mk_stmt(A_HLOCALIZEBNDS, 0);
4616 A_LOPP(ast, lop);
4617 A_ITRIPLEP(ast, rop);
4618 A_OTRIPLEP(ast, l1);
4619 A_DIMP(ast, l2);
4620 break;
4621 case A_HALLOBNDS:
4622 lop = A_LOPG(0);
4623 lop = new_ast(lop);
4624 ast = mk_stmt(A_HALLOBNDS, 0);
4625 A_LOPP(ast, lop);
4626 break;
4627 case A_HCYCLICLP:
4628 lop = A_LOPG(0);
4629 rop = A_ITRIPLEG(0);
4630 l1 = A_OTRIPLEG(0);
4631 l2 = A_OTRIPLE1G(0);
4632 l3 = A_DIMG(0);
4633 lop = new_ast(lop);
4634 rop = new_ast(rop);
4635 l1 = new_ast(l1);
4636 l2 = new_ast(l2);
4637 l3 = new_ast(l3);
4638 ast = mk_stmt(A_HCYCLICLP, 0);
4639 A_LOPP(ast, lop);
4640 A_ITRIPLEP(ast, rop);
4641 A_OTRIPLEP(ast, l1);
4642 A_OTRIPLE1P(ast, l2);
4643 A_DIMP(ast, l3);
4644 break;
4645 case A_HOFFSET:
4646 l1 = A_DESTG(0);
4647 lop = A_LOPG(0);
4648 rop = A_ROPG(0);
4649 l1 = new_ast(l1);
4650 lop = new_ast(lop);
4651 rop = new_ast(rop);
4652 ast = mk_stmt(A_HOFFSET, 0);
4653 A_DESTP(ast, l1);
4654 A_LOPP(ast, lop);
4655 A_ROPP(ast, rop);
4656 break;
4657 case A_HSECT:
4658 lop = A_LOPG(0);
4659 rop = A_BVECTG(0);
4660 lop = new_ast(lop);
4661 rop = new_ast(rop);
4662 ast = new_node(type);
4663 A_DTYPEP(ast, DT_INT);
4664 A_LOPP(ast, lop);
4665 A_BVECTP(ast, rop);
4666 break;
4667 case A_HCOPYSECT:
4668 lop = A_DESTG(0);
4669 rop = A_SRCG(0);
4670 l1 = A_DDESCG(0);
4671 l2 = A_SDESCG(0);
4672 lop = new_ast(lop);
4673 rop = new_ast(rop);
4674 l1 = new_ast(l1);
4675 l2 = new_ast(l2);
4676 ast = new_node(type);
4677 A_DTYPEP(ast, DT_INT);
4678 A_DESTP(ast, lop);
4679 A_SRCP(ast, rop);
4680 A_DDESCP(ast, l1);
4681 A_SDESCP(ast, l2);
4682 break;
4683 case A_HPERMUTESECT:
4684 lop = A_DESTG(0);
4685 rop = A_SRCG(0);
4686 l1 = A_DDESCG(0);
4687 l2 = A_SDESCG(0);
4688 l3 = A_BVECTG(0);
4689 lop = new_ast(lop);
4690 rop = new_ast(rop);
4691 l1 = new_ast(l1);
4692 l2 = new_ast(l2);
4693 l3 = new_ast(l3);
4694 ast = new_node(type);
4695 A_DTYPEP(ast, DT_INT);
4696 A_DESTP(ast, lop);
4697 A_SRCP(ast, rop);
4698 A_DDESCP(ast, l1);
4699 A_SDESCP(ast, l2);
4700 A_BVECTP(ast, l3);
4701 break;
4702 case A_HOVLPSHIFT:
4703 rop = A_SRCG(0);
4704 l2 = A_SDESCG(0);
4705 rop = new_ast(rop);
4706 l2 = new_ast(l2);
4707 ast = new_node(type);
4708 A_DTYPEP(ast, DT_INT);
4709 A_SRCP(ast, rop);
4710 A_SDESCP(ast, l2);
4711 break;
4712 case A_HGETSCLR:
4713 lop = A_DESTG(0);
4714 rop = A_SRCG(0);
4715 lop = new_ast(lop);
4716 rop = new_ast(rop);
4717 ast = mk_stmt(type, 0);
4718 A_DESTP(ast, lop);
4719 A_SRCP(ast, rop);
4720 break;
4721 case A_HGATHER:
4722 case A_HSCATTER:
4723 i = A_VSUBG(0);
4724 lop = A_DESTG(0);
4725 rop = A_SRCG(0);
4726 l1 = A_DDESCG(0);
4727 l2 = A_SDESCG(0);
4728 l3 = A_MDESCG(0);
4729 j = A_BVECTG(0);
4730 i = new_ast(i);
4731 lop = new_ast(lop);
4732 rop = new_ast(rop);
4733 l1 = new_ast(l1);
4734 l2 = new_ast(l2);
4735 l3 = new_ast(l3);
4736 j = new_ast(j);
4737 ast = new_node(type);
4738 A_DTYPEP(ast, DT_INT);
4739 A_VSUBP(ast, i);
4740 A_DESTP(ast, lop);
4741 A_SRCP(ast, rop);
4742 A_DDESCP(ast, l1);
4743 A_SDESCP(ast, l2);
4744 A_MDESCP(ast, l3);
4745 A_BVECTP(ast, j);
4746 break;
4747 case A_HCSTART:
4748 lop = A_LOPG(0);
4749 l1 = A_DESTG(0);
4750 l2 = A_SRCG(0);
4751 lop = new_ast(lop);
4752 l1 = new_ast(l1);
4753 l2 = new_ast(l2);
4754 ast = new_node(type);
4755 A_DTYPEP(ast, DT_INT);
4756 A_LOPP(ast, lop);
4757 A_DESTP(ast, l1);
4758 A_SRCP(ast, l2);
4759 break;
4760 case A_HCFINISH:
4761 case A_HCFREE:
4762 case A_HOWNERPROC:
4763 case A_HLOCALOFFSET:
4764 case A_ATOMIC:
4765 case A_ATOMICCAPTURE:
4766 case A_ATOMICREAD:
4767 case A_ATOMICWRITE:
4768 lop = A_LOPG(0);
4769 if (lop)
4770 lop = new_ast(lop);
4771 ast = mk_stmt(type, 0);
4772 A_LOPP(ast, lop);
4773 break;
4774 case A_MP_BMPSCOPE:
4775 case A_MP_PARALLEL:
4776 case A_MP_ENDPARALLEL:
4777 case A_CRITICAL:
4778 case A_MASTER:
4779 case A_ENDATOMIC:
4780 case A_BARRIER:
4781 case A_NOBARRIER:
4782 ast = mk_stmt(type, 0);
4783 break;
4784 case A_ENDCRITICAL:
4785 lop = A_LOPG(0);
4786 lop = new_ast(lop); /* corresponding critical */
4787 ast = mk_stmt(type, 0);
4788 A_LOPP(ast, lop);
4789 A_LOPP(lop, ast);
4790 break;
4791 case A_ENDMASTER:
4792 lop = A_LOPG(0);
4793 count = A_ARGCNTG(0);
4794 argt = new_argt(pa->list);
4795 lop = new_ast(lop); /* corresponding master */
4796 ast = mk_stmt(type, 0);
4797 A_ARGCNTP(ast, count);
4798 A_ARGSP(ast, argt);
4799 A_LOPP(ast, lop);
4800 A_LOPP(lop, ast);
4801 break;
4802 default:
4803 Trace(("unknown ast type %d at ast %d from file %s", type, pa->old_ast,
4804 import_file_name));
4805 interr("new_ast:unexpected ast type", type, 3);
4806 ast = 0;
4807 break;
4808 }
4809 #if DEBUG
4810 if (DBGBIT(3, 64))
4811 fprintf(gbl.dbgfil, "old ast %d new ast %d\n", pa->old_ast, ast);
4812 #endif
4813
4814 pa->new_ast = ast;
4815 return ast;
4816 } /* fill_ast */
4817
4818 static void
new_asts(void)4819 new_asts(void)
4820 {
4821 int i;
4822
4823 for (i = 0; i < astz.avl; i++) {
4824 (void)fill_ast(astz.base + i);
4825 }
4826 BZERO(astb.stg_base + 0, AST, 1); /* reinitialize AST #0 */
4827 }
4828
4829 static int
new_ast(int old_ast)4830 new_ast(int old_ast)
4831 {
4832 ASTITEM *pa;
4833 int hash, s;
4834
4835 hash = old_ast & ASTZHASHMASK;
4836 for (s = astzhash[hash]; s; s = pa->link) {
4837 pa = astz.base + (s - 1);
4838 if (pa->old_ast == old_ast)
4839 break;
4840 }
4841 if (!s) {
4842 if (old_ast < BASEast) {
4843 return old_ast;
4844 }
4845 Trace(("cannot find ast %d in file %s", old_ast, import_file_name));
4846 interr("incomplete interface file, missing AST", old_ast, 3);
4847 error(4, 0, gbl.lineno, "incomplete IPA file, missing AST ", "");
4848 }
4849 if (pa->new_ast)
4850 return pa->new_ast;
4851 return fill_ast(pa);
4852 } /* new_ast */
4853
4854 static void
new_stds(void)4855 new_stds(void)
4856 {
4857 STDITEM *p_std;
4858 int std;
4859 int ast;
4860 int lab;
4861 int i;
4862
4863 for (i = 0; i < stdz.avl; i++) {
4864 int flags, bit;
4865 p_std = stdz.base + i;
4866 ast = new_ast(p_std->ast);
4867 lab = new_symbol(p_std->label);
4868 std = add_stmt(ast);
4869 STD_LABEL(std) = lab;
4870 STD_LINENO(std) = p_std->lineno;
4871 #define GETBIT(f) \
4872 astb.std.stg_base[std].flags.bits.f = (flags & bit) ? 1 : 0; \
4873 bit <<= 1;
4874 flags = p_std->flags;
4875 bit = 1;
4876 GETBIT(ex);
4877 GETBIT(st);
4878 GETBIT(br);
4879 GETBIT(delete);
4880 GETBIT(ignore);
4881 GETBIT(split);
4882 GETBIT(minfo);
4883 GETBIT(local);
4884 GETBIT(pure);
4885 GETBIT(par);
4886 GETBIT(cs);
4887 GETBIT(parsect);
4888 GETBIT(orig);
4889 #undef GETBIT
4890 }
4891 }
4892
4893 static int
new_std(int old_std)4894 new_std(int old_std)
4895 {
4896 STDITEM *p_std;
4897 int i;
4898
4899 if (old_std)
4900 for (i = 0; i < stdz.avl; i++) {
4901 p_std = stdz.base + i;
4902 if (p_std->old == old_std)
4903 return p_std->new;
4904 }
4905 return 0;
4906 }
4907
4908 /** \brief Look up an (old) argt.
4909 *
4910 * If this is the first lookup, process the argument
4911 * asts from the old argt. The space for the new argt has already been
4912 * allocated and the 'arg' fields in the argt are overwritten by new asts.
4913 *
4914 * \return the index of the ASDITEM (NOT the new argt).
4915 */
4916 static int
new_argt(int offset)4917 new_argt(int offset)
4918 {
4919 int j;
4920 int cnt;
4921 int argt;
4922 int ast;
4923
4924 if (offset == 0)
4925 return 0;
4926 argt = argtz.base[offset].new;
4927 if (!argtz.base[offset].installed) {
4928 cnt = ARGT_CNT(argt);
4929 /* set flag early */
4930 argtz.base[offset].installed = TRUE;
4931 for (j = 0; j < cnt; j++) {
4932 ast = ARGT_ARG(argt, j);
4933 ast = new_ast(ast);
4934 ARGT_ARG(argt, j) = ast;
4935 if (A_CALLFGG(ast))
4936 argtz.base[offset].callfg = 1;
4937 }
4938 }
4939 return argt;
4940 }
4941
4942 /** \brief Look up an (old) asd.
4943 *
4944 * If this is the first lookup, process the subscript
4945 * ASTs; return the index of the ASDITEM item. NOTE: this function doesn't
4946 * create a NEW asd; it will provide the necessary information for an ensuing
4947 * call to mk_subscr().
4948 */
4949 static int
new_asd(int offset)4950 new_asd(int offset)
4951 {
4952 int j;
4953 int cnt;
4954 int ast;
4955
4956 if (!asdz.base[offset].installed) {
4957 cnt = asdz.base[offset].ndim;
4958 asdz.base[offset].installed = TRUE;
4959 for (j = 0; j < cnt; ++j) {
4960 ast = asdz.base[offset].subs[j];
4961 asdz.base[offset].subs[j] = new_ast(ast);
4962 }
4963 }
4964 return offset;
4965 }
4966
4967 /** \brief Look up an (old) ast list.
4968 *
4969 * If this is the first lookup, process the
4970 * information of each item in the list. The space for the new astli has
4971 * already been allocated and the fields in each astli item are overwritten.
4972 *
4973 * \return the index to the head of the 'new' ast list
4974 */
4975 static int
new_astli(int offset,int atype)4976 new_astli(int offset, int atype)
4977 {
4978 int j;
4979 int astli;
4980 int ast;
4981 int sptr;
4982
4983 if (!astliz.base[offset].installed) {
4984 astliz.base[offset].installed = TRUE;
4985 switch (atype) {
4986 case A_CGOTO:
4987 case A_AGOTO:
4988 for (astli = astliz.base[offset].new; astli; astli = ASTLI_NEXT(astli)) {
4989 ast = ASTLI_AST(astli);
4990 ast = new_ast(ast);
4991 ASTLI_AST(astli) = ast;
4992 }
4993 break;
4994 case A_FORALL:
4995 for (astli = astliz.base[offset].new; astli; astli = ASTLI_NEXT(astli)) {
4996 sptr = ASTLI_SPTR(astli);
4997 sptr = new_symbol(sptr);
4998 ast = ASTLI_TRIPLE(astli);
4999 ast = new_ast(ast);
5000 ASTLI_SPTR(astli) = sptr;
5001 ASTLI_TRIPLE(astli) = ast;
5002 }
5003 break;
5004 default:
5005 interr("new_astli: unsupport ast type", atype, 0);
5006 }
5007 }
5008 return astliz.base[offset].new;
5009 }
5010
5011 /** \brief Look up an (old) shd.
5012 *
5013 * If this is the first lookup, process the specifiers
5014 * (asts) for each dimension. After all of the specifiers have been processed,
5015 * create a new shape descriptor, stashing its index in the SHDITEM and return
5016 * the index to the new shape descriptor.
5017 */
5018 static int
new_shape(int offset)5019 new_shape(int offset)
5020 {
5021 int i;
5022 SHDITEM *p_shd;
5023 int j;
5024 int cnt;
5025 int ast;
5026
5027 if (offset == 0)
5028 return 0;
5029
5030 p_shd = shdz.base + offset;
5031 if (p_shd->new == 0) {
5032 cnt = p_shd->ndim;
5033 for (j = 0; j < cnt; ++j) {
5034 ast = p_shd->shp[j].lwb;
5035 p_shd->shp[j].lwb = new_ast(ast);
5036 ast = p_shd->shp[j].upb;
5037 p_shd->shp[j].upb = new_ast(ast);
5038 ast = p_shd->shp[j].stride;
5039 p_shd->shp[j].stride = new_ast(ast);
5040 }
5041 add_shape_rank(cnt);
5042 for (j = 0; j < cnt; ++j)
5043 add_shape_spec(p_shd->shp[j].lwb, p_shd->shp[j].upb,
5044 p_shd->shp[j].stride);
5045 p_shd->new = mk_shape();
5046 }
5047 return p_shd->new;
5048 }
5049
5050 static void
fill_ST_MODULE(SYMITEM * ps,int sptr)5051 fill_ST_MODULE(SYMITEM *ps, int sptr)
5052 {
5053 int flags, bit;
5054 SYM save_sym0;
5055
5056 save_sym0 = stb.stg_base[0];
5057 #define GETBIT(f) \
5058 stb.stg_base[0].f = (flags & bit) ? 1 : 0; \
5059 bit <<= 1;
5060 flags = ps->flags1;
5061 bit = 1;
5062 GETBIT(f1);
5063 GETBIT(f2);
5064 GETBIT(f3);
5065 GETBIT(f4);
5066 GETBIT(f5);
5067 GETBIT(f6);
5068 GETBIT(f7);
5069 GETBIT(f8);
5070 GETBIT(f9);
5071 GETBIT(f10);
5072 GETBIT(f11);
5073 GETBIT(f12);
5074 GETBIT(f13);
5075 GETBIT(f14);
5076 GETBIT(f15);
5077 GETBIT(f16);
5078 GETBIT(f17);
5079 GETBIT(f18);
5080 GETBIT(f19);
5081 GETBIT(f20);
5082 GETBIT(f21);
5083 GETBIT(f22);
5084 GETBIT(f23);
5085 GETBIT(f24);
5086 GETBIT(f25);
5087 GETBIT(f26);
5088 GETBIT(f27);
5089 GETBIT(f28);
5090 GETBIT(f29);
5091 GETBIT(f30);
5092 GETBIT(f31);
5093 GETBIT(f32);
5094 flags = ps->flags2;
5095 bit = 1;
5096 GETBIT(f33);
5097 GETBIT(f34);
5098 GETBIT(f35);
5099 GETBIT(f36);
5100 GETBIT(f37);
5101 GETBIT(f38);
5102 GETBIT(f39);
5103 GETBIT(f40);
5104 GETBIT(f41);
5105 GETBIT(f42);
5106 GETBIT(f43);
5107 GETBIT(f44);
5108 GETBIT(f45);
5109 GETBIT(f46);
5110 GETBIT(f47);
5111 GETBIT(f48);
5112 GETBIT(f49);
5113 GETBIT(f50);
5114 GETBIT(f51);
5115 GETBIT(f52);
5116 GETBIT(f53);
5117 GETBIT(f54);
5118 GETBIT(f55);
5119 GETBIT(f56);
5120 GETBIT(f57);
5121 GETBIT(f58);
5122 GETBIT(f59);
5123 GETBIT(f60);
5124 GETBIT(f61);
5125 GETBIT(f62);
5126 GETBIT(f63);
5127 GETBIT(f64);
5128 flags = ps->flags3;
5129 bit = 1;
5130 GETBIT(f65);
5131 GETBIT(f66);
5132 GETBIT(f67);
5133 GETBIT(f68);
5134 GETBIT(f69);
5135 GETBIT(f70);
5136 GETBIT(f71);
5137 GETBIT(f72);
5138 GETBIT(f73);
5139 GETBIT(f74);
5140 GETBIT(f75);
5141 GETBIT(f76);
5142 GETBIT(f77);
5143 GETBIT(f78);
5144 GETBIT(f79);
5145 GETBIT(f80);
5146 GETBIT(f81);
5147 GETBIT(f82);
5148 GETBIT(f83);
5149 GETBIT(f84);
5150 GETBIT(f85);
5151 GETBIT(f86);
5152 GETBIT(f87);
5153 GETBIT(f88);
5154 GETBIT(f89);
5155 GETBIT(f90);
5156 GETBIT(f91);
5157 GETBIT(f92);
5158 GETBIT(f93);
5159 GETBIT(f94);
5160 GETBIT(f95);
5161 GETBIT(f96);
5162 flags = ps->flags4;
5163 bit = 1;
5164 GETBIT(f97);
5165 GETBIT(f98);
5166 GETBIT(f99);
5167 GETBIT(f100);
5168 GETBIT(f101);
5169 GETBIT(f102);
5170 GETBIT(f103);
5171 GETBIT(f104);
5172 GETBIT(f105);
5173 GETBIT(f106);
5174 GETBIT(f107);
5175 GETBIT(f108);
5176 GETBIT(f109);
5177 GETBIT(f110);
5178 GETBIT(f111);
5179 GETBIT(f112);
5180 GETBIT(f113);
5181 GETBIT(f114);
5182 GETBIT(f115);
5183 GETBIT(f116);
5184 GETBIT(f117);
5185 GETBIT(f118);
5186 GETBIT(f119);
5187 GETBIT(f120);
5188 GETBIT(f121);
5189 GETBIT(f122);
5190 GETBIT(f123);
5191 GETBIT(f124);
5192 GETBIT(f125);
5193 GETBIT(f126);
5194 GETBIT(f127);
5195 GETBIT(f128);
5196 #undef GETBIT
5197
5198 NEEDMODP(sptr, NEEDMODG(0));
5199 TYPDP(sptr, TYPDG(0));
5200 PRIVATEP(sptr, PRIVATEG(0));
5201 HAS_TBP_BOUND_TO_SMPP(sptr, HAS_TBP_BOUND_TO_SMPG(0));
5202 HAS_SMP_DECP(sptr, HAS_SMP_DECG(0));
5203 stb.stg_base[0] = save_sym0;
5204
5205 } /* fill_ST_MODULE */
5206
5207 static void
fill_sym(SYMITEM * ps,int sptr)5208 fill_sym(SYMITEM *ps, int sptr)
5209 {
5210 int flags, bit;
5211 stb.stg_base[sptr].stype = ps->stype;
5212 stb.stg_base[sptr].sc = ps->sc;
5213 stb.stg_base[sptr].dtype = ps->dtype;
5214 switch (ps->stype) {
5215 case ST_ALIAS:
5216 case ST_MODPROC:
5217 stb.stg_base[sptr].symlk = 0;
5218 break;
5219 default:
5220 stb.stg_base[sptr].symlk = ps->symlk;
5221 }
5222 #define GETBIT(f) \
5223 stb.stg_base[sptr].f = (flags & bit) ? 1 : 0; \
5224 bit <<= 1;
5225 flags = ps->flags1;
5226 bit = 1;
5227 GETBIT(f1);
5228 GETBIT(f2);
5229 GETBIT(f3);
5230 GETBIT(f4);
5231 GETBIT(f5);
5232 GETBIT(f6);
5233 GETBIT(f7);
5234 GETBIT(f8);
5235 GETBIT(f9);
5236 GETBIT(f10);
5237 GETBIT(f11);
5238 GETBIT(f12);
5239 GETBIT(f13);
5240 GETBIT(f14);
5241 GETBIT(f15);
5242 GETBIT(f16);
5243 GETBIT(f17);
5244 GETBIT(f18);
5245 GETBIT(f19);
5246 GETBIT(f20);
5247 GETBIT(f21);
5248 GETBIT(f22);
5249 GETBIT(f23);
5250 GETBIT(f24);
5251 GETBIT(f25);
5252 GETBIT(f26);
5253 GETBIT(f27);
5254 GETBIT(f28);
5255 GETBIT(f29);
5256 GETBIT(f30);
5257 GETBIT(f31);
5258 GETBIT(f32);
5259 flags = ps->flags2;
5260 bit = 1;
5261 GETBIT(f33);
5262 GETBIT(f34);
5263 GETBIT(f35);
5264 GETBIT(f36);
5265 GETBIT(f37);
5266 GETBIT(f38);
5267 GETBIT(f39);
5268 GETBIT(f40);
5269 GETBIT(f41);
5270 GETBIT(f42);
5271 GETBIT(f43);
5272 GETBIT(f44);
5273 GETBIT(f45);
5274 GETBIT(f46);
5275 GETBIT(f47);
5276 GETBIT(f48);
5277 GETBIT(f49);
5278 GETBIT(f50);
5279 GETBIT(f51);
5280 GETBIT(f52);
5281 GETBIT(f53);
5282 GETBIT(f54);
5283 GETBIT(f55);
5284 GETBIT(f56);
5285 GETBIT(f57);
5286 GETBIT(f58);
5287 GETBIT(f59);
5288 GETBIT(f60);
5289 GETBIT(f61);
5290 GETBIT(f62);
5291 GETBIT(f63);
5292 GETBIT(f64);
5293 flags = ps->flags3;
5294 bit = 1;
5295 GETBIT(f65);
5296 GETBIT(f66);
5297 GETBIT(f67);
5298 GETBIT(f68);
5299 GETBIT(f69);
5300 GETBIT(f70);
5301 GETBIT(f71);
5302 GETBIT(f72);
5303 GETBIT(f73);
5304 GETBIT(f74);
5305 GETBIT(f75);
5306 GETBIT(f76);
5307 GETBIT(f77);
5308 GETBIT(f78);
5309 GETBIT(f79);
5310 GETBIT(f80);
5311 GETBIT(f81);
5312 GETBIT(f82);
5313 GETBIT(f83);
5314 GETBIT(f84);
5315 GETBIT(f85);
5316 GETBIT(f86);
5317 GETBIT(f87);
5318 GETBIT(f88);
5319 GETBIT(f89);
5320 GETBIT(f90);
5321 GETBIT(f91);
5322 GETBIT(f92);
5323 GETBIT(f93);
5324 GETBIT(f94);
5325 GETBIT(f95);
5326 GETBIT(f96);
5327 flags = ps->flags4;
5328 bit = 1;
5329 GETBIT(f97);
5330 GETBIT(f98);
5331 GETBIT(f99);
5332 GETBIT(f100);
5333 GETBIT(f101);
5334 GETBIT(f102);
5335 GETBIT(f103);
5336 GETBIT(f104);
5337 GETBIT(f105);
5338 GETBIT(f106);
5339 GETBIT(f107);
5340 GETBIT(f108);
5341 GETBIT(f109);
5342 GETBIT(f110);
5343 GETBIT(f111);
5344 GETBIT(f112);
5345 GETBIT(f113);
5346 GETBIT(f114);
5347 GETBIT(f115);
5348 GETBIT(f116);
5349 GETBIT(f117);
5350 GETBIT(f118);
5351 GETBIT(f119);
5352 GETBIT(f120);
5353 GETBIT(f121);
5354 GETBIT(f122);
5355 GETBIT(f123);
5356 GETBIT(f124);
5357 GETBIT(f125);
5358 GETBIT(f126);
5359 GETBIT(f127);
5360 GETBIT(f128);
5361 #undef GETBIT
5362
5363 #undef GETFIELD
5364 #define GETFIELD(f) stb.stg_base[sptr].f = ps->sym.f
5365 GETFIELD(b3);
5366 GETFIELD(b4);
5367 GETFIELD(scope);
5368 /*GETFIELD(nmptr); don't use*/
5369 GETFIELD(w9);
5370 GETFIELD(w10);
5371 GETFIELD(w11);
5372 GETFIELD(w12);
5373 GETFIELD(w13);
5374 GETFIELD(w14);
5375 GETFIELD(w15);
5376 GETFIELD(w16);
5377 GETFIELD(w17);
5378 GETFIELD(w18);
5379 GETFIELD(w19);
5380 GETFIELD(w20);
5381 GETFIELD(w21);
5382 GETFIELD(w22);
5383 GETFIELD(w23);
5384 GETFIELD(w24);
5385 GETFIELD(w25);
5386 GETFIELD(w26);
5387 GETFIELD(w27);
5388 GETFIELD(w28);
5389 GETFIELD(uname);
5390 GETFIELD(w30);
5391 GETFIELD(w31);
5392 GETFIELD(w32);
5393 GETFIELD(w34);
5394 GETFIELD(w35);
5395 GETFIELD(w36);
5396 #undef GETFIELD
5397 stb.stg_base[sptr].uname = 0;
5398 } /* fill_sym */
5399
5400 static void
import_constant(SYMITEM * ps)5401 import_constant(SYMITEM *ps)
5402 {
5403 INT val[4];
5404 int sptr;
5405 int dtype;
5406
5407 Trace(("import_constant(%d)", ps->sptr));
5408
5409 dtype = new_dtype(ps->dtype);
5410 /* just move the CONVAL fields into sym[0] */
5411 BCOPY(stb.stg_base, &ps->sym, SYM, 1);
5412 STYPEP(0, ST_CONST);
5413 switch (DTY(dtype)) {
5414 case TY_BINT:
5415 case TY_SINT:
5416 case TY_INT:
5417 case TY_BLOG:
5418 case TY_SLOG:
5419 case TY_LOG:
5420 case TY_WORD:
5421 case TY_REAL:
5422 case TY_DWORD:
5423 case TY_DBLE:
5424 case TY_CMPLX:
5425 case TY_INT8:
5426 case TY_LOG8:
5427 val[0] = CONVAL1G(0);
5428 val[1] = CONVAL2G(0);
5429 sptr = getcon(val, dtype);
5430 break;
5431 case TY_QUAD:
5432 val[0] = CONVAL1G(0);
5433 val[1] = CONVAL2G(0);
5434 val[2] = CONVAL3G(0);
5435 val[3] = CONVAL4G(0);
5436 sptr = getcon(val, dtype);
5437 break;
5438 case TY_CHAR:
5439 /* need to check dtype if length is 0 or 1, achar(0) has length of 1 */
5440 if (strlen(ps->strptr) == 0) {
5441 if (DTY(dtype + 1) == astb.k1)
5442 sptr = getstring(ps->strptr, 1);
5443 else
5444 if (DTY(dtype + 1) == astb.i1)
5445 sptr = getstring(ps->strptr, 1);
5446 else
5447 sptr = getstring(ps->strptr, strlen(ps->strptr));
5448 } else {
5449 sptr = getstring(ps->strptr, strlen(ps->strptr));
5450 }
5451 break;
5452 case TY_DCMPLX:
5453 case TY_QCMPLX:
5454 case TY_HOLL:
5455 case TY_NCHAR:
5456 import_symbol(ps);
5457 return;
5458 case TY_PTR:
5459 if (CONVAL1G(0)) {
5460 /*
5461 * defer these for the import of pointer constants -- cannot
5462 * call import_symbol() because the symbol in the CONVAL1
5463 * may not yet been processed yet; therefore, wait until 'all'
5464 * of the symbols in the 'symbol_list' have been processed.
5465 */
5466 any_ptr_constant = TRUE;
5467 return;
5468 }
5469 break;
5470 default:
5471 interr("import_const: unknown constant datatype", dtype, 4);
5472 return;
5473 }
5474 ps->new_sptr = sptr;
5475 NMPTRP(sptr, 0);
5476 if (ps->sym.nmptr) {
5477 /* import the name also */
5478 NMPTRP(sptr, find_nmptr(ps->name));
5479 }
5480 Trace(("import_constant(%d) returning %d", ps->sptr, sptr));
5481 } /* import_constant */
5482
5483 static void
import_symbol(SYMITEM * ps)5484 import_symbol(SYMITEM *ps)
5485 {
5486 SYMTYPE stype;
5487 SC_KIND sc;
5488 INT val[4];
5489 int sptr, s1, s2;
5490 LOGICAL set_dcld;
5491
5492 stype = ps->stype;
5493 Trace(("import_symbol(%s=%d) with stype=%d", ps->name, ps->sptr, stype));
5494 set_dcld = FALSE;
5495
5496 sc = ps->sc;
5497
5498 if (stype == ST_CONST) {
5499 int dtype;
5500 /* just move the CONVAL fields into sym[0] */
5501 BCOPY(stb.stg_base, &ps->sym, SYM, 1);
5502 /* handle the rest of the constant cases */
5503 dtype = new_dtype(ps->dtype);
5504 switch (DTY(dtype)) {
5505 case TY_BINT:
5506 case TY_SINT:
5507 case TY_INT:
5508 case TY_BLOG:
5509 case TY_SLOG:
5510 case TY_LOG:
5511 case TY_WORD:
5512 case TY_REAL:
5513 case TY_DWORD:
5514 case TY_DBLE:
5515 case TY_CMPLX:
5516 case TY_INT8:
5517 case TY_LOG8:
5518 case TY_QUAD:
5519 case TY_CHAR:
5520 /* already handled */
5521 return;
5522 case TY_DCMPLX:
5523 case TY_QCMPLX:
5524 s1 = CONVAL1G(0);
5525 s2 = CONVAL2G(0);
5526 val[0] = new_symbol(s1);
5527 val[1] = new_symbol(s2);
5528 sptr = getcon(val, dtype);
5529 break;
5530 case TY_HOLL:
5531 case TY_NCHAR:
5532 s1 = CONVAL1G(0);
5533 val[0] = new_symbol(s1);
5534 val[1] = CONVAL2G(0);
5535 sptr = getcon(val, dtype);
5536 break;
5537 default:
5538 /* error message already issued */
5539 return;
5540 }
5541 ps->new_sptr = sptr;
5542 return;
5543 }
5544
5545 /*
5546 * Same processing of labels for all types of import. Replace the label
5547 * with a compiler-created label for which astout will substitute with
5548 * a fortran label.
5549 */
5550 if (stype == ST_LABEL) {
5551 sptr = getlab();
5552 fill_sym(ps, sptr); /* copy flags, RFCNT, etc. */
5553 CCSYMP(sptr, 1); /* reset fields defined by getlab() */
5554 SYMLKP(sptr, 0);
5555 ps->new_sptr = sptr;
5556 return;
5557 }
5558
5559 sptr = getsymbol(ps->name);
5560 if (stype == ST_MODULE) {
5561 /* see if there is a module symbol somewhere in the hash link list */
5562 int s2;
5563 for (s2 = sptr; s2 > NOSYM; s2 = HASHLKG(s2)) {
5564 if (NMPTRG(s2) == NMPTRG(sptr) && STYPEG(s2) == ST_MODULE &&
5565 SCOPEG(s2) == SCOPEG(sptr)) {
5566 /* found it */
5567 sptr = s2;
5568 ps->new_sptr = sptr;
5569 fill_ST_MODULE(ps, sptr);
5570 return;
5571 }
5572 }
5573 } else if (module_base == 0 || sptr < module_base) {
5574 sptr = getocsym(sptr, stb.ovclass[stype], FALSE);
5575 }
5576
5577 if (for_module == sptr && stype == ST_MODULE) {
5578 /* re-use the 'module' symbol, if there is one, when importing
5579 * modules */
5580 } else if (STYPEG(sptr) == ST_UNKNOWN && SCOPEG(sptr) == stb.curr_scope) {
5581 int s2;
5582 if (sptr < module_base) {
5583 /* don't reuse the 'unknown' symbol */
5584 SCOPEP(sptr, 0);
5585 IGNOREP(sptr, 0);
5586 /* this occurs when 'sptr' is from the 'rename' clause */
5587 s2 = sptr;
5588 sptr = insert_sym(sptr);
5589 if (flg.debug && s2)
5590 set_modusename(s2, sptr);
5591 }
5592 /* else reuse the 'unknown' symbol */
5593 } else if (for_host && sptr < BASEsym && SCOPEG(sptr) == stb.curr_scope &&
5594 ps->sym.scope == stb.curr_scope && STYPEG(sptr) == stype) {
5595 /* redefinition of the same symbol */
5596 } else if (stype == ST_MODULE && STYPEG(sptr) == ST_MODULE) {
5597 /* re-use 'module' symbol */
5598 ps->new_sptr = sptr;
5599 return;
5600 } else if (((stype == ST_ENTRY && !for_inliner) || stype == ST_PROC)) {
5601 /* find the appropriate procedure to use, if it's available */
5602 /* at this point, generics have been resolved in caller and callee */
5603 for (s2 = sptr; s2 > NOSYM; s2 = HASHLKG(s2)) {
5604 if (s2 < original_symavl && NMPTRG(s2) == NMPTRG(sptr) &&
5605 (STYPEG(s2) == ST_ENTRY || STYPEG(s2) == ST_PROC)) {
5606 /* name matches, right stype, check if it should be or is
5607 * a module procedure */
5608 if ((SCOPEG(s2) == 0 && ps->sym.scope == 0) ||
5609 (SCOPEG(s2) != 0 && ps->sym.scope != 0 &&
5610 new_symbol(ps->sym.scope) == SCOPEG(s2))) {
5611 if ((ENCLFUNCG(s2) == 0 && ps->sym.w28 == 0) ||
5612 (ENCLFUNCG(s2) != 0 && ps->sym.w28 != 0 &&
5613 new_symbol(ps->sym.w28) == ENCLFUNCG(s2))) {
5614 break;
5615 }
5616 }
5617 }
5618 }
5619 if (s2 > NOSYM) {
5620 sptr = s2;
5621 } else {
5622 sptr = insert_sym(sptr);
5623 }
5624 } else {
5625 int sptr1 = NOSYM;
5626 if (stype == ST_MODPROC && STYPEG(sptr) == ST_USERGENERIC) {
5627 /* Looking for a MODPROC, found a USERGENERIC. See if there is a
5628 * MODPROC with the same name
5629 */
5630 for (sptr1 = first_hash(sptr); sptr1 > NOSYM; sptr1 = HASHLKG(sptr1)) {
5631 if (NMPTRG(sptr) == NMPTRG(sptr1) && STYPEG(sptr1) == ST_MODPROC) {
5632 sptr = sptr1;
5633 break;
5634 }
5635 }
5636 }
5637 if (sptr1 <= NOSYM) {
5638 sptr = insert_sym(sptr);
5639 }
5640 }
5641 if (for_inliner && SCOPEG(sptr) == stb.curr_scope) {
5642 fill_sym(ps, sptr);
5643 if (!XBIT(126, 1) && ST_ISVAR(STYPEG(sptr)))
5644 SCOPEP(sptr, stb.curr_scope);
5645 } else {
5646 fill_sym(ps, sptr);
5647 }
5648 ps->new_sptr = sptr;
5649 } /* import_symbol */
5650
5651 static void
import_ptr_constant(SYMITEM * ps)5652 import_ptr_constant(SYMITEM *ps)
5653 {
5654 int stype;
5655 stype = ps->stype;
5656 Trace(
5657 ("import_ptr_constant(%s=%d) with stype=%d", ps->name, ps->sptr, stype));
5658
5659 if (stype == ST_CONST) {
5660 int dtype;
5661 INT val[2];
5662 int sptr, s1;
5663 /* just move the CONVAL fields into sym[0] */
5664 BCOPY(stb.stg_base, &ps->sym, SYM, 1);
5665 /* handle the rest of the constant cases */
5666 dtype = new_dtype(ps->dtype);
5667 switch (DTY(dtype)) {
5668 case TY_PTR:
5669 s1 = CONVAL1G(0);
5670 if (s1) {
5671 val[0] = new_symbol(s1);
5672 val[1] = CONVAL2G(0);
5673 sptr = getcon(val, dtype);
5674 ps->new_sptr = sptr;
5675 }
5676 break;
5677 default:
5678 /* already handled */
5679 break;
5680 }
5681 }
5682 } /* import_ptr_constant */
5683
5684 /** \brief Fill DTYPE, and symbol links to other symbol links */
5685 static void
fill_links_symbol(SYMITEM * ps,WantPrivates wantPrivates)5686 fill_links_symbol(SYMITEM *ps, WantPrivates wantPrivates)
5687 {
5688 int ast, alias;
5689 int first, last;
5690 int mem, nml;
5691 int old_mem;
5692 int old_sptr, sptr, stype;
5693 DTYPE dtype;
5694
5695 old_sptr = ps->sptr;
5696 sptr = ps->new_sptr;
5697 stype = STYPEG(sptr);
5698
5699 if (ps->dtype == 0 && CVLENG(sptr)
5700 /* make sure we do not clear CVLEN for CLASS since it may be
5701 * a type bound procedure that overloads CVLEN with VTOFF or
5702 * VTABLE. TBD: may need to revisit with unlimited polymorphic
5703 * types.
5704 */
5705 && (!CLASSG(sptr) || (stype != ST_MEMBER && stype != ST_PROC &&
5706 stype != ST_USERGENERIC && stype != ST_OPERATOR))) {
5707 /* A function return value or a subprog argument that is a
5708 * fixed length string. Need to regenerate the dtype because
5709 * the dtype length is an ast that may not have been exported
5710 */
5711 int clen = CVLENG(sptr);
5712 int dty;
5713 /* HACK clen < 0 ==> TY_NCHAR */
5714 if (clen < 0) {
5715 clen = -clen;
5716 dty = TY_NCHAR;
5717 } else {
5718 dty = TY_CHAR;
5719 }
5720 dtype = get_type(2, dty, mk_cval(clen, DT_INT4));
5721 CVLENP(sptr, 0);
5722 } else {
5723 dtype = new_dtype(ps->dtype);
5724 }
5725 DTYPEP(sptr, dtype);
5726
5727 switch (stype) {
5728 case ST_CONST:
5729 /*SLNKP(sptr, 0);??*/
5730 SYMLKP(sptr, NOSYM);
5731 break;
5732 case ST_PARAM:
5733 /*
5734 * TBD - for named array constants, there are two symbols with the
5735 * same name, an ST_PARAM and an ST_ARRAY. The ST_PARAM's SYMLK
5736 * field locates the ST_ARRAY. In a non-module context, the
5737 * semantic analyzer creates both of these symbols. The second symbol
5738 * is not hashed into the symbol table; subsequent references of the
5739 * name constant during parsing always locate the ST_PARAM symbol.
5740 * When these symbols are read in from the module file, the
5741 * symbols are hashed, with the ST_ARRAY in front of the ST_PARAM.
5742 * This doesn't cause a problem except in the context where a
5743 * 'constant' is required.
5744 *
5745 * To fix, the ST_ARRAY needs to be 'unhashed',
5746 * but first, the data inits for the constant must find their way into
5747 * the module file --- TBD.
5748 */
5749 /*SLNKP(sptr, 0);???*/
5750 if (DTY(dtype) != TY_ARRAY) {
5751 ast = mk_id(sptr);
5752 if (!TY_ISWORD(DTY(dtype))) {
5753 CONVAL1P(sptr, new_symbol((int)CONVAL1G(sptr)));
5754 }
5755 if (DTY(dtype) < TY_PTR && A_ALIASG(ast) == 0) {
5756 alias = mk_cval1(CONVAL1G(sptr), DTYPEG(sptr));
5757 A_ALIASP(ast, alias);
5758 }
5759 /*
5760 * For DERIVED parameters, the CONVAL2 field was only meaningful
5761 * in its module file (and it's not an ast!!). So, do not try
5762 * to create an ast; in fact, clear it.
5763 */
5764 ast = 0;
5765 if (DTY(dtype) != TY_DERIVED) {
5766 ast = new_ast((int)CONVAL2G(sptr)); /* ast of expression */
5767 }
5768 CONVAL2P(sptr, ast);
5769 if ((!IGNOREG(sptr)) && (!ignore_private || !PRIVATEG(sptr))) {
5770 if (!PRIVATEG(sptr) || wantPrivates == INCLUDE_PRIVATES) {
5771 add_param(sptr); /* add_param() sets SYMLK */
5772 end_param();
5773 }
5774 }
5775 } else
5776 CONVAL1P(sptr, new_symbol((int)CONVAL1G(sptr)));
5777 DCLDP(sptr, 1);
5778 break;
5779 case ST_UNKNOWN:
5780 ENCLFUNCP(sptr, 0);
5781 break;
5782 case ST_IDENT:
5783 case ST_VAR:
5784 case ST_ARRAY:
5785 case ST_DESCRIPTOR:
5786 case ST_STRUCT:
5787 case ST_UNION:
5788 REFP(sptr, 0);
5789 if (for_interproc) {
5790 /* initialization information is not imported here */
5791 DINITP(sptr, 0);
5792 }
5793 if (for_inliner) {
5794 AUTOBJP(sptr, 0);
5795 }
5796 if (SLNKG(sptr) > NOSYM && can_find_symbol(SLNKG(sptr))) {
5797 SLNKP(sptr, new_symbol(SLNKG(sptr)));
5798 }
5799 #if DEBUG
5800 /* aux.list[] must be terminated with NOSYM, not 0 */
5801 assert(sptr > 0, "fill_links_symbol: corrupted aux.list[]", sptr, 3);
5802 #endif
5803 if (ps->socptr) {
5804 int sp;
5805 SOCPTRP(sptr, ps->socptr);
5806 for (sp = ps->socptr; sp; sp = SOC_NEXT(sp)) {
5807 SOC_SPTR(sp) = new_symbol(SOC_SPTR(sp));
5808 }
5809 }
5810
5811 if (ps->sc == SC_CMBLK || CMBLKG(sptr)) {
5812 /* don't clear the SYMLK field for common block members */
5813 /* storage class for common members at this point could
5814 * be based, for instance, so don't just check ps->sc */
5815 } else if (ps->sc == SC_BASED || POINTERG(sptr)) {
5816 SYMLKP(sptr, NOSYM);
5817 } else if (!for_inliner && !for_static && !CFUNCG(sptr)) {
5818 SYMLKP(sptr, NOSYM);
5819 HIDDENP(sptr, 1);
5820 }
5821 if (ps->sc == SC_LOCAL)
5822 ADDRESSP(sptr, 0);
5823 DCLDP(sptr, 1);
5824 if (ps->sc == SC_DUMMY && IGNOREG(sptr)) {
5825 MIDNUMP(sptr, 0);
5826 DESCRP(sptr, 0);
5827 PTROFFP(sptr, 0);
5828 if (SDSCG(sptr)) {
5829 if (can_find_symbol(SDSCG(sptr)))
5830 SDSCP(sptr, new_symbol(SDSCG(sptr)));
5831 if (IGNOREG(SDSCG(sptr))) {
5832 SDSCP(sptr, 0);
5833 }
5834 }
5835 } else {
5836 if (MIDNUMG(sptr))
5837 MIDNUMP(sptr, new_symbol(MIDNUMG(sptr)));
5838 if (DESCRG(sptr))
5839 DESCRP(sptr, new_symbol(DESCRG(sptr)));
5840 if (PTROFFG(sptr))
5841 PTROFFP(sptr, new_symbol(PTROFFG(sptr)));
5842 if (SDSCG(sptr))
5843 SDSCP(sptr, new_symbol(SDSCG(sptr)));
5844 }
5845
5846 if (ADJARRG(sptr) && SYMLKG(sptr) != NOSYM) {
5847 SYMLKP(sptr, new_symbol(SYMLKG(sptr)));
5848 }
5849
5850 if (ADJLENG(sptr) && ADJSTRLKG(sptr) && ADJSTRLKG(sptr) != NOSYM) {
5851 ADJSTRLKP(sptr, new_symbol(ADJSTRLKG(sptr)));
5852 }
5853 if (PARAMVALG(sptr))
5854 PARAMVALP(sptr, new_ast(PARAMVALG(sptr)));
5855 if (NMCNSTG(sptr))
5856 NMCNSTP(sptr, new_symbol(NMCNSTG(sptr)));
5857 if (CVLENG(sptr))
5858 CVLENP(sptr, new_symbol(CVLENG(sptr)));
5859 if (CFUNCG(sptr) && ALTNAMEG(sptr)) {
5860 ALTNAMEP(sptr, new_symbol(ALTNAMEG(sptr)));
5861 }
5862 if (stype == ST_DESCRIPTOR && PARENTG(sptr) && CLASSG(sptr) &&
5863 can_find_dtype(PARENTG(sptr))) {
5864 PARENTP(sptr, new_dtype(PARENTG(sptr)));
5865 } else if (stype == ST_DESCRIPTOR && PARENTG(sptr) && CLASSG(sptr)) {
5866 PARENTP(sptr, 0);
5867 }
5868 #ifdef DSCASTG
5869 if (stype != ST_DESCRIPTOR && DSCASTG(sptr))
5870 DSCASTP(sptr, new_ast(DSCASTG(sptr)));
5871 #endif
5872
5873 break;
5874 case ST_PLIST:
5875 /* SYMLK may need to be updated if it appears in a common block */
5876 if (for_interproc) {
5877 /* initialization information is not imported here */
5878 DINITP(sptr, 0);
5879 }
5880 break;
5881 case ST_CMBLK:
5882 DINITP(sptr, 0);
5883 /* process all elements of the common block */
5884 SYMLKP(sptr, gbl.cmblks);
5885 gbl.cmblks = sptr;
5886
5887 first = last = 0;
5888 for (old_mem = CMEMFG(sptr); old_mem > NOSYM; old_mem = SYMLKG(mem)) {
5889 mem = new_symbol(old_mem);
5890 SCP(mem, SC_CMBLK);
5891 CMBLKP(mem, sptr);
5892 if (last)
5893 SYMLKP(last, mem);
5894 else
5895 first = mem;
5896 last = mem;
5897 }
5898 SYMLKP(last, NOSYM);
5899 CMEMFP(sptr, first);
5900 CMEMLP(sptr, last);
5901 CMBLKP(sptr, 0);
5902 if (ALTNAMEG(sptr))
5903 ALTNAMEP(sptr, new_symbol(ALTNAMEG(sptr)));
5904 break;
5905 case ST_PROC:
5906 if (IS_PROC_DUMMYG(sptr) && SDSCG(sptr)) {
5907 SDSCP(sptr, new_symbol(SDSCG(sptr)));
5908 }
5909 if (FVALG(sptr) && can_find_symbol(FVALG(sptr))) {
5910 int fval;
5911 fval = new_symbol(FVALG(sptr));
5912 FVALP(sptr, fval);
5913 pop_sym(fval); /* never need to hash to return value name */
5914 }
5915 PARAMCTP(sptr, 0); /* TBD: fill in args */
5916 DPDSCP(sptr, 0);
5917 SYMLKP(sptr, NOSYM);
5918 if (FUNCG(sptr))
5919 DCLDP(sptr, 1); /* ensure functions are type declared */
5920 if (SLNKG(sptr) > NOSYM && can_find_symbol(SLNKG(sptr))) {
5921 SLNKP(sptr, new_symbol(SLNKG(sptr)));
5922 }
5923 #if DEBUG
5924 /* aux.list[ST_PROC] must be terminated with NOSYM, not 0 */
5925 assert(sptr > 0, "fill_links_symbol: corrupted aux.list[ST_PROC]", sptr, 3);
5926 #endif
5927 if (GSAMEG(sptr))
5928 GSAMEP(sptr, new_symbol(GSAMEG(sptr)));
5929 if (for_interproc || for_static) {
5930 HIDDENP(sptr, 1);
5931 }
5932 if (ALTNAMEG(sptr))
5933 ALTNAMEP(sptr, new_symbol(ALTNAMEG(sptr)));
5934 if (SCOPEG(sptr) && can_find_symbol(SCOPEG(sptr)))
5935 SCOPEP(sptr, new_symbol(SCOPEG(sptr)));
5936 if (CLASSG(sptr) && TBPLNKG(sptr) && can_find_dtype(TBPLNKG(sptr))) {
5937 TBPLNKP(sptr, new_dtype(TBPLNKG(sptr)));
5938 }
5939 break;
5940 case ST_ENTRY:
5941 if (FVALG(sptr)) {
5942 int fval;
5943 fval = new_symbol(FVALG(sptr));
5944 FVALP(sptr, fval);
5945 if (NMPTRG(fval) == NMPTRG(sptr))
5946 pop_sym(fval);
5947 }
5948 PARAMCTP(sptr, 0); /* TBD: fill in args */
5949 DPDSCP(sptr, 0);
5950 SYMLKP(sptr, NOSYM);
5951 if (for_interproc || for_static) {
5952 HIDDENP(sptr, 1);
5953 }
5954 if (ALTNAMEG(sptr))
5955 ALTNAMEP(sptr, new_symbol(ALTNAMEG(sptr)));
5956 if (SCOPEG(sptr))
5957 SCOPEP(sptr, new_symbol(SCOPEG(sptr)));
5958 break;
5959 case ST_NML:
5960 /* link into the list of namelists */
5961 SYMLKP(sptr, sem.nml);
5962 sem.nml = sptr;
5963 /* the first namelist entry was stashed in ps->ty */
5964 CMEMFP(sptr, ps->ty);
5965 /* get new symbol numbers for each of the namelist members */
5966 for (nml = CMEMFG(sptr); nml; nml = NML_NEXT(nml)) {
5967 NML_SPTR(nml) = new_symbol(NML_SPTR(nml));
5968 }
5969 if (ADDRESSG(sptr)) {
5970 /* the PLIST for the namelist is stored here */
5971 ADDRESSP(sptr, new_symbol(ADDRESSG(sptr)));
5972 }
5973 break;
5974 case ST_USERGENERIC:
5975 /* these field are not valid, and we need them to be inited
5976 to zero to handle multiple generic interfaces with same
5977 name. */
5978 if (GTYPEG(sptr) && !GNCNTG(sptr)) {
5979 /* Remap overloaded type */
5980 GTYPEP(sptr, new_symbol(GTYPEG(sptr)));
5981 }
5982 GNDSCP(sptr, 0);
5983 GNCNTP(sptr, 0);
5984 if (CLASSG(sptr) && TBPLNKG(sptr) && can_find_dtype(TBPLNKG(sptr))) {
5985 TBPLNKP(sptr, new_dtype(TBPLNKG(sptr)));
5986 }
5987 /* fall thru */
5988 case ST_STFUNC:
5989 case ST_PD:
5990 case ST_ISOC:
5991 SYMLKP(sptr, NOSYM);
5992 break;
5993 case ST_INTRIN:
5994 switch (DTY(dtype)) {
5995 case TY_DCMPLX:
5996 GDCMPLXP(GNRINTRG(sptr), sptr);
5997 break;
5998 case TY_CMPLX:
5999 GCMPLXP(GNRINTRG(sptr), sptr);
6000 break;
6001 }
6002 break;
6003
6004 case ST_LABEL:
6005 if (!CCSYMG(sptr))
6006 SYMLKP(sptr, NOSYM);
6007 break;
6008 case ST_TYPEDEF:
6009 case ST_STAG:
6010 SYMLKP(sptr, NOSYM);
6011 if (BASETYPEG(sptr))
6012 BASETYPEP(sptr, new_dtype(BASETYPEG(sptr)));
6013 PARENTP(sptr, new_symbol(PARENTG(sptr)));
6014 SDSCP(sptr, new_symbol(SDSCG(sptr)));
6015 if (TYPDEF_INITG(sptr) > NOSYM)
6016 TYPDEF_INITP(sptr, new_symbol(TYPDEF_INITG(sptr)));
6017 break;
6018 case ST_MEMBER:
6019 if (SYMLKG(sptr) == NOSYM) {
6020 } else if (SYMLKG(sptr) == old_sptr) {
6021 SYMLKP(sptr, sptr);
6022 } else {
6023 SYMLKP(sptr, new_symbol(SYMLKG(sptr)));
6024 }
6025 if (PSMEMG(sptr)) {
6026 if (PSMEMG(sptr) == old_sptr) {
6027 PSMEMP(sptr, sptr);
6028 } else {
6029 PSMEMP(sptr, new_symbol(PSMEMG(sptr)));
6030 }
6031 }
6032 if (VARIANTG(sptr) && VARIANTG(sptr) != NOSYM) {
6033 /* don't reinsert the parent member; parent must have been
6034 * inserted already */
6035 VARIANTP(sptr, new_symbol(VARIANTG(sptr)));
6036 }
6037 if (MIDNUMG(sptr))
6038 MIDNUMP(sptr, new_symbol(MIDNUMG(sptr)));
6039 if (DESCRG(sptr))
6040 DESCRP(sptr, new_symbol(DESCRG(sptr)));
6041 if (PTROFFG(sptr))
6042 PTROFFP(sptr, new_symbol(PTROFFG(sptr)));
6043 if (SDSCG(sptr))
6044 SDSCP(sptr, new_symbol(SDSCG(sptr)));
6045 if (ENCLDTYPEG(sptr))
6046 ENCLDTYPEP(sptr, new_dtype(ENCLDTYPEG(sptr)));
6047 if (PASSG(sptr)) {
6048 PASSP(sptr, new_symbol(PASSG(sptr)));
6049 }
6050 if (PARENTG(sptr)) {
6051 PARENTP(sptr, new_symbol(PARENTG(sptr)));
6052 }
6053 if (VTABLEG(sptr)) {
6054 VTABLEP(sptr, new_symbol(VTABLEG(sptr)));
6055 }
6056 if (IFACEG(sptr)) {
6057 IFACEP(sptr, new_symbol(IFACEG(sptr)));
6058 }
6059 if (BINDG(sptr)) {
6060 BINDP(sptr, new_symbol(BINDG(sptr)));
6061 }
6062 if (LENG(sptr) && LENPARMG(sptr)) {
6063 LENP(sptr, new_ast(LENG(sptr)));
6064 }
6065 if (INITKINDG(sptr) && PARMINITG(sptr)) {
6066 PARMINITP(sptr, new_ast(PARMINITG(sptr)));
6067 }
6068 if (KINDASTG(sptr)) {
6069 KINDASTP(sptr, new_ast(KINDASTG(sptr)));
6070 }
6071
6072 break;
6073 case ST_OPERATOR:
6074 if (INKINDG(sptr))
6075 bind_intrinsic_opr(PDNUMG(sptr), sptr);
6076 /* these field are not valid, and we need them to be inited
6077 to zero to handle multiple generic interfaces with same
6078 name. */
6079 GNDSCP(sptr, 0);
6080 GNCNTP(sptr, 0);
6081 SYMLKP(sptr, NOSYM);
6082 if (CLASSG(sptr) && TBPLNKG(sptr) && can_find_dtype(TBPLNKG(sptr))) {
6083 TBPLNKP(sptr, new_dtype(TBPLNKG(sptr)));
6084 }
6085 break;
6086 case ST_ARRDSC:
6087 SECDSCP(sptr, new_symbol(SECDSCG(sptr)));
6088 if (ARRAYG(sptr))
6089 ARRAYP(sptr, new_symbol(ARRAYG(sptr)));
6090 SYMLKP(sptr, NOSYM);
6091 break;
6092 case ST_ALIAS:
6093 SYMLKP(sptr, new_symbol(ps->symlk));
6094 if (PRIVATEG(sptr)) {
6095 }
6096 if (GSAMEG(sptr))
6097 GSAMEP(sptr, new_symbol(GSAMEG(sptr)));
6098 break;
6099 case ST_MODULE:
6100 break;
6101 case ST_MODPROC:
6102 if (ps->symlk)
6103 SYMLKP(sptr, new_symbol(ps->symlk));
6104 if (GSAMEG(sptr))
6105 GSAMEP(sptr, new_symbol(GSAMEG(sptr)));
6106 if (SYMLKG(sptr) && GSAMEG(sptr)) {
6107 /* if for modules, don't do this twice for module symbols */
6108 if (!for_module || SYMLKG(sptr) < module_base)
6109 GSAMEP(SYMLKG(sptr), GSAMEG(sptr)); /* ST_ENTRY -> generic */
6110 /* only do this for modules, and don't do twice for module symbols */
6111 if (for_module && GSAMEG(sptr) < module_base)
6112 GSAMEP(GSAMEG(sptr), SYMLKG(sptr)); /* generic -> ST_ENTRY */
6113 /* this line was removed because processing generics
6114 * also sets GSAMEP, and we can't do this twice */
6115 }
6116 break;
6117
6118 case ST_BLOCK:
6119 if (STARTLABG(sptr))
6120 STARTLABP(sptr, new_symbol(STARTLABG(sptr)));
6121 if (ENDLABG(sptr))
6122 ENDLABP(sptr, new_symbol(ENDLABG(sptr)));
6123 break;
6124
6125 default:
6126 interr("new_symbol:unexp stype", ps->stype, 3);
6127 break;
6128 }
6129 if (ENCLFUNCG(sptr) && can_find_symbol(ENCLFUNCG(sptr)))
6130 ENCLFUNCP(sptr, new_symbol(ENCLFUNCG(sptr)));
6131
6132 if (ps->sym.scope) {
6133 if (for_module || for_host) {
6134 SCOPEP(sptr, new_symbol(ps->sym.scope));
6135 } else if (for_static) {
6136 SCOPEP(sptr, new_symbol_if_module(ps->sym.scope));
6137 }
6138 }
6139 } /* fill_links_symbol */
6140
6141 static int
new_symbol(int old_sptr)6142 new_symbol(int old_sptr)
6143 {
6144 SYMITEM *ps;
6145 int sptr;
6146
6147 sptr = map_initsym(old_sptr, import_osym);
6148 if (sptr)
6149 return sptr;
6150 ps = findhash(old_sptr);
6151 if (ps)
6152 return ps->new_sptr;
6153 if (old_sptr == HOST_OLDSCOPE)
6154 return HOST_NEWSCOPE;
6155 if (old_sptr < BASEmod)
6156 return old_sptr;
6157 if (old_sptr < BASEsym)
6158 return old_sptr + ADJmod;
6159 interr("interf:new_symbol, symbol not found", old_sptr, 4);
6160 return 0;
6161 } /* new_symbol */
6162
6163 static int
new_symbol_if_module(int old_sptr)6164 new_symbol_if_module(int old_sptr)
6165 {
6166 SYMITEM *ps;
6167 int sptr, newsptr;
6168
6169 sptr = map_initsym(old_sptr, import_osym);
6170 if (sptr)
6171 return 0;
6172
6173 newsptr = 0;
6174 ps = findhash(old_sptr);
6175 if (ps) {
6176 if (ps->stype == ST_MODULE) {
6177 return ps->new_sptr;
6178 } else {
6179 return 0;
6180 }
6181 }
6182 if (old_sptr < BASEmod) {
6183 if (STYPEG(old_sptr) == ST_MODULE) {
6184 return old_sptr;
6185 }
6186 } else if (old_sptr < BASEsym) {
6187 if (STYPEG(old_sptr + ADJmod) == ST_MODULE) {
6188 return old_sptr + ADJmod;
6189 }
6190 }
6191 return 0;
6192 } /* new_symbol_if_module */
6193
6194 static void
new_symbol_and_link(int old_sptr,int * pnew,SYMITEM ** pps)6195 new_symbol_and_link(int old_sptr, int *pnew, SYMITEM **pps)
6196 {
6197 SYMITEM *ps;
6198 int sptr;
6199
6200 sptr = map_initsym(old_sptr, import_osym);
6201 if (sptr) {
6202 if (pnew)
6203 *pnew = sptr;
6204 if (pps)
6205 *pps = NULL;
6206 return;
6207 }
6208
6209 ps = findhash(old_sptr);
6210 if (ps) {
6211 if (pnew)
6212 *pnew = ps->new_sptr;
6213 if (pps)
6214 *pps = ps;
6215 return;
6216 }
6217 if (old_sptr < BASEmod) {
6218 if (pnew)
6219 *pnew = old_sptr;
6220 if (pps)
6221 *pps = NULL;
6222 return;
6223 }
6224 if (old_sptr < BASEsym) {
6225 if (pnew)
6226 *pnew = old_sptr + ADJmod;
6227 if (pps)
6228 *pps = NULL;
6229 return;
6230 }
6231 interr("interf:new_symbol_and_link, symbol not found", old_sptr, 4);
6232 } /* new_symbol_and_link */
6233
6234 static SYMITEM *
find_symbol(int old_sptr)6235 find_symbol(int old_sptr)
6236 {
6237 SYMITEM *ps;
6238
6239 ps = findhash(old_sptr);
6240 if (ps)
6241 return ps;
6242 #if DEBUG
6243 Trace(("cannot find old symbol %d in file %s", old_sptr, import_file_name));
6244 for (ps = symbol_list; ps != NULL; ps = ps->next) {
6245 Trace(("symbol list is %8lx = %4d (%4d) %s", ps, ps->sptr, ps->new_sptr,
6246 ps->name));
6247 }
6248 interr("module:find_symbol,stnfd", old_sptr, 0);
6249 #endif
6250 return symbol_list;
6251 }
6252
6253 static int
can_find_symbol(int old_sptr)6254 can_find_symbol(int old_sptr)
6255 {
6256 SYMITEM *ps;
6257
6258 ps = findhash(old_sptr);
6259 if (ps)
6260 return 1;
6261 return 0;
6262 }
6263
6264 static int
can_find_dtype(int old_dt)6265 can_find_dtype(int old_dt)
6266 {
6267 DITEM *pd;
6268 pd = finddthash(old_dt);
6269 if (pd)
6270 return 1;
6271 return 0;
6272 }
6273
6274 /** \brief Ensure that the common blocks from the interface file do not already
6275 * exist in the subprogram or if they do, their elements match.
6276 *
6277 * \return 0 if there aren't any conflicts; return the sptr to the common
6278 * block which conflicts.
6279 */
6280 static int
common_conflict(void)6281 common_conflict(void)
6282 {
6283 int cmblk, diff, prevcmblk, nextcmblk;
6284 SYMITEM *ps;
6285
6286 for (ps = symbol_list; ps; ps = ps->next) {
6287 if (ps->stype == ST_CMBLK) {
6288 for (cmblk = gbl.cmblks; cmblk != NOSYM; cmblk = SYMLKG(cmblk)) {
6289 if (!IGNOREG(cmblk) && strcmp(ps->name, SYMNAME(cmblk)) == 0) {
6290 Trace(("COMMON/%s/ already declared at symbol %d", ps->name, cmblk));
6291 diff = install_common(ps, cmblk);
6292 if (diff)
6293 return diff;
6294 }
6295 }
6296 }
6297 }
6298 prevcmblk = 0;
6299 for (cmblk = gbl.cmblks; cmblk > NOSYM; cmblk = nextcmblk) {
6300 nextcmblk = SYMLKG(cmblk);
6301 if (!IGNOREG(cmblk)) {
6302 /* keep cmblk on gbl.cmblks list */
6303 prevcmblk = cmblk;
6304 } else {
6305 /* remove cmblk from gbl.cmblks list */
6306 if (prevcmblk) {
6307 SYMLKP(prevcmblk, nextcmblk);
6308 } else {
6309 gbl.cmblks = nextcmblk;
6310 }
6311 SYMLKP(cmblk, NOSYM);
6312 }
6313 }
6314 return 0;
6315 } /* common_conflict */
6316
6317 /** \brief Compare the existing common block with the common block from the
6318 * interface file. Install the members while they match.
6319 *
6320 * NOTE: use sym entry 0 to hold the contents of the symbol from the
6321 * interface file so that the symtab macros can be used.
6322 */
6323 static int
install_common(SYMITEM * pscmblk,int cmblk)6324 install_common(SYMITEM *pscmblk, int cmblk)
6325 {
6326 SYMITEM *ps, *psfirst;
6327 int sptr;
6328 BCOPY(stb.stg_base, &pscmblk->sym, SYM, 1);
6329 ps = psfirst = find_symbol(CMEMFG(0));
6330 sptr = CMEMFG(cmblk);
6331 for (ps = psfirst; TRUE; ps = find_symbol(ps->symlk)) {
6332 if (!common_mem_eq(DTYPEG(sptr), new_dtype(ps->dtype)))
6333 goto common_diff;
6334 /* if end of inlined cblock reached, then ok: */
6335 if (ps->symlk == NOSYM)
6336 break;
6337
6338 /* check for inlined common block longer than pre-existing: */
6339 sptr = SYMLKG(sptr);
6340 if (sptr == NOSYM)
6341 goto common_diff;
6342 }
6343 /* the same */
6344 if (pscmblk->new_sptr) {
6345 IGNOREP(pscmblk->new_sptr, 1);
6346 HIDDENP(pscmblk->new_sptr, 1);
6347 }
6348 pscmblk->new_sptr = cmblk;
6349 pscmblk->sc = -1;
6350 sptr = CMEMFG(cmblk);
6351 for (ps = psfirst; TRUE; ps = find_symbol(ps->symlk)) {
6352 if (ps->new_sptr) {
6353 IGNOREP(ps->new_sptr, 1);
6354 HIDDENP(ps->new_sptr, 1);
6355 }
6356 ps->new_sptr = sptr;
6357 ps->sc = -1;
6358 /* if end of inlined cblock reached, then ok: */
6359 if (ps->symlk == NOSYM)
6360 break;
6361 sptr = SYMLKG(sptr);
6362 }
6363
6364 BZERO(stb.stg_base, SYM, 1);
6365 return 0;
6366
6367 common_diff:
6368 BZERO(stb.stg_base, SYM, 1);
6369 return cmblk;
6370 } /* install_common */
6371
6372 /** \brief return TRUE if two data types are equal.
6373 *
6374 * This function only needs to handle dtype situations resulting
6375 * from commonblock elements.
6376 */
6377 static LOGICAL
common_mem_eq(int d1,int d2)6378 common_mem_eq(int d1, int d2)
6379 {
6380 ADSC *ad1, *ad2;
6381 int n;
6382
6383 if (d1 == d2)
6384 return TRUE;
6385
6386 if (DTY(d1) != TY_ARRAY && DTY(d2) != TY_ARRAY)
6387 return FALSE;
6388
6389 if (DTY(d1 + 1) != DTY(d2 + 1))
6390 return FALSE; /* element types not the same */
6391
6392 ad1 = AD_DPTR(d1);
6393 ad2 = AD_DPTR(d2);
6394 n = AD_NUMDIM(ad1);
6395 if (n != AD_NUMDIM(ad2))
6396 return FALSE;
6397
6398 while (--n >= 0) {
6399 if (AD_UPAST(ad1, n) != AD_UPAST(ad2, n) ||
6400 AD_LWAST(ad1, n) != AD_LWAST(ad2, n))
6401 return FALSE; /* dimensions don't match */
6402 }
6403
6404 return TRUE;
6405 }
6406
6407 static int
import_mk_newsym(char * name,int stype)6408 import_mk_newsym(char *name, int stype)
6409 {
6410 int sptr;
6411
6412 sptr = getsymbol(name);
6413 /* if this is ST_UNKNOWN, or is a MODULE and we want a MODULE, use it.
6414 * otherwise, insert a new symbol */
6415 if (STYPEG(sptr) != ST_UNKNOWN &&
6416 (STYPEG(sptr) != ST_MODULE || stype != ST_MODULE))
6417 sptr = insert_sym(sptr);
6418 STYPEP(sptr, stype);
6419 SCOPEP(sptr, 0);
6420
6421 return sptr;
6422 }
6423
rw_import_state(RW_ROUTINE,RW_FILE)6424 void rw_import_state(RW_ROUTINE, RW_FILE)
6425 {
6426 int nw;
6427 int i;
6428 int nodecnt;
6429 USES_LIST *usenode, *prevnode;
6430 TOBE_IMPORTED_LIST *um;
6431
6432 RW_SCALAR(imported_modules.avail);
6433 /* since the imported_modules.list is never actually freed or
6434 * shrunk, it should already be of the proper size */
6435 RW_FD(imported_modules.list, IMPORT_LIST, imported_modules.avail);
6436
6437 /* save/restore the use_tree root (root is actually a list). If this is
6438 * a read, then
6439 * freed so the USES_LIST items still exist and can be re-used.
6440 */
6441 if (!ISREAD()) {
6442 for (nodecnt = 0, usenode = use_tree; usenode;
6443 usenode = usenode->next, nodecnt++)
6444 ;
6445 }
6446
6447 RW_SCALAR(nodecnt);
6448 prevnode = NULL;
6449 usenode = use_tree;
6450 if (ISREAD())
6451 init_use_tree();
6452
6453 for (i = 0; i < nodecnt; i++) {
6454 /* since the MOD_USE_AREA has not been deallocated, the TOBE_IMPORTED_LIST
6455 * nodes
6456 * still exist. Just save and restore ptrs to them.
6457 */
6458 if (!ISREAD()) {
6459 um = usenode->use_module;
6460 prevnode = usenode;
6461 usenode = usenode->next;
6462 }
6463 RW_SCALAR(um);
6464 if (ISREAD()) {
6465 add_to_use_tree(um);
6466 }
6467 }
6468
6469 } /* rw_import_state */
6470
6471 /* ----------------------------------------------------------------- */
6472
6473 static int
ipa_ast(int a)6474 ipa_ast(int a)
6475 {
6476 return new_ast(a);
6477 }
6478
6479 static int
dindex(int dtype)6480 dindex(int dtype)
6481 {
6482 return new_dtype(dtype);
6483 }
6484
6485 static int
get_symbolxref(int sptr)6486 get_symbolxref(int sptr)
6487 {
6488 return new_symbol(sptr);
6489 }
6490
6491