1 /*
2 * Copyright (c) 1997-2018, 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 /** \file
19 \brief Routines for exporting symbols to .mod files and to IPA.
20 */
21
22 #include "gbldefs.h"
23 #include "global.h"
24 #include "error.h"
25 #include "symtab.h"
26 #include "dtypeutl.h"
27 #include "machar.h"
28 #include "semant.h"
29 #include "ast.h"
30 #include "dinit.h"
31 #include "soc.h"
32 #include "lz.h"
33 #define TRACEFLAG 48
34 #define TRACEBIT 4
35 #define TRACESTRING "export"
36 #include "trace.h"
37
38 #define INSIDE_INTERF
39 #include "interf.h"
40 #include "fih.h"
41
42 #include "dpm_out.h"
43
44 #define COMPILER_OWNED_MODULE XBIT(58,0x100000)
45
46 /* ------------------------------------------------------------------ */
47 /* ----------------------- Export Utilities ------------------------- */
48 /* ------------------------------------------------------------------ */
49
50 /* ------------------------------------------------------------------ */
51 /* Write symbols to export file */
52 /* This is used for:
53 * module interface files
54 * interprocedural analysis
55 * procedure inlining
56 * static variable initialization
57 */
58
59 /* getitem area for module temp storage; pick an area not used by
60 * the caller of export()/import().
61 */
62 #define MOD_AREA 18
63
64 /* getitem area for appending symbols to the mod file; pick an area not
65 * used by semant and export()/import().
66 */
67 #define APPEND_AREA 19
68
69 typedef struct itemx {/* generic item record */
70 int val;
71 struct itemx *next;
72 } ITEMX;
73
74 typedef struct xitemx {/* generic item record */
75 int val;
76 struct xitemx *next;
77 int exceptlist;
78 } XITEMX;
79
80 static char *symbol_flag; /* flags for symbols being exported */
81 static int symbol_flag_size;
82 static int symbol_flag_lowest_const = 0;
83 static char *dtype_flag; /* flags for data types being exported */
84 static int dtype_flag_size;
85 static char *ast_flag; /* flags for asts being exported */
86 static int ast_flag_size;
87 static int ast_flag_lowest_const = 0;
88 static char *eqv_flag; /* flags for equivalences being exported */
89 static XITEMX *public_module_list = NULL; /* queue of modules in public part */
90 static ITEMX *private_module_list = NULL; /* other modules */
91
92 static ITEMX *append_list; /* list of symbols to be appended to mod file */
93
94 static LOGICAL for_module = FALSE;
95 static LOGICAL for_inliner = FALSE;
96 static int sym_module = 0; /* if we are exporting a module,
97 or a subprogram within a module */
98 static LOGICAL for_contained = FALSE;
99 static LOGICAL exporting_module = FALSE;
100 static lzhandle *outlz;
101 static int exportmode = 0;
102 #define MAX_FNAME_LEN 258
103
104 static int out_platform = MOD_ANY;
105
106 EXPORTB exportb;
107
108 static void queue_symbol(int);
109 static void rqueue_ast(int ast, int *unused);
110 static void queue_ast(int ast);
111 static void queue_dtype(int dtype);
112 static void export_dtypes(int, int);
113 static void export_outer_derived_dtypes(int limit);
114 static void export_dt(int);
115 static void export_symbol(int);
116 static void export_one_ast(int);
117 static void export_iso_c_libraries(void);
118 static void export_iso_fortran_env_libraries(void);
119 static void export_ieee_arith_libraries(void);
120 static void export_one_std(int);
121 static void queue_one_std(int std);
122 static void all_stds(void (*)(int));
123 static void export_parameter_info(ast_visit_fn);
124 static void export_data_file(int);
125 static void export_component_init(int);
126 static void export_data_file_asts(ast_visit_fn, int, int, int);
127 static void export_component_init_asts(ast_visit_fn, int, int);
128 static void export_equiv_asts(int, ast_visit_fn);
129 static void export_dist_info(int, ast_visit_fn);
130 static void export_align_info(int, ast_visit_fn);
131 static void export_equivs(void);
132 static void export_external_equiv();
133
134 static void export_dinit_file(void (*)(int), void (*)(int, INT), int);
135 static void export_dinit_record(int, INT);
136 static int dtype_skip(int dtype);
137
138 /* return 1 if the base type is double/complex/other 8-byte-type */
139 static int
doubletype(int sptr)140 doubletype(int sptr)
141 {
142 int dtype, dty;
143 dtype = DTYPEG(sptr);
144 dty = DTY(dtype);
145 if (dty == TY_ARRAY) {
146 dtype = DTY(dtype + 1);
147 dty = DTY(dtype);
148 }
149 switch (dty) {
150 case TY_DWORD:
151 case TY_INT8:
152 case TY_DBLE:
153 case TY_QUAD:
154 case TY_CMPLX:
155 case TY_DCMPLX:
156 case TY_QCMPLX:
157 case TY_LOG8:
158 return 1;
159 }
160 return 0;
161 } /* doubletype */
162
163 void
export_public_module(int module,int exceptlist)164 export_public_module(int module, int exceptlist)
165 {
166 XITEMX *p;
167
168 /* if an equivalent entry is in the list, don't add a duplicate */
169 for (p = public_module_list; p; p = p->next) {
170 if (p->val == module) {
171 if (same_sym_list(p->exceptlist, exceptlist)) {
172 return;
173 }
174 }
175 }
176
177 p = (XITEMX *)getitem(MOD_AREA, sizeof(XITEMX));
178 p->val = module;
179 p->next = public_module_list;
180 p->exceptlist = exceptlist;
181 public_module_list = p;
182 } /* export_public_module */
183
184 static lzhandle *
export_header(FILE * fd,char * export_name,int compress)185 export_header(FILE *fd, char *export_name, int compress)
186 {
187 lzhandle *lz;
188
189 if (XBIT(124, 0x10)) {
190 out_platform = out_platform | MOD_I8;
191 }
192 if (XBIT(124, 0x8)) {
193 out_platform = out_platform | MOD_R8;
194 }
195 if (XBIT(68, 0x1)) {
196 out_platform = out_platform | MOD_LA;
197 }
198 if (COMPILER_OWNED_MODULE)
199 out_platform = out_platform | MOD_PG;
200
201 fprintf(fd, "V%d :0x%x %s\n", IVSN, out_platform, export_name);
202 fprintf(fd, "%d %s S%d %d\n", (unsigned)strlen(gbl.src_file), gbl.src_file,
203 stb.firstosym, compress);
204
205 lz = lzinitfile(fd, 0 /*compress*/);
206 lzprintf(lz, "%s\n", gbl.datetime);
207
208 /* do the public and private libraries */
209 if (for_module || for_inliner || for_contained) {
210 XITEMX *pub;
211 ITEMX *p;
212 for (pub = public_module_list; pub; pub = pub->next) {
213 int i, count;
214 int base = CMEMFG(pub->val);
215 lzprintf(lz, "use %s public", SYMNAME(pub->val));
216 count = 0;
217 for (i = pub->exceptlist; i; i = SYMI_NEXT(i))
218 ++count;
219 lzprintf(lz, " %d", count);
220 for (i = pub->exceptlist; i; i = SYMI_NEXT(i)) {
221 lzprintf(lz, " %d", SYMI_SPTR(i) - base);
222 }
223 if (imported_directly(SYMNAME(pub->val), pub->exceptlist)) {
224 lzprintf(lz, " direct\n");
225 } else {
226 lzprintf(lz, " indirect\n");
227 }
228 }
229 for (p = private_module_list; p; p = p->next) {
230 lzprintf(lz, "use %s private\n", SYMNAME(p->val));
231 }
232 }
233 lzprintf(lz, "enduse\n");
234 return lz;
235 } /* export_header */
236
export(FILE * export_fd,char * export_name,int cleanup)237 static void export(FILE *export_fd, char *export_name, int cleanup)
238 {
239 int sptr;
240 int member;
241 int ast;
242 ITEMX *p;
243 XITEMX *pub;
244 char *t_nm;
245 int ty;
246 int acc; /* access type: 0 = PUBLIC, 1 = PRIVATE */
247 int chr; /* 0 => non-character; 1 => character */
248 int modcm;
249 int idx;
250 int sptr1;
251 int dtype;
252 int i;
253
254 Trace(("****** Exporting ******"));
255 #if DEBUG
256 if (DBGBIT(5, 16384))
257 symdmp(gbl.dbgfil, DBGBIT(5, 8));
258 #endif
259
260 symbol_flag_size = stb.stg_avail + 1;
261 symbol_flag_lowest_const = stb.stg_avail;
262 NEW(symbol_flag, char, symbol_flag_size);
263 BZERO(symbol_flag, char, stb.stg_avail + 1);
264
265 dtype_flag_size = stb.dt.stg_avail + 1;
266 NEW(dtype_flag, char, dtype_flag_size);
267 BZERO(dtype_flag, char, dtype_flag_size);
268
269 ast_flag_size = astb.stg_avail + 1;
270 ast_flag_lowest_const = astb.stg_avail;
271 NEW(ast_flag, char, ast_flag_size);
272 BZERO(ast_flag, char, ast_flag_size);
273
274 NEW(eqv_flag, char, sem.eqv_avail + 1);
275 BZERO(eqv_flag, char, sem.eqv_avail + 1);
276
277 for (pub = public_module_list; pub; pub = pub->next) {
278 symbol_flag[pub->val] = 1;
279 }
280 if (for_module) {
281 symbol_flag[sym_module] = 1;
282 }
283
284 exportb.hmark.maxsptr = stb.firstosym;
285 ast_visit(1, 1);
286 if (for_module || for_inliner) {
287 for (sptr = stb.firstosym; sptr < stb.stg_avail; sptr++) {
288 switch (STYPEG(sptr)) {
289 case ST_CMBLK:
290 if (for_module) {
291 if (!IGNOREG(sptr) && SCOPEG(sptr) == sym_module) {
292 FROMMODP(sptr, 1);
293 queue_symbol(sptr);
294 }
295 }
296 break;
297 case ST_ENTRY:
298 if (!for_module) {
299 if (!IGNOREG(sptr)) {
300 if (!for_inliner ||
301 (sptr == gbl.currsub || SCOPEG(sptr) == SCOPEG(gbl.currsub)))
302 queue_symbol(sptr);
303 }
304 }
305 break;
306 case ST_UNKNOWN:
307 case ST_PARAM:
308 case ST_ARRDSC:
309 case ST_OPERATOR:
310 case ST_TYPEDEF:
311 case ST_STAG:
312 case ST_MEMBER:
313 case ST_MODULE:
314 case ST_MODPROC:
315 case ST_ALIAS:
316 if (for_module) {
317 if (!IGNOREG(sptr) &&
318 (STYPEG(sptr) != ST_UNKNOWN || SCG(sptr) != SC_NONE) &&
319 (SCOPEG(sptr) == sym_module || STYPEG(sptr) == ST_OPERATOR)) {
320 if (STYPEG(sptr) == ST_TYPEDEF)
321 FROMMODP(sptr, 1);
322 queue_symbol(sptr);
323 }
324 } else if (for_inliner) {
325 if (!IGNOREG(sptr) && sptr >= stb.firstusym) {
326 if (sptr == gbl.currsub || SCOPEG(sptr) == SCOPEG(gbl.currsub))
327 queue_symbol(sptr);
328 }
329 }
330 break;
331 case ST_USERGENERIC:
332 case ST_PROC:
333 if (for_module) {
334 if (!IGNOREG(sptr) && SCOPEG(sptr) == sym_module) {
335 queue_symbol(sptr);
336 }
337 } else if (for_inliner) {
338 if (!IGNOREG(sptr) && sptr >= stb.firstusym) {
339 if (sptr == gbl.currsub || SCOPEG(sptr) == SCOPEG(gbl.currsub))
340 queue_symbol(sptr);
341 }
342 }
343 break;
344 case ST_LABEL:
345 case ST_BLOCK:
346 if (for_module) {
347 if (!IGNOREG(sptr) && SCOPEG(sptr) == sym_module)
348 queue_symbol(sptr);
349 } else if (for_inliner) {
350 if (!IGNOREG(sptr) && sptr >= stb.firstusym) {
351 if (sptr == gbl.currsub || SCOPEG(sptr) == SCOPEG(gbl.currsub))
352 queue_symbol(sptr);
353 }
354 }
355 break;
356 case ST_NML:
357 if (for_module) {
358 if (!IGNOREG(sptr) && SCOPEG(sptr) == sym_module) {
359 queue_symbol(sptr);
360 }
361 } else if (exporting_module) {
362 queue_symbol(sptr);
363 }
364 break;
365 case ST_ARRAY:
366 case ST_DESCRIPTOR:
367 case ST_VAR:
368 case ST_STRUCT:
369 case ST_UNION:
370 if (STYPEG(sptr) == ST_DESCRIPTOR && CLASSG(sptr) &&
371 SCG(sptr) == SC_EXTERN && sem.mod_dllexport) {
372 /* need to export type descriptor */
373 DLLP(sptr, DLL_EXPORT);
374 }
375 if (for_module) {
376 if (!IGNOREG(sptr) && SCOPEG(sptr) == sym_module) {
377 queue_symbol(sptr);
378 }
379 }
380 break;
381 case ST_IDENT:
382 if (for_module) {
383 if (SCG(sptr) == SC_DUMMY && SCOPEG(SCOPEG(sptr)) != sym_module &&
384 TBP_BOUND_TO_SMPG(SCOPEG(sptr))) {
385 queue_symbol(sptr);
386 }
387 }
388 break;
389 default:
390 break;
391 }
392 }
393 }
394
395 exportb.hmark.dt = DT_MAX + 1;
396
397 {
398 /* queue up all variables ever used, and
399 * all alignment descriptors and distribution descriptors used in
400 * realign/redistribute statements */
401 if (!for_module)
402 all_stds(queue_one_std);
403 if (for_module) {
404 int evp, evpfirst;
405 for (evpfirst = sem.eqvlist; evpfirst; evpfirst = EQV(evpfirst).next) {
406 if (EQV(evpfirst).is_first) {
407 LOGICAL found = FALSE;
408 evp = evpfirst;
409 do {
410 if (SCOPEG(EQV(evp).sptr) == sym_module ||
411 symbol_flag[EQV(evp).sptr]) {
412 found = TRUE;
413 break;
414 }
415 evp = EQV(evp).next;
416 } while (evp && !EQV(evp).is_first);
417 if (found) {
418 evp = evpfirst;
419 do {
420 int ss, numss, j;
421 eqv_flag[evp] = 1;
422 queue_symbol(EQV(evp).sptr);
423 queue_ast(EQV(evp).substring);
424 ss = EQV(evp).subscripts;
425 numss = EQV_NUMSS(ss);
426 /* depends on EQV_NUMSS(0) == 0, set in semant.c */
427 for (j = 0; j < numss; ++j) {
428 if (EQV_SS(ss, j))
429 queue_ast(EQV_SS(ss, j));
430 }
431 evp = EQV(evp).next;
432 } while (evp && !EQV(evp).is_first);
433 }
434 }
435 }
436 export_data_file_asts(rqueue_ast, 1, 1, 0);
437 export_component_init_asts(rqueue_ast, 1, 1);
438 } else {
439 int evp;
440 for (evp = sem.eqvlist; evp; evp = EQV(evp).next) {
441 int ss, numss, j;
442 eqv_flag[evp] = 1;
443 queue_symbol(EQV(evp).sptr);
444 queue_ast(EQV(evp).substring);
445 ss = EQV(evp).subscripts;
446 numss = EQV_NUMSS(ss);
447 /* depends on EQV_NUMSS(0) == 0, set in semant.c */
448 for (j = 0; j < numss; ++j) {
449 if (EQV_SS(ss, j))
450 queue_ast(EQV_SS(ss, j));
451 }
452 }
453 }
454 }
455 ast_unvisit();
456
457 outlz = export_header(export_fd, export_name, 0);
458
459 if (for_module) {
460 export_iso_c_libraries();
461 export_iso_fortran_env_libraries();
462 export_ieee_arith_libraries();
463 }
464
465 export_dtypes(0, 0);
466
467 for (sptr = stb.firstosym; sptr < stb.stg_avail; ++sptr) {
468 if (symbol_flag[sptr])
469 export_symbol(sptr);
470 }
471
472 for (ast = astb.firstuast; ast < astb.stg_avail; ++ast) {
473 if (ast >= ast_flag_size || ast_flag[ast])
474 export_one_ast(ast);
475 }
476 {
477 exportb.hmark.ast = astb.firstuast;
478 exportb.hmark.maxast = astb.stg_avail - 1;
479 if (!for_module)
480 all_stds(export_one_std);
481 export_equivs();
482 }
483
484 if (cleanup) {
485 freearea(MOD_AREA);
486 public_module_list = NULL;
487 private_module_list = NULL;
488 }
489
490 /* symbols, etc., will be added for the module subprograms */
491 append_list = NULL;
492
493 lzprintf(outlz, "Z\n");
494 {
495 export_data_file(0);
496 export_component_init(cleanup);
497 }
498 lzprintf(outlz, "Z\n");
499
500 FREE(eqv_flag);
501 FREE(ast_flag);
502 ast_flag_size = 0;
503 FREE(dtype_flag);
504 dtype_flag_size = 0;
505 FREE(symbol_flag);
506 symbol_flag_size = 0;
507 lzfinifile(outlz);
508 outlz = NULL;
509 fflush(export_fd);
510 } /* export */
511
512 void
export_iso_c_libraries(void)513 export_iso_c_libraries(void)
514 {
515 int first, last, sptr;
516
517 if (exportb.iso_c_library) {
518 Trace(("Exporting ISO_C Library"));
519 iso_c_lib_stat(&first, &last, ST_ISOC);
520 for (sptr = first; sptr <= last; ++sptr) {
521 if (STYPEG(sptr) == ST_INTRIN) {
522 lzprintf(outlz, "B %d %s %s\n", sptr, "iso_c_binding", SYMNAME(sptr));
523 }
524 }
525 sptr = lookupsymbol("c_sizeof");
526 lzprintf(outlz, "B %d %s %s\n", sptr, "iso_c_binding", SYMNAME(sptr));
527 }
528 } /* export_iso_c_libraries */
529
530 void
export_iso_fortran_env_libraries(void)531 export_iso_fortran_env_libraries(void)
532 {
533 int sptr;
534
535 if (exportb.iso_fortran_env_library) {
536 sptr = lookupsymbol("compiler_options");
537 lzprintf(outlz, "B %d %s %s\n", sptr, "iso_c_binding", SYMNAME(sptr));
538 sptr = lookupsymbol("compiler_version");
539 lzprintf(outlz, "B %d %s %s\n", sptr, "iso_c_binding", SYMNAME(sptr));
540 }
541 }
542
543 void
export_ieee_arith_libraries(void)544 export_ieee_arith_libraries(void)
545 {
546 int sptr;
547
548 if (exportb.ieee_arith_library) {
549 Trace(("Exporting IEEE_ARITH Library"));
550 sptr = get_ieee_arith_intrin("ieee_selected_real_kind");
551 lzprintf(outlz, "B %d %s %s\n", sptr, "ieee_arithmetic", SYMNAME(sptr));
552 }
553 }
554
555 void
export_inline(FILE * export_fd,char * export_name,char * file_name)556 export_inline(FILE *export_fd, char *export_name, char *file_name)
557 {
558 int internal;
559 lzhandle *export_lz;
560 for_inliner = TRUE;
561 if (gbl.internal > 1) {
562 internal = INTERNALG(gbl.currsub);
563 INTERNALP(gbl.currsub, 1);
564 }
565 export(export_fd, export_name, 1);
566 fclose(export_fd);
567 if (gbl.internal > 1) {
568 INTERNALP(gbl.currsub, internal);
569 }
570 for_inliner = FALSE;
571 sym_module = 0;
572 } /* export_inline */
573
574 /** \brief Save the module file for use when exporting contained subprograms */
575 void
export_module(FILE * module_file,char * export_name,int modulesym,int cleanup)576 export_module(FILE *module_file, char *export_name, int modulesym, int cleanup)
577 {
578 lzhandle *module_lz;
579
580 Trace(("Exporting module name %s", export_name));
581 for_module = TRUE;
582 sym_module = modulesym;
583 exporting_module = TRUE;
584 export(module_file, export_name, cleanup);
585 exporting_module = FALSE;
586 for_module = FALSE;
587 sym_module = 0;
588 }
589
590 void
export_append_sym(int sym)591 export_append_sym(int sym)
592 {
593 ITEMX *p;
594
595 Trace(("export append symbol %d %s", sym, SYMNAME(sym)));
596 p = (ITEMX *)getitem(APPEND_AREA, sizeof(ITEMX));
597 p->val = sym;
598 p->next = append_list;
599 append_list = p;
600 }
601
602 static ITEMX
603 *host_append_list; /* list of symbols to be appended to host file */
604
605 static void
mark_idstr(int ast,int * unused)606 mark_idstr(int ast, int *unused)
607 {
608 if (A_TYPEG(ast) == A_ID && SCG(A_SPTRG(ast)) != SC_DUMMY) {
609 A_IDSTRP(ast, 1);
610 }
611 }
612
613 void
mark_dtype_ast_idstr(int dtype)614 mark_dtype_ast_idstr(int dtype)
615 {
616 int i;
617 int ndim;
618
619 if (DTY(dtype) == TY_CHAR) {
620 if (DTY(dtype + 1)) {
621 ast_traverse(DTY(dtype + 1), NULL, mark_idstr, NULL);
622 }
623 } else if (DTY(dtype) == TY_ARRAY && DTY(dtype + 2) > 0) {
624 ndim = ADD_NUMDIM(dtype);
625 for (i = 0; i < ndim; ++i) {
626 if (ADD_LWBD(dtype, i)) {
627 ast_traverse(ADD_LWBD(dtype, i), NULL, mark_idstr, NULL);
628 }
629 if (ADD_UPBD(dtype, i)) {
630 ast_traverse(ADD_UPBD(dtype, i), NULL, mark_idstr, NULL);
631 }
632 }
633 }
634 }
635
636 void
export_append_host_sym(int sym)637 export_append_host_sym(int sym)
638 {
639 ITEMX *p;
640
641 Trace(("export append symbol %d %s", sym, SYMNAME(sym)));
642 p = (ITEMX *)getitem(APPEND_AREA, sizeof(ITEMX));
643 p->val = sym;
644 p->next = host_append_list;
645 host_append_list = p;
646 }
647
648 void
export_fix_host_append_list(int (* newsym)(int))649 export_fix_host_append_list(int (*newsym)(int))
650 {
651 ITEMX *p;
652 int oldv;
653 for (p = host_append_list; p != NULL; p = p->next) {
654 oldv = p->val;
655 p->val = newsym(oldv);
656 Trace(("fix host symbol %d to %d", oldv, p->val));
657 }
658 } /* export_fix_host_append_list */
659
660 static void
export_some_init()661 export_some_init()
662 {
663 symbol_flag_size = stb.stg_avail + 1;
664 symbol_flag_lowest_const = stb.stg_avail;
665 NEW(symbol_flag, char, symbol_flag_size);
666 BZERO(symbol_flag, char, stb.stg_avail + 1);
667
668 dtype_flag_size = stb.dt.stg_avail + 1;
669 NEW(dtype_flag, char, dtype_flag_size);
670 BZERO(dtype_flag, char, dtype_flag_size);
671
672 ast_flag_size = astb.stg_avail + 1;
673 ast_flag_lowest_const = astb.stg_avail;
674 NEW(ast_flag, char, ast_flag_size);
675 BZERO(ast_flag, char, ast_flag_size);
676
677 NEW(eqv_flag, char, sem.eqv_avail + 1);
678 BZERO(eqv_flag, char, sem.eqv_avail + 1);
679
680 } /* export_some_init */
681
682 static void
export_some_procedure(int sptr)683 export_some_procedure(int sptr)
684 {
685 int fval, cnt, dpdsc;
686 STYPEP(sptr, ST_PROC);
687 for (cnt = PARAMCTG(sptr), dpdsc = DPDSCG(sptr); cnt; --cnt, ++dpdsc) {
688 int arg = aux.dpdsc_base[dpdsc];
689 IGNOREP(arg, 1);
690 }
691 fval = FVALG(sptr);
692 if (fval) {
693 dpdsc = DPDSCG(sptr);
694 DTYPEP(sptr, DTYPEG(fval));
695 if (aux.dpdsc_base[dpdsc] == FVALG(sptr)) {
696 DPDSCP(sptr, dpdsc + 1);
697 PARAMCTP(sptr, PARAMCTG(sptr) - 1);
698 }
699 IGNOREP(fval, 1);
700 }
701 } /* export_some_procedure */
702
703 static void
export_some_args(int sptr,int limitsptr)704 export_some_args(int sptr, int limitsptr)
705 {
706 int fval, cnt, dpdsc;
707 for (cnt = PARAMCTG(sptr), dpdsc = DPDSCG(sptr); cnt; --cnt, ++dpdsc) {
708 int arg = aux.dpdsc_base[dpdsc];
709 if (arg < limitsptr) {
710 export_symbol(arg);
711 }
712 }
713 fval = FVALG(sptr);
714 if (fval) {
715 if (fval < limitsptr) {
716 export_symbol(fval);
717 }
718 }
719 } /* export_some_args */
720
721 static void
export_some_fini(int limitsptr,int limitast)722 export_some_fini(int limitsptr, int limitast)
723 {
724 int sptr, ast;
725 ITEMX *p;
726 for (sptr = symbol_flag_lowest_const; sptr < limitsptr; ++sptr) {
727 if (symbol_flag[sptr] && STYPEG(sptr) == ST_CONST) {
728 export_symbol(sptr);
729 }
730 }
731 for (sptr = limitsptr; sptr < stb.stg_avail; ++sptr) {
732 if (symbol_flag[sptr])
733 export_symbol(sptr);
734 }
735
736 for (ast = ast_flag_lowest_const; ast < limitast; ++ast) {
737 if (ast_flag[ast] && A_TYPEG(ast) == A_CNST) {
738 export_one_ast(ast);
739 }
740 }
741 for (ast = limitast; ast < astb.stg_avail; ++ast) {
742 if (ast >= ast_flag_size || ast_flag[ast])
743 export_one_ast(ast);
744 }
745
746 export_equivs();
747
748 FREE(eqv_flag);
749 FREE(ast_flag);
750 ast_flag_size = 0;
751 FREE(dtype_flag);
752 dtype_flag_size = 0;
753 FREE(symbol_flag);
754 freearea(MOD_AREA);
755 public_module_list = NULL;
756 private_module_list = NULL;
757 lzprintf(outlz, "Z\n");
758 } /* export_some_fini */
759
760 /* If the type of a contained subprogram return value or argument is a
761 * fixed length string, the dtype length (dtype+1) is an ast that will
762 * not be exported if the dtype happens to match the dtype of some data
763 * item or literal in the host. Stash the string DTY and length in the
764 * symbol table entry so the dtype can be reconstructed when imported.
765 */
766 static void
fixup_host_symbol_dtype(int sptr)767 fixup_host_symbol_dtype(int sptr)
768 {
769 int dtype = DTYPEG(sptr);
770 if ((DTY(dtype) == TY_CHAR &&
771 (dtype != DT_ASSCHAR || dtype != DT_DEFERCHAR)) ||
772 (DTY(dtype) == TY_NCHAR &&
773 (dtype != DT_ASSNCHAR || dtype != DT_DEFERNCHAR))) {
774 int clen = DTY(dtype + 1);
775 if (A_ALIASG(clen)
776 /* If CLASS is set, then do not clear CVLEN since it's overloaded by
777 * VTOFF and VTABLE which are used with type bound procedures. We
778 * may need to revisit this when we implement unlimited polymorphic
779 * types.
780 */
781 && (!CLASSG(sptr) ||
782 (STYPEG(sptr) != ST_MEMBER && STYPEG(sptr) != ST_PROC))) {
783 DTYPEP(sptr, 0);
784 clen = CONVAL2G(A_SPTRG(A_ALIASG(clen)));
785 /* HACK clen < 0 ==> TY_NCHAR */
786 if (DTY(dtype) == TY_NCHAR) {
787 clen = -clen;
788 }
789 CVLENP(sptr, clen);
790 }
791 } else if (DTY(dtype) == TY_ARRAY && ADJARRG(sptr)) {
792 /* similar to above condition if the bound is host symbol
793 * symbol will not be exported.
794 */
795 if (DTY(dtype + 2) > 0) {
796 ast_visit(1,1);
797 mark_dtype_ast_idstr(dtype);
798 ast_unvisit();
799 }
800 }
801 }
802
803 void
export_host_subprogram(FILE * host_file,int host_sym,int limitsptr,int limitast,int limitdtype)804 export_host_subprogram(FILE *host_file, int host_sym, int limitsptr,
805 int limitast, int limitdtype)
806 {
807 ITEMX *p;
808 Trace(("write host subprogram %d %s", host_sym, SYMNAME(host_sym)));
809 if (host_file == NULL) {
810 interr("no file to which to export contained subprogram", 0, 3);
811 }
812 if (sem.mod_cnt) {
813 sym_module = sem.mod_sym;
814 }
815 for_contained = TRUE;
816 export_some_init();
817 Trace(
818 ("limits are sptr=%d, ast=%d, dty=%d", limitsptr, limitast, limitdtype));
819
820 for (p = host_append_list; p != NULL; p = p->next) {
821 export_some_procedure(p->val);
822 INTERNALP(p->val, 1);
823 }
824 for (p = host_append_list; p != NULL; p = p->next) {
825 fixup_host_symbol_dtype(p->val);
826 ast_visit(1, 1);
827 queue_symbol(p->val);
828 ast_unvisit();
829 }
830
831 outlz = export_header(host_file, "host file", 0);
832
833 export_outer_derived_dtypes(limitdtype);
834 if (gbl.internal && FVALG(gbl.currsub) &&
835 (DTY(DTYPEG(FVALG(gbl.currsub))) != TY_ARRAY ||
836 !ADD_DEFER(DTYPEG(FVALG(gbl.currsub))))) {
837 ast_visit(1, 1);
838 mark_dtype_ast_idstr(DTYPEG(FVALG(gbl.currsub)));
839 ast_unvisit();
840 }
841 export_dtypes(limitdtype, 0);
842
843 for (p = host_append_list; p != NULL; p = p->next) {
844 if (p->val < limitsptr) {
845 export_symbol(p->val);
846 }
847 export_some_args(p->val, limitsptr);
848 }
849
850 export_some_fini(limitsptr, limitast);
851 lzfinifile(outlz);
852 outlz = NULL;
853 fflush(host_file);
854 sym_module = 0;
855 for_contained = FALSE;
856 } /* export_host_subprogram */
857
858 void
export_module_subprogram(FILE * subprog_file,int subprog_sym,int limitsptr,int limitast,int limitdtype)859 export_module_subprogram(FILE *subprog_file, int subprog_sym, int limitsptr,
860 int limitast, int limitdtype)
861 {
862 ITEMX *p;
863 int sptr;
864 Trace(("write module subprogram %d %s", subprog_sym, SYMNAME(subprog_sym)));
865 if (subprog_file == NULL) {
866 interr("no file to which to export contained subprogram", 0, 3);
867 }
868 export_some_init();
869 Trace(
870 ("limits are sptr=%d, ast=%d, dty=%d", limitsptr, limitast, limitdtype));
871
872 ENCLFUNCP(subprog_sym, sem.mod_sym);
873 if (STYPEG(subprog_sym) == ST_ALIAS) {
874 ENCLFUNCP(SYMLKG(subprog_sym), sem.mod_sym);
875 }
876 sym_module = sem.mod_sym;
877 for_contained = TRUE;
878 for (sptr = subprog_sym; sptr > NOSYM; sptr = SYMLKG(sptr)) {
879 export_some_procedure(sptr);
880 INMODULEP(sptr, 1);
881 ast_visit(1, 1);
882 queue_symbol(sptr);
883 ast_unvisit();
884 }
885 for (p = append_list; p != NULL; p = p->next) {
886 ast_visit(1, 1);
887 queue_symbol(p->val);
888 ast_unvisit();
889 }
890
891 /*
892 * Ensure that certain symbols are ignored by the compiler when
893 * read from the module file; these symbol need to have their
894 * IGNORE & HIDDEN flags set when exported. Typically, these
895 * symbols were discovered from the specification of the dummy
896 * arguments and are 'local' to the contained subprogram.
897 */
898 for (sptr = stb.stg_avail - 1; sptr > limitsptr; sptr--) {
899 if (symbol_flag[sptr])
900 switch (STYPEG(sptr)) {
901 case ST_IDENT:
902 case ST_VAR:
903 case ST_ARRAY:
904 case ST_STRUCT:
905 case ST_UNION:
906 case ST_CMBLK:
907 case ST_PARAM:
908 if (SCOPEG(sptr) && (SCOPEG(sptr) != sym_module) && !CFUNCG(sptr)) {
909 /*
910 * If symbol doesn't have module scope, assume it's
911 * local. Another way of determine if the symbol is
912 * local:
913 * - the symbol's SCOPE is subprog_sym, or
914 * - if SCOPE of subprog_sym is an ST_ALIAS, the symbol's
915 * SCOPE is the alias.
916 * CFUNCG : externally visable "C" style variable, type
917 * or common block
918 */
919 HIDDENP(sptr, 1);
920 IGNOREP(sptr, 1);
921 Trace(("Ignore %d(%s) in %d(%s)", sptr, SYMNAME(sptr), subprog_sym,
922 SYMNAME(subprog_sym)));
923 }
924 case ST_TYPEDEF:
925 if (SCOPEG(sptr) && (SCOPEG(sptr) != sym_module)) {
926 /*
927 * If symbol doesn't have module scope, assume it's
928 * local. Another way of determine if the symbol is
929 * local:
930 * - the symbol's SCOPE is subprog_sym, or
931 * - if SCOPE of subprog_sym is an ST_ALIAS, the symbol's
932 * SCOPE is the alias.
933 */
934 HIDDENP(sptr, 1);
935 IGNOREP(sptr, 1);
936 Trace(("Ignore %d(%s) in %d(%s)", sptr, SYMNAME(sptr), subprog_sym,
937 SYMNAME(subprog_sym)));
938 }
939 break;
940 case ST_ENTRY:
941 case ST_PROC:
942 if (sem.mod_dllexport && ENCLFUNCG(sptr) == gbl.currmod) {
943 DLLP(sptr, DLL_EXPORT);
944 }
945 break;
946
947 default:
948 break;
949 }
950 }
951
952 outlz = export_header(subprog_file, "module-contained subprogram file", 0);
953
954 export_dtypes(limitdtype, 1);
955
956 for (sptr = subprog_sym; sptr > NOSYM; sptr = SYMLKG(sptr)) {
957 if (sptr < limitsptr) {
958 export_symbol(sptr);
959 export_some_args(sptr, limitsptr);
960 }
961 }
962 for (p = append_list; p != NULL; p = p->next) {
963 if (STYPEG(p->val) == ST_MODPROC) {
964 export_symbol(p->val);
965 }
966 }
967 for (p = append_list; p != NULL; p = p->next) {
968 if (STYPEG(p->val) != ST_MODPROC) {
969 export_symbol(p->val);
970 }
971 }
972 append_list = NULL;
973
974 export_some_fini(limitsptr, limitast);
975 lzfinifile(outlz);
976 outlz = NULL;
977 fflush(subprog_file);
978 sym_module = 0;
979 for_contained = FALSE;
980 } /* export_module_subprogram */
981
982 void
exterf_init()983 exterf_init()
984 {
985 freearea(APPEND_AREA);
986 append_list = NULL;
987 host_append_list = NULL;
988 } /* exterf_init */
989
990 void
exterf_init_host()991 exterf_init_host()
992 {
993 host_append_list = NULL;
994 } /* exterf_init_host */
995
996 static VAR *
export_ivl_asts(VAR * ivl,ast_visit_fn astproc)997 export_ivl_asts(VAR *ivl, ast_visit_fn astproc)
998 {
999 do {
1000 if (ivl->u.varref.subt) {
1001 export_ivl_asts(ivl->u.varref.subt, astproc);
1002 } else {
1003 ast_traverse(ivl->u.varref.ptr, NULL, astproc, NULL);
1004 }
1005 ivl = ivl->next;
1006 } while (ivl != NULL && ivl->id == Varref);
1007 return ivl;
1008 } /* export_ivl_asts */
1009
1010 static void
export_ict_asts(ACL * ict,ast_visit_fn astproc,int queuesym,int queuedtype,int domarkdtype)1011 export_ict_asts(ACL *ict, ast_visit_fn astproc, int queuesym, int queuedtype,
1012 int domarkdtype)
1013 {
1014 for (; ict != NULL; ict = ict->next) {
1015 if (queuesym && ict->sptr)
1016 queue_symbol(ict->sptr);
1017 if (ict->id == AC_IDO) {
1018 if (ict->u1.doinfo->init_expr)
1019 ast_traverse(ict->u1.doinfo->init_expr, NULL, astproc, NULL);
1020 if (ict->u1.doinfo->limit_expr)
1021 ast_traverse(ict->u1.doinfo->limit_expr, NULL, astproc, NULL);
1022 if (ict->u1.doinfo->step_expr)
1023 ast_traverse(ict->u1.doinfo->step_expr, NULL, astproc, NULL);
1024 if (ict->u1.doinfo->count)
1025 ast_traverse(ict->u1.doinfo->count, NULL, astproc, NULL);
1026 if (queuesym && ict->u1.doinfo->index_var)
1027 queue_symbol(ict->u1.doinfo->index_var);
1028 }
1029 if (queuedtype) {
1030 if (ict->dtype)
1031 queue_dtype(ict->dtype);
1032 if (ict->ptrdtype)
1033 queue_dtype(ict->ptrdtype);
1034 }
1035 if (!ict->subc) {
1036 if (ict->id == AC_IEXPR) {
1037 int dtype = ict->dtype;
1038 if (DTY(dtype) == TY_DERIVED) {
1039 if (queuesym && DTY(dtype + 3))
1040 queue_symbol(DTY(dtype + 3));
1041 }
1042 if (queuedtype)
1043 queue_dtype(ict->dtype);
1044 export_ict_asts(ict->u1.expr->lop, astproc, queuesym, queuedtype,
1045 domarkdtype);
1046 if (BINOP(ict->u1.expr)) {
1047 export_ict_asts(ict->u1.expr->rop, astproc, queuesym, queuedtype,
1048 domarkdtype);
1049 }
1050 } else {
1051 if (queuedtype)
1052 queue_dtype(ict->dtype);
1053 if (ict->u1.ast > 0 && ict->u1.ast <= astb.stg_avail)
1054 ast_traverse(ict->u1.ast, NULL, astproc, NULL);
1055 }
1056 if (ict->repeatc) {
1057 ast_traverse(ict->repeatc, NULL, astproc, NULL);
1058 }
1059 } else {
1060 int dtype = ict->dtype;
1061 if (DTY(dtype) == TY_DERIVED) {
1062 if (queuesym && DTY(dtype + 3))
1063 queue_symbol(DTY(dtype + 3));
1064 }
1065 if (ict->repeatc) {
1066 ast_traverse(ict->repeatc, NULL, astproc, NULL);
1067 }
1068 if (queuedtype)
1069 queue_dtype(ict->dtype);
1070 export_ict_asts(ict->subc, astproc, queuesym, queuedtype, domarkdtype);
1071 }
1072 }
1073 } /* export_ict_asts */
1074
1075 static void
export_ivl_ict_asts(VAR * ivl,ACL * ict,ast_visit_fn astproc,int queuesym,int queuedtype,int domarkdtype)1076 export_ivl_ict_asts(VAR *ivl, ACL *ict, ast_visit_fn astproc, int queuesym,
1077 int queuedtype, int domarkdtype)
1078 {
1079 /* ignore structures except for IPA */
1080 if (!exportmode && ivl == NULL && ict->subc != NULL)
1081 return;
1082 if (!ivl) {
1083 if (queuesym && ict->sptr)
1084 queue_symbol(ict->sptr);
1085 } else {
1086 VAR *next;
1087 for (; ivl != NULL; ivl = next) {
1088 next = ivl->next;
1089 switch (ivl->id) {
1090 case Dostart:
1091 ast_traverse(ivl->u.dostart.indvar, NULL, astproc, NULL);
1092 ast_traverse(ivl->u.dostart.lowbd, NULL, astproc, NULL);
1093 ast_traverse(ivl->u.dostart.upbd, NULL, astproc, NULL);
1094 if (ivl->u.dostart.step) {
1095 ast_traverse(ivl->u.dostart.step, NULL, astproc, NULL);
1096 }
1097 break;
1098 case Doend:
1099 break;
1100 case Varref:
1101 next = export_ivl_asts(ivl, astproc);
1102 break;
1103 default:
1104 break;
1105 }
1106 }
1107 }
1108 export_ict_asts(ict, astproc, queuesym, queuedtype, domarkdtype);
1109 } /* export_ivl_ict_asts */
1110
1111 static void
export_data_file_asts(ast_visit_fn astproc,int queuesym,int queuedtype,int domarkdtype)1112 export_data_file_asts(ast_visit_fn astproc, int queuesym, int queuedtype,
1113 int domarkdtype)
1114 {
1115 int nw, lineno, fileno;
1116 VAR *ivl;
1117 ACL *ict;
1118 if (astb.df == NULL)
1119 return;
1120 nw = fseek(astb.df, 0L, 0);
1121 #if DEBUG
1122 assert(nw == 0, "export_data_file_asts: rewind error", nw, 4);
1123 #endif
1124 while (1) {
1125 nw = fread(&lineno, sizeof(lineno), 1, astb.df);
1126 if (nw == 0)
1127 break;
1128 #if DEBUG
1129 assert(nw == 1, "export_data_file_asts: lineno error", nw, 4);
1130 #endif
1131 nw = fread(&fileno, sizeof(fileno), 1, astb.df);
1132 if (nw == 0)
1133 break;
1134 #if DEBUG
1135 assert(nw == 1, "export_dinit_file: fileno error", nw, 4);
1136 #endif
1137 nw = fread(&ivl, sizeof(ivl), 1, astb.df);
1138 if (nw == 0)
1139 break;
1140 #if DEBUG
1141 assert(nw == 1, "export_data_file_asts: ivl error", nw, 4);
1142 #endif
1143 nw = fread(&ict, sizeof(ict), 1, astb.df);
1144 #if DEBUG
1145 assert(nw == 1, "export_data_file_asts: ict error", nw, 4);
1146 #endif
1147 export_ivl_ict_asts(ivl, ict, astproc, queuesym, queuedtype, domarkdtype);
1148 } /* while */
1149 } /* export_data_file_asts */
1150
1151 static void
export_component_init_asts(ast_visit_fn astproc,int queuesym,int queuedtype)1152 export_component_init_asts(ast_visit_fn astproc, int queuesym, int queuedtype)
1153 {
1154 int dtype;
1155
1156 for (dtype = DT_MAX + 1; dtype < stb.dt.stg_avail;) {
1157 if (DTY(dtype) == TY_DERIVED) {
1158 ACL *ict = (ACL *)get_getitem_p(DTY(dtype + 5));
1159 if (ict) {
1160 export_ict_asts(ict, astproc, queuesym, queuedtype, 0);
1161 }
1162 }
1163 dtype += dtype_skip(dtype);
1164 }
1165 }
1166
1167 static VAR *
export_ivl(VAR * ivl)1168 export_ivl(VAR *ivl)
1169 {
1170 do {
1171 int more = 0;
1172 if (ivl->next)
1173 more = 1;
1174 if (ivl->u.varref.subt) {
1175 lzprintf(outlz, "W %d %d\n", ivl->u.varref.dtype, more);
1176 export_ivl(ivl->u.varref.subt);
1177 } else {
1178 lzprintf(outlz, "V %d %d %d %d\n", ivl->u.varref.ptr, ivl->u.varref.dtype,
1179 ivl->u.varref.id, more);
1180 }
1181 ivl = ivl->next;
1182 } while (ivl != NULL && ivl->id == Varref);
1183 return ivl;
1184 } /* export_ivl */
1185
1186 static void
export_ict(ACL * ict)1187 export_ict(ACL *ict)
1188 {
1189 for (; ict != NULL; ict = ict->next) {
1190 int more = 0;
1191 if (ict->next)
1192 more = 1;
1193 switch (ict->id) {
1194 case AC_IDENT:
1195 lzprintf(outlz, "I %d %d %d %d %d %d\n", ict->sptr, ict->dtype,
1196 ict->ptrdtype, ict->repeatc, ict->u1.ast, more);
1197 break;
1198 case AC_CONST:
1199 lzprintf(outlz, "C %d %d %d %d %d %d\n", ict->sptr, ict->dtype,
1200 ict->ptrdtype, ict->repeatc, ict->u1.ast, more);
1201 break;
1202 case AC_AST:
1203 lzprintf(outlz, "A %d %d %d %d %d %d %d\n", ict->sptr, ict->dtype,
1204 ict->ptrdtype, ict->repeatc, (int)ict->is_const, ict->u1.ast,
1205 more);
1206 break;
1207 case AC_ACONST:
1208 lzprintf(outlz, "R %d %d %d %d\n", ict->sptr, ict->dtype, ict->ptrdtype,
1209 more);
1210 export_ict(ict->subc);
1211 break;
1212 case AC_SCONST:
1213 lzprintf(outlz, "S %d %d %d %d %d\n", ict->sptr, ict->dtype,
1214 ict->ptrdtype, ict->repeatc, more);
1215 export_ict(ict->subc);
1216 break;
1217 case AC_IDO:
1218 lzprintf(outlz, "O %d %d %d %d %d\n", ict->u1.doinfo->index_var,
1219 ict->u1.doinfo->init_expr, ict->u1.doinfo->limit_expr,
1220 ict->u1.doinfo->step_expr, more);
1221 export_ict(ict->subc);
1222 break;
1223 case AC_REPEAT:
1224 lzprintf(outlz, "P %d %d %d %d %d\n", ict->sptr, ict->dtype,
1225 ict->ptrdtype, ict->u1.ast, more);
1226 break;
1227 case AC_VMSUNION:
1228 lzprintf(outlz, "U %d %d %d %d %d %d\n", ict->sptr, ict->dtype,
1229 ict->ptrdtype, ict->repeatc, ict->u1.ast, more);
1230 export_ict(ict->subc);
1231 break;
1232 case AC_TYPEINIT:
1233 lzprintf(outlz, "T %d %d %d %d %d %d\n", ict->sptr, ict->dtype,
1234 ict->ptrdtype, ict->repeatc, ict->u1.ast, more);
1235 export_ict(ict->subc);
1236 break;
1237 case AC_VMSSTRUCT:
1238 lzprintf(outlz, "V %d %d %d %d %d %d\n", ict->sptr, ict->dtype,
1239 ict->ptrdtype, ict->repeatc, ict->u1.ast, more);
1240 export_ict(ict->subc);
1241 break;
1242 case AC_IEXPR:
1243 lzprintf(outlz, "X %d %d %d %d %d %d\n", ict->u1.expr->op, ict->sptr,
1244 ict->dtype, ict->ptrdtype, ict->repeatc, more);
1245 if (ict->u1.expr->lop)
1246 export_ict(ict->u1.expr->lop);
1247 else
1248 lzprintf(outlz, "N\n");
1249 if (BINOP(ict->u1.expr)) {
1250 if (ict->u1.expr->rop)
1251 export_ict(ict->u1.expr->rop);
1252 else
1253 lzprintf(outlz, "N\n");
1254 }
1255 break;
1256 case AC_ICONST:
1257 lzprintf(outlz, "L %d %d\n", ict->u1.i, more);
1258 break;
1259 default:
1260 interr("Attempt to export an unknown initializer type\n", ict->id, 3);
1261 return;
1262 }
1263 }
1264 } /* export_ict */
1265
1266 static void
export_ivl_ict(int lineno,VAR * ivl,ACL * ict,int dostructures)1267 export_ivl_ict(int lineno, VAR *ivl, ACL *ict, int dostructures)
1268 {
1269 /* ignore structures */
1270 if (ivl == NULL && ict->subc != NULL && !dostructures)
1271 return;
1272
1273 if (for_module && ivl) {
1274 /* put out initializations for named constants ONLY */
1275 if (ivl->next) {
1276 /* data statement, can't be a named constant */
1277 return;
1278 } else if (ivl->id == Varref) {
1279 int sptr = sym_of_ast(ivl->u.varref.ptr);
1280 if (!PARAMG(sptr)) {
1281 return;
1282 }
1283 }
1284 }
1285
1286 if (ivl == NULL) {
1287 lzprintf(outlz, "J %d 0 1\n", lineno);
1288 } else {
1289 VAR *next;
1290 lzprintf(outlz, "J %d 1 1\n", lineno);
1291 for (; ivl != NULL; ivl = next) {
1292 int more = 0;
1293 next = ivl->next;
1294 if (next)
1295 more = 1;
1296 switch (ivl->id) {
1297 case Dostart:
1298 lzprintf(outlz, "D %d %d %d %d %d\n", ivl->u.dostart.indvar,
1299 ivl->u.dostart.lowbd, ivl->u.dostart.upbd, ivl->u.dostart.step,
1300 more);
1301 break;
1302 case Doend:
1303 lzprintf(outlz, "E %d\n", more);
1304 break;
1305 case Varref:
1306 next = export_ivl(ivl);
1307 break;
1308 default:
1309 break;
1310 }
1311 }
1312 }
1313 export_ict(ict);
1314 } /* export_ivl_ict */
1315
1316 static void
export_component_init(int cleanup)1317 export_component_init(int cleanup)
1318 {
1319 int dtype, flag;
1320 flag = 2;
1321 if (cleanup)
1322 flag = 1;
1323
1324 for (dtype = DT_MAX + 1; dtype < stb.dt.stg_avail;) {
1325 if (DTY(dtype) == TY_DERIVED) {
1326 ACL *ict = (ACL *)get_getitem_p(DTY(dtype + 5));
1327 if (ict && (ict->ci_exprt & flag) == 0) {
1328 export_ict(ict);
1329 ict->ci_exprt |= flag;
1330 }
1331 }
1332 dtype += dtype_skip(dtype);
1333 }
1334 }
1335
1336 static void
export_data_file(int dostructures)1337 export_data_file(int dostructures)
1338 {
1339 int nw, lineno, fileno;
1340 VAR *ivl;
1341 ACL *ict;
1342 if (astb.df == NULL)
1343 return;
1344 nw = fseek(astb.df, 0L, 0);
1345 while (1) {
1346 nw = fread(&lineno, sizeof(lineno), 1, astb.df);
1347 if (nw == 0)
1348 break;
1349 nw = fread(&fileno, sizeof(fileno), 1, astb.df);
1350 if (nw == 0)
1351 break;
1352 nw = fread(&ivl, sizeof(ivl), 1, astb.df);
1353 if (nw == 0)
1354 break;
1355 nw = fread(&ict, sizeof(ict), 1, astb.df);
1356 export_ivl_ict(lineno, ivl, ict, dostructures);
1357 } /* while */
1358 } /* export_data_file */
1359
1360 /* ----------------------------------------------------------- */
1361 static void
rqueue_ast(int ast,int * unused)1362 rqueue_ast(int ast, int *unused)
1363 {
1364 int shape;
1365 int s, i, cnt;
1366 if (!ast)
1367 return;
1368 if (ast < ast_flag_size) {
1369 if (ast_flag[ast])
1370 return;
1371 ast_flag[ast] = 1;
1372 }
1373 switch (A_TYPEG(ast)) {
1374 case A_ID:
1375 if (A_ALIASG(ast) && A_ALIASG(ast) != ast)
1376 queue_ast(A_ALIASG(ast));
1377 case A_CNST:
1378 if (ast < ast_flag_lowest_const)
1379 ast_flag_lowest_const = ast;
1380 case A_LABEL:
1381 case A_INIT:
1382 if (A_SPTRG(ast) && A_SPTRG(ast) < symbol_flag_size)
1383 queue_symbol(A_SPTRG(ast));
1384 if (A_DTYPEG(ast) && A_SPTRG(ast) < symbol_flag_size)
1385 queue_dtype(A_DTYPEG(ast));
1386 break;
1387 case A_ALLOC:
1388 if (A_DTYPEG(ast))
1389 queue_dtype(A_DTYPEG(ast));
1390 break;
1391 case A_FUNC:
1392 case A_INTR:
1393 if (A_DTYPEG(ast))
1394 queue_dtype(A_DTYPEG(ast));
1395 s = A_SHAPEG(ast);
1396 if (s) {
1397 cnt = SHD_NDIM(s);
1398 for (i = 0; i < cnt; ++i) {
1399 int bound;
1400 if ((bound = SHD_LWB(s, i)))
1401 queue_ast(bound);
1402 if ((bound = SHD_UPB(s, i)))
1403 queue_ast(bound);
1404 if ((bound = SHD_STRIDE(s, i)))
1405 queue_ast(bound);
1406 }
1407 }
1408 break;
1409 case A_FORALL:
1410 case A_IF:
1411 case A_IFTHEN:
1412 case A_ELSEIF:
1413 case A_DOWHILE:
1414 case A_AIF:
1415 case A_WHERE:
1416 queue_ast(A_IFSTMTG(ast));
1417 break;
1418 case A_MP_TARGET:
1419 case A_MP_TARGETDATA:
1420 queue_ast(A_IFPARG(ast));
1421 queue_ast(A_LOPG(ast));
1422 break;
1423 case A_MP_TARGETUPDATE:
1424 case A_MP_TARGETEXITDATA:
1425 case A_MP_TARGETENTERDATA:
1426 queue_ast(A_IFPARG(ast));
1427 break;
1428 case A_MP_ENDTARGETDATA:
1429 case A_MP_ENDTARGET:
1430 queue_ast(A_LOPG(ast));
1431 break;
1432 case A_MP_PARALLEL:
1433 queue_ast(A_IFPARG(ast));
1434 queue_ast(A_NPARG(ast));
1435 queue_ast(A_LOPG(ast));
1436 queue_ast(A_ENDLABG(ast));
1437 queue_ast(A_PROCBINDG(ast));
1438 break;
1439 case A_MP_TEAMS:
1440 queue_ast(A_NTEAMSG(ast));
1441 queue_ast(A_THRLIMITG(ast));
1442 queue_ast(A_LOPG(ast));
1443 break;
1444 case A_MP_BMPSCOPE:
1445 queue_ast(A_STBLKG(ast));
1446 break;
1447 case A_MP_CRITICAL:
1448 case A_MP_ENDCRITICAL:
1449 queue_ast(A_LOPG(ast));
1450 queue_symbol(A_MEMG(ast));
1451 break;
1452 case A_MP_CANCEL:
1453 queue_ast(A_IFPARG(ast));
1454 case A_MP_SECTIONS:
1455 case A_MP_CANCELLATIONPOINT:
1456 queue_ast(A_ENDLABG(ast));
1457 break;
1458 case A_MP_PDO:
1459 queue_ast(A_DOLABG(ast));
1460 queue_ast(A_DOVARG(ast));
1461 queue_ast(A_LASTVALG(ast));
1462 queue_ast(A_M1G(ast));
1463 queue_ast(A_M2G(ast));
1464 queue_ast(A_M3G(ast));
1465 queue_ast(A_CHUNKG(ast));
1466 queue_ast(A_ENDLABG(ast));
1467 break;
1468 case A_MP_ATOMICREAD:
1469 queue_ast(A_SRCG(ast));
1470 break;
1471 case A_MP_ATOMICWRITE:
1472 case A_MP_ATOMICUPDATE:
1473 case A_MP_ATOMICCAPTURE:
1474 queue_ast(A_LOPG(ast));
1475 queue_ast(A_ROPG(ast));
1476 break;
1477 case A_MP_PRE_TLS_COPY:
1478 case A_MP_COPYIN:
1479 case A_MP_COPYPRIVATE:
1480 queue_ast(A_ROPG(ast));
1481 queue_symbol(A_SPTRG(ast));
1482 break;
1483 case A_MP_TASK:
1484 queue_ast(A_IFPARG(ast));
1485 queue_ast(A_FINALPARG(ast));
1486 queue_ast(A_PRIORITYG(ast));
1487 queue_ast(A_LOPG(ast));
1488 queue_ast(A_ENDLABG(ast));
1489 break;
1490 case A_MP_TASKLOOP:
1491 queue_ast(A_IFPARG(ast));
1492 queue_ast(A_FINALPARG(ast));
1493 queue_ast(A_PRIORITYG(ast));
1494 queue_ast(A_LOPG(ast));
1495 break;
1496 case A_MP_TASKLOOPREG:
1497 queue_ast(A_M1G(ast));
1498 queue_ast(A_M2G(ast));
1499 queue_ast(A_M3G(ast));
1500 break;
1501 case A_MP_TASKFIRSTPRIV:
1502 queue_ast(A_LOPG(ast));
1503 queue_ast(A_ROPG(ast));
1504 break;
1505 case A_MP_TASKREG:
1506 case A_MP_TASKDUP:
1507 case A_MP_ENDPARALLEL:
1508 case A_MP_MASTER:
1509 case A_MP_ENDMASTER:
1510 case A_MP_SINGLE:
1511 case A_MP_ENDSINGLE:
1512 case A_MP_SECTION:
1513 case A_MP_LSECTION:
1514 case A_MP_ENDSECTIONS:
1515 case A_MP_WORKSHARE:
1516 case A_MP_ENDWORKSHARE:
1517 case A_MP_ENDTASK:
1518 case A_MP_ETASKLOOP:
1519 queue_ast(A_LOPG(ast));
1520 break;
1521 case A_MP_ATOMIC:
1522 case A_MP_ENDATOMIC:
1523 case A_MP_BARRIER:
1524 case A_MP_ENDPDO:
1525 case A_MP_BCOPYIN:
1526 case A_MP_ECOPYIN:
1527 case A_MP_BCOPYPRIVATE:
1528 case A_MP_ECOPYPRIVATE:
1529 case A_MP_BPDO:
1530 case A_MP_ETASKDUP:
1531 case A_MP_ETASKLOOPREG:
1532 case A_MP_TASKWAIT:
1533 case A_MP_TASKYIELD:
1534 case A_MP_EMPSCOPE:
1535 case A_MP_BORDERED:
1536 case A_MP_EORDERED:
1537 case A_MP_FLUSH:
1538 case A_MP_ENDTEAMS:
1539 case A_MP_DISTRIBUTE:
1540 case A_MP_ENDDISTRIBUTE:
1541 break;
1542 default:
1543 if (A_DTYPEG(ast))
1544 queue_dtype(A_DTYPEG(ast));
1545 break;
1546 }
1547 } /* rqueue_ast */
1548
1549 static void
queue_ast(int ast)1550 queue_ast(int ast)
1551 {
1552 if (ast)
1553 ast_traverse(ast, NULL, rqueue_ast, NULL);
1554 } /* queue_ast */
1555
1556 static void
qqueue_ast(int ast,int unused)1557 qqueue_ast(int ast, int unused)
1558 {
1559 if (ast)
1560 ast_traverse(ast, NULL, rqueue_ast, NULL);
1561 } /* qqueue_ast */
1562
1563 static void
queue_dtype(int dtype)1564 queue_dtype(int dtype)
1565 {
1566 int ndim, i, sptr, zbase, numelm;
1567 int paramct;
1568
1569 if (dtype < DT_MAX)
1570 return;
1571
1572 if (dtype < dtype_flag_size) {
1573 if (dtype_flag[dtype])
1574 return;
1575 dtype_flag[dtype] = 1;
1576 }
1577
1578 switch (DTY(dtype)) {
1579 case TY_PTR:
1580 queue_dtype(DTY(dtype + 1));
1581 break;
1582 case TY_ARRAY:
1583 queue_dtype(DTY(dtype + 1));
1584 if (DTY(dtype + 2) > 0) {
1585 ndim = ADD_NUMDIM(dtype);
1586 for (i = 0; i < ndim; ++i) {
1587 int lb, ub, mpy;
1588 queue_ast(ADD_LWBD(dtype, i));
1589 queue_ast(ADD_UPBD(dtype, i));
1590 queue_ast(ADD_LWAST(dtype, i));
1591 queue_ast(ADD_UPAST(dtype, i));
1592 queue_ast(ADD_EXTNTAST(dtype, i));
1593 queue_ast(ADD_MLPYR(dtype, i));
1594 }
1595 queue_ast(ADD_ZBASE(dtype));
1596 queue_ast(ADD_NUMELM(dtype));
1597 }
1598 break;
1599 case TY_STRUCT:
1600 case TY_UNION:
1601 case TY_DERIVED:
1602 /* mark all members */
1603 for (sptr = DTY(dtype + 1); sptr > NOSYM; sptr = SYMLKG(sptr)) {
1604 #ifdef PARENTG
1605 int parent = PARENTG(sptr);
1606 if (parent == sptr && sptr >= symbol_flag_size) {
1607 /* this can occur when user declares a type extension that is
1608 * local to a particular module procedure and we're now
1609 * exporting all dtypes at an "end module" statement. The
1610 * parent symbol is local to the module procedure but not
1611 * the other parts of the module. In this case, we do not queue
1612 * the dtype. FS#20816
1613 */
1614 return;
1615 }
1616 #endif
1617 queue_symbol(sptr);
1618 }
1619 /* mark tag (structure name) */
1620 if (DTY(dtype + 3))
1621 queue_symbol(DTY(dtype + 3));
1622 break;
1623 case TY_CHAR:
1624 case TY_NCHAR:
1625 queue_ast(DTY(dtype + 1));
1626 break;
1627 case TY_PROC:
1628 queue_dtype(DTY(dtype + 1));
1629 if (DTY(dtype + 2)) /* interface */
1630 queue_symbol(DTY(dtype + 2));
1631 paramct = DTY(dtype + 3);
1632 if (paramct) {
1633 int *dscptr;
1634 for (dscptr = aux.dpdsc_base + DTY(dtype + 4); paramct > 0; paramct--) {
1635 queue_symbol(*dscptr);
1636 dscptr++;
1637 }
1638 }
1639 if (DTY(dtype + 5)) /* FVAL */
1640 queue_symbol(DTY(dtype + 5));
1641
1642 break;
1643 }
1644 } /* queue_dtype */
1645
1646 static void
add_to_private_mod_list(int sptr)1647 add_to_private_mod_list(int sptr)
1648 {
1649 ITEMX *p;
1650 for (p = private_module_list; p; p = p->next) {
1651 if (sptr == p->val) {
1652 return;
1653 }
1654 }
1655 p = (ITEMX *)getitem(MOD_AREA, sizeof(ITEMX));
1656 p->val = sptr;
1657 p->next = private_module_list;
1658 private_module_list = p;
1659 }
1660
1661 /* this symbol is referenced either directly or indirectly
1662 * for the current function. Arrange to have it written to
1663 * output file:
1664 */
1665 static void
queue_symbol(int sptr)1666 queue_symbol(int sptr)
1667 {
1668 int i, member;
1669 int stype, dtype;
1670 int dscptr;
1671 static LOGICAL recur_flag = FALSE;
1672 ITEMX *p;
1673
1674 #if DEBUG
1675 assert(sptr > 0, "queue_symbol, bad sptr", sptr, 2);
1676 if (sptr >= symbol_flag_size) {
1677 interr("queue_symbol, symbol_flag subscript too large", sptr, 4);
1678 }
1679 #endif
1680 stype = STYPEG(sptr);
1681 if (stype == ST_UNKNOWN && !for_module && sptr == gbl.sym_nproc) {
1682 return;
1683 }
1684 if (symbol_flag[sptr])
1685 return;
1686 symbol_flag[sptr] = 1;
1687
1688 /* don't need to process predefined symbols: */
1689 if (sptr < stb.firstosym)
1690 return;
1691
1692 if (for_module || for_inliner || for_contained ||
1693 (exportmode && XBIT(66, 0x20000000))) {
1694 int scope, scope2;
1695 scope = SCOPEG(sptr);
1696 for (scope2 = scope; scope2; scope2 = SCOPEG(scope2)) {
1697 if (STYPEG(scope2) == ST_MODULE) {
1698 scope = scope2;
1699 }
1700 if ((STYPEG(scope2) == ST_ENTRY && scope2 != sptr) ||
1701 (STYPEG(scope2) == ST_ALIAS && STYPEG(SYMLKG(scope2)) == ST_ENTRY &&
1702 SYMLKG(scope2) != sptr)) {
1703 scope = scope2;
1704 break;
1705 }
1706 if ((STYPEG(scope2) == ST_PROC && scope2 != sptr) ||
1707 (STYPEG(scope2) == ST_ALIAS && STYPEG(SYMLKG(scope2)) == ST_PROC &&
1708 SYMLKG(scope2) != sptr)) {
1709 scope = scope2;
1710 break;
1711 }
1712 if (SCOPEG(scope2) == scope2)
1713 break;
1714 }
1715 if (for_inliner && (sptr == gbl.currsub || SCOPEG(sptr) == stb.curr_scope ||
1716 SCG(sptr) == SC_DUMMY)) {
1717 /* export symbols from this subprogram as normal */
1718 } else if (sptr == gbl.currsub) {
1719 } else if (scope >= stb.firstosym && scope != sym_module &&
1720 STYPEG(scope) == ST_MODULE && stype != ST_MODULE) {
1721 /* putting out a "R " record. */
1722 queue_symbol(scope);
1723 switch (stype) {
1724 case ST_USERGENERIC:
1725 case ST_OPERATOR:
1726 for (dscptr = GNDSCG(sptr); dscptr; dscptr = SYMI_NEXT(dscptr)) {
1727 int ds = SYMI_SPTR(dscptr);
1728 if (SCOPEG(ds) == stb.curr_scope) {
1729 queue_symbol(SYMI_SPTR(dscptr));
1730 }
1731 }
1732 break;
1733 #ifdef ENCLDTYPEG
1734 case ST_MEMBER:
1735 /* enqueue the derived type tag */
1736 dtype = ENCLDTYPEG(sptr);
1737 if (DTY(dtype + 3))
1738 queue_symbol(DTY(dtype + 3));
1739 break;
1740 #endif
1741 }
1742 return;
1743 }
1744 }
1745 dtype = DTYPEG(sptr);
1746 if (dtype)
1747 queue_dtype(dtype);
1748
1749 /* Process newly added symbol */
1750 switch (stype) {
1751 case ST_MODULE:
1752 if (sptr != sym_module && !exportmode) {
1753 add_to_private_mod_list(sptr);
1754 }
1755 break;
1756 case ST_UNKNOWN:
1757 case ST_LABEL:
1758 case ST_STFUNC:
1759 break;
1760 case ST_ARRDSC:
1761 if (SECDSCG(sptr))
1762 queue_symbol(SECDSCG(sptr));
1763 if (ARRAYG(sptr))
1764 queue_symbol(ARRAYG(sptr));
1765 break;
1766 case ST_TYPEDEF:
1767 case ST_STAG:
1768 if (BASETYPEG(sptr)) {
1769 queue_dtype(BASETYPEG(sptr));
1770 }
1771 if (PARENTG(sptr)) {
1772 queue_symbol(PARENTG(sptr));
1773 }
1774 if (SDSCG(sptr) && CLASSG(SDSCG(sptr))) {
1775 queue_symbol(SDSCG(sptr));
1776 }
1777 if (TYPDEF_INITG(sptr) > NOSYM) {
1778 queue_symbol(TYPDEF_INITG(sptr));
1779 }
1780 break;
1781 case ST_IDENT:
1782 if (DESCRG(sptr))
1783 queue_symbol(DESCRG(sptr));
1784 if (ADJARRG(sptr) && SYMLKG(sptr) != NOSYM)
1785 queue_symbol(SYMLKG(sptr));
1786 if (ADJLENG(sptr) && ADJSTRLKG(sptr) && ADJSTRLKG(sptr) != NOSYM)
1787 queue_symbol(ADJSTRLKG(sptr));
1788
1789 if (SDSCG(sptr))
1790 queue_symbol(SDSCG(sptr));
1791 #ifdef DEVCOPYG
1792 if (DEVCOPYG(sptr))
1793 queue_symbol(DEVCOPYG(sptr));
1794 #endif
1795 break;
1796
1797 case ST_CONST:
1798 if (sptr < symbol_flag_lowest_const)
1799 symbol_flag_lowest_const = sptr;
1800 if (DTY(DTYPEG(sptr)) == TY_PTR) /* address constant */
1801 if (CONVAL1G(sptr)) {
1802 queue_symbol((int)CONVAL1G(sptr));
1803 }
1804 switch (DTY(DTYPEG(sptr))) {
1805 case TY_DCMPLX:
1806 case TY_QCMPLX:
1807 queue_symbol((int)CONVAL1G(sptr));
1808 queue_symbol((int)CONVAL2G(sptr));
1809 break;
1810 case TY_HOLL:
1811 queue_symbol((int)CONVAL1G(sptr));
1812 break;
1813 case TY_NCHAR:
1814 queue_symbol((int)CONVAL1G(sptr));
1815 break;
1816 default:
1817 break;
1818 }
1819 break;
1820
1821 case ST_ENTRY:
1822 case ST_PROC:
1823 if (STYPEG(sptr) == ST_PROC && IS_PROC_DUMMYG(sptr) && SDSCG(sptr)){
1824 queue_symbol(SDSCG(sptr));
1825 }
1826 if (FVALG(sptr)) {
1827 queue_symbol(FVALG(sptr));
1828 }
1829 if (ALTNAMEG(sptr)) {
1830 queue_symbol(ALTNAMEG(sptr));
1831 }
1832 if (GSAMEG(sptr))
1833 queue_symbol((int)GSAMEG(sptr));
1834 dscptr = DPDSCG(sptr);
1835 for (i = PARAMCTG(sptr); i > 0; i--) {
1836 int arg;
1837 arg = aux.dpdsc_base[dscptr];
1838 if (arg) {
1839 queue_symbol(arg);
1840 }
1841 dscptr++;
1842 }
1843 if (CLASSG(sptr) && TBPLNKG(sptr)) {
1844 queue_dtype(TBPLNKG(sptr));
1845 }
1846 break;
1847
1848 case ST_PARAM:
1849 if (DTY(DTYPEG(sptr)) == TY_ARRAY) {
1850 if (CONVAL1G(sptr)) {
1851 queue_symbol(CONVAL1G(sptr));
1852 }
1853 } else if (DTY(DTYPEG(sptr)) == TY_DERIVED) {
1854 if (CONVAL1G(sptr))
1855 queue_symbol(CONVAL1G(sptr));
1856 if (PARAMVALG(sptr))
1857 queue_ast(PARAMVALG(sptr));
1858 } else {
1859 if (!TY_ISWORD(DTY(DTYPEG(sptr)))) {
1860 queue_symbol(CONVAL1G(sptr));
1861 }
1862 queue_ast(CONVAL2G(sptr));
1863 }
1864 break;
1865
1866 case ST_MEMBER:
1867 queue_symbol(SYMLKG(sptr));
1868 if (PSMEMG(sptr))
1869 queue_symbol(PSMEMG(sptr));
1870 if (VARIANTG(sptr))
1871 queue_symbol(VARIANTG(sptr));
1872 if (MIDNUMG(sptr))
1873 queue_symbol(MIDNUMG(sptr));
1874 if (SDSCG(sptr))
1875 queue_symbol(SDSCG(sptr));
1876 if (PTROFFG(sptr))
1877 queue_symbol(PTROFFG(sptr));
1878 if (DESCRG(sptr))
1879 queue_symbol(DESCRG(sptr));
1880 if (ENCLDTYPEG(sptr))
1881 queue_dtype(ENCLDTYPEG(sptr));
1882 if (PARENTG(sptr))
1883 queue_symbol(PARENTG(sptr));
1884 if (VTABLEG(sptr))
1885 queue_symbol(VTABLEG(sptr));
1886 if (PASSG(sptr))
1887 queue_symbol(PASSG(sptr));
1888 if (IFACEG(sptr))
1889 queue_symbol(IFACEG(sptr));
1890 if (BINDG(sptr))
1891 queue_symbol(BINDG(sptr));
1892 if (LENG(sptr) && LENPARMG(sptr))
1893 queue_ast(LENG(sptr));
1894 if (INITKINDG(sptr) && PARMINITG(sptr))
1895 queue_ast(PARMINITG(sptr));
1896 if (KINDASTG(sptr))
1897 queue_ast(KINDASTG(sptr));
1898 break;
1899
1900 /* ELSE, FALL THROUGH: */
1901
1902 case ST_ARRAY:
1903 case ST_DESCRIPTOR:
1904 case ST_VAR:
1905 case ST_STRUCT:
1906 case ST_UNION:
1907 if (!recur_flag) {
1908 if (CFUNCG(sptr)) {
1909 /* externally visible C_BIND var, struct */
1910 queue_symbol(sptr);
1911
1912 if (ALTNAMEG(sptr)) {
1913 queue_symbol(ALTNAMEG(sptr));
1914 }
1915 } else if (SCG(sptr) == SC_CMBLK) {
1916 #if DEBUG
1917 assert(STYPEG(CMBLKG(sptr)) == ST_CMBLK, "q_s:CMBLK?", sptr, 2);
1918 #endif
1919 queue_symbol((int)CMBLKG(sptr));
1920 }
1921 }
1922
1923 if (MIDNUMG(sptr))
1924 queue_symbol(MIDNUMG(sptr));
1925 if (SDSCG(sptr))
1926 queue_symbol(SDSCG(sptr));
1927 if (PTROFFG(sptr))
1928 queue_symbol(PTROFFG(sptr));
1929 if (DESCRG(sptr))
1930 queue_symbol(DESCRG(sptr));
1931 if (PARAMVALG(sptr))
1932 queue_ast(PARAMVALG(sptr));
1933 if (CVLENG(sptr))
1934 queue_symbol(CVLENG(sptr));
1935 if (ADJARRG(sptr) && SYMLKG(sptr) != NOSYM)
1936 queue_symbol(SYMLKG(sptr));
1937 if (ADJLENG(sptr) && ADJSTRLKG(sptr) && ADJSTRLKG(sptr) != NOSYM)
1938 queue_symbol(ADJSTRLKG(sptr));
1939 if (STYPEG(sptr) == ST_DESCRIPTOR && PARENTG(sptr) && CLASSG(sptr)) {
1940 queue_dtype(PARENTG(sptr));
1941 }
1942 #ifdef DEVCOPYG
1943 if (DEVCOPYG(sptr))
1944 queue_symbol(DEVCOPYG(sptr));
1945 #endif
1946 #ifdef DSCASTG
1947 if (STYPEG(sptr) != ST_DESCRIPTOR && DSCASTG(sptr))
1948 queue_ast(DSCASTG(sptr));
1949 #endif
1950 break;
1951
1952 case ST_CMBLK:
1953 /* process all elements of the common block: */
1954 recur_flag = TRUE;
1955 for (member = CMEMFG(sptr); member > NOSYM; member = SYMLKG(member)) {
1956 queue_symbol(member);
1957 }
1958 recur_flag = FALSE;
1959 if (ALTNAMEG(sptr)) {
1960 queue_symbol(ALTNAMEG(sptr));
1961 }
1962 break;
1963
1964 case ST_NML:
1965 Trace(("exporting namelist %d/%s", sptr, SYMNAME(sptr)));
1966 queue_symbol(ADDRESSG(sptr));
1967 /* process all elements of the namelist */
1968 recur_flag = TRUE;
1969 for (member = CMEMFG(sptr); member; member = NML_NEXT(member)) {
1970 queue_symbol(NML_SPTR(member));
1971 }
1972 recur_flag = FALSE;
1973 break;
1974 case ST_PLIST:
1975 Trace(("exporting Plist %d/%s", sptr, SYMNAME(sptr)));
1976 break;
1977
1978 case ST_ALIAS:
1979 queue_symbol((int)SYMLKG(sptr));
1980 if (GSAMEG(sptr))
1981 queue_symbol((int)GSAMEG(sptr));
1982 break;
1983
1984 case ST_USERGENERIC:
1985 if (GTYPEG(sptr)) {
1986 /* FS#17726 - export overloaded type */
1987 queue_symbol((int)GTYPEG(sptr));
1988 }
1989 case ST_OPERATOR:
1990 if (GSAMEG(sptr))
1991 queue_symbol((int)GSAMEG(sptr));
1992 for (dscptr = GNDSCG(sptr); dscptr; dscptr = SYMI_NEXT(dscptr)) {
1993 queue_symbol(SYMI_SPTR(dscptr));
1994 }
1995 if (CLASSG(sptr) && TBPLNKG(sptr)) {
1996 queue_dtype(TBPLNKG(sptr));
1997 }
1998 break;
1999
2000 case ST_MODPROC:
2001 /*
2002 * Need to queue the module procedure's ST_ENTRY or ST_ALIAS if
2003 * a module is appending to generic defined in another module.
2004 */
2005 if (SYMLKG(sptr)) {
2006 queue_symbol(SYMLKG(sptr));
2007 }
2008 if (GSAMEG(sptr))
2009 queue_symbol((int)GSAMEG(sptr));
2010 /* module procedure descriptor */
2011 for (dscptr = SYMIG(sptr); dscptr; dscptr = SYMI_NEXT(dscptr))
2012 queue_symbol(SYMI_SPTR(dscptr));
2013 break;
2014
2015 case ST_BLOCK:
2016 if (STARTLABG(sptr))
2017 queue_symbol(STARTLABG(sptr));
2018 if (ENDLABG(sptr))
2019 queue_symbol(ENDLABG(sptr));
2020 break;
2021
2022 default:
2023 Trace(("Illegal symbol %d/%s in queue_symbol, type=%d", sptr, SYMNAME(sptr),
2024 STYPEG(sptr)));
2025 interr("queue_symbol: unexpected symbol type", sptr, 3);
2026 }
2027 if (ENCLFUNCG(sptr)) {
2028 queue_symbol(ENCLFUNCG(sptr));
2029 }
2030 if ((int)(SCOPEG(sptr)) >= stb.firstosym) {
2031 queue_symbol(SCOPEG(sptr));
2032 }
2033
2034 /* queue up variables in the storage overlap list, if necessary */
2035 switch (STYPEG(sptr)) {
2036 case ST_IDENT:
2037 case ST_VAR:
2038 case ST_ARRAY:
2039 case ST_STRUCT:
2040 case ST_UNION:
2041 if (SOCPTRG(sptr)) {
2042 int p;
2043 for (p = SOCPTRG(sptr); p; p = SOC_NEXT(p)) {
2044 queue_symbol(SOC_SPTR(p));
2045 }
2046 }
2047 break;
2048 default:
2049 break;
2050 }
2051 } /* queue_symbol */
2052
2053 /* ----------------------------------------------------------- */
2054
2055 static int
dtype_skip(int dtype)2056 dtype_skip(int dtype)
2057 {
2058 return dlen(DTY(dtype));
2059 } /* dtype_skip */
2060
2061 /*
2062 * write out necessary info for this data type:
2063 */
2064 static void
export_dt(int dtype)2065 export_dt(int dtype)
2066 {
2067 int paramct;
2068
2069 lzprintf(outlz, "D %d %d", dtype, (int)DTY(dtype));
2070
2071 switch (DTY(dtype)) {
2072 case TY_PTR:
2073 lzprintf(outlz, " %d", (int)DTY(dtype + 1));
2074 break;
2075
2076 case TY_ARRAY:
2077 /* print dtype and array descriptor entry */
2078 lzprintf(outlz, " %d", (int)DTY(dtype + 1));
2079 if (DTY(dtype + 2)) {
2080 ADSC *ad;
2081 int i, ndims;
2082
2083 if (DTY(dtype + 2) <= 0) {
2084 lzprintf(outlz, " 0");
2085 } else {
2086 ad = AD_DPTR(dtype);
2087 ndims = AD_NUMDIM(ad);
2088 lzprintf(outlz, " %d", ndims);
2089 lzprintf(outlz, " %d", AD_ZBASE(ad));
2090 lzprintf(outlz, " %d", AD_NUMELM(ad));
2091 lzprintf(outlz, " %d", AD_ASSUMSHP(ad));
2092 lzprintf(outlz, " %d", AD_DEFER(ad));
2093 lzprintf(outlz, " %d", AD_ADJARR(ad));
2094 lzprintf(outlz, " %d", AD_ASSUMSZ(ad));
2095 lzprintf(outlz, " %d", AD_NOBOUNDS(ad));
2096
2097 /* separate line per dimension */
2098 for (i = 0; i < ndims; i++) {
2099 lzprintf(outlz, "\n %d", AD_LWBD(ad, i));
2100 lzprintf(outlz, " %d", AD_UPBD(ad, i));
2101 lzprintf(outlz, " %d", AD_MLPYR(ad, i));
2102 lzprintf(outlz, " %d", AD_LWAST(ad, i));
2103 lzprintf(outlz, " %d", AD_UPAST(ad, i));
2104 lzprintf(outlz, " %d", AD_EXTNTAST(ad, i));
2105 }
2106 }
2107 } else /* 'null' descriptor */
2108 lzprintf(outlz, " %d", 0);
2109 break;
2110 case TY_UNION:
2111 case TY_STRUCT:
2112 case TY_DERIVED:
2113 /* print dtype and descriptor entry */
2114 lzprintf(outlz, " %d %d %d %d", (int)DTY(dtype + 1), (int)DTY(dtype + 2),
2115 (int)DTY(dtype + 3), (int)DTY(dtype + 4));
2116 break;
2117
2118 case TY_CHAR:
2119 case TY_NCHAR:
2120 lzprintf(outlz, " %d", (int)DTY(dtype + 1));
2121 break;
2122
2123 case TY_PROC:
2124 lzprintf(outlz, " %d", DTY(dtype + 1));
2125 lzprintf(outlz, " %d", DTY(dtype + 2)); /* interface */
2126 paramct = DTY(dtype + 3); /* PARAMCT */
2127 lzprintf(outlz, " %d", paramct);
2128 if (paramct) {
2129 int *dscptr;
2130 for (dscptr = aux.dpdsc_base + DTY(dtype + 4); paramct > 0; paramct--) {
2131 lzprintf(outlz, " %d", *dscptr);
2132 dscptr++;
2133 }
2134 }
2135 lzprintf(outlz, " %d", DTY(dtype + 5)); /* FVAL */
2136 break;
2137
2138 default:
2139 interr("export_dt: illegal dtype", dtype, 3);
2140 }
2141
2142 lzprintf(outlz, "\n");
2143 }
2144
2145 /* write out necessary info for all data types created in the module
2146 * specification
2147 */
2148 static void
export_dtypes(int start,int ignore)2149 export_dtypes(int start, int ignore)
2150 {
2151 int dtype, skip;
2152 if (start < DT_MAX + 1)
2153 start = DT_MAX + 1;
2154
2155 for (dtype = DT_MAX + 1; dtype < stb.dt.stg_avail;) {
2156 if ((dtype >= dtype_flag_size || dtype_flag[dtype]) &&
2157 (dtype >= start || DTY(dtype) == TY_CHAR)) {
2158 if (ignore) {
2159 int mem;
2160 switch (DTY(dtype)) {
2161 case TY_DERIVED:
2162 case TY_UNION:
2163 case TY_STRUCT:
2164 if (DTY(dtype + 3) && !CFUNCG(DTY(dtype + 3))) {
2165 IGNOREP(DTY(dtype + 3), 1);
2166 HIDDENP(DTY(dtype + 3), 1);
2167 }
2168 for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
2169 if (!CFUNCG(mem)) {
2170 IGNOREP(mem, 1);
2171 HIDDENP(mem, 1);
2172 }
2173 }
2174 break;
2175 }
2176 }
2177 export_dt(dtype);
2178 }
2179 dtype += dtype_skip(dtype);
2180 }
2181 }
2182
2183 /* write out necessary info for this data type: */
2184 static void
export_derived_dt(int dtype)2185 export_derived_dt(int dtype)
2186 {
2187 int sptr, scope;
2188 switch (DTY(dtype)) {
2189 case TY_UNION:
2190 case TY_STRUCT:
2191 case TY_DERIVED:
2192 sptr = DTY(dtype + 3);
2193 if (sptr == 0)
2194 return;
2195 scope = SCOPEG(sptr);
2196 if (scope == 0)
2197 return;
2198 if (STYPEG(scope) == ST_MODULE) {
2199 /* print dtype and descriptor entry */
2200 int base = CMEMFG(scope);
2201 lzprintf(outlz, "d %d %d %d %s %s\n", dtype, STYPEG(sptr), sptr - base,
2202 SYMNAME(scope), SYMNAME(sptr));
2203 } else {
2204 lzprintf(outlz, "e %d %d %d %s %s\n", dtype, STYPEG(sptr), STYPEG(scope),
2205 SYMNAME(scope), SYMNAME(sptr));
2206 }
2207 break;
2208 }
2209 }
2210
2211 static void
export_outer_derived_dtypes(int limit)2212 export_outer_derived_dtypes(int limit)
2213 {
2214 int dtype, skip;
2215
2216 for (dtype = 0; dtype < limit;) {
2217 if (dtype >= dtype_flag_size || dtype_flag[dtype]) {
2218 export_derived_dt(dtype);
2219 }
2220 dtype += dtype_skip(dtype);
2221 }
2222 } /* export_outer_derived_dtypes */
2223
2224 /* ----------------------------------------------------------- */
2225
2226 /*
2227 * write out necessary info for this symbol:
2228 */
2229 static void
export_symbol(int sptr)2230 export_symbol(int sptr)
2231 {
2232 int i;
2233 int dtype;
2234 char *strptr;
2235 int stringlen;
2236 SYM *wp;
2237 int dscptr;
2238 int nml, scope, stype, flags, bit;
2239
2240 scope = SCOPEG(sptr);
2241 stype = STYPEG(sptr);
2242 if (!exportmode && stype == ST_UNKNOWN && sptr == gbl.sym_nproc) {
2243 return;
2244 }
2245 if (for_module || for_inliner || for_contained ||
2246 (exportmode && XBIT(66, 0x20000000))) {
2247 int scope2, cs;
2248 for (scope2 = scope; scope2; scope2 = SCOPEG(scope2)) {
2249 if (STYPEG(scope2) == ST_MODULE) {
2250 scope = scope2;
2251 }
2252 if ((STYPEG(scope2) == ST_ENTRY && scope2 != sptr) ||
2253 (STYPEG(scope2) == ST_ALIAS && STYPEG(SYMLKG(scope2)) == ST_ENTRY &&
2254 SYMLKG(scope2) != sptr)) {
2255 scope = scope2;
2256 break;
2257 }
2258 if ((STYPEG(scope2) == ST_PROC && scope2 != sptr) ||
2259 (STYPEG(scope2) == ST_ALIAS && STYPEG(SYMLKG(scope2)) == ST_PROC &&
2260 SYMLKG(scope2) != sptr)) {
2261 scope = scope2;
2262 break;
2263 }
2264 if (SCOPEG(scope2) == scope2)
2265 break;
2266 }
2267 cs = SCOPEG(gbl.currsub);
2268 if (for_inliner &&
2269 (sptr == gbl.currsub || SCOPEG(sptr) == cs || SCG(sptr) == SC_DUMMY)) {
2270 /* export symbols from this subprogram as normal */
2271 } else if (sptr == gbl.currsub) {
2272 } else if ((scope >= stb.firstosym && scope != sym_module &&
2273 STYPEG(scope) == ST_MODULE && !ISSUBMODULEG(sptr))) {
2274 /* this symbol is from a USEd module */
2275 if (stype != ST_MODULE && stype != ST_UNKNOWN) {
2276 int dscptr, dsccnt;
2277 int base = CMEMFG(scope);
2278 int offset = sptr - base + 1;
2279 if (base == 0) {
2280 offset = 0;
2281 }
2282 lzprintf(outlz, "R %d %d %d %s %s", sptr, stype, offset, SYMNAME(scope),
2283 SYMNAME(sptr));
2284 /* may have additional overloaded names */
2285 switch (stype) {
2286 case ST_MEMBER:
2287 #ifdef ENCLDTYPEG
2288 dtype = ENCLDTYPEG(sptr);
2289 if (DTY(dtype + 3)) {
2290 lzprintf(outlz, " %s", SYMNAME(DTY(dtype + 3)));
2291 } else {
2292 lzprintf(outlz, " .");
2293 }
2294 #endif
2295 lzprintf(outlz, "\n");
2296 break;
2297 case ST_USERGENERIC:
2298 case ST_OPERATOR:
2299 lzprintf(outlz, "\n");
2300 dsccnt = 0;
2301 for (dscptr = GNDSCG(sptr); dscptr; dscptr = SYMI_NEXT(dscptr)) {
2302 int ds = SYMI_SPTR(dscptr);
2303 if (SCOPEG(ds) == stb.curr_scope) {
2304 ++dsccnt;
2305 }
2306 }
2307 if (dsccnt) {
2308 lzprintf(outlz, "O %d %d", sptr, dsccnt);
2309 for (dscptr = GNDSCG(sptr); dscptr; dscptr = SYMI_NEXT(dscptr)) {
2310 int ds = SYMI_SPTR(dscptr);
2311 if (SCOPEG(ds) == stb.curr_scope) {
2312 lzprintf(outlz, " %d", ds);
2313 }
2314 }
2315 lzprintf(outlz, "\n");
2316 }
2317 break;
2318 default:
2319 lzprintf(outlz, "\n");
2320 break;
2321 }
2322 }
2323 return;
2324 }
2325 if (for_inliner && sptr < stb.firstusym && sptr >= stb.firstosym) {
2326 lzprintf(outlz, "C %d %d %s\n", sptr, STYPEG(sptr), SYMNAME(sptr));
2327 return;
2328 }
2329 if (stype == ST_MODULE && sptr != sym_module && !for_inliner &&
2330 /* No return when this module has a separate module procedure that
2331 * implements a type bound procedure. We need to export modules
2332 * sptr next.
2333 */
2334 !HAS_TBP_BOUND_TO_SMPG(sptr) && ANCESTORG(sym_module) != sptr) {
2335 return;
2336 }
2337 }
2338
2339
2340 if ((STYPEG(sptr) == ST_ALIAS || STYPEG(sptr) == ST_PROC ||
2341 STYPEG(sptr) == ST_ENTRY) && ISSUBMODULEG(sptr))
2342 INMODULEP(sptr, TRUE);
2343
2344 /* BYTE-ORDER INDEPENDENT */
2345 wp = stb.stg_base + sptr;
2346 lzprintf(outlz, "S %d", sptr);
2347 if (exportmode)
2348 lzprintf(outlz, " %d", HASHLKG(sptr));
2349 lzprintf(outlz, " %d %d %d %d %d %d %d %d", stb.stg_base[sptr].stype,
2350 stb.stg_base[sptr].sc, stb.stg_base[sptr].b3, stb.stg_base[sptr].b4,
2351 stb.stg_base[sptr].dtype, stb.stg_base[sptr].symlk,
2352 stb.stg_base[sptr].scope, stb.stg_base[sptr].nmptr);
2353
2354 #undef PUTFIELD
2355 #undef PUTISZ_FIELD
2356 #define PUTFIELD(f) lzprintf(outlz, " %d", stb.stg_base[sptr].f)
2357 #define PUTISZ_FIELD(f) lzprintf(outlz, " %" ISZ_PF "d", stb.stg_base[sptr].f)
2358 #define ADDBIT(f) \
2359 if (stb.stg_base[sptr].f) \
2360 flags |= bit; \
2361 bit <<= 1;
2362
2363 flags = 0;
2364 bit = 1;
2365 ADDBIT(f1);
2366 ADDBIT(f2);
2367 ADDBIT(f3);
2368 ADDBIT(f4);
2369 ADDBIT(f5);
2370 ADDBIT(f6);
2371 ADDBIT(f7);
2372 ADDBIT(f8);
2373 ADDBIT(f9);
2374 ADDBIT(f10);
2375 ADDBIT(f11);
2376 ADDBIT(f12);
2377 ADDBIT(f13);
2378 ADDBIT(f14);
2379 ADDBIT(f15);
2380 ADDBIT(f16);
2381 ADDBIT(f17);
2382 ADDBIT(f18);
2383 ADDBIT(f19);
2384 ADDBIT(f20);
2385 ADDBIT(f21);
2386 ADDBIT(f22);
2387 ADDBIT(f23);
2388 ADDBIT(f24);
2389 ADDBIT(f25);
2390 ADDBIT(f26);
2391 ADDBIT(f27);
2392 ADDBIT(f28);
2393 ADDBIT(f29);
2394 ADDBIT(f30);
2395 ADDBIT(f31);
2396 ADDBIT(f32);
2397 lzprintf(outlz, " %x", flags);
2398 flags = 0;
2399 bit = 1;
2400 ADDBIT(f33);
2401 ADDBIT(f34);
2402 ADDBIT(f35);
2403 ADDBIT(f36);
2404 ADDBIT(f37);
2405 ADDBIT(f38);
2406 ADDBIT(f39);
2407 ADDBIT(f40);
2408 ADDBIT(f41);
2409 ADDBIT(f42);
2410 ADDBIT(f43);
2411 ADDBIT(f44);
2412 ADDBIT(f45);
2413 ADDBIT(f46);
2414 ADDBIT(f47);
2415 ADDBIT(f48);
2416 ADDBIT(f49);
2417 ADDBIT(f50);
2418 ADDBIT(f51);
2419 ADDBIT(f52);
2420 ADDBIT(f53);
2421 ADDBIT(f54);
2422 ADDBIT(f55);
2423 ADDBIT(f56);
2424 ADDBIT(f57);
2425 ADDBIT(f58);
2426 ADDBIT(f59);
2427 ADDBIT(f60);
2428 ADDBIT(f61);
2429 ADDBIT(f62);
2430 ADDBIT(f63);
2431 ADDBIT(f64);
2432 lzprintf(outlz, " %x", flags);
2433
2434 /*
2435 * New flags & fields were added for IVSN 26. Prefix the new set of
2436 * flags & fields with ' A'. interf will check for this prefix, and if
2437 * not present, the .mod file must be the previous version and interf
2438 * will not attempt to read these fields.
2439 *
2440 * START ---------- IVSN 26 flags & fields
2441 */
2442 lzprintf(outlz, " A");
2443 flags = 0;
2444 bit = 1;
2445 ADDBIT(f65);
2446 ADDBIT(f66);
2447 ADDBIT(f67);
2448 ADDBIT(f68);
2449 ADDBIT(f69);
2450 ADDBIT(f70);
2451 ADDBIT(f71);
2452 ADDBIT(f72);
2453 ADDBIT(f73);
2454 ADDBIT(f74);
2455 ADDBIT(f75);
2456 ADDBIT(f76);
2457 ADDBIT(f77);
2458 ADDBIT(f78);
2459 ADDBIT(f79);
2460 ADDBIT(f80);
2461 ADDBIT(f81);
2462 ADDBIT(f82);
2463 ADDBIT(f83);
2464 ADDBIT(f84);
2465 ADDBIT(f85);
2466 ADDBIT(f86);
2467 ADDBIT(f87);
2468 ADDBIT(f88);
2469 ADDBIT(f89);
2470 ADDBIT(f90);
2471 ADDBIT(f91);
2472 ADDBIT(f92);
2473 ADDBIT(f93);
2474 ADDBIT(f94);
2475 ADDBIT(f95);
2476 ADDBIT(f96);
2477 lzprintf(outlz, " %x", flags);
2478 PUTFIELD(w34);
2479 PUTFIELD(w35);
2480 PUTFIELD(w36);
2481 /*
2482 * END ---------- IVSN 26 flags & fields
2483 */
2484
2485 /*
2486 * New flags & fields were added for IVSN 28. Prefix the new set of
2487 * flags & fields with ' B'. interf will check for this prefix, and if
2488 * not present, the .mod file must be the previous version and interf
2489 * will not attempt to read these fields.
2490 *
2491 * START ---------- IVSN 28 flags & fields
2492 */
2493 lzprintf(outlz, " B");
2494 flags = 0;
2495 bit = 1;
2496 ADDBIT(f97);
2497 ADDBIT(f98);
2498 ADDBIT(f99);
2499 ADDBIT(f100);
2500 ADDBIT(f101);
2501 ADDBIT(f102);
2502 ADDBIT(f103);
2503 ADDBIT(f104);
2504 ADDBIT(f105);
2505 ADDBIT(f106);
2506 ADDBIT(f107);
2507 ADDBIT(f108);
2508 ADDBIT(f109);
2509 ADDBIT(f110);
2510 ADDBIT(f111);
2511 ADDBIT(f112);
2512 ADDBIT(f113);
2513 ADDBIT(f114);
2514 ADDBIT(f115);
2515 ADDBIT(f116);
2516 ADDBIT(f117);
2517 ADDBIT(f118);
2518 ADDBIT(f119);
2519 ADDBIT(f120);
2520 ADDBIT(f121);
2521 ADDBIT(f122);
2522 ADDBIT(f123);
2523 ADDBIT(f124);
2524 ADDBIT(f125);
2525 ADDBIT(f126);
2526 ADDBIT(f127);
2527 ADDBIT(f128);
2528 lzprintf(outlz, " %x", flags);
2529 PUTFIELD(lineno);
2530 PUTFIELD(w39);
2531 PUTFIELD(w40);
2532 /*
2533 * END ---------- IVSN 28 flags & fields
2534 */
2535
2536 PUTFIELD(w9);
2537 PUTISZ_FIELD(w10);
2538 PUTFIELD(w11);
2539 PUTFIELD(w12);
2540 PUTFIELD(w13);
2541 PUTISZ_FIELD(w14);
2542 PUTFIELD(w15);
2543 PUTFIELD(w16);
2544 PUTFIELD(w17);
2545 PUTFIELD(w18);
2546 PUTFIELD(w19);
2547 PUTFIELD(w20);
2548 PUTFIELD(w21);
2549 PUTFIELD(w22);
2550 PUTFIELD(w23);
2551 PUTFIELD(w24);
2552 PUTFIELD(w25);
2553 PUTFIELD(w26);
2554 PUTFIELD(w27);
2555 PUTFIELD(w28);
2556 PUTFIELD(uname);
2557 PUTFIELD(w30);
2558 PUTFIELD(w31);
2559 PUTFIELD(w32);
2560 #undef ADDBIT
2561 #undef PUTFIELD
2562 #undef PUTISZ_FIELD
2563
2564 switch (stype) {
2565 case ST_CONST:
2566 dtype = DTYPEG(sptr);
2567 lzprintf(outlz, " %d", (int)DTY(dtype)); /* contant's TY_ value */
2568 switch (DTY(dtype)) {
2569 case TY_BINT:
2570 case TY_SINT:
2571 case TY_INT:
2572 case TY_INT8:
2573 case TY_BLOG:
2574 case TY_SLOG:
2575 case TY_LOG:
2576 case TY_LOG8:
2577 case TY_REAL:
2578 case TY_DBLE:
2579 case TY_QUAD:
2580 case TY_CMPLX:
2581 case TY_NCHAR:
2582 case TY_DCMPLX:
2583 case TY_QCMPLX:
2584 if (NMPTRG(sptr)) {
2585 lzprintf(outlz, " %s", SYMNAME(sptr));
2586 }
2587 break;
2588
2589 case TY_CHAR:
2590 strptr = stb.n_base + CONVAL1G(sptr);
2591 stringlen = string_length(DTYPEG(sptr));
2592 lzprintf(outlz, " %d", stringlen);
2593 for (i = 0; i < stringlen; i++)
2594 lzprintf(outlz, " %x", ((int)*strptr++));
2595 break;
2596 }
2597 break;
2598
2599 case ST_UNKNOWN:
2600 case ST_IDENT:
2601 case ST_PARAM:
2602 case ST_MEMBER:
2603 case ST_UNION:
2604 case ST_STRUCT:
2605 case ST_VAR:
2606 case ST_ARRAY:
2607 case ST_DESCRIPTOR:
2608 case ST_CMBLK:
2609 case ST_ALIAS:
2610 case ST_ARRDSC:
2611 case ST_TYPEDEF:
2612 case ST_STAG:
2613 case ST_LABEL:
2614 case ST_MODULE:
2615 case ST_STFUNC:
2616 case ST_INTRIN: /* for new intrinsics with OPTYPE NEW_INTRIN */
2617 lzprintf(outlz, " %s", SYMNAME(sptr));
2618 break;
2619
2620 case ST_ENTRY:
2621 case ST_PROC:
2622 lzprintf(outlz, " %s", SYMNAME(sptr));
2623 {
2624 if ((i = PARAMCTG(sptr))) {
2625 /* output parameter descriptor */
2626 lzprintf(outlz, "\n");
2627 lzprintf(outlz, "F %d %d", sptr, i);
2628 dscptr = DPDSCG(sptr);
2629 while (TRUE) {
2630 lzprintf(outlz, " %d", aux.dpdsc_base[dscptr]);
2631 if (--i == 0)
2632 break;
2633 dscptr++;
2634 }
2635 } else {
2636 /* No args, but possibly an array or pointer return
2637 val. Create an 'F sptr 0' record. So Fix up will
2638 occur and DPDSC field gets filled in. */
2639 if (DPDSCG(sptr)) {
2640 lzprintf(outlz, "\n");
2641 lzprintf(outlz, "F %d %d", sptr, i);
2642 }
2643 }
2644 }
2645 break;
2646
2647 case ST_USERGENERIC:
2648 case ST_OPERATOR:
2649 lzprintf(outlz, " %s", SYMNAME(sptr));
2650 if ((i = GNCNTG(sptr))) {
2651 /* output generic descriptor */
2652 lzprintf(outlz, "\n");
2653 lzprintf(outlz, "O %d %d", sptr, i);
2654 for (dscptr = GNDSCG(sptr); dscptr; dscptr = SYMI_NEXT(dscptr))
2655 lzprintf(outlz, " %d", SYMI_SPTR(dscptr));
2656 }
2657 break;
2658
2659 case ST_MODPROC:
2660 lzprintf(outlz, " %s", SYMNAME(sptr));
2661 if ((dscptr = SYMIG(sptr))) {
2662 /* module procedure descriptor */
2663 lzprintf(outlz, "\n");
2664 lzprintf(outlz, "Q %d", sptr);
2665 for (; dscptr; dscptr = SYMI_NEXT(dscptr))
2666 lzprintf(outlz, " %d", SYMI_SPTR(dscptr));
2667 lzprintf(outlz, " 0");
2668 }
2669 break;
2670
2671 case ST_NML:
2672 lzprintf(outlz, " %s", SYMNAME(sptr));
2673 for (nml = CMEMFG(sptr); nml; nml = NML_NEXT(nml)) {
2674 lzprintf(outlz, "\nN %d %d", NML_SPTR(nml), NML_LINENO(nml));
2675 }
2676 lzprintf(outlz, "\nN -1 -1");
2677 break;
2678
2679 case ST_PLIST:
2680 case ST_CONSTRUCT:
2681 case ST_BLOCK:
2682 lzprintf(outlz, " %s", SYMNAME(sptr));
2683 break;
2684
2685 default:
2686 interr("export_symbol: illegal symbol type", sptr, 3);
2687 }
2688
2689 lzprintf(outlz, "\n");
2690
2691 /* output the storage overlap list, if necessary */
2692 switch (stype) {
2693 case ST_IDENT:
2694 case ST_VAR:
2695 case ST_ARRAY:
2696 case ST_STRUCT:
2697 case ST_UNION:
2698 if (SOCPTRG(sptr)) {
2699 int p;
2700 lzprintf(outlz, "L %d", sptr);
2701 for (p = SOCPTRG(sptr); p; p = SOC_NEXT(p)) {
2702 lzprintf(outlz, " %d", SOC_SPTR(p));
2703 }
2704 lzprintf(outlz, " -1\n");
2705 }
2706 break;
2707 default:
2708 break;
2709 }
2710
2711 switch (stype) {
2712 case ST_IDENT:
2713 case ST_VAR:
2714 /* If the string dtype information was stashed in the
2715 * this symbol table entry (see fixup_host_symbol_dtype),
2716 * the information is no longer needed so clear it (shouldn't
2717 * be necessary but just to be safe). */
2718 dtype = DTYPEG(sptr);
2719 if ((DTY(dtype) == TY_CHAR &&
2720 (dtype != DT_ASSCHAR || dtype != DT_DEFERCHAR)) ||
2721 (DTY(dtype) == TY_NCHAR &&
2722 (dtype != DT_ASSNCHAR || dtype != DT_DEFERNCHAR))) {
2723 int clen = DTY(dtype + 1);
2724 if (A_ALIASG(clen)
2725 /* If CLASS is set, then do not clear CVLEN since it's overloaded by
2726 * VTOFF and VTABLE which are used with type bound procedures. We
2727 * may need to revisit this when we implement unlimited polymorphic
2728 * types.
2729 */
2730 &&
2731 (!CLASSG(sptr) ||
2732 (STYPEG(sptr) != ST_MEMBER && STYPEG(sptr) != ST_PROC &&
2733 STYPEG(sptr) != ST_USERGENERIC && STYPEG(sptr) != ST_OPERATOR))) {
2734 CVLENP(sptr, 0);
2735 }
2736 }
2737 }
2738 }
2739
2740 /* ----------------------------------------------------------- */
2741
2742 /* write out necessary info for a single ast */
2743 static void
export_one_ast(int ast)2744 export_one_ast(int ast)
2745 {
2746 AST *wa;
2747 int bit, flags;
2748 int a;
2749 int i, s, n;
2750 int cnt;
2751 lzprintf(outlz, "A %d %d", ast, A_TYPEG(ast));
2752 flags = 0;
2753 bit = 1;
2754 #define ADDBIT(fl) \
2755 if (astb.stg_base[ast].fl) \
2756 flags |= bit; \
2757 bit <<= 1;
2758 ADDBIT(f1);
2759 ADDBIT(f2);
2760 ADDBIT(f3);
2761 ADDBIT(f4);
2762 ADDBIT(f5);
2763 ADDBIT(f6);
2764 ADDBIT(f7);
2765 ADDBIT(f8);
2766 #undef ADDBIT
2767 lzprintf(outlz, " %x", flags);
2768 lzprintf(outlz, " %d", astb.stg_base[ast].shape);
2769 lzprintf(outlz, " %d %d %d %d", astb.stg_base[ast].hshlk, astb.stg_base[ast].w3,
2770 astb.stg_base[ast].w4, astb.stg_base[ast].w5);
2771 lzprintf(outlz, " %d %d %d %d", astb.stg_base[ast].w6, astb.stg_base[ast].w7,
2772 astb.stg_base[ast].w8, astb.stg_base[ast].w9);
2773 lzprintf(outlz, " %d %d %d %d", astb.stg_base[ast].w10, astb.stg_base[ast].hw21,
2774 astb.stg_base[ast].hw22, astb.stg_base[ast].w12);
2775 lzprintf(outlz, " %d %d %d %d", astb.stg_base[ast].opt1, astb.stg_base[ast].opt2,
2776 astb.stg_base[ast].repl, astb.stg_base[ast].visit);
2777 /* IVSN 30 */
2778 lzprintf(outlz, " %d", astb.stg_base[ast].w18);
2779 lzprintf(outlz, " %d", astb.stg_base[ast].w19);
2780
2781 if (A_TYPEG(ast) == A_ID && A_IDSTRG(ast)) {
2782 lzprintf(outlz, " %s", SYMNAME(A_SPTRG(ast)));
2783 }
2784 lzprintf(outlz, "\n");
2785
2786 switch (A_TYPEG(ast)) {
2787 case A_FUNC:
2788 case A_INTR:
2789 if (!exportmode || gbl.internal > 1 || XBIT(66, 0x20000000)) {
2790 s = A_SHAPEG(ast);
2791 if (s) {
2792 n = SHD_NDIM(s);
2793 lzprintf(outlz, "T %d", n);
2794 for (i = 0; i < n; i++)
2795 lzprintf(outlz, " %d %d %d", SHD_LWB(s, i), SHD_UPB(s, i),
2796 SHD_STRIDE(s, i));
2797 lzprintf(outlz, "\n");
2798 }
2799 }
2800 /* fall through to dump argt */
2801 case A_CALL:
2802 case A_ICALL:
2803 case A_ENDMASTER:
2804 a = A_ARGSG(ast);
2805 if (a) {
2806 cnt = A_ARGCNTG(ast);
2807 lzprintf(outlz, "W %d", cnt);
2808 for (i = 0; i < cnt; i++)
2809 lzprintf(outlz, " %d", ARGT_ARG(a, i));
2810 lzprintf(outlz, "\n");
2811 }
2812 break;
2813 case A_SUBSCR:
2814 a = A_ASDG(ast);
2815 cnt = ASD_NDIM(a);
2816 lzprintf(outlz, "X %d", cnt);
2817 for (i = 0; i < cnt; i++)
2818 lzprintf(outlz, " %d", ASD_SUBS(a, i));
2819 lzprintf(outlz, "\n");
2820 break;
2821 case A_CGOTO:
2822 case A_AGOTO:
2823 case A_FORALL:
2824 a = A_LISTG(ast);
2825 lzprintf(outlz, "Y");
2826 while (a) {
2827 lzprintf(outlz, " %d %d", ASTLI_SPTR(a), ASTLI_TRIPLE(a));
2828 a = ASTLI_NEXT(a);
2829 }
2830 lzprintf(outlz, " -1\n");
2831 break;
2832 }
2833 } /* export_one_ast */
2834
2835 /* ----------------------------------------------------------- */
2836
2837 static void
queue_one_std(int std)2838 queue_one_std(int std)
2839 {
2840 if (STD_AST(std))
2841 queue_ast(STD_AST(std));
2842 if (STD_LABEL(std))
2843 queue_symbol(STD_LABEL(std));
2844 } /* queue_one_std */
2845
2846 static void
export_one_std(int std)2847 export_one_std(int std)
2848 {
2849 int bit, flags;
2850 flags = 0;
2851 bit = 1;
2852 #define ADDBIT(f) \
2853 if (astb.std.stg_base[std].flags.bits.f) \
2854 flags |= bit; \
2855 bit <<= 1;
2856 ADDBIT(ex);
2857 ADDBIT(st);
2858 ADDBIT(br);
2859 ADDBIT(delete);
2860 ADDBIT(ignore);
2861 ADDBIT(split);
2862 ADDBIT(minfo);
2863 ADDBIT(local);
2864 ADDBIT(pure);
2865 ADDBIT(par);
2866 ADDBIT(cs);
2867 ADDBIT(parsect);
2868 ADDBIT(orig);
2869 #undef ADDBIT
2870 lzprintf(outlz, "V %d %d %d %d %x", std, STD_AST(std), STD_LABEL(std),
2871 STD_LINENO(std), flags);
2872 if (exportmode) {
2873 lzprintf(outlz, " %d", STD_TAG(std));
2874 }
2875 lzprintf(outlz, "\n");
2876 } /* export_one_std */
2877
2878 static void
all_stds(void (* callproc)(int))2879 all_stds(void (*callproc)(int))
2880 {
2881 int std;
2882 for (std = STD_NEXT(0); std; std = STD_NEXT(std))
2883 (*callproc)(std);
2884 }
2885
2886 /* export a single record to the interf file */
2887 static void
export_dinit_record(int rectype,INT recval)2888 export_dinit_record(int rectype, INT recval)
2889 {
2890 lzprintf(outlz, "I %d %x\n", rectype, recval);
2891 } /* export_dinit_record */
2892
2893 /*
2894 * go through data initialization file.
2895 * call symproc for symbols in that file that will be saved
2896 */
2897 static void
export_dinit_file(void (* symproc)(int),void (* recproc)(int,INT),int do_fmt_nml)2898 export_dinit_file(void (*symproc)(int), void (*recproc)(int, INT),
2899 int do_fmt_nml)
2900 {
2901 DREC *p;
2902 dinit_fseek(0);
2903 while ((p = dinit_read())) {
2904 int ptype;
2905 INT pcon;
2906 int sptr;
2907 ptype = p->dtype;
2908 pcon = p->conval;
2909 switch (ptype) {
2910 case DINIT_FMT: /* skip the format */
2911 if (do_fmt_nml) {
2912 sptr = pcon;
2913 if (symproc)
2914 (*symproc)(sptr);
2915 } else {
2916 while ((p = dinit_read()) && p->dtype != DINIT_END)
2917 ;
2918 }
2919 break;
2920 case DINIT_NML: /* skip the namelist unless this is a module */
2921 if (exporting_module || do_fmt_nml) {
2922 if (recproc)
2923 (*recproc)(ptype, pcon);
2924 sptr = pcon;
2925 if (symproc)
2926 (*symproc)(sptr);
2927 } else {
2928 while ((p = dinit_read()) && p->dtype != DINIT_END)
2929 ;
2930 }
2931 break;
2932
2933 case DINIT_END:
2934 case DINIT_ENDTYPE: /* skip this */
2935 case DINIT_STARTARY: /* skip this also */
2936 case DINIT_ENDARY: /* skip this also */
2937 case 0: /* alignment record */
2938 case DINIT_ZEROES: /* skip it */
2939 case DINIT_OFFSET: /* unexpected */
2940 case DINIT_REPEAT: /* repeat count */
2941 if (recproc)
2942 (*recproc)(ptype, pcon);
2943 break;
2944 case DINIT_STR: /* string value */
2945 case DINIT_LABEL: /* take address, as for namelist */
2946 case DINIT_TYPEDEF: /* save the typedef symbol */
2947 case DINIT_LOC: /* initialize this variable */
2948 if (recproc)
2949 (*recproc)(ptype, pcon);
2950 sptr = pcon;
2951 if (symproc)
2952 (*symproc)(sptr);
2953 break;
2954 default:
2955 if (recproc)
2956 (*recproc)(ptype, pcon);
2957 if (symproc) {
2958 switch (DTY(ptype)) {
2959 case TY_DBLE:
2960 case TY_CMPLX:
2961 case TY_DCMPLX:
2962 case TY_QUAD:
2963 case TY_QCMPLX:
2964 case TY_INT8:
2965 case TY_LOG8:
2966 case TY_CHAR:
2967 case TY_NCHAR:
2968 /* save sptr */
2969 sptr = pcon;
2970 (*symproc)(sptr);
2971 break;
2972 case TY_INT: /* actual constant value stays the same */
2973 case TY_SINT: /* actual constant value stays the same */
2974 case TY_BINT: /* actual constant value stays the same */
2975 case TY_LOG: /* actual constant value stays the same */
2976 case TY_SLOG: /* actual constant value stays the same */
2977 case TY_BLOG: /* actual constant value stays the same */
2978 case TY_FLOAT: /* actual constant value stays the same */
2979 case TY_PTR: /* should not happen */
2980 default: /* should not happen */
2981 break;
2982 }
2983 }
2984 } /* switch */
2985 }
2986 dinit_fseek_end();
2987 } /* export_dinit_file */
2988
2989 /* go through symbols; if we find one that is a parameter, export
2990 * the ASTs for its value */
2991 static void
export_parameter_info(ast_visit_fn astproc)2992 export_parameter_info(ast_visit_fn astproc)
2993 {
2994 int sptr;
2995 for (sptr = stb.firstosym; sptr < stb.stg_avail; sptr++) {
2996 if (STYPEG(sptr) == ST_PARAM && DTY(DTYPEG(sptr)) != TY_ARRAY) {
2997 int ast = CONVAL2G(sptr);
2998 if (ast)
2999 ast_traverse(ast, NULL, astproc, NULL);
3000 }
3001 }
3002 } /* export_parameter_info */
3003
3004 static int
externalequiv(int evp)3005 externalequiv(int evp)
3006 {
3007 do {
3008 switch (SCG(EQV(evp).sptr)) {
3009 case SC_CMBLK:
3010 case SC_STATIC:
3011 return TRUE;
3012 default:;
3013 }
3014 evp = EQV(evp).next;
3015 } while (evp != 0 && EQV(evp).is_first == 0);
3016 return FALSE;
3017 } /* externalequiv */
3018
3019 static void
export_equiv_asts(int queuesym,ast_visit_fn astproc)3020 export_equiv_asts(int queuesym, ast_visit_fn astproc)
3021 {
3022 int evp, evnext;
3023 for (evp = sem.eqvlist; evp != 0; evp = evnext) {
3024 evnext = EQV(evp).next;
3025 /* beginning of an equivalence block */
3026 /* and some static variable in it */
3027 if (EQV(evp).is_first && externalequiv(evp)) {
3028 do {
3029 int ss, numss, j;
3030 if (queuesym)
3031 queue_symbol(EQV(evp).sptr);
3032 /* 0 or ast index for substring */
3033 if (EQV(evp).substring) {
3034 ast_traverse(EQV(evp).substring, NULL, astproc, NULL);
3035 }
3036 ss = EQV(evp).subscripts;
3037 numss = EQV_NUMSS(ss);
3038 /* depends on EQV_NUMSS(0) == 0, set in semant.c */
3039 for (j = 0; j < numss; ++j) {
3040 if (EQV_SS(ss, j))
3041 ast_traverse(EQV_SS(ss, j), NULL, astproc, NULL);
3042 }
3043 evp = EQV(evp).next;
3044 } while (evp != 0 && EQV(evp).is_first == 0);
3045 evnext = evp;
3046 }
3047 }
3048 } /* export_equiv_asts */
3049
3050 static void
export_equiv_item(int evp)3051 export_equiv_item(int evp)
3052 {
3053 int ss, numss, j;
3054 lzprintf(outlz, "E %d %d %d %d", PRIVATEG(EQV(evp).sptr), EQV(evp).lineno,
3055 EQV(evp).sptr, (EQV(evp).is_first == 0) ? 0 : 1);
3056 /* 0 or ast index for substring */
3057 lzprintf(outlz, " %d", (int)EQV(evp).substring);
3058 ss = EQV(evp).subscripts;
3059 numss = EQV_NUMSS(ss);
3060 /* depends on EQV_NUMSS(0) == 0, set in semant.c */
3061 for (j = 0; j < numss; ++j) {
3062 lzprintf(outlz, " %d", EQV_SS(ss, j));
3063 }
3064 lzprintf(outlz, " -1\n"); /* end of subscripts */
3065 } /* export_equiv_item */
3066
3067 static void
export_external_equiv()3068 export_external_equiv()
3069 {
3070 int evp, evnext;
3071 for (evp = sem.eqvlist; evp != 0; evp = evnext) {
3072 evnext = EQV(evp).next;
3073 /* beginning of an equivalence block */
3074 /* and some static variable in it */
3075 if (EQV(evp).is_first && externalequiv(evp)) {
3076 do {
3077 export_equiv_item(evp);
3078 evp = EQV(evp).next;
3079 } while (evp != 0 && EQV(evp).is_first == 0);
3080 evnext = evp;
3081 }
3082 }
3083 } /* export_external_equiv */
3084
3085 static void
export_equivs(void)3086 export_equivs(void)
3087 {
3088 int evp;
3089 for (evp = sem.eqvlist; evp != 0; evp = EQV(evp).next) {
3090 if (eqv_flag[evp])
3091 export_equiv_item(evp);
3092 }
3093 }
3094
3095 /* ----------------------------------------------------------- */
3096
3097 /*
3098 * set STD_TAG field
3099 */
3100 static int max_tag = 0;
3101 void
set_tag()3102 set_tag()
3103 {
3104 int std;
3105 for (std = STD_NEXT(0); std > 0; std = STD_NEXT(std)) {
3106 ++max_tag;
3107 STD_TAG(std) = max_tag;
3108 }
3109 } /* set_tag */
3110
3111