1 /*
2 * Copyright (c) 1997-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
20 \brief Routines used by lower.c for lowering symbols.
21 */
22
23 #include "gbldefs.h"
24 #include "global.h"
25 #include "error.h"
26 #include "symtab.h"
27 #include "symutl.h"
28 #include "dtypeutl.h"
29 #include "ast.h"
30 #include "semant.h"
31 #include "dinit.h"
32 #include "soc.h"
33 #include "pragma.h"
34 #include "rte.h"
35 #include "fih.h"
36 #include "dpm_out.h"
37 #include "rtlRtns.h"
38 #include "sharedefs.h"
39
40 #include "llmputil.h"
41
42 #define INSIDE_LOWER
43 #include "lower.h"
44 #include "dbg_out.h"
45 void scan_for_dwarf_module();
46 extern int print_file(int fihx);
47 static int valid_kind_parm_expr(int ast);
48 static int is_descr_expression(int ast);
49 static int lower_getnull(void);
50
51 /* table of data types to be exported */
52 static char *datatype_used;
53 static char *datatype_output;
54 static int last_datatype_used;
55 /* flag whether to mark linearized arrays yet */
56 static LOGICAL lower_linearized_dtypes = FALSE;
57
58 #define STB_LOWER() ((gbl.outfil == lowersym.lowerfile) && gbl.stbfil)
59 #define IS_STB_FILE() (gbl.stbfil == lowersym.lowerfile)
60 static void _stb_fixup_ifacearg(int);
61
62 /* keep a stack of information */
63 static int stack_top, stack_size;
64 static int *stack;
65
66 /* keep track of fih that has been written to file */
67 static int curr_findex;
68
69 /** \brief List of ILMs for function/subroutine arguments */
70 int *lower_argument;
71 int lower_argument_size;
72
73 /* header of linked list of pointer or allocatable variables whose
74 * pointer/offset/descriptors need to be initialized */
75 static int lower_pointer_list_head;
76
77 /* head of linked list of pointer/offset/section descriptors in the order they
78 * need to be given addresses */
79 static int lower_refd_list_head;
80
81 /* size of private area needed for private descriptors & their pointer &
82 * offset variables.
83 */
84 static ISZ_T private_addr;
85
86 struct lower_syms lowersym;
87
88 static int first_avail_scalarptr_temp, first_used_scalarptr_temp, first_temp;
89 static int first_avail_scalar_temp, first_used_scalar_temp;
90 static void lower_put_datatype(int, int);
91 static bool has_opt_args(SPTR sptr);
92
93 static void lower_fileinfo_llvm();
94 static LOGICAL llvm_iface_flag = FALSE;
95 static void stb_lower_sym_header();
96 static void check_debug_alias(SPTR sptr);
97
98 /** \brief
99 * ASSCHAR = -1 assumed size character
100 * ADJCHAR = -2 backend maps to DT_ASSCHAR
101 * DEFERCHAR = -3 deferred-length character */
102 enum LEN {ASSCHAR = -1, ADJCHAR = -2, DEFERCHAR = -3};
103
104 /** \brief Returns true if the procedure (sptr) has optional arguments.
105 */
106 static bool
has_opt_args(SPTR sptr)107 has_opt_args(SPTR sptr)
108 {
109 int i, psptr, nargs, dpdsc;
110
111 if (STYPEG(sptr) != ST_ENTRY && STYPEG(sptr) != ST_PROC) {
112 return false;
113 }
114 nargs = PARAMCTG(sptr);
115 dpdsc = DPDSCG(sptr);
116 for (i = 0; i < nargs; ++i) {
117 psptr = *(aux.dpdsc_base + dpdsc + i);
118 if (OPTARGG(psptr)) {
119 return true;
120 }
121 }
122 return false;
123 }
124 /** \brief Set 'EXTRA' bit for arrays, descriptors, array members
125 that have IPA no conflict information, or that are compiler temps,
126 or that can't conflict because they aren't targets and aren't pointers
127 */
128 void
lower_set_symbols(void)129 lower_set_symbols(void)
130 {
131 int sptr;
132 for (sptr = stb.firstosym; sptr < stb.stg_avail; ++sptr) {
133 /* allocatable arrays and members that are not POINTER
134 * arrays can be 'noconflict'; arrays without TARGET can be
135 * 'noconflict'; temp arrays are 'noconflict' */
136 switch (STYPEG(sptr)) {
137 case ST_ARRAY:
138 if (!IGNOREG(sptr)) {
139 if ((!ADDRTKNG(sptr) || (ALLOCG(sptr) && !POINTERG(sptr))) &&
140 SCG(sptr) != SC_BASED && IPA_isnoconflict(sptr)) {
141 VISIT2P(sptr, 1);
142 if (STYPEG(sptr) == ST_ARRAY && NEWARGG(sptr)) {
143 VISIT2P(NEWARGG(sptr), 1);
144 }
145 }
146 }
147 /* fall through */
148 case ST_MEMBER:
149 case ST_DESCRIPTOR:
150 if (!IGNOREG(sptr) && DTY(DTYPEG(sptr)) == TY_ARRAY) {
151 if ((!TARGETG(sptr) && !POINTERG(sptr) &&
152 (ALLOCG(sptr) || !ADDRTKNG(sptr))) ||
153 CCSYMG(sptr) || HCCSYMG(sptr)) {
154 VISIT2P(sptr, 1);
155 }
156 }
157 /* fall through */
158 case ST_VAR:
159 if (SCG(sptr) == SC_BASED) {
160 /* look at section descriptor, pointer */
161 int d, p;
162 p = MIDNUMG(sptr);
163 if (p && HCCSYMG(p))
164 VISIT2P(p, 1);
165 d = SDSCG(sptr);
166 if (d && HCCSYMG(d))
167 VISIT2P(d, 1);
168 }
169 break;
170 default:;
171 }
172 }
173 } /* lower_set_symbols */
174
175 /** \brief Set datatype of 'cray pointers' to derived types.
176 */
177 void
lower_set_craypointer(void)178 lower_set_craypointer(void)
179 {
180 int sptr;
181 for (sptr = stb.firstosym; sptr < stb.stg_avail; ++sptr) {
182 switch (STYPEG(sptr)) {
183 case ST_ARRAY:
184 case ST_VAR:
185 case ST_MEMBER:
186 if (SCG(sptr) == SC_BASED && MIDNUMG(sptr)) {
187 int ptr;
188 ptr = MIDNUMG(sptr);
189 if (DTYPEG(ptr) == DT_PTR) {
190 int dtype, ndtype;
191 dtype = DTYPEG(sptr);
192 if (DTY(dtype) == TY_ARRAY)
193 dtype = DTY(dtype + 1);
194 if (DTY(dtype) == TY_PTR)
195 ndtype = dtype;
196 else {
197 ndtype = get_type(2, TY_PTR, dtype);
198 }
199 DTYPEP(ptr, ndtype);
200 if (VISITG(ptr) || ndtype >= last_datatype_used) {
201 lower_use_datatype(ndtype, 1);
202 }
203 }
204 }
205 break;
206 default:;
207 }
208 }
209 } /* lower_set_craypointer */
210
211 /** \brief Reset data types of derived type pointers to DT_PTR.
212 */
213 void
lower_unset_symbols(void)214 lower_unset_symbols(void)
215 {
216 int sptr;
217 for (sptr = stb.firstosym; sptr < stb.stg_avail; ++sptr) {
218 switch (STYPEG(sptr)) {
219 case ST_ARRAY:
220 case ST_VAR:
221 case ST_MEMBER:
222 if (SCG(sptr) == SC_BASED && MIDNUMG(sptr)) {
223 int ptr;
224 ptr = MIDNUMG(sptr);
225 DTYPEP(ptr, DT_PTR);
226 }
227 break;
228 default:;
229 }
230 }
231 } /* lower_unset_symbols */
232
233 static void save_vol_descriptors(int);
234
235 /* call this first so the symbol count and datatype count won't change later */
236 static void
lower_make_all_descriptors(void)237 lower_make_all_descriptors(void)
238 {
239 int sptr;
240 int stp = 0;
241 for (sptr = stb.firstusym; sptr < stb.stg_avail; ++sptr) {
242 switch (STYPEG(sptr)) {
243 case ST_ARRAY:
244 case ST_DESCRIPTOR:
245 case ST_VAR:
246 case ST_IDENT:
247 case ST_STRUCT:
248 if (IGNOREG(sptr))
249 break;
250 /* see if setting LNRZD fixes REDIM statement processing */
251 if (ALLOCG(sptr) && !NODESCG(sptr)) {
252 LNRZDP(sptr, 1);
253 }
254 if (ENCLFUNCG(sptr) != 0) {
255 /* module symbols */
256 if (!POINTERG(sptr) && SDSCG(sptr) != 0 &&
257 STYPEG(SDSCG(sptr)) != ST_PARAM) {
258 if (!ASSUMSHPG(sptr) ||
259 (!XBIT(54, 2) && !(XBIT(58, 0x400000) && TARGETG(sptr)))) {
260 /* set SDSCS1 for sdsc */
261 SDSCS1P(SDSCG(sptr), 1);
262 }
263 }
264 break;
265 }
266 /* names that weren't resolved might be variables used by internal
267 * subroutines */
268 if (SCG(sptr) == SC_NONE)
269 SCP(sptr, SC_LOCAL);
270 if (SAVEG(sptr) && SCG(sptr) == SC_LOCAL)
271 SCP(sptr, SC_STATIC);
272 if (STYPEG(sptr) == ST_IDENT)
273 STYPEP(sptr, ST_VAR);
274 if (POINTERG(sptr) || ALLOCG(sptr) || ALLOCATTRG(sptr)) {
275 if (SDSCG(sptr) == 0 || STYPEG(SDSCG(sptr)) == ST_PARAM) {
276 if (MIDNUMG(sptr) == 0) {
277 stp = sym_get_ptr(sptr);
278 MIDNUMP(sptr, stp);
279 if (SCG(sptr) == SC_PRIVATE)
280 SCP(stp, SC_PRIVATE);
281 }
282 PTRSAFEP(MIDNUMG(sptr), 1);
283 } else {
284 if (PTROFFG(sptr) == 0) {
285 if (MIDNUMG(sptr) == 0) {
286 stp = sym_get_ptr(sptr);
287 MIDNUMP(sptr, stp);
288 if (SCG(sptr) == SC_PRIVATE)
289 SCP(stp, SC_PRIVATE);
290 }
291 if (SCG(sptr) == SC_DUMMY) {
292 if (!stp)
293 stp = sym_get_ptr(sptr);
294 SCP(stp, SC_DUMMY);
295 MIDNUMP(sptr, stp);
296 }
297 }
298 if (!POINTERG(sptr)) {
299 /* set SDSCS1 for sdsc */
300 SDSCS1P(SDSCG(sptr), 1);
301 }
302 if (MIDNUMG(sptr))
303 PTRSAFEP(MIDNUMG(sptr), 1);
304 }
305 SCP(sptr, SC_BASED);
306 if (SAVEG(sptr) && SCG(sptr) == SC_STATIC) {
307 int ptr, sdsc, off;
308 ptr = MIDNUMG(sptr);
309 SAVEP(MIDNUMG(sptr), 1);
310 if (ptr && SCG(ptr) == SC_LOCAL)
311 SCP(ptr, SC_STATIC);
312 sdsc = SDSCG(sptr);
313 if (sdsc && STYPEG(sdsc) != ST_PARAM) {
314 SAVEP(sdsc, 1);
315 if (SCG(sdsc) == SC_LOCAL)
316 SCP(sdsc, SC_STATIC);
317 }
318 off = PTROFFG(sptr);
319 if (off && STYPEG(off) != ST_PARAM) {
320 SAVEP(off, 1);
321 if (SCG(off) == SC_LOCAL)
322 SCP(off, SC_STATIC);
323 }
324 SAVEP(sptr, 0);
325 }
326 } else if (AUTOBJG(sptr) || (ADJARRG(sptr) && SCG(sptr) == SC_LOCAL)) {
327 if (MIDNUMG(sptr) == 0) {
328 SCP(sptr, SC_BASED);
329 stp = sym_get_ptr(sptr);
330 MIDNUMP(sptr, stp);
331 }
332 else if (flg.smp && MIDNUMG(sptr)) {
333 SCP(sptr, SC_BASED);
334 }
335 PTRSAFEP(MIDNUMG(sptr), 1);
336 if (SAVEG(sptr) && SCG(sptr) == SC_STATIC) {
337 int ptr, sdsc, off;
338 ptr = MIDNUMG(sptr);
339 SAVEP(MIDNUMG(sptr), 1);
340 if (ptr && SCG(ptr) == SC_LOCAL)
341 SCP(ptr, SC_STATIC);
342 sdsc = SDSCG(sptr);
343 if (sdsc && STYPEG(sdsc) != ST_PARAM) {
344 SAVEP(sdsc, 1);
345 if (SCG(sdsc) == SC_LOCAL)
346 SCP(sdsc, SC_STATIC);
347 }
348 off = PTROFFG(sptr);
349 if (off && STYPEG(off) != ST_PARAM) {
350 SAVEP(off, 1);
351 if (SCG(off) == SC_LOCAL)
352 SCP(off, SC_STATIC);
353 }
354 SAVEP(sptr, 0);
355 }
356 }
357 break;
358 case ST_MEMBER:
359 if (!POINTERG(sptr)) {
360 if (SDSCG(sptr) != 0 && STYPEG(SDSCG(sptr)) != ST_PARAM) {
361 /* set SDSCS1 for sdsc */
362 SDSCS1P(SDSCG(sptr), 1);
363 }
364 }
365 if (DTY(DTYPEG(sptr)) == TY_ARRAY) {
366 if (DISTG(sptr) || ALIGNG(sptr) || ADJARRG(sptr) || RUNTIMEG(sptr)) {
367 /* implement by handling like a pointer */
368 POINTERP(sptr, 1);
369 }
370 }
371 if (POINTERG(sptr)) {
372 if (SDSCG(sptr) == 0 || STYPEG(SDSCG(sptr)) == ST_PARAM) {
373 if (MIDNUMG(sptr) == 0) {
374 if (!is_procedure_ptr(sptr)) {
375 stp = sym_get_ptr(sptr);
376 MIDNUMP(sptr, stp);
377 } else {
378 MIDNUMP(sptr, sptr);
379 }
380 }
381 } else {
382 if (PTROFFG(sptr) == 0) {
383 if (MIDNUMG(sptr) == 0) {
384 stp = sym_get_ptr(sptr);
385 MIDNUMP(sptr, stp);
386 }
387 stp = sym_get_offset(sptr);
388 PTROFFP(sptr, stp);
389 }
390 }
391 }
392 break;
393 default:;
394 }
395 }
396 } /* lower_make_all_descriptors */
397
398 static void
save_vol_descriptors(int sptr)399 save_vol_descriptors(int sptr)
400 {
401 int ptr, sdsc, off;
402 if (SAVEG(sptr) && SCG(sptr) == SC_STATIC) {
403 ptr = MIDNUMG(sptr);
404 SAVEP(MIDNUMG(sptr), 1);
405 if (ptr && SCG(ptr) == SC_LOCAL)
406 SCP(ptr, SC_STATIC);
407 sdsc = SDSCG(sptr);
408 if (sdsc && STYPEG(sdsc) != ST_PARAM) {
409 SAVEP(sdsc, 1);
410 if (SCG(sdsc) == SC_LOCAL)
411 SCP(sdsc, SC_STATIC);
412 }
413 off = PTROFFG(sptr);
414 if (off && STYPEG(off) != ST_PARAM) {
415 SAVEP(off, 1);
416 if (SCG(off) == SC_LOCAL)
417 SCP(off, SC_STATIC);
418 }
419 SAVEP(sptr, 0);
420 }
421 if (VOLG(sptr)) {
422 ptr = MIDNUMG(sptr);
423 VOLP(MIDNUMG(sptr), 1);
424 sdsc = SDSCG(sptr);
425 if (sdsc && STYPEG(sdsc) != ST_PARAM) {
426 VOLP(sdsc, 1);
427 }
428 off = PTROFFG(sptr);
429 if (off && STYPEG(off) != ST_PARAM) {
430 VOLP(off, 1);
431 }
432 VOLP(sptr, 0);
433 }
434 }
435
436 static int
remove_list(int list,int sym)437 remove_list(int list, int sym)
438 {
439 int l, prev = 0;
440 for (l = list; l > NOSYM; l = SYMLKG(l)) {
441 if (l == sym) {
442 if (prev) {
443 SYMLKP(prev, SYMLKG(sym));
444 } else {
445 list = SYMLKG(sym);
446 }
447 SYMLKP(sym, NOSYM);
448 return list;
449 }
450 prev = l;
451 }
452 /* not found */
453 return list;
454 } /* remove_list */
455
456 static void
push_lower_refd_list(int sym)457 push_lower_refd_list(int sym)
458 {
459 if (LOWER_REFD_LIST(sym)) {
460 int l, prev;
461 prev = 0;
462 for (l = lower_refd_list_head; l > NOSYM; l = LOWER_REFD_LIST(l)) {
463 if (l == sym) {
464 if (prev) {
465 LOWER_REFD_LIST(prev) = LOWER_REFD_LIST(sym);
466 } else {
467 lower_refd_list_head = LOWER_REFD_LIST(sym);
468 }
469 break;
470 }
471 prev = l;
472 }
473 }
474 LOWER_REFD_LIST(sym) = lower_refd_list_head;
475 lower_refd_list_head = sym;
476 } /* push_lower_refd_list */
477
478 /* fill in LWAST, UPAST, MLPYR, ZBASE, NUMELM fields */
479 static void
fill_fixed_array_dtype(int dtype)480 fill_fixed_array_dtype(int dtype)
481 {
482 int i, ndim, m;
483 ISZ_T mlpyr, zbase, numelm;
484 ndim = ADD_NUMDIM(dtype);
485 mlpyr = 1;
486 zbase = 0;
487
488 m = ADD_MLPYR(dtype, 0);
489 if (m == 0) {
490 mlpyr = 1;
491 } else {
492 if (A_ALIASG(m))
493 m = A_ALIASG(m);
494 if (A_TYPEG(m) != A_CNST) {
495 lerror("nonconstant multiplier for dimension 1 for datatype %d", dtype);
496 mlpyr = 1;
497 } else {
498 int mlpyrsym;
499 mlpyrsym = A_SPTRG(m);
500 lower_visit_symbol(mlpyrsym);
501 if (STYPEG(mlpyrsym) == ST_CONST) {
502 mlpyr = ad_val_of(mlpyrsym);
503 } else {
504 lerror("nonconstant multiplier for dimension 1 for datatype %d", dtype);
505 mlpyr = 1;
506 }
507 }
508 }
509
510 for (i = 0; i < ndim; ++i) {
511 int lw, up;
512 ISZ_T lwval, upval;
513
514 lw = ADD_LWAST(dtype, i);
515 if (lw != 0 && A_ALIASG(lw))
516 lw = A_ALIASG(lw);
517 if (lw == 0) {
518 lwval = 1;
519 ADD_LWAST(dtype, i) = mk_cnst(lower_getiszcon(lwval));
520 } else if (A_TYPEG(lw) == A_CNST) {
521 lwval = ad_val_of(A_SPTRG(lw));
522 } else {
523 lerror("nonconstant array lower bound for dimension %d for datatype %d",
524 i, dtype);
525 lwval = 1;
526 ADD_LWAST(dtype, i) = mk_cnst(lower_getiszcon(lwval));
527 }
528
529 if (mlpyr > 0) {
530 ADD_MLPYR(dtype, i) = mk_cnst(lower_getiszcon(mlpyr));
531 zbase = zbase + mlpyr * lwval;
532 }
533
534 up = ADD_UPAST(dtype, i);
535
536 if (up != 0 && A_ALIASG(up))
537 up = A_ALIASG(up);
538 if (up == 0) {
539 if (i != ndim - 1) {
540 lerror("no upper bound for dimension %d of datatype %d", i, dtype);
541 }
542 mlpyr = -1;
543 } else if (A_TYPEG(up) != A_CNST && !valid_kind_parm_expr(up)) {
544 if (i != ndim - 1) {
545 lerror("nonconstant upper bound for dimension %d of datatype %d", i,
546 dtype);
547 }
548 mlpyr = -1;
549 } else {
550 upval = ad_val_of(A_SPTRG(up));
551
552 /* update multiplier for next dimension;
553 * mlpyr = mlpyr * (upper - lower + 1) */
554 if (mlpyr > 0) {
555 mlpyr *= (upval - lwval + 1);
556 }
557 }
558 }
559 ADD_ZBASE(dtype) = mk_cnst(lower_getiszcon(zbase));
560
561 if (mlpyr > 0) {
562 ADD_NUMELM(dtype) = mk_cnst(lower_getiszcon(mlpyr));
563 } else {
564 ADD_NUMELM(dtype) = astb.bnd.zero;
565 }
566 } /* fill_fixed_array_dtype */
567
568 /* fill in LWAST, UPAST, MLPYR, ZBASE, NUMELM fields */
569 static void
fill_pointer_array_dtype(int dtype,int sptr)570 fill_pointer_array_dtype(int dtype, int sptr)
571 {
572 int i, ndim, zbase, zbaseast, numelm, numelmast, desc;
573 int desc_ast;
574
575 desc = SDSCG(sptr);
576 if (desc == 0) {
577 lerror("no descriptor for %s, datatype %d", SYMNAME(sptr), dtype);
578 return;
579 }
580 ndim = ADD_NUMDIM(dtype);
581 for (i = 0; i < ndim; ++i) {
582 int m, lw, up, lwast, upast, extntast, mast;
583 lwast = ADD_LWAST(dtype, i);
584 if (!lwast || A_TYPEG(lwast) != A_CNST) {
585 ADD_LWAST(dtype, i) = get_global_lower(desc, i);
586 }
587
588 upast = ADD_UPAST(dtype, i);
589 if (!upast || A_TYPEG(upast) != A_CNST) {
590 int a;
591 a = get_extent(desc, i);
592 a = mk_binop(OP_SUB, a, astb.i1, A_DTYPEG(a)),
593 ADD_UPAST(dtype, i) =
594 mk_binop(OP_ADD, get_global_lower(desc, i), a, A_DTYPEG(a));
595 }
596
597 extntast = ADD_EXTNTAST(dtype, i);
598 if (!extntast || A_TYPEG(extntast) != A_CNST) {
599 ADD_EXTNTAST(dtype, i) = get_extent(desc, i);
600 }
601
602 mast = ADD_MLPYR(dtype, i);
603 if (!mast || A_TYPEG(mast) != A_CNST) {
604 ADD_MLPYR(dtype, i) = get_local_multiplier(desc, i);
605 }
606 }
607 zbaseast = ADD_ZBASE(dtype);
608 if (!zbaseast || A_TYPEG(zbaseast) != A_CNST) {
609 ADD_ZBASE(dtype) = get_xbase(desc);
610 }
611 numelmast = ADD_NUMELM(dtype);
612 if (!numelmast || A_TYPEG(numelmast) != A_CNST) {
613 ADD_NUMELM(dtype) = get_desc_gsize(desc);
614 }
615 } /* fill_pointer_array_dtype */
616
617 static int
adjarr_class(int sptr)618 adjarr_class(int sptr)
619 {
620 int midnum;
621 if (!XBIT(52, 4)) {
622 if (POINTERG(sptr) || MDALLOCG(sptr)) {
623 return SC_NONE;
624 }
625 }
626 midnum = MIDNUMG(sptr);
627 if (!midnum) {
628 if (!THREADG(sptr)) {
629 if (SAVEG(sptr) || SCG(sptr) == SC_STATIC) {
630 return SC_STATIC;
631 }
632 }
633 } else {
634 if (!THREADG(sptr)) {
635 if (SAVEG(midnum) || SCG(midnum) == SC_STATIC ||
636 SCG(midnum) == SC_CMBLK) {
637 return SC_STATIC;
638 }
639 }
640 if (SCG(midnum) == SC_PRIVATE)
641 return SC_PRIVATE;
642 }
643 return SC_LOCAL;
644 } /* adjarr_class */
645
646 static int
get_atmp(int tempsc,int dt,int saveg)647 get_atmp(int tempsc, int dt, int saveg)
648 {
649 int s;
650 s = getccsym('A', ++lowersym.acount, ST_VAR);
651 SCP(s, tempsc);
652 DTYPEP(s, dt);
653 SAVEP(s, saveg);
654 return s;
655 }
656
657 /* fill in LWAST, UPAST, MLPYR, ZBASE, NUMELM fields
658 * if assumed-shape, lower bounds are the actual values used */
659 static void
fill_adjustable_array_dtype(int dtype,int assumedshape,int stride1,int tempsc,int alltemp,int keeptemp,int saveg,int sptr)660 fill_adjustable_array_dtype(int dtype, int assumedshape, int stride1,
661 int tempsc, int alltemp, int keeptemp, int saveg,
662 int sptr)
663 {
664 int i, ndim, zbase, numelm, zbasesym, numelmsym, nonconstant;
665 int mlpyr, mlpyrsym;
666 ISZ_T mlpyrval;
667 int dt_bnd;
668 int enclfunc, midnum, taskp;
669
670 enclfunc = 0;
671 taskp = 0;
672
673 if (XBIT(68, 0x1))
674 dt_bnd = DT_INT8;
675 else
676 dt_bnd = DT_INT4;
677
678 ndim = ADD_NUMDIM(dtype);
679 nonconstant = 0;
680
681 mlpyr = ADD_MLPYR(dtype, 0);
682 if (mlpyr == 0 || stride1) {
683 mlpyrval = 1;
684 mlpyrsym = 0;
685 } else {
686 if (A_ALIASG(mlpyr))
687 mlpyr = A_ALIASG(mlpyr);
688 if (A_TYPEG(mlpyr) == A_ID || A_TYPEG(mlpyr) == A_CNST) {
689 mlpyrsym = A_SPTRG(mlpyr);
690 if (!alltemp && STYPEG(mlpyrsym) == ST_CONST) {
691 mlpyrval = ad_val_of(mlpyrsym);
692 mlpyrsym = 0;
693 } else if (!keeptemp || STYPEG(mlpyrsym) != ST_VAR) {
694 mlpyrsym = get_atmp(tempsc, dt_bnd, saveg);
695 mlpyrval = 0;
696 if (enclfunc) {
697 ENCLFUNCP(mlpyrsym, enclfunc);
698 TASKP(mlpyrsym, 1);
699 }
700 }
701 } else {
702 mlpyrsym = get_atmp(tempsc, dt_bnd, saveg);
703 if (enclfunc) {
704 ENCLFUNCP(mlpyrsym, enclfunc);
705 TASKP(mlpyrsym, 1);
706 }
707 mlpyrval = 0;
708 }
709 }
710 /* update multiplier */
711 if (mlpyrsym == 0) {
712 /* so far, multiplier is constant */
713 ADD_MLPYR(dtype, 0) = mk_cnst(lower_getiszcon(mlpyrval));
714 } else {
715 ADD_MLPYR(dtype, 0) = mk_id(mlpyrsym);
716 lower_visit_symbol(mlpyrsym);
717 }
718 for (i = 0; i < ndim; ++i) {
719 int m, lw, lwsym, up, upsym, extnt;
720 ISZ_T lwval, upval;
721 lw = ADD_LWAST(dtype, i);
722 if (lw != 0 && A_ALIASG(lw))
723 lw = A_ALIASG(lw);
724 if (lw == 0 && assumedshape && !XBIT(54, 2) &&
725 !(XBIT(58, 0x400000) && TARGETG(sptr))) {
726 ADD_LWAST(dtype, i) = astb.bnd.one;
727 lwsym = 0;
728 lwval = 1;
729 } else if (lw && A_TYPEG(lw) == A_CNST && !alltemp) {
730 lwval = ad_val_of(A_SPTRG(lw));
731 lwsym = 0;
732 } else if (keeptemp && lw && A_TYPEG(lw) == A_ID) {
733 lwval = 0;
734 lwsym = A_SPTRG(lw);
735 } else {
736 lwsym = get_atmp(tempsc, dt_bnd, saveg);
737 if (enclfunc) {
738 ENCLFUNCP(lwsym, enclfunc);
739 TASKP(lwsym, 1);
740 }
741 ADD_LWAST(dtype, i) = mk_id(lwsym);
742 lwval = 0;
743 lower_visit_symbol(lwsym);
744 }
745
746 up = ADD_UPAST(dtype, i);
747 if (up != 0 && A_ALIASG(up))
748 up = A_ALIASG(up);
749 if (up && A_TYPEG(up) == A_CNST && !alltemp) {
750 upval = ad_val_of(A_SPTRG(up));
751 upsym = 0;
752 } else if (keeptemp && up && A_TYPEG(up) == A_ID) {
753 upval = 0;
754 upsym = A_SPTRG(up);
755 } else {
756 upsym = get_atmp(tempsc, dt_bnd, saveg);
757 if (enclfunc) {
758 ENCLFUNCP(upsym, enclfunc);
759 TASKP(upsym, 1);
760 }
761 ADD_UPAST(dtype, i) = mk_id(upsym);
762 upval = 0;
763 lower_visit_symbol(upsym);
764 }
765
766 extnt = ADD_EXTNTAST(dtype, i);
767 if (extnt != 0 && A_ALIASG(extnt))
768 extnt = A_ALIASG(extnt);
769 if (extnt && A_TYPEG(extnt) == A_CNST && !alltemp) {
770 extnt = CONVAL2G(A_SPTRG(extnt));
771 } else if (keeptemp && extnt && A_TYPEG(extnt) == A_ID) {
772 extnt = A_SPTRG(extnt);
773 } else if (ALLOCATTRG(sptr) && THREADG(sptr) && extnt) {
774 /*
775 * do not create a scalar temp for the extent of an allocatable
776 * threadprivate; use the desriptor as-is.
777 * Perhaps, another routine should be called instead of
778 * fill_adjustable_array_dtype(), e.g., for POINTERs, we call
779 * fill_pointer_array_dtype()
780 */
781 ;
782 } else {
783 extnt = get_atmp(tempsc, dt_bnd, saveg);
784 if (enclfunc) {
785 ENCLFUNCP(extnt, enclfunc);
786 TASKP(extnt, 1);
787 }
788 ADD_EXTNTAST(dtype, i) = mk_id(extnt);
789 lower_visit_symbol(extnt);
790 }
791
792 if (mlpyrsym == 0 && lwsym == 0 && upsym == 0) {
793 mlpyrval *= (upval - lwval + 1);
794 ADD_MLPYR(dtype, i + 1) = mk_cnst(lower_getiszcon(mlpyrval));
795 } else {
796 mlpyr = ADD_MLPYR(dtype, i + 1);
797 if (keeptemp && mlpyr && A_TYPEG(mlpyr) == A_ID) {
798 mlpyrval = 0;
799 mlpyrsym = A_SPTRG(mlpyr);
800 } else {
801 mlpyrsym = get_atmp(tempsc, lowersym.bnd.dtype, saveg);
802 if (enclfunc) {
803 ENCLFUNCP(mlpyrsym, enclfunc);
804 TASKP(mlpyrsym, 1);
805 }
806 ADD_MLPYR(dtype, i + 1) = mk_id(mlpyrsym);
807 }
808 lower_visit_symbol(mlpyrsym);
809 }
810 }
811
812 zbase = ADD_ZBASE(dtype);
813 if (keeptemp && (A_TYPEG(zbase) == A_ID || A_TYPEG(zbase) == A_CNST)) {
814 zbasesym = A_SPTRG(zbase);
815 } else {
816 zbasesym = get_atmp(tempsc, dt_bnd, saveg);
817 if (enclfunc) {
818 ENCLFUNCP(zbasesym, enclfunc);
819 TASKP(zbasesym, 1);
820 }
821 ADD_ZBASE(dtype) = mk_id(zbasesym);
822 }
823 lower_visit_symbol(zbasesym);
824 } /* fill_adjustable_array_dtype */
825
826 static void
lower_prepare_symbols()827 lower_prepare_symbols()
828 {
829 int sptr, link, fval;
830 int stdx;
831 for (sptr = stb.firstosym; sptr < stb.stg_avail; ++sptr) {
832 int dtype, stype;
833 stype = STYPEG(sptr);
834 dtype = DTYPEG(sptr);
835 if (GSCOPEG(sptr)) {
836 fixup_reqgs_ident(sptr);
837 }
838 switch (stype) {
839 case ST_ARRAY:
840 if ((gbl.internal <= 1 && !gbl.empty_contains) || INTERNALG(sptr)) {
841 int saveg;
842 saveg = 0;
843 if (SAVEG(sptr) && !THREADG(sptr))
844 saveg = 1;
845 if (POINTERG(sptr) || MDALLOCG(sptr) || ALIGNG(sptr) || DISTG(sptr)) {
846 if (!XBIT(52, 4)) {
847 if (SDSCG(sptr) && STYPEG(SDSCG(sptr)) != ST_PARAM) {
848 /* use section descriptor elements in the array datatype */
849 fill_pointer_array_dtype(dtype, sptr);
850 }
851 } else {
852 /* insert .A variables in the descriptor */
853 fill_adjustable_array_dtype(dtype, ASSUMSHPG(sptr), 0,
854 adjarr_class(sptr), POINTERG(sptr), 0,
855 saveg, sptr);
856 }
857 } else if (XBIT(57, 0x10000) && ASSUMSHPG(sptr)) {
858 /* don't need to insert .A variables in the descriptor */
859 } else if (ASSUMSHPG(sptr) ||
860 (ALLOCG(sptr) && SCG(sptr) == SC_BASED && MIDNUMG(sptr) &&
861 SCG(MIDNUMG(sptr)) == SC_CMBLK)) {
862 if (!XBIT(52, 4)) {
863 int subdtype;
864 subdtype = DTY(dtype + 1);
865 subdtype = DTY(subdtype);
866 if (SDSCG(sptr) && !NODESCG(sptr) && subdtype != TY_CHAR &&
867 subdtype != TY_NCHAR && STYPEG(SDSCG(sptr)) != ST_PARAM) {
868 /* use section descriptor elements in the array datatype */
869 fill_pointer_array_dtype(dtype, sptr);
870 } else {
871 fill_adjustable_array_dtype(dtype, ASSUMSHPG(sptr), 1,
872 adjarr_class(sptr), ALLOCG(sptr), 1,
873 saveg, sptr);
874 }
875 } else if (!XBIT(52, 8)) {
876 fill_adjustable_array_dtype(dtype, ASSUMSHPG(sptr), 1,
877 adjarr_class(sptr), ALLOCG(sptr), 1,
878 saveg, sptr);
879 } else {
880 /* insert .A variables in the datatype */
881 fill_adjustable_array_dtype(dtype, ASSUMSHPG(sptr), 1,
882 adjarr_class(sptr), ALLOCG(sptr), 0,
883 saveg, sptr);
884 }
885 } else if (gbl.internal && ALLOCATTRG(sptr) && !INTERNALG(sptr) &&
886 MIDNUMG(sptr) &&
887 (SCG(MIDNUMG(sptr)) == SC_LOCAL ||
888 SCG(MIDNUMG(sptr)) == SC_DUMMY)) {
889 /*
890 * nothing to do --- Host local allocatables will be
891 * descriptor-based in the presence of internal procedures
892 */
893 ;
894 } else if (ALLOCG(sptr) || AUTOBJG(sptr) ||
895 (ADJARRG(sptr) && SCG(sptr) == SC_LOCAL)) {
896 if (flg.smp && MIDNUMG(sptr) && TASKG(MIDNUMG(sptr)))
897 ;
898 else
899 if (!XBIT(52, 8)) {
900 /* insert .A variables in the datatype */
901 fill_adjustable_array_dtype(dtype, 0, 1, adjarr_class(sptr),
902 ALLOCG(sptr), 1, saveg, sptr);
903 } else {
904 /* insert .A variables in the datatype */
905 fill_adjustable_array_dtype(dtype, 0, 1, adjarr_class(sptr),
906 ALLOCG(sptr), 0, saveg, sptr);
907 }
908 } else if (!ADJARRG(sptr)) {
909 /* fixed-size datatype */
910 fill_fixed_array_dtype(dtype);
911 }
912 }
913 /* fall through */
914
915 case ST_VAR:
916 case ST_IDENT:
917 case ST_STRUCT:
918 if (MDALLOCG(sptr))
919 break;
920 if (SCG(sptr) == SC_CMBLK)
921 break;
922 if (SCG(sptr) == SC_DUMMY)
923 break;
924 if (SCG(sptr) == SC_STATIC)
925 break;
926 if (CCSYMG(sptr) && !RESULTG(sptr))
927 break;
928 if (ENCLFUNCG(sptr) != 0)
929 break;
930 if (POINTERG(sptr) || ALLOCG(sptr)) {
931 /* this gets confused if the same ptr/off/desc are used
932 * for more than one symbol (as for function return arrays).
933 * We don't want to put them on the gbl.locals list more than
934 * once, and do want to make them static if any of the symbols
935 * using them are static */
936 int ptr, off, desc, ndtype;
937 ptr = MIDNUMG(sptr);
938 if (ptr == 0)
939 break;
940 off = PTROFFG(sptr);
941 desc = SDSCG(sptr);
942 if (desc != 0) {
943 if (STYPEG(desc) == ST_PARAM || STYPEG(desc) == ST_MEMBER)
944 break;
945 IGNOREP(ptr, 0);
946 if (off)
947 IGNOREP(off, 0);
948 IGNOREP(desc, 0);
949
950 /* give new addresses */
951 if (REFG(ptr)) {
952 if (SCG(ptr) == SC_STATIC) {
953 gbl.statics = remove_list(gbl.statics, ptr);
954 } else {
955 gbl.locals = remove_list(gbl.locals, ptr);
956 }
957 REFP(ptr, 0);
958 }
959 if (off && REFG(off)) {
960 if (SCG(off) == SC_STATIC) {
961 gbl.statics = remove_list(gbl.statics, off);
962 } else {
963 gbl.locals = remove_list(gbl.locals, off);
964 }
965 REFP(off, 0);
966 }
967 if (REFG(desc)) {
968 if (SCG(desc) == SC_STATIC) {
969 gbl.statics = remove_list(gbl.statics, desc);
970 } else {
971 gbl.locals = remove_list(gbl.locals, desc);
972 }
973 REFP(desc, 0);
974 }
975
976 /* astout.c would put the pointer/offset/descriptor
977 * triplet in a common block to make sure they are
978 * allocated continguously. Here, we simply give them
979 * consecutively addresses */
980 if (SAVEG(sptr)) {
981 SAVEP(ptr, 1);
982 SCP(ptr, SC_STATIC);
983 if (off) {
984 SAVEP(off, 1);
985 SCP(off, SC_STATIC);
986 }
987 /* FS#18004: If descriptor is for a polymorphic entity
988 * and the descriptor is a dummy argument, then do not
989 * turn it into a save variable/static. Otherwise,
990 * we may lose type information at runtime.
991 */
992 if (!CLASSG(sptr) || SCG(desc) != SC_DUMMY) {
993 SAVEP(desc, 1);
994 SCP(desc, SC_STATIC);
995 }
996 } else if (SCG(ptr) != SC_DUMMY &&
997 (SCG(ptr) == SC_STATIC || SCG(desc) == SC_STATIC ||
998 (off && SCG(off) == SC_STATIC))) {
999 SCP(ptr, SC_STATIC);
1000 if (off)
1001 SCP(off, SC_STATIC);
1002 SCP(desc, SC_STATIC);
1003 }
1004 if (ptr >= stb.firstusym && off > stb.firstusym &&
1005 desc > stb.firstusym) {
1006 if (SCG(desc) != SC_DUMMY) {
1007 if (SCG(ptr) == SC_LOCAL) {
1008 push_lower_refd_list(ptr);
1009 push_lower_refd_list(off);
1010 push_lower_refd_list(desc);
1011 } else {
1012 push_lower_refd_list(desc);
1013 push_lower_refd_list(off);
1014 push_lower_refd_list(ptr);
1015 }
1016 }
1017 }
1018 }
1019 if (XBIT(47, 0x8000000)) {
1020 if (desc)
1021 ADDRTKNP(desc, 1);
1022 if (off)
1023 ADDRTKNP(off, 1);
1024 ADDRTKNP(ptr, 1);
1025 }
1026 if (!SAVEG(ptr) && SCG(ptr) != SC_CMBLK && SCG(ptr) != SC_STATIC &&
1027 SCG(ptr) != SC_DUMMY &&
1028 !(ALLOCATTRG(sptr) && SCG(SDSCG(sptr)) == SC_DUMMY)) {
1029 /* Also, we must be sure the pointer, offset,
1030 * and first descriptor word are initially zero;
1031 * keep a list of the symbols */
1032 if (ptr >= stb.firstusym) {
1033 LOWER_POINTER_LIST(sptr) = lower_pointer_list_head;
1034 lower_pointer_list_head = sptr;
1035 }
1036 }
1037 }
1038 break;
1039 case ST_DESCRIPTOR:
1040 fill_fixed_array_dtype(dtype);
1041 break;
1042 case ST_MEMBER:
1043 if (DTY(dtype) == TY_ARRAY && IFACEG(sptr) &&
1044 STYPEG(IFACEG(sptr)) == ST_PROC && ABSTRACTG(IFACEG(sptr))) {
1045 dtype = get_array_dtype(rank_of_sym(sptr), DTY(dtype + 1));
1046 DTYPEP(sptr, dtype);
1047 lower_use_datatype(dtype, 1);
1048 }
1049
1050 if (IGNOREG(sptr))
1051 break;
1052
1053 if (DTY(dtype) == TY_ARRAY) {
1054 if ((POINTERG(sptr) || ALLOCG(sptr)) && SDSCG(sptr) &&
1055 STYPEG(SDSCG(sptr)) != ST_PARAM) {
1056 fill_pointer_array_dtype(dtype, sptr);
1057 } else if (ADD_ADJARR(dtype) || ADD_DEFER(dtype)) {
1058 break;
1059 } else {
1060 /* fixed-size datatype */
1061 fill_fixed_array_dtype(dtype);
1062 }
1063 }
1064 break;
1065 case ST_CONST:
1066 break;
1067 case ST_ALIAS:
1068 /* if this is an alias for a function and the function
1069 * return value's name is not the same as the function name
1070 * then create an alias for the return value that has the
1071 * same name as the function.
1072 */
1073 link = SYMLKG(sptr);
1074 if (STYPEG(link) == ST_ENTRY) {
1075 fval = FVALG(link);
1076 if (fval && NMPTRG(fval) != NMPTRG(sptr)) {
1077 int retval_sptr = insert_sym(sptr);
1078 STYPEP(retval_sptr, ST_ALIAS);
1079 DTYPEP(retval_sptr, DTYPEG(fval));
1080 SCOPEP(retval_sptr, SCOPEG(fval));
1081 IGNOREP(retval_sptr, 0);
1082 SYMLKP(retval_sptr, fval);
1083 }
1084 }
1085 break;
1086 case ST_LABEL:
1087 if (!VOLG(sptr))
1088 RFCNTP(sptr, 0);
1089 break;
1090 case ST_PROC:
1091 case ST_ENTRY:
1092 fval = FVALG(sptr);
1093 if (fval) {
1094 CCSYMP(fval, 1);
1095 }
1096 default:
1097 break;
1098 }
1099 }
1100 first_temp = stb.stg_avail;
1101 first_avail_scalarptr_temp = first_used_scalarptr_temp = NOSYM;
1102 first_avail_scalar_temp = first_used_scalar_temp = NOSYM;
1103 } /* lower_prepare_symbols */
1104
1105 static void
lower_finish_symbols(void)1106 lower_finish_symbols(void)
1107 {
1108 int sptr, link;
1109 for (sptr = stb.firstusym; sptr < stb.stg_avail; ++sptr) {
1110 int dtype;
1111 if (IGNOREG(sptr))
1112 continue;
1113 switch (STYPEG(sptr)) {
1114 case ST_PARAM:
1115 if (CCSYMG(sptr))
1116 break;
1117 if (ENCLFUNCG(sptr) == 0 ||
1118 (ENCLFUNCG(sptr) == gbl.currsub && flg.debug)) {
1119 lower_visit_symbol(sptr);
1120 }
1121 break;
1122 case ST_TYPEDEF:
1123 /* if this is a typedef for the current routine, export it */
1124 if (ENCLFUNCG(sptr) == 0 || ENCLFUNCG(sptr) == gbl.currsub) {
1125 lower_visit_symbol(sptr);
1126 }
1127 /* if this is a type descriptor for mod object file, export it */
1128 else if (SDSCG(sptr) && CLASSG(SDSCG(sptr)) && !PARENTG(sptr)) {
1129 lower_visit_symbol(sptr);
1130 }
1131 break;
1132 case ST_ARRAY:
1133 case ST_VAR:
1134 case ST_IDENT:
1135 case ST_STRUCT:
1136 /* if debug, or if contains routines, put out all locals */
1137 if (HCCSYMG(sptr))
1138 break;
1139
1140 if (ENCLFUNCG(sptr) != 0 && !flg.debug)
1141 break;
1142 if (!flg.debug && !XBIT(57, 0x20) && gbl.internal != 1)
1143 break;
1144 if (LOWER_SYMBOL_REPLACE(sptr))
1145 break;
1146
1147 lower_visit_symbol(sptr);
1148 break;
1149 case ST_MODULE:
1150 lower_visit_symbol(sptr);
1151 break;
1152 case ST_PROC:
1153 /* if -x 124 0x1000, and this appeared in an EXTERNAL statement,
1154 * export it */
1155 if (XBIT(124, 0x1000)) {
1156 if (TYPDG(sptr)) {
1157 lower_visit_symbol(sptr);
1158 }
1159 }
1160 break;
1161 case ST_BLOCK:
1162 lower_visit_symbol(sptr);
1163 break;
1164 default:
1165 break;
1166 }
1167 }
1168 } /* lower_finish_symbols */
1169
1170 void
lower_pointer_init(void)1171 lower_pointer_init(void)
1172 {
1173 int sptr;
1174 for (sptr = lower_pointer_list_head; sptr > 0;
1175 sptr = LOWER_POINTER_LIST(sptr)) {
1176 int ptr, off, desc;
1177 int lilm, rilm;
1178 if (STYPEG(sptr) != ST_MEMBER &&
1179 (XBIT(47, 0x2000000) || !HCCSYMG(sptr))) {
1180 ptr = MIDNUMG(sptr);
1181 if (SCG(ptr) != SC_PRIVATE) {
1182 lilm = plower("oS", "BASE", ptr);
1183 if (XBIT(49, 0x100)) {
1184 /* 64-bit pointers */
1185 } else {
1186 }
1187 rilm = lower_null();
1188 if (!XBIT(49, 0x20000000)) {
1189 plower("oii", "PST", lilm, rilm);
1190 } else if (XBIT(49, 0x100)) {
1191 plower("oii", "KST", lilm, rilm);
1192 } else {
1193 plower("oii", "IST", lilm, rilm);
1194 }
1195 off = PTROFFG(sptr);
1196 if (off && STYPEG(off) != ST_PARAM && !ENCLFUNCG(off) &&
1197 XBIT(47, 0x2000000)) {
1198 lilm = plower("oS", "BASE", off);
1199 if (XBIT(49, 0x100)) {
1200 /* 64-bit pointers */
1201 rilm = plower("oS", "KCON", lowersym.intzero);
1202 } else {
1203 rilm = plower("oS", "ICON", lowersym.intzero);
1204 }
1205 if (XBIT(49, 0x100)) {
1206 plower("oii", "KST", lilm, rilm);
1207 } else {
1208 plower("oii", "IST", lilm, rilm);
1209 }
1210 }
1211 }
1212 }
1213 desc = SDSCG(sptr);
1214 if (desc && STYPEG(desc) != ST_PARAM && !ENCLFUNCG(desc) &&
1215 SCG(desc) != SC_DUMMY && SCG(desc) != SC_PRIVATE &&
1216 (XBIT(47, 0x2000000) || !HCCSYMG(sptr))) {
1217 lilm = plower("oS", "BASE", desc);
1218 rilm = plower("oS", lowersym.bnd.con, lowersym.bnd.one);
1219 lilm = plower("onidi", "ELEMENT", 1, lilm, DTYPEG(desc), rilm);
1220 rilm = plower("oS", "ICON", lowersym.intzero);
1221 if (XBIT(68, 1)) {
1222 plower("oii", "KST", lilm, rilm);
1223 } else {
1224 plower("oii", "IST", lilm, rilm);
1225 }
1226 }
1227 }
1228 } /* lower_pointer_init */
1229
1230 extern int pghpf_type_sptr;
1231 extern int pghpf_local_mode_sptr;
1232
1233 void
lower_init_sym(void)1234 lower_init_sym(void)
1235 {
1236 int sym, dtype;
1237 lowersym.sc = SC_LOCAL;
1238 lowersym.parallel_depth = 0;
1239 lowersym.task_depth = 0;
1240 lower_linearized_dtypes = FALSE;
1241 lower_make_all_descriptors();
1242 /* reassign member addresses to account for distributed derived
1243 * type members, late additions of section descriptors, pointers, etc. */
1244 for (dtype = 0; dtype < stb.dt.stg_avail; dtype += dlen(DTY(dtype))) {
1245 if (DTY(dtype) == TY_DERIVED) {
1246 chkstruct(dtype);
1247 }
1248 }
1249 /* allocate the table of datatypes */
1250 last_datatype_used = stb.dt.stg_avail;
1251 NEW(datatype_used, char, last_datatype_used);
1252 BZERO(datatype_used, char, last_datatype_used);
1253 NEW(datatype_output, char, last_datatype_used);
1254 BZERO(datatype_output, char, last_datatype_used);
1255 if (gbl.internal < 2) {
1256 lowersym.acount = 0;
1257 lowersym.Ccount = 0;
1258 }
1259 lowersym.ptr0 = lowersym.ptr0c = 0;
1260 lowersym.license = lowersym.localmode = 0;
1261 lowersym.intzero = lower_getintcon(0);
1262 lowersym.intone = lower_getintcon(1);
1263 lowersym.realzero = stb.flt0;
1264 lowersym.dblezero = stb.dbl0;
1265 lowersym.ptrnull = lower_getnull();
1266 if (XBIT(68, 0x1)) {
1267 lowersym.bnd.zero = stb.k0;
1268 lowersym.bnd.one = stb.k1;
1269 lowersym.bnd.max = lower_getiszcon(0x7fffffffffffffff);
1270 lowersym.bnd.dtype = DT_INT8;
1271 lowersym.bnd.load = "KLD";
1272 lowersym.bnd.store = "KST";
1273 lowersym.bnd.con = "KCON";
1274 lowersym.bnd.add = "KADD";
1275 lowersym.bnd.sub = "KSUB";
1276 lowersym.bnd.mul = "KMUL";
1277 lowersym.bnd.div = "KDIV";
1278 } else {
1279 lowersym.bnd.zero = stb.i0;
1280 lowersym.bnd.one = stb.i1;
1281 lowersym.bnd.max = lower_getintcon(0x7fffffff);
1282 lowersym.bnd.dtype = DT_INT;
1283 lowersym.bnd.load = "ILD";
1284 lowersym.bnd.store = "IST";
1285 lowersym.bnd.con = "ICON";
1286 lowersym.bnd.add = "IADD";
1287 lowersym.bnd.sub = "ISUB";
1288 lowersym.bnd.mul = "IMUL";
1289 lowersym.bnd.div = "IDIV";
1290 }
1291 lowersym.loc = lowersym.exit = lowersym.alloc = lowersym.alloc_chk =
1292 lowersym.ptr_alloc = lowersym.dealloc = lowersym.dealloc_mbr =
1293 lowersym.lmalloc = lowersym.lfree = lowersym.calloc =
1294 lowersym.ptr_calloc = lowersym.auto_alloc = lowersym.auto_calloc =
1295 lowersym.auto_dealloc = 0;
1296 if (XBIT(70, 2)) {
1297 /* add subchk subroutine */
1298 if (XBIT(68, 0x1))
1299 lowersym.sym_subchk =
1300 lower_makefunc(mkRteRtnNm(RTE_subchk64), DT_INT, TRUE);
1301 else
1302 lowersym.sym_subchk =
1303 lower_makefunc(mkRteRtnNm(RTE_subchk), DT_INT, TRUE);
1304 lowersym.intmax = lower_getintcon(0x7fffffff);
1305 }
1306 if (XBIT(70, 4)) {
1307 /* add ptrchk subroutine */
1308 lowersym.sym_ptrchk = lower_makefunc(mkRteRtnNm(RTE_ptrchk), DT_INT, TRUE);
1309 }
1310
1311 lowersym.oldsymavl = stb.stg_avail;
1312 lowersym.sched_dtype = 0;
1313 lowersym.scheds_dtype = 0;
1314
1315 STG_ALLOC_SIDECAR(stb, lsymlists);
1316 lower_pointer_list_head = -1;
1317 lower_refd_list_head = NOSYM;
1318 lower_prepare_symbols();
1319
1320 private_addr = 0;
1321 for (sym = lower_refd_list_head; sym > NOSYM; sym = LOWER_REFD_LIST(sym)) {
1322 if (SCG(sym) != SC_PRIVATE)
1323 sym_is_refd(sym);
1324 else {
1325 /* Assume the descriptor, pointer, and offset variables have the
1326 * same alignment requirements; therefore, don't bother with
1327 * explicitly aligning their offsets as sym_is_refd() does.
1328 * NOTE: Assigning offsets for these variables is performed
1329 * here instead of in sym_is_refd() since sym_is_refd()
1330 * ignores private variables (doesn't set their REF
1331 * bits). The backend will adjust the offsets per
1332 * the target's first private address.
1333 */
1334 ADDRESSP(sym, private_addr);
1335 private_addr += size_of(DTYPEG(sym));
1336 REFP(sym, 1);
1337 }
1338 }
1339
1340 /* any variables in locals or statics list need to be exported */
1341 for (sym = gbl.locals; sym > NOSYM; sym = SYMLKG(sym)) {
1342 lower_visit_symbol(sym);
1343 }
1344 for (sym = gbl.statics; sym > NOSYM; sym = SYMLKG(sym)) {
1345 lower_visit_symbol(sym);
1346 }
1347
1348 /* If this symbol is used in a contained subprogram but not in the
1349 * contained subprogram's host, then the symbol in the host will not
1350 * automatically be lowered.
1351 */
1352 if (pghpf_type_sptr)
1353 lower_visit_symbol(pghpf_type_sptr);
1354 if (pghpf_local_mode_sptr)
1355 lower_visit_symbol(pghpf_local_mode_sptr);
1356
1357 /* prepare stack for use */
1358 stack_top = 0;
1359 stack_size = 100;
1360 NEW(stack, int, stack_size);
1361
1362 /* look for ENTRY points; make all ENTRY points with the same
1363 * return type use the same FVAL symbol */
1364 if (gbl.rutype == RU_FUNC) {
1365 int ent, esame;
1366 for (ent = gbl.entries; ent > NOSYM; ent = SYMLKG(ent)) {
1367 for (esame = gbl.entries; esame != ent; esame = SYMLKG(esame)) {
1368 int fval, fvalsame;
1369 fval = FVALG(ent);
1370 fvalsame = FVALG(esame);
1371 if (fval && fvalsame && fval != fvalsame &&
1372 DTYPEG(fval) == DTYPEG(fvalsame)) {
1373 /* esame is the earlier entry point, make ent use the
1374 * FVAL of esame */
1375 LOWER_SYMBOL_REPLACE(fval) = fvalsame;
1376 FVALP(ent, fvalsame);
1377 break; /* leave inner loop */
1378 }
1379 }
1380 }
1381 }
1382
1383 /* if an internal routine, change the entry points of the containing
1384 * routine to ST_PROC */
1385 if (gbl.internal > 1) {
1386 for (sym = lowersym.first_outer_sym; sym < lowersym.last_outer_sym; ++sym) {
1387 if (STYPEG(sym) == ST_ENTRY) {
1388 STYPEP(sym, ST_PROC);
1389 }
1390 }
1391 }
1392 lower_argument_size = 100;
1393 NEW(lower_argument, int, lower_argument_size);
1394 BZERO(lower_argument, int, lower_argument_size);
1395 } /* lower_init_sym */
1396
1397 void
lower_finish_sym(void)1398 lower_finish_sym(void)
1399 {
1400 FREE(lower_argument);
1401 lower_argument = NULL;
1402 lower_argument_size = 0;
1403 FREE(stack);
1404 stack = NULL;
1405 STG_DELETE_SIDECAR(stb, lsymlists);
1406 FREE(datatype_output);
1407 datatype_output = NULL;
1408 FREE(datatype_used);
1409 datatype_used = NULL;
1410 } /* lower_finish_sym */
1411
1412 typedef struct initem {
1413 char *name, *cname, *filename;
1414 struct initem *next;
1415 long offset, objoffset;
1416 int level, which, staticbase, size;
1417 } INITEM;
1418
1419 static INITEM *inlist = NULL, *inlistend = NULL;
1420 #define PERM_AREA 8
1421 #define STASH(p) strcpy(getitem(PERM_AREA, strlen(p) + 1), p);
1422
1423 void
lower_add_func_call(int level,long objoffset,long offset,char * name,char * cname,char * filename,char which,int staticbase,int size)1424 lower_add_func_call(int level, long objoffset, long offset, char *name,
1425 char *cname, char *filename, char which, int staticbase,
1426 int size)
1427 {
1428 INITEM *p;
1429 p = (INITEM *)getitem(PERM_AREA, sizeof(INITEM));
1430 p->level = level;
1431 p->offset = offset;
1432 p->objoffset = objoffset;
1433 p->name = STASH(name);
1434 p->cname = STASH(cname);
1435 p->filename = STASH(filename);
1436 p->which = which;
1437 p->staticbase = staticbase;
1438 p->size = size;
1439 p->next = NULL;
1440 if (inlistend) {
1441 inlistend->next = p;
1442 } else {
1443 inlist = p;
1444 }
1445 inlistend = p;
1446 } /* lower_add_func_call */
1447
1448 static int saveblockname = 0;
1449
1450 void
create_static_base(int blockname)1451 create_static_base(int blockname)
1452 {
1453 saveblockname = blockname;
1454 } /* create_static_base */
1455
1456 static void
putvline(char * n,ISZ_T v)1457 putvline(char *n, ISZ_T v)
1458 {
1459 #if DEBUG
1460 if (DBGBIT(47, 31) || XBIT(50, 0x10)) {
1461 fprintf(lowersym.lowerfile, "%s:%" ISZ_PF "d\n", n, v);
1462 } else
1463 #endif
1464 fprintf(lowersym.lowerfile, "%c:%" ISZ_PF "d\n", n[0], v);
1465 } /* putvline */
1466
1467 static void
putbit(char * bitname,int bit)1468 putbit(char *bitname, int bit)
1469 {
1470 #if DEBUG
1471 if (DBGBIT(47, 31) || XBIT(50, 0x10)) {
1472 fprintf(lowersym.lowerfile, " %s%c", bitname, bit ? '+' : '-');
1473 } else
1474 #endif
1475 fprintf(lowersym.lowerfile, " %c%c", bitname[0], bit ? '+' : '-');
1476 } /* putbit */
1477
1478 static void
putsym(char * valname,int sym)1479 putsym(char *valname, int sym)
1480 {
1481 if (valname) {
1482 #if DEBUG
1483 if (DBGBIT(47, 31) || XBIT(50, 0x10)) {
1484 fprintf(lowersym.lowerfile, " %s:", valname);
1485 } else
1486 #endif
1487 fprintf(lowersym.lowerfile, " %c:", valname[0]);
1488 } else {
1489 fprintf(lowersym.lowerfile, " ");
1490 }
1491 #if DEBUG
1492 if (DBGBIT(47, 8) && sym > NOSYM) {
1493 fprintf(lowersym.lowerfile, "%s", getprint(sym));
1494 } else
1495 #endif
1496 fprintf(lowersym.lowerfile, "%d", sym);
1497 } /* putsym */
1498
1499 static void
putval(char * valname,ISZ_T val)1500 putval(char *valname, ISZ_T val)
1501 {
1502 #if DEBUG
1503 if (DBGBIT(47, 31) || XBIT(50, 0x10)) {
1504 fprintf(lowersym.lowerfile, " %s:%" ISZ_PF "d", valname, val);
1505 } else
1506 #endif
1507 fprintf(lowersym.lowerfile, " %c:%" ISZ_PF "d", valname[0], val);
1508 } /* putval */
1509
1510 static void
putival(char * valname,int val)1511 putival(char *valname, int val)
1512 {
1513 #if DEBUG
1514 if (DBGBIT(47, 31) || XBIT(50, 0x10)) {
1515 fprintf(lowersym.lowerfile, "%s:%d", valname, val);
1516 } else
1517 #endif
1518 fprintf(lowersym.lowerfile, "%c:%d", valname[0], val);
1519 } /* putival */
1520
1521 static void
putlval(char * valname,long val)1522 putlval(char *valname, long val)
1523 {
1524 #if DEBUG
1525 if (DBGBIT(47, 31) || XBIT(50, 0x10)) {
1526 fprintf(lowersym.lowerfile, " %s:%ld", valname, val);
1527 } else
1528 #endif
1529 fprintf(lowersym.lowerfile, " %c:%ld", valname[0], val);
1530 } /* putlval */
1531
1532 static void
putpair(int first,int second)1533 putpair(int first, int second)
1534 {
1535 #if DEBUG
1536 if (DBGBIT(47, 8)) {
1537 fprintf(lowersym.lowerfile, " %s", getprint(first));
1538 fprintf(lowersym.lowerfile, ":%s", getprint(second));
1539 } else
1540 #endif
1541 fprintf(lowersym.lowerfile, " %d:%d", first, second);
1542 } /* putpair */
1543
1544 static void
puthex(int hex)1545 puthex(int hex)
1546 {
1547 fprintf(lowersym.lowerfile, " %x", hex);
1548 } /* puthex */
1549
1550 static void
putstring(char * s)1551 putstring(char *s)
1552 {
1553 #if DEBUG
1554 if (DBGBIT(47, 31) || XBIT(50, 0x10)) {
1555 fprintf(lowersym.lowerfile, " %s", s);
1556 } else
1557 #endif
1558 fprintf(lowersym.lowerfile, " %c", s[0]);
1559 } /* putstring */
1560
1561 static void
putwhich(char * s,char * ss)1562 putwhich(char *s, char *ss)
1563 {
1564 #if DEBUG
1565 if (DBGBIT(47, 31) || XBIT(50, 0x10)) {
1566 fprintf(lowersym.lowerfile, " %s", s);
1567 } else
1568 #endif
1569 fprintf(lowersym.lowerfile, " %s", ss);
1570 } /* putwhich */
1571
1572 /** \brief Print file table information
1573 */
1574 void
lower_fileinfo(void)1575 lower_fileinfo(void)
1576 {
1577 int fihx;
1578 char *dirname, *filename, *funcname, *fullname;
1579
1580 fihx = curr_findex;
1581
1582 for (; fihx < fihb.stg_avail; ++fihx) {
1583 dirname = FIH_DIRNAME(fihx);
1584 if (dirname == NULL)
1585 dirname = "";
1586 filename = FIH_FILENAME(fihx);
1587 if (filename == NULL)
1588 filename = "";
1589 funcname = FIH_FUNCNAME(fihx);
1590 if (funcname == NULL)
1591 funcname = "";
1592 fullname = FIH_FULLNAME(fihx);
1593 if (fullname == NULL)
1594 fullname = "";
1595
1596 fprintf(lowersym.lowerfile,
1597 "fihx:%d tag:%d parent:%d flags:%d "
1598 "lineno:%d srcline:%d level:%d next:%d %" GBL_SIZE_T_FORMAT
1599 ":%s %" GBL_SIZE_T_FORMAT ":%s %" GBL_SIZE_T_FORMAT
1600 ":%s %" GBL_SIZE_T_FORMAT ":%s\n",
1601 fihx, FIH_FUNCTAG(fihx), FIH_PARENT(fihx), FIH_FLAGS(fihx),
1602 FIH_LINENO(fihx), FIH_SRCLINE(fihx), FIH_LEVEL(fihx),
1603 FIH_NEXT(fihx), strlen(dirname), dirname, strlen(filename),
1604 filename, strlen(funcname), funcname, strlen(fullname), fullname);
1605 }
1606
1607 lower_fileinfo_llvm();
1608 curr_findex = fihx;
1609
1610 } /* lower_fileinfo */
1611
1612 /* Note: If you make any change to this function, please also update
1613 stb_lower_sym_header ()
1614 */
1615 void
lower_sym_header(void)1616 lower_sym_header(void)
1617 {
1618 ISZ_T bss_addr;
1619 INITEM *p;
1620 static int first_time = 1;
1621 int i;
1622
1623 /* last chance to fix up symbols and datatypes */
1624 lower_finish_symbols();
1625
1626 if (first_time) {
1627 first_time = 0;
1628 /* put out any saved inlining information */
1629 for (p = inlist; p; p = p->next) {
1630 putival("inline", p->level);
1631 putlval("offset", p->offset);
1632 putval("which", p->which);
1633 fprintf(lowersym.lowerfile, " %" GBL_SIZE_T_FORMAT ":%s", strlen(p->name),
1634 p->name);
1635 fprintf(lowersym.lowerfile, " %" GBL_SIZE_T_FORMAT ":%s",
1636 strlen(p->cname), p->cname);
1637 fprintf(lowersym.lowerfile, " %" GBL_SIZE_T_FORMAT ":%s",
1638 strlen(p->filename), p->filename);
1639 putlval("objoffset", p->objoffset);
1640 putval("base", p->staticbase);
1641 putval("size", p->size);
1642 fprintf(lowersym.lowerfile, "\n");
1643 }
1644 fprintf(lowersym.lowerfile, "ENDINLINE\n");
1645 }
1646
1647 /* put out header lines */
1648 fprintf(lowersym.lowerfile, "TOILM version %d/%d\n", VersionMajor,
1649 VersionMinor);
1650 if (gbl.internal == 1 && gbl.empty_contains)
1651 putvline("Internal", 0);
1652 else
1653 putvline("Internal", gbl.internal);
1654 if (gbl.internal > 1) {
1655 putvline("Outer", lowersym.outersub);
1656 putvline("First", stb.firstusym);
1657 }
1658 putvline("Symbols", stb.stg_avail - 1);
1659 putvline("Datatypes", stb.dt.stg_avail - 1);
1660 bss_addr = get_bss_addr();
1661 putvline("BSS", bss_addr);
1662 putvline("GBL", gbl.saddr);
1663 putvline("LOC", gbl.locaddr);
1664 putvline("STATICS", gbl.statics);
1665 putvline("LOCALS", gbl.locals);
1666 putvline("PRIVATES", private_addr);
1667 if (saveblockname) {
1668 putvline("GNAME", saveblockname);
1669 }
1670
1671 stb_lower_sym_header();
1672 } /* lower_sym_header */
1673
1674 static void
set_common_size(int common)1675 set_common_size(int common)
1676 {
1677 int elsym, lastelsym;
1678 ISZ_T offset = 0;
1679 ISZ_T size = 0;
1680 int aln_n = 1;
1681 lastelsym = 0;
1682
1683 /* for equivalence symbols, save the difference between
1684 * their starting address and the starting address of
1685 * their first non-EQV 'soc' overlap symbol */
1686 for (elsym = CMEMFG(common); elsym > NOSYM; elsym = SYMLKG(elsym)) {
1687 if (EQVG(elsym) && SOCPTRG(elsym)) {
1688 int socptr;
1689 for (socptr = SOCPTRG(elsym); socptr; socptr = SOC_NEXT(socptr)) {
1690 int socsptr = SOC_SPTR(socptr);
1691 if (!EQVG(socsptr)) {
1692 /* compute difference with nonEQV symbol */
1693 ISZ_T diff = ADDRESSG(elsym) - ADDRESSG(socsptr);
1694 ADDRESSP(elsym, diff);
1695 break;
1696 }
1697 }
1698 }
1699 }
1700 for (elsym = CMEMFG(common); elsym > NOSYM; elsym = SYMLKG(elsym)) {
1701 int dtype;
1702 lastelsym = elsym;
1703 dtype = DTYPEG(elsym);
1704 if (STYPEG(elsym) == ST_IDENT || STYPEG(elsym) == ST_UNKNOWN) {
1705 switch (DTY(dtype)) {
1706 case TY_STRUCT:
1707 STYPEP(elsym, ST_STRUCT);
1708 break;
1709 case TY_UNION:
1710 STYPEP(elsym, ST_UNION);
1711 break;
1712 case TY_DERIVED:
1713 STYPEP(elsym, ST_VAR);
1714 break;
1715 case TY_ARRAY:
1716 STYPEP(elsym, ST_ARRAY);
1717 break;
1718 default:
1719 STYPEP(elsym, ST_VAR);
1720 break;
1721 }
1722 }
1723 REFP(elsym, 1);
1724 if (!EQVG(elsym)) {
1725 int addr;
1726 ISZ_T msz;
1727 addr = alignment_of_var(elsym);
1728 offset = ALIGN(offset, addr);
1729 ADDRESSP(elsym, offset);
1730 msz = size_of_var(elsym);
1731 msz = pad_cmn_mem(elsym, msz, &aln_n);
1732 offset += msz;
1733 if (offset > size) {
1734 size = offset;
1735 }
1736 }
1737 /* note: common may not be volatile but a member may */
1738 if (VOLG(common))
1739 VOLP(elsym, 1);
1740 }
1741 for (elsym = CMEMFG(common); elsym > NOSYM; elsym = SYMLKG(elsym)) {
1742 if (EQVG(elsym)) {
1743 ISZ_T end_of_eqv;
1744 int socptr;
1745 /* look at the first non-EQV overlap symbol, add difference of their
1746 * old addresses to the new address of the overlap symbol,
1747 * to be the new address of this symbol */
1748 for (socptr = SOCPTRG(elsym); socptr; socptr = SOC_NEXT(socptr)) {
1749 int socsptr = SOC_SPTR(socptr);
1750 if (!EQVG(socsptr)) {
1751 /* compute difference with nonEQV symbol */
1752 ISZ_T diff = ADDRESSG(elsym) + ADDRESSG(socsptr);
1753 ADDRESSP(elsym, diff);
1754 break;
1755 }
1756 }
1757 end_of_eqv = ADDRESSG(elsym) + size_of_var(elsym);
1758 if (end_of_eqv > size)
1759 size = end_of_eqv;
1760 }
1761 }
1762 if (size == 0) {
1763 /* zero-size common block, ugh, add a nonzero-size element */
1764 NEWSYM(elsym);
1765 DTYPEP(elsym, DT_INT);
1766 SCP(elsym, SC_CMBLK);
1767 STYPEP(elsym, ST_VAR);
1768 CCSYMP(elsym, 1);
1769 SCOPEP(elsym, stb.curr_scope);
1770 SYMLKP(elsym, NOSYM);
1771 if (INTERNALG(common))
1772 INTERNALP(elsym, 1);
1773 if (lastelsym) {
1774 SYMLKP(lastelsym, elsym);
1775 } else {
1776 CMEMFP(common, elsym);
1777 }
1778 CMEMLP(common, elsym);
1779 size = size_of(DT_INT);
1780 }
1781 SIZEP(common, size);
1782 } /* set_common_size */
1783
1784 /** \brief Mark all commons to be exported, and fill in sizes for
1785 compiler commons that are unfinished.
1786 */
1787 void
lower_common_sizes(void)1788 lower_common_sizes(void)
1789 {
1790 int sptr, s, inmod;
1791 for (sptr = gbl.cmblks; sptr != NOSYM; sptr = SYMLKG(sptr)) {
1792 /* set 'visit' bit for all commons and all members */
1793 VISITP(sptr, 1);
1794 DTYPEP(sptr, 0);
1795 inmod = SCOPEG(sptr);
1796 if (inmod && STYPEG(inmod) == ST_ALIAS)
1797 inmod = SCOPEG(inmod);
1798 if (inmod && STYPEG(inmod) == ST_MODULE)
1799 lower_visit_symbol(inmod);
1800 set_common_size(sptr);
1801 if (IGNOREG(sptr))
1802 continue;
1803 for (s = CMEMFG(sptr); s != NOSYM; s = SYMLKG(s)) {
1804 lower_visit_symbol(s);
1805 }
1806 /* propagate altnames of common blocks */
1807 if (ALTNAMEG(sptr))
1808 lower_visit_symbol(ALTNAMEG(sptr));
1809 }
1810 } /* lower_common_sizes */
1811
1812 static void
check_additional_common(int newcom)1813 check_additional_common(int newcom)
1814 {
1815 int oldcom;
1816 int hash, link;
1817 int s, lasts;
1818
1819 /* if no members, already done */
1820 if (CMEMFG(newcom) == 0)
1821 return;
1822
1823 /* get hash address of this name */
1824 HASH_ID(hash, SYMNAME(newcom), strlen(SYMNAME(newcom)));
1825
1826 /* look through all symbols on that hash list, look for another
1827 * common block of the same name with VISIT bit set */
1828 for (link = stb.hashtb[hash]; link; link = HASHLKG(link)) {
1829 if (link != newcom && NMPTRG(link) == NMPTRG(newcom) &&
1830 STYPEG(link) == ST_CMBLK && VISITG(link))
1831 break;
1832 }
1833
1834 if (link == 0) {
1835 /* there is no such common block; we must instead just treat
1836 * this common block as the only one of its name */
1837 VISITP(newcom, 1);
1838 lower_use_datatype(DTYPEG(newcom), 1);
1839 set_common_size(newcom);
1840 for (s = CMEMFG(newcom); s != NOSYM; s = SYMLKG(s)) {
1841 lower_visit_symbol(s);
1842 }
1843 return;
1844 }
1845
1846 /* here, link is a common with the same name.
1847 * fill in the address fields if necessary, then
1848 * set the 'equivalence' bit for the members and add them
1849 * to the original common block as equivalences.
1850 * Theoretically, this should work whether the new names and
1851 * types are the same as the original or not. */
1852
1853 set_common_size(newcom);
1854
1855 lasts = 0;
1856 for (s = CMEMFG(newcom); s != NOSYM; lasts = s, s = SYMLKG(s)) {
1857 lower_visit_symbol(s);
1858 EQVP(s, 1);
1859 CMBLKP(s, link);
1860 }
1861 /* last common member should point to new common list */
1862 SYMLKP(CMEMLG(link), CMEMFG(newcom));
1863 CMEMLP(link, lasts);
1864
1865 /* unset visit flag for the 'equivalenced' common */
1866 VISITP(newcom, 0);
1867 /* remove all member pointers */
1868 CMEMFP(newcom, 0);
1869 CMEMLP(newcom, 0);
1870 } /* check_additional_common */
1871
1872 /* determine whether to make this function return value variable
1873 * a local or a dummy */
1874 static int
makefvallocal(int rutype,int fval)1875 makefvallocal(int rutype, int fval)
1876 {
1877 int dtype;
1878 /* if this was turned into a subroutine, make the fval a dummy */
1879 if (rutype != RU_FUNC)
1880 return 0;
1881 /* if the fval is a POINTER variable, make local */
1882 if (POINTERG(fval))
1883 return 1;
1884 dtype = DTYPEG(fval);
1885 /* if the datatype is a structure, derived type, make a dummy */
1886 if ((DTY(dtype) == TY_STRUCT || DTY(dtype) == TY_DERIVED))
1887 return 0;
1888 /* if the datatype is character, make a dummy */
1889 if (DTY(dtype) == TY_CHAR || DTY(dtype) == TY_NCHAR)
1890 return 0;
1891 /* if the datatype is complex, make a dummy */
1892 if (DTY(dtype) == TY_CMPLX || DTY(dtype) == TY_DCMPLX ||
1893 DTY(dtype) == TY_QCMPLX) {
1894 return 0;
1895 }
1896 /* else, make local */
1897 return 1;
1898 } /* makefvallocal */
1899
1900 void
lower_visit_symbol(int sptr)1901 lower_visit_symbol(int sptr)
1902 {
1903 int socptr, dtype, params, i, fval, inmod, stype, parsyms;
1904 if (LOWER_SYMBOL_REPLACE(sptr)) {
1905 lower_visit_symbol(LOWER_SYMBOL_REPLACE(sptr));
1906 lerror("visit symbol %s(%d) which was replaced by %s(%d)", SYMNAME(sptr),
1907 sptr, SYMNAME(LOWER_SYMBOL_REPLACE(sptr)),
1908 LOWER_SYMBOL_REPLACE(sptr));
1909 return;
1910 }
1911 if (VISITG(sptr))
1912 return;
1913
1914 if ((STYPEG(sptr) == ST_ALIAS || STYPEG(sptr) == ST_PROC ||
1915 STYPEG(sptr) == ST_ENTRY) &&
1916 SEPARATEMPG(sptr) &&
1917 STYPEG(SCOPEG(sptr)) == ST_MODULE)
1918 INMODULEP(sptr, 1);
1919
1920 VISITP(sptr, 1);
1921 dtype = DTYPEG(sptr);
1922 stype = STYPEG(sptr);
1923 if (stype == ST_PROC || stype == ST_ENTRY) {
1924 if (DTY(dtype) == TY_ARRAY) {
1925 dtype = DTY(dtype + 1);
1926 }
1927 }
1928 if (lower_linearized_dtypes || DTY(dtype) != TY_ARRAY || !XBIT(52, 4) ||
1929 !LNRZDG(sptr)) {
1930 /* linearized array data types are 'used' later */
1931 lower_use_datatype(dtype, 1);
1932 }
1933 switch (stype) {
1934 case ST_IDENT:
1935 case ST_UNKNOWN:
1936 if (dtype) {
1937 switch (DTY(dtype)) {
1938 case TY_STRUCT:
1939 STYPEP(sptr, ST_STRUCT);
1940 break;
1941 case TY_UNION:
1942 STYPEP(sptr, ST_UNION);
1943 break;
1944 case TY_DERIVED:
1945 STYPEP(sptr, ST_VAR);
1946 break;
1947 case TY_ARRAY:
1948 STYPEP(sptr, ST_ARRAY);
1949 break;
1950 default:
1951 STYPEP(sptr, ST_VAR);
1952 break;
1953 }
1954 }
1955 if (SCG(sptr) == SC_NONE) {
1956 SCP(sptr, SC_LOCAL);
1957 }
1958 default:
1959 break;
1960 }
1961
1962 switch (STYPEG(sptr)) {
1963 case ST_ARRAY:
1964 case ST_DESCRIPTOR:
1965 case ST_VAR:
1966 case ST_STRUCT:
1967 case ST_UNION:
1968 if (SCG(sptr) == SC_CMBLK) {
1969 /* mark the whole common block as visited */
1970 int common;
1971 common = CMBLKG(sptr);
1972 if (VISITG(common) == 0)
1973 lower_visit_symbol(common);
1974 }
1975 /* does it overlap with anything (equivalence overlaps?) */
1976 for (socptr = SOCPTRG(sptr); socptr; socptr = SOC_NEXT(socptr)) {
1977 int overlap;
1978 overlap = SOC_SPTR(socptr);
1979 lower_visit_symbol(overlap);
1980 }
1981 if (MIDNUMG(sptr))
1982 lower_visit_symbol(MIDNUMG(sptr));
1983 if (PTROFFG(sptr))
1984 lower_visit_symbol(PTROFFG(sptr));
1985 if (SDSCG(sptr))
1986 lower_visit_symbol(SDSCG(sptr));
1987 if (CVLENG(sptr))
1988 lower_visit_symbol(CVLENG(sptr));
1989 if (ALTNAMEG(sptr))
1990 lower_visit_symbol(ALTNAMEG(sptr));
1991 break;
1992 case ST_IDENT:
1993 /* not classified as ID or anything else as yet */
1994 if (SCG(sptr) == SC_CMBLK) {
1995 /* mark the whole common block as visited */
1996 int common;
1997 common = CMBLKG(sptr);
1998 if (VISITG(common) == 0)
1999 lower_visit_symbol(common);
2000 }
2001 if (MIDNUMG(sptr))
2002 lower_visit_symbol(MIDNUMG(sptr));
2003 break;
2004 case ST_ENTRY:
2005 fval = FVALG(sptr);
2006 if (fval) {
2007 lower_visit_symbol(FVALG(sptr));
2008 /* semant marks class of function return value temp as DUMMY so it
2009 * won't be deleted by the optimizer; pgftn wants it to be LOCAL;
2010 * if this is a real subroutine, it was converted from a function,
2011 * so leave it as dummy */
2012 if (SCG(fval) == SC_BASED) {
2013 /* ADDRESS field was used to hold symtab pointers
2014 * for optimizer */
2015 ADDRESSP(fval, 0);
2016 } else {
2017 if (makefvallocal(gbl.rutype, fval)) {
2018 SCP(fval, SC_LOCAL);
2019 if (is_iso_cptr(DTYPEG(fval))) {
2020 DTYPEP(fval, DT_CPTR);
2021 }
2022 } else {
2023 SCP(fval, SC_DUMMY);
2024 }
2025 }
2026 }
2027 params = DPDSCG(sptr);
2028 for (i = 0; i < (int)(PARAMCTG(sptr)); ++i) {
2029 int param = aux.dpdsc_base[params + i];
2030 if (param) {
2031 lower_visit_symbol(param);
2032 }
2033 }
2034 inmod = SCOPEG(sptr);
2035 if (inmod && STYPEG(inmod) == ST_ALIAS) {
2036 inmod = SCOPEG(inmod);
2037 }
2038 if (inmod && STYPEG(inmod) == ST_MODULE) {
2039 lower_visit_symbol(inmod);
2040 }
2041 if (ALTNAMEG(sptr))
2042 lower_visit_symbol(ALTNAMEG(sptr));
2043 break;
2044 case ST_PROC:
2045 inmod = SCOPEG(sptr);
2046 if (inmod && STYPEG(inmod) == ST_ALIAS)
2047 inmod = SCOPEG(inmod);
2048 if (inmod && STYPEG(inmod) == ST_MODULE)
2049 lower_visit_symbol(inmod);
2050 if (ALTNAMEG(sptr))
2051 lower_visit_symbol(ALTNAMEG(sptr));
2052 if (SCG(sptr) == SC_NONE ||
2053 (SCG(sptr) == SC_EXTERN && VISITG(sptr) &&
2054 (inmod || INMODULEG(sptr) ||
2055 (TYPDG(sptr) && DCLDG(sptr)) /* interface */))) {
2056 fval = FVALG(sptr);
2057 if (fval) {
2058 lower_visit_symbol(FVALG(sptr));
2059 if (SCG(fval) == SC_BASED) {
2060 ADDRESSP(fval, 0);
2061 } else {
2062 SCP(fval, SC_DUMMY);
2063 }
2064 }
2065 params = DPDSCG(sptr);
2066 for (i = 0; i < (int)(PARAMCTG(sptr)); ++i) {
2067 int param = aux.dpdsc_base[params + i];
2068 if (param) {
2069 lower_visit_symbol(param);
2070 }
2071 }
2072 }
2073 break;
2074 case ST_CONST:
2075 switch (DTY(DTYPEG(sptr))) {
2076 case TY_PTR:
2077 if (CONVAL1G(sptr))
2078 lower_visit_symbol(CONVAL1G(sptr));
2079 break;
2080 case TY_DCMPLX:
2081 case TY_QCMPLX:
2082 lower_visit_symbol(CONVAL1G(sptr));
2083 lower_visit_symbol(CONVAL2G(sptr));
2084 break;
2085 case TY_HOLL:
2086 /* symbol table ptr of char constant */
2087 lower_use_datatype(DTYPEG(CONVAL1G(sptr)), 1);
2088 break;
2089 }
2090 break;
2091 case ST_CMBLK:
2092 /* since all common blocks are visited by lower_common_sizes,
2093 * this should only be reached when there is another common block
2094 * of the same name, such as for inlined routines, interface blocks,
2095 * or the like. In any case, add this common also, making sure
2096 * it has a size and so on */
2097 check_additional_common(sptr);
2098 if (ALTNAMEG(sptr))
2099 lower_visit_symbol(ALTNAMEG(sptr));
2100 break;
2101 case ST_PARAM:
2102 if (!TY_ISWORD(DTY(DTYPEG(sptr)))) {
2103 lower_visit_symbol(CONVAL1G(sptr));
2104 }
2105 break;
2106 case ST_BLOCK:
2107 if (STARTLABG(sptr))
2108 lower_visit_symbol(STARTLABG(sptr));
2109 if (ENDLABG(sptr))
2110 lower_visit_symbol(ENDLABG(sptr));
2111 if (PARUPLEVELG(sptr))
2112 lower_visit_symbol(PARUPLEVELG(sptr));
2113 break;
2114 default:
2115 break;
2116 }
2117
2118 if (SCG(sptr) == SC_DUMMY) {
2119 int origdummy;
2120 origdummy = NEWARGG(sptr);
2121 if (origdummy) {
2122 lower_visit_symbol(origdummy);
2123 }
2124 }
2125 } /* lower_visit_symbol */
2126
2127 /*
2128 * return FALSE if this symbol is from a module that was implicitly 'used'
2129 */
2130 static LOGICAL
notimplicit(int sptr)2131 notimplicit(int sptr)
2132 {
2133 int s;
2134 s = SCOPEG(sptr);
2135 if (!s)
2136 return TRUE;
2137 if (STYPEG(s) != ST_MODULE)
2138 return TRUE;
2139 if (strcmp(SYMNAME(s), "cudadevice") == 0)
2140 return FALSE;
2141 if (strcmp(SYMNAME(s), "cudafor") == 0)
2142 return FALSE;
2143 if (strcmp(SYMNAME(s), "cudafor_la") == 0)
2144 return FALSE;
2145 return TRUE;
2146 } /* notimplicit */
2147
2148 void
lower_check_generics(void)2149 lower_check_generics(void)
2150 {
2151 int sptr;
2152 for (sptr = stb.firstosym; sptr < stb.stg_avail; ++sptr) {
2153 if (STYPEG(sptr) == ST_USERGENERIC) {
2154 int desc;
2155 if (XBIT(57, 0x20) && notimplicit(sptr)) {
2156 VISITP(sptr, 1);
2157 lower_use_datatype(DTYPEG(sptr), 1);
2158 for (desc = GNDSCG(sptr); desc; desc = SYMI_NEXT(desc)) {
2159 int s = SYMI_SPTR(desc);
2160 if (STYPEG(s) != ST_MODPROC) {
2161 lower_visit_symbol(s);
2162 }
2163 }
2164 } else {
2165 VISITP(sptr, 0);
2166 /* look for any actuals that were used */
2167 for (desc = GNDSCG(sptr); desc; desc = SYMI_NEXT(desc)) {
2168 int s = SYMI_SPTR(desc);
2169 if (s && CLASSG(sptr)) {
2170 VISITP(s, 1);
2171 }
2172 if (VISITG(s)) {
2173 VISITP(sptr, 1);
2174 lower_use_datatype(DTYPEG(sptr), 1);
2175 break;
2176 }
2177 }
2178 }
2179 }
2180 }
2181 } /* lower_check_generics */
2182
2183 /** \brief For contained subprograms, mark all the regular symbols
2184 of the host subprogram
2185 */
2186 void
lower_outer_symbols(void)2187 lower_outer_symbols(void)
2188 {
2189 int sptr;
2190 for (sptr = lowersym.first_outer_sym; sptr < lowersym.last_outer_sym;
2191 ++sptr) {
2192 switch (STYPEG(sptr)) {
2193 case ST_ARRAY:
2194 case ST_DESCRIPTOR:
2195 case ST_VAR:
2196 case ST_UNION:
2197 case ST_STRUCT:
2198 case ST_PLIST:
2199 if (!IGNOREG(sptr) &&
2200 (LOWER_SYMBOL_REPLACE(sptr) == 0))
2201 lower_visit_symbol(sptr);
2202 break;
2203 default:
2204 break;
2205 }
2206 }
2207 } /* lower_outer_symbols */
2208
2209 void
lower_use_datatype(int dtype,int usage)2210 lower_use_datatype(int dtype, int usage)
2211 {
2212 int ndim, i, sptr, zbase, numelm;
2213 if (dtype <= 0)
2214 return;
2215 if (dtype < last_datatype_used) {
2216 if (datatype_used[dtype]) {
2217 datatype_used[dtype] |= usage;
2218 return;
2219 }
2220 datatype_used[dtype] = usage;
2221 }
2222
2223 switch (DTY(dtype)) {
2224 case TY_PTR:
2225 if (dtype != DT_ADDR) {
2226 /* pointer datatype internal to lower */
2227 lower_use_datatype(DTY(dtype + 1), 1);
2228 } else {
2229 datatype_used[dtype] = 0;
2230 if (XBIT(49, 0x100)) { /* 64-bit pointers */
2231 lower_use_datatype(DT_INT8, 1);
2232 } else {
2233 lower_use_datatype(DT_INT, 1);
2234 }
2235 }
2236 break;
2237 case TY_ARRAY:
2238 lower_use_datatype(DTY(dtype + 1), 1);
2239 ndim = ADD_NUMDIM(dtype);
2240 for (i = 0; i < ndim; ++i) {
2241 int lb, ub, mpy;
2242 lb = ADD_LWAST(dtype, i);
2243 ub = ADD_UPAST(dtype, i);
2244 if (lb == 0) {
2245 lb = lowersym.intone;
2246 } else if (A_TYPEG(lb) == A_ID || A_TYPEG(lb) == A_CNST) {
2247 lb = A_SPTRG(lb);
2248 } else {
2249 lb = lowersym.intone;
2250 }
2251 lower_visit_symbol(lb);
2252 if (ub != 0) {
2253 if (A_TYPEG(ub) == A_ID || A_TYPEG(ub) == A_CNST) {
2254 ub = A_SPTRG(ub);
2255 lower_visit_symbol(ub);
2256 } else {
2257 ub = 0;
2258 }
2259 }
2260 if (ADD_DEFER(dtype)) {
2261 lb = ADD_LWBD(dtype, i);
2262 ub = ADD_UPBD(dtype, i);
2263 if (lb != 0) {
2264 if (A_TYPEG(lb) == A_ID || A_TYPEG(lb) == A_CNST) {
2265 lb = A_SPTRG(lb);
2266 lower_visit_symbol(lb);
2267 }
2268 }
2269 if (ub != 0) {
2270 if (A_TYPEG(ub) == A_ID || A_TYPEG(ub) == A_CNST) {
2271 ub = A_SPTRG(ub);
2272 lower_visit_symbol(ub);
2273 }
2274 }
2275 }
2276 mpy = ADD_MLPYR(dtype, i);
2277 if (mpy != 0) {
2278 if (A_TYPEG(mpy) == A_ID || A_TYPEG(mpy) == A_CNST) {
2279 mpy = A_SPTRG(mpy);
2280 lower_visit_symbol(mpy);
2281 }
2282 }
2283 }
2284 zbase = ADD_ZBASE(dtype);
2285 if (zbase == 0) {
2286 zbase = 0;
2287 } else {
2288 if (A_TYPEG(zbase) == A_ID || A_TYPEG(zbase) == A_CNST) {
2289 zbase = A_SPTRG(zbase);
2290 lower_visit_symbol(zbase);
2291 }
2292 }
2293 numelm = ADD_NUMELM(dtype);
2294 if (numelm != 0) {
2295 if (A_TYPEG(numelm) == A_ID || A_TYPEG(numelm) == A_CNST) {
2296 numelm = A_SPTRG(numelm);
2297 lower_visit_symbol(numelm);
2298 }
2299 }
2300 break;
2301 case TY_STRUCT:
2302 case TY_UNION:
2303 case TY_DERIVED:
2304 /* mark all members */
2305 for (sptr = DTY(dtype + 1); sptr > NOSYM; sptr = SYMLKG(sptr)) {
2306 lower_visit_symbol(sptr);
2307 }
2308 /* mark tag (structure name) */
2309 if (DTY(dtype + 3))
2310 lower_visit_symbol(DTY(dtype + 3));
2311 break;
2312 case TY_PROC: {
2313 int restype = DTY(dtype + 1);
2314 if (is_array_dtype(restype)) {
2315 /* array result types must be lowered later to avoid
2316 * lowering errors, but don't neglect the element type
2317 */
2318 restype = array_element_dtype(restype);
2319 }
2320 if (restype > 0)
2321 lower_use_datatype(restype, 1);
2322 }
2323 if (gbl.stbfil && DTY(dtype + 2)) {
2324 int iface = DTY(dtype + 2);
2325 int fval = DTY(dtype + 5);
2326 int params = DPDSCG(iface);
2327 if (STYPEG(iface) == ST_ALIAS) {
2328 iface = SYMLKG(iface);
2329 fval = FVALG(iface);
2330 params = DPDSCG(iface);
2331 }
2332 if (STYPEG(iface) == ST_MODPROC) {
2333 if (SCOPEG(iface) == gbl.currsub || ENCLFUNCG(iface) == gbl.currsub)
2334 break;
2335 if (ENCLFUNCG(iface) == ENCLFUNCG(gbl.currsub))
2336 break;
2337 }
2338 llvm_iface_flag = TRUE;
2339 lower_visit_symbol(iface);
2340 for (i = 0; i < (int)(PARAMCTG(iface)); ++i) {
2341 int param = aux.dpdsc_base[params + i];
2342 if (param) {
2343 lower_visit_symbol(param);
2344 }
2345 }
2346 if (fval)
2347 lower_visit_symbol(fval);
2348 llvm_iface_flag = FALSE;
2349 }
2350
2351 break;
2352 }
2353 } /* lower_use_datatype */
2354
2355 /* Return TRUE if this dtype was not already marked used */
2356 static int
lower_unused_datatype(int dtype)2357 lower_unused_datatype(int dtype)
2358 {
2359 if (dtype <= 0)
2360 return 1;
2361 if (dtype >= last_datatype_used)
2362 return 0;
2363 if (datatype_used[dtype])
2364 return 0;
2365 return 1;
2366 } /* lower_unused_datatype */
2367
2368 static int
eval_con_expr(int ast,int * val,int * dtyp)2369 eval_con_expr(int ast, int *val, int *dtyp)
2370 {
2371 int val1;
2372 int val2;
2373 int tmp_ast1;
2374 int tmp_ast2;
2375 int sptr;
2376 int success = 0;
2377
2378 if (!ast)
2379 return 0;
2380
2381 if (A_ALIASG(ast)) {
2382 *dtyp = A_DTYPEG(ast);
2383 ast = A_ALIASG(ast);
2384 }
2385
2386 switch (A_TYPEG(ast)) {
2387 case A_CNST:
2388 *dtyp = A_DTYPEG(ast);
2389 *val = CONVAL2G(A_SPTRG(ast));
2390 success = 1;
2391 break;
2392 case A_UNOP:
2393 if (eval_con_expr(A_LOPG(ast), &val1, dtyp)) {
2394 if (A_OPTYPEG(ast) == OP_SUB)
2395 *val = negate_const(val1, A_DTYPEG(ast));
2396 if (A_OPTYPEG(ast) == OP_LNOT)
2397 *val = ~val1;
2398 *dtyp = A_DTYPEG(ast);
2399 success = 1;
2400 }
2401 break;
2402 case A_BINOP:
2403 if (eval_con_expr(A_LOPG(ast), &val1, dtyp) &&
2404 eval_con_expr(A_ROPG(ast), &val2, dtyp)) {
2405 *val = const_fold(A_OPTYPEG(ast), val1, val2, A_DTYPEG(ast));
2406 *dtyp = A_DTYPEG(ast);
2407 success = 1;
2408 }
2409 break;
2410 case A_SUBSCR:
2411 case A_MEM:
2412 tmp_ast1 = complex_alias(ast);
2413 if (eval_con_expr(tmp_ast1, &val1, dtyp)) {
2414 *val = val1;
2415 success = 1;
2416 }
2417 break;
2418 }
2419
2420 return success;
2421 }
2422
2423 static void
lower_put_datatype(int dtype,int usage)2424 lower_put_datatype(int dtype, int usage)
2425 {
2426 int ndim, i, zbase, numelm;
2427 int dty, iface;
2428 /* if this was a 'stashed' old datatype */
2429 if (DTY(dtype) < 0)
2430 return;
2431 if (dtype < last_datatype_used) {
2432 if (datatype_output[dtype] > 1)
2433 return;
2434 else if (datatype_output[dtype] == 1) {
2435 if (!IS_STB_FILE())
2436 return;
2437 }
2438 datatype_output[dtype]++;
2439 }
2440 /* first character disambiguates:
2441 * a - any
2442 * A - array
2443 * c - character
2444 * C - complex
2445 * D - derived type
2446 * H - Hollerith
2447 * I - Integer
2448 * L - Logical
2449 * n - ncharacter
2450 * N - none
2451 * P - pointer
2452 * R - real
2453 * S - struct
2454 * U - union
2455 * W - word
2456 * Z - numeric
2457 */
2458
2459 if (DTY(dtype) == TY_ARRAY) {
2460 /* FS#19796: Make sure we lower the element type of array.
2461 * Otherwise, we might miss lowering dtypes for element indices
2462 * such as DT_INT8 if the array has a DT_INT8 array size or if
2463 * the user compiles with -i8.
2464 */
2465 ndim = ADD_NUMDIM(dtype);
2466 for (i = 0; i < ndim; ++i) {
2467 int lb, ub, extnt, mpy;
2468 lb = ADD_LWAST(dtype, i);
2469 ub = ADD_UPAST(dtype, i);
2470 extnt = ADD_EXTNTAST(dtype, i);
2471
2472 if (A_TYPEG(lb) == A_INTR) {
2473 switch (A_OPTYPEG(lb)) {
2474 case I_INT1:
2475 case I_INT2:
2476 case I_INT4:
2477 case I_INT8:
2478 case I_INT:
2479 lb = A_ARGSG(lb);
2480 lb = ARGT_ARG(lb, 0);
2481 dty = A_DTYPEG(ub);
2482 lower_put_datatype(dty, datatype_used[dty]);
2483 }
2484 }
2485 if (A_TYPEG(ub) == A_INTR) {
2486 switch (A_OPTYPEG(ub)) {
2487 case I_INT1:
2488 case I_INT2:
2489 case I_INT4:
2490 case I_INT8:
2491 case I_INT:
2492 ub = A_ARGSG(ub);
2493 ub = ARGT_ARG(ub, 0);
2494 dty = A_DTYPEG(ub);
2495 lower_put_datatype(dty, datatype_used[dty]);
2496 }
2497 }
2498 if (A_TYPEG(extnt) == A_INTR) {
2499 switch (A_OPTYPEG(extnt)) {
2500 case I_INT1:
2501 case I_INT2:
2502 case I_INT4:
2503 case I_INT8:
2504 case I_INT:
2505 extnt = A_ARGSG(extnt);
2506 extnt = ARGT_ARG(extnt, 0);
2507 dty = A_DTYPEG(extnt);
2508 lower_put_datatype(dty, datatype_used[dty]);
2509 }
2510 }
2511 }
2512 }
2513
2514 putival("datatype", dtype);
2515
2516 switch (DTY(dtype)) {
2517 case TY_NONE:
2518 putwhich("none", "n");
2519 break;
2520 case TY_WORD:
2521 putwhich("Word4", "W4");
2522 break;
2523 case TY_DWORD:
2524 putwhich("Word8", "W8");
2525 break;
2526 case TY_HOLL:
2527 putwhich("Hollerith", "H");
2528 break;
2529
2530 case TY_BINT:
2531 putwhich("Integer1", "I1");
2532 break;
2533 case TY_SINT:
2534 putwhich("Integer2", "I2");
2535 break;
2536 case TY_INT:
2537 putwhich("Integer4", "I4");
2538 break;
2539 case TY_INT8:
2540 putwhich("Integer8", "I8");
2541 break;
2542
2543 case TY_HALF:
2544 putwhich("Real2", "R2");
2545 break;
2546 case TY_REAL:
2547 putwhich("Real4", "R4");
2548 break;
2549 case TY_DBLE:
2550 putwhich("Real8", "R8");
2551 break;
2552 case TY_QUAD:
2553 putwhich("Real16", "R16");
2554 break;
2555
2556 case TY_HCMPLX:
2557 putwhich("Complex4", "C4");
2558 break;
2559 case TY_CMPLX:
2560 putwhich("Complex8", "C8");
2561 break;
2562 case TY_DCMPLX:
2563 putwhich("Complex16", "C16");
2564 break;
2565 case TY_QCMPLX:
2566 putwhich("Complex16", "C16");
2567 break;
2568
2569 case TY_BLOG:
2570 putwhich("Logical1", "L1");
2571 break;
2572 case TY_SLOG:
2573 putwhich("Logical2", "L2");
2574 break;
2575 case TY_LOG:
2576 putwhich("Logical4", "L4");
2577 break;
2578 case TY_LOG8:
2579 putwhich("Logical8", "L8");
2580 break;
2581
2582 case TY_CHAR:
2583 putwhich("character", "c");
2584 if (dtype == DT_ASSCHAR) {
2585 putval("len", ASSCHAR);
2586 } else if (dtype == DT_DEFERCHAR) {
2587 putval("len", DEFERCHAR);
2588 } else {
2589 int clen = DTY(dtype + 1);
2590 if (A_ALIASG(clen)) {
2591 clen = A_ALIASG(clen);
2592 clen = A_SPTRG(clen);
2593 clen = CONVAL2G(clen);
2594 putval("len", clen);
2595 } else {
2596 if (sem.gcvlen && is_deferlenchar_dtype(dtype)) {
2597 putval("len", DEFERCHAR);
2598 } else {
2599 putval("len", ADJCHAR);
2600 }
2601 }
2602 }
2603 break;
2604 case TY_NCHAR:
2605 putwhich("kcharacter", "k");
2606 if (dtype == DT_ASSNCHAR) {
2607 putval("len", ASSCHAR);
2608 } else if (dtype == DT_DEFERNCHAR) {
2609 putval("len", DEFERCHAR);
2610 } else {
2611 int clen = DTY(dtype + 1);
2612 if (A_ALIASG(clen)) {
2613 clen = A_ALIASG(clen);
2614 clen = A_SPTRG(clen);
2615 clen = CONVAL2G(clen);
2616 putval("len", clen);
2617 } else {
2618 putval("len", ASSCHAR);
2619 }
2620 }
2621 break;
2622
2623 case TY_PTR:
2624 putwhich("Pointer", "P");
2625 putval("ptrto", DTY(dtype + 1));
2626 break;
2627
2628 case TY_STRUCT:
2629 putwhich("Struct", "S");
2630 goto SUD;
2631 case TY_UNION:
2632 putwhich("Union", "U");
2633 goto SUD;
2634 case TY_DERIVED:
2635 putwhich("Derived", "D");
2636 SUD:
2637 /* first member (symbol), size (bytes), alignment (0/1/3/7) */
2638 putsym("member", DTY(dtype + 1));
2639 putval("size", DTY(dtype + 2));
2640 putsym("tag", DTY(dtype + 3));
2641 putval("align", DTY(dtype + 4));
2642 break;
2643
2644 case TY_NUMERIC:
2645 putwhich("Numeric", "N");
2646 break;
2647 case TY_ANY:
2648 putwhich("any", "a");
2649 break;
2650
2651 case TY_PROC: {
2652 int restype = DTY(dtype + 1);
2653 if (is_array_dtype(restype))
2654 restype = array_element_dtype(restype);
2655 }
2656 putwhich("proc", "p");
2657 putval("result", DTY(dtype + 1));
2658 iface = DTY(dtype + 2);
2659 if (iface) {
2660 /* Based revision 68096 - need to lower its symlink instead if it is
2661 * ST_ALIAS */
2662 if (STYPEG(iface) == ST_ALIAS) {
2663 putsym("iface", SYMLKG(iface));
2664 } else
2665 putsym("iface", iface);
2666
2667 } else
2668 putsym("iface", iface);
2669 putval("paramct", DTY(dtype + 3));
2670 putval("dpdsc", DTY(dtype + 4));
2671 putval("fval", DTY(dtype + 5));
2672 if (gbl.stbfil && DTY(dtype + 2)) {
2673 int fval = DTY(dtype + 5);
2674 int params = DPDSCG(iface);
2675 if (STYPEG(iface) == ST_ALIAS) {
2676 iface = SYMLKG(iface);
2677 fval = FVALG(iface);
2678 params = DPDSCG(iface);
2679 }
2680 if (STYPEG(iface) == ST_MODPROC) {
2681 if (SCOPEG(iface) == gbl.currsub || ENCLFUNCG(iface) == gbl.currsub)
2682 break;
2683 if (ENCLFUNCG(iface) == ENCLFUNCG(gbl.currsub))
2684 break;
2685 }
2686 llvm_iface_flag = TRUE;
2687 lower_visit_symbol(iface);
2688 for (i = 0; i < (int)(PARAMCTG(iface)); ++i) {
2689 int param = aux.dpdsc_base[params + i];
2690 if (param) {
2691 lower_visit_symbol(param);
2692 }
2693 }
2694 if (fval)
2695 lower_visit_symbol(fval);
2696 llvm_iface_flag = FALSE;
2697 }
2698 break;
2699
2700 case TY_ARRAY:
2701 ndim = ADD_NUMDIM(dtype);
2702 putwhich("Array", "A");
2703 putval("type", DTY(dtype + 1));
2704 putval("dims", ndim);
2705 for (i = 0; i < ndim; ++i) {
2706 int lb, ub, extnt, mpy;
2707 lb = ADD_LWAST(dtype, i);
2708 ub = ADD_UPAST(dtype, i);
2709 extnt = ADD_EXTNTAST(dtype, i);
2710 lb_again:
2711 if (lb == 0) {
2712 lb = lowersym.intone;
2713 lower_visit_symbol(lb);
2714 } else if (A_TYPEG(lb) == A_INTR) {
2715 switch (A_OPTYPEG(lb)) {
2716 case I_INT1:
2717 case I_INT2:
2718 case I_INT4:
2719 case I_INT8:
2720 case I_INT:
2721 lb = A_ARGSG(lb);
2722 lb = ARGT_ARG(lb, 0);
2723 goto lb_again;
2724 case I_SIZE: {
2725 int arr, con, dty, val;
2726 ADSC *ad;
2727 lb = A_ARGSG(lb);
2728 arr = ARGT_ARG(lb, 0);
2729 con = ARGT_ARG(lb, 1);
2730 if (!eval_con_expr(con, &val, &dty)) {
2731 goto lb_error;
2732 }
2733 dty = DTYPEG(memsym_of_ast(arr));
2734 ad = AD_DPTR(dty);
2735 lb = AD_UPAST(ad, val);
2736 goto lb_again;
2737 }
2738 }
2739 goto lb_error;
2740 } else if (A_TYPEG(lb) == A_ID || A_TYPEG(lb) == A_CNST) {
2741 lb = A_SPTRG(lb);
2742 lower_visit_symbol(lb);
2743 } else {
2744 if (!XBIT(52, 4)) {
2745 if (A_TYPEG(lb) == A_SUBSCR) {
2746 int l = A_LOPG(lb);
2747 if (A_TYPEG(l) == A_MEM)
2748 l = A_MEMG(l);
2749 if (A_TYPEG(l) == A_ID && DESCARRAYG(A_SPTRG(l))) {
2750 lb = 0;
2751 }
2752 }
2753 }
2754 if (lb) {
2755 lb_error:
2756 if (usage == 1)
2757 lerror("array lower bound is not a symbol for datatype %d", dtype);
2758 lb = lowersym.intone;
2759 lower_visit_symbol(lb);
2760 }
2761 }
2762 ub_again:
2763 if (ub == 0) {
2764 } else if (A_TYPEG(ub) == A_INTR) {
2765 switch (A_OPTYPEG(ub)) {
2766 case I_INT1:
2767 case I_INT2:
2768 case I_INT4:
2769 case I_INT8:
2770 case I_INT:
2771 ub = A_ARGSG(ub);
2772 ub = ARGT_ARG(ub, 0);
2773 goto ub_again;
2774 case I_SIZE: {
2775 int arr, con, dty, val;
2776 ADSC *ad;
2777 ub = A_ARGSG(ub);
2778 arr = ARGT_ARG(ub, 0);
2779 con = ARGT_ARG(ub, 1);
2780 if (!eval_con_expr(con, &val, &dty)) {
2781 if (A_TYPEG(A_LOPG(con)) == A_ID) {
2782 ub = 0;
2783 goto ub_again;
2784 }
2785 goto ub_error;
2786 }
2787 dty = DTYPEG(memsym_of_ast(arr));
2788 ad = AD_DPTR(dty);
2789 ub = AD_UPAST(ad, val);
2790 goto ub_again;
2791 }
2792 }
2793 goto ub_error;
2794
2795 } else if (A_TYPEG(ub) == A_ID || A_TYPEG(ub) == A_CNST) {
2796 ub = A_SPTRG(ub);
2797 lower_visit_symbol(ub);
2798 } else {
2799 if (!XBIT(52, 4)) {
2800 if (A_TYPEG(ub) == A_SUBSCR) {
2801 int u = A_LOPG(ub);
2802 if (A_TYPEG(u) == A_MEM)
2803 u = A_MEMG(u);
2804 if (A_TYPEG(u) == A_ID && DESCARRAYG(A_SPTRG(u))) {
2805 ub = 0;
2806 }
2807 } else if (A_TYPEG(ub) == A_BINOP && A_OPTYPEG(ub) == OP_ADD) {
2808 /* handle special case of lower+(extent-1) */
2809 int l, r, rl, rr;
2810 l = A_LOPG(ub);
2811 r = A_ROPG(ub);
2812 if (A_TYPEG(l) == A_BINOP && A_OPTYPEG(l) == OP_SUB) {
2813 rl = l;
2814 l = r;
2815 r = rl;
2816 }
2817 if (A_TYPEG(r) == A_BINOP && A_OPTYPEG(r) == OP_SUB) {
2818 rl = A_LOPG(r);
2819 rr = A_ROPG(r);
2820 if (A_TYPEG(l) == A_SUBSCR && A_TYPEG(rl) == A_SUBSCR &&
2821 A_TYPEG(rr) == A_CNST) {
2822 l = A_LOPG(l);
2823 rl = A_LOPG(rl);
2824 if (A_TYPEG(l) == A_ID && DESCARRAYG(A_SPTRG(l)) &&
2825 A_TYPEG(rl) == A_ID && DESCARRAYG(A_SPTRG(rl))) {
2826 ub = 0;
2827 }
2828 }
2829 }
2830 }
2831 }
2832 if (ub && !valid_kind_parm_expr(ub)) {
2833 ub_error:
2834 if (usage == 1) {
2835 lerror("array upper bound is not a symbol for datatype %d", dtype);
2836 }
2837 ub = 0;
2838 }
2839 }
2840 putpair(lb, ub);
2841 extnt_again:
2842 if (extnt == 0) {
2843 extnt = lowersym.intone;
2844 lower_visit_symbol(extnt);
2845 } else if (A_TYPEG(extnt) == A_INTR) {
2846 switch (A_OPTYPEG(extnt)) {
2847 case I_INT1:
2848 case I_INT2:
2849 case I_INT4:
2850 case I_INT8:
2851 case I_INT:
2852 extnt = A_ARGSG(extnt);
2853 extnt = ARGT_ARG(extnt, 0);
2854 goto extnt_again;
2855 case I_SIZE: {
2856 int arr, con, dty, val;
2857 ADSC *ad;
2858 extnt = A_ARGSG(extnt);
2859 arr = ARGT_ARG(extnt, 0);
2860 con = ARGT_ARG(extnt, 1);
2861 if (!eval_con_expr(con, &val, &dty)) {
2862 if (A_TYPEG(A_LOPG(con)) == A_ID) {
2863 extnt = 0;
2864 goto extnt_again;
2865 }
2866 goto extnt_error;
2867 }
2868 dty = DTYPEG(memsym_of_ast(arr));
2869 extnt = ADD_EXTNTAST(dty, val);
2870 goto extnt_again;
2871 }
2872 }
2873 goto extnt_error;
2874 } else if (A_TYPEG(extnt) == A_ID || A_TYPEG(extnt) == A_CNST) {
2875 extnt = A_SPTRG(extnt);
2876 lower_visit_symbol(extnt);
2877 } else {
2878 if (!XBIT(52, 4)) {
2879 if (A_TYPEG(extnt) == A_SUBSCR) {
2880 int l = A_LOPG(extnt);
2881 if (A_TYPEG(l) == A_MEM)
2882 l = A_MEMG(l);
2883 if (A_TYPEG(l) == A_ID && DESCARRAYG(A_SPTRG(l))) {
2884 extnt = 0;
2885 }
2886 }
2887 }
2888 if (extnt && !valid_kind_parm_expr(extnt)) {
2889 extnt_error:
2890 if (usage == 1)
2891 lerror("array extnt is not a symbol for datatype %d", dtype);
2892 extnt = lowersym.intone;
2893 lower_visit_symbol(extnt);
2894 }
2895 }
2896 mpy = ADD_MLPYR(dtype, i);
2897 if (mpy == 0) {
2898 } else if (A_TYPEG(mpy) == A_ID || A_TYPEG(mpy) == A_CNST) {
2899 mpy = A_SPTRG(mpy);
2900 lower_visit_symbol(mpy);
2901 } else {
2902 mpy = 0;
2903 }
2904 putsym("mpy", mpy);
2905 }
2906 zbase = ADD_ZBASE(dtype);
2907 if (zbase == 0) {
2908 zbase = 0;
2909 /*lerror( "array zero-base is unknown for datatype %d", dtype );*/
2910 /* it will be left as zero for assumed-shape arguments
2911 * of module subprograms */
2912 } else if (A_TYPEG(zbase) == A_ID || A_TYPEG(zbase) == A_CNST) {
2913 zbase = A_SPTRG(zbase);
2914 lower_visit_symbol(zbase);
2915 } else {
2916 if (!XBIT(52, 4)) {
2917 if (A_TYPEG(zbase) == A_SUBSCR) {
2918 int z = A_LOPG(zbase);
2919 if (A_TYPEG(z) == A_MEM)
2920 z = A_MEMG(z);
2921 if (A_TYPEG(z) == A_ID && DESCARRAYG(A_SPTRG(z))) {
2922 zbase = 0;
2923 }
2924 }
2925 }
2926 if (zbase) {
2927 zbase = 0;
2928 /*We need to avoid the case that logic array has been used for
2929 * intrinsics*/
2930 if (usage == 1 && ndim)
2931 lerror("array zero-base is not a symbol for datatype %d", dtype);
2932 }
2933 }
2934 if (zbase == 0)
2935 zbase = stb.i1;
2936 putsym("zbase", zbase);
2937 numelm = ADD_NUMELM(dtype);
2938 if (numelm == 0) {
2939 } else if (A_TYPEG(numelm) == A_ID || A_TYPEG(numelm) == A_CNST) {
2940 numelm = A_SPTRG(numelm);
2941 lower_visit_symbol(numelm);
2942 } else {
2943 if (!XBIT(52, 4)) {
2944 if (is_descr_expression(numelm)) {
2945 numelm = 0;
2946 } else if (A_TYPEG(numelm) == A_SUBSCR) {
2947 int n = A_LOPG(numelm);
2948 if (A_TYPEG(n) == A_ID && DESCARRAYG(A_SPTRG(n))) {
2949 numelm = 0;
2950 }
2951 }
2952 }
2953 if (numelm && !valid_kind_parm_expr(numelm)) {
2954 numelm = 0;
2955 if (usage == 1)
2956 lerror("array numelm is not a symbol for datatype %d", dtype);
2957 }
2958 }
2959 putsym("numelm", numelm);
2960 break;
2961
2962 default:
2963 fprintf(lowersym.lowerfile, "?????");
2964 lerror("unknown data type %d (value %d)", dtype, DTY(dtype));
2965 break;
2966 }
2967 fprintf(lowersym.lowerfile, "\n");
2968 } /* lower_put_datatype */
2969
2970 /* put dtype to ilm file and optionally to stb file */
2971 static void
lower_put_datatype_stb(int dtype)2972 lower_put_datatype_stb(int dtype)
2973 {
2974 int usage = dtype >= last_datatype_used ? 1 : datatype_used[dtype];
2975 lower_put_datatype(dtype, usage);
2976 if (STB_LOWER()) {
2977 FILE *tmpfile = lowersym.lowerfile;
2978 lowersym.lowerfile = gbl.stbfil;
2979 lower_put_datatype(dtype, usage);
2980 lowersym.lowerfile = tmpfile;
2981 }
2982 }
2983
2984 /** \brief Lower all of the data types */
2985 void
lower_data_types(void)2986 lower_data_types(void)
2987 {
2988 int dtype, sptr;
2989
2990 for (dtype = 0; dtype < stb.dt.stg_avail; dtype += dlen(DTY(dtype))) {
2991 if (dtype >= last_datatype_used || datatype_used[dtype]) {
2992 lower_put_datatype_stb(dtype);
2993 }
2994 }
2995 } /* lower_data_types */
2996
2997 void
lower_push(int value)2998 lower_push(int value)
2999 {
3000 ++stack_top;
3001 NEED(stack_top + 1, stack, int, stack_size, stack_size + 100);
3002 stack[stack_top] = value;
3003 } /* lower_push */
3004
3005 int
lower_pop(void)3006 lower_pop(void)
3007 {
3008 if (stack_top <= 0) {
3009 error(0, 4, 0, "stack underflow while lowering", "");
3010 }
3011 --stack_top;
3012 return stack[stack_top + 1];
3013 } /* lower_pop */
3014
3015 void
lower_check_stack(int check)3016 lower_check_stack(int check)
3017 {
3018 if (stack_top <= 0) {
3019 interr("stack underflow while lowering", stack_top, 4);
3020 }
3021 if (stack[stack_top] != check) {
3022 interr("stack error while lowering", check, 4);
3023 }
3024 --stack_top;
3025 } /* lower_check_stack */
3026
3027 int
lower_getintcon(int val)3028 lower_getintcon(int val)
3029 {
3030 INT v[4];
3031 int sptr;
3032 v[0] = v[2] = v[3] = 0;
3033 v[1] = val;
3034 sptr = getcon(v, DT_INT4);
3035 VISITP(sptr, 1);
3036 lower_use_datatype(DT_INT4, 1);
3037 return sptr;
3038 } /* lower_getintcon */
3039
3040 static int
lower_getnull(void)3041 lower_getnull(void)
3042 {
3043 INT v[4];
3044 int sptr;
3045 v[0] = v[1] = v[2] = v[3] = 0;
3046 sptr = getcon(v, DT_ADDR);
3047 return sptr;
3048 } /* lower_getnull */
3049
3050 int
lower_getiszcon(ISZ_T val)3051 lower_getiszcon(ISZ_T val)
3052 {
3053 if (XBIT(68, 0x1)) {
3054 INT num[2], sptr;
3055
3056 ISZ_2_INT64(val, num);
3057 sptr = getcon(num, DT_INT8);
3058 VISITP(sptr, 1);
3059 lower_use_datatype(DT_INT8, 1);
3060 return sptr;
3061 } else
3062 return lower_getintcon(val);
3063 } /* lower_getiszcon */
3064
3065 int
lower_getlogcon(int val)3066 lower_getlogcon(int val)
3067 {
3068 INT v[4];
3069 int sptr;
3070 v[0] = v[2] = v[3] = 0;
3071 v[1] = val;
3072 sptr = getcon(v, DT_LOG4);
3073 VISITP(sptr, 1);
3074 lower_use_datatype(DT_LOG4, 1);
3075 return sptr;
3076 } /* lower_getlogcon */
3077
3078 int
lower_getrealcon(int val)3079 lower_getrealcon(int val)
3080 {
3081 INT v[4];
3082 int sptr;
3083 v[0] = v[2] = v[3] = 0;
3084 v[1] = val;
3085 sptr = getcon(v, DT_REAL4);
3086 VISITP(sptr, 1);
3087 lower_use_datatype(DT_REAL4, 1);
3088 return sptr;
3089 } /* lower_getrealcon */
3090
3091 void
lower_namelist_plists(void)3092 lower_namelist_plists(void)
3093 {
3094 int sptr;
3095 for (sptr = stb.firstusym; sptr < stb.stg_avail; ++sptr) {
3096 if (STYPEG(sptr) == ST_NML) {
3097 /* change the data type of the namelist PLIST from DT_INT
3098 * to an array of proper size */
3099 int plist = ADDRESSG(sptr);
3100 int dtype = get_array_dtype(1, DT_PTR);
3101 int member;
3102 lower_use_datatype(DT_INT, 1);
3103 lower_use_datatype(DT_PTR, 1);
3104 ADD_ZBASE(dtype) = astb.bnd.one;
3105 ADD_MLPYR(dtype, 0) = astb.bnd.one;
3106 ADD_LWBD(dtype, 0) = ADD_LWAST(dtype, 0) = astb.bnd.one;
3107 ADD_NUMELM(dtype) = ADD_UPBD(dtype, 0) = ADD_UPAST(dtype, 0) =
3108 ADD_EXTNTAST(dtype, 0) = mk_cnst(lower_getiszcon(PLLENG(plist)));
3109 DTYPEP(plist, dtype);
3110 STYPEP(plist, ST_ARRAY);
3111 PLLENP(plist, 0);
3112
3113 /* export the namelist variable also */
3114 lower_visit_symbol(sptr);
3115 /* export all symbols in the namelist */
3116 for (member = CMEMFG(sptr); member; member = NML_NEXT(member)) {
3117 int sptr = NML_SPTR(member);
3118 if (LOWER_SYMBOL_REPLACE(sptr)) {
3119 sptr = LOWER_SYMBOL_REPLACE(sptr);
3120 }
3121 lower_visit_symbol(sptr);
3122 }
3123 }
3124 }
3125 } /* lower_namelist_plists */
3126
3127 /** \brief Convert the datatype for linearized arrays to assumed-size array */
3128 void
lower_linearized(void)3129 lower_linearized(void)
3130 {
3131 int sptr;
3132 if (!XBIT(52, 4))
3133 return;
3134 for (sptr = stb.firstosym; sptr < stb.stg_avail; ++sptr) {
3135 if (DTY(DTYPEG(sptr)) == TY_ARRAY && LNRZDG(sptr)) {
3136 /* type should be basetype(1:1):: array */
3137 int olddtype, dtype, savedtype;
3138 olddtype = DTYPEG(sptr);
3139 /* stash the old datatype; it can be retrieved
3140 * from the DTY('newdtype'-1) */
3141 savedtype = get_type(1, -olddtype, 0);
3142 dtype = get_array_dtype(1, DTY(olddtype + 1));
3143 ADD_ZBASE(dtype) = astb.bnd.one;
3144 ADD_MLPYR(dtype, 0) = astb.bnd.one;
3145 ADD_LWBD(dtype, 0) = ADD_LWAST(dtype, 0) = astb.bnd.one;
3146 ADD_NUMELM(dtype) = ADD_UPBD(dtype, 0) = ADD_UPAST(dtype, 0) =
3147 ADD_EXTNTAST(dtype, 0) = astb.bnd.one;
3148 lower_visit_symbol(lowersym.intone);
3149 DTYPEP(sptr, dtype);
3150 }
3151 }
3152 for (sptr = stb.firstosym; sptr < stb.stg_avail; ++sptr) {
3153 int dtype;
3154 dtype = DTYPEG(sptr);
3155 if (DTY(dtype) == TY_ARRAY && LNRZDG(sptr)) {
3156 lower_use_datatype(DTY(dtype + 1), 1);
3157 }
3158 if (STYPEG(sptr) == ST_PROC || STYPEG(sptr) == ST_ENTRY) {
3159 if (FVALG(sptr)) {
3160 DTYPEP(sptr, DTYPEG(FVALG(sptr)));
3161 }
3162 }
3163 }
3164 lower_linearized_dtypes = TRUE;
3165 } /* lower_linearized */
3166
3167 /*
3168 * find a NMPTR that shares NMPTR for different symbols with the same name
3169 * note that putsname always inserts a new name into the name table
3170 */
3171 static int
find_nmptr(char * symname,int len)3172 find_nmptr(char *symname, int len)
3173 {
3174 int hash, hptr;
3175 HASH_ID(hash, symname, len);
3176 for (hptr = stb.hashtb[hash]; hptr; hptr = HASHLKG(hptr)) {
3177 if (strcmp(SYMNAME(hptr), symname) == 0) {
3178 return NMPTRG(hptr);
3179 }
3180 }
3181 return putsname(symname, len);
3182 } /* find_nmptr */
3183
3184 static int
lower_newsymbol(char * name,int stype,int dtype,int sclass)3185 lower_newsymbol(char *name, int stype, int dtype, int sclass)
3186 {
3187 int sptr, hashid;
3188 int namelen = strlen(name);
3189 HASH_ID(hashid, name, namelen);
3190 ADDSYM(sptr, hashid);
3191 NMPTRP(sptr, find_nmptr(name, namelen));
3192 SYMLKP(sptr, NOSYM);
3193 STYPEP(sptr, stype);
3194 DTYPEP(sptr, dtype);
3195 SCP(sptr, sclass);
3196 SCOPEP(sptr, stb.curr_scope);
3197 switch (stype) {
3198 case ST_VAR:
3199 case ST_ARRAY:
3200 case ST_STRUCT:
3201 case ST_UNION:
3202 CCSYMP(sptr, 1);
3203 break;
3204 default:
3205 break;
3206 }
3207 VISITP(sptr, 1);
3208 lower_use_datatype(dtype, 1);
3209 return sptr;
3210 } /* lower_newsymbol */
3211
3212 int
lower_newfunc(char * name,int stype,int dtype,int sclass)3213 lower_newfunc(char *name, int stype, int dtype, int sclass)
3214 {
3215 int namelen, sptr, hashid;
3216 namelen = strlen(name);
3217 sptr = lookupsym(name, namelen);
3218 if (sptr <= NOSYM)
3219 sptr = lower_newsymbol(name, stype, dtype, sclass);
3220 return sptr;
3221 } /* lower_newfunc */
3222
3223 int
lower_makefunc(char * name,int dtype,LOGICAL isDscSafe)3224 lower_makefunc(char *name, int dtype, LOGICAL isDscSafe)
3225 {
3226 char *fullname;
3227 int symfunc;
3228 symfunc = lower_newfunc(name, ST_PROC, dtype, SC_EXTERN);
3229 HCCSYMP(symfunc, 1);
3230 if (isDscSafe)
3231 SDSCSAFEP(symfunc, 1);
3232 return symfunc;
3233 } /* lower_makefunc */
3234
3235 void
lower_clear_visit_fields(void)3236 lower_clear_visit_fields(void)
3237 {
3238 int sptr;
3239 for (sptr = 0; sptr < stb.stg_avail; ++sptr) {
3240 VISITP(sptr, 0);
3241 VISIT2P(sptr, 0);
3242 }
3243 } /* lower_clear_visit_fields */
3244
3245 static int lower_cmptrvar(char *, int, int, int *);
3246 static int get_cmptrvar(char *, int, int, int *);
3247
3248 /** \brief Add common blocks to hold various zeros
3249
3250 <pre>
3251 common/pghpf_0/ pghpf_01, pghpf_02, pghpf_03, pghpf_04
3252 integer pghpf_01, pghpf_02, pghpf_03, pghpf_04
3253 common/pghpf_0c/ pghpf_0c
3254 character*1 pghpf_0c
3255 common /pghpf_lineno/ pghpf_lineno
3256 common /pghpf_np/ hpf_np$
3257 common /pghpf_me/ hpf_me$
3258 </pre>
3259 */
3260 void
lower_add_pghpf_commons(void)3261 lower_add_pghpf_commons(void)
3262 {
3263 int symcommon, sym1, sym2, sym3, sym4, sym5, sym6, sym7, sym8, dtype;
3264 int bsym1, bsym2, bsym3, bsym4, bsym5, bsym6, bsym7, bsym8;
3265 int cmsz; /* common member size */
3266
3267 if (!XBIT(57, 0x8000)) {
3268 lowersym.ptr0 = lowersym.ptrnull;
3269 } else {
3270 symcommon = lower_newsymbol("pghpf_0", ST_CMBLK, 0, SC_NONE);
3271 SYMLKP(symcommon, gbl.cmblks);
3272 gbl.cmblks = symcommon;
3273 HCCSYMP(symcommon, 1);
3274 sym1 = lower_cmptrvar("pghpf_01", ST_VAR, DT_INT4, &bsym1);
3275 sym2 = lower_cmptrvar("pghpf_02", ST_VAR, DT_INT4, &bsym2);
3276 sym3 = lower_cmptrvar("pghpf_03", ST_VAR, DT_INT4, &bsym3);
3277 sym4 = lower_cmptrvar("pghpf_04", ST_VAR, DT_INT4, &bsym4);
3278 #if defined(TARGET_WIN)
3279 if (!XBIT(70, 0x80000000)) {
3280 DLLP(symcommon, DLL_IMPORT);
3281 }
3282 #endif
3283 if (!XBIT(70, 0x80000000)) {
3284 cmsz = 4;
3285 lowersym.ptr0 = sym3;
3286 } else {
3287 /* win dll target */
3288 cmsz = size_of(DT_PTR);
3289 lowersym.ptr0 = bsym3;
3290 }
3291 CMEMFP(symcommon, sym1);
3292 SYMLKP(sym1, sym2);
3293 SYMLKP(sym2, sym3);
3294 SYMLKP(sym3, sym4);
3295 SYMLKP(sym4, NOSYM);
3296 CMEMLP(symcommon, sym4);
3297 CMBLKP(sym1, symcommon);
3298 CMBLKP(sym2, symcommon);
3299 CMBLKP(sym3, symcommon);
3300 CMBLKP(sym4, symcommon);
3301 ADDRESSP(sym1, 0 * cmsz);
3302 ADDRESSP(sym2, 1 * cmsz);
3303 ADDRESSP(sym3, 2 * cmsz);
3304 ADDRESSP(sym4, 3 * cmsz);
3305 SIZEP(symcommon, 4 * cmsz);
3306 }
3307
3308 if (!XBIT(57, 0x8000)) {
3309 lowersym.ptr0c = lowersym.ptr0;
3310 } else {
3311 dtype = get_type(2, TY_CHAR, astb.i1);
3312 lower_use_datatype(dtype, 1);
3313 symcommon = lower_newsymbol("pghpf_0c", ST_CMBLK, 0, SC_NONE);
3314 SYMLKP(symcommon, gbl.cmblks);
3315 gbl.cmblks = symcommon;
3316 HCCSYMP(symcommon, 1);
3317 sym1 = lower_cmptrvar("pghpf_0c", ST_VAR, dtype, &bsym1);
3318 #if defined(TARGET_WIN)
3319 if (!XBIT(70, 0x80000000)) {
3320 DLLP(symcommon, DLL_IMPORT);
3321 }
3322 #endif
3323 if (!XBIT(70, 0x80000000)) {
3324 lowersym.ptr0c = sym1;
3325 SIZEP(symcommon, 1);
3326 } else {
3327 lowersym.ptr0c = bsym1;
3328 SIZEP(symcommon, size_of(DT_PTR));
3329 }
3330 CMEMFP(symcommon, sym1);
3331 SYMLKP(sym1, NOSYM);
3332 CMEMLP(symcommon, sym1);
3333 CMBLKP(sym1, symcommon);
3334 }
3335
3336 if (XBIT(70, 6)) {
3337 int l;
3338 l = strlen(gbl.src_file);
3339 lowersym.sym_chkfile = getstring(gbl.src_file, l + 1);
3340 }
3341 } /* lower_add_pghpf_commons */
3342
3343 static int
lower_cmptrvar(char * name,int stype,int dtype,int * bsym)3344 lower_cmptrvar(char *name, int stype, int dtype, int *bsym)
3345 {
3346 char bname[16];
3347 int len;
3348 int sym;
3349
3350 if (!XBIT(70, 0x80000000)) {
3351 sym = lower_newsymbol(name, stype, dtype, SC_CMBLK);
3352 return sym;
3353 }
3354
3355 len = strlen(name);
3356 #if DEBUG
3357 assert(len < (sizeof(bname) - 1), "lower_cmptrvar name overflow", 0, 0);
3358 #endif
3359 /* win dll target: the variable is actually a pointer-based object,
3360 * so what's added to the common is the object's pointer variable.
3361 * The name of the pointer variable is formed by appending 'p' to
3362 * the original name.
3363 */
3364 strcpy(bname, name);
3365 bname[len] = 'p';
3366 bname[len + 1] = 0;
3367
3368 sym = lower_newsymbol(bname, ST_VAR, DT_PTR, SC_CMBLK);
3369 *bsym = lower_newsymbol(name, stype, dtype, SC_BASED);
3370 MIDNUMP(*bsym, sym);
3371 return sym;
3372 }
3373
3374 static int
get_cmptrvar(char * name,int stype,int dtype,int * bsym)3375 get_cmptrvar(char *name, int stype, int dtype, int *bsym)
3376 {
3377 int sym;
3378
3379 if (!XBIT(70, 0x80000000)) {
3380 sym = getsymbol(name);
3381 STYPEP(sym, stype);
3382 DTYPEP(sym, dtype);
3383 SCP(sym, SC_CMBLK);
3384 VISITP(sym, 1);
3385 return sym;
3386 }
3387
3388 /* win dll target: the variable is actually a pointer-based object,
3389 * so what's added to the common is the object's pointer variable.
3390 * The name of the pointer variable is formed by appending 'p' to
3391 * the original name.
3392 */
3393 sym = getsymf("%sp", name);
3394 STYPEP(sym, ST_VAR);
3395 DTYPEP(sym, DT_PTR);
3396 SCP(sym, SC_CMBLK);
3397 VISITP(sym, 1);
3398
3399 *bsym = getsymbol(name);
3400 STYPEP(*bsym, stype);
3401 DTYPEP(*bsym, dtype);
3402 SCP(*bsym, SC_BASED);
3403 VISITP(*bsym, 1);
3404 MIDNUMP(*bsym, sym);
3405
3406 return sym;
3407 }
3408
3409 #if TY_MAX != 36
3410 #error "Need to edit lowersym.c to add new TY_... data types"
3411 #endif
3412
3413 static char *
putstype(int stype,int sptr)3414 putstype(int stype, int sptr)
3415 {
3416 /* TRY TO KEEP THESE UNIQUE IN THE FIRST CHARACTER! */
3417 #if ST_MAX != 35
3418 #error \
3419 "Need to edit lowersym.c to add new or remove old ST_... symbol types or need to run the symtab utility"
3420 #endif
3421 if (stype == ST_MODULE) {
3422 if (sptr == gbl.currsub) {
3423 stype = ST_ENTRY;
3424 } else {
3425 stype = ST_PROC;
3426 }
3427 }
3428 switch (stype) {
3429 case ST_ARRAY:
3430 return "Array";
3431 case ST_BLOCK:
3432 return "Block";
3433 case ST_CMBLK:
3434 return "Common";
3435 case ST_CONST:
3436 return "constant";
3437 case ST_DESCRIPTOR:
3438 return "Array";
3439 case ST_ENTRY:
3440 return "Entry";
3441 case ST_GENERIC:
3442 return "Generic";
3443 case ST_INTRIN:
3444 return "Intrinsic";
3445 case ST_PD:
3446 return "Known";
3447 case ST_LABEL:
3448 return "Label";
3449 case ST_PLIST:
3450 return "list";
3451 case ST_MEMBER:
3452 return "Member";
3453 case ST_MODULE:
3454 return "module";
3455 case ST_NML:
3456 return "Namelist";
3457 case ST_PARAM:
3458 return "parameter";
3459 case ST_PROC:
3460 case ST_MODPROC:
3461 return "Procedure";
3462 case ST_STRUCT:
3463 return "Struct";
3464 case ST_STAG:
3465 return "Tag";
3466 case ST_TYPEDEF:
3467 return "typedef";
3468 case ST_UNION:
3469 return "Union";
3470 case ST_USERGENERIC:
3471 return "Generic";
3472 case ST_VAR:
3473 return "Variable";
3474
3475 case ST_UNKNOWN:
3476 case ST_IDENT:
3477 case ST_STFUNC:
3478 case ST_ISOC:
3479 case ST_ISOFTNENV:
3480 case ST_ARRDSC:
3481 case ST_ALIAS:
3482 case ST_OPERATOR:
3483 case ST_CONSTRUCT:
3484 case ST_CRAY:
3485 default:
3486 lerror("unexpected symbol type %s(%d)",
3487 stype >= 0 && stype <= ST_MAX ? stb.stypes[stype] : "", stype);
3488 #if DEBUG
3489 symdentry(gbl.dbgfil, sptr);
3490 if (STYPEG(sptr) == ST_ALIAS)
3491 symdentry(gbl.dbgfil, SYMLKG(sptr));
3492 #endif
3493 return "?";
3494 }
3495 } /* putstype */
3496
3497 static char *
putsclass(int sclass,int sptr)3498 putsclass(int sclass, int sptr)
3499 {
3500 #if SC_MAX != 7
3501 #error "Need to edit lowersym.c to add new SC_... symbol classes"
3502 #endif
3503 switch (sclass) {
3504 case SC_BASED:
3505 return "Based";
3506 case SC_CMBLK:
3507 return "Common";
3508 case SC_DUMMY:
3509 return "Dummy";
3510 case SC_EXTERN:
3511 return "Extern";
3512 case SC_LOCAL:
3513 return "Local";
3514 case SC_NONE:
3515 return "none";
3516 case SC_PRIVATE:
3517 return "Private";
3518 case SC_STATIC:
3519 return "Static";
3520 default:
3521 lerror("unexpected symbol class %s(%d)",
3522 sclass >= 0 && sclass <= SC_MAX ? stb.scnames[sclass] : "", sclass);
3523 #if DEBUG
3524 symdentry(gbl.dbgfil, sptr);
3525 #endif
3526 return "?";
3527 }
3528 } /* putsclass */
3529
3530 static void
lower_symbol(int sptr)3531 lower_symbol(int sptr)
3532 {
3533 int i, params, count, namelen, strip, newline, dtype, altreturn, desc;
3534 int fvalfirst, fvallast, sc, inmod, pdaln, frommod, cudamodule = 0;
3535 int conval, stype, parsyms;
3536 int dll;
3537 int cudaemu, routx = 0;
3538 char *name;
3539 char tempname[15];
3540 int retdesc;
3541
3542 if (!IS_STB_FILE()) {
3543 int scope = SCOPEG(sptr);
3544 }
3545
3546 strip = 0;
3547 newline = 0;
3548 name = SYMNAME(sptr);
3549 namelen = ((name == NULL) ? 0 : strlen(name));
3550 #if DEBUG
3551 if (DBGBIT(47, 8)) {
3552 fprintf(lowersym.lowerfile, "symbol:%s ", getprint(sptr));
3553 } else
3554 #endif
3555 putival("symbol", sptr);
3556 stype = STYPEG(sptr);
3557 sc = SCG(sptr);
3558
3559 if ((STYPEG(sptr) == ST_ALIAS || STYPEG(sptr) == ST_PROC ||
3560 STYPEG(sptr) == ST_ENTRY) &&
3561 SEPARATEMPG(sptr) &&
3562 STYPEG(SCOPEG(sptr)) == ST_MODULE)
3563 INMODULEP(sptr, 1);
3564
3565 dtype = DTYPEG(sptr);
3566 if (stype == ST_CONST && DTY(dtype) == TY_HOLL)
3567 dtype = DTYPEG(CONVAL1G(sptr));
3568 if (stype == ST_PROC || stype == ST_ENTRY) {
3569 if (DTY(dtype) == TY_ARRAY) {
3570 dtype = DTY(dtype + 1);
3571 if (DTY(dtype) == TY_CHAR)
3572 dtype = DT_NONE;
3573 }
3574 }
3575 if (stype == ST_PROC || stype == ST_MODPROC) {
3576 if (sc == SC_NONE)
3577 sc = SC_EXTERN;
3578 }
3579 if (dtype == DT_ADDR) {
3580 if (XBIT(49, 0x100)) { /* 64-bit pointers */
3581 dtype = DT_INT8;
3582 } else {
3583 dtype = DT_INT;
3584 }
3585 }
3586
3587 putstring(putstype(stype, sptr));
3588 putstring(putsclass(sc, sptr));
3589 #if DEBUG
3590 if (DBGBIT(47, 8)) {
3591 fprintf(lowersym.lowerfile, " dtype:%d ", (int)DTY(dtype));
3592 } else
3593 #endif
3594 putval("dtype", dtype);
3595 /* type specific information */
3596 switch (stype) {
3597 case ST_ARRAY:
3598 case ST_DESCRIPTOR:
3599 case ST_STRUCT:
3600 case ST_UNION:
3601 case ST_VAR:
3602 putbit("addrtaken", ADDRTKNG(sptr));
3603 putbit("argument", ARGG(sptr));
3604 putbit("assigned", ASSNG(sptr));
3605 putbit("decl", DCLDG(sptr));
3606 #if defined(TARGET_WIN)
3607 putval("dll", DLLG(sptr));
3608 putbit("mscall", MSCALLG(sptr));
3609 putbit("cref", CREFG(sptr));
3610 #else
3611 putval("dll", 0);
3612 putbit("mscall", 0);
3613 putbit("cref", 0);
3614 #endif
3615 putbit("ccsym", CCSYMG(sptr));
3616 putbit("hccsym", HCCSYMG(sptr));
3617 if (SCOPEG(sptr) && STYPEG(SCOPEG(sptr)) == ST_MODULE &&
3618 SCOPEG(sptr) != stb.curr_scope) {
3619 putbit("init", 0);
3620 } else {
3621 putbit("init", DINITG(sptr));
3622 }
3623 if (!XBIT(7, 0x100000)) {
3624 putbit("datacnst", DATACONSTG(sptr));
3625 } else {
3626 putbit("datacnst", 0);
3627 }
3628 putbit("namelist", NMLG(sptr));
3629 putbit("optional", OPTARGG(sptr));
3630 putbit("pointer",
3631 POINTERG(sptr) || MDALLOCG(sptr) ||
3632 (ALLOCG(sptr) && (SCG(sptr) == SC_BASED) && !NODESCG(sptr)));
3633 putbit("private", PRIVATEG(sptr));
3634 pdaln = 0;
3635 #ifdef PDALNG
3636 if (!PDALN_IS_DEFAULT(sptr)) {
3637 pdaln = PDALNG(sptr);
3638 if (pdaln == 0)
3639 pdaln = PDALN_EXPLICIT_0;
3640 }
3641 #endif
3642 #ifdef QALNG
3643 if (QALNG(sptr) && (pdaln < 3 || pdaln == PDALN_EXPLICIT_0))
3644 pdaln = 3;
3645 #endif
3646 putval("pdaln", pdaln);
3647 #ifdef TQALNG
3648 if (stype == ST_VAR) {
3649 putbit("tqaln", TQALNG(sptr));
3650 } else
3651 #endif
3652 putbit("tqaln", 0);
3653 putbit("ref", REFG(sptr));
3654 putbit("save", SAVEG(sptr));
3655 putbit("seq", SEQG(sptr));
3656 putbit("target", TARGETG(sptr));
3657 putbit("param", PARAMG(sptr));
3658 if (gbl.internal <= 1 || INTERNALG(sptr)) {
3659 /* for outer procedures, no symbols are uplevel */
3660 putbit("uplevel", 0);
3661 putbit("internref", 0);
3662 } else if (SCOPEG(sptr) && STYPEG(SCOPEG(sptr)) == ST_MODULE) {
3663 /* module symbols are not uplevel */
3664 putbit("uplevel", 0);
3665 putbit("internref", 0);
3666 } else {
3667 putbit("uplevel", 1);
3668 if (INTERNREFG(sptr))
3669 putbit("internref", 1);
3670 else
3671 putbit("internref", 0);
3672 }
3673 putbit("ptrsafe", PTRSAFEG(sptr));
3674 putbit("thread", THREADG(sptr));
3675 putval("etls", ETLSG(sptr));
3676 putbit("tls", TLSG(sptr));
3677
3678 #ifdef TASKG
3679 putbit("task", TASKG(sptr));
3680 #else
3681 putbit("task", 0);
3682 #endif
3683 putbit("volatile", VOLG(sptr));
3684 if (sc == SC_DUMMY || sc == SC_BASED ||
3685 (CLASSG(sptr) && stype == ST_DESCRIPTOR)) {
3686 putval("address", 0);
3687 } else {
3688 putval("address", ADDRESSG(sptr));
3689 }
3690 if (ADJLENG(sptr)) {
3691 putsym("clen", CVLENG(sptr));
3692 } else {
3693 putval("clen", 0);
3694 }
3695 putsym("common", CMBLKG(sptr));
3696 #if DEBUG
3697 if (DBGBIT(47, 8)) { /* don't put out 'link' with this switch */
3698 } else
3699 #endif
3700 putsym("link", SYMLKG(sptr));
3701 putsym("midnum", MIDNUMG(sptr));
3702 if (flg.debug)
3703 check_debug_alias(sptr);
3704 if (sc == SC_DUMMY) {
3705 int a;
3706 a = NEWARGG(sptr);
3707 putval("origdummy", a);
3708 }
3709 if (stype == ST_ARRAY || stype == ST_DESCRIPTOR) {
3710 putbit("adjustable", ADJARRG(sptr));
3711 putbit("afterentry", AFTENTG(sptr));
3712 putbit("assumedshape", ASSUMSHPG(sptr));
3713 putbit("assumedsize", ASUMSZG(sptr));
3714 putbit("autoarray",
3715 AUTOBJG(sptr) || (ADJARRG(sptr) && SCG(sptr) == SC_LOCAL));
3716 putbit("noconflict", VISIT2G(sptr));
3717 putbit("s1", SDSCS1G(sptr));
3718 putbit("isdesc", stype == ST_DESCRIPTOR ? 1 : 0);
3719 #ifdef SDSCCONTIGG
3720 putbit("contig", stype == ST_DESCRIPTOR ? SDSCCONTIGG(sptr) : 0);
3721 #else
3722 putbit("contig", 0);
3723 #endif
3724 if (LNRZDG(sptr) && XBIT(52, 4)) {
3725 /* get original datatype */
3726 int origdtype;
3727 origdtype = -DTY(dtype - 1);
3728 putval("origdim", ADD_NUMDIM(origdtype));
3729 } else {
3730 putval("origdim", ADD_NUMDIM(dtype));
3731 }
3732 putsym("descriptor", SDSCG(sptr));
3733 }
3734 putbit("parref", PARREFG(sptr));
3735 putsym("enclfunc", ENCLFUNCG(sptr));
3736 putbit("passbyval", PASSBYVALG(sptr));
3737 putbit("passbyref", PASSBYREFG(sptr));
3738 putbit("Cfunc", CFUNCG(sptr));
3739 putsym("altname", ALTNAMEG(sptr));
3740 putbit("contigattr", CONTIGATTRG(sptr));
3741 putbit("device", 0);
3742 putbit("pinned", 0);
3743 putbit("shared", 0);
3744 putbit("constant", 0);
3745 putbit("texture", 0);
3746 putbit("managed", 0);
3747 putbit("intentin", (SCG(sptr) == SC_DUMMY && INTENTG(sptr) == INTENT_IN));
3748 #if defined(CLASSG)
3749 putbit("class", CLASSG(sptr));
3750 putval("parent", PARENTG(sptr));
3751 if (stype == ST_VAR) { /* TBD - need this for poly variable? */
3752 if (DTYPEG(sptr) == DT_DEFERCHAR || DTYPEG(sptr) == DT_ASSCHAR) {
3753 putsym("descriptor", SDSCG(sptr));
3754 } else if (sc == SC_DUMMY && CLASSG(sptr)) {
3755 putsym("descriptor", PARENTG(sptr));
3756 } else if ((sc == SC_DUMMY ||
3757 (sc == SC_BASED && SCG(MIDNUMG(sptr)) == SC_DUMMY)) &&
3758 NEWDSCG(sptr) && SDSCG(sptr)) {
3759 putsym("descriptor", NEWDSCG(sptr));
3760 } else if ((sc == SC_DUMMY || SCG(SDSCG(sptr)) == SC_DUMMY) &&
3761 needs_descriptor(sptr)) {
3762 putsym("descriptor", SDSCG(sptr));
3763 } else {
3764 putsym("descriptor", (CLASSG(sptr)) ? SDSCG(sptr) : 0);
3765 }
3766 }
3767 #else
3768 putbit("class", 0);
3769 putval("parent", 0);
3770 if (stype == ST_VAR) {
3771 if (DTYPEG(sptr) == DT_DEFERCHAR || DTYPEG(sptr) == DT_DEFERCHAR)
3772 putsym("descriptor", SDSCG(sptr));
3773 else
3774 putsym("descriptor", 0);
3775 }
3776 #endif
3777 if (DTY(dtype) == TY_DERIVED && PARENTG(DTY(dtype + 1)) &&
3778 DINITG(DTY(dtype + 1)) && sc == SC_STATIC) {
3779 /* Set reref bit for type extensions with initializations
3780 * in the parent component since we need to compute
3781 * assn_static_off() in back end's sym_is_refd() function.
3782 */
3783 putbit("reref", 1);
3784 } else {
3785 putbit("reref", 0);
3786 }
3787 putbit("reflected", 0);
3788 putbit("mirrored", 0);
3789 putbit("create", 0);
3790 putbit("copyin", 0);
3791 putbit("resident", 0);
3792 putbit("link", 0);
3793 putbit("devicecopy", 0);
3794 putbit("devicesd", 0);
3795 putval("devcopy", 0);
3796 putbit("allocattr", ALLOCATTRG(sptr));
3797 putbit("f90pointer", 0); /* F90POINTER will denote the POINTER attribute */
3798 /* but first need to remove FE legacy use */
3799 putbit("procdescr", IS_PROC_DESCRG(sptr));
3800 strip = 1;
3801 break;
3802
3803 case ST_CMBLK:
3804 putsym("altname", ALTNAMEG(sptr));
3805 putbit("ccsym", CCSYMG(sptr) || HCCSYMG(sptr));
3806 putbit("Cfunc", CFUNCG(sptr));
3807 #if defined(TARGET_WIN)
3808 putval("dll", DLLG(sptr));
3809 #else
3810 putval("dll", 0);
3811 #endif
3812 if (SCOPEG(sptr) == stb.curr_scope) {
3813 putbit("init", DINITG(sptr));
3814 } else {
3815 putbit("init", 0);
3816 }
3817 putsym("member", CMEMFG(sptr));
3818 putbit("mscall", MSCALLG(sptr));
3819 pdaln = 0;
3820 #ifdef PDALNG
3821 if (!PDALN_IS_DEFAULT(sptr)) {
3822 pdaln = PDALNG(sptr);
3823 if (pdaln == 0)
3824 pdaln = PDALN_EXPLICIT_0;
3825 }
3826 #endif
3827 #ifdef QALNG
3828 if (QALNG(sptr) && (pdaln < 3 || pdaln == PDALN_EXPLICIT_0))
3829 pdaln = 3;
3830 #endif
3831 putval("pdaln", pdaln);
3832 putbit("save", SAVEG(sptr));
3833 putval("size", SIZEG(sptr));
3834 putbit("stdcall", STDCALLG(sptr));
3835 putbit("thread", THREADG(sptr));
3836 putval("etls", ETLSG(sptr));
3837 putbit("tls", TLSG(sptr));
3838 putbit("volatile", VOLG(sptr));
3839 frommod = FROMMODG(sptr);
3840 if (MODCMNG(sptr) && frommod) {
3841 /* Just a module with specifications only */
3842 if (SCOPEG(sptr) == gbl.currsub)
3843 frommod = 0;
3844 }
3845 putbit("frommod", frommod);
3846 putbit("modcmn", MODCMNG(sptr));
3847 putsym("scope", SCOPEG(sptr));
3848 putbit("device", 0);
3849 putbit("constant", 0);
3850 putbit("create", 0);
3851 putbit("copyin", 0);
3852 putbit("resident", 0);
3853 putbit("link", 0);
3854 if (BLANKCG(sptr)) {
3855 namelen = 6;
3856 name = "_BLNK_";
3857 }
3858 strip = 1;
3859 break;
3860
3861 case ST_CONST:
3862 /* hollerith? and value */
3863 putbit("hollerith", HOLLG(sptr));
3864 switch (DTY(dtype)) {
3865 case TY_DWORD:
3866 case TY_INT8:
3867 case TY_LOG8:
3868 case TY_DBLE:
3869 case TY_CMPLX:
3870 puthex(CONVAL1G(sptr));
3871 puthex(CONVAL2G(sptr));
3872 break;
3873 case TY_BINT:
3874 case TY_SINT:
3875 case TY_INT:
3876 case TY_REAL:
3877 case TY_WORD:
3878 case TY_BLOG:
3879 case TY_SLOG:
3880 case TY_LOG:
3881 puthex(CONVAL2G(sptr));
3882 break;
3883 case TY_DCMPLX:
3884 case TY_QCMPLX:
3885 putsym("sym", CONVAL1G(sptr));
3886 putsym("sym", CONVAL2G(sptr));
3887 break;
3888 case TY_QUAD:
3889 puthex(CONVAL1G(sptr));
3890 puthex(CONVAL2G(sptr));
3891 puthex(CONVAL3G(sptr));
3892 puthex(CONVAL4G(sptr));
3893 break;
3894 case TY_PTR:
3895 putsym("sym", CONVAL1G(sptr));
3896 putval("offset", CONVAL2G(sptr));
3897 break;
3898 case TY_CHAR:
3899 case TY_NCHAR:
3900 /* put out the char string instead of the name */
3901 /* is this really a hollerith? */
3902 if (DTY(DTYPEG(sptr)) == TY_HOLL || DTY(dtype) == TY_NCHAR) {
3903 conval = CONVAL1G(sptr);
3904 name = stb.n_base + CONVAL1G(conval);
3905 namelen = string_length(DTYPEG(conval));
3906 } else {
3907 namelen = string_length(dtype);
3908 name = stb.n_base + CONVAL1G(sptr);
3909 }
3910 newline = 1;
3911 break;
3912 default:
3913 lerror("unexpected constant symbol data type (%d)", dtype);
3914 #if DEBUG
3915 symdentry(gbl.dbgfil, sptr);
3916 #endif
3917 break;
3918 }
3919 break;
3920
3921 case ST_MODULE:
3922 if (sptr == gbl.currsub) {
3923 /* put out like an ENTRY */
3924 putbit("currsub", 1);
3925 putbit("adjustable", 0);
3926 putbit("afterentry", 0);
3927 putsym("altname", 0);
3928 #if defined(TARGET_WIN_X86)
3929 putbit("Cfunc", 1);
3930 #else
3931 putbit("Cfunc", 0);
3932 #endif
3933 putbit("decl", 0);
3934 #if defined(TARGET_WIN)
3935 putval("dll", DLLG(sptr));
3936 #else
3937 putval("dll", 0);
3938 #endif
3939 putval("cmode", 0);
3940 putval("end", ENDLINEG(sptr));
3941 putsym("inmodule", 0);
3942 putval("line", FUNCLINEG(sptr));
3943 #if defined(TARGET_WIN_X86)
3944 putbit("mscall", 1);
3945 #else
3946 putbit("mscall", 0);
3947 #endif
3948 putbit("pure", 0);
3949 putbit("recursive", 0);
3950 putval("returnval", 0);
3951 putbit("passbyval", 0);
3952 putbit("passbyref", 0);
3953 putbit("stdcall", 0);
3954 putbit("decorate", 0);
3955 putbit("cref", 0);
3956 putbit("nomixedstrlen", 0);
3957 putval("cudaemu", 0);
3958 putval("rout", 0);
3959 putval("paramcount", 0);
3960 putval("altreturn", 0);
3961 putval("vtoff", 0);
3962 putval("invobj", 0);
3963 putbit("invobjinc", 0);
3964 putbit("class", 0);
3965 putbit("denorm", 0);
3966 putbit("aret", 0);
3967 putbit("vararg", 0);
3968 putbit("has_opts", 0);
3969 strip = 1;
3970 } else {
3971 /* put out like a PROC */
3972 putsym("altname", 0);
3973 putbit("ccsym", 0);
3974 putbit("decl", 0);
3975 putval("dll", 0);
3976 i = 0;
3977 #if defined(TARGET_WIN)
3978 if (ENCLFUNCG(gbl.currsub) == sptr && DLLG(sptr) != DLL_EXPORT &&
3979 DLLG(gbl.currsub) == DLL_EXPORT) {
3980 /*
3981 * dllexport of a normal ST_PROC is illegal; however, it
3982 * could represent a MODULE whose dllexport only occurs within
3983 * a contained procedure.
3984 */
3985 i = 1;
3986 }
3987 #endif
3988 putbit("dllexportmod", i);
3989 putval("cmode", 0);
3990 putbit("func", 0);
3991 putsym("inmodule", 0);
3992 #if defined(TARGET_WIN_X86)
3993 putbit("mscall", 1);
3994 #else
3995 putbit("mscall", 0);
3996 #endif
3997 putbit("needmod", NEEDMODG(sptr));
3998 putbit("pure", 0);
3999 putbit("ref", 0);
4000 putbit("passbyval", 0);
4001 putbit("passbyref", 0);
4002 putbit("cstructret", CSTRUCTRETG(sptr));
4003 putbit("sdscsafe", 0);
4004 putbit("stdcall", 0);
4005 putbit("decorate", 0);
4006 putbit("cref", 0);
4007 putbit("nomixedstrlen", 0);
4008 putbit("typed", TYPDG(sptr));
4009 putbit("recursive", 0);
4010 putval("returnval", 0);
4011 #if defined(TARGET_WIN_X86)
4012 putbit("Cfunc", 1);
4013 #else
4014 putbit("Cfunc", 0);
4015 #endif
4016 putbit("uplevel", 0);
4017 putbit("internref", 0);
4018 putval("rout", 0);
4019 putval("paramcount", 0);
4020 putval("vtoff", 0);
4021 putval("invobj", 0);
4022 putbit("invobjinc", 0);
4023 putbit("class", 0);
4024 putbit("mlib", 0);
4025 putbit("clib", 0);
4026 putbit("inmodproc", 0);
4027 putbit("cudamodule", 0);
4028 putbit("fwdref", 0);
4029 putbit("aret", 0);
4030 putbit("vararg", VARARGG(sptr));
4031 putbit("has_opts", 0);
4032 putbit("parref", PARREFG(sptr));
4033 /*
4034 * emit this bit only if emitting ST_MODULE as ST_PROC
4035 * this conversion happens in putstype()
4036 */
4037 if (sptr != gbl.currsub)
4038 putbit("is_interface", IS_INTERFACEG(sptr));
4039
4040 strip = 1;
4041 }
4042 break;
4043 case ST_ENTRY:
4044 inmod = SCOPEG(sptr);
4045 if (inmod && STYPEG(inmod) == ST_ALIAS) {
4046 inmod = SCOPEG(inmod);
4047 }
4048 if (!INMODULEG(sptr) || (inmod && STYPEG(inmod) != ST_MODULE)) {
4049 inmod = 0;
4050 }
4051 putbit("currsub", sptr == gbl.currsub);
4052 putbit("adjustable", ADJARRG(sptr));
4053 putbit("afterentry", AFTENTG(sptr));
4054 putsym("altname", ALTNAMEG(sptr));
4055 putbit("Cfunc", CFUNCG(sptr));
4056 putbit("decl", DCLDG(sptr));
4057 #if defined(TARGET_WIN)
4058 putval("dll", DLLG(sptr));
4059 #else
4060 putval("dll", 0);
4061 #endif
4062 #if defined(CUDAG)
4063 putval("cmode", CUDAG(sptr));
4064 #else
4065 putval("cmode", 0);
4066 #endif
4067 putval("end", ENDLINEG(sptr));
4068 putsym("inmodule", inmod);
4069 putval("line", FUNCLINEG(sptr));
4070 putbit("mscall", MSCALLG(sptr));
4071 putbit("pure", PUREG(sptr));
4072 putbit("recursive", RECURG(sptr));
4073 putsym("returnval", FVALG(sptr));
4074 putbit("passbyval", PASSBYVALG(sptr));
4075 putbit("passbyref", PASSBYREFG(sptr));
4076 putbit("stdcall", STDCALLG(sptr));
4077 putbit("decorate", DECORATEG(sptr));
4078 #ifdef CREFP
4079 putbit("cref", CREFG(sptr));
4080 putbit("nomixedstrlen", NOMIXEDSTRLENG(sptr));
4081 #else
4082 putbit("cref", 0);
4083 putbit("nomixedstrlen", 0);
4084 #endif
4085 cudaemu = 0;
4086 putval("cudaemu", cudaemu);
4087 fvalfirst = fvallast = 0;
4088 retdesc = CLASS_NONE;
4089 if (CFUNCG(sptr)) {
4090 retdesc = check_return(DTYPEG(FVALG(sptr)));
4091 if (retdesc != CLASS_MEM && retdesc != CLASS_PTR) {
4092 SCP(FVALG(sptr), SC_LOCAL); /* change retval from dummy to local */
4093 }
4094 } else if (CMPLXFUNC_C && FVALG(sptr) && DT_ISCMPLX(DTYPEG(FVALG(sptr)))) {
4095 SCP(FVALG(sptr), SC_LOCAL); /* change retval from dummy to local */
4096 }
4097 if (!POINTERG(sptr) && (retdesc == CLASS_NONE || retdesc == CLASS_MEM ||
4098 retdesc == CLASS_PTR)) {
4099 switch (DTY(dtype)) {
4100 case TY_CMPLX:
4101 case TY_DCMPLX:
4102 if (!CMPLXFUNC_C && FVALG(sptr))
4103 fvallast = 1;
4104 break;
4105 case TY_CHAR:
4106 case TY_NCHAR:
4107 if (FVALG(sptr) && !ADJLENG(FVALG(sptr)))
4108 fvallast = 1;
4109 break;
4110 case TY_DERIVED:
4111 case TY_STRUCT:
4112 if (FVALG(sptr))
4113 fvalfirst = 1;
4114 break;
4115 default:
4116 break;
4117 }
4118 }
4119 count = 0;
4120 altreturn = 0;
4121 params = DPDSCG(sptr);
4122 for (i = 0; i < (int)(PARAMCTG(sptr)); ++i) {
4123 if (aux.dpdsc_base[params + i]) {
4124 ++count;
4125 } else {
4126 ++altreturn;
4127 }
4128 }
4129 #if defined(ACCROUTG)
4130 putval("rout", ACCROUTG(sptr));
4131 routx = ACCROUTG(sptr);
4132 #else
4133 putval("rout", 0);
4134 #endif
4135 putval("paramcount", count + fvalfirst + fvallast);
4136 putval("altreturn", altreturn);
4137 putval("vtoff", VTOFFG(sptr));
4138 putval("invobj", INVOBJG(sptr));
4139 putbit("invobjinc", INVOBJINCG(sptr));
4140 putbit("class", CLASSG(sptr));
4141 putbit("denorm", gbl.denorm);
4142 putbit("aret", ARETG(sptr));
4143 putbit("vararg", 0);
4144 putbit("has_opts", has_opt_args(sptr) ? 1 : 0);
4145 if (fvalfirst) {
4146 putsym(NULL, FVALG(sptr));
4147 }
4148 for (i = 0; i < (int)(PARAMCTG(sptr)); ++i) {
4149 if (aux.dpdsc_base[params + i]) {
4150 putsym(NULL, aux.dpdsc_base[params + i]);
4151 }
4152 }
4153 if (fvallast) {
4154 putsym(NULL, FVALG(sptr));
4155 }
4156 strip = 1;
4157 break;
4158
4159 case ST_LABEL:
4160 putbit("ccsym", CCSYMG(sptr));
4161 putbit("assigned", ASSNG(sptr));
4162 putbit("format", FMTPTG(sptr));
4163 putbit("volatile", VOLG(sptr));
4164 putval("refs", RFCNTG(sptr));
4165 putval("agoto", AGOTOG(sptr));
4166 strip = 1;
4167 break;
4168
4169 case ST_MEMBER:
4170 putbit("ccsym", CCSYMG(sptr));
4171 putbit("s1", SDSCS1G(sptr));
4172 putbit("isdesc", DESCARRAYG(sptr));
4173 #ifdef SDSCCONTIGG
4174 putbit("contig", DESCARRAYG(sptr) ? SDSCCONTIGG(sptr) : 0);
4175 #else
4176 putbit("contig", 0);
4177 #endif
4178 putbit("contigattr", CONTIGATTRG(sptr));
4179 putbit("pointer", POINTERG(sptr) || ALLOCG(sptr));
4180 putval("address", ADDRESSG(sptr));
4181 if (DTY(dtype) == TY_ARRAY) {
4182 putsym("descriptor", SDSCG(sptr));
4183 } else if (DTYPEG(sptr) == DT_DEFERCHAR || DTYPEG(sptr) == DT_DEFERNCHAR) {
4184 putsym("descriptor", SDSCG(sptr));
4185 }
4186 #ifdef CLASSG
4187 else if (SDSCG(sptr) && (CLASSG(sptr) || FINALIZEDG(sptr))) {
4188 int sdsc_mem = SYMLKG(sptr);
4189 if (sdsc_mem == MIDNUMG(sptr)) {
4190 sdsc_mem = SYMLKG(sdsc_mem);
4191 if (PTRVG(sdsc_mem) || !DESCARRAYG(sdsc_mem))
4192 sdsc_mem = SYMLKG(sdsc_mem);
4193 }
4194 putsym("descriptor", sdsc_mem);
4195 }
4196 #endif
4197 else {
4198 putsym("descriptor", 0);
4199 }
4200 putbit("noconflict", VISIT2G(sptr));
4201 putsym("link", SYMLKG(sptr));
4202 if ((STYPEG(BINDG(sptr)) == ST_OPERATOR ||
4203 STYPEG(BINDG(sptr)) == ST_USERGENERIC)) {
4204 /* FS#17251: TBD - if bind is an ST_OPERATOR/ST_USERGENERIC, then
4205 * fill in with a type bound procedure or 0 if generic is
4206 * currently empty.
4207 */
4208 int mem;
4209 mem = get_specific_member(TBPLNKG(VTABLEG(sptr)), VTABLEG(sptr));
4210 putval("tbplnk", BINDG(mem));
4211 putval("vtable", VTABLEG(mem));
4212 putval("iface", 0);
4213 } else {
4214 char *vt = SYMNAME(VTABLEG(sptr));
4215 putval("tbplnk", BINDG(sptr));
4216 if (!IFACEG(sptr) && strlen(vt) > 4 &&
4217 strcmp(vt + (strlen(vt) - 4), "$tbp") == 0) {
4218 putval("vtable", 0);
4219 putval("iface", 0);
4220 } else {
4221 putval("vtable", (IFACEG(sptr)) ? 0 : VTABLEG(sptr));
4222 putval("iface", IFACEG(sptr));
4223 }
4224 }
4225 putbit("class", CLASSG(sptr));
4226 #if defined(TARGET_WIN)
4227 if (VTABLEG(sptr)) {
4228 putbit("mscall", MSCALLG(VTABLEG(sptr)));
4229 putbit("cref", CREFG(VTABLEG(sptr)));
4230 } else {
4231 putbit("mscall", MSCALLG(sptr));
4232 putbit("cref", CREFG(sptr));
4233 }
4234 #else
4235 putbit("mscall", 0);
4236 putbit("cref", 0);
4237 #endif
4238 putbit("allocattr", ALLOCATTRG(sptr));
4239 putbit("f90pointer", 0); /* need to remove FE legacy use of F90POINTER */
4240 #ifdef FINALG
4241 putval("final", (!ELEMENTALG(VTABLEG(sptr))) ? FINALG(sptr) : MAXDIMS + 2);
4242 #else
4243 putval("final", 0);
4244 #endif
4245 #ifdef FINALIZEDG
4246 putbit("finalized", FINALIZEDG(sptr));
4247 #else
4248 putbit("finalized", 0);
4249 #endif
4250 #ifdef KINDG
4251 putbit("kindparm", KINDG(sptr) != 0);
4252 #else
4253 putbit("kindparm", 0);
4254 #endif
4255 #ifdef LENPARMG
4256 putbit("lenparm", LENPARMG(sptr));
4257 #else
4258 putbit("lenparm", 0);
4259 #endif
4260 #ifdef TPALLOCG
4261 putbit("tpalloc", TPALLOCG(sptr));
4262 #else
4263 putbit("tpalloc", 0);
4264 #endif
4265 strip = 1;
4266 break;
4267
4268 case ST_MODPROC:
4269 /* fake a procedure */
4270 putsym("altname", 0);
4271 putbit("ccsym", 0);
4272 putbit("decl", 0);
4273 putval("dll", 0);
4274 putbit("dllexportmod", 0);
4275 putval("cmode", 0);
4276 putbit("func", 0);
4277 putsym("inmodule", 0);
4278 putbit("mscall", 0);
4279 putbit("needmod", 0);
4280 putbit("pure", 0);
4281 putbit("ref", 0);
4282 putbit("passbyval", 0);
4283 putbit("passbyref", 0);
4284 putbit("cstructret", 0);
4285 putbit("sdscsafe", 0);
4286 putbit("stdcall", 0);
4287 putbit("decorate", 0);
4288 putbit("cref", 0);
4289 putbit("nomixedstrlen", 0);
4290 putbit("typed", 0);
4291 putbit("recursive", 0);
4292 putval("returnval", 0);
4293 putbit("Cfunc", 0);
4294 putbit("uplevel", 0);
4295 putbit("internref", 0);
4296 putval("rout", 0);
4297 putval("paramcount", 0);
4298 putval("vtoff", 0);
4299 putval("invobj", 0);
4300 putbit("invobjinc", 0);
4301 putbit("class", 0);
4302 putbit("mlib", 0);
4303 putbit("clib", 0);
4304 putbit("inmodproc", 0);
4305 putbit("cudamodule", 0);
4306 putbit("fwdref", 0);
4307 putbit("aret", 0);
4308 putbit("vararg", 0);
4309 putbit("has_opts", 0);
4310 putbit("parref", 0);
4311 putbit("is_interface", 0);
4312 strip = 1;
4313 break;
4314
4315 case ST_NML:
4316 putval("line", NML_LINENO(CMEMFG(sptr)));
4317 putbit("ref", REFG(sptr));
4318 putval("plist", ADDRESSG(sptr));
4319 count = 0;
4320 for (i = CMEMFG(sptr); i; i = NML_NEXT(i)) {
4321 ++count;
4322 }
4323 putval("count", count);
4324 for (i = CMEMFG(sptr); i; i = NML_NEXT(i)) {
4325 putsym(NULL, NML_SPTR(i));
4326 }
4327 strip = 1;
4328 break;
4329
4330 case ST_PARAM:
4331 putbit("decl", DCLDG(sptr));
4332 putbit("private", PRIVATEG(sptr));
4333 putbit("ref", REFG(sptr));
4334 if (TY_ISWORD(DTY(dtype))) {
4335 putval("val", CONVAL1G(sptr));
4336 } else {
4337 putsym("sym", CONVAL1G(sptr));
4338 }
4339 strip = 1;
4340 break;
4341
4342 case ST_PLIST:
4343 putbit("ccsym", CCSYMG(sptr));
4344 putbit("init", DINITG(sptr));
4345 /*if( SCOPEG(sptr) == stb.curr_scope ){
4346 putbit( "init", DINITG(sptr) );
4347 }else{
4348 putbit( "init", 0 );
4349 }*/
4350 putbit("ref", 0); /* ref bit needs to be zero, so an address
4351 * can be assigned */
4352 if (gbl.internal <= 1 || INTERNALG(sptr)) {
4353 /* for outer procedures, all symbols are not uplevel */
4354 putbit("uplevel", 0);
4355 putbit("internref", 0);
4356 } else {
4357 putbit("uplevel", 1);
4358 if (INTERNREFG(sptr))
4359 putbit("internref", 1);
4360 else
4361 putbit("internref", 0);
4362 }
4363 putbit("parref", PARREFG(sptr));
4364 putval("count", PLLENG(sptr));
4365 putval("etls", ETLSG(sptr));
4366 putbit("tls", TLSG(sptr));
4367 strip = 1;
4368 break;
4369
4370 case ST_PROC:
4371 inmod = SCOPEG(sptr);
4372 if (inmod && STYPEG(inmod) == ST_ALIAS) {
4373 inmod = SCOPEG(inmod);
4374 }
4375 if (inmod && STYPEG(inmod) == ST_MODULE) {
4376 if (strcmp(SYMNAME(inmod), "cudadevice") == 0)
4377 cudamodule = 1;
4378 }
4379 if (!INMODULEG(sptr) || (inmod && STYPEG(inmod) != ST_MODULE)) {
4380 /* not actually in the module */
4381 inmod = 0;
4382 }
4383 putsym("altname", ALTNAMEG(sptr));
4384 putbit("ccsym", CCSYMG(sptr) || HCCSYMG(sptr));
4385 putbit("decl", DCLDG(sptr));
4386 dll = 0;
4387 #if defined(TARGET_WIN)
4388 if (SCG(sptr) != SC_DUMMY)
4389 dll = DLLG(sptr);
4390 #endif
4391 putval("dll", dll);
4392 putbit("dllexportmod", 0);
4393 #if defined(CUDAG)
4394 putval("cmode", CUDAG(sptr));
4395 #else
4396 putval("cmode", 0);
4397 #endif
4398 putbit("func", FUNCG(sptr));
4399 putsym("inmodule", inmod);
4400 putbit("mscall", MSCALLG(sptr));
4401 putbit("needmod", 0);
4402 putbit("pure", PUREG(sptr));
4403 putbit("ref", REFG(sptr));
4404 putbit("passbyval", PASSBYVALG(sptr));
4405 putbit("passbyref", PASSBYREFG(sptr));
4406 putbit("cstructret", CSTRUCTRETG(sptr));
4407 putbit("sdscsafe", SDSCSAFEG(sptr));
4408 putbit("stdcall", STDCALLG(sptr));
4409 putbit("decorate", DECORATEG(sptr));
4410 #ifdef CREFP
4411 putbit("cref", CREFG(sptr));
4412 putbit("nomixedstrlen", NOMIXEDSTRLENG(sptr));
4413 #else
4414 putbit("cref", 0);
4415 putbit("nomixedstrlen", 0);
4416 #endif
4417 putbit("typed", TYPDG(sptr));
4418 putbit("recursive", RECURG(sptr));
4419 putsym("returnval", FVALG(sptr));
4420 putbit("Cfunc", CFUNCG(sptr));
4421 if (SCG(sptr) != SC_DUMMY || gbl.internal <= 1 || INTERNALG(sptr)) {
4422 /* nondummy procedures are not uplevel; dummy
4423 * outer procedures, all symbols are not uplevel.
4424 */
4425 putbit("uplevel", 0);
4426 putbit("internref", 0);
4427 } else {
4428 /* dummy procedure, defined in host */
4429 putbit("uplevel", 1);
4430 if (INTERNREFG(sptr))
4431 putbit("internref", 1);
4432 else
4433 putbit("internref", 0);
4434 }
4435
4436 if (gbl.stbfil && DTY(DTYPEG(sptr) + 2)) {
4437 /* Need to do this earlier so that it lowers the descriptor */
4438 fvalfirst = fvallast = 0;
4439 retdesc = CLASS_NONE;
4440 if (CFUNCG(sptr)) {
4441 retdesc = check_return(DTYPEG(FVALG(sptr)));
4442 if (retdesc != CLASS_MEM && retdesc != CLASS_PTR) {
4443 /* retval is sc_local */
4444 }
4445 }
4446 if (!POINTERG(sptr) && (retdesc == CLASS_NONE || retdesc == CLASS_MEM ||
4447 retdesc == CLASS_PTR)) {
4448 switch (DTY(dtype)) {
4449 case TY_CMPLX:
4450 case TY_DCMPLX:
4451 if (FVALG(sptr))
4452 fvallast = 1;
4453 break;
4454 case TY_CHAR:
4455 case TY_NCHAR:
4456 if (FVALG(sptr) && !ADJLENG(FVALG(sptr)))
4457 fvallast = 1;
4458 break;
4459 case TY_DERIVED:
4460 case TY_STRUCT:
4461 if (FVALG(sptr))
4462 fvalfirst = 1;
4463 break;
4464 default:
4465 break;
4466 }
4467 }
4468 count = 0;
4469 altreturn = 0;
4470 params = DPDSCG(sptr);
4471 for (i = 0; i < (int)(PARAMCTG(sptr)); ++i) {
4472 if (aux.dpdsc_base[params + i]) {
4473 ++count;
4474 } else {
4475 ++altreturn;
4476 }
4477 }
4478 }
4479
4480 #if defined(ACCROUTG)
4481 putval("rout", ACCROUTG(sptr));
4482 routx = ACCROUTG(sptr);
4483 #else
4484 putval("rout", 0);
4485 #endif
4486 if (gbl.stbfil && DTY(DTYPEG(sptr) + 2))
4487 putval("paramcount", count + fvalfirst + fvallast);
4488 else
4489 putval("paramcount", 0);
4490 putval("vtoff", VTOFFG(sptr));
4491 putval("invobj", INVOBJG(sptr));
4492 putbit("invobjinc", INVOBJINCG(sptr));
4493 putbit("class", CLASSG(sptr));
4494 #ifdef LIBMG
4495 putbit("mlib", LIBMG(sptr));
4496 putbit("clib", LIBCG(sptr));
4497 #else
4498 putbit("mlib", 0);
4499 putbit("clib", 0);
4500 #endif
4501 putbit("inmodproc", SYMIG(sptr));
4502 putbit("cudamodule", cudamodule);
4503 putbit("fwdref", (inmod && IGNOREG(sptr)));
4504 putbit("aret", ARETG(sptr));
4505 putbit("vararg", 0);
4506 putbit("has_opts", has_opt_args(sptr) ? 1 : 0);
4507 putbit("parref", PARREFG(sptr));
4508 putbit("is_interface", IS_INTERFACEG(sptr));
4509 if (SCG(sptr) == SC_DUMMY)
4510 putval("descriptor", IS_PROC_DUMMYG(sptr) ? SDSCG(sptr) : 0);
4511 if (gbl.stbfil && DTY(DTYPEG(sptr) + 2)) {
4512 if (fvalfirst) {
4513 putsym(NULL, FVALG(sptr));
4514 }
4515 for (i = 0; i < (int)(PARAMCTG(sptr)); ++i) {
4516 if (aux.dpdsc_base[params + i]) {
4517 putsym(NULL, aux.dpdsc_base[params + i]);
4518 }
4519 }
4520 if (fvallast) {
4521 putsym(NULL, FVALG(sptr));
4522 }
4523 }
4524 strip = 1;
4525 break;
4526
4527 case ST_TYPEDEF:
4528 putbit("frommod", FROMMODG(sptr));
4529 #if !defined(PARENTG)
4530 putval("parent", 0);
4531 putval("descriptor", 0);
4532 putbit("class", 0);
4533 if (all_default_init(DTYPEG(sptr))) {
4534 putbit("alldefaultinit", 1);
4535 } else {
4536 putbit("alldefaultinit", 0);
4537 }
4538 putbit("unlpoly", 0);
4539 putbit("isocbind", 0);
4540 #else
4541 putval("parent", PARENTG(sptr));
4542 putval("descriptor", SDSCG(sptr));
4543 putbit("class", CLASSG(sptr));
4544 if (all_default_init(DTYPEG(sptr))) {
4545 putbit("alldefaultinit", 1);
4546 } else {
4547 putbit("alldefaultinit", 0);
4548 }
4549 putbit("unlpoly", UNLPOLYG(sptr));
4550 putbit("isoctype", ISOCTYPEG(sptr));
4551 putval("typedef_init", TYPDEF_INITG(sptr));
4552 #endif
4553 strip = 1;
4554 break;
4555
4556 case ST_GENERIC:
4557 putval("gsame", -1);
4558 putval("count", -1);
4559 strip = 1;
4560 break;
4561 case ST_USERGENERIC:
4562 putval("gsame", GSAMEG(sptr));
4563 count = 0;
4564 for (desc = GNDSCG(sptr); desc; desc = SYMI_NEXT(desc)) {
4565 int s = SYMI_SPTR(desc);
4566 if (VISITG(s))
4567 ++count;
4568 }
4569 putval("count", count);
4570 for (desc = GNDSCG(sptr); desc; desc = SYMI_NEXT(desc)) {
4571 int s = SYMI_SPTR(desc);
4572 if (VISITG(s)) {
4573 putsym(NULL, s);
4574 }
4575 }
4576 strip = 1;
4577 break;
4578
4579 case ST_INTRIN:
4580 case ST_PD:
4581 case ST_STAG:
4582 break;
4583
4584 case ST_UNKNOWN:
4585 case ST_IDENT:
4586 case ST_STFUNC:
4587 case ST_ISOC:
4588 case ST_ISOFTNENV:
4589 case ST_ARRDSC:
4590 case ST_ALIAS:
4591 case ST_OPERATOR:
4592 case ST_CONSTRUCT:
4593 case ST_CRAY:
4594 break;
4595
4596 case ST_BLOCK:
4597 putsym("enclfunc", ENCLFUNCG(sptr));
4598 putval("startline", STARTLINEG(sptr));
4599 putval("end", ENDLINEG(sptr));
4600 putsym("startlab", STARTLABG(sptr));
4601 putsym("endlab", ENDLABG(sptr));
4602 #ifdef PARUPLEVELG
4603 putval("paruplevel", PARUPLEVELG(sptr));
4604 #endif
4605 if (PARSYMSG(sptr)) {
4606 LLUplevel *up = llmp_get_uplevel(sptr);
4607 int count = 0;
4608 putval("parent", up->parent);
4609 /* recount parsymsct, don't count ST_ARRDSC */
4610 for (i = 0; i < up->vals_count; ++i) {
4611 if (up->vals[i] && STYPEG(up->vals[i]) == ST_ARRDSC)
4612 count++;
4613 }
4614 putval("parsymsct", (up->vals_count - count));
4615 for (i = 0; i < up->vals_count; ++i) {
4616 if (up->vals[i] && STYPEG(up->vals[i]) == ST_ARRDSC)
4617 continue;
4618 putsym(NULL, up->vals[i]);
4619 }
4620 } else {
4621 LLUplevel *up = llmp_has_uplevel(sptr);
4622 if (up) {
4623 putval("parent", up->parent);
4624 } else {
4625 putval("parent", 0);
4626 }
4627 putval("parsymsct", 0);
4628 }
4629
4630 strip = 1;
4631 break;
4632 }
4633 if (name == NULL && sptr >= first_temp) {
4634 sprintf(tempname, "T$%d", sptr);
4635 namelen = strlen(tempname);
4636 name = tempname;
4637 }
4638 if (namelen > 0 && strip) {
4639 while (name[namelen - 1] == ' ')
4640 --namelen;
4641 }
4642 fprintf(lowersym.lowerfile, " %d:", namelen);
4643 if (namelen > 0) {
4644 if (newline) {
4645 putc('\n', lowersym.lowerfile);
4646 putc('=', lowersym.lowerfile);
4647 while (namelen) {
4648 int namec;
4649 namec = *name;
4650 namec = namec & 0xff;
4651 fprintf(lowersym.lowerfile, "%2.2x", namec);
4652 /* yes, this could be all on one line, but a good compiler
4653 * should generate good code nevertheless.
4654 * [end of patronizing religious proselytizing] */
4655 ++name;
4656 --namelen;
4657 }
4658 } else {
4659 /* printf doesn't work, since the 'name' can have embedded '\0's */
4660 while (namelen) {
4661 putc(*name, lowersym.lowerfile);
4662 /* yes, this could be all on one line, but a good compiler
4663 * should generate good code nevertheless.
4664 * [end of patronizing religious proselytizing] */
4665 ++name;
4666 --namelen;
4667 }
4668 }
4669 }
4670 fprintf(lowersym.lowerfile, "\n");
4671 } /* lower_symbol */
4672
4673 /* lower symbol to ilm file and optionally to stb file */
4674 static void
lower_symbol_stb(int sptr)4675 lower_symbol_stb(int sptr)
4676 {
4677 lower_symbol(sptr);
4678 if (STB_LOWER()) {
4679 FILE *tmpfile = lowersym.lowerfile;
4680 lowersym.lowerfile = gbl.stbfil;
4681 lower_symbol(sptr);
4682 lowersym.lowerfile = tmpfile;
4683 }
4684 }
4685
4686 /* If the _V_ passbyvalue variable has been marked
4687 VISITP, then propagate that info to the corresping
4688 SC_LOCAL variable
4689 */
4690 static void
propagate_byval_visit(int sptr)4691 propagate_byval_visit(int sptr)
4692 {
4693 char *name;
4694 int origptr;
4695
4696 if (!PASSBYVALG(sptr) || !VISITG(sptr))
4697 return;
4698 origptr = MIDNUMG(sptr);
4699 if (origptr) {
4700 VISITP(origptr, 1);
4701 return;
4702 }
4703 name = SYMNAME(sptr);
4704
4705 if (SCG(sptr) == SC_DUMMY && SCOPEG(sptr) != gbl.currsub)
4706 return;
4707 }
4708
4709 void
lower_symbols(void)4710 lower_symbols(void)
4711 {
4712 SPTR sptr;
4713 FILE *tfile;
4714 bool is_interface;
4715 SPTR scope;
4716
4717 if (OUTPUT_DWARF)
4718 scan_for_dwarf_module();
4719
4720 for (sptr = 1; sptr < stb.stg_avail; ++sptr) {
4721 if (SCG(sptr) == SC_DUMMY)
4722 propagate_byval_visit(sptr);
4723
4724 if (FVALG(gbl.currsub) == sptr) {
4725 if (CFUNCG(gbl.currsub) || (CMPLXFUNC_C && DT_ISCMPLX(DTYPEG(sptr)))) {
4726 SCP(sptr, SC_LOCAL);
4727 }
4728 }
4729 if (VISITG(sptr) && STYPEG(sptr) == ST_ALIAS) {
4730 /* do not lower ST_ALIAS */
4731 int sptr2 = SYMLKG(sptr);
4732 VISITP(sptr, 0);
4733 if (sptr2 > NOSYM) {
4734 VISITP(sptr2, 1);
4735 if (sptr2 < sptr) {
4736 lower_symbol_stb(sptr2);
4737 VISIT2P(sptr2, 0);
4738 }
4739 }
4740 }
4741 if (VISITG(sptr) && STYPEG(sptr) == ST_TYPEDEF && BASETYPEG(sptr)) {
4742 lower_put_datatype_stb(BASETYPEG(sptr));
4743 }
4744 if (VISITG(sptr) && is_procedure_ptr(sptr)) {
4745 /* make sure we lower type and subtype of procedure ptr */
4746 int dtype = DTYPEG(sptr);
4747 lower_put_datatype_stb(dtype);
4748 lower_put_datatype_stb(DTY(dtype + 1));
4749 }
4750 scope = SCOPEG(sptr);
4751 is_interface = ((STYPEG(scope) == ST_PROC || STYPEG(scope) == ST_ENTRY) &&
4752 IS_INTERFACEG(scope));
4753
4754 if (!is_interface && STYPEG(sptr) == ST_TYPEDEF) {
4755 SPTR tag = DTY(DTYPEG(sptr) + 3);
4756 if (!VISITG(tag)) {
4757 SPTR sdsc = SDSCG(tag);
4758 lower_put_datatype_stb(DTYPEG(tag));
4759 lower_symbol_stb(tag);
4760 VISITP(tag, 1);
4761 if (sdsc && !VISITG(sdsc)) {
4762 VISITP(sdsc, 1);
4763 lower_put_datatype_stb(DTYPEG(sdsc));
4764 }
4765 }
4766 } else if (!VISITG(sptr) && CLASSG(sptr) && DESCARRAYG(sptr) &&
4767 STYPEG(sptr) == ST_DESCRIPTOR) {
4768 if (PARENTG(sptr) && !is_interface) {
4769 /* Only perform this if PARENT is set. Also do not create type
4770 * descriptors for derived types defined inside interfaces. When
4771 * derived types are defined inside interfaces, type descriptors are
4772 * not needed because there is no executable code inside an interface.
4773 * Furthermore, if we generate them, we might get multiple definitions
4774 * of the same type descriptor.
4775 */
4776 lower_put_datatype_stb(DTYPEG(sptr));
4777 VISITP(sptr, 1);
4778 lower_symbol_stb(sptr);
4779 VISIT2P(sptr, 0);
4780 lower_put_datatype_stb(PARENTG(sptr));
4781 }
4782 } else if (!VISITG(sptr) && STYPEG(sptr) == ST_MEMBER && FINALG(sptr)) {
4783 int vt = VTABLEG(sptr);
4784 lower_put_datatype_stb(ENCLDTYPEG(sptr));
4785 VISITP(sptr, 1);
4786 lower_symbol_stb(sptr);
4787 VISIT2P(sptr, 0);
4788 if (INMODULEG(vt) && !VISITG(vt)) {
4789 VISITP(vt, 1);
4790 if (vt < sptr) {
4791 lower_symbol_stb(vt);
4792 }
4793 VISIT2P(vt, 0);
4794 }
4795 } else if (/*!VISITG(sptr) &&*/ CLASSG(sptr) && DESCARRAYG(sptr) &&
4796 STYPEG(sptr) == ST_DESCRIPTOR &&
4797 (!UNLPOLYG(sptr) || STYPEG(SCOPEG(sptr)) != ST_MODULE)) {
4798 /* this occurs when we have a parent type descriptor
4799 * that's not directly used but we still need to
4800 * generate it for its children types.
4801 */
4802 VISITP(sptr, 1);
4803 lower_put_datatype_stb(DTYPEG(sptr));
4804 lower_put_datatype_stb(PARENTG(sptr));
4805 } else if (!CLASSG(sptr) && !VISITG(sptr) && STYPEG(sptr) == ST_MEMBER) {
4806 /* FS#18558 - need to lower members if derived type
4807 * contains type bound procedures. Otherwise, we may
4808 * not be able to generate "virtual function tables".
4809 */
4810 int dtype = ENCLDTYPEG(sptr);
4811 if (has_tbp_or_final(dtype)) {
4812 int mem;
4813 lower_put_datatype_stb(dtype);
4814 for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
4815 int dt_mem = DTYPEG(mem);
4816 lower_put_datatype_stb(dt_mem);
4817 if (DTY(dt_mem) == TY_ARRAY) {
4818 /* FS#19034 - must also lower array subtype */
4819 lower_put_datatype_stb(DTY(dt_mem + 1));
4820 }
4821 if (0 && mem != sptr) {
4822 lower_symbol_stb(mem);
4823 }
4824 VISITP(mem, 1);
4825 }
4826 }
4827
4828 } else if (CLASSG(sptr) && CCSYMG(sptr) && STYPEG(sptr) == ST_MEMBER) {
4829 int bind = BINDG(sptr);
4830 int vt = VTABLEG(sptr);
4831 if (STYPEG(vt) == ST_PROC || STYPEG(vt) == ST_ENTRY ||
4832 STYPEG(vt) == ST_OPERATOR || STYPEG(vt) == ST_USERGENERIC ||
4833 STYPEG(vt) == ST_MODPROC) {
4834 if (vt && !VISITG(vt) && !IFACEG(sptr)) {
4835 STYPEP(vt, ST_PROC);
4836 CCSYMP(vt, 0);
4837 VISITP(vt, 1);
4838 lower_put_datatype_stb(DTYPEG(vt));
4839 if (bind && vt < sptr) {
4840 lower_symbol_stb(vt);
4841 }
4842 VISIT2P(vt, 0);
4843 }
4844 if (bind && !VISITG(bind) && STYPEG(bind) == ST_PROC) {
4845 VISITP(bind, 1);
4846 lower_put_datatype_stb(DTYPEG(bind));
4847 lower_symbol_stb(bind);
4848 VISIT2P(bind, 0);
4849 }
4850 }
4851 } else if (!VISITG(sptr) && STYPEG(sptr) == ST_TYPEDEF && SDSCG(sptr) &&
4852 CLASSG(SDSCG(sptr)) && !PARENTG(sptr)) {
4853 /* Force generation of type descriptors in the mod object file */
4854 VISITP(sptr, 1);
4855 lower_put_datatype_stb(DTYPEG(sptr));
4856 } else if (flg.debug && !VISITG(sptr) && STYPEG(sptr) == ST_PARAM) {
4857 /* lower parameter in module for debugging purpose */
4858 int sym = 0;
4859 if (!ENCLFUNCG(sptr) || !SCOPEG(sptr))
4860 continue;
4861 if (ENCLFUNCG(sptr) && !NEEDMODG(ENCLFUNCG(sptr))) {
4862 continue;
4863 } else if (SCOPEG(sptr) && !NEEDMODG(SCOPEG(sptr))) {
4864 continue;
4865 }
4866 if (DTY(DTYPEG(sptr)) == TY_ARRAY || DTY(DTYPEG(sptr)) == TY_DERIVED)
4867 sym = CONVAL1G(sptr);
4868 else if (CONVAL2G(sptr))
4869 sym = sym_of_ast(CONVAL2G(sptr));
4870 if (sym && VISITG(sym)) {
4871 VISITP(sptr, 1);
4872 lower_put_datatype_stb(DTYPEG(sptr));
4873 }
4874 }
4875 else if (VISITG(sptr)) {
4876 int scope = SCOPEG(sptr);
4877 if (scope && STYPEG(scope) == ST_PROC && FVALG(scope) == sptr) {
4878 lower_put_datatype_stb(DTYPEG(sptr));
4879 }
4880 }
4881
4882 if (VISITG(sptr)) {
4883 lower_symbol_stb(sptr);
4884 }
4885 VISIT2P(sptr, 0);
4886
4887 /* Unfreeze intrinsics for re/use in internal routines.
4888 *
4889 * This isn't quite right. It favors declarations in an internal routine
4890 * at the possible expense of cases where a host routine declaration
4891 * should be accessible in an internal routine. It might be useful to
4892 * have multiple freeze bits, such as one for a host routine and one
4893 * for the current internal routine. That would allow more accurate
4894 * diagnosis of errors in internal routines.
4895 *
4896 * Unfortunately, multiple bits would require analysis of existing cases
4897 * where the bit is set and referenced, and there is a combinatorial
4898 * explosion of cases mixing various declarations and uses. For the LEN
4899 * intrinsic, for example, some possible declaration cases are:
4900 *
4901 * - INTEGER :: LEN ! (ambiguous) LEN may be a var or an intrinsic
4902 * - INTEGER, INTRINISC :: LEN ! LEN is an intrinsic
4903 * - <no declaration> -- (first) use determines what LEN is
4904 *
4905 * Some reference possibilities are:
4906 *
4907 * - LEN() is an (intrinsic) function call
4908 * - LEN is a (scalar) var reference
4909 *
4910 * These declarations and references can be present in any combination
4911 * in a host routine, in an internal routine, or both. Many of these
4912 * combinations are valid, but not all. Compilation currently mishandles
4913 * some of these variants. The choice to clear the "freeze" bit here is
4914 * a compromise attempt intended to favor correct compilation of valid
4915 * programs above diagnosis of error cases.
4916 */
4917 if (IS_INTRINSIC(STYPEG(sptr)))
4918 EXPSTP(sptr, 0);
4919 }
4920 if (gbl.internal > 1) {
4921 for (sptr = gbl.outerentries; sptr > NOSYM; sptr = SYMLKG(sptr)) {
4922 if (sptr != gbl.outersub) {
4923 putival("Entry", sptr);
4924 fprintf(lowersym.lowerfile, "\n");
4925 if (STB_LOWER())
4926 fprintf(gbl.stbfil, "\n");
4927 }
4928 }
4929 }
4930 if (XBIT(53, 2)) {
4931 lower_pstride_info(lowersym.lowerfile);
4932 if (STB_LOWER())
4933 lower_pstride_info(gbl.stbfil);
4934 }
4935 for (sptr = 1; sptr < stb.stg_avail; ++sptr) {
4936 int socptr;
4937 if (!VISITG(sptr))
4938 continue;
4939 switch (STYPEG(sptr)) {
4940 case ST_VAR:
4941 case ST_ARRAY:
4942 socptr = SOCPTRG(sptr);
4943 if (socptr) {
4944 int s, n;
4945 n = 0;
4946 for (s = socptr; s; s = SOC_NEXT(s)) {
4947 ++n;
4948 }
4949 #if DEBUG
4950 if (DBGBIT(47, 8) && sptr > NOSYM) {
4951 fprintf(lowersym.lowerfile, "overlap:%s", getprint(sptr));
4952 } else
4953 #endif
4954 putival("overlap", sptr);
4955 putval("count", n);
4956 if (STB_LOWER()) {
4957 tfile = lowersym.lowerfile;
4958 lowersym.lowerfile = gbl.stbfil;
4959 if (DBGBIT(47, 8) && sptr > NOSYM)
4960 fprintf(gbl.stbfil, "overlap:%s", getprint(sptr));
4961 else
4962 putival("overlap", sptr);
4963 putval("count", n);
4964 lowersym.lowerfile = tfile;
4965 }
4966 for (s = socptr; s; s = SOC_NEXT(s)) {
4967 int overlap;
4968 overlap = SOC_SPTR(s);
4969 #if DEBUG
4970 if (DBGBIT(47, 8) && overlap > NOSYM) {
4971 fprintf(lowersym.lowerfile, " %s", getprint(overlap));
4972 if (STB_LOWER())
4973 fprintf(gbl.stbfil, " %s", getprint(overlap));
4974 } else
4975 #endif
4976 {
4977 fprintf(lowersym.lowerfile, " %d", overlap);
4978 if (STB_LOWER())
4979 fprintf(gbl.stbfil, " %d", overlap);
4980 }
4981 }
4982 fprintf(lowersym.lowerfile, "\n");
4983 if (STB_LOWER())
4984 fprintf(gbl.stbfil, "\n");
4985 }
4986 break;
4987 default:
4988 break;
4989 }
4990 }
4991 /* restore TY_PTR stuff to its original type */
4992 for (sptr = stb.firstosym; sptr < stb.stg_avail; ++sptr) {
4993 int dtype;
4994 switch (STYPEG(sptr)) {
4995 case ST_MEMBER:
4996 dtype = DTYPEG(sptr);
4997 if (DTY(dtype) == TY_PTR && dtype != DT_ADDR &&
4998 DTY(DTY(dtype + 1)) != TY_PROC) {
4999 DTYPEP(sptr, DTY(dtype + 1));
5000 }
5001 break;
5002 default:;
5003 }
5004 if (DTY(DTYPEG(sptr)) == TY_ARRAY && LNRZDG(sptr) && XBIT(52, 4)) {
5005 /* restore the old linearized datatype from the stashed type */
5006 dtype = DTYPEG(sptr);
5007 dtype = -DTY(dtype - 1);
5008 DTYPEP(sptr, dtype);
5009 }
5010 }
5011 for (sptr = stb.firstosym; sptr < stb.stg_avail; ++sptr) {
5012 /* restore data types of procedures/entries */
5013 if (STYPEG(sptr) == ST_PROC || STYPEG(sptr) == ST_ENTRY) {
5014 if (FVALG(sptr)) {
5015 DTYPEP(sptr, DTYPEG(FVALG(sptr)));
5016 }
5017 }
5018 }
5019 } /* lower_symbols */
5020
5021 /** \brief Reset temps for next statement */
5022 void
lower_reset_temps(void)5023 lower_reset_temps(void)
5024 {
5025 int sptr, nextsptr;
5026 for (sptr = first_used_scalarptr_temp; sptr > NOSYM; sptr = nextsptr) {
5027 nextsptr = SYMLKG(sptr);
5028 SYMLKP(sptr, first_avail_scalarptr_temp);
5029 first_avail_scalarptr_temp = sptr;
5030 }
5031 first_used_scalarptr_temp = 0;
5032 for (sptr = first_used_scalar_temp; sptr > NOSYM; sptr = nextsptr) {
5033 nextsptr = SYMLKG(sptr);
5034 SYMLKP(sptr, first_avail_scalar_temp);
5035 first_avail_scalar_temp = sptr;
5036 }
5037 first_used_scalar_temp = 0;
5038 } /* lower_reset_temps */
5039
5040 /** \brief Return a symbol which is a temp scalar of DTYPE 'dtype' */
5041 int
lower_scalar_temp(int dtype)5042 lower_scalar_temp(int dtype)
5043 {
5044 int sptr, lastsptr, nextsptr;
5045 for (lastsptr = 0, sptr = first_avail_scalar_temp; sptr > NOSYM;
5046 lastsptr = sptr, sptr = nextsptr) {
5047 nextsptr = SYMLKG(sptr);
5048
5049 if (DTYPEG(sptr) == dtype && SCG(sptr) == lowersym.sc) {
5050 /* remove from this list, add to 'used' list, return it */
5051 if (lastsptr) {
5052 SYMLKP(lastsptr, nextsptr);
5053 } else {
5054 first_avail_scalar_temp = nextsptr;
5055 }
5056 SYMLKP(sptr, first_used_scalar_temp);
5057 first_used_scalar_temp = sptr;
5058 return sptr;
5059 }
5060 }
5061 /* make a 'dtype' variable to be the temp */
5062 sptr = getccsym_sc('C', ++lowersym.Ccount, ST_VAR, lowersym.sc);
5063 DTYPEP(sptr, dtype);
5064 SYMLKP(sptr, first_used_scalar_temp);
5065 if (gbl.internal > 1)
5066 INTERNALP(sptr, 1);
5067 first_used_scalar_temp = sptr;
5068 return sptr;
5069 } /* lower_scalar_temp */
5070
5071 /** \brief For an ST_MEMBER of an anonymous structure/union,
5072 fill member_parent[sptr] with the symbol name of
5073 its parent structure
5074 */
5075 void
lower_fill_member_parent(void)5076 lower_fill_member_parent(void)
5077 {
5078 int sptr;
5079 for (sptr = stb.firstosym; sptr < stb.stg_avail; ++sptr) {
5080 int tag, s;
5081 int dtype = DTYPEG(sptr);
5082 switch (DTY(dtype)) {
5083 case TY_DERIVED:
5084 case TY_STRUCT:
5085 case TY_UNION:
5086 tag = DTY(dtype + 3);
5087 if (tag == 0) {
5088 /* look through the linked list of members;
5089 * make each member point back to this tag */
5090 for (s = DTY(dtype + 1); s > NOSYM; s = SYMLKG(s)) {
5091 if (LOWER_MEMBER_PARENT(s)) {
5092 lerror("symbol %s (%d) appears in two anonymous structs",
5093 SYMNAME(s), s);
5094 }
5095 LOWER_MEMBER_PARENT(s) = sptr;
5096 }
5097 }
5098 break;
5099 default:
5100 break;
5101 }
5102 }
5103 } /* lower_fill_member_parent */
5104
5105 void
lower_mark_entries(void)5106 lower_mark_entries(void)
5107 {
5108 int ent;
5109 /* always mark the current routine or block data, ... */
5110 lower_visit_symbol(gbl.currsub);
5111
5112 /* mark any entry points, also */
5113 for (ent = gbl.entries; ent > NOSYM; ent = SYMLKG(ent)) {
5114 int params, i;
5115 lower_visit_symbol(ent);
5116 /* mark any parameters, unless a module name */
5117 if (STYPEG(ent) != ST_MODULE) {
5118 params = DPDSCG(ent);
5119 for (i = 0; i < (int)(PARAMCTG(ent)); ++i) {
5120 int parm = aux.dpdsc_base[params + i];
5121 if (parm) {
5122 lower_visit_symbol(parm);
5123 }
5124 }
5125 }
5126 }
5127 if (gbl.internal > 1) {
5128 if (lowersym.outersub) {
5129 lower_visit_symbol(lowersym.outersub);
5130 }
5131 for (ent = gbl.outerentries; ent > NOSYM; ent = SYMLKG(ent)) {
5132 int params, i;
5133 lower_visit_symbol(ent);
5134 /* mark any parameters, unless a module name */
5135 params = DPDSCG(ent);
5136 for (i = 0; i < (int)(PARAMCTG(ent)); ++i) {
5137 int parm = aux.dpdsc_base[params + i];
5138 if (parm) {
5139 lower_visit_symbol(parm);
5140 }
5141 }
5142 }
5143 }
5144 } /* lower_mark_entries */
5145
5146 int
lower_lab(void)5147 lower_lab(void)
5148 {
5149 int lab;
5150 lab = getlab();
5151 RFCNTP(lab, 0);
5152 return lab;
5153 } /* lower_lab */
5154
5155 int
lowersym_pghpf_cmem(int * whichmem)5156 lowersym_pghpf_cmem(int *whichmem)
5157 {
5158 int ptr;
5159 int base;
5160
5161 if (*whichmem == 0)
5162 lower_add_pghpf_commons();
5163
5164 if (!XBIT(57, 0x8000)) {
5165 if (whichmem == &lowersym.ptr0)
5166 return plower("oS", "ACON", *whichmem);
5167 if (whichmem == &lowersym.ptr0c)
5168 return plower("oS", "ACON", *whichmem);
5169 }
5170
5171 if (!XBIT(70, 0x80000000))
5172 return plower("oS", "BASE", *whichmem);
5173
5174 ptr = MIDNUMG(*whichmem);
5175 base = plower("oS", "BASE", ptr);
5176 return plower("oiS", "PLD", base, *whichmem);
5177 }
5178
5179 /* Checks to see if array bound ast is an expression that uses a type parameter.
5180 * This function is mirrored in semutil2.c.
5181 * TO DO: Move this function to dtypeutl.c, make it extern, and remove the
5182 * instance in semutil2.c.
5183 */
5184 static int
valid_kind_parm_expr(int ast)5185 valid_kind_parm_expr(int ast)
5186 {
5187 int sptr, rslt, i;
5188
5189 if (!ast)
5190 return 0;
5191
5192 switch (A_TYPEG(ast)) {
5193 case A_INTR:
5194 switch (A_OPTYPEG(ast)) {
5195 case I_INT1:
5196 case I_INT2:
5197 case I_INT4:
5198 case I_INT8:
5199 case I_INT:
5200 i = A_ARGSG(ast);
5201 return valid_kind_parm_expr(ARGT_ARG(i, 0));
5202 }
5203 break;
5204 case A_CNST:
5205 return 1;
5206 case A_MEM:
5207 sptr = memsym_of_ast(ast);
5208 if (KINDG(sptr))
5209 return 1;
5210 return 0;
5211 case A_ID:
5212 sptr = A_SPTRG(ast);
5213 if (KINDG(sptr))
5214 return 1;
5215 return 0;
5216 case A_CONV:
5217 case A_UNOP:
5218 return valid_kind_parm_expr(A_LOPG(ast));
5219 case A_BINOP:
5220 rslt = valid_kind_parm_expr(A_LOPG(ast));
5221 if (!rslt)
5222 return 0;
5223 rslt = valid_kind_parm_expr(A_ROPG(ast));
5224 if (!rslt)
5225 return 0;
5226 return 1;
5227 }
5228 return 0;
5229 }
5230
5231 static int
is_descr_expression(int ast)5232 is_descr_expression(int ast)
5233 {
5234
5235 int sptr, rslt, i;
5236
5237 if (!ast)
5238 return 0;
5239
5240 switch (A_TYPEG(ast)) {
5241 case A_INTR:
5242 switch (A_OPTYPEG(ast)) {
5243 case I_INT1:
5244 case I_INT2:
5245 case I_INT4:
5246 case I_INT8:
5247 case I_INT:
5248 i = A_ARGSG(ast);
5249 return is_descr_expression(ARGT_ARG(i, 0));
5250 }
5251 break;
5252 case A_CNST:
5253 return 0;
5254 case A_MEM:
5255 sptr = memsym_of_ast(ast);
5256 if (DESCARRAYG(sptr))
5257 return 1;
5258 return 0;
5259 case A_ID:
5260 sptr = A_SPTRG(ast);
5261 if (DESCARRAYG(sptr))
5262 return 1;
5263 return 0;
5264 case A_SUBSCR:
5265 case A_CONV:
5266 case A_UNOP:
5267 return is_descr_expression(A_LOPG(ast));
5268 case A_BINOP:
5269 rslt = is_descr_expression(A_LOPG(ast));
5270 if (rslt)
5271 return 1;
5272 rslt = is_descr_expression(A_ROPG(ast));
5273 if (!rslt)
5274 return 0;
5275 return 1;
5276 }
5277 return 0;
5278 }
5279
5280 static void
lower_fileinfo_llvm()5281 lower_fileinfo_llvm()
5282 {
5283 int fihx;
5284 char *dirname, *filename, *funcname, *fullname;
5285
5286 if (!STB_LOWER())
5287 return;
5288 fihx = curr_findex;
5289
5290 for (; fihx < fihb.stg_avail; ++fihx) {
5291 dirname = FIH_DIRNAME(fihx);
5292 if (dirname == NULL)
5293 dirname = "";
5294 filename = FIH_FILENAME(fihx);
5295 if (filename == NULL)
5296 filename = "";
5297 funcname = FIH_FUNCNAME(fihx);
5298 if (funcname == NULL)
5299 funcname = "";
5300 fullname = FIH_FULLNAME(fihx);
5301 if (fullname == NULL)
5302 fullname = "";
5303
5304 fprintf(gbl.stbfil,
5305 "fihx:%d tag:%d parent:%d flags:%d lineno:%d "
5306 "srcline:%d level:%d next:%d %" GBL_SIZE_T_FORMAT
5307 ":%s %" GBL_SIZE_T_FORMAT ":%s %" GBL_SIZE_T_FORMAT
5308 ":%s %" GBL_SIZE_T_FORMAT ":%s\n",
5309 fihx, FIH_FUNCTAG(fihx), FIH_PARENT(fihx), FIH_FLAGS(fihx),
5310 FIH_LINENO(fihx), FIH_SRCLINE(fihx), FIH_LEVEL(fihx),
5311 FIH_NEXT(fihx), strlen(dirname), dirname, strlen(filename),
5312 filename, strlen(funcname), funcname, strlen(fullname), fullname);
5313 }
5314 curr_findex = fihx;
5315
5316 } /* lower_fileinfo_llvm */
5317
5318 static void
stb_lower_sym_header()5319 stb_lower_sym_header()
5320 {
5321 ISZ_T bss_addr;
5322 INITEM *p;
5323 static int first_time = 1;
5324 int i;
5325 FILE *tmpfile = lowersym.lowerfile;
5326
5327 if (!STB_LOWER()) {
5328 if (first_time)
5329 first_time = 0;
5330 return;
5331 }
5332
5333 lowersym.lowerfile = gbl.stbfil;
5334
5335 /* Following code is copied from lower_sym_header */
5336 if (first_time) {
5337 /* put out any saved inlining information */
5338 first_time = 0;
5339 for (p = inlist; p; p = p->next) {
5340 putival("inline", p->level);
5341 putlval("offset", p->offset);
5342 putval("which", p->which);
5343 fprintf(lowersym.lowerfile, " %" GBL_SIZE_T_FORMAT ":%s", strlen(p->name),
5344 p->name);
5345 fprintf(lowersym.lowerfile, " %" GBL_SIZE_T_FORMAT ":%s",
5346 strlen(p->cname), p->cname);
5347 fprintf(lowersym.lowerfile, " %" GBL_SIZE_T_FORMAT ":%s",
5348 strlen(p->filename), p->filename);
5349 putlval("objoffset", p->objoffset);
5350 putval("base", p->staticbase);
5351 putval("size", p->size);
5352 fprintf(lowersym.lowerfile, "\n");
5353 }
5354 fprintf(lowersym.lowerfile, "ENDINLINE\n");
5355 }
5356
5357 /* put out header lines */
5358 fprintf(lowersym.lowerfile, "TOILM version %d/%d\n", VersionMajor,
5359 VersionMinor);
5360 if (gbl.internal == 1 && gbl.empty_contains)
5361 putvline("Internal", 0);
5362 else
5363 putvline("Internal", gbl.internal);
5364 if (gbl.internal > 1) {
5365 putvline("Outer", lowersym.outersub);
5366 putvline("First", stb.firstusym);
5367 }
5368 putvline("Symbols", stb.stg_avail - 1);
5369 putvline("Datatypes", stb.dt.stg_avail - 1);
5370 bss_addr = get_bss_addr();
5371 putvline("BSS", bss_addr);
5372 putvline("GBL", gbl.saddr);
5373 putvline("LOC", gbl.locaddr);
5374 putvline("STATICS", gbl.statics);
5375 putvline("LOCALS", gbl.locals);
5376 putvline("PRIVATES", private_addr);
5377 if (saveblockname) {
5378 putvline("GNAME", saveblockname);
5379 }
5380 lowersym.lowerfile = tmpfile;
5381
5382 } /* lower_sym_header */
5383
5384 typedef struct old_dscp {
5385 int sptr;
5386 int dpdsc;
5387 int paramct;
5388 int fval;
5389 } OLD_DPDSC;
5390
5391 static OLD_DPDSC *save_dpdsc = NULL;
5392 static int save_dpdsc_cnt = 0;
5393
5394 static void
llvm_check_retval_inargs(int sptr)5395 llvm_check_retval_inargs(int sptr)
5396 {
5397 int fval = FVALG(sptr);
5398 if (fval) {
5399 int dtype;
5400 int ent_dtype = DTYPEG(sptr);
5401 llvm_fix_args(sptr, dtype != DT_NONE);
5402 dtype = DTYPEG(fval);
5403 fix_class_args(sptr);
5404 if (DTYPEG(sptr) != DT_NONE && makefvallocal(RU_FUNC, fval)) {
5405 SCP(fval, SC_LOCAL);
5406 if (is_iso_cptr(DTYPEG(fval))) {
5407 DTYPEP(fval, DT_CPTR);
5408 }
5409 }
5410 switch (DTY(dtype)) {
5411 case TY_ARRAY:
5412 if (aux.dpdsc_base[DPDSCG(sptr)] != fval) {
5413 DPDSCP(sptr, DPDSCG(sptr) - 1);
5414 *(aux.dpdsc_base + DPDSCG(sptr)) = fval;
5415 PARAMCTP(sptr, PARAMCTG(sptr) + 1);
5416 DTYPEP(sptr, DT_NONE);
5417 SCP(fval, SC_DUMMY);
5418 }
5419 break;
5420 case TY_CHAR:
5421 case TY_NCHAR:
5422 if (dtype != ent_dtype)
5423 return;
5424 if (!POINTERG(sptr) && ADJLENG(fval) && DPDSCG(sptr)) {
5425
5426 if (aux.dpdsc_base[DPDSCG(sptr)] != fval) {
5427 DPDSCP(sptr, DPDSCG(sptr) - 1);
5428 *(aux.dpdsc_base + DPDSCG(sptr)) = fval;
5429 PARAMCTP(sptr, PARAMCTG(sptr) + 1);
5430 DTYPEP(sptr, DT_NONE);
5431 SCP(fval, SC_DUMMY);
5432 }
5433 }
5434 case TY_DCMPLX:
5435 if (DTY(ent_dtype) != TY_DCMPLX) {
5436 return;
5437 }
5438 goto pointer_check;
5439
5440 default:
5441 if (DTY(ent_dtype) == TY_DCMPLX || DTY(ent_dtype) == TY_CHAR ||
5442 DTY(ent_dtype) == TY_NCHAR)
5443 return;
5444
5445 pointer_check:
5446 if (aux.dpdsc_base[DPDSCG(sptr)] != fval &&
5447 (POINTERG(sptr) || ALLOCATTRG(fval) || (DTY(ent_dtype) == TY_DCMPLX))
5448
5449 ) {
5450 if (DPDSCG(sptr) && DTYPEG(sptr) != DT_NONE) {
5451
5452 DPDSCP(sptr, DPDSCG(sptr) - 1);
5453 *(aux.dpdsc_base + DPDSCG(sptr)) = fval;
5454 PARAMCTP(sptr, PARAMCTG(sptr) + 1);
5455 DTYPEP(sptr, DT_NONE);
5456 SCP(fval, SC_DUMMY);
5457 }
5458 }
5459 break;
5460 }
5461 }
5462 }
5463
5464 static void
_stb_fixup_ifacearg(int sptr)5465 _stb_fixup_ifacearg(int sptr)
5466 {
5467 int params, i, newdsc, fval;
5468
5469 i = save_dpdsc_cnt;
5470 if (save_dpdsc_cnt == 0) {
5471 save_dpdsc_cnt = 1;
5472 NEW(save_dpdsc, OLD_DPDSC, save_dpdsc_cnt);
5473 } else {
5474 NEED(save_dpdsc_cnt + 1, save_dpdsc, OLD_DPDSC, save_dpdsc_cnt,
5475 save_dpdsc_cnt + 1);
5476 }
5477
5478 fval = FVALG(sptr);
5479 save_dpdsc[i].sptr = sptr;
5480 save_dpdsc[i].dpdsc = DPDSCG(sptr);
5481 save_dpdsc[i].paramct = PARAMCTG(sptr);
5482 save_dpdsc[i].fval = fval;
5483
5484 fix_class_args(sptr);
5485 if (INTERFACEG(sptr))
5486 return;
5487
5488 llvm_check_retval_inargs(sptr);
5489
5490 newdsc = newargs_for_llvmiface(sptr);
5491 llvm_iface_flag = TRUE;
5492 interface_for_llvmiface(sptr, newdsc);
5493 undouble_callee_args_llvmf90(sptr);
5494 params = DPDSCG(sptr);
5495 if (fval && NEWARGG(fval)) {
5496 FVALP(sptr, NEWARGG(fval));
5497 lower_visit_symbol(FVALG(sptr));
5498 }
5499 for (i = 0; i < (int)(PARAMCTG(sptr)); ++i) {
5500 int param = aux.dpdsc_base[params + i];
5501 if (param) {
5502 lower_visit_symbol(param);
5503 }
5504 }
5505 llvm_iface_flag = FALSE;
5506 }
5507
5508 /* TODO: Note that for contained subroutine, we need remove to the added
5509 * argument
5510 * before entering the contained routine. Then at lower, we need to put it back
5511 * again.
5512 */
5513
5514 void
stb_fixup_llvmiface()5515 stb_fixup_llvmiface()
5516 {
5517 int sptr, params, i, newdsc, fval;
5518 /* go through iface symbols */
5519 for (sptr = 1; sptr < stb.stg_avail; ++sptr) {
5520 if (STYPEG(sptr) == ST_PROC) {
5521 if (SCG(sptr) == SC_NONE ||
5522 (SCG(sptr) == SC_EXTERN &&
5523 ((VISITG(sptr) && INMODULEG(sptr)) ||
5524 (DPDSCG(sptr) && VISITG(sptr)) ||
5525 (gbl.currsub && gbl.currsub == SCOPEG(sptr) &&
5526 NEEDMODG(gbl.currsub))))
5527
5528 ) {
5529 _stb_fixup_ifacearg(sptr);
5530 }
5531 }
5532 }
5533 }
5534
5535 void
uncouple_callee_args()5536 uncouple_callee_args()
5537 {
5538 int i, sptr;
5539 /* do it backward just in case there is a case where we overwrite the existing
5540 * one */
5541 for (i = (save_dpdsc_cnt - 1); i >= 0; i--) {
5542 sptr = save_dpdsc[i].sptr;
5543 DPDSCP(sptr, save_dpdsc[i].dpdsc);
5544 PARAMCTP(sptr, save_dpdsc[i].paramct);
5545 FVALP(sptr, save_dpdsc[i].fval);
5546 INTERFACEP(sptr, 0);
5547 }
5548 FREE(save_dpdsc);
5549 save_dpdsc = NULL;
5550 save_dpdsc_cnt = 0;
5551 }
5552
5553 /**
5554 \brief Inspect a common block variable symbol to see if it has a alias
5555 name, if YES, write to ilm file with attribute "has_alias" be 1 and
5556 followed by the length and name of the alias; if NO, put 0 to "has_alias".
5557 */
5558 static void
check_debug_alias(SPTR sptr)5559 check_debug_alias(SPTR sptr)
5560 {
5561 if (gbl.rutype != RU_BDATA && STYPEG(sptr) == ST_VAR && SCG(sptr) == SC_CMBLK) {
5562 /* Create debug info for restricted import of module variables
5563 * and renaming of module variables */
5564 if (HASHLKG(sptr)) {
5565 if (STYPEG(HASHLKG(sptr)) == ST_ALIAS &&
5566 !strcmp(SYMNAME(sptr), SYMNAME(HASHLKG(sptr)))) {
5567 putbit("has_alias", 1);
5568 fprintf(lowersym.lowerfile, " %d:%s",
5569 strlen(SYMNAME(sptr)), SYMNAME(HASHLKG(sptr)));
5570 } else {
5571 SPTR candidate = sptr;
5572 while (candidate) {
5573 if (dbgref_symbol.altname[candidate] &&
5574 SYMLKG(dbgref_symbol.altname[candidate]->sptr) == sptr)
5575 break;
5576 candidate = HASHLKG(candidate);
5577 }
5578 if (candidate) {
5579 putbit("has_alias", 1);
5580 fprintf(lowersym.lowerfile, " %d:%s",
5581 strlen(SYMNAME(dbgref_symbol.altname[candidate]->sptr)),
5582 SYMNAME(dbgref_symbol.altname[candidate]->sptr));
5583 } else {
5584 putbit("has_alias", 0);
5585 }
5586 }
5587 } else {
5588 putbit("has_alias", 0);
5589 }
5590 }
5591 }
5592
5593