1 /*
2 * Copyright (c) 1994-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 Fortran - symbol table access module.
21
22 * This module contains the routines used to initialize, update, access, and
23 * dump the symbol table. Note that in addition to being used by PGHPF, this
24 * module is used by the utility program, symini, which processes intrinsic and
25 * generic definitions in order to set up the initial symbol table for PGHPF.
26 */
27
28 #include "gbldefs.h"
29 #include "global.h"
30 #include "error.h"
31 #include "machar.h"
32 #include "symtab.h"
33 #include "symtabdf.h"
34 #include "symutl.h"
35 #include "syminidf.h"
36 #include "dtypeutl.h"
37 #include "soc.h"
38 #include "state.h"
39 #include "ast.h"
40 #include "semant.h"
41 #include "llmputil.h"
42 #include "rtlRtns.h"
43 #include <stdarg.h>
44
45
46 /* During IPA recompilations, compiler-generated temporary names
47 * need to be distinct from the names that were used on the first
48 * compile.
49 */
50 #define IPA_RECOMPILATION_SUFFIX (XBIT(89, 0x40) ? "i" : "")
51
52 /* implicit data types */
53 typedef struct {
54 int dtype;
55 LOGICAL set, anyset; /* True if set by IMPLICIT stmt */
56 LOGICAL typ8; /* True if the type is altered by -r8 */
57 } DTIMPL[26 + 26 + 2];
58
59 typedef struct {
60 SPTR dec_sptr;
61 SPTR def_sptr;
62 } DEC_DEF_MAP;
63
64 static DTIMPL dtimplicit;
65 static int dtimplicitsize = 0;
66 static DTIMPL *save_dtimplicit = NULL;
67 static int dtimplicitstack = 0;
68
69 static void cng_inttyp(int, int);
70 static void cng_specific(int, int);
71 static void generate_type_mismatch_errors(SPTR s1, SPTR s2);
72 static void update_arrdsc(SPTR s, DEC_DEF_MAP *smap, int num_dummies);
73 /* entry hack? */
74 static ENTRY onlyentry;
75
76 /*--------------------------------------------------------------------------*/
77
78 /**
79 * Initialize symbol table for new user program unit.
80 */
81 void
sym_init(void)82 sym_init(void)
83 {
84 int i;
85 INT tmp[2], res[2];
86 int dtype;
87 static char *npname = "hpf_np$";
88 int sptr;
89
90 /* allocate symbol table and name table space: */
91 sym_init_first();
92
93 init_chartab(); /* see dtypeutl.c */
94
95 STG_RESET(stb.dt);
96 STG_NEXT_SIZE(stb.dt, DT_MAX);
97 for (i = 0; i <= DT_MAX; ++i)
98 DTY(i) = pd_dtype[i];
99
100 if (XBIT(49, 0x800000)) {
101 DT_REAL = DT_REAL8;
102 DT_CMPLX = DT_CMPLX16;
103 if (XBIT(49, 0x200)) {
104 DT_DBLE = DT_REAL8;
105 DT_DCMPLX = DT_CMPLX16;
106 } else {
107 DT_DBLE = DT_QUAD;
108 DT_DCMPLX = DT_QCMPLX;
109 }
110 }
111 if (XBIT(49, 0x80000000)) {
112 DT_INT = DT_INT8;
113 DT_LOG = DT_LOG8;
114 }
115 if (XBIT(49, 0x100) && !XBIT(125, 0x2000)) {
116 DT_PTR = DT_INT8;
117 }
118 if (!XBIT(124, 0x10)) {
119 stb.user.dt_int = DT_INT;
120 stb.user.dt_log = DT_LOG;
121 } else {
122 /* -i8 */
123 stb.user.dt_int = DT_INT8;
124 stb.user.dt_log = DT_LOG8;
125 }
126 if (!XBIT(124, 0x8)) {
127 stb.user.dt_real = DT_REAL;
128 stb.user.dt_cmplx = DT_CMPLX;
129 } else {
130 /* -r8 */
131 stb.user.dt_real = DT_DBLE;
132 stb.user.dt_cmplx = DT_DCMPLX;
133 }
134 /*
135 * Set up initial implicit types. All are real except for the letters i
136 * thru n:
137 */
138 init_implicit();
139
140 /*
141 * now initialize symbol table. There are 2 cases: The first case occurs
142 * within the utility symini - we start with a totally empty symbol
143 * table. The second case occurs within PGHPF - the initial symbol table is
144 * copied from some arrays set up by symini.
145 */
146
147 #if DEBUG
148 assert(stb.stg_size >= INIT_SYMTAB_SIZE, "sym_init:INIT_SYMTAB_SIZE",
149 INIT_SYMTAB_SIZE, 0);
150 #endif
151 BCOPY(stb.stg_base, init_sym, SYM, INIT_SYMTAB_SIZE);
152 stb.stg_avail = INIT_SYMTAB_SIZE;
153 stb.stg_cleared = INIT_SYMTAB_SIZE;
154 #if DEBUG
155 assert(stb.n_size >= INIT_NAMES_SIZE, "sym_init:INIT_NAMES_SIZE",
156 INIT_NAMES_SIZE, 0);
157 #endif
158 BCOPY(stb.n_base, init_names, char, INIT_NAMES_SIZE);
159 stb.namavl = INIT_NAMES_SIZE;
160
161 BCOPY(stb.hashtb, init_hashtb, int, HASHSIZE);
162
163 if (XBIT(124, 0x10)) {
164 /* -i8 */
165 cng_inttyp(intast_sym[I_ICHAR], DT_INT8);
166 }
167
168 /* change the specific intrinsics whose types are DT_QUAD and DT_QCMPLX
169 * if the the '-dp' switch is present. This could be within a #ifdef C90,
170 * but we do build the T3E/C90 pghpfc on solaris.
171 */
172 if (XBIT(49, 0x200))
173 for (i = 1; i < INIT_SYMTAB_SIZE; i++)
174 if (STYPEG(i) == ST_INTRIN) {
175 if (INTTYPG(i) == DT_QUAD)
176 INTTYPP(i, DT_REAL8);
177 else if (INTTYPG(i) == DT_QCMPLX)
178 INTTYPP(i, DT_CMPLX16);
179 if (ARGTYPG(i) == DT_QUAD)
180 ARGTYPP(i, DT_REAL8);
181 else if (ARGTYPG(i) == DT_QCMPLX)
182 ARGTYPP(i, DT_CMPLX16);
183 }
184
185 /*
186 * enter constants into symbol table:
187 *
188 * * * * * * * * * * N O T E * * * * * * * * *
189 * * * * * * * * * * N O T E * * * * * * * * *
190 * DO NOT CHANGE the order of entering these predefined symbols.
191 * To add a predefined, insert it between the last getcon/getsym
192 * and where stb.firstosym is set.
193 */
194
195 /* int 0, 1 */
196 tmp[0] = tmp[1] = (INT)0;
197 stb.i0 = getcon(tmp, DT_INT);
198 if (DT_INT == DT_INT8)
199 stb.k0 = stb.i0;
200 else if (!XBIT(57, 0x2))
201 stb.k0 = getcon(tmp, DT_INT8);
202 else
203 stb.k0 = 0;
204 tmp[1] = (INT)1;
205 stb.i1 = getcon(tmp, DT_INT);
206 if (DT_INT == DT_INT8)
207 stb.k1 = stb.i1;
208 else if (!XBIT(57, 0x2))
209 stb.k1 = getcon(tmp, DT_INT8);
210 else
211 stb.k1 = 0;
212
213 add_fp_constants();
214 /*
215 * * * * * * * * * * N O T E * * * * * * * * *
216 * NO MORE predefined contants until immediately before
217 * stb.firstosym is set ...
218 */
219
220 /* create symbol hpf_np$ */
221 sptr = getsymbol(npname);
222 STYPEP(sptr, ST_UNKNOWN);
223 DTYPEP(sptr, DT_INT);
224 DCLDP(sptr, 1);
225 SCP(sptr, SC_LOCAL);
226 NODESCP(sptr, 1);
227 gbl.sym_nproc = sptr;
228 if (XBIT(70, 0x80000000)) {
229 int bsym;
230 SCP(sptr, SC_BASED);
231 bsym = getsymf("%sp", npname); /* hpf_np$p */
232 STYPEP(bsym, ST_UNKNOWN);
233 DTYPEP(bsym, DT_PTR);
234 DCLDP(bsym, 1);
235 SCP(bsym, SC_LOCAL);
236 NODESCP(bsym, 1);
237 MIDNUMP(sptr, bsym);
238 }
239
240 /* allocate space for auxiliary symtab structures: */
241
242 if (aux.dpdsc_size <= 0) {
243 aux.dpdsc_size = 100;
244 NEW(aux.dpdsc_base, int, aux.dpdsc_size);
245 }
246 aux.dpdsc_avl = 1; /* 0 => null DPDSC field */
247 aux.dpdsc_base[0] = 0;
248
249 if (aux.arrdsc_size <= 0) {
250 aux.arrdsc_size = 200;
251 NEW(aux.arrdsc_base, int, aux.arrdsc_size);
252 }
253 aux.arrdsc_base[0] = 0; /* numdim=0 if array descriptor is zero */
254 aux.arrdsc_avl = 1;
255
256 if (aux.nml_size <= 0) {
257 aux.nml_size = 200;
258 NEW(aux.nml_base, NMLDSC, aux.nml_size);
259 }
260 aux.nml_avl = 1;
261 aux.nml_base[0].sptr = 0;
262 aux.nml_base[0].next = 0;
263 aux.nml_base[0].lineno = 0;
264
265 if (!XBIT(7, 0x100000)) {
266 if (aux.dvl_size <= 0) {
267 aux.dvl_size = 32;
268 NEW(aux.dvl_base, DVL, aux.dvl_size);
269 }
270 aux.dvl_avl = 0;
271 }
272
273 if (aux.symi_size <= 0) {
274 aux.symi_size = 100;
275 NEW(aux.symi_base, SYMI, aux.symi_size);
276 }
277 aux.symi_avl = 1; /* 0 => end of list */
278 aux.symi_base[0].sptr = 0;
279 aux.symi_base[0].next = 0;
280
281 /*
282 * * * * * * * * * * N O T E * * * * * * * * *
283 * More predefined constants after ORIGINAL set; note the
284 * value of NXTRA (number of post-original symbols.
285 */
286 tmp[0] = 0;
287 res[0] = 0;
288 tmp[1] = CONVAL2G(stb.flt0);
289 xfneg(tmp[1], &res[1]);
290 stb.fltm0 = getcon(res, DT_REAL4);
291 tmp[0] = CONVAL1G(stb.dbl0);
292 tmp[1] = CONVAL2G(stb.dbl0);
293 xdneg(tmp, res);
294 stb.dblm0 = getcon(res, DT_DBLE);
295 #define NXTRA 2
296
297 aux.curr_entry = &onlyentry;
298 stb.firstusym = stb.firstosym = stb.stg_avail;
299 stb.lbavail = 99999;
300
301 for (i = 0; i < ST_MAX; i++)
302 aux.list[i] = NOSYM; /* 'empty' list for each stype */
303
304 soc.avail = 1;
305 if ((gbl.internal == 0) && (flg.ipa & 0x100) == 0) {
306 /* clear at outer routines, but not for static$init routines */
307 if (gbl.currmod == 0) {
308 dtimplicitstack = 0;
309 } else {
310 dtimplicitstack = 1;
311 }
312 }
313 symutl.sc = SC_LOCAL;
314
315 llmp_reset_uplevel();
316 }
317
318 static void
cng_inttyp(int ss,int dt)319 cng_inttyp(int ss, int dt)
320 {
321 #if DEBUG
322 assert(STYPEG(ss) == ST_INTRIN, "cng_inttyp not intr", ss, 3);
323 #endif
324 INTTYPP(ss, dt);
325 }
326
327 static void
cng_specific(int os,int ns)328 cng_specific(int os, int ns)
329 {
330
331 #if DEBUG
332 assert(STYPEG(os) == ST_INTRIN, "cng_specific not intr", os, 3);
333 assert(STYPEG(ns) == ST_INTRIN, "cng_specific not intr", ns, 3);
334 #endif
335 dup_sym(os, &stb.stg_base[ns]);
336 }
337
338 /**
339 * Set up initial implicit types. All are real except for the letters i
340 * thru n:
341 */
342 void
init_implicit(void)343 init_implicit(void)
344 {
345 int i;
346 int default_real;
347 int default_int;
348
349 for (i = 0; i < 54; i++) {
350 dtimplicit[i].dtype = stb.user.dt_real;
351 dtimplicit[i].set = FALSE;
352 dtimplicit[i].anyset = FALSE; /* not explicit set anywhere */
353 if (XBIT(124, 0x8) && !XBIT(49, 0x800000)) {
354 dtimplicit[i].typ8 = TRUE;
355 } else {
356 dtimplicit[i].typ8 = FALSE;
357 }
358 }
359
360 default_int = flg.i4 ? stb.user.dt_int : DT_SINT;
361 implicit_int(default_int);
362 }
363
364 /**
365 * simple routine to reset the default integer type for implicitly typing
366 * integer variables. Needed for compile-type processing of -i4/-noi4
367 * options in OPTIONS statement.
368 */
369 void
implicit_int(int default_int)370 implicit_int(int default_int)
371 {
372 int i;
373 for (i = 8; i <= 13; i++) {
374 dtimplicit[i].dtype = dtimplicit[i + 26].dtype = default_int;
375 dtimplicit[i].typ8 = dtimplicit[i + 26].typ8 = FALSE;
376 }
377 }
378
379 void
save_implicit(LOGICAL reset)380 save_implicit(LOGICAL reset)
381 {
382 if (save_dtimplicit == NULL) {
383 dtimplicitsize = 4;
384 NEW(save_dtimplicit, DTIMPL, dtimplicitsize);
385 BZERO(save_dtimplicit, DTIMPL, dtimplicitsize);
386 } else {
387 NEED(dtimplicitstack + 1, save_dtimplicit, DTIMPL, dtimplicitsize,
388 dtimplicitsize * 2);
389 }
390 BCOPY(save_dtimplicit[dtimplicitstack], dtimplicit, DTIMPL, 1);
391 ++dtimplicitstack;
392 if (reset) {
393 int i;
394 for (i = 0; i < 54; i++) {
395 dtimplicit[i].set = FALSE; /* not explicitly set at this level */
396 }
397 }
398 }
399
400 void
restore_implicit(void)401 restore_implicit(void)
402 {
403 if (dtimplicitstack <= 0)
404 interr("IMPLICIT stack too shallow", dtimplicitstack, 3);
405 --dtimplicitstack;
406 BCOPY(dtimplicit, save_dtimplicit[dtimplicitstack], DTIMPL, 1);
407 }
408
409 /**
410 * Return the first & last sym pointers for the HPF_LIBRARY procedures.
411 * Initially, the stype of the HPF library procedures is ST_HL;
412 * when the USE statement is seen, the stype of these symbols is changed
413 * to ST_PD.
414 */
415 void
hpf_library_stat(int * firstp,int * lastp,int stype)416 hpf_library_stat(int *firstp, int *lastp, int stype)
417 {
418 if (stype == ST_CRAY) {
419 *firstp = CRAY_FIRST;
420 *lastp = CRAY_LAST;
421 }
422 #if DEBUG
423 else {
424 interr("hpf_library_stat:illegal stype", stype, 0);
425 }
426 #endif
427 }
428
429 /**
430 * Return the first & last sym pointers for the ISO_C intrinsic
431 * procedures. Initially, the stype of the ISO_C library procedures is ST_ISOC
432 * when the USE statement is seen, the stype of these symbols is changed
433 * to ST_INTRIN
434 */
435 void
iso_c_lib_stat(int * firstp,int * lastp,int stype)436 iso_c_lib_stat(int *firstp, int *lastp, int stype)
437 {
438
439 if (stype == ST_ISOC) {
440 *firstp = ISO_C_FIRST;
441 *lastp = ISO_C_LAST;
442 }
443 #if DEBUG
444 else {
445 interr("iso_c_lib_stat:illegal stype", stype, 0);
446 }
447 #endif
448 }
449
450 extern int
get_ieee_arith_intrin(char * nm)451 get_ieee_arith_intrin(char *nm)
452 {
453 int i;
454
455 for (i = IEEEARITH_FIRST; i <= IEEEARITH_LAST; i++) {
456 if (strcmp(SYMNAME(i), nm) == 0)
457 return i;
458 }
459 return 0;
460 }
461
462 /*
463 * Enter symbol with indicated null-terminated name into symbol table,
464 * initialize the new entry, and return pointer to it. If there is already
465 * such a symbol, just return pointer to the existing symbol table entry.
466 */
467 int
getsymbol(const char * name)468 getsymbol(const char *name)
469 {
470 return getsym(name, strlen(name));
471 }
472
473 /** \brief Enter symbol with indicated name into symbol table, initialize
474 the new entry.
475 \param name symbol name
476 \param olength number of characters in the symbol name
477 \return pointer to new symbol
478
479 If there is already such a symbol, just return pointer to the existing
480 symbol table entry.
481 */
482 int
getsym(const char * name,int olength)483 getsym(const char *name, int olength)
484 {
485 int sptr; /* pointer to symbol table entry */
486
487 sptr = installsym(name, olength);
488 switch (STYPEG(sptr)) {
489 case ST_ISOC:
490 case ST_IEEEARITH:
491 case ST_IEEEEXCEPT:
492 case ST_ISOFTNENV:
493 case ST_CRAY:
494 /* predefined symbol is the name of an HPF library procedure; since
495 * the stype is ST_HL, this implies that a 'USE HPF_LIBRARY' statement
496 * was not seen. Consequently, this symbol is a user symbol and
497 * a new (ST_UNKNOWN) symbol must be entered into the symbol table.
498 */
499 sptr = insert_sym(sptr);
500 setimplicit(sptr);
501 if (gbl.internal > 1)
502 INTERNALP(sptr, 1);
503 SCOPEP(sptr, stb.curr_scope);
504 IGNOREP(sptr, 0);
505 break;
506 case ST_UNKNOWN:
507 setimplicit(sptr);
508 if (gbl.internal > 1)
509 INTERNALP(sptr, 1);
510 SCOPEP(sptr, stb.curr_scope);
511 IGNOREP(sptr, 0);
512 break;
513 default:
514 break;
515 }
516 return sptr;
517 }
518
519 /* Construct a name via vsnprintf(), then use it to look up or
520 * create a symbol.
521 */
522 int
getsymf(const char * fmt,...)523 getsymf(const char *fmt, ...)
524 {
525 char buffer[MAXIDLEN + 1];
526 va_list ap;
527
528 va_start(ap, fmt);
529 vsnprintf(buffer, sizeof buffer, fmt, ap);
530 va_end(ap);
531 buffer[sizeof buffer - 1] = '\0'; /* Windows vsnprintf bug work-around */
532 return getsymbol(buffer);
533 }
534
535 /*--------------------------------------------------------------------------*
536 * getcon & get_acon is identical between C and Fortran; should be shared *
537 *--------------------------------------------------------------------------*/
538
539 /** \brief Enter constant of given dtype and value into the symbol table and
540 return
541 pointer to it.
542
543 If an entry for the constant already exists, return pointer to the existing
544 entry instead.
545 */
546 SPTR
getcon(INT * value,DTYPE dtype)547 getcon(INT *value, DTYPE dtype)
548 {
549 int sptr; /* symbol table pointer */
550 int hashval; /* index into hashtb */
551
552 /*
553 * First loop thru the appropriate hash link list to see if this constant
554 * is already in the symbol table:
555 */
556
557 hashval = HASH_CON(value);
558 if (hashval < 0)
559 hashval = -hashval;
560 for (sptr = stb.hashtb[hashval]; sptr != 0; sptr = HASHLKG(sptr)) {
561 if (DTY(dtype) == TY_QUAD) {
562 if (DTYPEG(sptr) != dtype || STYPEG(sptr) != ST_CONST ||
563 CONVAL1G(sptr) != value[0] || CONVAL2G(sptr) != value[1] ||
564 CONVAL3G(sptr) != value[2] || CONVAL4G(sptr) != value[3])
565 continue;
566
567 /* Matching entry has been found. Return it: */
568 return (sptr);
569 }
570 if (DTYPEG(sptr) != dtype || STYPEG(sptr) != ST_CONST ||
571 CONVAL1G(sptr) != value[0] || CONVAL2G(sptr) != value[1])
572 continue;
573
574 /* Matching entry has been found. Return it: */
575 return (sptr);
576 }
577
578 /* Constant not found. Create a new symbol table entry for it: */
579
580 ADDSYM(sptr, hashval);
581 STYPEP(sptr, ST_CONST);
582 CONVAL1P(sptr, value[0]);
583 CONVAL2P(sptr, value[1]);
584 if (DTY(dtype) == TY_QUAD) {
585 CONVAL3P(sptr, value[2]);
586 CONVAL4P(sptr, value[3]);
587 }
588 DTYPEP(sptr, dtype);
589 SCOPEP(sptr, 1);
590
591 return (sptr);
592 }
593
594 /* constant value (value[1] if 1 word) */
595 int
hashcon(INT * value,int dtype,int sptr)596 hashcon(INT *value, int dtype, int sptr)
597 {
598 int sptr1; /* symbol table pointer */
599 int hashval; /* index into hashtb */
600
601 /*
602 * First loop thru the appropriate hash link list to see if this constant
603 * is already in the symbol table:
604 */
605
606 hashval = HASH_CON(value);
607 if (hashval < 0)
608 hashval = -hashval;
609 for (sptr1 = stb.hashtb[hashval]; sptr1 != 0; sptr1 = HASHLKG(sptr1)) {
610
611 if (sptr1 == sptr)
612 return (sptr);
613 }
614
615 /* sptr not found. */
616
617 HASHLKP(sptr, stb.hashtb[hashval]);
618 stb.hashtb[hashval] = sptr;
619
620 return (sptr);
621 }
622
623 SPTR
get_acon(SPTR sym,ISZ_T off)624 get_acon(SPTR sym, ISZ_T off)
625 {
626 return get_acon3(sym, off, DT_CPTR);
627 }
628
629
630 /*
631 * BIGOBJects are supported, need an acon-specific getcon
632 */
633 SPTR
get_acon3(SPTR sym,ISZ_T off,DTYPE dtype)634 get_acon3(SPTR sym, ISZ_T off, DTYPE dtype)
635 {
636 INT value[2];
637 int sptr; /* symbol table pointer */
638 int hashval; /* index into stb.hashtb */
639
640 /*
641 * First loop thru the appropriate hash link list to see if this constant
642 * is already in the symbol table:
643 */
644
645 bgitoi64(off, value);
646 value[0] = sym;
647 hashval = HASH_CON(value);
648 if (hashval < 0)
649 hashval = -hashval;
650 for (sptr = stb.hashtb[hashval]; sptr != 0; sptr = HASHLKG(sptr)) {
651 if (DTYPEG(sptr) != dtype || STYPEG(sptr) != ST_CONST ||
652 CONVAL1G(sptr) != sym || ACONOFFG(sptr) != off)
653 continue;
654
655 /* Matching entry has been found. Return it: */
656
657 return (sptr);
658 }
659
660 /* Constant not found. Create a new symbol table entry for it: */
661
662 ADDSYM(sptr, hashval);
663 CONVAL1P(sptr, sym);
664 ACONOFFP(sptr, off);
665 STYPEP(sptr, ST_CONST);
666 DTYPEP(sptr, dtype);
667 SCOPEP(sptr, 1);
668
669 return (sptr);
670 }
671
672 ISZ_T
get_isz_cval(int con)673 get_isz_cval(int con)
674 {
675 INT num[2];
676 ISZ_T v;
677 #if DEBUG
678 assert(STYPEG(con) == ST_CONST, "get_isz_cval-not ST_CONST", con, 0);
679 assert(DT_ISINT(DTYPEG(con)) || DT_ISLOG(DTYPEG(con)),
680 "get_int_cval-not int const", con, 0);
681 #endif
682 if (XBIT(68, 0x1)) {
683 if (size_of(DTYPEG(con)) <= 4)
684 return get_int_cval(con);
685 }
686 num[0] = CONVAL1G(con);
687 num[1] = CONVAL2G(con);
688 INT64_2_ISZ(num, v);
689 return v;
690 }
691
692 /**
693 * Retrieve the value of an integer constant symbol table entry and
694 * return as an 'INT'. Coerce TY_INT8 values if necessary.
695 */
696 INT
get_int_cval(int con)697 get_int_cval(int con)
698 {
699 INT res;
700 DBLINT64 inum;
701
702 #if DEBUG
703 assert(STYPEG(con) == ST_CONST, "get_int_cval-not ST_CONST", con, 0);
704 assert(DT_ISINT(DTYPEG(con)) || DT_ISLOG(DTYPEG(con)),
705 "get_int_cval-not int const", con, 0);
706 #endif
707
708 switch (DTY(DTYPEG(con))) {
709 case TY_INT8:
710 case TY_LOG8:
711 res = CONVAL2G(con);
712 break;
713 default:
714 res = CONVAL2G(con);
715 break;
716 }
717
718 return res;
719 }
720
721 /**
722 * Sign extend an integer value of an indicated width (8, 16, 32); value
723 * returned is sign extended with respect to the host's int type.
724 */
725 INT
sign_extend(INT val,int width)726 sign_extend(INT val, int width)
727 {
728 /* 32-bit INT */
729 int w;
730
731 if (width == 32)
732 return val;
733 w = 32 - width;
734 return ARSHIFT(LSHIFT(val, w), w);
735 }
736
737 /*--------------------------------------------------------------------------*/
738
739 /** \brief Enter character constant into symbol table and return
740 pointer to it.
741 \param value character string value
742 \param length length of character string
743
744 If the constant is already in the table,
745 return pointer to the existing entry instead.
746 */
747 int
getstring(char * value,int length)748 getstring(char *value, int length)
749 {
750 int sptr; /* symbol table pointer */
751 int hashval; /* index into hashtb */
752 char *np; /* pointer to string characters */
753 char *p;
754 int i, clen;
755 int dtype;
756 /*
757 * first loop thru the appropriate hash link list to see if symbol is
758 * already in the table:
759 */
760 HASH_STR(hashval, value, length);
761 /* Ensure hash value is positive. '\nnn' can cause negative hash values */
762 if (hashval < 0)
763 hashval = -hashval;
764 for (sptr = stb.hashtb[hashval]; sptr != 0; sptr = HASHLKG(sptr)) {
765 if (STYPEG(sptr) != ST_CONST)
766 continue;
767 i = DTYPEG(sptr);
768 if (DTY(i) == TY_CHAR) {
769 clen = DTY(i + 1);
770 if (clen > 0 && A_ALIASG(clen)) {
771 clen = A_ALIASG(clen);
772 clen = A_SPTRG(clen);
773 clen = CONVAL2G(clen);
774 if (clen == length) {
775 /* now match the characters in the strings: */
776
777 np = stb.n_base + CONVAL1G(sptr);
778 p = value;
779 i = length;
780 while (i--)
781 if (*np++ != *p++)
782 goto Continue;
783 /* Matching entry has been found in symtab. Return it: */
784 return sptr;
785 }
786 }
787 }
788 Continue:;
789 }
790
791 /* String not found. Create a new symtab entry for it: */
792
793 dtype = get_type(2, TY_CHAR, mk_cval(length, DT_INT4));
794 ADDSYM(sptr, hashval);
795 STYPEP(sptr, ST_CONST);
796 CONVAL1P(sptr, putsname(value, length));
797 DTYPEP(sptr, dtype);
798 SCOPEP(sptr, 1);
799 return (sptr);
800 }
801
802 /*--------------------------------------------------------------------------*/
803
804 /**
805 * Create a 'kinded' hollerith constant from a string constant and return the
806 * pointer to it. If the constant is already in the table, return pointer to
807 * the existing entry. Possible kind values are:
808 * 'h' - left justifed, blank filled.
809 * 'l' - left justfied, zero filled.
810 * 'r' - right justfied, zero filled.
811 */
812 int
gethollerith(int strcon,int kind)813 gethollerith(int strcon, int kind)
814 {
815 INT val[2];
816 int sptr;
817
818 val[0] = strcon;
819 val[1] = kind;
820 sptr = getcon(val, DT_HOLL);
821 HOLLP(sptr, 1);
822 return sptr;
823 }
824
825 /*--------------------------------------------------------------------------*/
826
827 /** \brief Change the current settings for implicit variable types and character
828 lengths.
829 \param firstc characters delimiting range
830 \param lastc new value assigned to range
831 \param dtype data type
832 */
833 void
newimplicit(int firstc,int lastc,int dtype)834 newimplicit(int firstc, int lastc, int dtype)
835 {
836 int i, j; /* indices into implicit arrays */
837 char temp[2];
838
839 i = IMPL_INDEX(firstc); /* IMPL_INDEX is defined in symtab.h */
840 j = IMPL_INDEX(lastc);
841 #if DEBUG
842 assert(i >= 0 && j >= 0 && i < 54 && j < 54, "newimplicit: bad impl range", i,
843 4);
844 #endif
845
846 for (; i <= j; i++) {
847 if (dtimplicit[i].set) { /* already set */
848 temp[0] = 'a' + i;
849 temp[1] = 0;
850 if (dtype == dtimplicit[i].dtype)
851 error(54, 2, gbl.lineno, temp, CNULL);
852 else
853 error(54, 3, gbl.lineno, temp, CNULL);
854 }
855 dtimplicit[i].dtype = dtype;
856 dtimplicit[i].set = TRUE;
857 dtimplicit[i].anyset = TRUE; /* explicitly set */
858 dtimplicit[i].typ8 = FALSE;
859 }
860 }
861
862 void
newimplicitnone(void)863 newimplicitnone(void)
864 {
865 int i;
866 for (i = 0; i < 54; ++i) {
867 dtimplicit[i].anyset = FALSE; /* explicit reset */
868 }
869 } /* newimplicitnone */
870
871 /*--------------------------------------------------------------------------*/
872
873 /**
874 * assign to the indicated symbol table entry, the current implicit dtype.
875 */
876 void
setimplicit(int sptr)877 setimplicit(int sptr)
878 {
879 int firstc; /* first character of symbol name */
880 int i; /* index into implicit tables defined by the
881 * first character of the name of sptr. */
882
883 firstc = *SYMNAME(sptr);
884
885 /*
886 * determine index into implicit array. Note that the value returned
887 * will be -1 if this routine is being called from within the symini
888 * utility for a symbol beginning with ".".
889 */
890
891 i = IMPL_INDEX(firstc);
892
893 if (i != -1) {
894 DTYPEP(sptr, dtimplicit[i].dtype);
895 }
896 }
897
898 /** \brief Return FALSE if this symbol could not have been properly implicitly
899 * typed
900 */
901 LOGICAL
was_implicit(int sptr)902 was_implicit(int sptr)
903 {
904 int firstc, i;
905 firstc = *SYMNAME(sptr);
906 i = IMPL_INDEX(firstc);
907 if (symutl.none_implicit && !dtimplicit[i].anyset)
908 return FALSE;
909 return TRUE;
910 } /* was_implicit */
911
912 /** \brief Return ptr to printable representation of the indicated PARAMETER.
913 \param sptr symbol table pointer
914 */
915 char *
parmprint(int sptr)916 parmprint(int sptr)
917 {
918 int dtype;
919 char *buf;
920 INT save;
921
922 if (STYPEG(sptr) != ST_PARAM)
923 return "";
924 /*
925 * Change the symbol table entry to an ST_CONST use getprint
926 * to get the character representation.
927 */
928 STYPEP(sptr, ST_CONST);
929 dtype = DTYPEG(sptr);
930 if (DTY(dtype) == TY_SINT || DTY(dtype) == TY_BINT || DTY(dtype) == TY_HOLL ||
931 DTY(dtype) == TY_WORD)
932 DTYPEP(sptr, DT_INT);
933 else if (DTY(dtype) == DT_SLOG || DTY(dtype) == DT_BLOG)
934 DTYPEP(sptr, DT_LOG);
935 if (TY_ISWORD(DTY(dtype))) {
936 save = CONVAL2G(sptr);
937 CONVAL2P(sptr, CONVAL1G(sptr));
938 buf = getprint(sptr);
939 CONVAL2P(sptr, save);
940 } else
941 buf = getprint((int)CONVAL1G(sptr));
942 STYPEP(sptr, ST_PARAM);
943 DTYPEP(sptr, dtype);
944 return buf;
945 }
946
947 /*---------------------------------------------------------------------*
948 * getprint cannot be shared between FORTRAN and C *
949 *---------------------------------------------------------------------*/
950
951 /**
952 * Return ptr to printable representation of the indicated symbol. For
953 * symbols which are not constants, the name of the symbol is used.
954 * Constants are converted into the appropriate character representation.
955 */
956 static char *
__log_print(INT val)957 __log_print(INT val)
958 {
959 if (val == 0)
960 return ".FALSE.";
961 return ".TRUE.";
962 }
963
964 /**
965 \param sptr symbol table pointer
966 */
967 char *
getprint(int sptr)968 getprint(int sptr)
969 {
970 int len; /* length of character string */
971 static char *b = NULL;
972 char *from, *end, *to;
973 int c;
974 INT num[4];
975 int dtype;
976
977 if (sptr == 0)
978 return ".0.";
979 if (sptr < 0)
980 return ".neg.";
981 if (sptr >= stb.stg_avail)
982 return ".toobig.";
983 if (STYPEG(sptr) != ST_CONST)
984 return SYMNAME(sptr);
985
986 if (b == NULL) {
987 NEW(b, char, 100);
988 }
989 dtype = DTYPEG(sptr);
990 switch (DTY(dtype)) {
991 case TY_WORD:
992 sprintf(b, "%08X", CONVAL2G(sptr));
993 break;
994 case TY_DWORD:
995 sprintf(b, "%08X%08X", CONVAL1G(sptr), CONVAL2G(sptr));
996 break;
997 case TY_BINT:
998 sprintf(b, "%d_1", CONVAL2G(sptr));
999 break;
1000 case TY_SINT:
1001 sprintf(b, "%d_2", CONVAL2G(sptr));
1002 break;
1003 case TY_INT:
1004 sprintf(b, "%d", CONVAL2G(sptr));
1005 break;
1006 case TY_INT8:
1007 num[0] = CONVAL1G(sptr);
1008 num[1] = CONVAL2G(sptr);
1009 ui64toax(num, b, 22, 0, 10);
1010 break;
1011 case TY_BLOG:
1012 sprintf(b, "%s_1", __log_print(CONVAL2G(sptr)));
1013 break;
1014 case TY_SLOG:
1015 sprintf(b, "%s_2", __log_print(CONVAL2G(sptr)));
1016 break;
1017 case TY_LOG:
1018 case TY_LOG8:
1019 sprintf(b, "%s", __log_print(CONVAL2G(sptr)));
1020 break;
1021 case TY_REAL:
1022 num[0] = CONVAL2G(sptr);
1023 cprintf(b, "%17.10e", (INT*)(size_t)(num[0]));
1024 break;
1025
1026 case TY_DBLE:
1027 num[0] = CONVAL1G(sptr);
1028 num[1] = CONVAL2G(sptr);
1029 cprintf(b, "%24.17le", num);
1030 break;
1031 case TY_QUAD:
1032 num[0] = CONVAL1G(sptr);
1033 num[1] = CONVAL2G(sptr);
1034 num[2] = CONVAL3G(sptr);
1035 num[3] = CONVAL4G(sptr);
1036 cprintf(b, "%44.37qd", num);
1037 break;
1038
1039 case TY_CMPLX:
1040 num[0] = CONVAL1G(sptr);
1041 cprintf(b, "%17.10e", (INT*)(size_t)(num[0]));
1042 b[17] = ',';
1043 b[18] = ' ';
1044 num[0] = CONVAL2G(sptr);
1045 cprintf(&b[19], "%17.10e", (INT*)(size_t)(num[0]));
1046 break;
1047
1048 case TY_DCMPLX:
1049 num[0] = CONVAL1G(CONVAL1G(sptr));
1050 num[1] = CONVAL2G(CONVAL1G(sptr));
1051 cprintf(b, "%24.17le", num);
1052 b[24] = ',';
1053 b[25] = ' ';
1054 num[0] = CONVAL1G(CONVAL2G(sptr));
1055 num[1] = CONVAL2G(CONVAL2G(sptr));
1056 cprintf(&b[26], "%24.17le", num);
1057 break;
1058
1059 case TY_NCHAR:
1060 sptr = CONVAL1G(sptr); /* sptr to char string constant */
1061 dtype = DTYPEG(sptr);
1062 goto like_char;
1063 case TY_HOLL:
1064 sptr = CONVAL1G(sptr);
1065 dtype = DTYPEG(sptr);
1066 case TY_CHAR:
1067 like_char:
1068 from = stb.n_base + CONVAL1G(sptr);
1069 len = string_length(dtype);
1070 end = b + 93;
1071 *b = '\"';
1072 for (to = b + 1; len-- && to < end;) {
1073 c = *from++ & 0xff;
1074 if (c == '\"' || c == '\'' || c == '\\') {
1075 *to++ = '\\';
1076 *to++ = c;
1077 } else if (c >= ' ' && c <= '~') {
1078 *to++ = c;
1079 } else if (c == '\n') {
1080 *to++ = '\\';
1081 *to++ = 'n';
1082 }
1083 else {
1084 *to++ = '\\';
1085 /* Mask off 8 bits worth of unprintable character */
1086 sprintf(to, "%03o", (c & 255));
1087 to += 3;
1088 }
1089 }
1090 *to++ = '\"';
1091 *to = '\0';
1092 break;
1093
1094 case TY_PTR:
1095 strcpy(b, "address constant");
1096 break;
1097
1098 default:
1099 interr("getprint:bad const dtype", sptr, 1);
1100 }
1101 return b;
1102 }
1103
1104 /*--------------------------------------------------------------------------*/
1105
1106 #undef _PFG
1107 #define _PFG(cond, str) \
1108 if (cond) \
1109 fprintf(dfil, " %s", str)
1110
1111 /**
1112 \param file the file
1113 \param sptr symbol currently being dumped
1114 */
1115 void
symdentry(FILE * file,int sptr)1116 symdentry(FILE *file, int sptr)
1117 {
1118 FILE *dfil;
1119 int dscptr; /* ptr to dummy parameter descriptor list */
1120 char buff[210]; /* text buffer used to create output lines */
1121 char typeb[4096]; /* buffer for text of dtype */
1122 int stype; /* symbol type of sptr */
1123 int dtype; /* data type of sptr */
1124 int i;
1125
1126 dfil = file ? file : stderr;
1127 strcpy(buff, getprint(sptr));
1128 stype = STYPEG(sptr);
1129 dtype = DTYPEG(sptr);
1130
1131 /* write first line containing symbol name, dtype, and stype: */
1132
1133 if (stype == ST_CMBLK || stype == ST_LABEL || stype == ST_GENERIC ||
1134 stype == ST_NML || stype == ST_USERGENERIC || stype == ST_PD
1135 ) {
1136 fprintf(dfil, "\n%-40.40s %s\n", buff, stb.stypes[stype]);
1137 } else {
1138 *typeb = '\0';
1139 getdtype(dtype, typeb);
1140 fprintf(dfil, "\n%-40.40s %s %s\n", buff, typeb, stb.stypes[stype]);
1141 }
1142 if (UNAMEG(sptr)) {
1143 fprintf(dfil, "original uname:%s \n", stb.n_base + UNAMEG(sptr));
1144 }
1145
1146 /* write second line: */
1147
1148 fprintf(dfil, "sptr: %d hashlk: %d nmptr: %d dtype: %d scope: %d", sptr,
1149 HASHLKG(sptr), NMPTRG(sptr), DTYPEG(sptr), SCOPEG(sptr));
1150 _PFG(INTERNALG(sptr), "internal");
1151 fprintf(dfil, " lineno: %d", LINENOG(sptr));
1152 fprintf(dfil, " enclfunc: %d\n", ENCLFUNCG(sptr));
1153
1154 switch (stype) {
1155 case ST_UNKNOWN:
1156 case ST_IDENT:
1157 case ST_VAR:
1158 case ST_ARRAY:
1159 case ST_DESCRIPTOR:
1160 case ST_STRUCT:
1161 case ST_UNION:
1162 fprintf(dfil, "dcld:%d ccsym:%d save:%d ref:%d dinit:%d",
1163 DCLDG(sptr), CCSYMG(sptr), SAVEG(sptr), REFG(sptr), DINITG(sptr));
1164 fprintf(dfil, " vol:%d ptrv:%d cvlen:%d\n", VOLG(sptr), PTRVG(sptr),
1165 CVLENG(sptr));
1166 fprintf(dfil,
1167 "address: %" ISZ_PF "d sc:%d(%s) symlk: %d midnum: %d ",
1168 ADDRESSG(sptr), SCG(sptr),
1169 (SCG(sptr) <= SC_MAX) ? stb.scnames[SCG(sptr)] : "na", SYMLKG(sptr),
1170 MIDNUMG(sptr));
1171 fprintf(dfil, "socptr: %d autobj: %d\n", SOCPTRG(sptr), AUTOBJG(sptr));
1172 fprintf(dfil, "addrtkn:%d eqv:%d hccsym:%d", ADDRTKNG(sptr), EQVG(sptr),
1173 HCCSYMG(sptr));
1174 fprintf(dfil, " alloc:%d arg:%d seq:%d nml:%d assn:%d", ALLOCG(sptr),
1175 ARGG(sptr), SEQG(sptr), NMLG(sptr), ASSNG(sptr));
1176 fprintf(dfil, "\nprivate:%d", PRIVATEG(sptr));
1177 _PFG(MDALLOCG(sptr), "mdalloc");
1178 #ifdef DYNAMICG
1179 _PFG(DYNAMICG(sptr), "dynamic");
1180 #endif
1181 _PFG(POINTERG(sptr), "pointer");
1182 _PFG(F90POINTERG(sptr), "f90pointer");
1183 _PFG(TARGETG(sptr), "target");
1184 _PFG(NOMDCOMG(sptr), "nomdcom");
1185 _PFG(HIDDENG(sptr), "hidden");
1186 _PFG(IGNOREG(sptr), "ignore");
1187 #ifdef LNRZDG
1188 _PFG(LNRZDG(sptr), "lnrzd");
1189 #endif
1190 _PFG(TYP8G(sptr), "typ8");
1191 _PFG(ASSUMLENG(sptr), "assumlen");
1192 _PFG(ADJLENG(sptr), "adjlen");
1193 _PFG(PARAMG(sptr), "param");
1194 _PFG(PASSBYVALG(sptr), "passbyval");
1195 _PFG(PASSBYREFG(sptr), "passbyref");
1196 _PFG(CFUNCG(sptr), "cfunc");
1197 _PFG(STDCALLG(sptr), "stdcall");
1198 _PFG(ALLOCATTRG(sptr), "allocattr");
1199 _PFG(DESCARRAYG(sptr), "descarray");
1200 _PFG(CONTIGATTRG(sptr), "contigattr");
1201 _PFG(CLASSG(sptr), "class");
1202 _PFG(THREADG(sptr), "thread");
1203 _PFG(PROTECTEDG(sptr), "protected");
1204 if (stype == ST_VAR && CCSYMG(sptr))
1205 _PFG(ERLYSPECG(sptr), "erlyspec");
1206 #ifdef PTRSTOREG
1207 _PFG(PTRSTOREG(sptr), "ptrstore");
1208 #endif
1209 _PFG(DESCUSEDG(sptr), "descused");
1210 _PFG(ALLOCDESCG(sptr), "allocdesc");
1211 _PFG(RESHAPEDG(sptr), "reshaped");
1212 _PFG(INTERNREFG(sptr), "internref");
1213
1214 #ifdef TASKG
1215 _PFG(TASKG(sptr), "task");
1216 #endif
1217 #ifdef PARREFG
1218 _PFG(PARREFG(sptr), "parref");
1219 #endif
1220 #ifdef NOEXTENTG
1221 _PFG(NOEXTENTG(sptr), "noextent");
1222 #endif
1223 #if defined(TARGET_WIN)
1224 if (SCG(sptr) != SC_DUMMY) {
1225 if (DLLG(sptr) == DLL_EXPORT)
1226 fprintf(dfil, " dllexport");
1227 else if (DLLG(sptr) == DLL_IMPORT)
1228 fprintf(dfil, " dllimport");
1229 }
1230 #endif
1231 fprintf(dfil, " sdsc: %d", SDSCG(sptr));
1232 fprintf(dfil, " ptroff: %d", PTROFFG(sptr));
1233 if (NEWARGG(sptr))
1234 fprintf(dfil, " newarg: %d", NEWARGG(sptr));
1235 if (PARAMVALG(sptr))
1236 fprintf(dfil, " paramval: %d", PARAMVALG(sptr));
1237 if (SCG(sptr) == SC_CMBLK)
1238 fprintf(dfil, " cmblk: %d", CMBLKG(sptr));
1239 if (stype == ST_ARRAY) {
1240 fprintf(dfil, "\n");
1241 fprintf(dfil, "asumsz: %d adjarr: %d aftent: %d assumshp: %d",
1242 (int)ASUMSZG(sptr), (int)ADJARRG(sptr), (int)AFTENTG(sptr),
1243 (int)ASSUMSHPG(sptr));
1244 fprintf(dfil, " nodesc: %d", (int)NODESCG(sptr));
1245 }
1246 if (ADJARRG(sptr) || ADJLENG(sptr)) {
1247 fprintf(dfil, "\n");
1248 fprintf(dfil, "adjstrlk: %d", ADJSTRLKG(sptr));
1249 }
1250 fprintf(dfil, " descr: %d\n", DESCRG(sptr));
1251 fprintf(dfil, "altname:%d\n", ALTNAMEG(sptr));
1252 if (SCG(sptr) == SC_DUMMY) {
1253 _PFG(RESULTG(sptr), "result ");
1254 fprintf(dfil, "optarg:%d intent:%s", OPTARGG(sptr),
1255 INTENTG(sptr) == INTENT_IN || INTENTG(sptr) == INTENT_OUT
1256 ? (INTENTG(sptr) == INTENT_IN ? "IN" : "OUT")
1257 : "INOUT");
1258 if (IGNORE_TKRG(sptr)) {
1259 fprintf(dfil, " IGNORE_");
1260 if (IGNORE_TKRG(sptr) & IGNORE_T)
1261 fprintf(dfil, "T");
1262 if (IGNORE_TKRG(sptr) & IGNORE_K)
1263 fprintf(dfil, "K");
1264 if (IGNORE_TKRG(sptr) & IGNORE_R)
1265 fprintf(dfil, "R");
1266 if (IGNORE_TKRG(sptr) & IGNORE_D)
1267 fprintf(dfil, "D");
1268 if (IGNORE_TKRG(sptr) & IGNORE_M)
1269 fprintf(dfil, "M");
1270 if (IGNORE_TKRG(sptr) & IGNORE_C)
1271 fprintf(dfil, "C");
1272 }
1273 fprintf(dfil, "\n");
1274 }
1275 if (stype != ST_UNKNOWN && SCG(sptr) != SC_DUMMY && SOCPTRG(sptr))
1276 dmp_socs(sptr, dfil);
1277
1278 if (DBGBIT(8, 4) && DTY(dtype) == TY_ARRAY) {
1279 /* print the declared array bounds */
1280 char comma = '(';
1281 ADSC *ad;
1282 int i;
1283 static char line[200], *p;
1284 ad = AD_DPTR(dtype);
1285 p = line;
1286 for (i = 0; i < AD_NUMDIM(ad); ++i) {
1287 *p++ = comma;
1288 comma = ',';
1289 if (AD_LWBD(ad, i)) {
1290 *p = '\0';
1291 getast(AD_LWBD(ad, i), p);
1292 p += strlen(p);
1293 *p++ = ':';
1294 }
1295 if (AD_UPBD(ad, i)) {
1296 *p = '\0';
1297 getast(AD_UPBD(ad, i), p);
1298 p += strlen(p);
1299 } else {
1300 *p++ = '*';
1301 }
1302 }
1303 *p++ = ')';
1304 *p = '\0';
1305 fprintf(dfil, "declared bounds %s\n", line);
1306 }
1307 break;
1308
1309 case ST_STAG:
1310 fprintf(dfil, "dcld:%d nest:%d\n", DCLDG(sptr), NESTG(sptr));
1311 break;
1312
1313 case ST_NML:
1314 fprintf(dfil, "symlk: %d address: %" ISZ_PF
1315 "d cmemf: %d cmeml: %d ref: %d\n",
1316 SYMLKG(sptr), ADDRESSG(sptr), CMEMFG(sptr), (int)CMEMLG(sptr),
1317 REFG(sptr));
1318 for (i = CMEMFG(sptr); i; i = NML_NEXT(i))
1319 fprintf(dfil, " nml:%5d sptr:%5d %s\n", i, (int)NML_SPTR(i),
1320 SYMNAME(NML_SPTR(i)));
1321 break;
1322
1323 case ST_MEMBER:
1324 fprintf(dfil,
1325 "address:%" ISZ_PF "d symlk:%d variant:%d fnml:%d ccsym:%d",
1326 ADDRESSG(sptr), SYMLKG(sptr), VARIANTG(sptr), (int)FNMLG(sptr),
1327 CCSYMG(sptr));
1328 fprintf(dfil, "\nencldtype:%d sc:%d(%s) private:%d", ENCLDTYPEG(sptr),
1329 SCG(sptr), (SCG(sptr) <= SC_MAX) ? stb.scnames[SCG(sptr)] : "na",
1330 PRIVATEG(sptr));
1331 _PFG(IGNOREG(sptr), "ignore");
1332 _PFG(POINTERG(sptr), "pointer");
1333 #ifdef LNRZDG
1334 _PFG(LNRZDG(sptr), "lnrzd");
1335 #endif
1336 _PFG(ALLOCG(sptr), "alloc");
1337 _PFG(SEQG(sptr), "seq");
1338 _PFG(ALLOCATTRG(sptr), "allocattr");
1339 _PFG(DESCARRAYG(sptr), "descarray");
1340 _PFG(NOPASSG(sptr), "nopass");
1341 _PFG(CONTIGATTRG(sptr), "contigattr");
1342 _PFG(CLASSG(sptr), "class");
1343 fprintf(dfil, "\n");
1344 fprintf(dfil, "ptroff:%d", PTROFFG(sptr));
1345 fprintf(dfil, " midnum:%d", MIDNUMG(sptr));
1346 fprintf(dfil, " sdsc:%d", SDSCG(sptr));
1347 fprintf(dfil, " descr: %d", DESCRG(sptr));
1348 if (PASSG(sptr))
1349 fprintf(dfil, " pass: %d", PASSG(sptr));
1350 #ifdef IFACEG
1351 if (IFACEG(sptr))
1352 fprintf(dfil, " iface: %d", IFACEG(sptr));
1353 #endif
1354 #ifdef VTABLEG
1355 if (VTABLEG(sptr))
1356 fprintf(dfil, " vtable: %d", VTABLEG(sptr));
1357 #endif
1358 fprintf(dfil, "\n");
1359 break;
1360
1361 case ST_CMBLK:
1362 fprintf(dfil, "save:%d dinit:%d size:%" ISZ_PF "d vol:%d alloc:%d",
1363 SAVEG(sptr), DINITG(sptr), SIZEG(sptr), VOLG(sptr), ALLOCG(sptr));
1364 _PFG(THREADG(sptr), "thread");
1365 fprintf(dfil, " seq:%d private:%d\n", SEQG(sptr), PRIVATEG(sptr));
1366 fprintf(dfil, "hccsym:%d", HCCSYMG(sptr));
1367 #ifdef PDALNG
1368 fprintf(dfil, " pdaln:%d%s", PDALNG(sptr), PDALN_IS_DEFAULT(sptr) ? "(default)" : "");
1369 #endif
1370 _PFG(HIDDENG(sptr), "hidden");
1371 _PFG(IGNOREG(sptr), "ignore");
1372 fprintf(dfil, "\n");
1373 fprintf(dfil, "midnum: %d symlk: %d cmemf: %d cmeml: %d\n",
1374 MIDNUMG(sptr), SYMLKG(sptr), CMEMFG(sptr), (int)CMEMLG(sptr));
1375 fprintf(dfil, "altname: %d", ALTNAMEG(sptr));
1376 _PFG(MODCMNG(sptr), "modcmn");
1377 _PFG(QALNG(sptr), "qaln");
1378 _PFG(CFUNCG(sptr), "cfunc");
1379 _PFG(STDCALLG(sptr), "stdcall");
1380 #ifdef TLSG
1381 _PFG(TLSG(sptr), "tls");
1382 #endif /* TLSG */
1383 #ifdef USE_MPC
1384 if (ETLSG(sptr))
1385 fprintf(file, " etls: %d", ETLSG(sptr));
1386 #endif /* USE_MPC */
1387 #if defined(TARGET_WIN)
1388 if (DLLG(sptr) == DLL_EXPORT)
1389 fprintf(dfil, " dllexport");
1390 else if (DLLG(sptr) == DLL_IMPORT)
1391 fprintf(dfil, " dllimport");
1392 #endif
1393 fprintf(dfil, "\n");
1394 break;
1395
1396 case ST_ENTRY:
1397 fprintf(dfil, "dcld: %d ccsym: %d entstd: %d entnum: %d\n",
1398 DCLDG(sptr), CCSYMG(sptr), ENTSTDG(sptr), (int)ENTNUMG(sptr));
1399 fprintf(dfil, "endline: %d symlk: %d paramct: %d dpdsc: %d\n",
1400 ENDLINEG(sptr), SYMLKG(sptr), PARAMCTG(sptr), DPDSCG(sptr));
1401 fprintf(dfil, "funcline: %d bihnum: %d fval: %d pure: %d impure: %d "
1402 " recur:%d\n",
1403 FUNCLINEG(sptr), BIHNUMG(sptr), FVALG(sptr), PUREG(sptr),
1404 IMPUREG(sptr), RECURG(sptr));
1405 fprintf(dfil, "adjarr:%d aftent:%d assumshp:%d", ADJARRG(sptr),
1406 AFTENTG(sptr), ASSUMSHPG(sptr));
1407 fprintf(dfil, " private:%d", PRIVATEG(sptr));
1408 _PFG(ASSUMLENG(sptr), "assumlen");
1409 _PFG(ADJLENG(sptr), "adjlen");
1410 _PFG(POINTERG(sptr), "pointer");
1411 _PFG(PTRARGG(sptr), "ptrarg");
1412 _PFG(TYP8G(sptr), "typ8");
1413 _PFG(ELEMENTALG(sptr), "elemental");
1414 _PFG(DFLTG(sptr), "dflt");
1415 _PFG(ARETG(sptr), "aret");
1416 fprintf(dfil, "\n");
1417 fprintf(dfil, " gsame: %d\n", (int)GSAMEG(sptr));
1418 fprintf(dfil, "altname: %d", ALTNAMEG(sptr));
1419 #ifdef MVDESCG
1420 _PFG(MVDESCG(sptr), "mvdesc");
1421 #endif
1422 _PFG(MSCALLG(sptr), "mscall");
1423 #ifdef CREFP
1424 _PFG(CREFG(sptr), "cref");
1425 _PFG(NOMIXEDSTRLENG(sptr), "nomixedstrlen");
1426 #endif
1427 _PFG(PASSBYVALG(sptr), "passbyval");
1428 _PFG(PASSBYREFG(sptr), "passbyref");
1429 _PFG(STDCALLG(sptr), "stdcall");
1430 _PFG(CFUNCG(sptr), "cfunc");
1431 _PFG(DECORATEG(sptr), "decorate");
1432 #if defined(TARGET_WIN)
1433 if (DLLG(sptr) == DLL_EXPORT)
1434 fprintf(dfil, " dllexport");
1435 else if (DLLG(sptr) == DLL_IMPORT)
1436 fprintf(dfil, " dllimport");
1437 #endif
1438 fprintf(dfil, "\n");
1439 fprintf(dfil, "Parameters:\n");
1440 dscptr = DPDSCG(sptr);
1441 for (i = PARAMCTG(sptr); i > 0; dscptr++, i--) {
1442 fprintf(dfil, "sptr =%5d", aux.dpdsc_base[dscptr]);
1443 if (aux.dpdsc_base[dscptr])
1444 fprintf(dfil, ", %s", SYMNAME(aux.dpdsc_base[dscptr]));
1445 fprintf(dfil, "\n");
1446 }
1447 break;
1448
1449 case ST_PROC:
1450 fprintf(dfil, "dcld:%d ref:%d ccsym:%d func:%d typd:%d pure:%d "
1451 "impure: %d\n",
1452 DCLDG(sptr), REFG(sptr), CCSYMG(sptr), FUNCG(sptr), TYPDG(sptr),
1453 PUREG(sptr), IMPUREG(sptr));
1454 fprintf(dfil, "fval:%d recur:%d private:%d sc:%d(%s)\n", FVALG(sptr),
1455 RECURG(sptr), PRIVATEG(sptr), SCG(sptr),
1456 (SCG(sptr) <= SC_MAX) ? stb.scnames[SCG(sptr)] : "na");
1457 fprintf(dfil, "symlk: %d paramct: %d dpdsc: %d:", SYMLKG(sptr),
1458 PARAMCTG(sptr), DPDSCG(sptr));
1459 fprintf(dfil, " private:%d inmod:%d fwdref:%d", PRIVATEG(sptr),
1460 INMODULEG(sptr), FWDREFG(sptr));
1461 _PFG(HCCSYMG(sptr), "hccsym");
1462 _PFG(ASSUMLENG(sptr), "assumlen");
1463 _PFG(ADJLENG(sptr), "adjlen");
1464 _PFG(POINTERG(sptr), "pointer");
1465 _PFG(PTRARGG(sptr), "ptrarg");
1466 _PFG(OPTARGG(sptr), "optarg");
1467 _PFG(TYP8G(sptr), "typ8");
1468 _PFG(ARETG(sptr), "aret");
1469 fprintf(dfil, "\n");
1470 fprintf(dfil, "altname: %d", ALTNAMEG(sptr));
1471 #ifdef MVDESCG
1472 _PFG(MVDESCG(sptr), "mvdesc");
1473 #endif
1474 _PFG(CFUNCG(sptr), "cfunc");
1475 _PFG(CSTRUCTRETG(sptr), "cstructret");
1476 _PFG(MSCALLG(sptr), "mscall");
1477 #ifdef CREFP
1478 _PFG(CREFG(sptr), "cref");
1479 _PFG(NOMIXEDSTRLENG(sptr), "nomixedstrlen");
1480 #endif
1481 _PFG(PASSBYVALG(sptr), "passbyval");
1482 _PFG(PASSBYREFG(sptr), "passbyref");
1483 _PFG(STDCALLG(sptr), "stdcall");
1484 _PFG(DECORATEG(sptr), "decorate");
1485 #if defined(TARGET_WIN)
1486 if (SCG(sptr) != SC_DUMMY) {
1487 if (DLLG(sptr) == DLL_EXPORT)
1488 fprintf(dfil, " dllexport");
1489 else if (DLLG(sptr) == DLL_IMPORT)
1490 fprintf(dfil, " dllimport");
1491 }
1492 #endif
1493 _PFG(ELEMENTALG(sptr), "elemental");
1494 _PFG(DFLTG(sptr), "dflt");
1495 #ifdef NOCOG
1496 _PFG(NOCOG(sptr), "noco");
1497 #endif
1498 _PFG(VARARGG(sptr), "vararg");
1499 fprintf(dfil, "\n");
1500 fprintf(dfil, " gsame: %d", (int)GSAMEG(sptr));
1501 if (HCCSYMG(sptr) && INTENTG(sptr)) {
1502 fprintf(dfil, " intent:%s",
1503 INTENTG(sptr) == INTENT_IN || INTENTG(sptr) == INTENT_OUT
1504 ? (INTENTG(sptr) == INTENT_IN ? "IN" : "OUT")
1505 : "INOUT");
1506 }
1507 fprintf(dfil, "\n");
1508 if (DPDSCG(sptr) && PARAMCTG(sptr)) {
1509 fprintf(dfil, "Parameters:\n");
1510 dscptr = DPDSCG(sptr);
1511 for (i = PARAMCTG(sptr); i > 0; dscptr++, i--) {
1512 fprintf(dfil, "sptr =%5d", aux.dpdsc_base[dscptr]);
1513 if (aux.dpdsc_base[dscptr])
1514 fprintf(dfil, ", %s", SYMNAME(aux.dpdsc_base[dscptr]));
1515 fprintf(dfil, "\n");
1516 }
1517 }
1518 break;
1519
1520 case ST_CONST:
1521 fprintf(dfil, "holl: %d ", HOLLG(sptr));
1522 fprintf(dfil, "symlk: %d address: %" ISZ_PF "d conval1: %d ",
1523 SYMLKG(sptr), ADDRESSG(sptr), CONVAL1G(sptr));
1524 if (DTYPEG(sptr) == DT_HOLL)
1525 fprintf(dfil, "conval2: %c\n", CONVAL2G(sptr));
1526 else
1527 fprintf(dfil, "conval2: %d\n", CONVAL2G(sptr));
1528 _PFG(PRIVATEG(sptr), "private");
1529 break;
1530
1531 case ST_LABEL:
1532 fprintf(dfil, "rfcnt: %d address: %" ISZ_PF
1533 "d symlk: %d iliblk: %d fmtpt: %d agoto: %" ISZ_PF "d",
1534 RFCNTG(sptr), ADDRESSG(sptr), SYMLKG(sptr), ILIBLKG(sptr),
1535 FMTPTG(sptr), AGOTOG(sptr));
1536 _PFG(TARGETG(sptr), "target");
1537 _PFG(ASSNG(sptr), "assn");
1538 _PFG(VOLG(sptr), "vol");
1539 fprintf(dfil, "\n");
1540 break;
1541
1542 case ST_STFUNC:
1543 fprintf(dfil, "symlk: %d sfdsc: %x excvlen: %d sfast: %d\n",
1544 SYMLKG(sptr), (int)SFDSCG(sptr), (int)DTY(DTYPEG(sptr) + 1),
1545 SFASTG(sptr));
1546 break;
1547 case ST_PARAM:
1548 if (TY_ISWORD(DTY(dtype))) {
1549 /* fprintf(dfil, "conval1: 0x%lx\n", CONVAL1G(sptr)); */
1550 fprintf(dfil, "conval1: 0x%x (%s)\n", CONVAL1G(sptr), parmprint(sptr));
1551 } else
1552 fprintf(dfil, "conval1: %d (sptr)\n", CONVAL1G(sptr));
1553 fprintf(dfil, "symlk:%d", SYMLKG(sptr));
1554 fprintf(dfil, " private:%d", PRIVATEG(sptr));
1555 _PFG(DCLDG(sptr), "dcld");
1556 _PFG(TYPDG(sptr), "typd");
1557 _PFG(VAXG(sptr), "vax");
1558 _PFG(HIDDENG(sptr), "hidden");
1559 _PFG(IGNOREG(sptr), "ignore");
1560 _PFG(ENDG(sptr), "end");
1561 if (DTY(dtype) != TY_ARRAY)
1562 fprintf(dfil, " conval2: %d(ast)\n", CONVAL2G(sptr));
1563 else
1564 fprintf(dfil, " conval2: get_getitem_p(%d)\n", CONVAL2G(sptr));
1565 break;
1566
1567 case ST_ISOC:
1568 case ST_ISOFTNENV:
1569 case ST_INTRIN:
1570 fprintf(dfil, "dcld:%d expst:%d typd:%d\n", (int)DCLDG(sptr),
1571 (int)EXPSTG(sptr), (int)TYPDG(sptr));
1572 *typeb = '\0';
1573 getdtype((int)ARGTYPG(sptr), typeb);
1574 fprintf(
1575 dfil, "pnmptr: %d paramct: %d ilm: %d arrayf: %d argtype: %s\n",
1576 PNMPTRG(sptr), PARAMCTG(sptr), (int)ILMG(sptr), ARRAYFG(sptr), typeb);
1577 *typeb = '\0';
1578 getdtype((int)INTTYPG(sptr), typeb);
1579 fprintf(dfil, "inttyp: %s intast: %d", typeb, (int)INTASTG(sptr));
1580 _PFG(NATIVEG(sptr), "native");
1581 fprintf(dfil, "\n");
1582 break;
1583
1584 case ST_USERGENERIC:
1585 fprintf(dfil, "gsame: %d gncnt:%d gndsc:%d private:%d gtype:%d\n",
1586 GSAMEG(sptr), GNCNTG(sptr), GNDSCG(sptr), PRIVATEG(sptr),
1587 GTYPEG(sptr));
1588 fprintf(dfil, "Overloaded funcs:\n");
1589 for (dscptr = GNDSCG(sptr); dscptr; dscptr = SYMI_NEXT(dscptr))
1590 fprintf(dfil, "sptr =%5d, %s\n", SYMI_SPTR(dscptr),
1591 SYMNAME(SYMI_SPTR(dscptr)));
1592 break;
1593
1594 case ST_GENERIC:
1595 fprintf(dfil,
1596 "expst:%d typd:%d gsame:%d gsint:%d gint:%d gint8:%d\n",
1597 EXPSTG(sptr), TYPDG(sptr), GSAMEG(sptr), GSINTG(sptr), GINTG(sptr),
1598 GINT8G(sptr));
1599 fprintf(
1600 dfil,
1601 "greal:%d gdble:%d gquad:%d gcmplx:%d gdcmplx:%d gqcmplx:%d\n",
1602 GREALG(sptr), GDBLEG(sptr), GQUADG(sptr), GCMPLXG(sptr), GDCMPLXG(sptr),
1603 GQCMPLXG(sptr));
1604 break;
1605
1606 case ST_PD:
1607 case ST_IEEEARITH:
1608 case ST_IEEEEXCEPT:
1609 case ST_CRAY:
1610 fprintf(dfil, "pdnum: %d intast: %d", (int)PDNUMG(sptr),
1611 (int)INTASTG(sptr));
1612 _PFG(DCLDG(sptr), "dcld");
1613 _PFG(NATIVEG(sptr), "native");
1614 fprintf(dfil, "\n");
1615 break;
1616
1617 case ST_PLIST:
1618 fprintf(dfil, "ref: %d", REFG(sptr));
1619 if (SCG(sptr) == SC_CMBLK)
1620 fprintf(dfil, " cmblk: %d", CMBLKG(sptr));
1621 _PFG(DINITG(sptr), "dinit");
1622 fprintf(dfil, "\n");
1623 fprintf(dfil, "address: %" ISZ_PF "d pllen: %d sc:%d(%s) symlk: %d\n",
1624 ADDRESSG(sptr), PLLENG(sptr), SCG(sptr),
1625 (SCG(sptr) <= SC_MAX) ? stb.scnames[SCG(sptr)] : "na",
1626 SYMLKG(sptr));
1627 if (SYMNAME(sptr)[1] == 'J')
1628 fprintf(dfil, "swel: %d, deflab: %d\n", SWELG(sptr), (int)DEFLABG(sptr));
1629 break;
1630
1631 case ST_ALIAS:
1632 fprintf(dfil, "symlk: %d private: %d ", SYMLKG(sptr), PRIVATEG(sptr));
1633 _PFG(IGNOREG(sptr), "ignore");
1634 fprintf(dfil, "\n");
1635 break;
1636
1637 case ST_ARRDSC:
1638 fprintf(dfil, "descr: %d secd: %d secdsc: %d slnk: %d array %d",
1639 DESCRG(sptr), SECDG(sptr), SECDSCG(sptr), SLNKG(sptr),
1640 ARRAYG(sptr));
1641 fprintf(dfil, " alnd: %d", ALNDG(sptr));
1642 fprintf(dfil, "\n");
1643 break;
1644
1645 case ST_TYPEDEF:
1646 fprintf(dfil, "private:%d", PRIVATEG(sptr));
1647 _PFG(POINTERG(sptr), "pointer");
1648 _PFG(SEQG(sptr), "seq");
1649 _PFG(ALLOCFLDG(sptr), "allocfld");
1650 _PFG(CFUNCG(sptr), "bind(c)");
1651 _PFG(UNLPOLYG(sptr), "unlpoly");
1652 fprintf(dfil, "\n");
1653 break;
1654 case ST_MODULE:
1655 fprintf(dfil, "funcline: %d ", FUNCLINEG(sptr));
1656 fprintf(dfil, "base: %d", CMEMFG(sptr));
1657 fprintf(dfil, " private:%d", PRIVATEG(sptr));
1658 _PFG(DCLDG(sptr), "dcld");
1659 _PFG(DINITG(sptr), "dinit");
1660 _PFG(NEEDMODG(sptr), "needmod");
1661 _PFG(TYPDG(sptr), "typd");
1662 #if defined(TARGET_WIN)
1663 if (DLLG(sptr) == DLL_EXPORT)
1664 fprintf(dfil, " dllexport");
1665 else if (DLLG(sptr) == DLL_IMPORT)
1666 fprintf(dfil, " dllimport");
1667 #endif
1668 fprintf(dfil, "\n");
1669 break;
1670 case ST_OPERATOR:
1671 fprintf(dfil, "inkind:%d pdnum:%d", INKINDG(sptr), PDNUMG(sptr));
1672 fprintf(dfil, " gncnt:%d gndsc:%d", GNCNTG(sptr), GNDSCG(sptr));
1673 fprintf(dfil, " private:%d\n", PRIVATEG(sptr));
1674 fprintf(dfil, "Overloaded funcs:\n");
1675 for (dscptr = GNDSCG(sptr); dscptr; dscptr = SYMI_NEXT(dscptr))
1676 fprintf(dfil, "sptr =%5d, %s\n", SYMI_SPTR(dscptr),
1677 SYMNAME(SYMI_SPTR(dscptr)));
1678 break;
1679 case ST_MODPROC:
1680 fprintf(dfil, "symlk: %d symi: %d gsame: %d private: %d\n",
1681 SYMLKG(sptr), SYMIG(sptr), (int)GSAMEG(sptr), PRIVATEG(sptr));
1682 fprintf(dfil, "Mapped from generics/operators:\n");
1683 for (dscptr = SYMIG(sptr); dscptr; dscptr = SYMI_NEXT(dscptr))
1684 fprintf(dfil, "sptr =%5d, %s\n", SYMI_SPTR(dscptr),
1685 SYMNAME(SYMI_SPTR(dscptr)));
1686 break;
1687 case ST_CONSTRUCT:
1688 fprintf(dfil, "funcline:%d\n", FUNCLINEG(sptr));
1689 break;
1690
1691 case ST_BLOCK:
1692 fprintf(dfil, "startline %d endline %d enclfunc %d\n", STARTLINEG(sptr),
1693 ENDLINEG(sptr), ENCLFUNCG(sptr));
1694 fprintf(dfil, "startlab %d endlab %d", STARTLABG(sptr), ENDLABG(sptr));
1695 fprintf(dfil, " autobj: %d", AUTOBJG(sptr));
1696 fprintf(dfil, "\n");
1697 break;
1698
1699 default:
1700 interr("symdmp: bad symbol type", stype, 1);
1701 }
1702 }
1703
1704 /**
1705 * dump symbol table for debugging purposes. If full == TRUE, dump entire
1706 * symbol table, otherwise dump symtab beginning with user symbols.
1707 */
1708 void
symdmp(FILE * dfil,LOGICAL full)1709 symdmp(FILE *dfil, LOGICAL full)
1710 {
1711 int sptr; /* symbol currently being dumped */
1712
1713 for (sptr = (full ? 1 : stb.firstusym); sptr < stb.stg_avail; sptr++)
1714 symdentry(dfil, sptr);
1715 }
1716
1717 void
dmp_socs(int sptr,FILE * file)1718 dmp_socs(int sptr, FILE *file)
1719 {
1720 int p;
1721 int q;
1722
1723 fprintf(file, "dmp_socs(%d)\n", sptr);
1724 if (!soc.base) {
1725 fprintf(file, "ERROR - soc.base is null\n");
1726 return;
1727 }
1728 q = 0;
1729 for (p = SOCPTRG(sptr); p; p = SOC_NEXT(p)) {
1730 fprintf(file, " overlaps: %s\n", SYMNAME(SOC_SPTR(p)));
1731 if (q == p) {
1732 fprintf(file, ">>>>> soc loop\n");
1733 break;
1734 }
1735 q = p;
1736 }
1737 }
1738
1739 /*--------------------------------------------------------------------------*
1740 * getccsym could be shared between C and Fortran *
1741 *--------------------------------------------------------------------------*/
1742
1743 /**
1744 * create (or possibly reuse) a compiler created symbol whose name is of the
1745 * form . 'letter' dddd where dddd is the decimal representation of n and
1746 * 'letter' is the character specified in the letter argument.
1747 */
1748 int
getccsym(int letter,int n,SYMTYPE stype)1749 getccsym(int letter, int n, SYMTYPE stype)
1750 {
1751 char name[32];
1752 int sptr, i;
1753 char *suffix = IPA_RECOMPILATION_SUFFIX;
1754
1755 sprintf(name, ".%c%04d%s", letter, n, suffix); /* at least 4, could be more */
1756 i = 0;
1757 do {
1758 sptr = getsymbol(name);
1759 if (STYPEG(sptr) == ST_UNKNOWN) {
1760 STYPEP(sptr, stype);
1761 CCSYMP(sptr, 1);
1762 IGNOREP(sptr, 0);
1763 SCOPEP(sptr, stb.curr_scope);
1764 return sptr;
1765 }
1766 if (SCOPEG(sptr) == stb.curr_scope && STYPEG(sptr) == stype)
1767 return sptr;
1768 /* make up a new name */
1769 ++i;
1770 sprintf(&name[2], "%04d%03d%s", n, i, suffix);
1771 } while (1);
1772 }
1773
1774 /**
1775 * create (never reuse) a compiler created symbol whose name is of the
1776 * form . 'letter' dddd where dddd is the decimal representation of n
1777 * and 'letter' is the character specified in the letter argument.
1778 */
1779 int
getnewccsym(int letter,int n,int stype)1780 getnewccsym(int letter, int n, int stype)
1781 {
1782 char name[32];
1783 int sptr;
1784
1785 sprintf(name, ".%c%04d", letter, n); /* at least 4, could be more */
1786 NEWSYM(sptr);
1787 NMPTRP(sptr, putsname(name, strlen(name)));
1788 STYPEP(sptr, stype);
1789 CCSYMP(sptr, 1);
1790 SCOPEP(sptr, 2);
1791 if (gbl.internal > 1)
1792 INTERNALP(sptr, 1);
1793 return (sptr);
1794 } /* getnewccsym */
1795
1796 /**
1797 * create (never reuse) a compiler created symbol whose name is of the
1798 * form .
1799 */
1800 static int
getnewccsym2(char * name,int n,int stype)1801 getnewccsym2(char *name, int n, int stype)
1802 {
1803 int sptr;
1804
1805 NEWSYM(sptr);
1806 NMPTRP(sptr, putsname(name, strlen(name)));
1807 STYPEP(sptr, stype);
1808 CCSYMP(sptr, 1);
1809 SCOPEP(sptr, 2);
1810 if (gbl.internal > 1)
1811 INTERNALP(sptr, 1);
1812 return (sptr);
1813 } /* getnewccsym2 */
1814
1815 int
getnewccsymf(int stype,const char * fmt,...)1816 getnewccsymf(int stype, const char *fmt, ...)
1817 {
1818 char buffer[MAXIDLEN + 1];
1819 va_list ap;
1820 int sptr;
1821
1822 va_start(ap, fmt);
1823 vsnprintf(buffer, sizeof buffer, fmt, ap);
1824 va_end(ap);
1825 buffer[sizeof buffer - 1] = '\0'; /* Windows vsnprintf bug work-around */
1826
1827 return getnewccsym2(buffer, 0 /*unused*/, stype);
1828 }
1829
1830 /**
1831 * similar to getccsym, but storage class is an argument. Calls getccsym
1832 * if the storage class is not private; if private, a 'p' is appended to
1833 * the name.
1834 */
1835 int
getccsym_sc(int letter,int n,int stype,int sc)1836 getccsym_sc(int letter, int n, int stype, int sc)
1837 {
1838 int sptr;
1839
1840 if (sc != SC_PRIVATE)
1841 sptr = getccsym(letter, n, stype);
1842 else {
1843 char name[32];
1844 int i;
1845 char *suffix = IPA_RECOMPILATION_SUFFIX;
1846 sprintf(name, ".%c%04dp%s", letter, n,
1847 suffix); /* at least 4, could be more */
1848 i = 0;
1849 do {
1850 sptr = getsymbol(name);
1851 if (STYPEG(sptr) == ST_UNKNOWN) {
1852 STYPEP(sptr, stype);
1853 CCSYMP(sptr, 1);
1854 IGNOREP(sptr, 0);
1855 SCOPEP(sptr, stb.curr_scope);
1856 break;
1857 }
1858 if (SCOPEG(sptr) == stb.curr_scope && STYPEG(sptr) == stype &&
1859 SCG(sptr) == sc)
1860 break;
1861 /* make up a new name */
1862 ++i;
1863 sprintf(&name[2], "%04d%03dp%s", n, i, suffix);
1864 } while (1);
1865 }
1866 SCP(sptr, sc);
1867 return (sptr);
1868 }
1869
1870 /**
1871 * create (or possibly reuse) a compiler created symbol whose name is of the
1872 * form . "pfx" dddd where dddd is the decimal representation of n and
1873 * "pfx" is the prefix specified in the pfx argument.
1874 */
1875 int
getccssym(const char * pfx,int n,int stype)1876 getccssym(const char *pfx, int n, int stype)
1877 {
1878 char name[32];
1879 int sptr, i;
1880 char *suffix = IPA_RECOMPILATION_SUFFIX;
1881
1882 sprintf(name, ".%s%04d%s", pfx, n, suffix); /* at least 4, could be more */
1883 i = 0;
1884 do {
1885 sptr = getsymbol(name);
1886 if (STYPEG(sptr) == ST_UNKNOWN) {
1887 STYPEP(sptr, stype);
1888 CCSYMP(sptr, 1);
1889 IGNOREP(sptr, 0);
1890 SCOPEP(sptr, stb.curr_scope);
1891 return sptr;
1892 }
1893 if (SCOPEG(sptr) == stb.curr_scope && STYPEG(sptr) == stype)
1894 return sptr;
1895 /* make up a new name */
1896 ++i;
1897 sprintf(&name[strlen(pfx) + 1], "%04d%03d%s", n, i, suffix);
1898 } while (1);
1899 }
1900
1901 /**
1902 * similar to getccssym, but storage class is an argument. Calls getccssym
1903 * if the storage class is not private; if private, a 'p' is appended to
1904 * the name.
1905 */
1906 int
getccssym_sc(const char * pfx,int n,int stype,int sc)1907 getccssym_sc(const char *pfx, int n, int stype, int sc)
1908 {
1909 int sptr;
1910
1911 if (sc != SC_PRIVATE)
1912 sptr = getccssym(pfx, n, stype);
1913 else {
1914 int i = 0;
1915 sptr = getsymf(".%s%04dp%s", pfx, n, IPA_RECOMPILATION_SUFFIX);
1916 do {
1917 if (STYPEG(sptr) == ST_UNKNOWN) {
1918 STYPEP(sptr, stype);
1919 CCSYMP(sptr, 1);
1920 IGNOREP(sptr, 0);
1921 SCOPEP(sptr, stb.curr_scope);
1922 break;
1923 }
1924 if (SCOPEG(sptr) == stb.curr_scope && STYPEG(sptr) == stype &&
1925 SCG(sptr) == sc)
1926 break;
1927 /* make up a new name */
1928 sptr = getsymf(".%s%04d%03dp%s", pfx, n, ++i, IPA_RECOMPILATION_SUFFIX);
1929 } while (1);
1930 }
1931 SCP(sptr, sc);
1932 return sptr;
1933 }
1934
1935 /**
1936 * create (or possibly reuse) a compiler created symbol whose name is of the
1937 * form z_'letter'_'d' where 'd' is the decimal representation of n.
1938 * If the storage class is private, 'p' is appended to the name.
1939 */
1940 int
getcctmp_sc(int letter,int n,int stype,int dtype,int sc)1941 getcctmp_sc(int letter, int n, int stype, int dtype, int sc)
1942 {
1943 int i = 0;
1944 const char *scp = sc == SC_PRIVATE ? "p" : "";
1945 int sptr = getsymf("z_%c_%d%s%s", letter, n,
1946 IPA_RECOMPILATION_SUFFIX, scp);
1947
1948 #if DEBUG
1949 assert(sc, "getcctmp_sc: SC_NONE", letter, 4);
1950 #endif
1951 do {
1952 if (STYPEG(sptr) == ST_UNKNOWN) {
1953 STYPEP(sptr, stype);
1954 DTYPEP(sptr, dtype);
1955 DCLDP(sptr, 1);
1956 SCOPEP(sptr, stb.curr_scope);
1957 HCCSYMP(sptr, 1);
1958 SCP(sptr, sc);
1959 IGNOREP(sptr, 0);
1960 #ifdef CUDAG
1961 if (CUDAG(gbl.currsub) & (CUDA_GLOBAL | CUDA_DEVICE)) {
1962 DEVICEP(sptr, 1);
1963 }
1964 #endif
1965 return (sptr);
1966 }
1967 /* getcctmp_sc() is called from get_arr_tmp() in semutil2.c in a
1968 * search loop that checks dtypes for acceptable matches, so we'll
1969 * allow distinct dtypes here if both are arrays.
1970 */
1971 if (SCOPEG(sptr) == stb.curr_scope && STYPEG(sptr) == stype &&
1972 SCG(sptr) == sc &&
1973 (DTYPEG(sptr) == dtype ||
1974 (dtype > 0 && DTYPEG(sptr) > 0 && DTY(dtype) == TY_ARRAY &&
1975 DTY(DTYPEG(sptr)) == TY_ARRAY)))
1976 return sptr;
1977 /* make up a new name */
1978 sptr = getsymf("z_%c_%d_%d%s%s", letter, n, ++i,
1979 IPA_RECOMPILATION_SUFFIX, scp);
1980 } while (1);
1981 }
1982
1983 /**
1984 * Create a local compiler-created symbol - calls getcctmp_sc with the
1985 * storage class SC_LOCAL.
1986 */
1987 int
getcctmp(int letter,int n,int stype,int dtype)1988 getcctmp(int letter, int n, int stype, int dtype)
1989 {
1990 int sptr;
1991 sptr = getcctmp_sc(letter, n, stype, dtype, SC_LOCAL);
1992 return sptr;
1993 }
1994
1995 /*--------------------------------------------------------------------------*
1996 * insert_sym is the same between C and Fortran *
1997 *--------------------------------------------------------------------------*/
1998
1999 /**
2000 * create new symbol table entry and insert it in the hash list immediately
2001 * in front of 'first':
2002 */
2003 int
insert_sym(int first)2004 insert_sym(int first)
2005 {
2006 int sptr, i, j;
2007 INT hashval;
2008 char *np;
2009
2010 NEWSYM(sptr);
2011 NMPTRP(sptr, NMPTRG(first));
2012 /* link newly created symbol immediately in front of first: */
2013 np = SYMNAME(first);
2014 i = strlen(np);
2015 HASH_ID(hashval, np, i);
2016 HASHLKP(sptr, first);
2017 if (stb.hashtb[hashval] == first)
2018 stb.hashtb[hashval] = sptr;
2019 else {
2020 /* scan hash list to find immed. predecessor of first: */
2021 for (i = stb.hashtb[hashval]; (j = HASHLKG(i)) != first; i = j)
2022 assert(j != 0, "insert_sym: bad hash", first, 4);
2023 HASHLKP(i, sptr);
2024 }
2025
2026 SYMLKP(sptr, NOSYM); /* installsym for ftn also sets SYMLK */
2027 setimplicit(sptr);
2028 if (gbl.internal > 1)
2029 INTERNALP(sptr, 1);
2030 SCOPEP(sptr, stb.curr_scope);
2031 return sptr;
2032 }
2033
2034 /**
2035 * create new symbol table entry and insert it in the hash list
2036 * in front of the head of the list containing 'first':
2037 */
2038 int
insert_sym_first(int first)2039 insert_sym_first(int first)
2040 {
2041 int sptr, i, j;
2042 INT hashval;
2043 char *np;
2044
2045 NEWSYM(sptr);
2046 NMPTRP(sptr, NMPTRG(first));
2047 /* link newly created symbol in front of the hash list: */
2048 np = SYMNAME(first);
2049 i = strlen(np);
2050 HASH_ID(hashval, np, i);
2051 HASHLKP(sptr, stb.hashtb[hashval]);
2052 stb.hashtb[hashval] = sptr;
2053 SYMLKP(sptr, NOSYM); /* installsym for ftn also sets SYMLK */
2054 setimplicit(sptr);
2055 if (gbl.internal > 1)
2056 INTERNALP(sptr, 1);
2057 SCOPEP(sptr, stb.curr_scope);
2058 return sptr;
2059 }
2060
2061 /**
2062 * return a compiler-created label -- user labels begin with '.', compiler-
2063 * created labels begin with '%'. Compiler-created labels will be mapped
2064 * to fortran 77 labels by astout.
2065 */
2066 int
getlab(void)2067 getlab(void)
2068 {
2069 int lab;
2070 while (TRUE) {
2071 lab = getsymf("%%L%05d", stb.lbavail--);
2072 if (STYPEG(lab) != ST_LABEL) {
2073 #if DEBUG
2074 assert(STYPEG(lab) == ST_UNKNOWN, "getlab,sym not unk", lab, 3);
2075 #endif
2076 STYPEP(lab, ST_LABEL);
2077 CCSYMP(lab, 1);
2078 SYMLKP(lab, 0);
2079 break;
2080 }
2081 }
2082 return lab;
2083 }
2084
2085 /** \brief Return TRUE if sptr is in symi list represented by list.
2086 */
2087 LOGICAL
sym_in_sym_list(int sptr,int list)2088 sym_in_sym_list(int sptr, int list)
2089 {
2090 for (; list != 0; list = SYMI_NEXT(list)) {
2091 if (SYMI_SPTR(list) == sptr) {
2092 return TRUE;
2093 }
2094 }
2095 return FALSE;
2096 }
2097
2098 /** \brief Return TRUE if these two symi lists have the same sptrs in the same
2099 * order.
2100 */
2101 LOGICAL
same_sym_list(int list1,int list2)2102 same_sym_list(int list1, int list2)
2103 {
2104 for (;;) {
2105 if (list1 == 0) {
2106 return list2 == 0;
2107 }
2108 if (list2 == 0 || SYMI_SPTR(list1) != SYMI_SPTR(list2)) {
2109 return FALSE;
2110 }
2111 list1 = SYMI_NEXT(list1);
2112 list2 = SYMI_NEXT(list2);
2113 }
2114 }
2115
2116 /**
2117 * \brief remove a symbol from its hash list
2118 */
2119 void
pop_sym(int sptr)2120 pop_sym(int sptr)
2121 {
2122 char *name;
2123 INT hashval;
2124 int s, j, l;
2125
2126 #if DEBUG
2127 if (DBGBIT(5, 1024))
2128 fprintf(gbl.dbgfil, "pop_sym(): sym %d\n", sptr);
2129 #endif
2130 if (NMPTRG(sptr) == 0)
2131 return;
2132 name = SYMNAME(sptr);
2133 l = strlen(name);
2134 HASH_ID(hashval, name, l);
2135 for (s = stb.hashtb[hashval], j = 0; s; s = HASHLKG(s)) {
2136 if (s == sptr) {
2137 #if DEBUG
2138 if (DBGBIT(5, 1024))
2139 fprintf(gbl.dbgfil, "removing %s, sptr:%d\n", SYMNAME(sptr), sptr);
2140 #endif
2141 if (j)
2142 HASHLKP(j, HASHLKG(sptr));
2143 else
2144 stb.hashtb[hashval] = HASHLKG(sptr);
2145 break;
2146 }
2147 j = s;
2148 }
2149 HASHLKP(sptr, 0);
2150 }
2151
2152 /**
2153 * \brief push a symbol onto a hash list
2154 */
2155 void
push_sym(int sptr)2156 push_sym(int sptr)
2157 {
2158 char *name;
2159 int l;
2160 INT hashval;
2161 #if DEBUG
2162 if (DBGBIT(5, 1024))
2163 fprintf(gbl.dbgfil, "push_sym(sym %d)\n", sptr);
2164 #endif
2165 if (NMPTRG(sptr) == 0)
2166 return;
2167 name = SYMNAME(sptr);
2168 l = strlen(name);
2169 HASH_ID(hashval, name, l);
2170 HASHLKP(sptr, stb.hashtb[hashval]);
2171 stb.hashtb[hashval] = sptr;
2172 } /* push_sym */
2173
2174 /** create a function ST item given a name */
2175 SPTR
mkfunc(const char * nmptr)2176 mkfunc(const char *nmptr)
2177 {
2178 SPTR sptr;
2179
2180 sptr = getsymbol(nmptr);
2181 STYPEP(sptr, ST_PROC);
2182 DTYPEP(sptr, DT_INT);
2183 SCP(sptr, SC_EXTERN);
2184 CCSYMP(sptr, 1);
2185 return (sptr);
2186 }
2187
2188 /**
2189 \brief create a coercion function based on the data type.
2190 */
2191 char *
mk_coercion_func_name(int dtype)2192 mk_coercion_func_name(int dtype)
2193 {
2194 SPTR sptr;
2195 FtnRtlEnum rtlRtn;
2196
2197 switch (DTY(dtype)) {
2198 case TY_BINT:
2199 rtlRtn = RTE_int1;
2200 break;
2201 case TY_SINT:
2202 rtlRtn = RTE_int2;
2203 break;
2204 case TY_INT:
2205 rtlRtn = RTE_int4;
2206 break;
2207 case TY_INT8:
2208 rtlRtn = RTE_int8;
2209 break;
2210 case TY_BLOG:
2211 rtlRtn = RTE_log1;
2212 break;
2213 case TY_SLOG:
2214 rtlRtn = RTE_log2;
2215 break;
2216 case TY_LOG:
2217 rtlRtn = RTE_log4;
2218 break;
2219 case TY_LOG8:
2220 rtlRtn = RTE_log8;
2221 break;
2222 case TY_REAL:
2223 rtlRtn = RTE_real4;
2224 break;
2225 case TY_DBLE:
2226 rtlRtn = RTE_real8;
2227 break;
2228 case TY_QUAD:
2229 rtlRtn = RTE_real16;
2230 break;
2231 case TY_CMPLX:
2232 rtlRtn = RTE_cmplx8;
2233 break;
2234 case TY_DCMPLX:
2235 rtlRtn = RTE_cmplx16;
2236 break;
2237 case TY_QCMPLX:
2238 rtlRtn = RTE_cmplx32;
2239 break;
2240 default:
2241 interr("mk_coercion_func_name: ty not allowed", DTY(dtype), 3);
2242 rtlRtn = RTE_no_rtn;
2243 break;
2244 }
2245 return (mkRteRtnNm(rtlRtn));
2246 }
2247
2248 /** \brief Create a coercion function based on the data type.
2249 */
2250 int
mk_coercion_func(int dtype)2251 mk_coercion_func(int dtype)
2252 {
2253 int sptr;
2254
2255 sptr = sym_mkfunc_nodesc(mk_coercion_func_name(dtype), dtype);
2256 return sptr;
2257 }
2258
2259 /**
2260 * create an external variable given a name and its data type. A common block
2261 * of the same name is created and its member is the variable. If the variable
2262 * already exists, just return it.
2263 */
2264 int
mk_external_var(char * name,int dtype)2265 mk_external_var(char *name, int dtype)
2266 {
2267 int commonsptr = getsymbol(name);
2268 int sptr;
2269
2270 if (STYPEG(commonsptr) != ST_UNKNOWN) {
2271 #if DEBUG
2272 if (DTY(dtype) != TY_ARRAY)
2273 assert(STYPEG(commonsptr) == ST_VAR,
2274 "mk_external_var:scalar name conflict", commonsptr, 3);
2275 else
2276 assert(STYPEG(commonsptr) == ST_ARRAY,
2277 "mk_external_var:array name conflict", commonsptr, 3);
2278 #endif
2279 return commonsptr;
2280 }
2281
2282 STYPEP(commonsptr, ST_CMBLK);
2283 DCLDP(commonsptr, 1);
2284 HCCSYMP(commonsptr, 1);
2285 SCP(commonsptr, SC_CMBLK);
2286 pop_sym(commonsptr); /* hide common block from subsequent getsyms */
2287
2288 sptr = getsymbol(name);
2289 if (DTY(dtype) != TY_ARRAY)
2290 STYPEP(sptr, ST_VAR);
2291 else
2292 STYPEP(sptr, ST_ARRAY);
2293 DTYPEP(sptr, dtype);
2294 DCLDP(sptr, 1);
2295 HCCSYMP(sptr, 1);
2296 SCP(sptr, SC_CMBLK);
2297
2298 SYMLKP(commonsptr, gbl.cmblks); /* link into list of common blocks */
2299 gbl.cmblks = commonsptr;
2300 CMEMFP(commonsptr, sptr); /* add the variable to the common */
2301 CMEMLP(commonsptr, NOSYM);
2302 CMBLKP(sptr, commonsptr);
2303 SYMLKP(sptr, NOSYM);
2304
2305 return sptr;
2306 }
2307
2308 /**
2309 \brief determine if an argument is an argument to a given entry
2310 \param ent entry sptr
2311 \param arg argument sptr
2312 */
2313 LOGICAL
is_arg_in_entry(int ent,int arg)2314 is_arg_in_entry(int ent, int arg)
2315 {
2316 int dscptr; /* ptr to dummy parameter descriptor list */
2317 int i;
2318
2319 #if DEBUG
2320 assert(STYPEG(ent) == ST_ENTRY, "is_arg_entry:need ST_ENTRY", ent, 3);
2321 assert(SCG(arg) == SC_DUMMY, "is_arg_entry:need SC_DUMMY", arg, 3);
2322 #endif
2323 dscptr = DPDSCG(ent);
2324 for (i = PARAMCTG(ent); i > 0; dscptr++, i--)
2325 if (arg == *(aux.dpdsc_base + dscptr))
2326 return TRUE;
2327
2328 return FALSE;
2329 }
2330
2331 /**
2332 \brief determine if an argument $p is an $p of argument to a given entry
2333 \param ent entry sptr
2334 \param arg argument sptr
2335 */
2336 LOGICAL
is_argp_in_entry(int ent,int arg)2337 is_argp_in_entry(int ent, int arg)
2338 {
2339 int dscptr; /* ptr to dummy parameter descriptor list */
2340 int i;
2341
2342 #if DEBUG
2343 assert(STYPEG(ent) == ST_ENTRY, "is_arg_entry:need ST_ENTRY", ent, 3);
2344 assert(SCG(arg) == SC_DUMMY, "is_arg_entry:need SC_DUMMY", arg, 3);
2345 #endif
2346 dscptr = DPDSCG(ent);
2347 for (i = PARAMCTG(ent); i > 0; dscptr++, i--) {
2348 int sptr = *(aux.dpdsc_base + dscptr);
2349 if (arg == sptr)
2350 return TRUE;
2351 if (POINTERG(sptr) || ALLOCG(sptr)) {
2352 if (arg == MIDNUMG(sptr))
2353 return TRUE;
2354 }
2355 }
2356
2357 return FALSE;
2358 }
2359
2360 int
resolve_sym_aliases(int sptr)2361 resolve_sym_aliases(int sptr)
2362 {
2363 while (sptr > NOSYM && STYPEG(sptr) == ST_ALIAS) {
2364 sptr = SYMLKG(sptr);
2365 }
2366 return sptr;
2367 }
2368
2369 LOGICAL
is_procedure_ptr(int sptr)2370 is_procedure_ptr(int sptr)
2371 {
2372 sptr = resolve_sym_aliases(sptr);
2373 if (sptr > NOSYM && (POINTERG(sptr) || IS_PROC_DUMMYG(sptr))) {
2374 switch (STYPEG(sptr)) {
2375 case ST_PROC:
2376 case ST_ENTRY:
2377 /* subprograms aren't considered to be procedure pointers */
2378 break;
2379 default:
2380 return is_procedure_ptr_dtype(DTYPEG(sptr));
2381 }
2382 }
2383 return FALSE;
2384 }
2385
2386 void
proc_arginfo(int sptr,int * paramct,int * dpdsc,int * iface)2387 proc_arginfo(int sptr, int *paramct, int *dpdsc, int *iface)
2388 {
2389 if (!is_procedure_ptr(sptr)) {
2390 if (STYPEG(sptr) == ST_GENERIC || STYPEG(sptr) == ST_INTRIN) {
2391 if (paramct)
2392 *paramct = 0;
2393 if (dpdsc)
2394 *dpdsc = 0;
2395 if (iface)
2396 *iface = sptr;
2397 } else if (IS_TBP(sptr)) {
2398 int mem, sptr2;
2399 mem = 0;
2400 sptr2 = get_implementation(TBPLNKG(sptr), sptr, 0, &mem);
2401 if (STYPEG(BINDG(mem)) == ST_OPERATOR ||
2402 STYPEG(BINDG(mem)) == ST_USERGENERIC) {
2403 mem = get_specific_member(TBPLNKG(sptr), sptr);
2404 sptr = VTABLEG(mem);
2405 } else
2406 sptr = sptr2;
2407 if (paramct)
2408 *paramct = PARAMCTG(sptr);
2409 if (dpdsc)
2410 *dpdsc = DPDSCG(sptr);
2411 if (iface)
2412 *iface = (IFACEG(mem)) ? IFACEG(mem) : sptr;
2413 } else if (STYPEG(sptr) == ST_MEMBER && CLASSG(sptr) && CCSYMG(sptr) &&
2414 VTABLEG(sptr) && BINDG(sptr)) {
2415 int mem;
2416 mem = sptr;
2417 sptr = VTABLEG(sptr);
2418 if (paramct)
2419 *paramct = PARAMCTG(sptr);
2420 if (dpdsc)
2421 *dpdsc = DPDSCG(sptr);
2422 if (iface)
2423 *iface = (IFACEG(mem)) ? IFACEG(mem) : sptr;
2424 return;
2425 } else if (STYPEG(sptr) == ST_PD) {
2426 if (paramct)
2427 *paramct = 0;
2428 if (dpdsc)
2429 *dpdsc = 0;
2430 if (iface)
2431 *iface = sptr;
2432 } else {
2433 if (paramct)
2434 *paramct = PARAMCTG(sptr);
2435 if (dpdsc)
2436 *dpdsc = DPDSCG(sptr);
2437 if (iface)
2438 *iface = sptr;
2439 }
2440 } else {
2441 int dtype, dtproc;
2442 dtype = DTYPEG(sptr);
2443 #if DEBUG
2444 assert(DTY(dtype) == TY_PTR, "proc_arginfo, expected TY_PTR dtype", sptr,
2445 4);
2446 #endif
2447 dtproc = DTY(dtype + 1);
2448 #if DEBUG
2449 assert(DTY(dtproc) == TY_PROC, "proc_arginfo, expected TY_PROC dtype", sptr,
2450 4);
2451 #endif
2452 if (paramct)
2453 *paramct = DTY(dtproc + 3);
2454 if (dpdsc)
2455 *dpdsc = DTY(dtproc + 4);
2456 if (iface)
2457 *iface = DTY(dtproc + 2);
2458 }
2459 }
2460
2461 /**
2462 * \brief Compares two symbols by returning true if they both have equivalent
2463 * interfaces. Otherwise, return false.
2464 *
2465 * If flag is set, then we also make sure that sym1 and sym2 have the same
2466 * symbol name.
2467 */
2468 bool
cmp_interfaces(int sym1,int sym2,int flag)2469 cmp_interfaces(int sym1, int sym2, int flag)
2470 {
2471
2472 int i, paramct, paramct2, dpdsc, dpdsc2, psptr, psptr2;
2473 int iface1, iface2;
2474
2475 if (sym1 <= NOSYM)
2476 return false;
2477
2478 /* It's OK for the argument procedure pointer to point to NOSYM as long as
2479 * the formal procedure pointer points to a valid symtab entry.
2480 *
2481 * We assume the following:
2482 *
2483 * sym1 is the formal procedure pointer dummy argument
2484 * sym2 is the actual procedure pointer argument
2485 */
2486 if (sym2 <= NOSYM)
2487 return true;
2488
2489 if (STYPEG(sym1) != ST_PROC) {
2490 int scope, alt_iface;
2491 int hash, hptr, len;
2492 char *symname;
2493 symname = SYMNAME(sym1);
2494 len = strlen(symname);
2495 HASH_ID(hash, symname, len);
2496 for (hptr = stb.hashtb[hash]; hptr; hptr = HASHLKG(hptr)) {
2497 if (STYPEG(hptr) == ST_PROC && strcmp(symname, SYMNAME(hptr)) == 0) {
2498 alt_iface = hptr;
2499 if (alt_iface && (scope = test_scope(alt_iface))) {
2500 if (scope <= test_scope(sym1)) {
2501 sym1 = alt_iface;
2502 break;
2503 }
2504 }
2505 }
2506 }
2507 }
2508 if (STYPEG(sym2) != ST_PROC) {
2509 int scope, alt_iface;
2510 int hash, hptr, len;
2511 char *symname;
2512 symname = SYMNAME(sym2);
2513 len = strlen(symname);
2514 HASH_ID(hash, symname, len);
2515 for (hptr = stb.hashtb[hash]; hptr; hptr = HASHLKG(hptr)) {
2516 if (STYPEG(hptr) == ST_PROC && strcmp(symname, SYMNAME(hptr)) == 0) {
2517 alt_iface = hptr;
2518 if (alt_iface && (scope = test_scope(alt_iface))) {
2519 if (scope <= test_scope(sym2)) {
2520 sym2 = alt_iface;
2521 break;
2522 }
2523 }
2524 }
2525 }
2526 }
2527
2528 iface1 = iface2 = paramct = paramct2 = dpdsc = dpdsc2 = 0;
2529 proc_arginfo(sym1, ¶mct2, &dpdsc2, &iface1);
2530 proc_arginfo(sym2, ¶mct, &dpdsc, &iface2);
2531 if (!iface1 || !iface2)
2532 return false;
2533 if (flag && strcmp(SYMNAME(iface1), SYMNAME(iface2)) != 0)
2534 return false;
2535 if (paramct != paramct2)
2536 return false;
2537 if (iface1 && iface1 == iface2)
2538 return true;
2539 if (!eq_dtype2(DTYPEG(FVALG(iface1)), DTYPEG(FVALG(iface2)), 0))
2540 return false; /* result types differ */
2541 for (i = 0; i < paramct; ++dpdsc, ++dpdsc2, ++i) {
2542 psptr2 = *(aux.dpdsc_base + dpdsc2);
2543 psptr = *(aux.dpdsc_base + dpdsc);
2544 if (!psptr || !psptr2 || STYPEG(psptr) != STYPEG(psptr2) ||
2545 strcmp(SYMNAME(psptr), SYMNAME(psptr2)) != 0)
2546 return false;
2547 if (STYPEG(psptr) == ST_PROC && STYPEG(psptr2) == ST_PROC) {
2548 if (!cmp_interfaces(psptr, psptr2, flag)) {
2549 return false;
2550 }
2551 } else if (!eq_dtype2(DTYPEG(psptr), DTYPEG(psptr2), 0)) {
2552 return false;
2553 }
2554 }
2555 return true;
2556 }
2557
2558 /**
2559 * \brief Tests the characteristics between two interfaces.
2560 *
2561 * \param psptr is the first interface.
2562 *
2563 * \param pstr2 is the second interface.
2564 *
2565 * \param flag is a bit mask that enforces/relaxes certain checks (see
2566 * cmp_interface_flags enum in symtab.c).
2567 *
2568 * \return true if the two characteristics are compatible, else false.
2569 */
2570 bool
compatible_characteristics(int psptr,int psptr2,cmp_interface_flags flag)2571 compatible_characteristics(int psptr, int psptr2, cmp_interface_flags flag)
2572 {
2573
2574 if (!psptr || !psptr2) {
2575 return false;
2576 }
2577
2578 if ( (((flag & RELAX_INTENT_CHK) == 0) &&
2579 INTENTG(psptr) != INTENTG(psptr2)) ||
2580 (((flag & CMP_OPTARG) != 0) && OPTARGG(psptr) != OPTARGG(psptr2)) ||
2581 ALLOCATTRG(psptr) != ALLOCATTRG(psptr2) ||
2582 PASSBYVALG(psptr) != PASSBYVALG(psptr2) ||
2583 ASYNCG(psptr) != ASYNCG(psptr2) || VOLG(psptr) != VOLG(psptr2) ||
2584 CLASSG(psptr) != CLASSG(psptr2) ||
2585 (((flag & RELAX_POINTER_CHK) == 0) &&
2586 POINTERG(psptr) != POINTERG(psptr2)) ||
2587 TARGETG(psptr) != TARGETG(psptr2) ||
2588 CONTIGATTRG(psptr) != CONTIGATTRG(psptr2)) {
2589 if (flag & CMP_SUBMOD_IFACE)
2590 generate_type_mismatch_errors(psptr, psptr2);
2591
2592 return false;
2593 }
2594
2595 if ((flag & RELAX_STYPE_CHK) == 0 && STYPEG(psptr) != STYPEG(psptr2)) {
2596 return false;
2597 }
2598
2599 if (strcmp(SYMNAME(psptr), SYMNAME(psptr2)) != 0) {
2600 if (flag & CMP_SUBMOD_IFACE) {
2601 /* function may use itself name as a return variable, so no name
2602 comparison for function return variables.
2603 */
2604 if (!RESULTG(psptr) && !RESULTG(psptr2))
2605 error(1057, ERR_Severe, gbl.lineno, SYMNAME(psptr2),SYMNAME(psptr));
2606 }
2607 if ((flag & IGNORE_ARG_NAMES) == 0 && (flag & CMP_SUBMOD_IFACE) == 0)
2608 return false;
2609 }
2610
2611 if (STYPEG(psptr) == ST_PROC && STYPEG(psptr2) == ST_PROC &&
2612 (flag & DEFER_IFACE_CHK) == 0) {
2613 if (!cmp_interfaces_strict(psptr, psptr2, (flag | CMP_OPTARG))) {
2614 return false;
2615 }
2616 } else if (DTY(DTYPEG(psptr)) == DTY(DTYPEG(psptr2)) &&
2617 (DTY(DTYPEG(psptr)) == TY_CHAR
2618 || DTY(DTYPEG(psptr)) == TY_NCHAR
2619 )) {
2620 /* check character objects only when they both
2621 * have constant lengths or at least one is assumed shape.
2622 */
2623 int d1 = DTYPEG(psptr);
2624 int a1 = DTY(d1+1);
2625 int d2 = DTYPEG(psptr2);
2626 int a2 = DTY(d2+1);
2627 if ((a1 == 0 || a2 == 0 ||
2628 (A_TYPEG(a1) == A_CNST && A_TYPEG(a2) == A_CNST)) &&
2629 !eq_dtype2(d1, d2, 0)) {
2630 return FALSE;
2631 }
2632 } else if (!eq_dtype2(DTYPEG(psptr), DTYPEG(psptr2), 0)) {
2633 if (flag & CMP_SUBMOD_IFACE) {
2634 /* check whether variable type matches for:
2635 1. argument type
2636 2. function return type
2637 */
2638 if ((DTY(DTYPEG(psptr)) != DTY(DTYPEG(psptr2))) ||
2639 (DDTG(DTYPEG(psptr)) != DDTG(DTYPEG(psptr2)) &&
2640 DTYG(DTYPEG(psptr)) != DTYG(DTYPEG(psptr2))))
2641 generate_type_mismatch_errors(psptr, psptr2);
2642 }
2643 return FALSE;
2644 } else if (DTY(DTYPEG(psptr)) == TY_ARRAY &&
2645 DTY(DTYPEG(psptr2)) == TY_ARRAY) {
2646 /* Check extents of array dimensions. Note: the call to eq_dtype2()
2647 * above checks type and rank.
2648 */
2649 ADSC *ad, *ad2;
2650 int i, ast, ast2, numdim;
2651
2652 ad = AD_DPTR(DTYPEG(psptr));
2653 numdim = AD_NUMDIM(ad);
2654
2655 ad2 = AD_DPTR(DTYPEG(psptr2));
2656
2657 for(i=0; i < numdim; ++i) {
2658 ast = AD_EXTNTAST(ad, i);
2659 ast2 = AD_EXTNTAST(ad2, i);
2660 if (A_TYPEG(ast) == A_CNST && A_TYPEG(ast2) == A_CNST &&
2661 CONVAL2G(A_SPTRG(ast)) != CONVAL2G(A_SPTRG(ast2))) {
2662 return false;
2663 }
2664 }
2665 }
2666
2667 return true;
2668 }
2669
2670 /**
2671 * \brief Same as cmp_interfaces() except we also compare the characteristics as
2672 * defined in "12.2 Characteristics of procedures" in F2003 Spec.
2673 */
2674 bool
cmp_interfaces_strict(SPTR sym1,SPTR sym2,cmp_interface_flags flag)2675 cmp_interfaces_strict(SPTR sym1, SPTR sym2, cmp_interface_flags flag)
2676 {
2677 int i, paramct, paramct2, dpdsc, dpdsc2, psptr, psptr2;
2678 int iface1, iface2, chk_stype, j;
2679 bool relax1, relax2;
2680
2681 iface1 = iface2 = paramct = paramct2 = dpdsc = dpdsc2 = 0;
2682 proc_arginfo(sym1, ¶mct, &dpdsc, &iface1);
2683 proc_arginfo(sym2, ¶mct2, &dpdsc2, &iface2);
2684
2685 if (FVALG(sym1) && FVALG(sym2) && dpdsc > 0 && dpdsc2 > 0) {
2686 /* Check characteristics of results if applicable. We do this here
2687 * to handle the case where one symbol will have its result in argument
2688 * 1 and another symbol will not. This occurs when one symbol is a
2689 * function and another symbol is a function interface (i.e., we do not
2690 * put the function result into argument 1 for interfaces). We then
2691 * adjust parameter counts and argument descriptors when the result is
2692 * in an argument so parameter counts are consistent between the two
2693 * symbols.
2694 */
2695 if (paramct > 0) {
2696 psptr = aux.dpdsc_base[dpdsc];
2697 if (FVALG(sym1) == psptr) {
2698 paramct--;
2699 dpdsc++;
2700 }
2701 }
2702 if (paramct2 > 0) {
2703 psptr2 = aux.dpdsc_base[dpdsc2];
2704 if (FVALG(sym2) == psptr2) {
2705 paramct2--;
2706 dpdsc2++;
2707 }
2708 }
2709 psptr = FVALG(sym1);
2710 psptr2 = FVALG(sym2);
2711 if (!compatible_characteristics(psptr, psptr2, flag)) {
2712 return false;
2713 }
2714 }
2715
2716 /* we may have added descriptors such as type descriptors to the
2717 * argument descriptor. Do not count them.
2718 */
2719
2720 for (j = i = 0; i < paramct; ++i) {
2721 psptr = aux.dpdsc_base[dpdsc + i];
2722 if (CCSYMG(psptr) && CLASSG(psptr)) {
2723 ++j;
2724 }
2725 }
2726 paramct -= j;
2727
2728 for (j = i = 0; i < paramct2; ++i) {
2729 psptr2 = aux.dpdsc_base[dpdsc2 + i];
2730 if (CCSYMG(psptr2) && CLASSG(psptr2)) {
2731 ++j;
2732 }
2733 }
2734 paramct2 -= j;
2735
2736 if (PUREG(sym1) != PUREG(sym2) || IMPUREG(sym1) != IMPUREG(sym2)) {
2737 if (flag & CMP_SUBMOD_IFACE)
2738 error(1060, ERR_Severe, gbl.lineno, "PURE function prefix",SYMNAME(sym1));
2739
2740 relax1 = (flag & RELAX_PURE_CHK_1) != 0;
2741 relax2 = (flag & RELAX_PURE_CHK_2) != 0;
2742
2743 if (!relax1 && !relax2) {
2744 /* both arguments must have matching pure/impure attributes */
2745 return false;
2746 }
2747 if (relax1 != relax2 && PUREG(sym1) != PUREG(sym2)) {
2748 if (!relax1 && PUREG(sym1)) {
2749 /* argument 1 has pure but argument 2 does not. */
2750 return false;
2751 }
2752 if (!relax2 && PUREG(sym2)) {
2753 /* argument 2 has pure but argument 1 does not */
2754 return false;
2755 }
2756 }
2757 }
2758 if (paramct != paramct2) {
2759 if (flag & CMP_SUBMOD_IFACE)
2760 error(1059, ERR_Severe, gbl.lineno, SYMNAME(sym1), NULL);
2761 return false;
2762 }
2763 if (CFUNCG(sym1) != CFUNCG(sym2)){
2764 if (flag & CMP_SUBMOD_IFACE)
2765 error(1060, ERR_Severe, gbl.lineno, "BIND attribute", SYMNAME(sym1));
2766 return false;
2767 }
2768 if (ELEMENTALG(sym1) != ELEMENTALG(sym2)){
2769 if (flag & CMP_SUBMOD_IFACE)
2770 error(1060, ERR_Severe, gbl.lineno, "ELEMENTAL function prefix",SYMNAME(sym1));
2771 return false;
2772 }
2773
2774 if ((FVALG(sym1) && !FVALG(sym2)) || (FVALG(sym2) && !FVALG(sym1))) {
2775 if (flag & CMP_SUBMOD_IFACE)
2776 error(1058, ERR_Severe, gbl.lineno, SYMNAME(sym1), NULL);
2777 return false;
2778 }
2779
2780 if (!iface1 || !iface2)
2781 return false;
2782 if ( ((flag & CMP_IFACE_NAMES) != 0) && strcmp(SYMNAME(iface1),
2783 SYMNAME(iface2)) != 0)
2784 return false;
2785 if (iface1 && iface1 == iface2)
2786 return true;
2787
2788 for (i = 0; i < paramct; ++dpdsc, ++dpdsc2, ++i) {
2789 psptr2 = aux.dpdsc_base[dpdsc2];
2790 psptr = aux.dpdsc_base[dpdsc];
2791
2792 if (!compatible_characteristics(psptr, psptr2, flag)) {
2793 return false;
2794 }
2795
2796 }
2797 return true;
2798 }
2799
2800 /**
2801 * replace contents of a symbol with values defining every field while ensuring
2802 * values necessary for the hashing function are saved and restored.
2803 */
2804 void
dup_sym(int new,SYM * content)2805 dup_sym(int new, SYM *content)
2806 {
2807 int hashlk, nmptr, scope;
2808
2809 hashlk = HASHLKG(new);
2810 nmptr = NMPTRG(new);
2811 scope = SCOPEG(new);
2812 *(stb.stg_base + new) = *content;
2813 HASHLKP(new, hashlk);
2814 NMPTRP(new, nmptr);
2815 SCOPEP(new, scope);
2816 }
2817
2818 /** \Brief Create a duplicate of this sym and return it */
2819 int
insert_dup_sym(int sptr)2820 insert_dup_sym(int sptr)
2821 {
2822 int new_sptr = insert_sym(sptr);
2823 dup_sym(new_sptr, &stb.stg_base[sptr]);
2824 return new_sptr;
2825 }
2826
2827 /** If mod is a submodule, return the module it is a submodule of.
2828 * If it's a module, return mod. Otherwise 0.
2829 */
2830 SPTR
get_ancestor_module(SPTR mod)2831 get_ancestor_module(SPTR mod)
2832 {
2833 if (mod == 0 || STYPEG(mod) != ST_MODULE)
2834 return 0;
2835 for (;;) {
2836 SPTR parent = PARENTG(mod);
2837 if (parent == 0)
2838 return mod;
2839 mod = parent;
2840 }
2841 }
2842
2843 /** return the symbol of the explicit interface of the ST_PROC
2844 */
2845 SPTR
find_explicit_interface(SPTR s)2846 find_explicit_interface(SPTR s) {
2847 SPTR sptr;
2848 for (sptr = HASHLKG(s); sptr; sptr = HASHLKG(sptr)) {
2849 /* skip noise sptr with same string name*/
2850 if (NMPTRG(sptr) != NMPTRG(s))
2851 continue;
2852
2853 if (!INMODULEG(sptr))
2854 break;
2855 if (SEPARATEMPG(sptr))
2856 return sptr;
2857 }
2858
2859 return 0;
2860 }
2861
2862 /** \brief Instantiate a copy of a separate module subprogram's
2863 declared interface as part of the MODULE PROCEDURE's
2864 definition (i.e., implement what would have taken place
2865 had the subprogram been defined with a MODULE SUBROUTINE
2866 or MODULE FUNCTION with a compatible interface).
2867 */
2868 SPTR
instantiate_interface(SPTR iface)2869 instantiate_interface(SPTR iface)
2870 {
2871 int dummies;
2872 SPTR fval, hashlk_sptr, proc;
2873 DEC_DEF_MAP *dec_def_map;
2874 proc = insert_dup_sym(iface);
2875 gbl.currsub = proc;
2876
2877 SCOPEP(proc, SCOPEG(find_explicit_interface(proc)));
2878 dummies = PARAMCTG(iface);
2879 NEW(dec_def_map, DEC_DEF_MAP, dummies);
2880 fval = NOSYM;
2881
2882 STYPEP(proc, ST_ENTRY);
2883 INMODULEP(proc, TRUE);
2884
2885 if (FVALG(iface) > NOSYM) {
2886 fval = insert_sym_first(FVALG(iface));
2887 dup_sym(fval, &stb.stg_base[FVALG(iface)]);
2888
2889 /* Needs to disable hidden attribute to enable proc to
2890 * access derived type members
2891 */
2892 HIDDENP(fval, 0);
2893 IGNOREP(fval, 0);
2894
2895 SCOPEP(fval, proc);
2896 if (ENCLFUNCG(FVALG(iface)) == iface) {
2897 ENCLFUNCP(fval, proc);
2898 }
2899 FVALP(proc, fval);
2900 ++aux.dpdsc_avl; /* always reserve one for fval */
2901 }
2902
2903 if (dummies > 0 || fval > NOSYM) {
2904 int iface_dpdsc = DPDSCG(iface);
2905 int proc_dpdsc = aux.dpdsc_avl;
2906 int j, newdsc;
2907
2908 aux.dpdsc_avl += dummies;
2909 NEED(aux.dpdsc_avl, aux.dpdsc_base, int, aux.dpdsc_size,
2910 aux.dpdsc_size + dummies + 100);
2911 DPDSCP(proc, proc_dpdsc);
2912 if (fval > NOSYM) {
2913 aux.dpdsc_base[proc_dpdsc - 1] = fval;
2914 }
2915 for (j = 0; j < dummies; ++j) {
2916 SPTR arg = aux.dpdsc_base[iface_dpdsc + j];
2917 if (arg > NOSYM) {
2918 dec_def_map[j].dec_sptr = arg;
2919 arg = insert_dup_sym(arg);
2920 dec_def_map[j].def_sptr = arg;
2921 SCOPEP(arg, proc);
2922 if (DTY(DTYPEG(arg)) == TY_ARRAY && ASSUMSHPG(arg)) {
2923 DTYPE elem_dt = array_element_dtype(DTYPEG(arg));
2924 int arr_dsc = mk_arrdsc();
2925 DTY(arr_dsc + 1) = elem_dt;
2926 DTYPEP(arg, arr_dsc);
2927 trans_mkdescr(arg);
2928 ALLOCP(arg, TRUE);
2929 /* needs to tie the array descritor with the symbol arg here*/
2930 get_static_descriptor(arg);
2931 }
2932 if (ALLOCATTRG(arg) || POINTERG(arg)) {
2933 if (!SDSCG(arg))
2934 get_static_descriptor(arg);
2935 if (!PTROFFG(arg))
2936 get_all_descriptors(arg);
2937 }
2938
2939 HIDDENP(arg, 0);
2940 IGNOREP(arg, 0);
2941 if (ENCLFUNCG(arg) == iface) {
2942 ENCLFUNCP(arg, proc);
2943 }
2944 }
2945 aux.dpdsc_base[proc_dpdsc + j] = arg;
2946 }
2947 }
2948
2949 if (ADJARRG(fval)) {
2950 ADSC *ad;
2951 int arr_dsc;
2952 DTYPE elem_dt;
2953 ad = AD_DPTR(DTYPEG(FVALG(iface)));
2954 update_arrdsc(fval, dec_def_map, dummies);
2955 elem_dt = array_element_dtype(DTYPEG(iface));
2956 arr_dsc = mk_arrdsc();
2957 DTY(arr_dsc + 1) = elem_dt;
2958 DTYPEP(fval, arr_dsc);
2959 trans_mkdescr(fval);
2960 }
2961
2962 FREE(dec_def_map);
2963
2964 return proc;
2965 }
2966
2967 /** \brief Update array bound AST SPTRs (old_sptr) using newly created SPTRs
2968 (new_sptr) by referring to DEC_DEF_MAP. The DEC_DEF_MAP is a struct
2969 which contains mapping info from the old_sptr to new_sptr.
2970 */
2971 static void
update_arrdsc(SPTR s,DEC_DEF_MAP * smap,int num_dummies)2972 update_arrdsc(SPTR s, DEC_DEF_MAP *smap, int num_dummies) {
2973 int i, j;
2974 SPTR dec_sptr_lwbd, dec_sptr_upbd;
2975 ADSC *ad;
2976 ad = AD_DPTR(DTYPEG(s));
2977 sem.arrdim.ndim = AD_NUMDIM(ad);
2978 sem.arrdim.ndefer = AD_DEFER(ad);
2979 for (i = 0; i < sem.arrdim.ndim; ++i) {
2980 /* restore arrdsc bound ast info from *ad */
2981 sem.bounds[i].lwast = AD_LWAST(ad, i);
2982 sem.bounds[i].upast = AD_UPAST(ad, i);
2983
2984 /* update arrdsc bound ast info */
2985 dec_sptr_lwbd = A_SPTRG(AD_LWBD(ad, i));
2986 dec_sptr_upbd = A_SPTRG(AD_UPBD(ad, i));
2987 for (j = 0; j < num_dummies; ++j) {
2988 if (dec_sptr_lwbd == smap[j].dec_sptr)
2989 sem.bounds[i].lwast = mk_id(smap[j].def_sptr);
2990 if (dec_sptr_upbd == smap[j].dec_sptr)
2991 sem.bounds[i].upast = mk_id(smap[j].def_sptr);
2992 }
2993 }
2994 }
2995
2996 /**
2997 * reinitialize a symbol
2998 */
2999 void
reinit_sym(int sptr)3000 reinit_sym(int sptr)
3001 {
3002 int nmptr, scope, hashlk;
3003 hashlk = HASHLKG(sptr);
3004 nmptr = NMPTRG(sptr);
3005 scope = SCOPEG(sptr);
3006 BZERO(stb.stg_base + sptr, char, sizeof(SYM));
3007 HASHLKP(sptr, hashlk);
3008 NMPTRP(sptr, nmptr);
3009 SCOPEP(sptr, scope);
3010 } /* reinit_sym */
3011
3012 char *
sym_strsave(char * s)3013 sym_strsave(char *s)
3014 {
3015 int i;
3016 char *p;
3017
3018 i = strlen(s);
3019 NEW(p, char, i + 1);
3020 strcpy(p, s);
3021 return p;
3022 }
3023
3024 static int manglecount = 0;
3025
3026 /**
3027 * create a distinct mangled name
3028 */
3029 char *
mangle_name(char * basename,char * purpose)3030 mangle_name(char *basename, char *purpose)
3031 {
3032 int length, i, j;
3033 int sptr, hashval;
3034 int tail_index;
3035 static char name[MAXIDLEN + 1];
3036 int max_idlen = MAXIDLEN;
3037
3038 /* we use the convention: basename$purpose%d
3039 * if purpose is absent, just basename%d
3040 * to deal with the length issue:
3041 * + if the length of the name exceeds the max allowed, truncate.
3042 * + if a clash occurs, append to or replace the 'tail' of the name
3043 * with a digit string (max 5 digits).
3044 ) */
3045
3046 if (flg.standard) {
3047 max_idlen = STANDARD_MAXIDLEN;
3048 }
3049 length = strlen(basename);
3050 if (length > max_idlen)
3051 length = max_idlen;
3052 memcpy(name, basename, length);
3053 if (purpose) {
3054 j = length + 1 + strlen(purpose); /* basname$purpose */
3055 if (j > max_idlen)
3056 j = max_idlen;
3057 j -= length; /* room for $purpose */
3058 if (j > 0) {
3059 name[length] = '$';
3060 memcpy(&name[length + 1], purpose, j - 1);
3061 length += j;
3062 }
3063 }
3064 name[length] = '\0';
3065 tail_index = length; /* append digit string */
3066 if ((max_idlen - length) < 5)
3067 tail_index = max_idlen - 5; /* no room replace last 5 characters */
3068 for (i = 0;;) {
3069 length = strlen(name);
3070 HASH_ID(hashval, name, length);
3071 for (sptr = stb.hashtb[hashval]; sptr != 0; sptr = HASHLKG(sptr)) {
3072 if (IGNOREG(sptr) && stb.curr_scope == SCOPEG(sptr))
3073 continue;
3074 if (strcmp(name, SYMNAME(sptr)) == 0)
3075 break;
3076 }
3077 if (sptr == 0)
3078 break;
3079 ++i;
3080 ++manglecount;
3081 if (manglecount >= 10000)
3082 manglecount = 0;
3083 sprintf(&name[tail_index], "%d", manglecount);
3084 assert(i < 10000, "mangle_name: too many temps", 0, 4);
3085 }
3086 return name;
3087 }
3088
3089 /**
3090 same as mangle_name, except only clash for members of the same derived type
3091 */
3092 char *
mangle_name_dt(char * basename,char * purpose,int encldtype)3093 mangle_name_dt(char *basename, char *purpose, int encldtype)
3094 {
3095 int length, i, j;
3096 int sptr, hashval;
3097 int tail_index;
3098 static char name[MAXIDLEN + 1];
3099 int max_idlen = MAXIDLEN;
3100
3101 if (flg.standard) {
3102 max_idlen = STANDARD_MAXIDLEN;
3103 }
3104
3105 length = strlen(basename);
3106 if (length > max_idlen)
3107 length = max_idlen;
3108 memcpy(name, basename, length);
3109 if (purpose) {
3110 j = length + 1 + strlen(purpose); /* basname$purpose */
3111 if (j > max_idlen)
3112 j = max_idlen;
3113 j -= length; /* room for $purpose */
3114 if (j > 0) {
3115 name[length] = '$';
3116 memcpy(&name[length + 1], purpose, j - 1);
3117 length += j;
3118 }
3119 }
3120 name[length] = '\0';
3121 tail_index = length; /* append digit string */
3122 if ((max_idlen - length) < 5)
3123 tail_index = max_idlen - 5; /* no room replace last 5 characters */
3124 for (i = 0;;) {
3125 length = strlen(name);
3126 HASH_ID(hashval, name, length);
3127 for (sptr = stb.hashtb[hashval]; sptr != 0; sptr = HASHLKG(sptr)) {
3128 if (STYPEG(sptr) != ST_MEMBER || ENCLDTYPEG(sptr) != encldtype)
3129 continue; /* no clash */
3130 if (strcmp(name, SYMNAME(sptr)) == 0)
3131 break;
3132 }
3133 if (sptr == 0)
3134 break;
3135 ++i;
3136 sprintf(&name[tail_index], "%d", i);
3137 assert(i < 10000, "mangle_name: too many temps", 0, 4);
3138 }
3139 return name;
3140 }
3141
3142 /**
3143 can be called after name mangling if the original name needs to be saved in
3144 the symbol table, (for instance, for debug symbols.)
3145 */
3146 void
save_uname(int newsptr,INT oldnmptr)3147 save_uname(int newsptr, INT oldnmptr)
3148 {
3149 if (!newsptr) {
3150 interr("save_uname bad sptr", newsptr, 3);
3151 return;
3152 }
3153
3154 if (!UNAMEG(newsptr)) {
3155 UNAMEP(newsptr, oldnmptr); /* save original user name */
3156 } else {
3157 ; /* do nothing, name is being changed again. */
3158 }
3159
3160 #if DEBUG
3161 assert(oldnmptr <= stb.namavl, "save_uname: bad nmptr", oldnmptr, 3);
3162 #endif
3163 }
3164
3165 int
add_symitem(int sptr,int nxt)3166 add_symitem(int sptr, int nxt)
3167 {
3168 int i;
3169 i = aux.symi_avl++;
3170 NEED(aux.symi_avl, aux.symi_base, SYMI, aux.symi_size, aux.symi_avl + 100);
3171 SYMI_SPTR(i) = sptr;
3172 SYMI_NEXT(i) = nxt;
3173 return i;
3174 }
3175
3176 /**
3177 * switch from ST_CRAFT/ST_CRAY to ST_PD or vice versa
3178 */
3179 void
change_predefineds(int stype,LOGICAL remove)3180 change_predefineds(int stype, LOGICAL remove)
3181 {
3182 int first, last;
3183 int s;
3184
3185 hpf_library_stat(&first, &last, stype);
3186 if (first == 0)
3187 return;
3188 if (!remove) {
3189 for (s = first; s <= last; s++)
3190 if (STYPEG(s) == stype)
3191 STYPEP(s, ST_PD);
3192 } else {
3193 for (s = first; s <= last; s++)
3194 if (STYPEG(s) == ST_PD)
3195 BCOPY(stb.stg_base + s, init_sym + s, SYM, 1);
3196 }
3197 }
3198
3199 #if DEBUG
3200 void
dbg_symdentry(int sptr)3201 dbg_symdentry(int sptr)
3202 {
3203 symdentry(stderr, sptr);
3204 }
3205 #endif
3206
rw_sym_state(RW_ROUTINE,RW_FILE)3207 void rw_sym_state(RW_ROUTINE, RW_FILE)
3208 {
3209 int nw;
3210
3211 RW_FD(stb.hashtb, stb.hashtb, 1);
3212 RW_SCALAR(stb.firstusym);
3213 RW_SCALAR(stb.stg_avail);
3214 RW_SCALAR(stb.stg_cleared);
3215 RW_FD(stb.stg_base, SYM, stb.stg_avail);
3216
3217 RW_SCALAR(stb.namavl);
3218 RW_FD(stb.n_base, char, stb.namavl);
3219
3220 RW_SCALAR(stb.lbavail);
3221
3222 RW_SCALAR(aux.dpdsc_avl);
3223 RW_FD(aux.dpdsc_base, int, aux.dpdsc_avl);
3224
3225 RW_SCALAR(aux.arrdsc_avl);
3226 RW_FD(aux.arrdsc_base, int, aux.arrdsc_avl);
3227
3228 RW_SCALAR(aux.nml_avl);
3229 RW_FD(aux.nml_base, NMLDSC, aux.nml_avl);
3230
3231 RW_SCALAR(aux.symi_avl);
3232 RW_FD(aux.symi_base, SYMI, aux.symi_avl);
3233
3234 RW_FD(aux.list, int, ST_MAX + 1);
3235
3236 RW_SCALAR(gbl.cmblks);
3237
3238 RW_SCALAR(soc.avail);
3239 if (soc.avail > 1) {
3240 if (ISREAD()) {
3241 if (soc.size == 0) {
3242 soc.size = soc.avail + 100;
3243 NEW(soc.base, SOC_ITEM, soc.size);
3244 } else {
3245 NEED(soc.avail, soc.base, SOC_ITEM, soc.size, soc.avail + 1000);
3246 }
3247 }
3248 RW_FD(soc.base, SOC_ITEM, soc.avail);
3249 }
3250 }
3251
3252 /**
3253 * Compilation is finished - deallocate storage, close files, etc.
3254 */
3255 void
symtab_fini(void)3256 symtab_fini(void)
3257 {
3258 FREE(stb.stg_base);
3259 stb.stg_size = 0;
3260 FREE(stb.n_base);
3261 stb.n_size = 0;
3262 STG_DELETE(stb.dt);
3263 FREE(stb.w_base);
3264 stb.w_size = 0;
3265 fini_chartab();
3266 if (aux.dpdsc_base) {
3267 FREE(aux.dpdsc_base);
3268 aux.dpdsc_avl = aux.dpdsc_size = 0;
3269 }
3270 if (aux.arrdsc_base) {
3271 FREE(aux.arrdsc_base);
3272 aux.arrdsc_avl = aux.arrdsc_size = 0;
3273 }
3274 if (aux.nml_base) {
3275 FREE(aux.nml_base);
3276 aux.nml_avl = aux.nml_size = 0;
3277 }
3278 if (aux.dvl_base) {
3279 FREE(aux.dvl_base);
3280 aux.dvl_avl = aux.dvl_size = 0;
3281 }
3282 if (aux.symi_base) {
3283 FREE(aux.symi_base);
3284 aux.symi_avl = aux.symi_size = 0;
3285 }
3286 if (soc.base) {
3287 FREE(soc.base);
3288 soc.avail = soc.size = 0;
3289 }
3290 if (save_dtimplicit) {
3291 FREE(save_dtimplicit);
3292 dtimplicitsize = dtimplicitstack = 0;
3293 }
3294 } /* symtab_fini */
3295
3296 /**
3297 * call this when -standard is set
3298 */
3299 void
symtab_standard(void)3300 symtab_standard(void)
3301 {
3302 /* remove _TY_INT from TY_LOG types */
3303 dttypes[TY_BLOG] &= ~_TY_INT;
3304 dttypes[TY_SLOG] &= ~_TY_INT;
3305 dttypes[TY_LOG] &= ~_TY_INT;
3306 dttypes[TY_LOG8] &= ~_TY_INT;
3307 } /* symtab_standard */
3308
3309 /**
3310 * call this when -nostandard is set; undo what symtab_standard does
3311 */
3312 void
symtab_nostandard(void)3313 symtab_nostandard(void)
3314 {
3315 /* add _TY_INT to TY_LOG types */
3316 dttypes[TY_BLOG] |= _TY_INT;
3317 dttypes[TY_SLOG] |= _TY_INT;
3318 dttypes[TY_LOG] |= _TY_INT;
3319 dttypes[TY_LOG8] |= _TY_INT;
3320 } /* symtab_nostandard */
3321
3322 /** \brief Adding intrinsics, predeclareds, etc. to symini_ftn has the effect
3323 of rendering existng .mod files incompatible because the values of
3324 stb.firstosym will be different.
3325
3326 stb.firstosym is computed from:
3327 1. the number of intrinsics, predeclareds defined by symini_ftn, and
3328 2. the number of predeclared constants/symbols created in
3329 symtab.c:sym_init() (e.g., 1.0, 0, 2, etc.)
3330
3331 It should be possible to map the 'firstosym' symbols from the
3332 previous symini to the current symini by just subscripting a table
3333 using the old symbol as the index. The purpose of oldsyms0() is to
3334 generate the table, map_init0[], based on the old (6.1) version of
3335 symini and the current symini which defines the mapping. The 6.1
3336 information, represented by init_sym0[] and init_names0[], are
3337 manually extracted from the 6.1-generated syminidf.h; these tables
3338 are just renamed versions of init_sym[] & init_names[]. oldsyms0()
3339 just scans these 'symbols' and looks for the symbols with the same
3340 names in the current symini. In addition to generating the
3341 table, map_init0[], the size of the table, init_syms0_size, is
3342 generated. If new intrinsics are added after today's symini is
3343 released, a new table & size, presumably named init_sym1 and
3344 init_syms1_size, will be generated from inputs init_sym1 &
3345 init_names1. This process should be able to be repreated to create
3346 map_init2, ...
3347
3348 Determine if a firstosym value read from a .mod file matches
3349 the current initial symtab or a previous initial symtab for
3350 which we have mapping information.
3351 */
3352 int
can_map_initsym(int old_firstosym)3353 can_map_initsym(int old_firstosym)
3354 {
3355 int xtra;
3356 if (old_firstosym == stb.firstosym) {
3357 return 1;
3358 }
3359 if (old_firstosym == stb.firstosym - NXTRA) {
3360 return 1;
3361 }
3362 xtra = stb.firstosym - INIT_SYMTAB_SIZE - NXTRA; /*predefined consts, etc.*/
3363 if (old_firstosym == (init_syms0_size + xtra)) {
3364 return 1;
3365 }
3366 if (old_firstosym == (init_syms1_size + xtra)) {
3367 return 1;
3368 }
3369 if (old_firstosym == (init_syms2_size + xtra)) {
3370 return 1;
3371 }
3372 if (old_firstosym == (init_syms3_size + xtra)) {
3373 return 1;
3374 }
3375 return 0;
3376 }
3377
3378 /** \brief Determine if oldsym, read from a .mod file, is a predefined
3379 (intrinsic, predeclared, constant, etc.).
3380
3381 If it is, attempt to map the oldsym to
3382 the current set of predefineds; note that oldsym could also be from
3383 the current set. The value of old_firstosym indicates to which set,
3384 current or older, oldsym belongs.
3385 */
3386 int
map_initsym(int oldsym,int old_firstosym)3387 map_initsym(int oldsym, int old_firstosym)
3388 {
3389 int xtra;
3390
3391 if (old_firstosym == stb.firstosym) {
3392 /* current set of predefineds */
3393 if (oldsym < stb.firstosym)
3394 return oldsym;
3395 return 0;
3396 }
3397
3398 if (old_firstosym == (stb.firstosym - NXTRA)) {
3399 /* current set of predefineds */
3400 if (oldsym < (stb.firstosym - NXTRA))
3401 return oldsym;
3402 return 0;
3403 }
3404
3405 if (oldsym >= old_firstosym)
3406 return 0;
3407
3408 xtra = stb.firstosym - INIT_SYMTAB_SIZE - NXTRA;
3409 if (old_firstosym == (init_syms0_size + xtra)) {
3410 if (oldsym >= init_syms0_size) {
3411 xtra = oldsym - init_syms0_size;
3412 return INIT_SYMTAB_SIZE + xtra;
3413 }
3414 return map_init0[oldsym];
3415 }
3416 if (old_firstosym == (init_syms1_size + xtra)) {
3417 if (oldsym >= init_syms1_size) {
3418 xtra = oldsym - init_syms1_size;
3419 return INIT_SYMTAB_SIZE + xtra;
3420 }
3421 return map_init1[oldsym];
3422 }
3423 if (old_firstosym == (init_syms2_size + xtra)) {
3424 if (oldsym >= init_syms2_size) {
3425 xtra = oldsym - init_syms2_size;
3426 return INIT_SYMTAB_SIZE + xtra;
3427 }
3428 return map_init2[oldsym];
3429 }
3430 if (old_firstosym == (init_syms3_size + xtra)) {
3431 if (oldsym >= init_syms3_size) {
3432 xtra = oldsym - init_syms3_size;
3433 return INIT_SYMTAB_SIZE + xtra;
3434 }
3435 return map_init3[oldsym];
3436 }
3437 interr("map_initsym: bad osym", old_firstosym, 0);
3438 return 0;
3439 }
3440
3441 /** \brief Convert two dollar signs to a hyphen. Especially used for the
3442 submodule *.mod file renaming:
3443 ancestor$$submod.mod -> ancestor-submod.mod
3444 */
3445 void
convert_2dollar_signs_to_hyphen(char * name)3446 convert_2dollar_signs_to_hyphen(char *name) {
3447 char *p, *q;
3448 p = q = name;
3449 while (*q) {
3450 if (*q == '$' && *(q+1) == '$') {
3451 q = q + 2;
3452 *p++ = '-';
3453 }
3454 *p++ = *q++;
3455 }
3456 *p = *q;
3457 }
3458
3459 /** \brief Used for check whether sym2 used inside the scope of sym1 is defined in
3460 parent modules (SCOPEG(sym2)) and used by inherited submodules
3461 ENCLFUNCG(sym1).
3462 */
3463 bool
is_used_by_submod(SPTR sym1,SPTR sym2)3464 is_used_by_submod(SPTR sym1, SPTR sym2) {
3465 if (SCOPEG(sym2) == sym1 &&
3466 STYPEG(ENCLFUNCG(sym1)) == ST_MODULE &&
3467 STYPEG(SCOPEG(sym2)) == ST_MODULE &&
3468 SCOPEG(sym2) == ANCESTORG(ENCLFUNCG(sym1)))
3469 return true;
3470
3471 /* when sym2 is defined in the common block of parent module of submodule sym1 */
3472 if (SCG(sym2) == SC_CMBLK)
3473 return SCOPEG(CMBLKG(sym2)) == ANCESTORG(ENCLFUNCG(sym1));
3474
3475 return false;
3476 }
3477
3478 /** \brief Emit variable type mismatch errors for either subprogram argument variables
3479 or function return type based on separate module subprogram's definition vs.
3480 its declaration.
3481 */
3482 static void
generate_type_mismatch_errors(SPTR s1,SPTR s2)3483 generate_type_mismatch_errors(SPTR s1, SPTR s2) {
3484 if (RESULTG(s1) && RESULTG(s2))
3485 error(1061, ERR_Severe, gbl.lineno, SYMNAME(s1), NULL);
3486 else
3487 error(1058, ERR_Severe, gbl.lineno, SYMNAME(s1), NULL);
3488 }
3489
3490