1 /*
2 * Copyright (c) 1993-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 /** \file
19 * \brief Fortran symbol table access module
20 *
21 * FTN - symbol table access module. This module contains the routines used
22 * to initialize, update, access, and dump the symbol table. Note that in
23 * addition to being used by FTN, this module is used by the utility
24 * program, symini, which processes intrinsic and generic definitions in
25 * order to set up the initial symbol table for FTN.
26 */
27
28 #include "gbldefs.h"
29 #include "error.h"
30 #include "symtab.h"
31 #include "machar.h"
32 #include "symtabdf.h"
33 #include "syminidf.h"
34 #include "soc.h"
35 #include "llmputil.h"
36 #include "llutil.h"
37 #include "llassem.h"
38 #include "dtypeutl.h"
39 #include "symfun.h"
40
41 /* implicit data types */
42 static struct {
43 DTYPE dtype;
44 bool set; /* True if set by IMPLICIT stmt */
45 } dtimplicit[26 + 26 + 2];
46
47 static void cng_generic(char *, char *);
48 static void cng_specific(char *, char *);
49 static void cng_inttyp(char *, int);
50 static void clear_vc(void);
51
52 /* entry hack? */
53 static ENTRY onlyentry;
54
55 /*
56 * Define macro which converts character into index into these arrays:
57 */
58 #define IMPL_INDEX(uc) \
59 (islower(uc) ? uc - 'a' \
60 : (isupper(uc) ? 26 + (uc - 'A') \
61 : (uc == '$' ? 52 : (uc == '_' ? 53 : -1))))
62 /*--------------------------------------------------------------------------*/
63
64 /**
65 \brief Initialize symbol table for new user program unit.
66 */
67 void
sym_init(void)68 sym_init(void)
69 {
70 int i;
71 INT tmp[2];
72 DTYPE default_int;
73 DTYPE default_real;
74 DTYPE dtype;
75 extern void chkstruct();
76
77 /* allocate symbol table and name table space: */
78 sym_init_first();
79
80 init_chartab(); /* see dtypeutl.c */
81
82 STG_RESET(stb.dt);
83 STG_NEXT_SIZE(stb.dt, DT_MAX);
84 for (i = 0; i <= DT_MAX; ++i)
85 DTySet((DTYPE)i, pd_dtype[i]);
86
87 /*
88 * Set up initial implicit types. All are real except for the letters i
89 * thru n:
90 */
91
92 default_real = XBIT(124, 0x8) ? DT_DBLE : DT_REAL;
93 for (i = 0; i < 54; i++) {
94 dtimplicit[i].dtype = default_real;
95 dtimplicit[i].set = false;
96 }
97
98 default_int = flg.i4 ? DT_INT : DT_SINT;
99 if (XBIT(124, 0x10))
100 default_int = DT_INT8;
101 implicit_int(default_int);
102
103 /*
104 * now initialize symbol table. There are 2 cases: The first case occurs
105 * within the utility symini - we start with a totally empty symbol
106 * table. The second case occurs within FTN - the initial symbol table is
107 * copied from some arrays set up by symini.
108 */
109
110 BCOPY(stb.stg_base, init_sym, SYM, INIT_SYMTAB_SIZE);
111 stb.stg_avail = INIT_SYMTAB_SIZE;
112 stb.stg_cleared = INIT_SYMTAB_SIZE;
113 BCOPY(stb.n_base, init_names, char, INIT_NAMES_SIZE);
114 stb.namavl = INIT_NAMES_SIZE;
115
116 BCOPY(stb.hashtb, init_hashtb, int, HASHSIZE);
117
118 if (XBIT(124, 0x20)) {
119 cng_generic("real", "dble");
120 cng_generic("cmplx", "dcmplx");
121 cng_specific("alog", "dlog");
122 cng_specific("alog10", "dlog10");
123 cng_specific("amax1", "dmax1");
124 cng_specific("amin1", "dmin1");
125 cng_specific("amod", "dmod");
126 cng_specific("cabs", "cdabs");
127 cng_specific("csqrt", "cdsqrt");
128 cng_specific("clog", "cdlog");
129 cng_specific("cexp", "cdexp");
130 cng_specific("csin", "cdsin");
131 cng_specific("ccos", "cdcos");
132 if (XBIT(124, 0x80000)) {
133 cng_specific("floati", "dfloti");
134 cng_specific("floatj", "dflotj");
135 cng_specific("float", "dfloat");
136 cng_specific(".floatk", ".dflotk");
137 }
138 }
139 if (XBIT(124, 0x10)) {
140 cng_generic("int", "int8");
141 cng_specific("ifix", "kifix");
142 cng_specific("idint", ".idint8");
143
144 cng_generic("nint", "knint");
145 cng_specific("idnint", "kidnnt");
146
147 cng_specific("iabs", "kiabs");
148 cng_specific("isign", "kisign");
149 cng_specific("idim", "kidim");
150 cng_specific("max0", ".kmax0");
151 cng_specific("max1", "kmax1");
152 cng_specific("min0", ".kmin0");
153 cng_specific("min1", "kmin1");
154 cng_specific("len", "klen");
155 cng_specific("index", "kindex");
156
157 cng_specific("lge", ".lge8");
158 cng_specific("lgt", ".lgt8");
159 cng_specific("lle", ".lle8");
160 cng_specific("llt", ".llt8");
161
162 cng_inttyp("ichar", DT_INT8);
163 cng_inttyp("nlen", DT_INT8);
164 cng_inttyp("nindex", DT_INT8);
165 }
166
167 /* enter constants into symbol table: */
168
169 /* int 0, 1 */
170 tmp[0] = tmp[1] = 0;
171 stb.i0 = getcon(tmp, DT_INT);
172 stb.k0 = getcon(tmp, DT_INT8);
173 tmp[1] = 1;
174 stb.i1 = getcon(tmp, DT_INT);
175 stb.k1 = getcon(tmp, DT_INT8);
176
177 /* l.0, 2.0, 0.5 as floats(reals) */
178 /* 1.0, 2.0, 0.5 as double */
179 add_fp_constants();
180
181 /* allocate space for auxiliary symtab structures: */
182
183 if (aux.dpdsc_size <= 0) {
184 aux.dpdsc_size = 100;
185 NEW(aux.dpdsc_base, int, aux.dpdsc_size);
186 }
187 aux.dpdsc_avl = 0;
188
189 if (aux.arrdsc_size <= 0) {
190 aux.arrdsc_size = 200;
191 NEW(aux.arrdsc_base, int, aux.arrdsc_size);
192 aux.arrdsc_base[0] = 0;
193 }
194 aux.arrdsc_avl = 1;
195
196 if (aux.nml_size <= 0) {
197 aux.nml_size = 200;
198 NEW(aux.nml_base, NMLDSC, aux.nml_size);
199 aux.nml_base[0].sptr = 0;
200 aux.nml_base[0].next = 0;
201 aux.nml_base[0].lineno = 0;
202 }
203 aux.nml_avl = 1;
204
205 if (aux.dvl_size <= 0) {
206 aux.dvl_size = 32;
207 NEW(aux.dvl_base, DVL, aux.dvl_size);
208 }
209 aux.dvl_avl = 0;
210
211 if (aux.symi_size <= 0) {
212 aux.symi_size = 100;
213 NEW(aux.symi_base, SYMI, aux.symi_size);
214 aux.symi_base[0].sptr = 0;
215 aux.symi_base[0].next = 0;
216 }
217 aux.symi_avl = 1; /* 0 => end of list */
218
219 llmp_reset_uplevel();
220
221 BZERO(aux.vtypes, char, sizeof(aux.vtypes));
222 clear_vc();
223
224 aux.curr_entry = &onlyentry;
225 stb.firstusym = (SPTR)stb.stg_avail;
226 stb.lbavail = 0;
227 }
228
229 static void
cng_generic(char * old,char * New)230 cng_generic(char *old, char *New)
231 {
232 int os, ns;
233
234 #undef COPYFIELD
235 #define COPYFIELD(f) stb.stg_base[os].f = stb.stg_base[ns].f
236 os = getsym(old, strlen(old));
237 ns = getsym(New, strlen(New));
238 #if DEBUG
239 assert(STYPEG(os) == ST_GENERIC, "cng_generic not intr", os, ERR_Severe);
240 assert(STYPEG(ns) == ST_GENERIC, "cng_generic not intr", ns, ERR_Severe);
241 #endif
242 COPYFIELD(w9);
243 COPYFIELD(w10);
244 COPYFIELD(w11);
245 COPYFIELD(w12);
246 COPYFIELD(w13);
247 COPYFIELD(w14);
248 COPYFIELD(w15);
249 COPYFIELD(w16);
250 #undef COPYFIELD
251 }
252
253 static void
cng_specific(char * old,char * New)254 cng_specific(char *old, char *New)
255 {
256 int os, ns;
257
258 #define COPYFIELD(f) stb.stg_base[os].f = stb.stg_base[ns].f
259 os = getsym(old, strlen(old));
260 ns = getsym(New, strlen(New));
261 #if DEBUG
262 assert(STYPEG(os) == ST_INTRIN, "cng_specific not intr", os, ERR_Severe);
263 assert(STYPEG(ns) == ST_INTRIN, "cng_specific not intr", ns, ERR_Severe);
264 #endif
265 DTYPEP(os, DTYPEG(ns));
266 COPYFIELD(w9);
267 COPYFIELD(w11);
268 COPYFIELD(w12);
269 COPYFIELD(w13);
270 COPYFIELD(w14);
271 COPYFIELD(w15);
272 #undef COPYFIELD
273 }
274
275 static void
cng_inttyp(char * old,int dt)276 cng_inttyp(char *old, int dt)
277 {
278 int ss;
279 ss = getsym(old, strlen(old));
280 #if DEBUG
281 assert(STYPEG(ss) == ST_INTRIN, "cng_inttyp not intr", ss, ERR_Severe);
282 #endif
283 INTTYPP(ss, dt);
284 }
285
286 /**
287 \brief Simple routine to reset the default integer type for
288 implicitly typing integer variables. Needed for compile-type
289 processing of -i4/-noi4 options in OPTIONS statement.
290 */
291 void
implicit_int(DTYPE default_int)292 implicit_int(DTYPE default_int)
293 {
294 int i;
295 for (i = 8; i <= 13; i++) {
296 dtimplicit[i].dtype = dtimplicit[i + 26].dtype = default_int;
297 }
298 }
299
300 /**
301 \brief Enter symbol with indicated name into symbol table,
302 initialize the new entry, and return pointer to it. If there is
303 already such a symbol, just return pointer to the existing symbol
304 table entry.
305
306 \param name is the symbol name.
307
308 */
309 SPTR
getsymbol(const char * name)310 getsymbol(const char *name)
311 {
312 return getsym(name, strlen(name));
313 }
314
315 /**
316 \brief Like getsymbol, but accepts a string that is *not*
317 null-terminated.
318
319 \param name is the symbol name.
320 \param olength is the number of characters in the symbol name.
321 */
322 SPTR
getsym(const char * name,int olength)323 getsym(const char *name, int olength)
324 {
325 SPTR sptr; /* pointer to symbol table entry */
326
327 sptr = installsym(name, olength);
328 if (STYPEG(sptr) == ST_UNKNOWN)
329 setimplicit(sptr);
330 return sptr;
331 }
332
333 /* FIXME: getcon & get_acon are identical between C and Fortran;
334 should be shared */
335
336 /**
337 \brief Enter constant of given dtype and value into the symbol
338 table and return pointer to it. If an entry for the constant
339 already exists, return pointer to the existing entry instead.
340
341 \param value is the constant value (value[1] if 1 word).
342 \param dtype - tbw.
343 */
344 SPTR
getcon(INT * value,DTYPE dtype)345 getcon(INT *value, DTYPE dtype)
346 {
347 SPTR sptr; /* symbol table pointer */
348 int hashval; /* index into hashtb */
349
350 /*
351 * First loop thru the appropriate hash link list to see if this constant
352 * is already in the symbol table:
353 */
354
355 hashval = HASH_CON(value);
356 if (hashval < 0)
357 hashval = -hashval;
358 for (sptr = stb.hashtb[hashval]; sptr != 0; sptr = HASHLKG(sptr)) {
359 if (DTY(dtype) == TY_128) {
360 if (DTYPEG(sptr) != dtype || STYPEG(sptr) != ST_CONST ||
361 CONVAL1G(sptr) != value[0] || CONVAL2G(sptr) != value[1] ||
362 CONVAL3G(sptr) != value[2] || CONVAL4G(sptr) != value[3])
363 continue;
364
365 /* Matching entry has been found. Return it: */
366 return sptr;
367 }
368 if (DTYPEG(sptr) != dtype || STYPEG(sptr) != ST_CONST ||
369 CONVAL1G(sptr) != value[0] || CONVAL2G(sptr) != value[1])
370 continue;
371
372 /* Matching entry has been found. Return it: */
373
374 return sptr;
375 }
376
377 /* Constant not found. Create a new symbol table entry for it: */
378
379 ADDSYM(sptr, hashval);
380 CONVAL1P(sptr, value[0]);
381 CONVAL2P(sptr, value[1]);
382 if (DTY(dtype) == TY_128) {
383 CONVAL3P(sptr, value[2]);
384 CONVAL4P(sptr, value[3]);
385 }
386 STYPEP(sptr, ST_CONST);
387 DTYPEP(sptr, dtype);
388
389 return sptr;
390 }
391
392 SPTR
get_acon(SPTR sym,ISZ_T off)393 get_acon(SPTR sym, ISZ_T off)
394 {
395 return get_acon3(sym, off, DT_CPTR);
396 }
397
398 /*
399 * BIGOBJects are supported, need an acon-specific getcon
400 */
401 SPTR
get_acon3(SPTR sym,ISZ_T off,DTYPE dtype)402 get_acon3(SPTR sym, ISZ_T off, DTYPE dtype)
403 {
404 INT value[2];
405 SPTR sptr; /* symbol table pointer */
406 int hashval; /* index into stb.hashtb */
407
408 /*
409 * First loop thru the appropriate hash link list to see if this constant
410 * is already in the symbol table:
411 */
412
413 bgitoi64(off, value);
414 value[0] = sym;
415 hashval = HASH_CON(value);
416 if (hashval < 0)
417 hashval = -hashval;
418 for (sptr = stb.hashtb[hashval]; sptr != 0; sptr = HASHLKG(sptr)) {
419 if (DTYPEG(sptr) != dtype || STYPEG(sptr) != ST_CONST ||
420 CONVAL1G(sptr) != sym || ACONOFFG(sptr) != off)
421 continue;
422
423 /* Matching entry has been found. Return it: */
424
425 return sptr;
426 }
427
428 /* Constant not found. Create a new symbol table entry for it: */
429
430 ADDSYM(sptr, hashval);
431 CONVAL1P(sptr, sym);
432 ACONOFFP(sptr, off);
433 STYPEP(sptr, ST_CONST);
434 DTYPEP(sptr, dtype);
435
436 return sptr;
437 }
438
439 SPTR
get_vcon(INT * value,DTYPE dtype)440 get_vcon(INT *value, DTYPE dtype)
441 {
442 SPTR sptr; /* symbol table pointer */
443 int hashval; /* index into stb.hashtb */
444 int i, n;
445 int vc;
446 /*
447 * First loop thru the appropriate hash link list to see if this constant
448 * is already in the symbol table:
449 */
450 hashval = HASH_CON((&stb.dt.stg_base[dtype]));
451 if (hashval < 0)
452 hashval = -hashval;
453 n = DTyVecLength(dtype);
454 for (sptr = stb.hashtb[hashval]; sptr != 0; sptr = HASHLKG(sptr)) {
455 if (DTYPEG(sptr) != dtype || STYPEG(sptr) != ST_CONST)
456 continue;
457 vc = CONVAL1G(sptr);
458 for (i = 0; i < n; i++)
459 if (VCON_CONVAL(vc + i) != value[i])
460 goto cont;
461 /* Matching entry has been found. Return it: */
462 return sptr;
463 cont:;
464 }
465
466 /* Constant not found. Create a new symbol table entry for it: */
467
468 ADDSYM(sptr, hashval);
469
470 vc = aux.vcon_avl;
471 /*
472 * Always add a 4th element to a 3-element vector constant
473 */
474 if (n != 3)
475 aux.vcon_avl += n;
476 else
477 aux.vcon_avl += 4;
478 NEED(aux.vcon_avl, aux.vcon_base, INT, aux.vcon_size, aux.vcon_size + 64);
479 for (i = 0; i < n; i++)
480 VCON_CONVAL(vc + i) = value[i];
481 if (n == 3) {
482 VCON_CONVAL(vc + 3) = 0;
483 }
484 CONVAL1P(sptr, vc);
485 STYPEP(sptr, ST_CONST);
486 DTYPEP(sptr, dtype);
487
488 return sptr;
489 }
490
491 static int vc0[TY_MAX + 1][TY_VECT_MAXLEN];
492 static int vc1[TY_MAX + 1][TY_VECT_MAXLEN];
493 static int vcm0[TY_MAX + 1][TY_VECT_MAXLEN];
494 static int fltm0;
495 static int dblm0;
496
497 /* need to clear it per function */
498 static void
clear_vc(void)499 clear_vc(void)
500 {
501 int arrsize = (TY_MAX + 1) * TY_VECT_MAXLEN;
502 BZERO(vc0, int, arrsize);
503 BZERO(vc1, int, arrsize);
504 BZERO(vcm0, int, arrsize);
505 }
506
507 /** \brief Get a vector constant of a zero which suits the element type.
508 */
509 int
get_vcon0(DTYPE dtype)510 get_vcon0(DTYPE dtype)
511 {
512 int i, n, ty;
513 INT zero;
514 INT v[TY_VECT_MAXLEN];
515
516 n = DTyVecLength(dtype);
517 #if DEBUG
518 assert(sizeof(v) % sizeof(INT) <= n, "get_vcon0 v[] not large enough",
519 __LINE__, ERR_Severe);
520 #endif
521 ty = DTY(DTySeqTyElement(dtype));
522 if (vc0[ty][n - 1])
523 return vc0[ty][n - 1];
524 switch (ty) {
525 case TY_INT8:
526 case TY_LOG8:
527 zero = stb.k0;
528 break;
529 case TY_FLOAT:
530 zero = CONVAL2G(stb.flt0);
531 break;
532 case TY_DBLE:
533 zero = stb.dbl0;
534 break;
535 default:
536 zero = 0;
537 break;
538 }
539 for (i = 0; i < n; i++)
540 v[i] = zero;
541 vc0[ty][n - 1] = get_vcon(v, dtype);
542 return vc0[ty][n - 1];
543 }
544
545 /*
546 * get a vector constant of a one which suits the element type.
547 */
548 int
get_vcon1(DTYPE dtype)549 get_vcon1(DTYPE dtype)
550 {
551 int i, n, ty;
552 INT one, v[TY_VECT_MAXLEN];
553
554 n = DTyVecLength(dtype);
555 #if DEBUG
556 assert(sizeof(v) % sizeof(INT) <= n, "get_vcon1 v[] not large enough",
557 __LINE__, ERR_Severe);
558 #endif
559 ty = DTY(DTySeqTyElement(dtype));
560 if (vc1[ty][n - 1])
561 return vc1[ty][n - 1];
562 switch (ty) {
563 case TY_INT8:
564 case TY_LOG8:
565 one = stb.k1;
566 break;
567 case TY_FLOAT:
568 one = CONVAL2G(stb.flt1);
569 break;
570 case TY_DBLE:
571 one = stb.dbl1;
572 break;
573 default:
574 one = 1;
575 break;
576 }
577 for (i = 0; i < n; i++)
578 v[i] = one;
579 vc1[ty][n - 1] = get_vcon(v, dtype);
580 return vc1[ty][n - 1];
581 }
582
583 int
get_vconm0(DTYPE dtype)584 get_vconm0(DTYPE dtype)
585 {
586 int i, n, ty;
587 INT val[2], zero;
588 INT v[TY_VECT_MAXLEN];
589
590 n = DTyVecLength(dtype);
591 #if DEBUG
592 assert(sizeof(v) % sizeof(INT) <= n, "get_vconm0 v[] not large enough",
593 __LINE__, ERR_Severe);
594 #endif
595 ty = DTY(DTySeqTyElement(dtype));
596 if (vcm0[ty][n - 1])
597 return vcm0[ty][n - 1];
598 switch (ty) {
599 case TY_FLOAT:
600 if (fltm0)
601 zero = CONVAL2G(fltm0);
602 else {
603 val[0] = 0;
604 val[1] = CONVAL2G(stb.flt0) | 0x80000000;
605 fltm0 = getcon(val, DT_FLOAT);
606 zero = val[1];
607 }
608 break;
609 case TY_DBLE:
610 if (!dblm0) {
611 val[0] = CONVAL1G(stb.dbl0) | 0x80000000;
612 val[1] = CONVAL2G(stb.dbl0);
613 dblm0 = getcon(val, DT_DBLE);
614 }
615 zero = dblm0;
616 break;
617 default:
618 vcm0[ty][n - 1] = get_vcon0(dtype);
619 return vcm0[ty][n - 1];
620 }
621 for (i = 0; i < n; i++)
622 v[i] = zero;
623 vcm0[ty][n - 1] = (int)get_vcon(v, dtype); // ???
624 return vcm0[ty][n - 1];
625 }
626
627 /*
628 * get a vector constant by expanding a scalar
629 */
630 SPTR
get_vcon_scalar(INT sclr,DTYPE dtype)631 get_vcon_scalar(INT sclr, DTYPE dtype)
632 {
633 int i, n;
634 INT v[TY_VECT_MAXLEN];
635
636 n = DTyVecLength(dtype);
637 #if DEBUG
638 assert(sizeof(v) % sizeof(INT) <= n, "get_vcon_scalar v[] not large enough",
639 __LINE__, ERR_Severe);
640 #endif
641 for (i = 0; i < n; i++)
642 v[i] = sclr;
643 return get_vcon(v, dtype);
644 }
645
646 ISZ_T
get_isz_cval(int con)647 get_isz_cval(int con)
648 {
649 INT num[2];
650 ISZ_T v;
651 #if DEBUG
652 assert(STYPEG(con) == ST_CONST, "get_isz_cval-not ST_CONST", con, ERR_unused);
653 assert(DT_ISINT(DTYPEG(con)), "get_isz_cval-not 64-bit int const", con,
654 ERR_unused);
655 #endif
656 num[1] = CONVAL2G(con);
657 if (size_of(DTYPEG(con)) > 4)
658 num[0] = CONVAL1G(con);
659 else if (num[1] < 0)
660 num[0] = -1;
661 else
662 num[0] = 0;
663 INT64_2_ISZ(num, v);
664 return v;
665 }
666
667 /**
668 \brief Sign extend an integer value of an indicated width (8, 16,
669 32); value returned is sign extended with respect to the host's int
670 type.
671 */
672 INT
sign_extend(INT val,int width)673 sign_extend(INT val, int width)
674 {
675 /* 32-bit INT */
676 int w;
677
678 if (width == 32)
679 return val;
680 w = 32 - width;
681 return ARSHIFT(LSHIFT(val, w), w);
682 }
683
684 SPTR
getstring(char * value,int length)685 getstring(char *value, int length)
686 {
687 SPTR sptr; /* symbol table pointer */
688 int hashval; /* index into hashtb */
689 char *np; /* pointer to string characters */
690 char *p;
691 int i;
692
693 /*
694 * first loop thru the appropriate hash link list to see if symbol is
695 * already in the table:
696 */
697 HASH_STR(hashval, value, length);
698 /* Ensure hash value is positive. '\nnn' can cause negative hash values */
699 if (hashval < 0)
700 hashval = -hashval;
701 for (sptr = stb.hashtb[hashval]; sptr != SPTR_NULL; sptr = HASHLKG(sptr)) {
702 DTYPE dtype_;
703 if (STYPEG(sptr) != ST_CONST)
704 continue;
705
706 i = dtype_ = DTYPEG(sptr);
707 if (DTY(dtype_) == TY_CHAR && DTyCharLength(dtype_) == length) {
708 /* now match the characters in the strings: */
709 np = stb.n_base + CONVAL1G(sptr);
710 p = value;
711 i = length;
712 while (i--)
713 if (*np++ != *p++)
714 goto Continue;
715
716 /* Matching entry has been found in symtab. Return it: */
717 return sptr;
718 }
719 Continue:;
720 }
721
722 /* String not found. Create a new symtab entry for it: */
723 ADDSYM(sptr, hashval);
724 CONVAL1P(sptr, putsname(value, length));
725 STYPEP(sptr, ST_CONST);
726 DTYPEP(sptr, get_type(2, TY_CHAR, length));
727
728 return sptr;
729 }
730
731 SPTR
getntstring(char * value)732 getntstring(char *value)
733 {
734 int len_string = strlen(value);
735
736 if (len_string)
737 len_string++;
738
739 return getstring(value, len_string);
740 }
741
742 SPTR
getstringaddr(SPTR sptr)743 getstringaddr(SPTR sptr)
744 {
745 SPTR sptrx;
746
747 for (sptrx = stb.firstusym; sptrx < stb.stg_avail; ++sptrx) {
748 if ((STYPEG(sptrx) == ST_CONST) && (DTYPEG(sptr) == DT_ADDR) &&
749 (CONVAL1G(sptrx) == sptr))
750 return sptrx; /* found */
751 }
752
753 /* String not found. Create a new symtab entry */
754 NEWSYM(sptrx); /* can I use get_con here? */
755 CONVAL1P(sptrx, sptr);
756 STYPEP(sptrx, ST_CONST);
757 DTYPEP(sptrx, DT_ADDR);
758
759 return sptrx;
760 }
761
762 void
newimplicit(int firstc,int lastc,DTYPE dtype)763 newimplicit(int firstc, int lastc, DTYPE dtype)
764 {
765 int i, j; /* indices into implicit arrays */
766 char temp[2];
767
768 i = IMPL_INDEX(firstc);
769 j = IMPL_INDEX(lastc);
770 assert(i >= 0 & j >= 0 & i < 54 & j < 54, "newimplicit: bad impl range", i,
771 ERR_Fatal);
772
773 for (; i <= j; i++) {
774 if (dtimplicit[i].set) {
775 temp[0] = 'a' + i;
776 temp[1] = 0;
777 if (dtype == dtimplicit[i].dtype)
778 error((error_code_t)54, ERR_Warning, gbl.lineno, temp, CNULL);
779 else
780 error((error_code_t)54, ERR_Severe, gbl.lineno, temp, CNULL);
781 }
782 dtimplicit[i].dtype = dtype;
783 dtimplicit[i].set = true;
784 }
785 }
786
787 /**
788 \brief Assign to the indicated symbol table entry, the current
789 implicit dtype.
790 */
791 void
setimplicit(int sptr)792 setimplicit(int sptr)
793 {
794 int firstc; /* first character of symbol name */
795 int i; /* index into implicit tables defined by the
796 * first character of the name of sptr. */
797
798 firstc = *SYMNAME(sptr);
799
800 /*
801 * determine index into implicit array. Note that the value returned
802 * will be -1 if this routine is being called from within the symini
803 * utility for a symbol beginning with ".".
804 */
805
806 i = IMPL_INDEX(firstc);
807 if (i != -1) {
808 DTYPEP(sptr, dtimplicit[i].dtype);
809 }
810 }
811
812 /**
813 \brief Scan backwards in the symbol table to reapply the current
814 implicit state to variables which have not been typed. Invoked
815 when an implicit statement follows specification statements
816 (usually a severe error) and the option -x 125 0x80 is specified.
817 */
818 void
reapply_implicit(void)819 reapply_implicit(void)
820 {
821 int sptr;
822 int firstc; /* first character of symbol name */
823 int i; /* index into implicit tables defined by the
824 * first character of the name of sptr. */
825
826 for (sptr = stb.stg_avail - 1; sptr >= stb.firstusym; sptr--) {
827 if (CCSYMG(sptr))
828 continue;
829 switch (STYPEG(sptr)) {
830 case ST_VAR:
831 case ST_PROC:
832 if (!DCLDG(sptr)) {
833 firstc = *SYMNAME(sptr);
834 i = IMPL_INDEX(firstc);
835 DTYPEP(sptr, dtimplicit[i].dtype);
836 }
837 break;
838 case ST_ARRAY:
839 if (!DCLDG(sptr)) {
840 /* WARNING: believe it's safe to overwrite the dtype
841 * in the dtype record; if not, need to 'duplicate' the
842 * array dtype record.
843 */
844 firstc = *SYMNAME(sptr);
845 i = IMPL_INDEX(firstc);
846 DTySetFst(DTYPEG(sptr), dtimplicit[i].dtype);
847 }
848 break;
849 default:
850 break;
851 }
852 }
853 }
854
855 /** \brief Return ptr to printable representation of the indicated PARAMETER.
856 *
857 * \param sptr - symbol table pointer
858 */
859 char *
parmprint(int sptr)860 parmprint(int sptr)
861 {
862 DTYPE dtype;
863 char *buf;
864
865 if (STYPEG(sptr) != ST_PARAM)
866 return "";
867 /*
868 * Change the symbol table entry to an ST_CONST use getprint
869 * to get the character representation.
870 */
871 STYPEP(sptr, ST_CONST);
872 dtype = DTYPEG(sptr);
873 if (DTY(dtype) == TY_SINT || DTY(dtype) == TY_BINT || DTY(dtype) == TY_HOLL ||
874 DTY(dtype) == TY_WORD)
875 DTYPEP(sptr, DT_INT);
876 else if (DTY(dtype) == DT_SLOG || DTY(dtype) == DT_BLOG)
877 DTYPEP(sptr, DT_LOG);
878 if (TY_ISWORD(DTY(dtype))) {
879 CONVAL2P(sptr, CONVAL1G(sptr));
880 buf = getprint(sptr);
881 CONVAL2P(sptr, 0);
882 } else
883 buf = getprint((int)CONVAL1G(sptr));
884 STYPEP(sptr, ST_PARAM);
885 DTYPEP(sptr, dtype);
886 return buf;
887 }
888
889 /*---------------------------------------------------------------------*
890 * getprint cannot be shared between FORTRAN and C *
891 *---------------------------------------------------------------------*/
892
893 /** \brief Return ptr to printable representation of the indicated symbol.
894 *
895 * For symbols which are not constants, the name of the symbol is used.
896 * Constants are converted into the appropriate character representation.
897 *
898 * \param sptr - symbol table pointer
899 */
900 char *
getprint(int sptr)901 getprint(int sptr)
902 {
903 int len; /* length of character string */
904 static char *b = NULL;
905 char *from, *end, *to;
906 int c;
907 INT num[2];
908 DTYPE dtype;
909
910 if (STYPEG(sptr) != ST_CONST) {
911 from = SYMNAME(sptr);
912 if (*from == '\0') {
913 static char bf[16];
914 sprintf(bf, ".%d.", sptr);
915 return bf;
916 }
917 return SYMNAME(sptr);
918 }
919
920 if (b == NULL) {
921 NEW(b, char, 100);
922 }
923 dtype = DTYPEG(sptr);
924 switch (DTY(dtype)) {
925 case TY_WORD:
926 sprintf(b, "%08X", CONVAL2G(sptr));
927 break;
928 case TY_DWORD:
929 sprintf(b, "%08X%08X", CONVAL1G(sptr), CONVAL2G(sptr));
930 break;
931 case TY_INT8:
932 case TY_LOG8:
933 num[0] = CONVAL1G(sptr);
934 num[1] = CONVAL2G(sptr);
935 ui64toax(num, b, 22, 0, 10);
936 break;
937 case TY_INT:
938 case TY_LOG:
939 sprintf(b, "%d", CONVAL2G(sptr));
940 break;
941 case TY_REAL:
942 num[0] = CONVAL2G(sptr);
943 cprintf(b, "%17.10e", (INT *)((BIGINT)num[0]));
944 break;
945
946 case TY_DBLE:
947 num[0] = CONVAL1G(sptr);
948 num[1] = CONVAL2G(sptr);
949 cprintf(b, "%24.17le", num);
950 break;
951
952 case TY_CMPLX:
953 num[0] = CONVAL1G(sptr);
954 cprintf(b, "%17.10e", (INT *)((BIGINT)num[0]));
955 b[17] = ',';
956 b[18] = ' ';
957 num[0] = CONVAL2G(sptr);
958 cprintf(&b[19], "%17.10e", (INT *)((BIGINT)num[0]));
959 break;
960
961 case TY_DCMPLX:
962 num[0] = CONVAL1G(CONVAL1G(sptr));
963 num[1] = CONVAL2G(CONVAL1G(sptr));
964 cprintf(b, "%24.17le", num);
965 b[24] = ',';
966 b[25] = ' ';
967 num[0] = CONVAL1G(CONVAL2G(sptr));
968 num[1] = CONVAL2G(CONVAL2G(sptr));
969 cprintf(&b[26], "%24.17le", num);
970 break;
971
972 case TY_NCHAR:
973 sptr = CONVAL1G(sptr); /* sptr to char string constant */
974 dtype = DTYPEG(sptr);
975 case TY_HOLL: /* Should be no holleriths in symbol table */
976 case TY_CHAR:
977 from = stb.n_base + CONVAL1G(sptr);
978 len = DTyCharLength(dtype);
979 end = b + 93;
980 *b = '\"';
981 for (to = b + 1; len-- && to < end;) {
982 c = *from++ & 0xff;
983 if (c == '\"' || c == '\'' || c == '\\') {
984 *to++ = '\\';
985 *to++ = c;
986 } else if (c >= ' ' && c <= '~') {
987 *to++ = c;
988 } else if (c == '\n') {
989 *to++ = '\\';
990 *to++ = 'n';
991 }
992 else {
993 *to++ = '\\';
994 /* Mask off 8 bits worth of unprintable character */
995 sprintf(to, "%03o", (c & 255));
996 to += 3;
997 }
998 }
999 *to++ = '\"';
1000 *to = '\0';
1001 break;
1002
1003 case TY_128:
1004 sprintf(b, "%08x %08x %08x %08x", CONVAL1G(sptr), CONVAL2G(sptr),
1005 CONVAL3G(sptr), CONVAL4G(sptr));
1006 break;
1007
1008 case TY_PTR:
1009 strcpy(b, "address constant");
1010 break;
1011
1012 case TY_VECT:
1013 strcpy(b, "vector constant");
1014 break;
1015
1016 default:
1017 interr("getprint:bad const dtype", sptr, ERR_Informational);
1018 }
1019 return b;
1020 }
1021
1022 /*
1023 * dump symbol table information for symbol sptr.
1024 */
1025 static void putaltname(FILE *, int, char *);
1026 static void putcuda(FILE *, int);
1027
1028 #undef _PFG
1029 #define _PFG(cond, str) \
1030 if (cond) \
1031 fprintf(dfil, " %s", str)
1032
1033 #if DEBUG
1034 /**
1035 \param file the file.
1036 \param sptr symbol currently being dumped.
1037 */
1038 void
symdentry(FILE * file,int sptr)1039 symdentry(FILE *file, int sptr)
1040 {
1041 FILE *dfil;
1042 int dscptr; /* ptr to dummy parameter descriptor list */
1043 char buff[110]; /* text buffer used to create output lines */
1044 char typeb[110]; /* buffer for text of dtype */
1045 int stype; /* symbol type of sptr */
1046 DTYPE dtype; /* data type of sptr */
1047 int i;
1048
1049 dfil = file ? file : stderr;
1050 strcpy(buff, getprint(sptr));
1051 stype = STYPEG(sptr);
1052 dtype = DTYPEG(sptr);
1053
1054 /* write first line containing symbol name, dtype, and stype: */
1055
1056 if (stype == ST_CMBLK || stype == ST_LABEL || stype == ST_GENERIC ||
1057 stype == ST_NML || stype == ST_PD)
1058 fprintf(dfil, "\n%-40.40s %s\n", buff, stb.stypes[stype]);
1059 else {
1060 *typeb = '\0';
1061 getdtype(dtype, typeb);
1062 fprintf(dfil, "\n%-40.40s %s %s\n", buff, typeb, stb.stypes[stype]);
1063 }
1064
1065 /* write second line: */
1066
1067 fprintf(dfil, "sptr: %d hashlk: %d nmptr: %d dtype: %d\n", sptr,
1068 HASHLKG(sptr), NMPTRG(sptr), dtype);
1069
1070 switch (stype) {
1071 case ST_UNKNOWN:
1072 case ST_IDENT:
1073 case ST_VAR:
1074 case ST_ARRAY:
1075 case ST_STRUCT:
1076 case ST_UNION:
1077 fprintf(dfil, "dcld: %d ccsym: %d save: %d ref: %d dinit: %d vol: %d",
1078 DCLDG(sptr), CCSYMG(sptr), SAVEG(sptr), REFG(sptr), DINITG(sptr),
1079 VOLG(sptr));
1080 fprintf(dfil, " scope: %d enclfunc: %d\n", SCOPEG(sptr), ENCLFUNCG(sptr));
1081 fprintf(dfil, "address: %" ISZ_PF "d sc:%d(%s) symlk: %d midnum: %d",
1082 ADDRESSG(sptr), SCG(sptr),
1083 (SCG(sptr) <= SC_MAX) ? stb.scnames[SCG(sptr)] : "na", SYMLKG(sptr),
1084 MIDNUMG(sptr));
1085 if (CLENG(sptr))
1086 fprintf(dfil, " clen: %d", CLENG(sptr));
1087 if (SOCPTRG(sptr))
1088 fprintf(dfil, " socptr: %d", SOCPTRG(sptr));
1089 #ifdef BASESYMG
1090 if (BASESYMG(sptr))
1091 fprintf(dfil, " basesym: %d", BASESYMG(sptr));
1092 #endif
1093 fprintf(dfil, "\n");
1094 fprintf(dfil, "addrtkn: %d", ADDRTKNG(sptr));
1095 _PFG(REGARGG(sptr), "regarg");
1096 _PFG(MEMARGG(sptr), "memarg");
1097 _PFG(COPYPRMSG(sptr), "copyprms");
1098 _PFG(ALLOCG(sptr), "alloc");
1099 _PFG(ASSNG(sptr), "assn");
1100 _PFG(THREADG(sptr), "thread");
1101 _PFG(QALNG(sptr), "qaln");
1102 _PFG(PASSBYVALG(sptr), "passbyval");
1103 _PFG(PASSBYREFG(sptr), "passbyref");
1104 _PFG(STDCALLG(sptr), "stdcall");
1105 _PFG(CFUNCG(sptr), "cfunc");
1106 #ifdef CONTIGATTRG
1107 _PFG(CONTIGATTRG(sptr), "contigattr");
1108 #endif
1109 #ifdef TASKG
1110 _PFG(TASKG(sptr), "task");
1111 #endif
1112 #ifdef PARREFG
1113 _PFG(PARREFG(sptr), "parref");
1114 #endif
1115 #if defined(TARGET_WIN_X86)
1116 if (DLLG(sptr) == DLL_EXPORT)
1117 fprintf(dfil, " dllexport");
1118 else if (DLLG(sptr) == DLL_IMPORT)
1119 fprintf(dfil, " dllimport");
1120 #endif
1121 #ifdef INLNG
1122 _PFG(INLNG(sptr), "inln");
1123 if (INLNG(sptr) && SCG(sptr) == SC_BASED) {
1124 _PFG(UNSAFEG(sptr), "unsafe");
1125 }
1126 #endif
1127 /*if (SCG(sptr) == SC_BASED)*/
1128 fprintf(dfil, " noconflict:%d", NOCONFLICTG(sptr));
1129 if (stype == ST_ARRAY ||
1130 ((stype == ST_STRUCT || stype == ST_UNION) && dtype > 0 &&
1131 dtype < stb.dt.stg_avail && DTY(dtype) == TY_ARRAY)) {
1132 fprintf(dfil, " asumsz:%d adjarr:%d aftent:%d", (int)ASUMSZG(sptr),
1133 (int)ADJARRG(sptr), (int)AFTENTG(sptr));
1134 /* for fortran-90 */
1135 fprintf(dfil, " assumshp:%d", ASSUMSHPG(sptr));
1136 fprintf(dfil, " sdsc:%d origdim:%d sdscs1:%d", (int)SDSCG(sptr),
1137 (int)ORIGDIMG(sptr), SDSCS1G(sptr));
1138 }
1139 /* for fortran-90 */
1140 fprintf(dfil, "\n");
1141 fprintf(dfil, "pointer: %d", (int)POINTERG(sptr));
1142 fprintf(dfil, " uplevel: %d", (int)UPLEVELG(sptr));
1143 fprintf(dfil, " internref: %d", (int)INTERNREFG(sptr));
1144 fprintf(dfil, " gscope: %d", (int)GSCOPEG(sptr));
1145 fprintf(dfil, " origdummy: %d", (int)ORIGDUMMYG(sptr));
1146 _PFG(LSCOPEG(sptr), "lscope");
1147 _PFG(PTRSAFEG(sptr), "ptrsafe");
1148 _PFG(ALLOCATTRG(sptr), "allocattr");
1149 _PFG(F90POINTERG(sptr), "f90pointer");
1150 _PFG(REREFG(sptr), "reref");
1151 if (stype == ST_ARRAY) {
1152 _PFG(DESCARRAYG(sptr), "descarray");
1153 }
1154 if (SCG(sptr) == SC_DUMMY) {
1155 _PFG(OPTARGG(sptr), "optarg");
1156 _PFG(INTENTING(sptr), "intentin");
1157 }
1158 if (SCG(sptr) == SC_DUMMY) {
1159 _PFG(UNSAFEG(sptr), "unsafe");
1160 _PFG(HOMEDG(sptr), "homed");
1161 }
1162 fprintf(dfil, "\n");
1163 putaltname(dfil, sptr, "");
1164 if (SCG(sptr) != SC_DUMMY && SOCPTRG(sptr))
1165 dmp_socs(sptr, dfil);
1166 break;
1167
1168 case ST_STAG:
1169 case ST_TYPEDEF:
1170 fprintf(dfil, "dcld: %d\n", DCLDG(sptr));
1171 _PFG(UNLPOLYG(sptr), "unlpoly");
1172 break;
1173
1174 case ST_NML:
1175 fprintf(dfil,
1176 "symlk: %d address: %" ISZ_PF
1177 "d cmemf: %d cmeml: %d ref: %d\n",
1178 SYMLKG(sptr), ADDRESSG(sptr), CMEMFG(sptr), (int)CMEMLG(sptr),
1179 REFG(sptr));
1180 for (i = CMEMFG(sptr); i; i = NML_NEXT(i))
1181 fprintf(dfil, " nml:%5d sptr:%5d %s\n", i, (int)NML_SPTR(i),
1182 SYMNAME(NML_SPTR(i)));
1183 break;
1184
1185 case ST_MEMBER:
1186 fprintf(dfil, "address: %" ISZ_PF "d symlk: %d variant: %d ccsym: %d",
1187 ADDRESSG(sptr), SYMLKG(sptr), VARIANTG(sptr), (int)CCSYMG(sptr));
1188 fprintf(dfil, " pointer: %d", (int)POINTERG(sptr));
1189 _PFG(LSCOPEG(sptr), "lscope");
1190 _PFG(PTRSAFEG(sptr), "ptrsafe");
1191 #ifdef CONTIGATTRG
1192 _PFG(CONTIGATTRG(sptr), "contigattr");
1193 #endif
1194 _PFG(CLASSG(sptr), "class");
1195 if (DTY(dtype) == TY_ARRAY) {
1196 fprintf(dfil, " sdscs1:%d", SDSCS1G(sptr));
1197 }
1198 fprintf(dfil, " vtable:%d", VTABLEG(sptr));
1199 fprintf(dfil, " iface:%d", IFACEG(sptr));
1200 fprintf(dfil, " tbplnk:%d", TBPLNKG(sptr));
1201 fprintf(dfil, "\n");
1202 break;
1203
1204 case ST_CMBLK:
1205 fprintf(dfil,
1206 "save: %d dinit: %d size: %" ISZ_PF
1207 "d vol:%d alloc:%d ccsym:%d",
1208 SAVEG(sptr), DINITG(sptr), SIZEG(sptr), VOLG(sptr), ALLOCG(sptr),
1209 CCSYMG(sptr));
1210 fprintf(dfil, "\n");
1211 fprintf(dfil, " scope: %d enclfunc: %d", SCOPEG(sptr), ENCLFUNCG(sptr));
1212 #ifdef PDALNG
1213 fprintf(dfil, " pdaln: %d", PDALNG(sptr));
1214 #endif
1215 fprintf(dfil, "\n");
1216 fprintf(dfil, "midnum: %d symlk: %d cmemf: %d cmeml: %d\n",
1217 MIDNUMG(sptr), SYMLKG(sptr), CMEMFG(sptr), (int)CMEMLG(sptr));
1218 putaltname(dfil, sptr, "");
1219 _PFG(THREADG(sptr), "thread");
1220 _PFG(QALNG(sptr), "qaln");
1221 _PFG(CFUNCG(sptr), "cfunc");
1222 _PFG(STDCALLG(sptr), "stdcall");
1223 _PFG(FROMMODG(sptr), "frommod");
1224 _PFG(MODCMNG(sptr), "modcmn");
1225 #ifdef TLSG
1226 _PFG(TLSG(sptr), "tls");
1227 #endif /* TLSG */
1228 #ifdef USE_MPC
1229 if (ETLSG(sptr))
1230 fprintf(file, " etls: %d", ETLSG(sptr));
1231 #endif /* USE_MPC */
1232 #if defined(TARGET_WIN_X86)
1233 if (DLLG(sptr) == DLL_EXPORT)
1234 fprintf(dfil, " dllexport");
1235 else if (DLLG(sptr) == DLL_IMPORT)
1236 fprintf(dfil, " dllimport");
1237 #endif
1238 fprintf(dfil, "\n");
1239 break;
1240
1241 case ST_ENTRY:
1242 fprintf(dfil, "dcld: %d ccsym: %d address: %" ISZ_PF "d midnum: %d ",
1243 DCLDG(sptr), CCSYMG(sptr), ADDRESSG(sptr), MIDNUMG(sptr));
1244 fprintf(dfil, "symlk: %d paramct: %d dpdsc: %d\n", SYMLKG(sptr),
1245 PARAMCTG(sptr), DPDSCG(sptr));
1246 fprintf(dfil, "funcline: %d copyprms: %d bihnum: %d fval: %d",
1247 (int)FUNCLINEG(sptr), COPYPRMSG(sptr), BIHNUMG(sptr), FVALG(sptr));
1248 fprintf(dfil, " adjarr: %d aftent: %d", ADJARRG(sptr), AFTENTG(sptr));
1249 _PFG(CONTAINEDG(sptr), "contained");
1250 fprintf(dfil, "\n");
1251 putaltname(dfil, sptr, "");
1252 _PFG(CFUNCG(sptr), "cfunc");
1253 #ifdef CSTRUCTRETG
1254 _PFG(CSTRUCTRETG(sptr), "cstructret");
1255 #endif
1256 _PFG(MSCALLG(sptr), "mscall");
1257 _PFG(CREFG(sptr), "cref");
1258 _PFG(NOMIXEDSTRLENG(sptr), "nomixedstrlen");
1259 _PFG(PASSBYVALG(sptr), "passbyval");
1260 _PFG(PASSBYREFG(sptr), "passbyref");
1261 _PFG(STDCALLG(sptr), "stdcall");
1262 _PFG(DECORATEG(sptr), "decorate");
1263 #if defined(TARGET_WIN_X86)
1264 if (DLLG(sptr) == DLL_EXPORT)
1265 fprintf(dfil, " dllexport");
1266 else if (DLLG(sptr) == DLL_IMPORT)
1267 fprintf(dfil, " dllimport");
1268 #endif
1269 if (WINNT_CALL)
1270 fprintf(dfil, " argsize:%d", ARGSIZEG(sptr));
1271 _PFG(ARETG(sptr), "aret");
1272 fprintf(dfil, "\n");
1273 putcuda(dfil, sptr);
1274 fprintf(dfil, "Parameter sptr's:\n");
1275 dscptr = DPDSCG(sptr);
1276 for (i = PARAMCTG(sptr); i > 0; dscptr++, i--)
1277 fprintf(dfil, "sptr = %d\n", *(aux.dpdsc_base + dscptr));
1278 break;
1279
1280 case ST_PROC:
1281 fprintf(dfil, "dcld: %d ref: %d ccsym: %d func: %d midnum: %d ",
1282 DCLDG(sptr), REFG(sptr), CCSYMG(sptr), FUNCG(sptr), MIDNUMG(sptr));
1283 fprintf(dfil, "sc:%d(%s) symlk: %d", SCG(sptr),
1284 (SCG(sptr) <= SC_MAX) ? stb.scnames[SCG(sptr)] : "na",
1285 SYMLKG(sptr));
1286 fprintf(dfil, "\n");
1287 fprintf(dfil, "paramct: %d dpdsc: %d fval: %d", PARAMCTG(sptr),
1288 DPDSCG(sptr), FVALG(sptr));
1289 fprintf(dfil, "\n");
1290 if (SCG(sptr) == SC_DUMMY) {
1291 fprintf(dfil, "address: %" ISZ_PF "d", ADDRESSG(sptr));
1292 _PFG(UNSAFEG(sptr), "unsafe");
1293 fprintf(dfil, " uplevel: %d", (int)UPLEVELG(sptr));
1294 fprintf(dfil, " internref: %d", (int)INTERNREFG(sptr));
1295 fprintf(dfil, " gscope: %d", (int)GSCOPEG(sptr));
1296 }
1297 _PFG(CONTAINEDG(sptr), "contained");
1298 _PFG(NEEDMODG(sptr), "needmod");
1299 _PFG(TYPDG(sptr), "typd");
1300 putaltname(dfil, sptr, " ");
1301 _PFG(CFUNCG(sptr), "cfunc");
1302 #ifdef CSTRUCTRETG
1303 _PFG(CSTRUCTRETG(sptr), "cstructret");
1304 #endif
1305 _PFG(MSCALLG(sptr), "mscall");
1306 _PFG(CREFG(sptr), "cref");
1307 _PFG(NOMIXEDSTRLENG(sptr), "nomixedstrlen");
1308 _PFG(PASSBYVALG(sptr), "passbyval");
1309 _PFG(PASSBYREFG(sptr), "passbyref");
1310 _PFG(STDCALLG(sptr), "stdcall");
1311 _PFG(DECORATEG(sptr), "decorate");
1312 #if defined(TARGET_WIN_X86)
1313 if (DLLG(sptr) == DLL_EXPORT)
1314 fprintf(dfil, " dllexport");
1315 else if (DLLG(sptr) == DLL_IMPORT)
1316 fprintf(dfil, " dllimport");
1317 #endif
1318 _PFG(CNCALLG(sptr), "cncall");
1319 #ifdef NOPADG
1320 _PFG(NOPADG(sptr), "nopad");
1321 #endif
1322 #ifdef ARG1PTRG
1323 _PFG(ARG1PTRG(sptr), "arg1ptr");
1324 #endif
1325 _PFG(XMMSAFEG(sptr), "xmmsafe");
1326 if (WINNT_CALL)
1327 fprintf(dfil, " argsize:%d", ARGSIZEG(sptr));
1328 _PFG(ARETG(sptr), "aret");
1329 _PFG(VARARGG(sptr), "vararg");
1330 fprintf(dfil, "\n");
1331 putcuda(dfil, sptr);
1332 break;
1333
1334 case ST_CONST:
1335 fprintf(dfil, "holl: %d ", HOLLG(sptr));
1336 fprintf(dfil,
1337 "symlk: %d address: %" ISZ_PF "d conval1: %d conval2: %d\n",
1338 SYMLKG(sptr), ADDRESSG(sptr), CONVAL1G(sptr), CONVAL2G(sptr));
1339 if (DTY(dtype) == TY_VECT) {
1340 int vc, n;
1341 vc = CONVAL1G(sptr);
1342 n = DTyVecLength(dtype);
1343 fprintf(dfil, " vcon_base[%d]:\n", vc);
1344 for (i = 0; i < n; i += 4) {
1345 const char *f1, *f2;
1346 switch (DTySeqTyElement(dtype)) {
1347 case DT_FLOAT:
1348 f1 = " %08x %08x";
1349 f2 = " %08x";
1350 break;
1351 case DT_DBLE:
1352 case DT_INT8:
1353 f1 = " %8d %8d";
1354 f2 = " %8d";
1355 break;
1356 default:
1357 f1 = " %08x %08x";
1358 f2 = " %08x";
1359 }
1360 fprintf(dfil, f1, VCON_CONVAL(vc + i), VCON_CONVAL(vc + i + 1));
1361 if (n > 2) {
1362 fprintf(dfil, f2, VCON_CONVAL(vc + i + 2));
1363 if (n != 3)
1364 fprintf(dfil, f2, VCON_CONVAL(vc + i + 3));
1365 }
1366 fprintf(dfil, "\n");
1367 }
1368 }
1369 break;
1370
1371 case ST_LABEL:
1372 fprintf(dfil,
1373 "rfcnt: %d address: %" ISZ_PF
1374 "d symlk: %d iliblk: %d fmtpt: %d vol: %d\n",
1375 RFCNTG(sptr), ADDRESSG(sptr), SYMLKG(sptr), ILIBLKG(sptr),
1376 FMTPTG(sptr), VOLG(sptr));
1377 if (BEGINSCOPEG(sptr))
1378 fprintf(file, "beginscope ");
1379 if (ENDSCOPEG(sptr))
1380 fprintf(file, "endscope ");
1381 fprintf(file, " in func: %d\n", ENCLFUNCG(sptr));
1382 break;
1383
1384 case ST_STFUNC:
1385 fprintf(dfil, "sfdsc: %x excvlen: %d\n", SFDSCG(sptr),
1386 DTyCharLength(DTYPEG(sptr)));
1387 break;
1388
1389 case ST_PARAM:
1390 if (TY_ISWORD(DTY(dtype))) {
1391 fprintf(dfil, "conval1: 0x%x (%s)\n", CONVAL1G(sptr), parmprint(sptr));
1392 } else {
1393 fprintf(dfil, "conval1: %d (sptr)\n", CONVAL1G(sptr));
1394 }
1395 break;
1396
1397 case ST_INTRIN:
1398 fprintf(dfil, "dcld: %d expst: %d\n", (int)DCLDG(sptr),
1399 (int)EXPSTG(sptr));
1400 *typeb = '\0';
1401 getdtype(ARGTYPG(sptr), typeb);
1402 fprintf(dfil, "pnmptr: %d paramct: %d ilm: %d argtype: %s\n",
1403 PNMPTRG(sptr), PARAMCTG(sptr), (int)ILMG(sptr), typeb);
1404 *typeb = '\0';
1405 getdtype(INTTYPG(sptr), typeb);
1406 fprintf(dfil, "inttyp: %s\n", typeb);
1407 break;
1408
1409 case ST_GENERIC:
1410 if (sptr >= stb.firstusym) {
1411 int dscptr;
1412 fprintf(dfil, "gsame: %d gncnt:%d gndsc:%d\n", (int)GSAMEG(sptr),
1413 GNCNTG(sptr), GNDSCG(sptr));
1414 fprintf(dfil, "Overloaded funcs:\n");
1415 for (dscptr = GNDSCG(sptr); dscptr; dscptr = SYMI_NEXT(dscptr)) {
1416 fprintf(dfil, "sptr =%5d, %s\n", SYMI_SPTR(dscptr),
1417 SYMNAME(SYMI_SPTR(dscptr)));
1418 }
1419 } else
1420 {
1421 fprintf(dfil, "expst: %d gsint: %d gint: %d greal: %d\n",
1422 EXPSTG(sptr), GSINTG(sptr), GINTG(sptr), (int)GREALG(sptr));
1423 fprintf(dfil,
1424 "gdble: %d gcmplx: %d gdcmplx: %d gint8: %d gsame: %d\n",
1425 GDBLEG(sptr), GCMPLXG(sptr), GDCMPLXG(sptr), GINT8G(sptr),
1426 (int)GSAMEG(sptr));
1427 }
1428 break;
1429
1430 case ST_PD:
1431 fprintf(dfil, "pdnum: %d\n", PDNUMG(sptr));
1432 break;
1433
1434 case ST_PLIST:
1435 fprintf(dfil, "ref: %d dinit: %d\n", REFG(sptr), DINITG(sptr));
1436 fprintf(dfil, "address: %" ISZ_PF "d pllen: %d", ADDRESSG(sptr),
1437 PLLENG(sptr));
1438 fprintf(dfil, " uplevel: %d", (int)UPLEVELG(sptr));
1439 fprintf(dfil, " internref: %d", (int)INTERNREFG(sptr));
1440 fprintf(dfil, "\n");
1441 if (SYMNAME(sptr)[1] == 'J')
1442 fprintf(dfil, "swel: %d, deflab: %d\n", SWELG(sptr), (int)DEFLABG(sptr));
1443 #ifdef TLSG
1444 _PFG(TLSG(sptr), "tls");
1445 #endif /* TLSG */
1446 #ifdef USE_MPC
1447 if (ETLSG(sptr))
1448 fprintf(file, " etls: %d", ETLSG(sptr));
1449 #endif /* USE_MPC */
1450 break;
1451
1452 case ST_BLOCK:
1453 fprintf(dfil, "startline %d endline %d enclfunc %d\n", STARTLINEG(sptr),
1454 ENDLINEG(sptr), ENCLFUNCG(sptr));
1455 fprintf(file, "startlab %d endlab %d beginscopelab %d endscopelab %d",
1456 STARTLABG(sptr), ENDLABG(sptr), BEGINSCOPELABG(sptr),
1457 ENDSCOPELABG(sptr));
1458 fprintf(dfil, " autobj: %d", AUTOBJG(sptr));
1459 #ifdef PARUPLEVEL
1460 fprintf(dfil, " paruplevel: %d", PARUPLEVELG(sptr));
1461 #endif
1462 #ifdef PARSYMSG
1463 fprintf(dfil, " parsyms: %d", PARSYMSG(sptr));
1464 fprintf(dfil, " parsymsct: %d", PARSYMSCTG(sptr));
1465 #endif
1466 fprintf(dfil, "\n");
1467 break;
1468
1469 default:
1470 interr("symdmp: bad symbol type", stype, ERR_Informational);
1471 }
1472 }
1473 #endif
1474
1475 static void
putaltname(FILE * dfil,int sptr,char * pref)1476 putaltname(FILE *dfil, int sptr, char *pref)
1477 {
1478 int ss, len;
1479 char *np;
1480 ss = ALTNAMEG(sptr);
1481 if (!ss)
1482 return;
1483 fprintf(dfil, "%saltname:%d(", pref, ss);
1484 if (DECORATEG(sptr))
1485 fprintf(dfil, "_");
1486 len = DTyCharLength(DTYPEG(ss));
1487 np = stb.n_base + CONVAL1G(ss);
1488 while (true) {
1489 fprintf(dfil, "%c", *np);
1490 if (len <= 1)
1491 break;
1492 len--;
1493 np++;
1494 }
1495 fprintf(dfil, ")");
1496 }
1497
1498 static void
putcuda(FILE * dfil,int sptr)1499 putcuda(FILE *dfil, int sptr)
1500 {
1501 #ifdef CUDAG
1502 if (CUDAG(sptr)) {
1503 int cu;
1504 fprintf(dfil, "cuda: ");
1505 cu = CUDAG(sptr);
1506 if (cu & CUDA_HOST) {
1507 fprintf(dfil, "host");
1508 cu &= ~CUDA_HOST;
1509 if (cu)
1510 fprintf(dfil, "+");
1511 }
1512 if (cu & CUDA_DEVICE) {
1513 fprintf(dfil, "device");
1514 cu &= ~CUDA_DEVICE;
1515 if (cu)
1516 fprintf(dfil, "+");
1517 }
1518 if (cu & CUDA_GLOBAL) {
1519 fprintf(dfil, "global");
1520 cu &= ~CUDA_GLOBAL;
1521 if (cu)
1522 fprintf(dfil, "+");
1523 }
1524 if (cu & CUDA_GRID) {
1525 fprintf(dfil, "grid");
1526 cu &= ~CUDA_GRID;
1527 if (cu)
1528 fprintf(dfil, "+");
1529 }
1530 if (cu & CUDA_BUILTIN) {
1531 fprintf(dfil, "builtin");
1532 cu &= ~CUDA_BUILTIN;
1533 if (cu)
1534 fprintf(dfil, "+");
1535 }
1536 if (cu & CUDA_CONSTRUCTOR) {
1537 fprintf(dfil, "constructor");
1538 cu &= ~CUDA_CONSTRUCTOR;
1539 if (cu)
1540 fprintf(dfil, "+");
1541 }
1542 #ifdef CUDA_STUB
1543 if (cu & CUDA_STUB) {
1544 fprintf(dfil, "stub");
1545 cu &= ~CUDA_STUB;
1546 if (cu)
1547 fprintf(dfil, "+");
1548 }
1549 #endif
1550 fprintf(dfil, "\n");
1551 }
1552 #endif
1553 }
1554
1555 /**
1556 \brief Dump symbol table for debugging purposes. If full == true,
1557 dump entire symbol table, otherwise dump symtab beginning with user
1558 symbols.
1559 */
1560 void
symdmp(FILE * dfil,bool full)1561 symdmp(FILE *dfil, bool full)
1562 {
1563 #if DEBUG
1564 int sptr; /* symbol currently being dumped */
1565
1566 for (sptr = (full ? 1 : stb.firstusym); sptr < stb.stg_avail; sptr++)
1567 symdentry(dfil, sptr);
1568 #endif
1569 }
1570
1571 #if DEBUG
1572 void
dmp_socs(int sptr,FILE * file)1573 dmp_socs(int sptr, FILE *file)
1574 {
1575 int p;
1576 int q;
1577
1578 fprintf(file, "dmp_socs(%d)\n", sptr);
1579 q = 0;
1580 for (p = SOCPTRG(sptr); p; p = SOC_NEXT(p)) {
1581 fprintf(file, " overlaps: %s\n", SYMNAME(SOC_SPTR(p)));
1582 if (q == p) {
1583 fprintf(file, ">>>>> soc loop\n");
1584 break;
1585 }
1586 q = p;
1587 }
1588 }
1589 #endif
1590
1591 /* FIXME: getccsym could be shared between C and Fortran */
1592
1593 static void
set_ccflags(int sptr,SYMTYPE stype)1594 set_ccflags(int sptr, SYMTYPE stype)
1595 {
1596 STYPEP(sptr, stype);
1597 CCSYMP(sptr, 1);
1598 LSCOPEP(sptr, 1);
1599 #ifdef REFDP
1600 /* C+++ mark all compiler generated tmps as referenced */
1601 REFDP(sptr, 1);
1602 #endif
1603 }
1604
1605 SPTR
getccsym(int letter,int n,SYMTYPE stype)1606 getccsym(int letter, int n, SYMTYPE stype)
1607 {
1608 char name[16];
1609 SPTR sptr;
1610
1611 sprintf(name, ".%c%04d", letter, n); /* at least 4, could be more */
1612 sptr = getsym(name, strlen(name));
1613 set_ccflags(sptr, stype);
1614 return sptr;
1615 }
1616
1617 SPTR
getnewccsym(int letter,int n,SYMTYPE stype)1618 getnewccsym(int letter, int n, SYMTYPE stype)
1619 {
1620 char name[32];
1621 SPTR sptr;
1622
1623 sprintf(name, ".%c%04d", letter, n); /* at least 4, could be more */
1624 NEWSYM(sptr);
1625 NMPTRP(sptr, putsname(name, strlen(name)));
1626 set_ccflags(sptr, stype);
1627 return sptr;
1628 }
1629
1630 SPTR
getccsym_sc(int letter,int n,SYMTYPE stype,SC_KIND sc)1631 getccsym_sc(int letter, int n, SYMTYPE stype, SC_KIND sc)
1632 {
1633 SPTR sptr;
1634
1635 if (sc != SC_PRIVATE) {
1636 sptr = getccsym(letter, n, stype);
1637 SCP(sptr, sc);
1638 } else {
1639 char name[16];
1640 sprintf(name, ".%c%04dp", letter, n); /* at least 4, could be more */
1641 sptr = getcctemp_sc(name, stype, sc);
1642 return sptr;
1643 }
1644
1645 SCP(sptr, sc);
1646 return sptr;
1647 }
1648
1649 SPTR
getcctemp_sc(char * name,SYMTYPE stype,SC_KIND sc)1650 getcctemp_sc(char *name, SYMTYPE stype, SC_KIND sc)
1651 {
1652 SPTR sym;
1653
1654 sym = getsym(name, strlen(name));
1655 set_ccflags(sym, stype);
1656 SCP(sym, sc);
1657 return sym;
1658 }
1659
1660 SPTR
getccssym(char * pfx,int n,SYMTYPE stype)1661 getccssym(char *pfx, int n, SYMTYPE stype)
1662 {
1663 char name[32];
1664 SPTR sptr;
1665 int i;
1666
1667 sprintf(name, ".%s%04d", pfx, n); /* at least 4, could be more */
1668 i = 0;
1669 do {
1670 sptr = getsym(name, strlen(name));
1671 if (STYPEG(sptr) == ST_UNKNOWN) {
1672 STYPEP(sptr, stype);
1673 CCSYMP(sptr, 1);
1674 SCOPEP(sptr, stb.curr_scope);
1675 return sptr;
1676 }
1677 if (SCOPEG(sptr) == stb.curr_scope)
1678 return sptr;
1679 /* make up a new name */
1680 ++i;
1681 sprintf(&name[strlen(pfx) + 1], "%04d%03d", n, i);
1682 } while (1);
1683 }
1684
1685 SPTR
getccssym_sc(char * pfx,int n,SYMTYPE stype,SC_KIND sc)1686 getccssym_sc(char *pfx, int n, SYMTYPE stype, SC_KIND sc)
1687 {
1688 SPTR sptr;
1689
1690 if (sc != SC_PRIVATE)
1691 sptr = getccssym(pfx, n, stype);
1692 else {
1693 char name[32];
1694 int i;
1695 sprintf(name, ".%s%04dp", pfx, n); /* at least 4, could be more */
1696 i = 0;
1697 do {
1698 sptr = getsym(name, strlen(name));
1699 if (STYPEG(sptr) == ST_UNKNOWN) {
1700 STYPEP(sptr, stype);
1701 CCSYMP(sptr, 1);
1702 SCOPEP(sptr, stb.curr_scope);
1703 break;
1704 }
1705 if (SCOPEG(sptr) == stb.curr_scope)
1706 break;
1707 /* make up a new name */
1708 ++i;
1709 sprintf(&name[strlen(pfx) + 1], "%04d%03dp", n, i);
1710 } while (1);
1711 }
1712 SCP(sptr, sc);
1713 return sptr;
1714 }
1715
1716 /* FIXME: getccsym_copy is the same between C and Fortran */
1717
1718 /*
1719 * get a compiler symbol that is a 'copy' of the given symbol
1720 * append '.copy' to the name
1721 * copy the symbol type, data type, symbol class fields
1722 */
1723 SPTR
getccsym_copy(SPTR oldsptr)1724 getccsym_copy(SPTR oldsptr)
1725 {
1726 SPTR sptr;
1727 int oldlen, len, i;
1728 char fname[39];
1729 char *name;
1730
1731 if (STYPEG(oldsptr) != ST_VAR)
1732 return oldsptr;
1733 if (!DT_ISINT(DTYPEG(oldsptr)))
1734 return oldsptr;
1735 oldlen = strlen(SYMNAME(oldsptr));
1736 if (oldlen >= 32) {
1737 name = (char *)malloc(oldlen + 1);
1738 } else {
1739 name = fname;
1740 }
1741 strcpy(name, SYMNAME(oldsptr));
1742 strcat(name, ".copy");
1743 len = strlen(name);
1744 i = 0;
1745 do {
1746 sptr = getsym(name, strlen(name));
1747 if (STYPEG(sptr) == ST_UNKNOWN) {
1748 STYPEP(sptr, STYPEG(oldsptr));
1749 DTYPEP(sptr, DTYPEG(oldsptr));
1750 SCP(sptr, SCG(oldsptr));
1751 CCSYMP(sptr, 1);
1752 SCOPEP(sptr, SCOPEG(oldsptr));
1753 ENCLFUNCP(sptr, ENCLFUNCG(oldsptr));
1754 break;
1755 }
1756 if (SCOPEG(sptr) == stb.curr_scope)
1757 break;
1758 /* make up a new name */
1759 ++i;
1760 sprintf(name + len, "%d", i);
1761 } while (1);
1762 #ifdef REFDP
1763 /* C+++ mark all compiler generated tmps as referenced */
1764 REFDP(sptr, 1);
1765 #endif
1766 if (oldlen >= 32)
1767 free(name);
1768 return sptr;
1769 }
1770
1771 /* FIXME: insert_sym is the same between C and Fortran */
1772
1773 /**
1774 \brief Create new symbol table entry and insert it in the hash list
1775 immediately in front of 'first':
1776 */
1777 SPTR
insert_sym(SPTR first)1778 insert_sym(SPTR first)
1779 {
1780 SPTR sptr;
1781 int i, j;
1782 INT hashval;
1783 char *np;
1784
1785 NEWSYM(sptr);
1786 NMPTRP(sptr, NMPTRG(first));
1787 /* link newly created symbol immediately in front of first: */
1788 np = SYMNAME(first);
1789 i = strlen(np);
1790 HASH_ID(hashval, np, i);
1791 HASHLKP(sptr, first);
1792 if (stb.hashtb[hashval] == first)
1793 stb.hashtb[hashval] = sptr;
1794 else {
1795 /* scan hash list to find immed. predecessor of first: */
1796 for (i = stb.hashtb[hashval]; (j = HASHLKG(i)) != first; i = j)
1797 assert(j != 0, "insert_sym: bad hash", first, ERR_Fatal);
1798 HASHLKP(i, sptr);
1799 }
1800
1801 SYMLKP(sptr, NOSYM); /* installsym for ftn also sets SYMLK */
1802 setimplicit(sptr);
1803 return sptr;
1804 }
1805
1806 /**
1807 \brief Create new symbol table entry and insert it in the hash list
1808 immediately in front of 'first':
1809 */
1810 SPTR
insert_sym_first(SPTR first)1811 insert_sym_first(SPTR first)
1812 {
1813 SPTR sptr;
1814 int i;
1815 INT hashval;
1816 char *np;
1817
1818 NEWSYM(sptr);
1819 NMPTRP(sptr, NMPTRG(first));
1820 /* link newly created symbol immediately in front of first: */
1821 np = SYMNAME(first);
1822 i = strlen(np);
1823 HASH_ID(hashval, np, i);
1824 HASHLKP(sptr, stb.hashtb[hashval]);
1825 stb.hashtb[hashval] = sptr;
1826 setimplicit(sptr);
1827 return sptr;
1828 }
1829
1830 SPTR
getlab(void)1831 getlab(void)
1832 {
1833 return getccsym('B', stb.lbavail++, ST_LABEL);
1834 }
1835
1836 int
get_entry_item(void)1837 get_entry_item(void)
1838 {
1839 int ent = aux.entry_avail;
1840 if (aux.entry_avail++ == 0) {
1841 aux.entry_size = 10;
1842 NEW(aux.entry_base, ENTRY, aux.entry_size);
1843 } else {
1844 NEED(aux.entry_avail, aux.entry_base, ENTRY, aux.entry_size,
1845 aux.entry_size + 10);
1846 }
1847 return ent;
1848 }
1849
1850 /**
1851 \brief Scan all hash lists and remove symbols whose scope is
1852 greater than or equal to the current scope:
1853 */
1854 void
pop_scope(void)1855 pop_scope(void)
1856 {
1857 int i, j, sptr;
1858
1859 #if DEBUG
1860 if (DBGBIT(5, 1024))
1861 fprintf(gbl.dbgfil, "pop_scope(): scope %d\n", stb.curr_scope);
1862 #endif
1863 for (i = 0; i < HASHSIZE; i++)
1864 for (sptr = stb.hashtb[i], j = 0; sptr; sptr = HASHLKG(sptr))
1865 if ((int)SCOPEG(sptr) >= stb.curr_scope) {
1866 #if DEBUG
1867 if (DBGBIT(5, 1024))
1868 fprintf(gbl.dbgfil, "removing %s, sptr:%d\n", SYMNAME(sptr), sptr);
1869 #endif
1870 if (j)
1871 HASHLKP(j, HASHLKG(sptr));
1872 else
1873 stb.hashtb[i] = HASHLKG(sptr);
1874 } else {
1875 j = sptr;
1876 }
1877 }
1878
1879 /**
1880 \brief Scan all hash lists and remove specified symbol from scope.
1881 */
1882 void
pop_sym(int sptr)1883 pop_sym(int sptr)
1884 {
1885 char *name;
1886 INT hashval;
1887 int s, j;
1888
1889 #if DEBUG
1890 if (DBGBIT(5, 1024))
1891 fprintf(gbl.dbgfil, "pop_sym(): sym %d\n", sptr);
1892 #endif
1893 if (NMPTRG(sptr) == 0)
1894 return;
1895 name = SYMNAME(sptr);
1896 HASH_ID(hashval, name, strlen(name));
1897 for (s = stb.hashtb[hashval], j = 0; s; s = HASHLKG(s)) {
1898 if (s == sptr) {
1899 #if DEBUG
1900 if (DBGBIT(5, 1024))
1901 fprintf(gbl.dbgfil, "removing %s, sptr:%d\n", SYMNAME(sptr), sptr);
1902 #endif
1903 if (j)
1904 HASHLKP(j, HASHLKG(sptr));
1905 else
1906 stb.hashtb[hashval] = HASHLKG(sptr);
1907 break;
1908 }
1909 j = s;
1910 }
1911 HASHLKP(sptr, SPTR_NULL);
1912 }
1913
1914 /**
1915 \brief Create a function ST item given a name.
1916 */
1917 SPTR
mkfunc(const char * nmptr)1918 mkfunc(const char *nmptr)
1919 {
1920 SPTR sptr;
1921
1922 sptr = getsym(nmptr, strlen(nmptr));
1923 if (STYPEG(sptr) == ST_PROC) {
1924 if (!REFG(sptr) && !SYMLKG(sptr)) {
1925 SYMLKP(sptr, gbl.externs);
1926 gbl.externs = sptr;
1927 }
1928 sym_is_refd(sptr);
1929 return sptr;
1930 }
1931 STYPEP(sptr, ST_PROC);
1932 DTYPEP(sptr, DT_INT);
1933 SCP(sptr, SC_EXTERN);
1934 CCSYMP(sptr, 1);
1935 #ifdef SDSCSAFEP
1936 SDSCSAFEP(sptr, 1);
1937 #endif
1938 if (!REFG(sptr) && !SYMLKG(sptr)) {
1939 SYMLKP(sptr, gbl.externs);
1940 gbl.externs = sptr;
1941 }
1942
1943 sym_is_refd(sptr);
1944 return sptr;
1945 }
1946
1947 typedef enum LLVMCallBack_t { NO_LLVM_CALLBACK, LLVM_CALLBACK } LLVMCallBack_t;
1948
1949 static SPTR
vmk_prototype(LLVMCallBack_t llCallBack,const char * name,const char * attr,DTYPE resdt,int nargs,va_list vargs)1950 vmk_prototype(LLVMCallBack_t llCallBack, const char *name, const char *attr,
1951 DTYPE resdt, int nargs, va_list vargs)
1952 {
1953 DTYPE args[64];
1954 SPTR sptr;
1955 int i;
1956 unsigned flags = 0;
1957
1958 if (nargs > 64) {
1959 interr("vmk_prototype: nargs exceeds", 64, ERR_Severe);
1960 nargs = 64;
1961 }
1962 sptr = getsym(name, strlen(name));
1963 for (i = 0; i < nargs; i++) {
1964 int argdt = va_arg(vargs, int);
1965 args[i] = (DTYPE) argdt;
1966 }
1967 sptr = mkfunc(name); /* NEED a mk_pfunc() */
1968 DTYPEP(sptr, resdt);
1969 /*
1970 * A string of blank separated words, only the first character of each word is
1971 * signficant
1972 */
1973 while (attr) {
1974 while (*attr <= ' ' && *attr)
1975 ++attr;
1976 if (*attr == '\0')
1977 break;
1978 switch (*attr++) {
1979 case 'f': /* fast */
1980 flags |= FAST_MATH_FLAG;
1981 break;
1982 case 'p': /* pure */
1983 PUREP(sptr, 1);
1984 break;
1985 default:
1986 break;
1987 }
1988 while (*attr > ' ')
1989 ++attr;
1990 }
1991 if (llCallBack == LLVM_CALLBACK)
1992 ll_add_func_proto(sptr, flags, nargs, args);
1993 return sptr;
1994 }
1995
1996 /**
1997 \brief Make a prototype but do not register it
1998
1999 Use when not using the LLVM backend or when the signature given is known to
2000 cause regressions in testing.
2001 */
2002 SPTR
mk_prototype(const char * name,const char * attr,DTYPE resdt,int nargs,...)2003 mk_prototype(const char *name, const char *attr, DTYPE resdt, int nargs, ...)
2004 {
2005 va_list vargs;
2006 SPTR rv;
2007 va_start(vargs, nargs);
2008 rv = vmk_prototype(NO_LLVM_CALLBACK, name, attr, resdt, nargs, vargs);
2009 va_end(vargs);
2010 return rv;
2011 }
2012
2013 /**
2014 \brief Make a prototype and register it with LLVM
2015 */
2016 SPTR
mk_prototype_llvm(const char * name,const char * attr,DTYPE resdt,int nargs,...)2017 mk_prototype_llvm(const char *name, const char *attr, DTYPE resdt, int nargs,
2018 ...)
2019 {
2020 va_list vargs;
2021 SPTR rv;
2022 va_start(vargs, nargs);
2023 rv = vmk_prototype(LLVM_CALLBACK, name, attr, resdt, nargs, vargs);
2024 va_end(vargs);
2025 return rv;
2026 }
2027
2028 int
add_symitem(int sptr,int nxt)2029 add_symitem(int sptr, int nxt)
2030 {
2031 int i;
2032 i = aux.symi_avl++;
2033 NEED(aux.symi_avl, aux.symi_base, SYMI, aux.symi_size, aux.symi_avl + 100);
2034 SYMI_SPTR(i) = sptr;
2035 SYMI_NEXT(i) = nxt;
2036 return i;
2037 }
2038
2039 #if DEBUG
2040 int
dbg_symdentry(int sptr)2041 dbg_symdentry(int sptr)
2042 {
2043 symdentry(stderr, sptr);
2044 return 0;
2045 }
2046 #endif
2047
2048 SPTR
get_semaphore(void)2049 get_semaphore(void)
2050 {
2051 SPTR sym;
2052 DTYPE dt;
2053 int ival[2];
2054 char name[10];
2055 ADSC *ad;
2056 static int semaphore_cnt = 0; /* counter for semaphore variables */
2057
2058 strcpy(name, ".sem");
2059 sprintf(&name[4], "%05d", semaphore_cnt);
2060 semaphore_cnt++;
2061 sym = getsym(name, 9); /* semaphore variable, 1 per critical section */
2062 /*
2063 * kmpc requires a semaphore variable to be 32 bytes and
2064 * 8-byte aligned
2065 */
2066 dt = get_array_dtype(1, DT_INT8);
2067 STYPEP(sym, ST_ARRAY);
2068 DTYPEP(sym, dt);
2069 ad = AD_DPTR(dt);
2070 AD_NUMELM(ad) = AD_UPBD(ad, 0);
2071 AD_MLPYR(ad, 0) = stb.i1;
2072 AD_LWBD(ad, 0) = stb.i1;
2073 ival[0] = 0;
2074 ival[1] = 4;
2075 AD_UPBD(ad, 0) = getcon(ival, DT_INT);
2076 AD_NUMDIM(ad) = 1;
2077 AD_NUMELM(ad) = AD_UPBD(ad, 0);
2078 AD_SCHECK(ad) = 0;
2079 AD_ZBASE(ad) = stb.i1;
2080 ADDRTKNP(sym, 1);
2081 CCSYMP(sym, 1);
2082 SCP(sym, SC_STATIC);
2083 DCLDP(sym, 1);
2084 return sym;
2085 }
2086
2087 #if DEBUG
2088 int
tr_conval2g(char * fn,int ln,int s)2089 tr_conval2g(char *fn, int ln, int s)
2090 {
2091 if (DTYPEG(s) && DTY(DTYPEG(s)) == TY_PTR) {
2092 fprintf(stderr, "ACON CONVAL2G:%s:%d\n", fn, ln);
2093 }
2094 return stb.stg_base[s].w14;
2095 }
2096
2097 int
tr_conval2p(char * fn,int ln,int s,int v)2098 tr_conval2p(char *fn, int ln, int s, int v)
2099 {
2100 if (DTYPEG(s) && DTY(DTYPEG(s)) == TY_PTR) {
2101 fprintf(stderr, "ACON CONVAL2P:%s:%d\n", fn, ln);
2102 }
2103 stb.stg_base[s].w14 = v;
2104 return v;
2105 }
2106 #endif
2107
2108 SPTR
addnewsym(const char * name)2109 addnewsym(const char *name)
2110 {
2111 SPTR sptr;
2112 NEWSYM(sptr);
2113 NMPTRP(sptr, putsname(name, strlen(name)));
2114 return sptr;
2115 } /* addnewsym */
2116
2117 SPTR
adddupsym(SPTR oldsptr)2118 adddupsym(SPTR oldsptr)
2119 {
2120 SPTR sptr;
2121 NEWSYM(sptr);
2122 NMPTRP(sptr, NMPTRG(oldsptr));
2123 return sptr;
2124 } /* adddupsym */
2125