1 /*
2 * Copyright (c) 1997-2019, NVIDIA CORPORATION. All rights reserved.
3 *
4 * Licensed under the Apache License, Version 2.0 (the "License");
5 * you may not use this file except in compliance with the License.
6 * You may obtain a copy of the License at
7 *
8 * http://www.apache.org/licenses/LICENSE-2.0
9 *
10 * Unless required by applicable law or agreed to in writing, software
11 * distributed under the License is distributed on an "AS IS" BASIS,
12 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13 * See the License for the specific language governing permissions and
14 * limitations under the License.
15 *
16 */
17
18 /** \file
19 * \brief upper - import the lowered F90/HPF code
20 */
21
22 #include "upper.h"
23 #include "error.h"
24 #include "ilm.h"
25 #include "ilmtp.h"
26 #include "semant.h"
27 #include "semutil0.h"
28 #include "main.h"
29 #include "soc.h"
30 #include "dinit.h"
31 #include "dinitutl.h"
32 #include "nme.h"
33 #include "fih.h"
34 #include "pragma.h"
35 #include "ccffinfo.h"
36 #include "llmputil.h"
37 #include "llassem.h"
38 #include "cgraph.h"
39 #include "semsym.h"
40 #include "llmputil.h"
41 #include "dtypeutl.h"
42 #include "exp_rte.h"
43 #include "symfun.h"
44 #include <stdarg.h>
45
46 static int endilmfile; /* flag for end of file */
47 static int ilmlinenum = 0;
48
49 static char *line = NULL;
50 static int linelen = 0;
51 static int pos;
52
53 static int do_level = 0;
54 static int in_array_ctor = 0;
55 static int oprnd_cnt = 0;
56 static int passbyflags = 1;
57 static int cfuncflags = 1;
58 static int cudaflags = 1;
59 static int cudaemu = 0; /* 1 => global; 2 => device */
60 extern int init_list_count;
61
62 static int llvm_stb_processing = 0;
63
64 static int read_line(void);
65 static void checkversion(char *text);
66 static int checkname(const char *text);
67 static ISZ_T getval(const char *valname);
68 static long getlval(char *valname);
69 static int getbit(char *bitname);
70
71 #define STB_UPPER() (gbl.stbfil != NULL)
72 static void do_llvm_sym_is_refd(void);
73 static void build_agoto(void);
74 static void free_modvar_alias_list(void);
75 static void save_modvar_alias(SPTR sptr, const char *alias_name);
76
77 static void init_upper(void);
78 static void read_fileentries(void);
79 static void read_datatype(void);
80 static void read_symbol(void);
81 static void read_overlap(void);
82 static void read_Entry(void);
83 static void read_program(void);
84 static void read_ipainfo(void);
85 static int newindex(int);
86 static int newinfo(void);
87 static void fix_datatype(void);
88 static void fix_symbol(void);
89 static int create_thread_private_vector(int, int);
90 static DTYPE create_threadprivate_dtype(void);
91 static int getnamelen(void);
92 static char *getname(void);
93 static int getoperand(const char *optype, char letter);
94
95 static void read_ilm(void);
96 static void read_label(void);
97
98 static void Begindata(void);
99 static void Writedata(void);
100 static void dataDo(void);
101 static void dataEnddo(void);
102 static void dataConstant(void);
103 static void dataReference(void);
104 static void dataStructure(void);
105 static void dataVariable(void);
106 static void read_init(void);
107 static void data_pop_const(void);
108 static void data_push_const(void);
109 static void read_global(void);
110 static int read_CCFF(void);
111 #include "direct.h"
112 static void read_contained(void);
113
114 typedef struct CGR_LIST {
115 struct CGR_LIST *next;
116 SPTR func_sptr;
117 } CGR_LIST;
118
119 static CGR_LIST *deferred_cgr_func = NULL;
120 static CGR_LIST *deferred_cgr_list = NULL;
121
122 /* type of descriptor elements */
123 #define DESC_ELM_DT (XBIT(68, 1) ? DT_INT8 : DT_INT)
124
125 typedef struct {
126 char *keyword;
127 char *shortkeyword;
128 int keyvalue;
129 } namelist;
130
131 /* clang-format off */
132 static const namelist IPAtypes[] = {
133 "pstride", "p", 1, "sstride", "s", 2, "Target", "T", 3,
134 "target", "t", 4, "allcallsafe", "a", 5, "safe", "f", 6,
135 "callsafe", "c", 7, NULL, NULL, -1,
136 };
137
138 /* list of datatype keywords */
139 static const namelist Datatypes[] = {
140 "Array", "A", TY_ARRAY, "Complex8", "C8", TY_CMPLX,
141 "Complex16", "C16", TY_DCMPLX, "Derived", "D", TY_STRUCT,
142 "Hollerith", "H", TY_HOLL, "Integer1", "I1", TY_BINT,
143 "Integer2", "I2", TY_SINT, "Integer4", "I4", TY_INT,
144 "Integer8", "I8", TY_INT8, "Logical1", "L1", TY_BLOG,
145 "Logical2", "L2", TY_SLOG, "Logical4", "L4", TY_LOG,
146 "Logical8", "L8", TY_LOG8, "Numeric", "N", TY_NUMERIC,
147 "Pointer", "P", TY_PTR, "proc", "p", TY_PROC,
148 "Real2", "R2", TY_HALF,
149 "Real4", "R4", TY_REAL, "Real8", "R8", TY_DBLE,
150 "Real16", "R16", TY_QUAD, "Struct", "S", TY_STRUCT,
151 "Word4", "W4", TY_WORD, "Word8", "W8", TY_DWORD,
152 "Union", "U", TY_UNION, "any", "a", TY_ANY,
153 "character", "c", TY_CHAR, "kcharacter", "k", TY_NCHAR,
154 "none", "n", TY_NONE, NULL, NULL, -1,
155 };
156
157 /* list of symbol type keywords */
158 static const namelist Symboltypes[] = {
159 "Array", "A", ST_ARRAY, "Block", "B", ST_BLOCK,
160 "Common", "C", ST_CMBLK, "Derived", "D", ST_STRUCT,
161 "Entry", "E", ST_ENTRY, "Generic", "G", ST_GENERIC,
162 "Intrinsic", "I", ST_INTRIN, "Known", "K", ST_PD,
163 "Label", "L", ST_LABEL, "Member", "M", ST_MEMBER,
164 "Namelist", "N", ST_NML, "Procedure", "P", ST_PROC,
165 "Struct", "S", ST_STRUCT, "Tag", "T", ST_STAG,
166 "Union", "U", ST_UNION, "Variable", "V", ST_VAR,
167 "constant", "c", ST_CONST, "dpname", "d", ST_DPNAME,
168 "list", "l", ST_PLIST,
169 "module", "m", -99, "parameter", "p", ST_PARAM,
170 "typedef", "t", ST_TYPEDEF, NULL, NULL, -1,
171 };
172 /* list of symbol class keywords */
173 static const namelist Symbolclasses[] = {
174 "Based", "B", SC_BASED, "Common", "C", SC_CMBLK,
175 "Dummy", "D", SC_DUMMY, "Extern", "E", SC_EXTERN,
176 "Local", "L", SC_LOCAL, "Private", "P", SC_PRIVATE,
177 "Static", "S", SC_STATIC, "none", "n", SC_NONE,
178 NULL, NULL, -1,
179 };
180
181 /* list of subprogram type keywords */
182 static const namelist Subprogramtypes[] = {
183 "Blockdata", "B", RU_BDATA, "Function", "F", RU_FUNC,
184 "Program", "P", RU_PROG, "Subroutine", "S", RU_SUBR,
185 NULL, NULL, -1,
186 };
187 /* clang-format on */
188
189 static int symbolcount = 0, datatypecount = 0;
190 static int oldsymbolcount = 0, olddatatypecount = 0;
191 static SPTR *symbolxref;
192 static DTYPE *datatypexref;
193
194 static int *agototab;
195 static int agotosz = 0;
196 static int agotomax;
197
198 typedef struct {
199 int type; /* INFO_... below */
200 int next; /* next IPAinfo entry for this symbol */
201 union {
202 struct {
203 int indirect; /* integer count of '*'s x 2, plus 1 if imprecise */
204 int target; /* sptr of target, or pseudo target number */
205 } target;
206 struct {
207 int low, high;
208 } range;
209 struct {
210 int info;
211 } funcinfo;
212 long pstride;
213 struct {
214 int val1;
215 int val2;
216 } val;
217 } t;
218 } IPAinfo;
219
220 /* values for IPAinfo.type */
221 #define INFO_GTARGET 1
222 #define INFO_OGTARGET 2
223 #define INFO_LTARGET 3
224 #define INFO_OTARGET 4
225 #define INFO_FLDYNTARGET 5
226 #define INFO_FGDYNTARGET 6
227 #define INFO_FUNKTARGET 7
228 #define INFO_FOTARGET 8
229 #define INFO_FSTARGET 9
230 #define INFO_FOSTARGET 10
231 #define INFO_RANGE 11
232 #define INFO_SAFE 12
233 #define INFO_FUNC 13
234 #define INFO_NEWSYM 14
235 #define INFO_NOCONFLICT 15
236 #define INFO_NOADDR 16
237 #define INFO_PSTRIDE 17
238 #define INFO_SSTRIDE 18
239 #define INFO_ALLCALLSAFE 19
240 #define INFO_CALLSAFE 20
241
242 typedef struct {
243 int sptr, info;
244 } IPAindex;
245
246 typedef struct {
247 int base, increment;
248 } SYMinfo;
249
250 typedef struct {
251 int stmt, lhs, rhs;
252 } repltype;
253
254 typedef struct {
255 int lhs, rhs;
256 } repltemptype;
257
258 typedef struct {
259 int index, dtype, link;
260 } typelisttype;
261
262 typedef struct {
263 int version;
264
265 IPAindex *index;
266 int indexsize, indexavl;
267
268 IPAinfo *info;
269 int infosize, infoavl;
270 } IPAB;
271
272 /* values for IPNFO_FUNCINFO() */
273 #define FINFO_WRITEARG 0x01
274 #define FINFO_READGLOB 0x02
275 #define FINFO_WRITEGLOB 0x04
276 #define FINFO_READSTATIC 0x08
277 #define FINFO_WRITESTATIC 0x10
278
279 int IPA_Pointer_Targets_Disambiguated = 0;
280 int IPA_Safe_Globals_Confirmed = 0;
281 int IPA_Range_Propagated = 0;
282 int IPA_Func_Propagated = 0;
283 int IPA_Pointer_Strides_Propagated = 0;
284
285 #if DEBUG
286
287 /* print a message, continue */
288 #define Trace(a) TraceOutput a
289
290 static void
TraceOutput(const char * fmt,...)291 TraceOutput(const char *fmt, ...)
292 {
293 va_list argptr;
294 va_start(argptr, fmt);
295
296 if (DBGBIT(47, 0x100)) {
297 if (gbl.dbgfil) {
298 vfprintf(gbl.dbgfil, fmt, argptr);
299 fprintf(gbl.dbgfil, "\n");
300 } else {
301 fprintf(stderr, "Trace: ");
302 vfprintf(stderr, fmt, argptr);
303 fprintf(stderr, "\n");
304 }
305 va_end(argptr);
306 }
307 } /* TraceOutput */
308 #else
309
310 /* eliminate the trace output */
311 #define Trace(a)
312 #endif
313
314 typedef struct alias_syminfo {
315 SPTR sptr;
316 const char *alias;
317 struct alias_syminfo *next;
318 } alias_syminfo;
319 static alias_syminfo *modvar_alias_list;
320
321 /* for processing data initialization */
322 typedef struct typestack {
323 DTYPE dtype;
324 SPTR member;
325 } typestack;
326
327 /* for saving outer procedure symbol information for the next internal routine
328 */
329 typedef struct upper_syminfo {
330 ISZ_T address;
331 ISZ_T clen_address;
332 SC_KIND sc;
333 int ref : 1;
334 int save : 1;
335 int memarg;
336 int clen_memarg;
337 } upper_syminfo;
338
339 static void restore_saved_syminfo(int);
340 static int getkeyword(char *keyname, const namelist NL[]);
341
342 static IPAB ipab;
343 static int errors;
344
345 /* keep a stack of information */
346 static int stack_top, stack_size;
347 static int **stack;
348
349 static typestack *ts; /* type stack */
350 static int tsl = -1; /* level in type stack */
351 static int tssize = 0; /* level in type stack */
352
353 static SPTR *saved_symbolxref;
354 static int saved_symbolcount = 0;
355 static upper_syminfo *saved_syminfo;
356 static int saved_syminfocount = 0;
357 static upper_syminfo *saved_tpinfo;
358 static int saved_tpcount = 0;
359 static int tpcount;
360 static DTYPE threadprivate_dtype;
361 static int *ilmxref;
362 static int ilmxrefsize, origilmavl;
363
364 #ifdef __cplusplus
getSptrVal(const char * s)365 inline SPTR getSptrVal(const char *s) {
366 return static_cast<SPTR>(getval(s));
367 }
368
getDtypeVal(const char * s)369 inline DTYPE getDtypeVal(const char *s) {
370 return static_cast<DTYPE>(getval(s));
371 }
372
getSptrOperand(const char * s,char ch)373 inline SPTR getSptrOperand(const char *s, char ch) {
374 return static_cast<SPTR>(getoperand(s, ch));
375 }
376
getDtypeOperand(const char * s,char ch)377 inline DTYPE getDtypeOperand(const char *s, char ch) {
378 return static_cast<DTYPE>(getoperand(s, ch));
379 }
380
getTYKind(void)381 inline TY_KIND getTYKind(void) {
382 return static_cast<TY_KIND>(getkeyword("datatype", Datatypes));
383 }
384
getSymType(void)385 inline SYMTYPE getSymType(void) {
386 return static_cast<SYMTYPE>(getkeyword("type", Symboltypes));
387 }
388
getSCKind(void)389 inline SC_KIND getSCKind(void) {
390 return static_cast<SC_KIND>(getkeyword("class", Symbolclasses));
391 }
392
getRUType(void)393 inline RUTYPE getRUType(void) {
394 return static_cast<RUTYPE>(getkeyword("procedure", Subprogramtypes));
395 }
396
getIPAType(void)397 inline int getIPAType(void) {
398 return getkeyword("type", IPAtypes);
399 }
400 #else // !C++
401 #define getSptrVal getval
402 #define getDtypeVal getval
403 #define getSptrOperand getoperand
404 #define getDtypeOperand getoperand
405 #define getTYKind() getkeyword("datatype", Datatypes)
406 #define getSymType() getkeyword("type", Symboltypes)
407 #define getSCKind() getkeyword("class", Symbolclasses)
408 #define getRUType() getkeyword("procedure", Subprogramtypes)
409 #define getIPAType() getkeyword("type", IPAtypes)
410 #endif // C++
411
412 #define IPNDX_SPTR(i) ipab.index[i].sptr
413 #define IPNDX_INFO(i) ipab.index[i].info
414 #define IPNFO_TYPE(i) ipab.info[i].type
415 #define IPNFO_NEXT(i) ipab.info[i].next
416 #define IPNFO_INDIRECT(i) (ipab.info[i].t.target.indirect >> 1)
417 #define IPNFO_IMPRECISE(i) (ipab.info[i].t.target.indirect & 0x01)
418 #define IPNFO_SET(i, indirect, imprecise) \
419 (ipab.info[i].t.target.indirect = indirect << 1 + (imprecise ? 1 : 0))
420 #define IPNFO_SET_IMPRECISE(i) (ipab.info[i].t.target.indirect |= 1)
421 #define IPNFO_TARGET(i) ipab.info[i].t.target.target
422 #define IPNFO_LOW(i) ipab.info[i].t.range.low
423 #define IPNFO_HIGH(i) ipab.info[i].t.range.high
424 #define IPNFO_FUNCINFO(i) ipab.info[i].t.funcinfo.info
425 #define IPNFO_PSTRIDE(i) ipab.info[i].t.pstride
426 #define IPNFO_SSTRIDE(i) ipab.info[i].t.pstride
427 #define IPNFO_VAL(i) ipab.info[i].t.val.val1
428 #define IPNFO_VAL2(i) ipab.info[i].t.val.val2
429
430 /**
431 * \brief Entry point for reading in ILM file
432 *
433 * Size of private array allocated by frontend - the frontend will allocate
434 * space for a descriptor and its pointer & offset variables since there
435 * is an assumed sequence of allocation.
436 */
437 void
upper(int stb_processing)438 upper(int stb_processing)
439 {
440 ISZ_T size;
441 SPTR first;
442 int firstinternal, gstaticbase;
443 static long ilmpos;
444 extern void set_private_size(ISZ_T);
445
446 llvm_stb_processing = stb_processing;
447 init_upper();
448
449 /* read first line */
450 endilmfile = read_line();
451 if (endilmfile) {
452 /* must be done! */
453 gbl.eof_flag = 1;
454 return;
455 }
456 if (line[0] == 'C') {
457 /* check for end of module */
458 if (strncmp(line, "CONSTRUCTORACC", 14) == 0) {
459 gbl.bss_addr = 0;
460 gbl.saddr = 0;
461 gbl.locaddr = 0;
462 gbl.statics = NOSYM;
463 gbl.locals = NOSYM;
464 gbl.cuda_constructor = true;
465 gbl.paddr = 0;
466 gbl.internal = 0;
467 return;
468 }
469 }
470 checkversion("TOILM");
471
472 endilmfile = read_line();
473 gbl.internal = getval("Internal");
474
475 if (gbl.internal > 1) {
476 --gbl.numcontained;
477 endilmfile = read_line();
478 gbl.outersub = getSptrVal("Outer");
479 endilmfile = read_line();
480 firstinternal = getval("First");
481 } else {
482 gbl.outersub = SPTR_NULL;
483 gbl.numcontained = 0;
484 firstinternal = stb.firstusym;
485 }
486
487 endilmfile = read_line();
488 symbolcount = getval("Symbols");
489 oldsymbolcount = stb.stg_avail - 1;
490 NEW(symbolxref, SPTR, symbolcount + 1);
491 BZERO(symbolxref, SPTR, symbolcount + 1);
492
493 endilmfile = read_line();
494 datatypecount = getval("Datatypes");
495 olddatatypecount = stb.dt.stg_avail - 1;
496 NEW(datatypexref, DTYPE, datatypecount + 1);
497 BZERO(datatypexref, DTYPE, datatypecount + 1);
498
499 ilmxrefsize = 100;
500 NEW(ilmxref, int, ilmxrefsize);
501 BZERO(ilmxref, int, ilmxrefsize);
502 origilmavl = 0;
503
504 endilmfile = read_line();
505 size = getval("BSS");
506 gbl.bss_addr = size;
507
508 endilmfile = read_line();
509 size = getval("GBL");
510 gbl.saddr = size;
511
512 endilmfile = read_line();
513 size = getval("LOC");
514 gbl.locaddr = size;
515
516 endilmfile = read_line();
517 first = getSptrVal("STATICS");
518 gbl.statics = first;
519
520 endilmfile = read_line();
521 first = getSptrVal("LOCALS");
522 gbl.locals = first;
523
524 endilmfile = read_line();
525 size = getval("PRIVATES");
526 set_private_size(size);
527
528 endilmfile = read_line();
529 gstaticbase = 0;
530 while (!endilmfile) {
531 /* read datatypes, symbols */
532 switch (line[0]) {
533 case 'd':
534 read_datatype();
535 break;
536 case 's':
537 read_symbol();
538 break;
539 case 'o':
540 read_overlap();
541 break;
542 case 'E':
543 read_Entry();
544 break;
545 case 'p':
546 read_program();
547 break;
548 case 'f':
549 read_fileentries();
550 break;
551 case 'i':
552 read_ipainfo();
553 break;
554 case 'e':
555 endilmfile = 1;
556 break;
557 case 'c':
558 read_contained();
559 break;
560 case 'g':
561 read_global();
562 break;
563 case 'G':
564 gstaticbase = getval("GNAME");
565 break;
566 case 'x':
567 if (line[1] == 'l') {
568 }
569 break;
570 default:
571 fprintf(stderr, "ILM error: line %d unknown line type %c\n", ilmlinenum,
572 line[0]);
573 ++errors;
574 break;
575 }
576 /* don't read next line if this was the end line */
577 if (!endilmfile)
578 endilmfile = read_line();
579 }
580 fix_symbol();
581 fix_datatype();
582
583 #if DEBUG
584 if (DBGBIT(47, 0x200)) {
585 dmp_dtype();
586 symdmp(gbl.dbgfil, 0);
587 }
588 #endif
589 if (STB_UPPER()) {
590 if (endilmfile) {
591 goto do_pastilm;
592 }
593 }
594 endilmfile = read_line();
595 if (checkname("CCFF")) {
596 endilmfile = read_CCFF();
597 if (!endilmfile)
598 read_line(); /* read line past CCFF messages */
599 }
600
601 if (STB_UPPER()) {
602 goto do_pastilm;
603 }
604
605 /* import the ILMs */
606
607 /* check first line */
608 checkversion("AST2ILM");
609
610 endilmfile = read_line();
611 while (!endilmfile) {
612 switch (line[0]) {
613 case 'B':
614 /* Begindata */
615 Begindata();
616 break;
617 case 'C':
618 /* Data Constant repeatcount datatype symbol [value | symbol] */
619 dataConstant();
620 break;
621 case 'D':
622 /* Data Do indvar lower upper step */
623 dataDo();
624 break;
625 case 'E':
626 /* Data Enddo */
627 dataEnddo();
628 break;
629 case 'e':
630 /* end */
631 endilmfile = 1;
632 break;
633 case 'i':
634 /* ilm */
635 read_ilm();
636 break;
637 case 'I':
638 /* initialization */
639 read_init();
640 break;
641 case 'l':
642 /* label */
643 read_label();
644 break;
645 case 'R':
646 /* data Reference ilm type */
647 dataReference();
648 break;
649 case 's':
650 /* structure repeatcount datatype symbol no_dinitp */
651 dataStructure();
652 break;
653 case 't':
654 /* tructurend */
655 data_pop_const();
656 break;
657 case 'V':
658 /* data Variable ilm type */
659 dataVariable();
660 break;
661 case 'W':
662 /* Writedata: end of data statement */
663 Writedata();
664 break;
665 default:
666 fprintf(stderr, "ILM error: line %d unknown line type %c\n", ilmlinenum,
667 line[0]);
668 ++errors;
669 break;
670 }
671 /* don't read next line if this was the end line */
672 if (!endilmfile)
673 endilmfile = read_line();
674 }
675
676 do_pastilm:
677 if (ts)
678 FREE(ts);
679 if (stack)
680 FREE(stack);
681 FREE(datatypexref);
682 FREE(ilmxref);
683
684 if (gbl.internal) {
685 /* must be done here before freeing symbolxref and saved_symbolxref */
686 fixup_llvm_uplevel_symbol();
687 }
688 if (agotosz) {
689 build_agoto();
690 }
691
692 switch (gbl.internal) {
693 case 0:
694 /* no internal routines */
695 FREE(symbolxref);
696 symbolxref = NULL;
697 /* get rid of stuff from previous containing routine, if any */
698 if (saved_symbolxref) {
699 FREE(saved_symbolxref);
700 saved_symbolxref = NULL;
701 saved_symbolcount = 0;
702 }
703 if (saved_syminfo) {
704 FREE(saved_syminfo);
705 saved_syminfo = NULL;
706 saved_syminfocount = 0;
707 }
708 gbl.outersub = SPTR_NULL;
709 break;
710 case 1:
711 /* outer routine having internal routines */
712 /* get rid of stuff from previous containing routine, if any */
713 if (saved_symbolxref) {
714 FREE(saved_symbolxref);
715 saved_symbolxref = NULL;
716 saved_symbolcount = 0;
717 }
718 if (saved_syminfo) {
719 FREE(saved_syminfo);
720 saved_syminfo = NULL;
721 saved_syminfocount = 0;
722 }
723 saved_symbolxref = symbolxref;
724 saved_symbolcount = symbolcount;
725 /* this is how many symbols we need to save information for */
726 saved_syminfocount = stb.stg_avail;
727 symbolxref = NULL;
728 gbl.outersub = gbl.currsub;
729 if (saved_tpinfo) {
730 FREE(saved_tpinfo);
731 saved_tpinfo = NULL;
732 saved_tpcount = 0;
733 }
734 break;
735 default:
736 /* inner routine; restore saved information */
737 restore_saved_syminfo(firstinternal);
738 FREE(symbolxref);
739 symbolxref = NULL;
740 /* keep the old 'syminfo' and 'saved_symbolxref' for next routine */
741 break;
742 }
743
744 /* import the DIRECTIVES */
745
746 /* read first line */
747 if (!STB_UPPER()) {
748 endilmfile = read_line();
749 checkversion("DIRECTIVES");
750 ilmlinenum += direct_import(gbl.srcfil);
751 } else if (endilmfile) {
752 goto do_dchar;
753 }
754 endilmfile = read_line(); /* end */
755 if (line[0] == 'e') {
756 endilmfile = 1;
757 } else {
758 errors++;
759 }
760
761 if (STB_UPPER()) {
762 goto do_dchar;
763 }
764
765 do_dinit();
766 /* if we are using the global ILM structure,
767 * look for assumed-length or deferred-length character dummy arguments.
768 * get a temp for the character length */
769 do_dchar:
770 if (XBIT(14, 0x20000) || !XBIT(14, 0x10000)) {
771 int e, dpdsc, paramct, i, param;
772 for (e = gbl.entries; e > NOSYM; e = SYMLKG(e)) {
773 dpdsc = DPDSCG(e);
774 paramct = PARAMCTG(e);
775 for (i = 0; i < paramct; ++i) {
776 int param, dtype;
777 param = aux.dpdsc_base[dpdsc + i];
778 dtype = DDTG(DTYPEG(param));
779 if (dtype == DT_DEFERCHAR || dtype == DT_DEFERNCHAR ||
780 dtype == DT_ASSCHAR || dtype == DT_ASSNCHAR) {
781 if (!CLENG(param)) {
782 int clen;
783 clen = getdumlen();
784 CLENP(param, clen);
785 PARREFP(clen, PARREFG(param));
786 }
787 }
788 }
789 }
790 }
791
792 if (gstaticbase) {
793 create_static_base(gstaticbase);
794 }
795 freearea(4); /* free memory used to build static initializations */
796 if (errors) {
797 interr("Errors in ILM file", errors, ERR_Fatal);
798 }
799 llvm_stb_processing = 0;
800 } /* upper */
801
802 /**
803 \brief For outer routines that contain inner routines, make sure all
804 variables get an address, even if never used in this routine, in case they
805 are used by the contained routines.
806 */
807 void
upper_assign_addresses(void)808 upper_assign_addresses(void)
809 {
810 if (gbl.internal == 1) {
811 SPTR sptr;
812 for (sptr = (SPTR) stb.firstusym; sptr < stb.stg_avail; ++sptr) {
813 switch (STYPEG(sptr)) {
814 case ST_VAR:
815 case ST_ARRAY:
816 case ST_STRUCT:
817 case ST_UNION:
818 case ST_PLIST:
819 if (REFG(sptr) == 0) {
820 switch (SCG(sptr)) {
821 case SC_LOCAL:
822 case SC_STATIC:
823 hostsym_is_refd(sptr);
824 break;
825 default:
826 break;
827 }
828 }
829 break;
830 default:
831 break;
832 }
833 }
834 }
835 } /* upper_assign_addresses */
836
837 static void
restore_saved_syminfo(int firstinternal)838 restore_saved_syminfo(int firstinternal)
839 {
840 int s;
841 SPTR newsptr, oldsptr;
842 SC_KIND sc;
843 int ref, save;
844 ISZ_T address;
845
846 if (gbl.internal < 2)
847 return;
848 for (s = 1; s <= saved_symbolcount; ++s) {
849 /* has this symbol been imported for this internal routine? */
850 if (s > symbolcount)
851 break;
852 if (s >= firstinternal)
853 break;
854 newsptr = symbolxref[s];
855 if (newsptr == 0)
856 continue;
857 oldsptr = saved_symbolxref[s];
858 if (oldsptr >= saved_syminfocount)
859 continue;
860 sc = saved_syminfo[oldsptr].sc;
861 address = saved_syminfo[oldsptr].address;
862 ref = saved_syminfo[oldsptr].ref;
863 save = saved_syminfo[oldsptr].save;
864 switch (STYPEG(newsptr)) {
865 case ST_PLIST:
866 case ST_VAR:
867 case ST_ARRAY:
868 case ST_STRUCT:
869 case ST_UNION:
870 if (sc == SC_DUMMY) {
871 SCP(newsptr, sc);
872 ADDRESSP(newsptr, address);
873 REFP(newsptr, ref);
874 MEMARGP(newsptr, saved_syminfo[oldsptr].memarg);
875 if (saved_syminfo[oldsptr].clen_address) {
876 int clen;
877 clen = gethost_dumlen(newsptr, saved_syminfo[oldsptr].clen_address);
878 CLENP(newsptr, clen);
879 MEMARGP(clen, saved_syminfo[oldsptr].clen_memarg);
880 }
881 #if DEBUG
882 if (sc != SCG(newsptr)) {
883 Trace(("outer procedure dummy %d name %s had (sc)=(%d) now (%d)",
884 newsptr, SYMNAME(newsptr), sc, (int)SCG(newsptr)));
885 fprintf(stderr,
886 "ILM error: internal routine gets bad sclass for "
887 "outer variable %s\n",
888 SYMNAME(newsptr));
889 ++errors;
890 }
891 #endif
892 } else if (REFG(newsptr) && (save || !SAVEG(newsptr))) {
893 /* allow for the case where the SAVE flag was optimized away */
894 /* compare the saved REF, ADDRESS, SC fields */
895 if (REREFG(newsptr)) {
896 /* handle special case when REREF flag is set. See
897 * comment for REREF in fix_symbol().
898 */
899 ADDRESSP(newsptr, address);
900 }
901 if (sc != SCG(newsptr) || address != ADDRESSG(newsptr) || ref == 0) {
902 if (sc || address || ref) {
903 Trace(("outer procedure symbol %d name %s had "
904 "(sc,address,ref)=(%d,%" ISZ_PF "d,%d) now (%d,%" ISZ_PF
905 "d,%d)",
906 newsptr, SYMNAME(newsptr), sc, address, ref,
907 (int)SCG(newsptr), (int)ADDRESSG(newsptr),
908 (int)REFG(newsptr)));
909 fprintf(stderr,
910 "ILM error: internal routine gets bad address for "
911 "outer variable %s\n",
912 SYMNAME(newsptr));
913 ++errors;
914 }
915 }
916 } else if (ref) {
917 /* get the saved REF, ADDRESS, SC fields */
918 if (sc == SC_LOCAL) {
919 SCP(newsptr, sc);
920 SAVEP(newsptr, save);
921 ADDRESSP(newsptr, address);
922 REFP(newsptr, ref);
923 if (!UPLEVELG(newsptr)) {
924 SYMLKP(newsptr, gbl.locals);
925 gbl.locals = newsptr;
926 }
927 } else if (sc == SC_STATIC) {
928 SCP(newsptr, sc);
929 ADDRESSP(newsptr, address);
930 REFP(newsptr, ref);
931 if (!UPLEVELG(newsptr)) {
932 SYMLKP(newsptr, gbl.statics);
933 gbl.statics = newsptr;
934 }
935 } else {
936 Trace(("unknown restore (sc,address,ref)=(%d,%" ISZ_PF "d,%d)", sc,
937 address, ref));
938 }
939 }
940 if (IS_THREAD_TP(newsptr)) {
941 int ss;
942 int tptr;
943 int psptr;
944
945 switch (SCG(newsptr)) {
946 case SC_LOCAL:
947 case SC_STATIC:
948 if (UPLEVELG(newsptr) && !MIDNUMG(newsptr)) {
949 tptr = create_thread_private_vector(newsptr, oldsptr);
950 MIDNUMP(tptr, newsptr);
951 MIDNUMP(newsptr, tptr);
952 if (!XBIT(69, 0x80))
953 SCP(tptr, SC_STATIC);
954 }
955 break;
956 case SC_BASED:
957 psptr = MIDNUMG(newsptr);
958 if ((SCG(psptr) == SC_LOCAL || SCG(psptr) == SC_STATIC) &&
959 UPLEVELG(psptr)) {
960 if (POINTERG(newsptr)) {
961 /*
962 * Cannot rely on the SYMLK chain appearing as
963 * $p -> $o -> $sd
964 * Apparently, these links only occur for the
965 * pointer's internal variables if the pointer
966 * does not have the SAVE attribute. Without
967 * these fields, the correct size of the threads'
968 * copies cannot be computed.
969 * Just explicitly look for the internal pointer
970 * and descriptor. If the descriptor is present,
971 * can assume that there is an offest variable which
972 * only needs to be accounted for in the size
973 * computation of the threads' copies.
974 * Setup up the MIDNUM fields as follows where
975 * foo is the symtab entry which has the POINTER
976 * flag set:
977 * foo -> foo$p
978 * TPpfoo -> foo
979 * foo$p -> TPpfoo
980 * foo$sd -> TPpfoo
981 * Note that foo's SDSC -> foo$sd.
982 * Before we had:
983 * foo -> TPpfoo
984 * TPpfoo -> foo$p
985 * which is a problem for computing the size
986 * when starting with TPpfoo.
987 */
988 int sdsptr;
989 tptr = create_thread_private_vector(psptr, oldsptr);
990 THREADP(psptr, 1);
991 MIDNUMP(newsptr, psptr);
992 MIDNUMP(tptr, newsptr);
993 MIDNUMP(psptr, tptr);
994 sdsptr = SDSCG(newsptr);
995 if (sdsptr) {
996 THREADP(sdsptr, 1);
997 MIDNUMP(sdsptr, tptr);
998 }
999 } else {
1000 /*
1001 * Given the above code for POINTER, this code is
1002 * probably dead, but leave it just in case.
1003 */
1004 tptr = create_thread_private_vector(psptr, oldsptr);
1005 THREADP(psptr, 1);
1006 MIDNUMP(newsptr, tptr);
1007 MIDNUMP(tptr, psptr);
1008 MIDNUMP(psptr, tptr);
1009 if (SYMLKG(psptr) != NOSYM) {
1010 psptr = symbolxref[SYMLKG(psptr)];
1011 THREADP(psptr, 1);
1012 MIDNUMP(psptr, tptr);
1013 if (SYMLKG(psptr) != NOSYM) {
1014 psptr = symbolxref[SYMLKG(psptr)];
1015 THREADP(psptr, 1);
1016 MIDNUMP(psptr, tptr);
1017 }
1018 }
1019 }
1020 }
1021 break;
1022 default:
1023 break;
1024 }
1025 }
1026 break;
1027
1028 case ST_PROC:
1029 /* assertion: must be a dummy procedure */
1030 ADDRESSP(newsptr, address);
1031 MEMARGP(newsptr, saved_syminfo[oldsptr].memarg);
1032 break;
1033 default:
1034 break;
1035 }
1036 }
1037
1038 } /* restore_saved_syminfo */
1039
1040 /**
1041 \brief Save information about symbols for this outer routine to restore
1042 inside other inner routines.
1043 */
1044 void
upper_save_syminfo(void)1045 upper_save_syminfo(void)
1046 {
1047 int s, sptr, sc, ref;
1048 ISZ_T address;
1049
1050 if (gbl.internal != 1)
1051 return;
1052 /* allocate a saved_syminfo; only need info for symbols imported;
1053 * saved_syminfocount set for gbl.internal==1 in upper() */
1054 NEW(saved_syminfo, upper_syminfo, saved_syminfocount + 1);
1055 BZERO(saved_syminfo, upper_syminfo, saved_syminfocount + 1);
1056 for (s = 1; s <= saved_symbolcount; ++s) {
1057 sptr = saved_symbolxref[s];
1058 if (sptr == 0)
1059 continue;
1060 switch (STYPEG(sptr)) {
1061 case ST_VAR:
1062 case ST_ARRAY:
1063 case ST_STRUCT:
1064 case ST_UNION:
1065 case ST_PLIST:
1066 if (REFG(sptr) || GSCOPEG(sptr) || SCG(sptr) == SC_DUMMY) {
1067 saved_syminfo[sptr].sc = SCG(sptr);
1068 saved_syminfo[sptr].address = ADDRESSG(sptr);
1069 saved_syminfo[sptr].ref = REFG(sptr) | GSCOPEG(sptr);
1070 saved_syminfo[sptr].save = SAVEG(sptr);
1071 saved_syminfo[sptr].clen_address = 0;
1072 saved_syminfo[sptr].clen_memarg = 0;
1073 if (SCG(sptr) == SC_DUMMY) {
1074 if (DDTG(DTYPEG(sptr)) == DT_ASSCHAR ||
1075 DDTG(DTYPEG(sptr)) == DT_ASSNCHAR) {
1076 saved_syminfo[sptr].clen_address = ADDRESSG(CLENG(sptr));
1077 saved_syminfo[sptr].clen_memarg = MEMARGG(CLENG(sptr));
1078 } else if (DDTG(DTYPEG(sptr)) == DT_DEFERCHAR ||
1079 DDTG(DTYPEG(sptr)) == DT_DEFERNCHAR) {
1080 saved_syminfo[sptr].clen_address = ADDRESSG(CLENG(sptr));
1081 saved_syminfo[sptr].clen_memarg = MEMARGG(CLENG(sptr));
1082 }
1083 saved_syminfo[sptr].memarg = MEMARGG(sptr);
1084 }
1085 }
1086 break;
1087 case ST_PROC:
1088 if (SCG(sptr) == SC_DUMMY) {
1089 /* sc & reg aren't needed but are copied to prevent * UMRs. */
1090 saved_syminfo[sptr].sc = SCG(sptr);
1091 saved_syminfo[sptr].address = ADDRESSG(sptr);
1092 saved_syminfo[sptr].ref = REFG(sptr);
1093 saved_syminfo[sptr].memarg = MEMARGG(sptr);
1094 }
1095 break;
1096 default:
1097 break;
1098 }
1099 }
1100 if (tpcount) {
1101 int cnt;
1102 NEW(saved_tpinfo, upper_syminfo, tpcount + 1);
1103 cnt = 0;
1104 for (sptr = gbl.threadprivate; sptr > NOSYM; sptr = TPLNKG(sptr)) {
1105 /*
1106 if (STYPEG(MIDNUMG(sptr)) == ST_CMBLK)
1107 continue;
1108 */
1109 saved_tpinfo[cnt].sc = SCG(sptr);
1110 saved_tpinfo[cnt].address = ADDRESSG(sptr);
1111 saved_tpinfo[cnt].ref = REFG(sptr);
1112 saved_tpinfo[cnt].memarg = MIDNUMG(sptr);
1113 cnt++;
1114 }
1115 saved_tpcount = cnt;
1116 }
1117 } /* upper_save_syminfo */
1118
1119 static void
init_upper(void)1120 init_upper(void)
1121 {
1122 gbl.entries = NOSYM;
1123 gbl.cuda_constructor = false;
1124 soc.avail = 1;
1125
1126 errors = 0;
1127
1128 stack_top = 0;
1129 stack_size = 0;
1130 stack = NULL;
1131 tsl = -1;
1132 ts = NULL;
1133 tssize = 0;
1134 if (linelen == 0) {
1135 linelen = 4096;
1136 line = (char *)malloc(linelen * sizeof(char));
1137 }
1138 if (ipab.index == NULL) {
1139 ipab.indexsize = 100;
1140 NEW(ipab.index, IPAindex, ipab.indexsize);
1141 }
1142 ipab.indexavl = 0;
1143 if (ipab.info == NULL) {
1144 ipab.infosize = 100;
1145 NEW(ipab.info, IPAinfo, ipab.infosize);
1146 }
1147 ipab.infoavl = 1;
1148 if (modvar_alias_list) {
1149 free_modvar_alias_list();
1150 }
1151 } /* init_upper */
1152
1153 /*
1154 * called from main
1155 * read the 'inline' information saved in the ilm file
1156 */
1157 void
upper_init(void)1158 upper_init(void)
1159 {
1160 int end;
1161 end = read_line();
1162 while (line[0] == 'i') {
1163 char *name, *cname, *filename;
1164 int level, which, namelen, cnamelen, filenamelen, base, size;
1165 long offset, objoffset;
1166 /* an 'inline' line */
1167 level = getval("inline");
1168 offset = getlval("offset");
1169 which = getval("which");
1170 cnamelen = getnamelen();
1171 cname = line + pos;
1172 pos += cnamelen;
1173 namelen = getnamelen();
1174 name = line + pos;
1175 pos += namelen;
1176 filenamelen = getnamelen();
1177 filename = line + pos;
1178 pos += filenamelen;
1179 objoffset = getlval("objoffset");
1180 base = getval("base");
1181 size = getval("size");
1182 name[namelen] = '\0';
1183 cname[cnamelen] = '\0';
1184 filename[filenamelen] = '\0';
1185 end = read_line();
1186 }
1187
1188 } /* upper_init */
1189
1190 static int
read_line(void)1191 read_line(void)
1192 {
1193 char *ret;
1194 int i, ch;
1195 i = 0;
1196 pos = 0;
1197 while (1) {
1198 if (STB_UPPER())
1199 ch = fgetc(gbl.stbfil); /* fgetc() returns an int */
1200 else
1201 ch = fgetc(gbl.srcfil); /* fgetc() returns an int */
1202 if (i >= linelen) {
1203 if (linelen == 0) {
1204 linelen = 4096;
1205 line = (char *)malloc(linelen * sizeof(char));
1206 } else {
1207 linelen = linelen * 2;
1208 line = (char*) realloc(line, linelen);
1209 }
1210 }
1211 if (ch == EOF || (char)ch == '\n') {
1212 line[i] = '\0';
1213 break;
1214 }
1215 line[i] = (char)ch;
1216 ++i;
1217 }
1218
1219 ++ilmlinenum;
1220 if (ch == EOF && i == 0)
1221 return 1;
1222 return 0;
1223 } /* read_line */
1224
1225 static void
checkversion(char * text)1226 checkversion(char *text)
1227 {
1228 int ret;
1229 char check[50];
1230 int v1, v2;
1231
1232 v1 = v2 = 0;
1233 check[0] = '\0';
1234 ret = sscanf(line, "%s version %d/%d", check, &v1, &v2);
1235 if (ret != 3 || v1 != VersionMajor || strcmp(text, check) != 0) {
1236 fprintf(stderr,
1237 "IILM file version error\n"
1238 "Expecting %s version %d/%d\n"
1239 " got %s version %d/%d\n",
1240 text, VersionMajor, VersionMinor, check, v1, v2);
1241 exit(1);
1242 }
1243 if (v2 != VersionMinor) {
1244 switch (VersionMajor) {
1245 case 1:
1246 /*
1247 * The PASSBYVAL & PASSBYREF flags are new to 1.10
1248 * If the version
1249 */
1250 if (v2 < 10 && VersionMinor >= 10) {
1251 passbyflags = 0;
1252 return;
1253 }
1254 /* CFUNC for variables are new t. 1.1 :
1255 make the externally visable variables
1256 compatible with the equivalent C extern
1257 */
1258 if (v2 < 11 && VersionMinor >= 11) {
1259 cfuncflags = 0;
1260 return;
1261 }
1262 if (v2 < 15 && VersionMinor >= 15) {
1263 cudaflags = 0;
1264 return;
1265 }
1266 }
1267 fprintf(stderr,
1268 "ILM file version error\n"
1269 "Expecting %s version %d/%d\n"
1270 " got %s version %d/%d\n",
1271 text, VersionMajor, VersionMinor, check, v1, v2);
1272 exit(1);
1273 }
1274 } /* checkversion */
1275
1276 /* skip white space */
1277 static void
skipwhitespace(void)1278 skipwhitespace(void)
1279 {
1280 while (line[pos] <= ' ' && line[pos] != '\0')
1281 ++pos;
1282 } /* skipwhitespace */
1283
1284 /* check that the name matches */
1285 static int
checkname(const char * name)1286 checkname(const char *name)
1287 {
1288 int i;
1289 if ((line[pos] == name[0]) && (line[pos + 1] == ':')) {
1290 /* short version of file, just initial letter of each field */
1291 pos += 2;
1292 return 1;
1293 }
1294 for (i = 0; name[i] && line[pos + i]; ++i) {
1295 if (line[pos + i] != name[i])
1296 return 0;
1297 }
1298 if (line[pos + i] == '\n' || line[pos + i] == ' ' || line[pos + i] == '\0') {
1299 pos += i;
1300 return 1;
1301 }
1302 if (line[pos + i] == ':') {
1303 pos += i + 1; /* skip past colon */
1304 return 1;
1305 }
1306 return 0;
1307 } /* checkname */
1308
1309 /* check that the name matches */
1310 static int
checkbitname(char * name)1311 checkbitname(char *name)
1312 {
1313 int i;
1314 if ((line[pos] == name[0]) &&
1315 (line[pos + 1] == '-' || line[pos + 1] == '+')) {
1316 /* short version of file, just initial letter of each field */
1317 ++pos;
1318 return 1;
1319 }
1320 for (i = 0; name[i] && line[pos + i]; ++i) {
1321 if (line[pos + i] != name[i])
1322 return 0;
1323 }
1324 if (line[pos + i] == '+' || line[pos + i] == '-') {
1325 pos += i;
1326 return 1;
1327 }
1328 return 0;
1329 } /* checkbitname */
1330
1331 static ISZ_T
getval(const char * valname)1332 getval(const char *valname)
1333 {
1334 ISZ_T val, neg;
1335
1336 if (endilmfile) {
1337 fprintf(stderr, "ILM file: looking past end-of-file for value %s\n",
1338 valname);
1339 ++errors;
1340 return 0;
1341 }
1342
1343 skipwhitespace();
1344
1345 if (!checkname(valname)) {
1346 fprintf(stderr,
1347 "ILM file line %d: expecting value for %s\n"
1348 "instead got: %s\n",
1349 ilmlinenum, valname, line + pos);
1350 ++errors;
1351 return 0;
1352 }
1353
1354 val = 0;
1355 neg = 1;
1356 if (line[pos] == '-') {
1357 ++pos;
1358 neg = -1;
1359 }
1360 while (line[pos] >= '0' && line[pos] <= '9') {
1361 val = val * 10 + (line[pos] - '0');
1362 ++pos;
1363 }
1364 val *= neg;
1365 Trace((" %s=%d", valname, val));
1366 return val;
1367 } /* getval */
1368
1369 static long
getlval(char * valname)1370 getlval(char *valname)
1371 {
1372 long val, neg;
1373
1374 if (endilmfile) {
1375 fprintf(stderr, "ILM file: looking past end-of-file for value %s\n",
1376 valname);
1377 ++errors;
1378 return 0;
1379 }
1380
1381 skipwhitespace();
1382
1383 if (!checkname(valname)) {
1384 fprintf(stderr,
1385 "ILM file line %d: expecting value for %s\n"
1386 "instead got: %s\n",
1387 ilmlinenum, valname, line + pos);
1388 ++errors;
1389 return 0;
1390 }
1391
1392 val = 0;
1393 neg = 1;
1394 if (line[pos] == '-') {
1395 ++pos;
1396 neg = -1;
1397 }
1398 while (line[pos] >= '0' && line[pos] <= '9') {
1399 val = val * 10 + (line[pos] - '0');
1400 ++pos;
1401 }
1402 val *= neg;
1403 Trace((" %s=%d", valname, val));
1404 return val;
1405 } /* getlval */
1406
1407 static int
getbit(char * bitname)1408 getbit(char *bitname)
1409 {
1410 if (endilmfile) {
1411 fprintf(stderr, "ILM file: looking past end-of-file for bit %s\n", bitname);
1412 ++errors;
1413 return 0;
1414 }
1415
1416 skipwhitespace();
1417
1418 if (!checkbitname(bitname)) {
1419 fprintf(stderr,
1420 "ILM file line %d: expecting bit %s\n"
1421 "instead got: %s\n",
1422 ilmlinenum, bitname, line + pos);
1423 ++errors;
1424 return 0;
1425 }
1426
1427 if (line[pos] == '-') {
1428 ++pos;
1429 Trace((" %s-", bitname));
1430 return 0;
1431 }
1432 if (line[pos] == '+') {
1433 ++pos;
1434 Trace((" %s+", bitname));
1435 return 1;
1436 }
1437 fprintf(stderr,
1438 "ILM file line %d: expecting +/- value for %s\n"
1439 "instead got: %s\n",
1440 ilmlinenum, bitname, line + pos);
1441 ++errors;
1442 return 0;
1443 } /* getbit */
1444
1445 /* get a pair of numbers first:second */
1446 static void
getpair(SPTR * first,SPTR * second)1447 getpair(SPTR *first, SPTR *second)
1448 {
1449 int val, neg;
1450 if (endilmfile) {
1451 fprintf(stderr, "ILM file: looking past end-of-file for number pair\n");
1452 *first = *second = SPTR_NULL;
1453 ++errors;
1454 return;
1455 }
1456
1457 skipwhitespace();
1458
1459 val = 0;
1460 neg = 1;
1461 if (line[pos] == '-') {
1462 ++pos;
1463 neg = -1;
1464 }
1465 while (line[pos] >= '0' && line[pos] <= '9') {
1466 val = val * 10 + (line[pos] - '0');
1467 ++pos;
1468 }
1469 *first = (SPTR)(val * neg);
1470
1471 if (line[pos] != ':') {
1472 fprintf(stderr,
1473 "ILM file line %d: expecting number pair\n"
1474 "instead got: %s\n",
1475 ilmlinenum, line + pos);
1476 *second = SPTR_NULL;
1477 ++errors;
1478 return;
1479 }
1480 ++pos;
1481
1482 val = 0;
1483 neg = 1;
1484 if (line[pos] == '-') {
1485 ++pos;
1486 neg = -1;
1487 }
1488 while (line[pos] >= '0' && line[pos] <= '9') {
1489 val = val * 10 + (line[pos] - '0');
1490 ++pos;
1491 }
1492 *second = (SPTR)(val * neg);
1493 } /* getpair */
1494
1495 static int
getnum(void)1496 getnum(void)
1497 {
1498 int val;
1499
1500 if (endilmfile) {
1501 fprintf(stderr, "ILM file: looking past end-of-file for number\n");
1502 ++errors;
1503 return 0;
1504 }
1505
1506 skipwhitespace();
1507
1508 val = 0;
1509 while (line[pos] >= '0' && line[pos] <= '9') {
1510 val = val * 10 + (line[pos] - '0');
1511 ++pos;
1512 }
1513 Trace((" %d", val));
1514 return val;
1515 } /* getnum */
1516
1517 static int
gethex(void)1518 gethex(void)
1519 {
1520 int val;
1521 char ch;
1522
1523 if (endilmfile) {
1524 fprintf(stderr, "ILM file: looking past end-of-file for hex value\n");
1525 ++errors;
1526 return 0;
1527 }
1528
1529 skipwhitespace();
1530
1531 val = 0;
1532 while (1) {
1533 ch = line[pos];
1534 if (ch >= '0' && ch <= '9') {
1535 val = val * 16 + (line[pos] - '0');
1536 } else if (ch >= 'a' && ch <= 'f') {
1537 val = val * 16 + (line[pos] - 'a') + 10;
1538 } else if (ch >= 'A' && ch <= 'F') {
1539 val = val * 16 + (line[pos] - 'A') + 10;
1540 } else {
1541 break;
1542 }
1543 ++pos;
1544 }
1545 Trace((" %x", val));
1546 return val;
1547 } /* gethex */
1548
1549 static int
match(char * K)1550 match(char *K)
1551 {
1552 int j;
1553 for (j = 0; K[j]; ++j) {
1554 if (K[j] != line[pos + j]) {
1555 return 0;
1556 }
1557 }
1558 if (line[pos + j] <= ' ') { /* all matched */
1559 pos += j;
1560 return 1;
1561 }
1562 return 0;
1563 } /* match */
1564
1565 static int
getkeyword(char * keyname,const namelist NL[])1566 getkeyword(char *keyname, const namelist NL[])
1567 {
1568 int i;
1569 if (endilmfile) {
1570 fprintf(stderr, "ILM file: looking past end-of-file for %s keyword\n",
1571 keyname);
1572 ++errors;
1573 return 0;
1574 }
1575
1576 skipwhitespace();
1577
1578 for (i = 0; NL[i].keyword; ++i) {
1579 if (line[pos] == NL[i].keyword[0]) {
1580 /* check this keyword and shortkeyword */
1581 if (match(NL[i].keyword)) {
1582 Trace((" %s=%s", keyname, NL[i].keyword));
1583 return NL[i].keyvalue;
1584 }
1585 if (match(NL[i].shortkeyword)) {
1586 Trace((" %s=%s", keyname, NL[i].keyword));
1587 return NL[i].keyvalue;
1588 }
1589 }
1590 }
1591 fprintf(stderr, "ILM File line %d: no match for %s keyword\n", ilmlinenum,
1592 keyname);
1593 ++errors;
1594 return -1;
1595 } /* getkeyword */
1596
1597 static int
getnamelen(void)1598 getnamelen(void)
1599 {
1600 int val;
1601 if (endilmfile) {
1602 fprintf(stderr, "ILM file: looking past end-of-file for name\n");
1603 ++errors;
1604 return 0;
1605 }
1606
1607 skipwhitespace();
1608
1609 val = 0;
1610 while (line[pos] >= '0' && line[pos] <= '9') {
1611 val = val * 10 + (line[pos] - '0');
1612 ++pos;
1613 }
1614 if (line[pos] == ':')
1615 ++pos;
1616 Trace((" %d:", val));
1617 return val;
1618 } /* getnamelen */
1619
1620 static char *
getname(void)1621 getname(void)
1622 {
1623 int len;
1624 char *name;
1625 len = getnamelen();
1626 name = line + pos;
1627 pos += len + 1;
1628 name[len] = '\0';
1629 return name;
1630 } /* getname */
1631
1632 static void
read_datatype(void)1633 read_datatype(void)
1634 {
1635 DTYPE dtype, dt;
1636 TY_KIND dval;
1637 int ty;
1638 SPTR member;
1639 int align;
1640 DTYPE subtype;
1641 int ndim;
1642 SPTR lower, upper;
1643 int i;
1644 SPTR tag;
1645 ISZ_T size;
1646 ADSC *ad;
1647 SPTR iface;
1648 int paramct, dpdsc;
1649 SPTR fval;
1650
1651 dtype = getDtypeVal("datatype");
1652 dval = getTYKind();
1653 switch (dval) {
1654 case TY_CMPLX:
1655 datatypexref[dtype] = DT_CMPLX;
1656 break;
1657 case TY_DCMPLX:
1658 datatypexref[dtype] = DT_DCMPLX;
1659 break;
1660 case TY_HOLL:
1661 datatypexref[dtype] = DT_HOLL;
1662 break;
1663 case TY_BINT:
1664 datatypexref[dtype] = DT_BINT;
1665 break;
1666 case TY_SINT:
1667 datatypexref[dtype] = DT_SINT;
1668 break;
1669 case TY_INT:
1670 datatypexref[dtype] = DT_INT;
1671 break;
1672 case TY_INT8:
1673 datatypexref[dtype] = DT_INT8;
1674 break;
1675 case TY_BLOG:
1676 datatypexref[dtype] = DT_BLOG;
1677 break;
1678 case TY_SLOG:
1679 datatypexref[dtype] = DT_SLOG;
1680 break;
1681 case TY_LOG:
1682 datatypexref[dtype] = DT_LOG;
1683 break;
1684 case TY_LOG8:
1685 datatypexref[dtype] = DT_LOG8;
1686 break;
1687 case TY_NUMERIC:
1688 datatypexref[dtype] = DT_NUMERIC;
1689 break;
1690 case TY_REAL:
1691 datatypexref[dtype] = DT_REAL;
1692 break;
1693 case TY_DBLE:
1694 datatypexref[dtype] = DT_DBLE;
1695 break;
1696 case TY_QUAD:
1697 datatypexref[dtype] = DT_QUAD;
1698 break;
1699 case TY_WORD:
1700 datatypexref[dtype] = DT_WORD;
1701 break;
1702 case TY_DWORD:
1703 datatypexref[dtype] = DT_DWORD;
1704 break;
1705 case TY_ANY:
1706 datatypexref[dtype] = DT_ANY;
1707 break;
1708 case TY_NONE:
1709 datatypexref[dtype] = DT_NONE;
1710 break;
1711
1712 case TY_STRUCT:
1713 case TY_UNION:
1714 member = getSptrVal("member");
1715 size = getval("size");
1716 tag = getSptrVal("tag");
1717 align = getval("align");
1718 dt = get_type(6, dval, NOSYM);
1719 datatypexref[dtype] = dt;
1720 DTySetAlgTy(dt, member, size, tag, align, 0);
1721 break;
1722 case TY_CHAR:
1723 size = getval("len");
1724 if (size == -1) {
1725 datatypexref[dtype] = DT_ASSCHAR;
1726 } else if (size == -2) {
1727 datatypexref[dtype] = DT_ASSCHAR;
1728 } else if (size == -3) {
1729 datatypexref[dtype] = DT_DEFERCHAR;
1730 } else if (size == -4) {
1731 datatypexref[dtype] = DT_DEFERCHAR;
1732 } else {
1733 datatypexref[dtype] = get_type(2, dval, size);
1734 }
1735 break;
1736 case TY_NCHAR:
1737 size = getval("len");
1738 if (size == -1) {
1739 datatypexref[dtype] = DT_ASSNCHAR;
1740 } else if (size == -2) {
1741 datatypexref[dtype] = DT_ASSNCHAR;
1742 } else if (size == -3) {
1743 datatypexref[dtype] = DT_DEFERNCHAR;
1744 } else if (size == -4) {
1745 datatypexref[dtype] = DT_DEFERNCHAR;
1746 } else {
1747 datatypexref[dtype] = get_type(2, dval, size);
1748 }
1749 break;
1750 case TY_ARRAY:
1751 subtype = getDtypeVal("type");
1752 ndim = getval("dims");
1753 dt = get_array_dtype(ndim, subtype);
1754 /* get the pointer to the array bounds descriptor */
1755 ad = AD_DPTR(dt);
1756 AD_NUMDIM(ad) = ndim;
1757 AD_SCHECK(ad) = 0;
1758 for (i = 0; i < ndim; ++i) {
1759 getpair(&lower, &upper);
1760 AD_LWBD(ad, i) = lower; /* to be fixed after symbols added */
1761 AD_UPBD(ad, i) = upper; /* to be fixed after symbols added */
1762 AD_MLPYR(ad, i) = getSptrVal("mpy");
1763 }
1764 AD_ZBASE(ad) = getval("zbase");
1765 AD_NUMELM(ad) = getSptrVal("numelm");
1766 datatypexref[dtype] = dt;
1767 break;
1768 case TY_PTR:
1769 subtype = getDtypeVal("ptrto");
1770 if (subtype == DT_ANY) {
1771 datatypexref[dtype] = DT_ADDR;
1772 } else {
1773 datatypexref[dtype] = get_type(2, dval, subtype);
1774 }
1775 break;
1776 case TY_PROC:
1777 subtype = getDtypeVal("result");
1778 iface = getSptrVal("iface");
1779 paramct = getval("paramct");
1780 dpdsc = getval("dpdsc");
1781 fval = getSptrVal("fval");
1782 dt = get_type(6, dval, subtype);
1783 datatypexref[dtype] = dt;
1784 DTySetProcTy(dt, subtype, iface, paramct, dpdsc, fval);
1785 break;
1786 }
1787 } /* read_datatype */
1788
1789 static void
fix_datatype(void)1790 fix_datatype(void)
1791 {
1792 int d;
1793 DTYPE dtype;
1794 int ndim, i;
1795 SPTR lower, upper;
1796 int member;
1797 SPTR mlpyr;
1798 int zbase;
1799 SPTR numelm;
1800 DTYPE subtype;
1801 SPTR tag;
1802 ADSC *ad;
1803 SPTR iface;
1804 int dpdsc;
1805 SPTR fval;
1806
1807 for (d = 0; d <= datatypecount; ++d) {
1808 dtype = datatypexref[d];
1809 if (dtype > olddatatypecount) {
1810 switch (DTY(dtype)) {
1811 case TY_STRUCT:
1812 case TY_UNION:
1813 member = DTyAlgTyMember(dtype);
1814 member = symbolxref[member];
1815 DTySetFst(dtype, member);
1816 tag = DTyAlgTyTag(dtype);
1817 if (tag) {
1818 tag = symbolxref[tag];
1819 DTySetAlgTyTag(dtype, tag);
1820 }
1821 if (PARENTG(tag)) {
1822 /* fix up "parent member" */
1823 SPTR ptag;
1824 DTYPE pdtype;
1825 int pmem;
1826 PARENTP(member, member);
1827 pdtype = DTYPEG(member);
1828 ptag = DTyAlgTyTag(pdtype);
1829 if (ptag > oldsymbolcount) {
1830 DTySetAlgTyTag(pdtype, ptag);
1831 }
1832 pmem = DTyAlgTyMember(pdtype);
1833 if (pmem > oldsymbolcount) {
1834 DTySetFst(pdtype, pmem);
1835 }
1836 } else {
1837 PARENTP(member, 0);
1838 }
1839 break;
1840 case TY_ARRAY:
1841 subtype = DTySeqTyElement(dtype);
1842 subtype = datatypexref[subtype];
1843 if (subtype == 0) {
1844 fprintf(stderr, "ILM file: missing subtype for array datatype %d\n",
1845 d);
1846 ++errors;
1847 }
1848 DTySetFst(dtype, subtype);
1849 ad = AD_DPTR(dtype);
1850 ndim = AD_NUMDIM(ad);
1851 for (i = 0; i < ndim; ++i) {
1852 lower = AD_LWBD(ad, i);
1853 lower = symbolxref[lower];
1854 AD_LWBD(ad, i) = lower;
1855 upper = AD_UPBD(ad, i);
1856 if (upper > 0) {
1857 upper = symbolxref[upper];
1858 AD_UPBD(ad, i) = upper;
1859 }
1860 mlpyr = AD_MLPYR(ad, i);
1861 if (mlpyr > 0) {
1862 mlpyr = symbolxref[mlpyr];
1863 AD_MLPYR(ad, i) = mlpyr;
1864 }
1865 }
1866 zbase = AD_ZBASE(ad);
1867 if (zbase > 0) {
1868 zbase = symbolxref[zbase];
1869 AD_ZBASE(ad) = zbase;
1870 }
1871 numelm = AD_NUMELM(ad);
1872 if (numelm > 0) {
1873 numelm = symbolxref[numelm];
1874 AD_NUMELM(ad) = numelm;
1875 }
1876 break;
1877 case TY_PTR:
1878 subtype = DTySeqTyElement(dtype);
1879 subtype = datatypexref[subtype];
1880 if (subtype == 0) {
1881 fprintf(stderr, "ILM file: missing subtype for pointer datatype %d\n",
1882 d);
1883 ++errors;
1884 }
1885 DTySetFst(dtype, subtype);
1886 break;
1887 case TY_PROC:
1888 subtype = DTyReturnType(dtype);
1889 subtype = datatypexref[subtype];
1890 /* NOTE: subtype may be 0, i.e. DT_NONE */
1891 DTySetFst(dtype, subtype);
1892 iface = DTyInterface(dtype);
1893 if (iface) {
1894 iface = symbolxref[iface];
1895 }
1896 DTySetInterface(dtype, iface);
1897 dpdsc = DTyParamDesc(dtype);
1898 if (dpdsc && iface) {
1899 dpdsc = DPDSCG(iface);
1900 }
1901 DTySetParamDesc(dtype, dpdsc);
1902 fval = DTyFuncVal(dtype);
1903 if (fval) {
1904 fval = symbolxref[fval];
1905 }
1906 DTySetFuncVal(dtype, fval);
1907 default:
1908 break;
1909 }
1910 }
1911 }
1912 } /* fix_datatype */
1913
1914 static SPTR
newsymbol(void)1915 newsymbol(void)
1916 {
1917 SPTR sptr;
1918 int hashid;
1919 int namelen = getnamelen();
1920 char *ch = line + pos;
1921 HASH_ID(hashid, ch, namelen);
1922 ADDSYM(sptr, hashid);
1923 NMPTRP(sptr, putsname(line + pos, namelen));
1924 SYMLKP(sptr, NOSYM);
1925 return sptr;
1926 } /* newsymbol */
1927
1928 static int
newintrinsic(int wantstype)1929 newintrinsic(int wantstype)
1930 {
1931 int namelen, sptr, hashid, first;
1932 char *name;
1933 namelen = getnamelen();
1934 name = line + pos;
1935 name[namelen] = '\0';
1936 HASH_ID(hashid, name, namelen);
1937 first = stb.hashtb[hashid];
1938 for (sptr = first; sptr; sptr = HASHLKG(sptr)) {
1939 if (strcmp(SYMNAME(sptr), name) == 0) {
1940 switch (STYPEG(sptr)) {
1941 case ST_PD:
1942 case ST_INTRIN:
1943 case ST_GENERIC:
1944 return sptr;
1945 default:
1946 break;
1947 }
1948 }
1949 }
1950 fprintf(stderr, "ILM file: can't find intrinsic %s\n", name);
1951 ++errors;
1952 return 0;
1953 } /* newintrinsic */
1954
1955 static char
gethexchar(FILE * file)1956 gethexchar(FILE *file)
1957 {
1958 char c1, c2, val;
1959 c1 = getc(file);
1960 c2 = getc(file);
1961 if (c1 >= '0' && c1 <= '9') {
1962 c1 = c1 - '0';
1963 } else if (c1 >= 'a' && c1 <= 'f') {
1964 c1 = c1 - 'a' + 10;
1965 } else if (c1 >= 'A' && c1 <= 'F') {
1966 c1 = c1 - 'A' + 10;
1967 } else {
1968 c1 = '\0';
1969 }
1970 if (c2 >= '0' && c2 <= '9') {
1971 c2 = c2 - '0';
1972 } else if (c2 >= 'a' && c2 <= 'f') {
1973 c2 = c2 - 'a' + 10;
1974 } else if (c2 >= 'A' && c2 <= 'F') {
1975 c2 = c2 - 'A' + 10;
1976 } else {
1977 c2 = '\0';
1978 }
1979 val = c1 << 4 | c2;
1980 return val;
1981 } /* gethexchar */
1982
1983 #if defined(TARGET_WIN_X86) && defined(PGFTN)
1984 /*
1985 * convert to upper case
1986 */
1987 static void
upcase_name(char * name)1988 upcase_name(char *name)
1989 {
1990 char *p;
1991 int ch;
1992 for (p = name; ch = *p; ++p)
1993 if (ch >= 'a' && ch <= 'z')
1994 *p = ch + ('A' - 'a');
1995 }
1996 #endif
1997
1998 /* Get symbol for sptr from symbolxref or create a new one and add it. */
1999 static SPTR
get_or_create_symbol(SPTR sptr)2000 get_or_create_symbol(SPTR sptr)
2001 {
2002 SPTR newsptr;
2003 if (symbolxref[sptr])
2004 return symbolxref[sptr];
2005 newsptr = newsymbol();
2006 symbolxref[sptr] = newsptr;
2007 return newsptr;
2008 }
2009
2010 static void
read_symbol(void)2011 read_symbol(void)
2012 {
2013 SPTR newsptr;
2014 SYMTYPE stype;
2015 SC_KIND sclass;
2016 DTYPE dtype;
2017 int val[4], namelen, i, dpdsc, inmod;
2018 /* flags: */
2019 int addrtkn, adjustable, afterentry, altname, altreturn, aret, argument,
2020 assigned, assumedshape, assumedsize, autoarray, blank, Cfunc, ccsym, clen,
2021 cmode, common, constant, count, currsub, decl;
2022 SPTR descriptor;
2023 int intentin, texture, device, dll, dllexportmod, enclfunc, end, endlab,
2024 format, func, gsame, gdesc, hccsym, hollerith, init, isdesc, linenum;
2025 SPTR link;
2026 int managed,
2027 member, midnum, mscall, namelist, needmod, nml, noconflict, passbyval,
2028 passbyref, cstructret, optional, origdim, origdum, paramcount, pinned,
2029 plist, pointer, Private, ptrsafe, pure, pdaln, recursive, ref, refs,
2030 returnval, routx = 0, save, sdscs1, sdsccontig, contigattr, sdscsafe, seq,
2031 shared, startlab, startline, stdcall, decorate, cref,
2032 nomixedstrlen, sym, target, param, thread, task, tqaln, typed,
2033 uplevel, vararg, Volatile, fromMod, modcmn;
2034 SPTR parent;
2035 int internref,
2036 Class, denorm, Scope, vtable, iface, vtoff, tbplnk, invobj,
2037 invobjinc, reref, libm, libc, tls, etls;
2038 int reflected, mirrored, create, copyin, resident, acclink, devicecopy,
2039 devicesd, devcopy;
2040 int unlpoly, allocattr, f90pointer, final, finalized, kindparm;
2041 int lenparm, isoctype;
2042 int inmodproc, cudamodule, datacnst, fwdref;
2043 int agoto, parref, parsyms, parsymsct, paruplevel, is_interface;
2044 int typedef_init;
2045 int alldefaultinit;
2046 int tpalloc, procdummy, procdesc, has_opts;
2047 ISZ_T address, size;
2048 SPTR sptr = getSptrVal("symbol");
2049 bool has_alias = false;
2050 char *alias_name;
2051 #if DEBUG
2052 if (sptr > symbolcount) {
2053 fprintf(stderr, "Symbol count was %d, but new symbol number is %d\n",
2054 symbolcount, sptr);
2055 exit(1);
2056 }
2057 #endif
2058 stype = getSymType();
2059 sclass = getSCKind();
2060 dtype = getDtypeVal("dtype");
2061 #if DEBUG
2062 if (dtype > datatypecount) {
2063 fprintf(stderr, "Datatype count was %d, but new datatype is %d\n",
2064 datatypecount, dtype);
2065 interr("upper() FAIL", 0, ERR_Fatal);
2066 }
2067 #endif
2068 if (dtype > 0) {
2069 dtype = datatypexref[dtype]; /* fix data type */
2070 if (dtype == 0) {
2071 fprintf(stderr, "ILM file line %d: missing data type for symbol %d\n",
2072 ilmlinenum, sptr);
2073 ++errors;
2074 }
2075 }
2076 newsptr = SPTR_NULL;
2077 passbyval = 0;
2078 passbyref = 0;
2079 cstructret = 0;
2080 switch (stype) {
2081
2082 case ST_ARRAY:
2083 case ST_STRUCT:
2084 case ST_UNION:
2085 case ST_VAR:
2086 addrtkn = getbit("addrtaken");
2087 argument = getbit("argument"); /* + */
2088 assigned = getbit("assigned");
2089 decl = getbit("decl");
2090 dll = getval("dll");
2091 mscall = getbit("mscall");
2092 cref = getbit("cref");
2093 ccsym = getbit("ccsym");
2094 hccsym = getbit("hccsym");
2095 init = getbit("init");
2096 datacnst = getbit("datacnst");
2097 namelist = getbit("namelist"); /* + */
2098 optional = getbit("optional"); /* + */
2099 pointer = getbit("pointer"); /* + */
2100 Private = getbit("private"); /* + */
2101 pdaln = getval("pdaln"); /* + */
2102 tqaln = getbit("tqaln"); /* + */
2103 ref = getbit("ref");
2104 save = getbit("save");
2105 seq = getbit("seq"); /* + */
2106 target = getbit("target"); /* + */
2107 param = getbit("param");
2108 uplevel = getbit("uplevel");
2109 internref = getbit("internref");
2110 ptrsafe = getbit("ptrsafe");
2111 thread = getbit("thread");
2112 etls = getval("etls");
2113 tls = getbit("tls");
2114 task = getbit("task");
2115 Volatile = getbit("volatile");
2116 address = getval("address");
2117 clen = getval("clen");
2118 common = getval("common");
2119 link = getSptrVal("link");
2120 midnum = getval("midnum");
2121 if (flg.debug && gbl.rutype != RU_BDATA &&
2122 stype == ST_VAR && sclass == SC_CMBLK) {
2123 /* Retrieve debug info for renaming and restricted importing
2124 * of module variables */
2125 has_alias = getbit("has_alias");
2126 if (has_alias) {
2127 const int namelen = getnamelen();
2128 NEW(alias_name, char, namelen + 1);
2129 strncpy(alias_name, line + pos, namelen);
2130 alias_name[namelen] = '\0';
2131 pos += namelen;
2132 }
2133 }
2134 if (sclass == SC_DUMMY) {
2135 origdum = getval("origdummy");
2136 }
2137 origdim = 0;
2138 if (stype == ST_ARRAY) {
2139 adjustable = getbit("adjustable");
2140 afterentry = getbit("afterentry");
2141 assumedshape = getbit("assumedshape"); /* + */
2142 assumedsize = getbit("assumedsize");
2143 autoarray = getbit("autoarray");
2144 noconflict = getbit("noconflict");
2145 sdscs1 = getbit("s1");
2146 isdesc = getbit("isdesc");
2147 sdsccontig = getbit("contig");
2148 origdim = getval("origdim");
2149 descriptor = getSptrVal("descriptor");
2150 }
2151 parref = getbit("parref");
2152 enclfunc = getval("enclfunc");
2153 if (passbyflags) {
2154 passbyval = getbit("passbyval");
2155 passbyref = getbit("passbyref");
2156 }
2157 if (cfuncflags) {
2158 Cfunc = getbit("Cfunc");
2159 altname = getval("altname");
2160 }
2161 contigattr = getbit("contigattr");
2162 if (cudaflags) {
2163 device = getbit("device");
2164 pinned = getbit("pinned");
2165 shared = getbit("shared");
2166 constant = getbit("constant");
2167 texture = getbit("texture");
2168 managed = getbit("managed");
2169 }
2170 intentin = getbit("intentin");
2171
2172 Class = getbit("class");
2173 parent = getSptrVal("parent");
2174
2175 if (stype == ST_VAR) { /* TBD - for polymorphic variable */
2176 descriptor = getSptrVal("descriptor");
2177 }
2178
2179 reref = getbit("reref");
2180
2181 reflected = getbit("reflected");
2182 mirrored = getbit("mirrored");
2183 create = getbit("create");
2184 copyin = getbit("copyin");
2185 resident = getbit("resident");
2186 acclink = getbit("link");
2187 devicecopy = getbit("devicecopy");
2188 devicesd = getbit("devicesd");
2189 devcopy = getval("devcopy");
2190
2191 allocattr = getbit("allocattr");
2192 f90pointer = getbit("f90pointer"); /* will denote the POINTER attribute */
2193 /* but need to remove FE legacy use */
2194 procdesc = getbit("procdescr");
2195 newsptr = get_or_create_symbol(sptr);
2196 if (Class) {
2197 CLASSP(newsptr, Class);
2198 }
2199
2200 if (target) {
2201 TARGETP(newsptr, 1);
2202 }
2203
2204 if (reref) {
2205 REREFP(newsptr, 1);
2206 }
2207
2208 if (stype == ST_VAR) { /* TBD - for polymorphic variable */
2209 SDSCP(newsptr, descriptor);
2210 VARDSCP(newsptr, 1);
2211 }
2212
2213 if (stype == ST_VAR && DTY(dtype) == TY_STRUCT) {
2214 STYPEP(newsptr, ST_STRUCT);
2215 } else {
2216 STYPEP(newsptr, stype);
2217 }
2218 if (Class && stype == ST_ARRAY && isdesc) {
2219 /* put the type that this type descriptor is associated with
2220 * in subtype field. (polymoprhic variable) */
2221 DTYPE dt;
2222 ADSC *ad;
2223 DTySetFst(dtype, parent);
2224
2225 dt = get_array_dtype(1, datatypexref[parent]);
2226 /* get the pointer to the array bounds descriptor */
2227 ad = AD_DPTR(dt);
2228 AD_NUMDIM(ad) = 1;
2229 AD_SDSC(ad) = SPTR_NULL;
2230 }
2231 SCP(newsptr, sclass);
2232 DTYPEP(newsptr, dtype);
2233 DCLDP(newsptr, decl);
2234 #if defined(TARGET_WIN_X86)
2235 if (dll)
2236 DLLP(newsptr, dll);
2237 #endif
2238 DINITP(newsptr, init);
2239 DATACONSTP(newsptr, datacnst);
2240 CCSYMP(newsptr, ccsym | hccsym);
2241 if (sclass == SC_LOCAL) {
2242 SAVEP(newsptr, save | init);
2243 } else {
2244 SAVEP(newsptr, save);
2245 }
2246 REFP(newsptr, ref);
2247 ADDRTKNP(newsptr, addrtkn);
2248 UPLEVELP(newsptr, uplevel);
2249 INTERNREFP(newsptr, internref);
2250 if (internref && STB_UPPER()) {
2251 add_llvm_uplevel_symbol(sptr);
2252 }
2253 PTRSAFEP(newsptr, ptrsafe);
2254 THREADP(newsptr, thread);
2255 #ifdef TASKG
2256 TASKP(newsptr, task);
2257 #endif
2258 VOLP(newsptr, Volatile);
2259 ASSNP(newsptr, assigned);
2260 #ifdef PDALNP
2261 if (pdaln > 0)
2262 PDALNP(newsptr, pdaln);
2263 #endif
2264 #ifdef QALNP
2265 if (pdaln != PDALN_EXPLICIT_0 && pdaln >= 3)
2266 QALNP(newsptr, 1);
2267 #endif
2268 OPTARGP(newsptr, optional);
2269 POINTERP(newsptr, pointer);
2270 SYMLKP(newsptr, link);
2271 SOCPTRP(newsptr, 0);
2272 ADDRESSP(newsptr, address);
2273 PARAMP(newsptr, param);
2274 CONTIGATTRP(newsptr, contigattr);
2275 if (cfuncflags) {
2276 CFUNCP(newsptr, Cfunc);
2277 ALTNAMEP(newsptr, altname);
2278
2279 if (Cfunc) {
2280 /* add C_BIND vars to list of global externs */
2281 SYMLKP(newsptr, gbl.externs);
2282 gbl.externs = newsptr;
2283 }
2284 }
2285
2286 if (sclass == SC_CMBLK) {
2287 if (CFUNCG(newsptr)) {
2288 /* variables visable from C */
2289 SCP(newsptr, SC_EXTERN); /* try this */
2290 } else {
2291
2292 MIDNUMP(newsptr, common);
2293 }
2294 } else {
2295 if (CFUNCG(newsptr)) {
2296 /* variables visable from C */
2297 SCP(newsptr, SC_EXTERN); /* try this */
2298 } else {
2299 MIDNUMP(newsptr, midnum);
2300 }
2301 }
2302 if (sclass == SC_DUMMY) {
2303 ORIGDUMMYP(newsptr, origdum);
2304 }
2305 ORIGDIMP(newsptr, origdim);
2306 if (stype == ST_ARRAY) {
2307 ASSUMSHPP(newsptr, assumedshape);
2308 ASUMSZP(newsptr, assumedsize);
2309 ADJARRP(newsptr, adjustable);
2310 AFTENTP(newsptr, afterentry);
2311 AUTOBJP(newsptr, autoarray);
2312 DESCARRAYP(newsptr, isdesc);
2313 IS_PROC_DESCRP(newsptr, procdesc);
2314 if (isdesc) {
2315 SDSCS1P(newsptr, sdscs1);
2316 SDSCCONTIGP(newsptr, sdsccontig);
2317 }
2318 SDSCP(newsptr, descriptor);
2319 /* fill in SDSC field of datatype, if necessary */
2320 if (descriptor && (pointer || assumedshape) && !XBIT(52, 4)) {
2321 AD_SDSC(AD_DPTR(dtype)) = descriptor;
2322 }
2323 }
2324 if (clen)
2325 CLENP(newsptr, clen);
2326 if (stype == ST_ARRAY && sclass == SC_BASED) {
2327 /* set the NOCONFLICT bit? */
2328 if (noconflict) {
2329 NOCONFLICTP(newsptr, 1);
2330 }
2331 }
2332 if (sclass != SC_BASED && !pointer && !target && !addrtkn) {
2333 /* set the NOCONFLICT flag, meaning no pointers can conflict with it */
2334 NOCONFLICTP(newsptr, 1);
2335 }
2336 if (SCG(newsptr) == SC_PRIVATE && REFG(newsptr)) {
2337 /* frontend has allocated this private variable - need to
2338 * adjust its offset
2339 */
2340 fix_private_sym(newsptr);
2341 }
2342 if (PARAMG(newsptr) || (DINITG(newsptr) && CCSYMG(newsptr))) {
2343 init_list_count++;
2344 }
2345 PARREFP(newsptr, parref);
2346 ENCLFUNCP(newsptr, enclfunc);
2347 if (XBIT(119, 0x2000000) && enclfunc)
2348 LIBSYMP(newsptr, LIBSYMG(symbolxref[enclfunc]));
2349 if (passbyflags) {
2350 PASSBYVALP(newsptr, passbyval);
2351 PASSBYREFP(newsptr, passbyref);
2352 if (optional)
2353 PASSBYVALP(newsptr, 0);
2354 }
2355 if (cudaflags) {
2356 if (constant)
2357 device = 1;
2358 DEVICEP(newsptr, device);
2359 PINNEDP(newsptr, pinned);
2360 SHAREDP(newsptr, shared);
2361 CONSTANTP(newsptr, constant);
2362 TEXTUREP(newsptr, texture);
2363 MANAGEDP(newsptr, managed);
2364 ACCCREATEP(newsptr, create);
2365 ACCCOPYINP(newsptr, copyin);
2366 ACCRESIDENTP(newsptr, resident);
2367 ACCLINKP(newsptr, acclink);
2368 }
2369 INTENTINP(newsptr, intentin);
2370 ALLOCATTRP(newsptr, allocattr);
2371 if (flg.debug && has_alias)
2372 save_modvar_alias(newsptr, alias_name);
2373 break;
2374
2375 case ST_CMBLK:
2376 altname = getval("altname");
2377 ccsym = getbit("ccsym");
2378 Cfunc = getbit("Cfunc");
2379 dll = getval("dll");
2380 init = getbit("init");
2381 member = getval("member");
2382 mscall = getbit("mscall");
2383 pdaln = getval("pdaln"); /* + */
2384 save = getbit("save");
2385 size = getval("size");
2386 stdcall = getbit("stdcall");
2387 thread = getbit("thread");
2388 etls = getval("etls");
2389 tls = getbit("tls");
2390 Volatile = getbit("volatile");
2391 fromMod = getbit("frommod");
2392 modcmn = getbit("modcmn");
2393 Scope = getval("scope");
2394 if (cudaflags) {
2395 device = getbit("device");
2396 constant = getbit("constant");
2397 create = getbit("create");
2398 copyin = getbit("copyin");
2399 resident = getbit("resident");
2400 acclink = getbit("link");
2401 }
2402
2403 newsptr = get_or_create_symbol(sptr);
2404
2405 STYPEP(newsptr, stype);
2406 SCP(newsptr, sclass);
2407 DTYPEP(newsptr, dtype);
2408
2409 ALTNAMEP(newsptr, altname);
2410 CCSYMP(newsptr, ccsym);
2411 CFUNCP(newsptr, Cfunc);
2412 #if defined(TARGET_WIN_X86)
2413 if (dll)
2414 DLLP(newsptr, dll);
2415 #endif
2416 DINITP(newsptr, init);
2417 MSCALLP(newsptr, mscall);
2418 #ifdef PDALNP
2419 if (pdaln > 0)
2420 PDALNP(newsptr, pdaln);
2421 #endif
2422 #ifdef QALNP
2423 if (pdaln != PDALN_EXPLICIT_0 && pdaln >= 3)
2424 QALNP(newsptr, 1);
2425 #endif
2426 SAVEP(newsptr, save);
2427 STDCALLP(newsptr, stdcall);
2428 THREADP(newsptr, thread);
2429 VOLP(newsptr, Volatile);
2430 FROMMODP(newsptr, fromMod);
2431 MODCMNP(newsptr, modcmn);
2432 SCOPEP(newsptr, Scope);
2433
2434 CMEMFP(newsptr, member);
2435 SIZEP(newsptr, size);
2436 if (cudaflags) {
2437 DEVICEP(newsptr, device);
2438 CONSTANTP(newsptr, constant);
2439 ACCCREATEP(newsptr, create);
2440 ACCCOPYINP(newsptr, copyin);
2441 ACCRESIDENTP(newsptr, resident);
2442 ACCLINKP(newsptr, acclink);
2443 }
2444
2445 SYMLKP(newsptr, gbl.cmblks);
2446 gbl.cmblks = newsptr;
2447 if (modcmn && !fromMod) {
2448 /* Indicate that the compiler-created module common is being
2449 * defined in this subprogram.
2450 */
2451 DEFDP(newsptr, 1);
2452 }
2453 break;
2454
2455 case ST_CONST:
2456 hollerith = getbit("hollerith");
2457 switch (DTY(dtype)) {
2458 case TY_HOLL: /* symbol table ptr of char constant */
2459 val[0] = getval("sym"); /* to be fixed */
2460 /* always add a new symbol; don't use getcon()
2461 * because the symbol pointers have not been resolved yet */
2462 newsptr = newsymbol();
2463 CONVAL1P(newsptr, val[0]);
2464 ACONOFFP(newsptr, 0);
2465 STYPEP(newsptr, ST_CONST);
2466 DTYPEP(newsptr, dtype);
2467 break;
2468 case TY_DWORD:
2469 case TY_INT8:
2470 case TY_LOG8:
2471 case TY_DBLE:
2472 case TY_CMPLX:
2473 val[0] = gethex();
2474 val[1] = gethex();
2475 newsptr = getcon(val, dtype);
2476 break;
2477 case TY_INT:
2478 case TY_REAL:
2479 case TY_WORD:
2480 case TY_LOG:
2481 val[0] = 0;
2482 val[1] = gethex();
2483 newsptr = getcon(val, dtype);
2484 break;
2485 case TY_BINT:
2486 case TY_SINT:
2487 val[0] = 0;
2488 val[1] = gethex();
2489 dtype = DT_INT;
2490 newsptr = getcon(val, dtype);
2491 break;
2492 case TY_BLOG:
2493 case TY_SLOG:
2494 val[0] = 0;
2495 val[1] = gethex();
2496 dtype = DT_LOG;
2497 newsptr = getcon(val, dtype);
2498 break;
2499 case TY_DCMPLX:
2500 val[0] = getval("sym");
2501 val[1] = getval("sym");
2502 /* always add a new symbol; don't use getcon()
2503 * because the symbol pointers have not been resolved yet */
2504 newsptr = newsymbol();
2505 CONVAL1P(newsptr, val[0]);
2506 CONVAL2P(newsptr, val[1]);
2507 STYPEP(newsptr, ST_CONST);
2508 DTYPEP(newsptr, dtype);
2509 break;
2510 case TY_QUAD:
2511 val[0] = gethex();
2512 val[1] = gethex();
2513 val[2] = gethex();
2514 val[3] = gethex();
2515 newsptr = getcon(val, dtype);
2516 break;
2517 case TY_PTR:
2518 val[0] = getval("sym");
2519 address = getval("offset");
2520 /* always add a new symbol; don't use getcon()
2521 * because the symbol pointers have not been resolved yet */
2522 newsptr = newsymbol();
2523 CONVAL1P(newsptr, val[0]);
2524 ACONOFFP(newsptr, address);
2525 STYPEP(newsptr, ST_CONST);
2526 DTYPEP(newsptr, dtype);
2527 break;
2528 case TY_CHAR:
2529 case TY_NCHAR:
2530 namelen = getnamelen();
2531 /* read the next 'namelen' characters */
2532 if (namelen > 0) {
2533 char dash;
2534 /* get the dash */
2535 if (STB_UPPER())
2536 dash = getc(gbl.stbfil);
2537 else
2538 dash = getc(gbl.srcfil);
2539 if (namelen >= linelen) {
2540 linelen = namelen * 2;
2541 line = (char*) realloc(line, linelen);
2542 }
2543 if (dash == '-') {
2544 for (i = 0; i <= namelen; ++i) {
2545 if (STB_UPPER())
2546 line[i] = getc(gbl.stbfil);
2547 else
2548 line[i] = getc(gbl.srcfil);
2549 }
2550 } else {
2551 for (i = 0; i < namelen; ++i) {
2552 if (STB_UPPER())
2553 line[i] = gethexchar(gbl.stbfil);
2554 else
2555 line[i] = gethexchar(gbl.srcfil);
2556 }
2557 if (STB_UPPER())
2558 line[i] = getc(gbl.stbfil);
2559 else
2560 line[i] = getc(gbl.srcfil);
2561 }
2562 ++ilmlinenum;
2563 }
2564 newsptr = getstring(line, namelen);
2565 if (hollerith)
2566 HOLLP(newsptr, 1);
2567 if (DTY(dtype) == TY_NCHAR) {
2568 val[0] = newsptr;
2569 val[1] = val[2] = val[3] = 0;
2570 newsptr = getcon(val, dtype);
2571 }
2572 break;
2573 default:
2574 fprintf(stderr,
2575 "ILM file line %d: unknown constant type %d for old symbol %d\n",
2576 ilmlinenum, dtype, sptr);
2577 ++errors;
2578 break;
2579 }
2580 SYMLKP(newsptr, SPTR_NULL);
2581 symbolxref[sptr] = newsptr;
2582 break;
2583
2584 case ST_ENTRY:
2585 currsub = getbit("currsub");
2586 adjustable = getbit("adjustable");
2587 afterentry = getbit("afterentry");
2588 altname = getval("altname");
2589 Cfunc = getbit("Cfunc");
2590 decl = getbit("decl");
2591 dll = getval("dll");
2592 cmode = getval("cmode");
2593 end = getval("end"); /* + */
2594 inmod = getval("inmodule");
2595 linenum = getval("line");
2596 mscall = getbit("mscall");
2597 pure = getbit("pure"); /* + */
2598 recursive = getbit("recursive"); /* + */
2599 returnval = getval("returnval");
2600 if (passbyflags) {
2601 passbyval = getbit("passbyval");
2602 passbyref = getbit("passbyref");
2603 }
2604 stdcall = getbit("stdcall");
2605 decorate = getbit("decorate");
2606 cref = getbit("cref");
2607 nomixedstrlen = getbit("nomixedstrlen");
2608 cudaemu = getval("cudaemu");
2609 routx = getval("rout");
2610 paramcount = getval("paramcount");
2611 altreturn = getval("altreturn");
2612 vtoff = getval("vtoff");
2613 invobj = getval("invobj");
2614 invobjinc = getbit("invobjinc");
2615 Class = getbit("class");
2616 denorm = getbit("denorm");
2617 aret = getbit("aret");
2618 vararg = getbit("vararg");
2619 has_opts = getbit("has_opts");
2620
2621 if (altreturn) {
2622 gbl.arets = true;
2623 }
2624 if (denorm) {
2625 gbl.denorm = true;
2626 }
2627
2628 if (paramcount == 0) {
2629 dpdsc = 0;
2630 } else {
2631 dpdsc = aux.dpdsc_avl;
2632 aux.dpdsc_avl += paramcount;
2633 NEED(aux.dpdsc_avl, aux.dpdsc_base, int, aux.dpdsc_size,
2634 aux.dpdsc_size + paramcount + 100);
2635
2636 for (i = 0; i < paramcount; ++i) {
2637 aux.dpdsc_base[dpdsc + i] = getnum();
2638 }
2639 }
2640 newsptr = get_or_create_symbol(sptr);
2641
2642 STYPEP(newsptr, stype);
2643 SCP(newsptr, sclass);
2644 CFUNCP(newsptr, Cfunc);
2645 DTYPEP(newsptr, dtype);
2646 DCLDP(newsptr, decl);
2647 #if defined(TARGET_WIN_X86)
2648 if (dll)
2649 DLLP(newsptr, dll);
2650 #endif
2651 MSCALLP(newsptr, mscall);
2652 if (passbyflags) {
2653 PASSBYVALP(newsptr, passbyval);
2654 PASSBYREFP(newsptr, passbyref);
2655 }
2656 #ifdef CUDAP
2657 CUDAP(newsptr, cmode);
2658 #endif
2659 STDCALLP(newsptr, stdcall);
2660 DECORATEP(newsptr, decorate);
2661 CREFP(newsptr, cref);
2662 NOMIXEDSTRLENP(newsptr, nomixedstrlen);
2663 COPYPRMSP(newsptr, 0);
2664 ADJARRP(newsptr, adjustable);
2665 AFTENTP(newsptr, afterentry);
2666 ADDRESSP(newsptr, 0);
2667 ALTNAMEP(newsptr, altname);
2668 DPDSCP(newsptr, dpdsc);
2669 PARAMCTP(newsptr, paramcount);
2670 FUNCLINEP(newsptr, linenum);
2671 FVALP(newsptr, returnval);
2672 INMODULEP(newsptr, inmod);
2673 /* add to list of gbl.entries */
2674 if (currsub) {
2675 gbl.currsub = newsptr;
2676 /* don't add if this is a block data */
2677 if (gbl.rutype != RU_BDATA) {
2678 /* add to front of list */
2679 SYMLKP(newsptr, (SPTR) gbl.entries);
2680 gbl.entries = newsptr;
2681 }
2682 if (recursive)
2683 flg.recursive = true;
2684 } else if (gbl.entries <= NOSYM) {
2685 SYMLKP(newsptr, NOSYM);
2686 gbl.entries = newsptr;
2687 } else {
2688 int s;
2689 for (s = gbl.entries; SYMLKG(s) > NOSYM; s = SYMLKG(s))
2690 ;
2691 SYMLKP(s, newsptr);
2692 SYMLKP(newsptr, NOSYM);
2693 }
2694 VTOFFP(newsptr, vtoff);
2695 INVOBJP(newsptr, invobj);
2696 INVOBJINCP(newsptr, invobjinc);
2697 if (invobj) {
2698 CLASSP(newsptr, Class);
2699 }
2700 HAS_OPT_ARGSP(newsptr, has_opts);
2701 break;
2702
2703 case ST_LABEL:
2704 ccsym = getbit("ccsym");
2705 assigned = getbit("assigned"); /* + */
2706 format = getbit("format");
2707 Volatile = getbit("volatile");
2708 refs = getval("refs");
2709 agoto = getval("agoto");
2710
2711 newsptr = get_or_create_symbol(sptr);
2712
2713 STYPEP(newsptr, stype);
2714 SCP(newsptr, sclass);
2715 DTYPEP(newsptr, dtype);
2716
2717 CCSYMP(newsptr, ccsym);
2718 RFCNTP(newsptr, refs);
2719 ADDRESSP(newsptr, 0);
2720 FMTPTP(newsptr, format);
2721 VOLP(newsptr, Volatile);
2722 if (!gbl.stbfil && agoto) {
2723 if (agotosz == 0) {
2724 agotosz = 64;
2725 NEW(agototab, int, agotosz);
2726 agotomax = 0;
2727 }
2728 NEED(agoto, agototab, int, agotosz, agoto + 32);
2729 agototab[agoto - 1] = newsptr;
2730 if (agoto > agotomax)
2731 agotomax = agoto;
2732 }
2733 break;
2734
2735 case ST_MEMBER:
2736 ccsym = getbit("ccsym");
2737 sdscs1 = getbit("s1");
2738 isdesc = getbit("isdesc");
2739 sdsccontig = getbit("contig");
2740 contigattr = getbit("contigattr");
2741 pointer = getbit("pointer");
2742 address = getval("address");
2743 descriptor = getSptrVal("descriptor");
2744 noconflict = getbit("noconflict");
2745 link = getSptrVal("link");
2746 tbplnk = getval("tbplnk");
2747 vtable = getval("vtable");
2748 iface = getval("iface");
2749 Class = getbit("class");
2750 mscall = getbit("mscall");
2751 cref = getbit("cref");
2752 allocattr = getbit("allocattr");
2753 f90pointer = getbit("f90pointer"); /* will denote the POINTER attribute */
2754 /* but need to remove FE legacy use */
2755 final = getval("final");
2756 finalized = getbit("finalized");
2757 kindparm = getbit("kindparm");
2758 lenparm = getbit("lenparm");
2759 tpalloc = getbit("tpalloc");
2760
2761 newsptr = get_or_create_symbol(sptr);
2762
2763 STYPEP(newsptr, stype);
2764 SCP(newsptr, sclass);
2765 DTYPEP(newsptr, dtype);
2766 SDSCP(newsptr, descriptor);
2767 /* fill in SDSC field of datatype, if necessary */
2768 if (descriptor && pointer && !XBIT(52, 4) &&
2769 ((!Class && !finalized && dtype != DT_DEFERCHAR &&
2770 dtype != DT_DEFERNCHAR) ||
2771 DTY(dtype) == TY_ARRAY)) {
2772 AD_SDSC(AD_DPTR(dtype)) = descriptor;
2773 }
2774 /* set the NOCONFLICT bit? */
2775 if (noconflict) {
2776 NOCONFLICTP(newsptr, 1);
2777 }
2778
2779 CCSYMP(newsptr, ccsym);
2780 ADDRESSP(newsptr, address);
2781 SYMLKP(newsptr, link);
2782 POINTERP(newsptr, pointer);
2783 DESCARRAYP(newsptr, isdesc);
2784 if (isdesc) {
2785 SDSCS1P(newsptr, sdscs1);
2786 SDSCCONTIGP(newsptr, sdsccontig);
2787 }
2788 VARIANTP(newsptr, NOSYM);
2789 PSMEMP(newsptr, newsptr);
2790 VTABLEP(newsptr, vtable);
2791 IFACEP(newsptr, iface);
2792 TBPLNKP(newsptr, tbplnk);
2793 CLASSP(newsptr, Class);
2794 ALLOCATTRP(newsptr, allocattr);
2795 CONTIGATTRP(newsptr, contigattr);
2796 FINALP(newsptr, final);
2797 FINALIZEDP(newsptr, finalized);
2798 KINDPARMP(newsptr, kindparm);
2799 LENPARMP(newsptr, lenparm);
2800 TPALLOCP(newsptr, tpalloc);
2801 break;
2802
2803 case ST_NML:
2804 linenum = getval("line");
2805 ref = getbit("ref");
2806 plist = getval("plist");
2807 count = getval("count");
2808
2809 nml = aux.nml_avl;
2810 aux.nml_avl += count;
2811 NEED(aux.nml_avl, aux.nml_base, NMLDSC, aux.nml_size,
2812 aux.nml_size + count + 100);
2813
2814 for (i = 0; i < count; ++i) {
2815 NML_SPTR(nml + i) = getnum();
2816 NML_NEXT(nml + i) = nml + i + 1;
2817 NML_LINENO(nml + i) = linenum;
2818 }
2819 NML_NEXT(nml + count - 1) = 0;
2820
2821 newsptr = get_or_create_symbol(sptr);
2822
2823 STYPEP(newsptr, stype);
2824 SCP(newsptr, sclass);
2825 DTYPEP(newsptr, dtype);
2826
2827 REFP(newsptr, ref);
2828 ADDRESSP(newsptr, plist);
2829 CMEMFP(newsptr, nml);
2830 CMEMLP(newsptr, nml + count - 1);
2831
2832 SYMLKP(newsptr, sem.nml);
2833 sem.nml = newsptr;
2834 break;
2835
2836 case ST_PARAM:
2837 decl = getbit("decl"); /* + */
2838 Private = getbit("private"); /* + */
2839 ref = getbit("ref");
2840 if (TY_ISWORD(DTY(dtype))) {
2841 val[0] = getval("val");
2842 } else {
2843 val[0] = getval("sym");
2844 }
2845
2846 newsptr = get_or_create_symbol(sptr);
2847
2848 STYPEP(newsptr, stype);
2849 SCP(newsptr, sclass);
2850 DTYPEP(newsptr, dtype);
2851
2852 REFP(newsptr, ref);
2853 CONVAL1P(newsptr, val[0]);
2854 break;
2855
2856 case ST_PLIST:
2857 ccsym = getbit("ccsym");
2858 init = getbit("init");
2859 ref = getbit("ref");
2860 uplevel = getbit("uplevel");
2861 internref = getbit("internref");
2862 parref = getbit("parref");
2863 count = getval("count");
2864 etls = getval("etls");
2865 tls = getbit("tls");
2866
2867 newsptr = get_or_create_symbol(sptr);
2868
2869 STYPEP(newsptr, stype);
2870 SCP(newsptr, sclass);
2871 DTYPEP(newsptr, dtype);
2872
2873 DINITP(newsptr, init);
2874 CCSYMP(newsptr, ccsym);
2875 REFP(newsptr, ref);
2876 UPLEVELP(newsptr, uplevel);
2877 INTERNREFP(newsptr, internref);
2878 if (internref && STB_UPPER()) {
2879 add_llvm_uplevel_symbol(sptr);
2880 }
2881 PARREFP(newsptr, parref);
2882 PLLENP(newsptr, count);
2883 break;
2884
2885 case ST_PROC:
2886 altname = getval("altname");
2887 ccsym = getbit("ccsym");
2888 decl = getbit("decl");
2889 dll = getval("dll");
2890 dllexportmod = getbit("dllexportmod");
2891 cmode = getval("cmode");
2892 func = getbit("func");
2893 inmod = getval("inmodule");
2894 mscall = getbit("mscall");
2895 needmod = getbit("needmod");
2896 pure = getbit("pure");
2897 ref = getbit("ref");
2898 if (passbyflags) {
2899 passbyval = getbit("passbyval");
2900 passbyref = getbit("passbyref");
2901 }
2902 cstructret = getbit("cstructret");
2903 sdscsafe = getbit("sdscsafe");
2904 stdcall = getbit("stdcall");
2905 decorate = getbit("decorate");
2906 cref = getbit("cref");
2907 nomixedstrlen = getbit("nomixedstrlen");
2908 typed = getbit("typed");
2909 recursive = getbit("recursive");
2910 returnval = getval("returnval");
2911 Cfunc = getbit("Cfunc");
2912 uplevel = getbit("uplevel");
2913 internref = getbit("internref");
2914 routx = getval("rout");
2915 paramcount = getval("paramcount");
2916 vtoff = getval("vtoff");
2917 invobj = getval("invobj");
2918 invobjinc = getbit("invobjinc");
2919 Class = getbit("class");
2920 libm = getbit("mlib");
2921 libc = getbit("clib");
2922 inmodproc = getbit("inmodproc");
2923 cudamodule = getbit("cudamodule");
2924 fwdref = getbit("fwdref");
2925 aret = getbit("aret");
2926 vararg = getbit("vararg");
2927 has_opts = getbit("has_opts");
2928 parref = getbit("parref");
2929 is_interface = getbit("is_interface");
2930 descriptor = (sclass == SC_DUMMY) ? getSptrVal("descriptor") : SPTR_NULL;
2931
2932 if (paramcount == 0) {
2933 dpdsc = 0;
2934 } else {
2935 dpdsc = aux.dpdsc_avl;
2936 aux.dpdsc_avl += paramcount;
2937 NEED(aux.dpdsc_avl, aux.dpdsc_base, int, aux.dpdsc_size,
2938 aux.dpdsc_size + paramcount + 100);
2939
2940 for (i = 0; i < paramcount; ++i) {
2941 aux.dpdsc_base[dpdsc + i] = getnum();
2942 }
2943 }
2944
2945 newsptr = get_or_create_symbol(sptr);
2946 STYPEP(newsptr, stype);
2947 SCP(newsptr, sclass);
2948 DTYPEP(newsptr, dtype);
2949
2950 ALTNAMEP(newsptr, altname);
2951 CCSYMP(newsptr, ccsym);
2952 DCLDP(newsptr, decl);
2953 #if defined(TARGET_WIN_X86)
2954 if (dll)
2955 DLLP(newsptr, dll);
2956 #endif
2957 #ifdef CUDAP
2958 CUDAP(newsptr, cmode);
2959 #endif
2960 FUNCP(newsptr, func);
2961 INMODULEP(newsptr, inmod);
2962 MSCALLP(newsptr, mscall);
2963 NEEDMODP(newsptr, needmod);
2964 PUREP(newsptr, pure);
2965 REFP(newsptr, ref);
2966 REDUCP(newsptr, 0);
2967 PASSBYVALP(newsptr, passbyval);
2968 PASSBYREFP(newsptr, passbyref);
2969 CSTRUCTRETP(newsptr, cstructret);
2970 #ifdef SDSCSAFEP
2971 SDSCSAFEP(newsptr, sdscsafe);
2972 #endif
2973 STDCALLP(newsptr, stdcall);
2974 DECORATEP(newsptr, decorate);
2975 CREFP(newsptr, cref);
2976 NOMIXEDSTRLENP(newsptr, nomixedstrlen);
2977 CFUNCP(newsptr, Cfunc);
2978 UPLEVELP(newsptr, uplevel);
2979 INTERNREFP(newsptr, internref);
2980 DPDSCP(newsptr, dpdsc);
2981 PARAMCTP(newsptr, paramcount);
2982 FVALP(newsptr, returnval);
2983 if (internref && STB_UPPER()) {
2984 add_llvm_uplevel_symbol(sptr);
2985 }
2986 LIBMP(newsptr, libm);
2987 LIBCP(newsptr, libc);
2988 #ifdef CUDAMODULEP
2989 CUDAMODULEP(newsptr, cudamodule);
2990 #endif
2991 FWDREFP(newsptr, fwdref);
2992 TYPDP(newsptr, needmod && typed);
2993
2994 if (XBIT(119, 0x2000000)) {
2995 // Set LIBSYM for -Msecond_underscore processing.
2996 char *s = SYMNAME(newsptr);
2997 if (needmod) {
2998 switch (*s) {
2999 case 'a':
3000 if (strncmp(s, "accel_lib", 9) == 0)
3001 LIBSYMP(newsptr, true);
3002 break;
3003 case 'i':
3004 if (strncmp(s, "ieee_arithmetic", 15) == 0 ||
3005 strncmp(s, "ieee_exceptions", 15) == 0 ||
3006 strncmp(s, "ieee_features", 13) == 0 ||
3007 strncmp(s, "iso_c_binding", 13) == 0 ||
3008 strncmp(s, "iso_fortran_env", 15) == 0)
3009 LIBSYMP(newsptr, true);
3010 break;
3011 case 'o':
3012 if (strncmp(s, "omp_lib", 7) == 0)
3013 LIBSYMP(newsptr, true);
3014 break;
3015 case 'p':
3016 if (strncmp(s, "pgi_acc_common", 14) == 0)
3017 LIBSYMP(newsptr, true);
3018 break;
3019 }
3020 } else if (inmod) {
3021 LIBSYMP(newsptr, LIBSYMG(symbolxref[inmod]));
3022 } else if (strncmp(s, "omp_", 4) == 0) {
3023 // This code should execute when OpenMP routines are used without
3024 // 'use omp_lib', and should typically set LIBSYM.
3025 static const char *omp_name[] = {
3026 "destroy_lock", "destroy_nest_lock",
3027 "get_active_level", "get_ancestor_thread_num",
3028 "get_cancellation", "get_default_device",
3029 "get_dynamic", "get_initial_device",
3030 "get_level", "get_max_active_levels",
3031 "get_max_task_priority", "get_max_threads",
3032 "get_nested", "get_num_devices",
3033 "get_num_places", "get_num_procs",
3034 "get_num_teams", "get_num_threads",
3035 "get_partition_num_places", "get_partition_place_nums",
3036 "get_place_num", "get_place_num_procs",
3037 "get_place_proc_ids", "get_proc_bind",
3038 "get_schedule", "get_team_num",
3039 "get_team_size", "get_thread_limit",
3040 "get_thread_num", "get_wtick",
3041 "get_wtime", "in_parallel",
3042 "init_lock", "init_nest_lock",
3043 "init_nest_lock_with_hint", "is_initial_device",
3044 "set_default_device", "set_dynamic",
3045 "set_lock", "set_max_active_levels",
3046 "set_nest_lock", "set_nested",
3047 "set_num_threads", "set_schedule",
3048 "test_lock", "test_nest_lock",
3049 "unset_lock", "unset_nest_lock",
3050 };
3051 int c, l, m, u;
3052 s += 4;
3053 for (l=0, u=sizeof(omp_name)/sizeof(char*)-1, m=u/2; l<=u; m=(l+u)/2) {
3054 c = strcmp(s, omp_name[m]);
3055 if (c == 0) {
3056 LIBSYMP(newsptr, true);
3057 break;
3058 }
3059 if (c < 0)
3060 u = m - 1;
3061 else
3062 l = m + 1;
3063 }
3064 }
3065 }
3066
3067 if (sclass != SC_DUMMY && sptr != gbl.outersub && !Class && !inmodproc) {
3068 /* add to list of gbl.externs. gbl.externs may contain
3069 * SC_STATIC routines, e.g., internal procedures.
3070 * If unified.c creates multiple versions of the internal
3071 * procedure, it needs to see the internal procedure on
3072 * the gbl.externs list so that the selection is done in the
3073 * host. If class is set, then this is an internal ST_PROC
3074 * used in F2003 type bound procedures. Do not add these to
3075 * the extern list since they're ultimately not referenced. We
3076 * also do not add these to the extern list if they're used as
3077 * a module procedure or part of a generic interface.
3078 */
3079 SYMLKP(newsptr, gbl.externs);
3080 gbl.externs = newsptr;
3081 }
3082 #if defined(TARGET_WIN_X86)
3083 if (dllexportmod) {
3084 /*
3085 * dllexport of a normal ST_PROC is illegal; however, it
3086 * could represent a MODULE whose dllexport only occurs within
3087 * a contained procedure.
3088 */
3089 dllexport_mod(newsptr);
3090 }
3091 #endif
3092 VTOFFP(newsptr, vtoff);
3093 INVOBJP(newsptr, invobj);
3094 INVOBJINCP(newsptr, invobjinc);
3095 if (invobj) {
3096 CLASSP(newsptr, Class);
3097 }
3098 VARARGP(newsptr, vararg);
3099 PARREFP(newsptr, parref);
3100 IS_INTERFACEP(newsptr, is_interface);
3101 SDSCP(newsptr, descriptor);
3102 HAS_OPT_ARGSP(newsptr, has_opts);
3103 break;
3104
3105 case ST_GENERIC:
3106 gsame = getval("gsame");
3107 count = getval("count");
3108 if (count < 0)
3109 goto Handle_as_Intrinsic;
3110 if (count == 0) {
3111 gdesc = 0;
3112 } else {
3113 gdesc = aux.symi_avl;
3114 aux.symi_avl += count;
3115 NEED(aux.symi_avl, aux.symi_base, SYMI, aux.symi_size,
3116 aux.symi_size + count + 100);
3117 for (i = 0; i < count; ++i) {
3118 SYMI_SPTR(gdesc + i) = getnum();
3119 SYMI_NEXT(gdesc + i) = gdesc + i + 1;
3120 }
3121 SYMI_NEXT(gdesc + count - 1) = 0;
3122 }
3123 newsptr = get_or_create_symbol(sptr);
3124
3125 STYPEP(newsptr, stype);
3126 SCP(newsptr, sclass);
3127 DTYPEP(newsptr, dtype);
3128
3129 if (count >= 0) {
3130 GSAMEP(newsptr, gsame);
3131 GNDSCP(newsptr, gdesc);
3132 GNCNTP(newsptr, count);
3133 }
3134 break;
3135
3136 case ST_PD:
3137 case ST_INTRIN:
3138 Handle_as_Intrinsic:
3139 /* exported as an intrinsic, generic, or predeclared function.
3140 * actually this symbol should be replaced by the fortran name
3141 * of a function that does the same work; the only time the symbol
3142 * gets used is for certain intrinsic/predeclared calls or when
3143 * the function appears in a procedure argument list */
3144 i = newintrinsic(stype);
3145 if (i) {
3146 /* get the function name to use */
3147 if (STYPEG(i) == ST_GENERIC) {
3148 int gnr = i;
3149 if (GSAMEG(i) == 0) {
3150 fprintf(stderr, "ILM file: generic %s not allowed as argument\n",
3151 SYMNAME(i));
3152 ++errors;
3153 }
3154 i = GSAMEG(i); /* function to use if same name */
3155 if (ARGTYPG(i) == DT_INT) {
3156 if (!flg.i4)
3157 i = GSINTG(gnr);
3158 else if (XBIT(124, 0x10))
3159 i = GINT8G(gnr);
3160 } else if (XBIT(124, 0x8)) {
3161 if (ARGTYPG(i) == DT_REAL)
3162 i = GDBLEG(gnr);
3163 else if (ARGTYPG(i) == DT_CMPLX)
3164 i = GDCMPLXG(gnr);
3165 }
3166 }
3167 }
3168 if (i) {
3169 int name = PNMPTRG(i);
3170 int cr_size = 0;
3171 char *actualname;
3172 if (name == 0) {
3173 fprintf(stderr, "ILM file: intrinsic %s not allowed as argument\n",
3174 SYMNAME(i));
3175 ++errors;
3176 } else {
3177 actualname = local_sname(stb.n_base + name);
3178 #ifdef CREFP
3179 #ifdef TARGET_WIN_X8664
3180 /* Need to add trailing underscore because can't do it in assem.c */
3181 if (WINNT_CREF && !WINNT_NOMIXEDSTRLEN) {
3182 strcat(actualname, "_m");
3183 cr_size = 2; /* size of "_m" */
3184 }
3185 if (WINNT_CREF) {
3186 strcat(actualname, "_");
3187 cr_size += 1; /* size of "_" */
3188 }
3189 #endif
3190 #endif
3191
3192 newsptr = getsym(actualname, strlen(stb.n_base + name) + cr_size);
3193 newsptr = declref(newsptr, ST_PROC, 'r');
3194
3195 symbolxref[sptr] = newsptr;
3196
3197 DTYPEP(newsptr, INTTYPG(i));
3198 SCP(newsptr, SC_EXTERN);
3199 if (XBIT(119, 0x2000000))
3200 LIBSYMP(newsptr, strncmp(SYMNAME(newsptr), "ftn_", 4) == 0);
3201 SYMLKP(newsptr, gbl.externs);
3202 gbl.externs = newsptr;
3203 if (WINNT_CALL)
3204 MSCALLP(newsptr, 1);
3205 #ifdef CREFP
3206 if (WINNT_CREF)
3207 CCSYMP(newsptr, 1);
3208 #endif
3209 }
3210 }
3211 break;
3212
3213 case ST_STAG:
3214 case ST_TYPEDEF:
3215 if (stype == ST_TYPEDEF) {
3216 /* ST_TYPEDEF */
3217 fromMod = getbit("frommod");
3218 parent = getSptrVal("parent");
3219 descriptor = getSptrVal("descriptor");
3220 Class = getbit("class");
3221 alldefaultinit = getbit("alldefaultinit");
3222 unlpoly = getbit("unlpoly");
3223 isoctype = getbit("isoctype");
3224 typedef_init = getval("typedef_init");
3225 newsptr = get_or_create_symbol(sptr);
3226 } else {
3227 /* ST_STAG */
3228 fromMod = 0;
3229 parent = SPTR_NULL;
3230 Class = 0;
3231 typedef_init = 0;
3232 newsptr = get_or_create_symbol(sptr);
3233 }
3234 STYPEP(newsptr, stype);
3235 SCP(newsptr, sclass);
3236 DTYPEP(newsptr, dtype);
3237 FROMMODP(newsptr, fromMod);
3238 PARENTP(newsptr, parent);
3239 SDSCP(newsptr, descriptor);
3240 CLASSP(newsptr, Class);
3241 ALLDEFAULTINITP(newsptr, alldefaultinit);
3242 UNLPOLYP(newsptr, unlpoly);
3243 ISOCTYPEP(newsptr, isoctype);
3244 TYPDEF_INITP(newsptr, typedef_init);
3245 break;
3246
3247 case ST_BLOCK:
3248 enclfunc = getval("enclfunc");
3249 startline = getval("startline");
3250 end = getval("end");
3251 startlab = getval("startlab");
3252 endlab = getval("endlab");
3253 paruplevel = getval("paruplevel");
3254 parent = getSptrVal("parent");
3255 parsymsct = getval("parsymsct");
3256 parsyms = 0;
3257 if (parsymsct || parent) {
3258 LLUplevel *up;
3259
3260 parsyms = llmp_get_next_key();
3261 up = llmp_create_uplevel_bykey(parsyms);
3262 up->parent = parent;
3263 for (i = 0; i < parsymsct; ++i) {
3264 /* todo this should be removed as it's wrong.
3265 * Keep it until tested. */
3266 llmp_add_shared_var(up, getnum());
3267 }
3268 }
3269
3270 newsptr = get_or_create_symbol(sptr);
3271 STYPEP(newsptr, stype);
3272 ENCLFUNCP(newsptr, enclfunc);
3273 STARTLINEP(newsptr, startline);
3274 ENDLINEP(newsptr, end);
3275 STARTLABP(newsptr, startlab);
3276 ENDLABP(newsptr, endlab);
3277 PARSYMSP(newsptr, parsyms);
3278 PARSYMSCTP(newsptr, parsymsct);
3279 PARUPLEVELP(newsptr, paruplevel);
3280
3281 break;
3282
3283 case -99: /* MODULE */
3284 /* import this as a block data symbol */
3285 break;
3286
3287 default:
3288 fprintf(stderr, "ILM file line %d: unknown symbol type\n", ilmlinenum);
3289 ++errors;
3290 break;
3291 }
3292 Trace((" newsptr = %d", newsptr));
3293 } /* read_symbol */
3294
3295 static void
read_overlap(void)3296 read_overlap(void)
3297 {
3298 int sptr, count, i;
3299 sptr = getval("overlap");
3300 sptr = symbolxref[sptr];
3301 count = getval("count");
3302 SOCPTRP(sptr, soc.avail);
3303 if (soc.size == 0) { /* allocate it */
3304 soc.size = 1000;
3305 if (count >= soc.size)
3306 soc.size = count + 1000;
3307 NEW(soc.base, SOC_ITEM, soc.size);
3308 } else {
3309 NEED(soc.avail + count, soc.base, SOC_ITEM, soc.size,
3310 soc.avail + count + 1000);
3311 }
3312 for (i = 0; i < count; ++i) {
3313 int n;
3314 n = getnum();
3315 SOC_SPTR(soc.avail) = symbolxref[n];
3316 SOC_NEXT(soc.avail) = soc.avail + 1;
3317 ++soc.avail;
3318 }
3319 /* unlink the last one */
3320 SOC_NEXT(soc.avail - 1) = 0;
3321 } /* read_overlap */
3322
3323 static void
read_program(void)3324 read_program(void)
3325 {
3326 int progtype;
3327 if (!checkname("procedure")) {
3328 fprintf(stderr,
3329 "ILM file line %d: expecting value for procedure\n"
3330 "instead got: %s\n",
3331 ilmlinenum, line + pos);
3332 ++errors;
3333 return;
3334 }
3335 gbl.rutype = getRUType();
3336 gbl.has_program |= (gbl.rutype == RU_PROG);
3337 if (gbl.rutype == RU_PROG) {
3338 flg.recursive = false;
3339 } else if (flg.smp) {
3340 flg.recursive = true;
3341 }
3342 } /* read_program */
3343
3344 /* add ipab.info pointer stride info for sptr */
3345 static void
addpstride(int sptr,long stride)3346 addpstride(int sptr, long stride)
3347 {
3348 int i, j;
3349 if (!XBIT(66, 0x1000000))
3350 return;
3351 j = newindex(sptr);
3352 i = newinfo();
3353 IPNFO_TYPE(i) = INFO_PSTRIDE;
3354 IPNFO_NEXT(i) = IPNDX_INFO(j);
3355 IPNFO_PSTRIDE(i) = stride;
3356 IPNDX_INFO(j) = i;
3357 Trace(("symbol %d:%s has stride %ld", sptr, SYMNAME(sptr), stride));
3358 } /* addpstride */
3359
3360 /* add ipab.info pointer section stride info for sptr */
3361 static void
addsstride(int sptr,long stride)3362 addsstride(int sptr, long stride)
3363 {
3364 int i, j;
3365 if (!XBIT(66, 0x1000000))
3366 return;
3367 j = newindex(sptr);
3368 i = newinfo();
3369 IPNFO_TYPE(i) = INFO_SSTRIDE;
3370 IPNFO_NEXT(i) = IPNDX_INFO(j);
3371 IPNFO_SSTRIDE(i) = stride;
3372 IPNDX_INFO(j) = i;
3373 Trace(("symbol %d:%s has section stride %ld", sptr, SYMNAME(sptr), stride));
3374 } /* addsstride */
3375
3376 static void
addf90target(int sptr,int targettype,int targetid)3377 addf90target(int sptr, int targettype, int targetid)
3378 {
3379 int i, j;
3380 j = newindex(sptr);
3381 i = newinfo();
3382 IPNFO_TYPE(i) = targettype;
3383 IPNFO_NEXT(i) = IPNDX_INFO(j);
3384 IPNFO_TARGET(i) = targetid;
3385 IPNDX_INFO(j) = i;
3386 Trace(("symbol %d:%s has targettype %d id %d", sptr, targettype, targetid));
3387 } /* addf90target */
3388
3389 static void
addsafe(int sptr,int safetype,int val)3390 addsafe(int sptr, int safetype, int val)
3391 {
3392 int i, j;
3393 j = newindex(sptr);
3394 i = newinfo();
3395 IPNFO_TYPE(i) = safetype;
3396 IPNFO_VAL(i) = val;
3397 IPNFO_NEXT(i) = IPNDX_INFO(j);
3398 IPNDX_INFO(j) = i;
3399 Trace(("symbol %d:%s has safetype %d", sptr, safetype));
3400 } /* addsafe */
3401
3402 static void
read_ipainfo(void)3403 read_ipainfo(void)
3404 {
3405 int sptr, itype, targettype, targetid, func, smax;
3406 long stride;
3407 sptr = getval("info");
3408 sptr = symbolxref[sptr];
3409 itype = getIPAType();
3410 switch (itype) {
3411 case 1: /* pstride */
3412 stride = getlval("stride");
3413 addpstride(sptr, stride);
3414 break;
3415 case 2: /* sstride */
3416 stride = getlval("stride");
3417 addsstride(sptr, stride);
3418 break;
3419 case 3: /* Target, from local analysis */
3420 targettype = getval("type");
3421 targetid = getval("id");
3422 switch (targettype) {
3423 case 1: /* local dynamic memory */
3424 addf90target(sptr, INFO_FUNKTARGET, targetid);
3425 break;
3426 case 2: /* local dynamic memory */
3427 addf90target(sptr, INFO_FLDYNTARGET, targetid);
3428 break;
3429 case 3: /* global dynamic memory */
3430 addf90target(sptr, INFO_FGDYNTARGET, targetid);
3431 break;
3432 case 4: /* nonlocal symbol */
3433 addf90target(sptr, INFO_FOTARGET, targetid);
3434 break;
3435 case 5: /* precise symbol */
3436 case 6: /* imprecise symbol */
3437 if (symbolxref[targetid]) {
3438 addf90target(sptr, INFO_FSTARGET, symbolxref[targetid]);
3439 } else {
3440 addf90target(sptr, INFO_FOSTARGET, symbolxref[targetid]);
3441 }
3442 break;
3443 }
3444 break;
3445 case 4: /* Target, from IPA */
3446 targettype = getval("type");
3447 targetid = getval("id");
3448 switch (targettype) {
3449 case 1: /* local symbol */
3450 if (symbolxref[targetid]) {
3451 addf90target(sptr, INFO_LTARGET, symbolxref[targetid]);
3452 } else {
3453 addf90target(sptr, INFO_OTARGET, targetid);
3454 }
3455 break;
3456 case 2: /* global symbol */
3457 if (symbolxref[targetid]) {
3458 addf90target(sptr, INFO_GTARGET, symbolxref[targetid]);
3459 } else {
3460 addf90target(sptr, INFO_OGTARGET, targetid);
3461 }
3462 break;
3463 case 3: /* other data */
3464 addf90target(sptr, INFO_OTARGET, targetid);
3465 break;
3466 case 4: /* anonymous global variable */
3467 addf90target(sptr, INFO_OGTARGET, targetid);
3468 break;
3469 }
3470 break;
3471 case 5: /* all call safe, from IPA */
3472 addsafe(sptr, INFO_ALLCALLSAFE, 0);
3473 break;
3474 case 6: /* safe, from IPA */
3475 addsafe(sptr, INFO_SAFE, 0);
3476 break;
3477 case 7: /* callsafe, from IPA */
3478 func = getval("func");
3479 if (symbolxref[func]) {
3480 addsafe(sptr, INFO_CALLSAFE, symbolxref[func]);
3481 }
3482 break;
3483 }
3484 } /* read_ipainfo */
3485
3486 static void
fix_symbol(void)3487 fix_symbol(void)
3488 {
3489 int s;
3490 SPTR sptr;
3491 int i, fval, smax;
3492 int altname;
3493 DTYPE dtype;
3494 int parsyms, parsymsct, paruplevel;
3495 int clen, common, count, dpdsc;
3496 SPTR desc;
3497 int enclfunc, inmod, scope;
3498 SPTR lab, link;
3499 int midnum, member, nml, paramcount, plist, val, origdum;
3500 int typedef_init;
3501 int func_count;
3502
3503 threadprivate_dtype = DT_NONE;
3504 tpcount = 0;
3505 if (gbl.statics) {
3506 /* NOSYM required instead of 0 */
3507 if (!symbolxref[gbl.statics]) {
3508 gbl.statics = NOSYM;
3509 } else {
3510 gbl.statics = symbolxref[gbl.statics];
3511 }
3512 } else {
3513 gbl.statics = NOSYM;
3514 }
3515
3516 if (gbl.locals) {
3517 /* NOSYM required instead of 0 */
3518 if (!symbolxref[gbl.locals]) {
3519 gbl.locals = NOSYM;
3520 } else {
3521 gbl.locals = symbolxref[gbl.locals];
3522 }
3523 } else {
3524 gbl.locals = NOSYM;
3525 }
3526
3527 if (gbl.outersub) {
3528 gbl.outersub = symbolxref[gbl.outersub];
3529 }
3530 smax = stb.stg_avail;
3531 for (sptr = (SPTR)(oldsymbolcount + 1); sptr < smax; ++sptr) {
3532 bool refd_done = false;
3533 switch (STYPEG(sptr)) {
3534 case ST_TYPEDEF: /* FS#16646 - fix type descriptor symbol */
3535 desc = SDSCG(sptr);
3536 if (desc > NOSYM) {
3537 desc = symbolxref[desc];
3538 SDSCP(sptr, desc);
3539 }
3540 typedef_init = TYPDEF_INITG(sptr);
3541 if (typedef_init > NOSYM) {
3542 typedef_init = symbolxref[typedef_init];
3543 TYPDEF_INITP(sptr, typedef_init);
3544 }
3545 break;
3546 case ST_ARRAY:
3547 case ST_STRUCT:
3548 case ST_UNION:
3549 dtype = DTYPEG(sptr);
3550 if (REREFG(sptr)) {
3551 /* REF bit not set in front end because we need to
3552 * compute assn_static_off() in the back end's
3553 * sym_is_refd(). So, we will do it here. This typically
3554 * occurs with type extensions that have initializations
3555 * in their parent component.
3556 */
3557 REFP(sptr, 0);
3558 sym_is_refd(sptr);
3559 refd_done = true; /* don't put on gbl lists again */
3560 }
3561 if (DTY(dtype) == TY_ARRAY) {
3562 desc = SDSCG(sptr);
3563 if (desc > NOSYM) {
3564 desc = symbolxref[desc];
3565 SDSCP(sptr, desc);
3566 }
3567 if (desc > NOSYM && AD_SDSC(AD_DPTR(dtype))) {
3568 AD_SDSC(AD_DPTR(dtype)) = desc;
3569 }
3570 if (CLASSG(sptr) && DESCARRAYG(sptr)) {
3571 /* insert type descriptor in gbl list */
3572 int sptr2;
3573 for (sptr2 = gbl.typedescs; sptr2 > NOSYM; sptr2 = TDLNKG(sptr2)) {
3574 if (sptr2 == sptr)
3575 break;
3576 }
3577 if (sptr2 != sptr) {
3578 /* unset CC flag so getsname() produces a
3579 * correct Fortran global symbol with a
3580 * trailing underscore.
3581 */
3582 CCSYMP(sptr, 0);
3583 TDLNKP(sptr, gbl.typedescs);
3584 gbl.typedescs = sptr;
3585 }
3586 }
3587 }
3588 /* fall through */
3589 case ST_VAR:
3590 if (STYPEG(sptr) != ST_ARRAY && VARDSCG(sptr)) {
3591 desc = SDSCG(sptr);
3592 if (desc > NOSYM) {
3593 desc = symbolxref[desc];
3594 SDSCP(sptr, desc);
3595 }
3596 }
3597 link = SYMLKG(sptr);
3598 if ((link > NOSYM) && !CFUNCG(sptr)) {
3599 /* CFUNCG : keep BIND(C) variables on the
3600 gbl.extern list
3601 */
3602 SYMLKP(sptr, symbolxref[link]);
3603 }
3604 if (SCG(sptr) == SC_CMBLK) {
3605 common = MIDNUMG(sptr);
3606 if (CFUNCG(sptr)) {
3607 /* variables visable from C */
3608 SCP(sptr, SC_EXTERN); /* try this */
3609 } else {
3610 MIDNUMP(sptr, symbolxref[common]);
3611 }
3612 } else if (IS_THREAD_TP(sptr)) {
3613 if ((SCG(sptr) == SC_LOCAL || SCG(sptr) == SC_STATIC) &&
3614 !UPLEVELG(sptr) && !MIDNUMG(sptr)) {
3615 int tptr;
3616 tptr = create_thread_private_vector(sptr, 0);
3617 MIDNUMP(tptr, sptr);
3618 MIDNUMP(sptr, tptr);
3619 if (!XBIT(69, 0x80))
3620 SCP(tptr, SC_STATIC);
3621 } else if (SCG(sptr) == SC_BASED) {
3622 int psptr;
3623 psptr = symbolxref[MIDNUMG(sptr)];
3624 if (SCG(psptr) == SC_CMBLK) {
3625 /* if the $p var is in a common block, the
3626 * treadprivate vector will be generated when
3627 * the $p var is processed
3628 */
3629 MIDNUMP(sptr, psptr);
3630 } else if ((SCG(psptr) == SC_LOCAL || SCG(psptr) == SC_STATIC) &&
3631 UPLEVELG(psptr)) {
3632 /* defer until restore_saved_syminfo() */
3633 MIDNUMP(sptr, psptr);
3634 } else if (POINTERG(sptr)) {
3635 /* Cannot rely on the SYMLK chain appearing as
3636 * $p -> $o -> $sd
3637 * Apparently, these links only occur for the pointer's internal
3638 * variables if the pointer does not have the SAVE attribute.
3639 * Without these fields, the correct size of the threads' copies
3640 * cannot be computed.
3641 * Just explicitly look for the internal pointer and descriptor.
3642 * If the descriptor is present, can assume that there is an
3643 * offest var which only needs to be accounted for in the size
3644 * computation of the threads' copies.
3645 * Setup up the MIDNUM fields as follows where foo is the symtab
3646 * entry which has the POINTER flag set:
3647 * foo -> foo$p
3648 * TPpfoo -> foo
3649 * foo$p -> TPpfoo
3650 * foo$sd -> TPpfoo
3651 * Note that foo's SDSC -> foo$sd.
3652 * Before we had:
3653 * foo -> TPpfoo
3654 * TPpfoo -> foo$p
3655 * which is a problem for computing the size when starting with
3656 * TPpfoo.
3657 */
3658 int tptr;
3659 int sdsptr;
3660 tptr = create_thread_private_vector(sptr, 0);
3661 THREADP(psptr, 1);
3662 MIDNUMP(sptr, psptr);
3663 MIDNUMP(tptr, sptr);
3664 MIDNUMP(psptr, tptr);
3665 sdsptr = SDSCG(sptr);
3666 if (sdsptr) {
3667 THREADP(sdsptr, 1);
3668 MIDNUMP(sdsptr, tptr);
3669 }
3670 if (!XBIT(69, 0x80))
3671 if (SCG(psptr) == SC_LOCAL || SCG(psptr) == SC_STATIC)
3672 SCP(tptr, SC_STATIC);
3673 } else {
3674 /*
3675 * Given the above code for POINTER, this code is
3676 * probably dead, but leave it just in case.
3677 */
3678 int tptr;
3679 tptr = create_thread_private_vector(psptr, 0);
3680 THREADP(psptr, 1);
3681 MIDNUMP(sptr, tptr);
3682 MIDNUMP(tptr, psptr);
3683 MIDNUMP(psptr, tptr);
3684 if (SYMLKG(psptr) != NOSYM) {
3685 psptr = symbolxref[SYMLKG(psptr)];
3686 THREADP(psptr, 1);
3687 MIDNUMP(psptr, tptr);
3688 if (SYMLKG(psptr) != NOSYM) {
3689 psptr = symbolxref[SYMLKG(psptr)];
3690 THREADP(psptr, 1);
3691 MIDNUMP(psptr, tptr);
3692 }
3693 }
3694 }
3695 }
3696 } else {
3697 midnum = MIDNUMG(sptr);
3698 if (midnum) {
3699 const int newMid = symbolxref[midnum];
3700 MIDNUMP(sptr, newMid);
3701 #ifdef REVMIDLNKP
3702 if (POINTERG(sptr) && newMid) {
3703 assert(!REVMIDLNKG(newMid), "REVMIDLNK already set", newMid,
3704 ERR_Fatal);
3705 REVMIDLNKP(newMid, sptr);
3706 }
3707 #endif
3708 if (ALLOCATTRG(sptr))
3709 ALLOCATTRP(newMid, 1);
3710 }
3711 }
3712 if (SCG(sptr) == SC_DUMMY) {
3713 origdum = ORIGDUMMYG(sptr);
3714 if (origdum) {
3715 origdum = symbolxref[origdum];
3716 ORIGDUMMYP(sptr, origdum);
3717 ORIGDUMMYP(origdum, sptr);
3718 }
3719 } else if (SCG(sptr) == SC_STATIC && REFG(sptr) && !refd_done &&
3720 !DINITG(sptr)) {
3721 /* FE90 front end doesn't have a gbl.bssvars */
3722 SYMLKP(sptr, gbl.bssvars);
3723 gbl.bssvars = sptr;
3724 }
3725 clen = CLENG(sptr);
3726 if (clen) {
3727 clen = symbolxref[clen];
3728 CLENP(sptr, clen);
3729 }
3730 if (!XBIT(124, 64) && SCG(sptr) == SC_BASED) {
3731 /* if the MIDNUM (pointer) is not a TEMP,
3732 * and we are not using safe 'cray-pointer' semantics,
3733 * reset NOCONFLICT */
3734 midnum = MIDNUMG(sptr);
3735 if (midnum && !CCSYMG(midnum)) {
3736 NOCONFLICTP(sptr, 0);
3737 }
3738 }
3739 if (SCG(sptr) == SC_BASED && MIDNUMG(sptr) && CCSYMG(MIDNUMG(sptr))) {
3740 /* nonuser cray pointer, the pointer variable has no conflict */
3741 NOCONFLICTP(MIDNUMG(sptr), 1);
3742 }
3743 if (SCG(sptr) == SC_BASED && !NOCONFLICTG(sptr) && MIDNUMG(sptr) &&
3744 !CCSYMG(MIDNUMG(sptr))) {
3745 /* ### for now, reset NOCONFLICT bit on cray pointer */
3746 /* ### error in f90correct/bq00.f with -Mscalarsse -Mx,72,1 */
3747 NOCONFLICTP(MIDNUMG(sptr), 0);
3748 }
3749 enclfunc = ENCLFUNCG(sptr);
3750 if (enclfunc) {
3751 enclfunc = symbolxref[enclfunc];
3752 ENCLFUNCP(sptr, enclfunc);
3753 }
3754 altname = ALTNAMEG(sptr);
3755 if (altname)
3756 ALTNAMEP(sptr, symbolxref[altname]);
3757 break;
3758 case ST_CMBLK:
3759 member = CMEMFG(sptr);
3760 CMEMFP(sptr, symbolxref[member]);
3761 altname = ALTNAMEG(sptr);
3762 if (altname)
3763 ALTNAMEP(sptr, symbolxref[altname]);
3764 scope = SCOPEG(sptr);
3765 if (scope) {
3766 scope = symbolxref[scope];
3767 SCOPEP(sptr, scope);
3768 }
3769 break;
3770 case ST_CONST:
3771 switch (DTY(DTYPEG(sptr))) {
3772 case TY_HOLL:
3773 val = CONVAL1G(sptr);
3774 CONVAL1P(sptr, symbolxref[val]);
3775 break;
3776 case TY_DCMPLX:
3777 val = CONVAL1G(sptr);
3778 CONVAL1P(sptr, symbolxref[val]);
3779 val = CONVAL2G(sptr);
3780 CONVAL2P(sptr, symbolxref[val]);
3781 break;
3782 case TY_PTR:
3783 val = CONVAL1G(sptr);
3784 CONVAL1P(sptr, symbolxref[val]);
3785 break;
3786 default:
3787 break;
3788 }
3789 break;
3790 case ST_LABEL:
3791 break;
3792 case ST_MEMBER:
3793 link = SYMLKG(sptr);
3794 if (link > NOSYM) {
3795 link = symbolxref[link];
3796 SYMLKP(sptr, link);
3797 VARIANTP(link, sptr);
3798 if (ALLOCATTRG(sptr) && ADDRESSG(link) == ADDRESSG(sptr) &&
3799 DTY(DTYPEG(link)) == TY_PTR)
3800 ALLOCATTRP(link, 1);
3801 }
3802 dtype = DTYPEG(sptr);
3803 if (DTY(dtype) == TY_ARRAY) {
3804 desc = SDSCG(sptr);
3805 if (desc > NOSYM) {
3806 desc = symbolxref[desc];
3807 SDSCP(sptr, desc);
3808 }
3809 if (desc > NOSYM && AD_SDSC(AD_DPTR(dtype))) {
3810 AD_SDSC(AD_DPTR(dtype)) = desc;
3811 } else if (desc <= NOSYM && AD_SDSC(AD_DPTR(dtype)) > oldsymbolcount) {
3812 desc = AD_SDSC(AD_DPTR(dtype));
3813 AD_SDSC(AD_DPTR(dtype)) = symbolxref[desc];
3814 }
3815
3816 } else if (DTYPEG(sptr) == DT_ASSCHAR) {
3817 desc = SDSCG(sptr);
3818 if (desc > NOSYM) {
3819 desc = symbolxref[desc];
3820 SDSCP(sptr, desc);
3821 }
3822 } else if (DTYPEG(sptr) == DT_DEFERCHAR) {
3823 desc = SDSCG(sptr);
3824 if (desc > NOSYM) {
3825 desc = symbolxref[desc];
3826 SDSCP(sptr, desc);
3827 }
3828 } else if (CLASSG(sptr) || FINALIZEDG(sptr)) {
3829 desc = SDSCG(sptr);
3830 if (desc > NOSYM) {
3831 desc = symbolxref[desc];
3832 SDSCP(sptr, desc);
3833 }
3834 }
3835 if (SCG(sptr) == SC_BASED && MIDNUMG(sptr) && CCSYMG(MIDNUMG(sptr))) {
3836 /* nonuser cray pointer, the pointer variable has no conflict */
3837 NOCONFLICTP(MIDNUMG(sptr), 1);
3838 }
3839 if (CLASSG(sptr) || FINALIZEDG(sptr)) {
3840 /* Fix up type bound procedure links */
3841 int sym = TBPLNKG(sptr);
3842 if (sym > oldsymbolcount) {
3843 sym = symbolxref[sym];
3844 TBPLNKP(sptr, sym);
3845 }
3846 sym = VTABLEG(sptr);
3847 if (sym > oldsymbolcount) {
3848 sym = symbolxref[sym];
3849 VTABLEP(sptr, sym);
3850 }
3851 sym = IFACEG(sptr);
3852 if (sym > oldsymbolcount) {
3853 sym = symbolxref[sym];
3854 IFACEP(sptr, sym);
3855 }
3856 }
3857 break;
3858 case ST_NML:
3859 plist = ADDRESSG(sptr);
3860 ADDRESSP(sptr, symbolxref[plist]);
3861 /* fix namelist members */
3862 for (nml = CMEMFG(sptr); nml; nml = NML_NEXT(nml)) {
3863 member = NML_SPTR(nml);
3864 NML_SPTR(nml) = symbolxref[member];
3865 }
3866 break;
3867 case ST_PARAM:
3868 if (!TY_ISWORD(DTY(DTYPEG(sptr)))) {
3869 /* fix up sptr */
3870 val = CONVAL1G(sptr);
3871 CONVAL1P(sptr, symbolxref[val]);
3872 }
3873 break;
3874 case ST_PLIST:
3875 if (!UPLEVELG(sptr))
3876 sym_is_refd(sptr);
3877 break;
3878 case ST_PROC:
3879 case ST_ENTRY:
3880 paramcount = PARAMCTG(sptr);
3881 dpdsc = DPDSCG(sptr);
3882 for (i = 0; i < paramcount; ++i) {
3883 int param;
3884 param = aux.dpdsc_base[dpdsc + i];
3885 param = symbolxref[param];
3886 aux.dpdsc_base[dpdsc + i] = param;
3887 }
3888 fval = FVALG(sptr);
3889 if (fval) {
3890 fval = symbolxref[fval];
3891 FVALP(sptr, fval);
3892 }
3893 inmod = INMODULEG(sptr);
3894 if (inmod) {
3895 inmod = symbolxref[inmod];
3896 INMODULEP(sptr, inmod);
3897 }
3898 altname = ALTNAMEG(sptr);
3899 if (altname)
3900 ALTNAMEP(sptr, symbolxref[altname]);
3901 if (STYPEG(sptr) == ST_PROC && SDSCG(sptr)) {
3902 SDSCP(sptr, symbolxref[SDSCG(sptr)]);
3903 }
3904 break;
3905 case ST_GENERIC:
3906 for (desc = (SPTR)GNDSCG(sptr); desc; desc = (SPTR)SYMI_NEXT(desc)) {
3907 int spec;
3908 spec = SYMI_SPTR(desc);
3909 spec = symbolxref[spec];
3910 SYMI_SPTR(desc) = spec;
3911 }
3912 break;
3913 case ST_BLOCK:
3914 enclfunc = ENCLFUNCG(sptr);
3915 if (enclfunc) {
3916 enclfunc = symbolxref[enclfunc];
3917 ENCLFUNCP(sptr, enclfunc);
3918 }
3919 lab = STARTLABG(sptr);
3920 STARTLABP(sptr, symbolxref[lab]);
3921 lab = ENDLABG(sptr);
3922 ENDLABP(sptr, symbolxref[lab]);
3923 paruplevel = PARUPLEVELG(sptr);
3924 if (paruplevel) {
3925 paruplevel = symbolxref[paruplevel];
3926 PARUPLEVELP(sptr, paruplevel);
3927 }
3928 if (PARSYMSG(sptr) || llmp_has_uplevel(sptr)) {
3929 LLUplevel *up = llmp_get_uplevel(sptr);
3930 for (i = 0; i < up->vals_count; ++i) {
3931 int parsptr = up->vals[i];
3932 parsptr = symbolxref[parsptr];
3933 up->vals[i] = parsptr;
3934 }
3935 if (up->parent) {
3936 up->parent = symbolxref[up->parent];
3937 if (llmp_has_uplevel(up->parent) == 0) {
3938 parsyms = llmp_get_next_key();
3939 PARSYMSP(up->parent, parsyms);
3940 up = llmp_create_uplevel_bykey(parsyms);
3941 }
3942 }
3943 }
3944 break;
3945 default:
3946 break;
3947 }
3948 }
3949 for (common = gbl.cmblks; common > NOSYM; common = SYMLKG(common)) {
3950 #if defined(TARGET_WIN_X86)
3951 int cmem;
3952 for (cmem = CMEMFG(common); cmem > NOSYM; cmem = SYMLKG(cmem)) {
3953 if ((DLLG(cmem) == DLL_EXPORT) && (DLLG(common) != DLL_EXPORT)) {
3954 DLLP(common, DLL_EXPORT);
3955 }
3956 }
3957 #endif
3958 if (common > oldsymbolcount) {
3959 member = CMEMFG(common);
3960 for (; SYMLKG(member) > NOSYM; member = SYMLKG(member))
3961 ;
3962 CMEMLP(common, member);
3963 if (IS_THREAD_TP(common)) {
3964 char *np;
3965 int len, hashid, tptr;
3966 /* mark all members as thread-private */
3967 for (member = CMEMFG(common); member > NOSYM; member = SYMLKG(member)) {
3968 THREADP(member, 1);
3969 }
3970
3971 tptr = create_thread_private_vector(common, 0);
3972 /* Link the common block and its vector */
3973 MIDNUMP(tptr, common);
3974 MIDNUMP(common, tptr);
3975 }
3976 #if defined(TARGET_WIN_X86)
3977 else if (DLLG(common) == DLL_EXPORT) {
3978 /* mark all members as dllexport */
3979 for (member = CMEMFG(common); member > NOSYM; member = SYMLKG(member))
3980 DLLP(member, DLL_EXPORT);
3981 } else if (DLLG(common) == DLL_IMPORT) {
3982 /* mark all members as dllimport */
3983 for (member = CMEMFG(common); member > NOSYM; member = SYMLKG(member))
3984 DLLP(member, DLL_IMPORT);
3985 }
3986 #endif
3987 }
3988 }
3989 } /* fix_symbol */
3990
3991 static int
create_thread_private_vector(int sptr,int host_tpsym)3992 create_thread_private_vector(int sptr, int host_tpsym)
3993 {
3994 char TPname[MAXIDLEN + 5];
3995 char *np;
3996 int len, hashid;
3997 SPTR tptr;
3998
3999 if (threadprivate_dtype == 0) {
4000 threadprivate_dtype = create_threadprivate_dtype();
4001 }
4002 TPname[0] = 'T';
4003 TPname[1] = 'P';
4004 TPname[2] = 'p';
4005 np = SYMNAME(sptr);
4006 len = strlen(np);
4007 if (len > MAXIDLEN)
4008 len = MAXIDLEN;
4009 strncpy(TPname + 3, np, len);
4010 HASH_ID(hashid, TPname, len + 3);
4011 ADDSYM(tptr, hashid);
4012 NMPTRP(tptr, putsname(TPname, len + 3));
4013 STYPEP(tptr, ST_VAR);
4014 SCP(tptr, SC_EXTERN);
4015 DTYPEP(tptr, threadprivate_dtype);
4016 DCLDP(tptr, 1);
4017
4018 if (host_tpsym) {
4019 /*
4020 * If the threadprivate variable/common were declared in the host,
4021 * need to use its threadprivate vector which is also declared in
4022 * the host along with its host attributes. Also, in this case,
4023 * avoid adding the vector to the gbl.threadprivate list; doing so
4024 * yields multiple declaratations via _mp_cdecl[p].
4025 */
4026 int s;
4027 for (s = 0; s < saved_tpcount; s++) {
4028 if (host_tpsym == saved_tpinfo[s].memarg) {
4029 SCP(tptr, saved_tpinfo[s].sc);
4030 ADDRESSP(tptr, saved_tpinfo[s].address);
4031 REFP(tptr, saved_tpinfo[s].ref);
4032 if (STYPEG(sptr) != ST_CMBLK)
4033 UPLEVELP(tptr, 1);
4034 return tptr;
4035 }
4036 }
4037 }
4038
4039 /* Add the vector to the gbl.threadprivate list */
4040 TPLNKP(tptr, gbl.threadprivate);
4041 gbl.threadprivate = tptr;
4042 tpcount++;
4043
4044 return tptr;
4045 }
4046
4047 /* create the datatype for the vector of pointers,
4048 * this code copied from 'semant.c' for the pgf77
4049 */
4050 static DTYPE
create_threadprivate_dtype(void)4051 create_threadprivate_dtype(void)
4052 {
4053 DTYPE dt;
4054 SPTR zero, one, maxcpu, maxcpup1;
4055 int val[4];
4056 ADSC *ad;
4057 return DT_ADDR;
4058
4059 val[0] = 0;
4060 val[1] = 0;
4061 zero = getcon(val, DESC_ELM_DT);
4062 val[1] = 1;
4063 one = getcon(val, DESC_ELM_DT);
4064 val[1] = MAXCPUS - 1;
4065 maxcpu = getcon(val, DESC_ELM_DT);
4066 val[1] = MAXCPUS;
4067 maxcpup1 = getcon(val, DESC_ELM_DT);
4068 dt = get_array_dtype(1, __POINT_T);
4069 ad = AD_DPTR(dt);
4070 AD_NUMDIM(ad) = 1;
4071 AD_SCHECK(ad) = 0;
4072 AD_LWBD(ad, 0) = zero;
4073 AD_UPBD(ad, 0) = maxcpu;
4074 AD_MLPYR(ad, 0) = one;
4075 AD_ZBASE(ad) = zero;
4076 AD_NUMELM(ad) = maxcpup1;
4077 return dt;
4078 }
4079
4080 #include "upperilm.h"
4081
4082 static int
getilm(void)4083 getilm(void)
4084 {
4085 int val;
4086
4087 if (endilmfile) {
4088 fprintf(stderr, "ILM file: looking past end-of-file for ilm number\n");
4089 ++errors;
4090 return 0;
4091 }
4092
4093 if (line[pos] != 'i') {
4094 fprintf(stderr,
4095 "ILM file line %d: expecting ilm number\n"
4096 "instead got: %s\n",
4097 ilmlinenum, line + pos);
4098 ++errors;
4099 return 0;
4100 }
4101
4102 ++pos;
4103 val = 0;
4104 while (line[pos] >= '0' && line[pos] <= '9') {
4105 val = val * 10 + (line[pos] - '0');
4106 ++pos;
4107 }
4108 return val;
4109 } /* getilm */
4110
4111 static int
getoperand(const char * optype,char letter)4112 getoperand(const char *optype, char letter)
4113 {
4114 int val, neg;
4115
4116 if (endilmfile) {
4117 fprintf(stderr, "ILM file: looking past end-of-file for %s operand\n",
4118 optype);
4119 ++errors;
4120 return 0;
4121 }
4122
4123 skipwhitespace();
4124
4125 if (line[pos] != letter) {
4126 fprintf(stderr,
4127 "ILM file line %d: expecting %s operand\n"
4128 "instead got: %s\n",
4129 ilmlinenum, optype, line + pos);
4130 ++errors;
4131 return 0;
4132 }
4133
4134 ++pos;
4135 val = 0;
4136 neg = 1;
4137 if (line[pos] == '-') {
4138 ++pos;
4139 neg = -1;
4140 }
4141 while (line[pos] >= '0' && line[pos] <= '9') {
4142 val = val * 10 + (line[pos] - '0');
4143 ++pos;
4144 }
4145 val *= neg;
4146 switch (letter) {
4147 case chsym:
4148 if (val == 0)
4149 return 0;
4150 if (symbolxref[val] != 0) {
4151 return symbolxref[val];
4152 }
4153 break;
4154 case chdtype:
4155 if (datatypexref[val] != 0) {
4156 return datatypexref[val];
4157 }
4158 if (val == 0) {
4159 return 0;
4160 }
4161 break;
4162 case chilm:
4163 if (val <= 0 || val >= origilmavl) {
4164 fprintf(stderr, "ILM FILE line %d: Bad ilm operand %d\n", ilmlinenum,
4165 val);
4166 ++errors;
4167 } else if (ilmxref[val] == 0) {
4168 fprintf(stderr, "ILM FILE line %d: Invalid ilm operand %d\n", ilmlinenum,
4169 val);
4170 ++errors;
4171 } else {
4172 val = ilmxref[val];
4173 }
4174 return val;
4175 case chline:
4176 case chnum:
4177 return val;
4178 default:
4179 break;
4180 }
4181 fprintf(stderr, "ILM file line %d: unknown %s operand %d\n", ilmlinenum,
4182 optype, val);
4183 ++errors;
4184 return 0;
4185 } /* getoperand */
4186
4187 static int
getoperation(void)4188 getoperation(void)
4189 {
4190 char ch;
4191 char *p;
4192 int len;
4193 int hi, lo;
4194
4195 if (endilmfile) {
4196 fprintf(stderr, "ILM file: looking past end-of-file for operation\n");
4197 ++errors;
4198 return 0;
4199 }
4200
4201 skipwhitespace();
4202
4203 /* end of statement? */
4204 p = line + pos;
4205
4206 if (strncmp(p, "---", 3) == 0) {
4207 /* yes, simply return */
4208 return -1;
4209 }
4210
4211 /* check for unimplemented operation */
4212 if (strncmp(p, "--", 2) == 0) {
4213 /* yes, simply return */
4214 return -2;
4215 }
4216
4217 ch = line[pos];
4218 len = 0;
4219 while ((ch >= 'A' && ch <= 'Z') || (ch >= 'a' && ch <= 'z') ||
4220 (ch >= '0' && ch <= '9') || (ch == '_')) {
4221 ++pos;
4222 ++len;
4223 ch = line[pos];
4224 }
4225 line[pos] = '\0';
4226 /* binary search */
4227 hi = NUMOPERATIONS - 1;
4228 lo = 0;
4229 while (lo <= hi) {
4230 int mid, compare;
4231 mid = (hi + lo) / 2;
4232 compare = strcmp(p, info[mid].name);
4233 if (compare == 0) {
4234 line[pos] = ch;
4235 return mid;
4236 }
4237 if (compare < 0) {
4238 hi = mid - 1;
4239 } else {
4240 lo = mid + 1;
4241 }
4242 }
4243 line[pos] = ch;
4244 fprintf(stderr, "ILM file line %d: unknown operation: %s\n", ilmlinenum, p);
4245 ++errors;
4246 return -5;
4247 } /* getoperation */
4248
4249 /* read one line from the ILM file */
4250 static void
read_ilm(void)4251 read_ilm(void)
4252 {
4253 int ilm, op, numoperands, i, opc;
4254 ilm = getilm();
4255 if (line[pos] == ':') {
4256 ++pos;
4257 }
4258
4259 op = getoperation();
4260 numoperands = 0;
4261
4262 if (op >= 0 && info[op].ilmtype == IM_BOS) {
4263 /* first argument is the line number */
4264 gbl.lineno = getoperand("line", chline);
4265 gbl.findex = getoperand("number", chnum);
4266 Trace(("Statement at line %d", gbl.lineno));
4267 origilmavl = 4;
4268 } else if (op >= 0) {
4269 opc = info[op].ilmtype;
4270 Trace(("read i%d: %s (%d) with %d operands", ilm, info[op].name, op,
4271 info[op].numoperands));
4272 if (ilm != origilmavl) {
4273 fprintf(stderr, "ILM FILE line %d: Reading ilm %d into slot %d\n",
4274 ilmlinenum, ilm, origilmavl);
4275 ++errors;
4276 }
4277 if (opc == IM_AGOTO) {
4278 gbl.asgnlbls = NME_NULL;
4279 }
4280
4281 numoperands = info[op].numoperands;
4282 /* this is where the next ILM should appear: */
4283 ++origilmavl;
4284 NEED(ilm + 1, ilmxref, int, ilmxrefsize, ilm + 100);
4285 ilmxref[ilm] = ilmb.ilmavl;
4286 ad1ilm(opc);
4287 for (i = 0; i < numoperands; ++i) {
4288 int opnd;
4289 switch (info[op].operand[i]) {
4290 case pilm:
4291 ++origilmavl;
4292 opnd = getoperand("ilm", chilm);
4293 Trace((" %c%d", chilm, opnd));
4294 ad1ilm(opnd);
4295 break;
4296 case psym:
4297 ++origilmavl;
4298 opnd = getoperand("symbol", chsym);
4299 Trace((" %c%d", chsym, opnd));
4300 ad1ilm(opnd);
4301 if (opc == IM_LABEL)
4302 DEFDP(opnd, 1);
4303 break;
4304 case pdtype:
4305 ++origilmavl;
4306 opnd = getoperand("datatype", chdtype);
4307 Trace((" %c%d", chdtype, opnd));
4308 ad1ilm(opnd);
4309 break;
4310 case pline:
4311 ++origilmavl;
4312 opnd = getoperand("line", chline);
4313 Trace((" %c%d", chline, opnd));
4314 ad1ilm(opnd);
4315 break;
4316 case pnum:
4317 ++origilmavl;
4318 opnd = getoperand("number", chnum);
4319 Trace((" %c%d", chnum, opnd));
4320 ad1ilm(opnd);
4321 break;
4322 case pilms:
4323 skipwhitespace();
4324 while (line[pos] == chilm) {
4325 ++origilmavl;
4326 opnd = getoperand("ilm", chilm);
4327 Trace((" %c%d", chilm, opnd));
4328 ad1ilm(opnd);
4329 skipwhitespace();
4330 }
4331 break;
4332 case pargs:
4333 skipwhitespace();
4334 while (line[pos] == chilm) {
4335 ++origilmavl;
4336 opnd = getoperand("ilm", chilm);
4337 Trace((" %c%d", chilm, opnd));
4338 ad1ilm(opnd);
4339 skipwhitespace();
4340 opnd = getoperand("datatype", chdtype);
4341 /* ignore the datatype */
4342 skipwhitespace();
4343 }
4344 break;
4345 case psyms:
4346 skipwhitespace();
4347 while (line[pos] == chsym) {
4348 ++origilmavl;
4349 opnd = getoperand("symbol", chsym);
4350 Trace((" %c%d", chsym, opnd));
4351 ad1ilm(opnd);
4352 skipwhitespace();
4353 }
4354 break;
4355 case pnums:
4356 skipwhitespace();
4357 while (line[pos] == chnum) {
4358 ++origilmavl;
4359 opnd = getoperand("number", chnum);
4360 Trace((" %c%d", chnum, opnd));
4361 ad1ilm(opnd);
4362 skipwhitespace();
4363 }
4364 break;
4365 default:
4366 break;
4367 }
4368 }
4369 } else if (op == -1) {
4370 /* end of statement */
4371 Trace(("---------------"));
4372 /* write ilms out */
4373 wrilms(-1);
4374 } else if (op == -2) {
4375 /* unimplemented ilm */
4376 Trace(("read i%d: -- unimplemented", ilm));
4377 }
4378 } /* read_ilm */
4379
4380 static int
getlabelnum(void)4381 getlabelnum(void)
4382 {
4383 int val;
4384 if (endilmfile) {
4385 fprintf(stderr, "ILM file: looking past end-of-file for label number\n");
4386 ++errors;
4387 return 0;
4388 }
4389
4390 if (line[pos] != 'l') {
4391 fprintf(stderr,
4392 "ILM file line %d: expecting label number\n"
4393 "instead got: %s\n",
4394 ilmlinenum, line + pos);
4395 ++errors;
4396 return 0;
4397 }
4398
4399 ++pos;
4400 val = 0;
4401 while (line[pos] >= '0' && line[pos] <= '9') {
4402 val = val * 10 + (line[pos] - '0');
4403 ++pos;
4404 }
4405 return val;
4406 } /* getlabelnum */
4407
4408 int
getswel(int sz)4409 getswel(int sz)
4410 {
4411 int sw;
4412 sw = sem.switch_avl;
4413 sem.switch_avl += sz;
4414 if (sem.switch_size == 0) { /* allocate it */
4415 if (sz < 400)
4416 sem.switch_size = 400;
4417 else
4418 sem.switch_size = sz;
4419 NEW(switch_base, SWEL, sem.switch_size);
4420 } else {
4421 NEED(sem.switch_avl, switch_base, SWEL, sem.switch_size,
4422 sem.switch_size + 300);
4423 }
4424 return sw;
4425 }
4426
4427 static void
read_label(void)4428 read_label(void)
4429 {
4430 int l;
4431 SPTR label;
4432 int value, first, sw;
4433 /* add a label to the label list */
4434 l = getlabelnum();
4435 label = getSptrVal("label");
4436 label = symbolxref[label];
4437 value = getval("value");
4438 first = getbit("first");
4439 sw = getswel(1);
4440 switch_base[sw].clabel = label;
4441 switch_base[sw].val = value;
4442 switch_base[sw].next = 0;
4443 if (!first) {
4444 switch_base[sw - 1].next = sw;
4445 }
4446 if (l != sw) {
4447 fprintf(stderr,
4448 "ILM file line %d: switch label %d entered at switch offset %d\n",
4449 ilmlinenum, l, sw);
4450 ++errors;
4451 }
4452 } /* read_label */
4453
4454 static VAR *dataivl;
4455 static VAR *lastivl;
4456 static CONST *dataict;
4457 static CONST *lastict;
4458 static CONST *outerict;
4459
4460 static void
data_add_ivl(VAR * ivl)4461 data_add_ivl(VAR *ivl)
4462 {
4463 ivl->next = NULL;
4464 if (lastivl) {
4465 lastivl->next = ivl;
4466 } else {
4467 dataivl = ivl;
4468 }
4469 lastivl = ivl;
4470 } /* data_add_ivl */
4471
4472 static void
data_push_const(void)4473 data_push_const(void)
4474 {
4475 /* rotate: NULL=>dataict=>outerict=>lastict->subc */
4476 lastict->subc = outerict;
4477 outerict = dataict;
4478 dataict = NULL;
4479 lastict = NULL;
4480 } /* data_push_const */
4481
4482 static void
data_pop_const(void)4483 data_pop_const(void)
4484 {
4485 CONST *save;
4486 for (lastict = outerict; lastict->next; lastict = lastict->next)
4487 ;
4488 /* unrotate: lastict->subc=>outerict=>dataict=>lastict->subc */
4489 save = lastict->subc;
4490 lastict->subc = dataict;
4491 dataict = outerict;
4492 outerict = save;
4493 } /* data_pop_const */
4494
4495 static void
data_add_const(CONST * ict)4496 data_add_const(CONST *ict)
4497 {
4498 ict->next = NULL;
4499 if (lastict) {
4500 lastict->next = ict;
4501 } else {
4502 dataict = ict;
4503 }
4504 lastict = ict;
4505 } /* data_add_const */
4506
4507 static void
push(int * value)4508 push(int *value)
4509 {
4510 ++stack_top;
4511 if (stack_top >= stack_size) {
4512 if (stack_size == 0) {
4513 stack_size = 100;
4514 NEW(stack, int *, stack_size);
4515 } else {
4516 stack_size += 100;
4517 NEED(stack_top, stack, int *, stack_size, stack_size + 100);
4518 }
4519 }
4520 stack[stack_top] = value;
4521 } /* push */
4522
4523 static int *
pop(void)4524 pop(void)
4525 {
4526 if (stack_top <= 0) {
4527 fprintf(stderr, "ILM file line %d: stack underflow while lowering\n",
4528 ilmlinenum);
4529 exit(1);
4530 }
4531 --stack_top;
4532 return stack[stack_top + 1];
4533 } /* pop */
4534
4535 static void
push_typestack(void)4536 push_typestack(void)
4537 {
4538 ++tsl;
4539 if (tsl >= tssize) {
4540 if (tssize == 0) {
4541 tssize = 100;
4542 NEW(ts, typestack, tssize);
4543 } else {
4544 tssize += 100;
4545 NEED(tsl, ts, typestack, tssize, tssize + 100);
4546 }
4547 }
4548 } /* push_typestack */
4549
4550 static void
read_init(void)4551 read_init(void)
4552 {
4553 int val;
4554 DTYPE dtypev;
4555 int a;
4556 DTYPE dt;
4557 static SPTR sptr = SPTR_NULL; /* the symbol being initialized */
4558 static DTYPE dtype; /* the datatype of that symbol */
4559 static int offset = 0;
4560 int movemember = 1;
4561
4562 if (!checkname("Init")) {
4563 fprintf(stderr,
4564 "ILM file line %d: Error in initialization record\ngot %s\n",
4565 ilmlinenum, line);
4566 ++errors;
4567 return;
4568 }
4569 skipwhitespace();
4570 switch (line[pos]) {
4571 case 'a': /* array start/end */
4572 if (!checkname("array")) {
4573 fprintf(stderr,
4574 "ILM file line %d: "
4575 "Error in array initialization\n"
4576 "got %s\n",
4577 ilmlinenum, line);
4578 ++errors;
4579 return;
4580 }
4581 skipwhitespace();
4582 if (line[pos] == 's' && checkname("start")) {
4583 if (tsl < 0) {
4584 fprintf(stderr,
4585 "ILM file line %d: "
4586 "unexpected array initialization\n",
4587 ilmlinenum);
4588 ++errors;
4589 return;
4590 }
4591 dt = ts[tsl].dtype;
4592 if (DTY(dt) != TY_ARRAY) {
4593 fprintf(stderr,
4594 "ILM file line %d: "
4595 "array initialization for nonarray type\n",
4596 ilmlinenum);
4597 ++errors;
4598 return;
4599 }
4600 push_typestack();
4601 ts[tsl].dtype = DTySeqTyElement(dt);
4602 ts[tsl].member = SPTR_NULL;
4603 movemember = 0;
4604 } else if (line[pos] == 'e' && checkname("end")) {
4605 if (tsl < 0) {
4606 fprintf(stderr,
4607 "ILM file line %d: "
4608 "misplaced end-array\n",
4609 ilmlinenum);
4610 ++errors;
4611 return;
4612 }
4613 --tsl;
4614 } else {
4615 fprintf(stderr,
4616 "ILM file line %d: "
4617 "Error in array initialization\n"
4618 "got %s\n",
4619 ilmlinenum, line);
4620 ++errors;
4621 return;
4622 }
4623 break;
4624 case 'c': /* data charstring */
4625 val = getval("charstring");
4626 val = symbolxref[val];
4627 dtypev = DTYPEG(val);
4628 if (sptr > 0) {
4629 DTYPE totype;
4630 if (tsl == 0) {
4631 totype = dtype;
4632 } else {
4633 dt = ts[tsl].dtype;
4634 totype = DTY(dt) == TY_ARRAY ? DTySeqTyElement(dt) : dt;
4635 }
4636 if (DTYG(dtypev) == TY_HOLL) {
4637 /* convert hollerith string to proper length */
4638 val = cngcon(val, DTYPEG(val), totype);
4639 } else if (DTYG(dtypev) == TY_CHAR || DTYG(dtypev) == TY_NCHAR ||
4640 (totype > 0 && DTYG(dtypev) != DTY(totype))) {
4641 /* convert to proper character string length or
4642 * convert constant to datatype of symbol */
4643 val = cngcon(val, dtypev, totype);
4644 dtypev = totype;
4645 }
4646 }
4647 dinit_put(dtypev, val);
4648 offset += size_of(dtypev);
4649 break;
4650 case 'e': /* end */
4651 sptr = SPTR_NULL;
4652 dtype = DT_NONE;
4653 tsl = -1;
4654 break;
4655 case 'f': /* format */
4656 val = getval("format");
4657 sptr = symbolxref[val];
4658 offset = 0;
4659 dinit_put(DINIT_LOC, sptr);
4660 sptr = SPTR_NULL; /* don't type-convert */
4661 dtype = DT_NONE;
4662 break;
4663 case 'l': /* location */
4664 val = getval("location");
4665 sptr = symbolxref[val];
4666 dtype = DDTG(DTYPEG(sptr));
4667 offset = 0;
4668 dinit_put(DINIT_LOC, sptr);
4669 push_typestack();
4670 ts[tsl].dtype = DTYPEG(sptr);
4671 ts[tsl].member = SPTR_NULL;
4672 break;
4673 case 'L': { /* Label */
4674 SPTR sptr;
4675 val = getval("Label");
4676 sptr = symbolxref[val];
4677 val = sptr;
4678 dinit_put(DINIT_LABEL, sptr);
4679 if (!UPLEVELG(sptr))
4680 sym_is_refd(sptr);
4681 } break;
4682 case 'n': /* namelist */
4683 val = getval("namelist");
4684 sptr = symbolxref[val];
4685 offset = 0;
4686 dinit_put(DINIT_FUNCCOUNT, gbl.func_count);
4687 dinit_put(DINIT_LOC, sptr);
4688 dinit_put(DINIT_FUNCCOUNT, gbl.func_count);
4689 sptr = SPTR_NULL; /* don't type-convert */
4690 dtype = DT_NONE;
4691 break;
4692 case 'r': /* repeat count */
4693 val = getval("repeat");
4694 dinit_put(DINIT_REPEAT, val);
4695 break;
4696 case 's': /* data symbol and type */
4697 val = getval("symbol");
4698 dtypev = getDtypeVal("datatype");
4699 if (datatypexref[dtypev] == 0) {
4700 fprintf(stderr,
4701 "ILM file line %d: missing data type %d for initialization\n",
4702 ilmlinenum, dtypev);
4703 ++errors;
4704 }
4705 dtypev = datatypexref[dtypev];
4706 val = symbolxref[val];
4707 if (sptr > 0) {
4708 DTYPE totype;
4709 if (tsl == 0) {
4710 totype = dtype;
4711 } else {
4712 dt = ts[tsl].dtype;
4713 totype = DTY(dt) == TY_ARRAY ? DTySeqTyElement(dt) : dt;
4714 }
4715 if (DTYG(dtypev) == TY_HOLL) {
4716 /* convert hollerith string to proper length */
4717 val = cngcon(val, DTYPEG(val), totype);
4718 } else if (DTYG(dtypev) == TY_CHAR || DTYG(dtypev) == TY_NCHAR ||
4719 (totype > 0 && DTYG(dtypev) != DTY(totype))) {
4720 /* convert to proper character string length or
4721 * convert constant to datatype of symbol */
4722 val = cngcon(val, dtypev, totype);
4723 dtypev = totype;
4724 }
4725 if (flg.opt >= 2 && dtypev == dtype && tsl == 0 &&
4726 STYPEG(sptr) == ST_VAR && SCG(sptr) == SC_LOCAL) {
4727 NEED(aux.dvl_avl + 1, aux.dvl_base, DVL, aux.dvl_size,
4728 aux.dvl_size + 32);
4729 DVL_SPTR(aux.dvl_avl) = sptr;
4730 DVL_CONVAL(aux.dvl_avl) = val;
4731 REDUCP(sptr, 1); /* => in dvl table */
4732 aux.dvl_avl++;
4733 }
4734 }
4735 a = alignment(dtypev);
4736 while (a & offset) {
4737 dinit_put(DT_BLOG, 0);
4738 ++offset;
4739 }
4740 dinit_put(dtypev, val);
4741 offset += size_of(dtypev);
4742 break;
4743 case 't': /* typedef start/end */
4744 if (!checkname("typedef")) {
4745 fprintf(stderr,
4746 "ILM file line %d: "
4747 "Error in derived type initialization\n"
4748 "got %s\n",
4749 ilmlinenum, line);
4750 ++errors;
4751 return;
4752 }
4753 skipwhitespace();
4754 if (line[pos] == 's' && checkname("start")) {
4755 if (tsl < 0) {
4756 fprintf(stderr,
4757 "ILM file line %d: "
4758 "unexpected derived type initialization\n",
4759 ilmlinenum);
4760 ++errors;
4761 return;
4762 }
4763 dt = ts[tsl].dtype;
4764 if (DTYG(dt) != TY_STRUCT) {
4765 fprintf(stderr,
4766 "ILM file line %d: "
4767 "structure initialization for non-derived type\n",
4768 ilmlinenum);
4769 ++errors;
4770 return;
4771 }
4772 push_typestack();
4773 ts[tsl].member = DTY(dt) == TY_ARRAY ? DTyAlgTyMember(DTySeqTyElement(dt)) : DTyAlgTyMember(dt);
4774 ts[tsl].dtype = DTYPEG(ts[tsl].member);
4775 movemember = 0;
4776 } else if (line[pos] == 'e' && checkname("end")) {
4777 if (tsl < 0) {
4778 fprintf(stderr,
4779 "ILM file line %d: "
4780 "misplaced end-derived-type\n",
4781 ilmlinenum);
4782 ++errors;
4783 return;
4784 }
4785 --tsl;
4786 } else {
4787 fprintf(stderr,
4788 "ILM file line %d: "
4789 "Error in derived type initialization\n"
4790 "got %s\n",
4791 ilmlinenum, line);
4792 ++errors;
4793 return;
4794 }
4795 break;
4796 case 'v': /* data value and type */
4797 val = getval("value");
4798 dtypev = getDtypeVal("datatype");
4799 if (datatypexref[dtypev] == 0) {
4800 fprintf(stderr,
4801 "ILM file line %d: missing data type %d "
4802 "for initialization\n",
4803 ilmlinenum, dtypev);
4804 ++errors;
4805 }
4806 dtypev = datatypexref[dtypev];
4807 if (sptr > 0) {
4808 DTYPE totype;
4809 if (tsl == 0) {
4810 totype = dtype;
4811 } else {
4812 dt = ts[tsl].dtype;
4813 totype = (DTY(dt) == TY_ARRAY) ? DTySeqTyElement(dt) : dt;
4814 }
4815 if (DTYG(dtypev) == TY_CHAR || DTYG(dtypev) == TY_NCHAR ||
4816 (totype > 0 && DTYG(dtypev) != DTY(totype))) {
4817 if (DTY(totype) == TY_CHAR && DTySeqTyElement(totype) == 1) {
4818 /* special case of initializing char*1 to numeric */
4819 if (DT_ISINT(dtypev) && !DT_ISLOG(dtypev)) {
4820 /* integer value, not symbol */
4821 char buf[2];
4822 if (val < 0 || val > 255) {
4823 buf[0] = val & 0xff;
4824 } else {
4825 buf[0] = val;
4826 }
4827 buf[1] = 0;
4828 val = getstring(buf, 1);
4829 dtypev = DT_CHAR;
4830 }
4831 }
4832 val = cngcon(val, dtypev, totype);
4833 dtypev = totype;
4834 }
4835 if (flg.opt >= 2 && dtypev == dtype && tsl == 0 &&
4836 STYPEG(sptr) == ST_VAR && SCG(sptr) == SC_LOCAL) {
4837 NEED(aux.dvl_avl + 1, aux.dvl_base, DVL, aux.dvl_size,
4838 aux.dvl_size + 32);
4839 DVL_SPTR(aux.dvl_avl) = sptr;
4840 DVL_CONVAL(aux.dvl_avl) = val;
4841 REDUCP(sptr, 1); /* => in dvl table */
4842 aux.dvl_avl++;
4843 }
4844 }
4845 a = alignment(dtypev);
4846 while (a & offset) {
4847 dinit_put(DT_BLOG, 0);
4848 ++offset;
4849 }
4850 dinit_put(dtypev, val);
4851 offset += size_of(dtypev);
4852 break;
4853 }
4854 if (movemember && tsl > 0 && ts[tsl].member > 0) {
4855 ts[tsl].member = SYMLKG(ts[tsl].member);
4856 ts[tsl].dtype = DTYPEG(ts[tsl].member);
4857 }
4858 } /* read_init */
4859
4860 static void
Begindata(void)4861 Begindata(void)
4862 {
4863 dataivl = lastivl = NULL;
4864 dataict = lastict = outerict = NULL;
4865 /* prepare stack */
4866 ilmb.ilmavl = BOS_SIZE;
4867 } /* Begindata */
4868
4869 static void
Writedata(void)4870 Writedata(void)
4871 {
4872 dinit(dataivl, dataict);
4873 } /* Writedata */
4874
4875 static void
dataDo(void)4876 dataDo(void)
4877 {
4878 VAR *ivl;
4879 if (!checkname("Do")) {
4880 fprintf(stderr, "ILM file line %d: Error in data Do record\ngot %s\n",
4881 ilmlinenum, line);
4882 ++errors;
4883 return;
4884 }
4885 ivl = (VAR *)getitem(5, sizeof(VAR));
4886 BZERO(ivl, VAR, 1);
4887 ivl->id = Dostart;
4888 ivl->u.dostart.indvar = getoperand("ilm", chilm);
4889 ivl->u.dostart.lowbd = getoperand("ilm", chilm);
4890 ivl->u.dostart.upbd = getoperand("ilm", chilm);
4891 ivl->u.dostart.step = getoperand("ilm", chilm);
4892 data_add_ivl(ivl);
4893 push((int *)ivl);
4894 } /* dataDo */
4895
4896 static void
dataEnddo(void)4897 dataEnddo(void)
4898 {
4899 VAR *ivl;
4900 if (!checkname("Enddo")) {
4901 fprintf(stderr, "ILM file line %d: Error in data Enddo record\ngot %s\n",
4902 ilmlinenum, line);
4903 ++errors;
4904 return;
4905 }
4906 ivl = (VAR *)getitem(5, sizeof(VAR));
4907 BZERO(ivl, VAR, 1);
4908 ivl->id = Doend;
4909 ivl->u.doend.dostart = (VAR *)pop();
4910 data_add_ivl(ivl);
4911 } /* dataEnddo */
4912
4913 static void
dataReference(void)4914 dataReference(void)
4915 {
4916 VAR *ivl;
4917 if (!checkname("Reference")) {
4918 fprintf(stderr,
4919 "ILM file line %d: Error in data Reference record\ngot %s\n",
4920 ilmlinenum, line);
4921 ++errors;
4922 return;
4923 }
4924 ivl = (VAR *)getitem(5, sizeof(VAR));
4925 BZERO(ivl, VAR, 1);
4926 ivl->id = Varref;
4927 ivl->u.varref.id = S_LVALUE;
4928 ivl->u.varref.ptr = getoperand("ilm", chilm);
4929 ivl->u.varref.dtype = getDtypeOperand("datatype", chdtype);
4930 ivl->u.varref.shape = 0;
4931 data_add_ivl(ivl);
4932 } /* dataReference */
4933
4934 static void
dataVariable(void)4935 dataVariable(void)
4936 {
4937 VAR *ivl;
4938 if (!checkname("Variable")) {
4939 fprintf(stderr, "ILM file line %d: Error in data Variable record\ngot %s\n",
4940 ilmlinenum, line);
4941 ++errors;
4942 return;
4943 }
4944 ivl = (VAR *)getitem(5, sizeof(VAR));
4945 BZERO(ivl, VAR, 1);
4946 ivl->id = Varref;
4947 ivl->u.varref.id = S_IDENT;
4948 ivl->u.varref.ptr = getoperand("ilm", chilm);
4949 ivl->u.varref.dtype = getDtypeOperand("datatype", chdtype);
4950 ivl->u.varref.shape = 0;
4951 data_add_ivl(ivl);
4952 } /* dataVariable */
4953
4954 static void
dataConstant(void)4955 dataConstant(void)
4956 {
4957 CONST *ict;
4958
4959 if (!checkname("Constant")) {
4960 fprintf(stderr, "ILM file line %d: Error in data Constant record\ngot %s\n",
4961 ilmlinenum, line);
4962 ++errors;
4963 return;
4964 }
4965
4966 skipwhitespace();
4967 switch (line[pos]) {
4968 case 'C':
4969 getval("CONSTANT");
4970 ict = (CONST *)getitem(4, sizeof(CONST));
4971 BZERO(ict, CONST, 1);
4972 ict->id = AC_CONST;
4973 ict->repeatc = getoperand("number", chnum);
4974 ict->dtype = getDtypeOperand("datatype", chdtype);
4975 ict->sptr = getSptrOperand("symbol", chsym);
4976 if (ict->sptr && DTY(DTYPEG(ict->sptr)) == TY_PTR) {
4977 /* ict->sptr != 0 ==> component initialization. Assigning
4978 * something (0 from NULL()) to a pointer.
4979 * The type of the pointer was changed late in lower()
4980 * after this constant was written. Change the type
4981 * to avoid errors in dinit */
4982 ict->dtype = DT_ADDR;
4983 }
4984 skipwhitespace();
4985 if (line[pos] == 'n') {
4986 ict->u1.conval = getoperand("number", chnum);
4987 } else if (line[pos] == 's') {
4988 ict->u1.conval = getoperand("symbol", chsym);
4989 } else {
4990 fprintf(
4991 stderr,
4992 "ILM file line %d: error in Constant line: unknown value\ngot %s\n",
4993 ilmlinenum, line);
4994 ++errors;
4995 return;
4996 }
4997 data_add_const(ict);
4998 break;
4999 case 'L':
5000 getval("LITRLINT");
5001 ict = (CONST *)getitem(4, sizeof(CONST));
5002 BZERO(ict, CONST, 1);
5003 ict->id = AC_CONST;
5004 ict->u1.conval = getoperand("number", chnum);
5005 ict->dtype = DT_INT;
5006 data_add_const(ict);
5007 break;
5008 case 'I':
5009 getval("ID");
5010 ict = (CONST *)getitem(4, sizeof(CONST));
5011 BZERO(ict, CONST, 1);
5012 ict->id = AC_IDENT;
5013 ict->repeatc = getoperand("number", chnum);
5014 ict->dtype = getDtypeOperand("datatype", chdtype);
5015 ict->sptr = getSptrOperand("symbol", chsym);
5016 if (STYPEG(ict->sptr) == ST_PARAM) {
5017 ict->sptr = SymConval1(ict->sptr);
5018 }
5019 ict->mbr = getSptrOperand("symbol", chsym);
5020 data_add_const(ict);
5021 break;
5022 case 'D':
5023 getval("DO");
5024 ict = (CONST *)getitem(4, sizeof(CONST));
5025 BZERO(ict, CONST, 1);
5026 ict->id = AC_IDO;
5027 ict->u1.ido.index_var = getSptrOperand("do index var", chsym);
5028 ict->repeatc = 1;
5029 data_add_const(ict);
5030 init_list_count++; /* need an place to do idx value */
5031 do_level++;
5032 break;
5033 case 'd':
5034 getval("doend");
5035 if (!do_level--) {
5036 fprintf(stderr, "ILM file line %d: error in Constant: unexpected doend\n",
5037 ilmlinenum);
5038 ++errors;
5039 return;
5040 }
5041 data_pop_const();
5042 break;
5043 case 'B':
5044 getval("BOUNDS");
5045 data_push_const();
5046 break;
5047 case 'b':
5048 getval("boundsend");
5049 data_pop_const();
5050 if (lastict->u1.ido.initval == 0) {
5051 lastict->u1.ido.initval = lastict->subc;
5052 } else if (lastict->u1.ido.limitval == 0) {
5053 lastict->u1.ido.limitval = lastict->subc;
5054 } else {
5055 lastict->u1.ido.stepval = lastict->subc;
5056 data_push_const();
5057 }
5058 break;
5059 case 'A':
5060 getval("ARRAY");
5061 in_array_ctor++;
5062 ict = (CONST *)getitem(4, sizeof(CONST));
5063 BZERO(ict, CONST, 1);
5064 ict->id = AC_ACONST;
5065 ict->sptr = getSptrOperand("symbol", chsym);
5066 ict->dtype = getDtypeOperand("datatype", chdtype);
5067 ict->repeatc = 1;
5068 data_add_const(ict);
5069 data_push_const();
5070 break;
5071 case 'a':
5072 getval("arrayend");
5073 if (--in_array_ctor < 0) {
5074 fprintf(stderr,
5075 "ILM file line %d: error in Constant: too many arrayends\n",
5076 ilmlinenum);
5077 ++errors;
5078 return;
5079 }
5080 data_pop_const();
5081 break;
5082 case 'E':
5083 getval("EXPR");
5084 ict = (CONST *)getitem(4, sizeof(CONST));
5085 BZERO(ict, CONST, 1);
5086 ict->id = AC_IEXPR;
5087 ict->repeatc = getoperand("number", chnum);
5088 ict->u1.expr.op = getoperand("expression operator", chnum);
5089 if (AC_UNARY_OP(ict->u1.expr)) {
5090 oprnd_cnt += 1;
5091 } else {
5092 oprnd_cnt += 2;
5093 }
5094 ict->sptr = getSptrOperand("symbol", chsym);
5095 ict->dtype = getDtypeOperand("datatype", chdtype);
5096 data_add_const(ict);
5097 break;
5098 case 'O':
5099 getval("OPERAND");
5100 if (!(oprnd_cnt)) {
5101 fprintf(stderr,
5102 "ILM file line %d: error in Constant: unexpected "
5103 "expression operand\n",
5104 ilmlinenum);
5105 ++errors;
5106 return;
5107 }
5108 data_push_const();
5109 break;
5110 case 'o':
5111 getval("operandend");
5112 if (!(oprnd_cnt--)) {
5113 fprintf(stderr,
5114 "ILM file line %d: error in Constant: unexpected "
5115 "expression operand end\n",
5116 ilmlinenum);
5117 ++errors;
5118 return;
5119 }
5120 data_pop_const();
5121 if (lastict->u1.expr.lop == 0) {
5122 lastict->u1.expr.lop = lastict->subc;
5123 } else {
5124 lastict->u1.expr.rop = lastict->subc;
5125 }
5126 lastict->subc = 0;
5127 break;
5128 default:
5129 fprintf(stderr,
5130 "ILM file line %d: error in Constant: unknown constant type\n",
5131 ilmlinenum);
5132 ++errors;
5133 return;
5134 break;
5135 }
5136
5137 } /* dataConstant */
5138
5139 static void
dataStructure(void)5140 dataStructure(void)
5141 {
5142 CONST *ict;
5143 if (!checkname("structure")) {
5144 fprintf(stderr,
5145 "ILM file line %d: Error in data structure record\ngot %s\n",
5146 ilmlinenum, line);
5147 ++errors;
5148 return;
5149 }
5150 ict = (CONST *)getitem(4, sizeof(CONST));
5151 BZERO(ict, CONST, 1);
5152 ict->id = AC_SCONST;
5153 ict->repeatc = getoperand("number", chnum);
5154 ict->dtype = getDtypeOperand("datatype", chdtype);
5155 ict->sptr = getSptrOperand("symbol", chsym);
5156 ict->no_dinitp = getoperand("number", chnum);
5157 data_add_const(ict);
5158 data_push_const();
5159 } /* dataConstant */
5160
5161 /*
5162 * read file entries
5163 */
5164 static void
read_fileentries(void)5165 read_fileentries(void)
5166 {
5167 int fihx, tag, parent, flags, lineno, srcline, level, next;
5168 int dirlen, filelen, funclen, fullnlen;
5169 char *dirname, *filename, *funcname, *fullname;
5170
5171 fihx = getval("fihx");
5172 tag = getlval("tag");
5173 parent = getval("parent");
5174 flags = getval("flags");
5175 lineno = getval("lineno");
5176 srcline = getval("srcline");
5177 level = getval("level");
5178 next = getval("next");
5179
5180 dirlen = getnamelen();
5181 dirname = line + pos;
5182 pos += dirlen;
5183
5184 filelen = getnamelen();
5185 filename = line + pos;
5186 pos += filelen;
5187
5188 funclen = getnamelen();
5189 funcname = line + pos;
5190 pos += funclen;
5191
5192 fullnlen = getnamelen();
5193 fullname = line + pos;
5194 pos += fullnlen;
5195
5196 dirname[dirlen] = '\0';
5197 filename[filelen] = '\0';
5198 funcname[funclen] = '\0';
5199 fullname[fullnlen] = '\0';
5200
5201 if (funclen == 0)
5202 funcname = NULL;
5203
5204 if (fihx > 1) {
5205 addfile(fullname, funcname, tag, flags, lineno, srcline, level);
5206 FIH_PARENT(fihx) = parent;
5207 }
5208 }
5209
5210 /*
5211 * read symbol for which GSCOPE must be set
5212 */
5213 static void
read_global(void)5214 read_global(void)
5215 {
5216 int sptr;
5217 sptr = getval("global");
5218 sptr = symbolxref[sptr];
5219 if (sptr > NOSYM) {
5220 GSCOPEP(sptr, 1);
5221 }
5222 } /* read_global */
5223
5224 /*
5225 * Read CCFF messages, save in the CCFF message database
5226 */
5227 static int
read_CCFF(void)5228 read_CCFF(void)
5229 {
5230 int endilmfile;
5231 int fihx;
5232 if (!checkname("CCFF")) {
5233 fprintf(stderr, "ILM file line %d: Expecting CCFF info, got %s\n",
5234 ilmlinenum, line);
5235 ++errors;
5236 return 0;
5237 }
5238 fihx = 1;
5239 do {
5240 /* CCFFinl
5241 * CCFFlni
5242 * CCFFmsg
5243 * CCFFarg
5244 * CCFFtxt
5245 * CCFFend */
5246 int seq, lineno, msgtype;
5247 char *symname, *msgid, *funcname;
5248 char *argname, *argval, *text;
5249
5250 endilmfile = read_line();
5251 if (endilmfile)
5252 return endilmfile;
5253 if (strncmp(line, "CCFF", 4) != 0) {
5254 fprintf(stderr, "ILM file line %d: Expecting CCFF data, got %s\n",
5255 ilmlinenum, line);
5256 ++errors;
5257 return 0;
5258 }
5259 switch (line[4]) {
5260 case 'i': /* CCFFinl */
5261 pos = 8;
5262 break;
5263 case 'l': /* CCFFlni */
5264 pos = 8;
5265 break;
5266 case 'm': /* CCFFmsg */
5267 pos = 8;
5268 seq = getval("seq");
5269 lineno = getval("lineno");
5270 msgtype = getval("type");
5271 symname = getname();
5272 funcname = getname();
5273 msgid = getname();
5274 save_ccff_msg(msgtype, msgid, fihx, lineno, symname, funcname);
5275 break;
5276 case 'a': /* CCFFarg */
5277 pos = 8;
5278 argname = getname();
5279 argval = getname();
5280 save_ccff_arg(argname, argval);
5281 break;
5282 case 't': /* CCFFtxt */
5283 pos = 8;
5284 text = line + pos;
5285 save_ccff_text(text);
5286 break;
5287 case 'e': /* CCFFend */
5288 return 0;
5289 break;
5290 }
5291 } while (1);
5292 } /* read_CCFF */
5293
5294 /*
5295 * read a host subprogram entry symbol
5296 */
5297 static void
read_Entry(void)5298 read_Entry(void)
5299 {
5300 SPTR sptr;
5301 int outersub;
5302 sptr = getSptrVal("Entry");
5303 sptr = symbolxref[sptr];
5304 if (sptr > NOSYM && gbl.outersub) {
5305 outersub = symbolxref[gbl.outersub];
5306 if (SYMLKG(outersub) == 0) {
5307 SYMLKP(outersub, NOSYM);
5308 }
5309 SYMLKP(sptr, SYMLKG(outersub));
5310 SYMLKP(outersub, sptr);
5311 }
5312 } /* read_Entry */
5313
5314 /*
5315 * read names of contained subprograms
5316 */
5317 static void
read_contained(void)5318 read_contained(void)
5319 {
5320 int namelen, hashid, sptr;
5321 char *ch;
5322 if (!checkname("contained")) {
5323 fprintf(stderr,
5324 "ILM file line %d: Expecting contained routine name, got %s\n",
5325 ilmlinenum, line);
5326 ++errors;
5327 return;
5328 }
5329 if (gbl.internal == 1)
5330 ++gbl.numcontained;
5331 namelen = getnamelen();
5332 ch = line + pos;
5333 ch[namelen] = '\0';
5334 HASH_ID(hashid, ch, namelen);
5335 if (hashid < 0)
5336 hashid = -hashid;
5337 /* look for the symbol */
5338 for (sptr = stb.hashtb[hashid]; sptr > NOSYM; sptr = HASHLKG(sptr)) {
5339 switch (STYPEG(sptr)) {
5340 case ST_PROC:
5341 case ST_ENTRY:
5342 if (!INMODULEG(sptr) && strcmp(ch, SYMNAME(sptr)) == 0) {
5343 CONTAINEDP(sptr, 1);
5344 return;
5345 }
5346 break;
5347 default:
5348 break;
5349 }
5350 }
5351 /* not found for this subprogram, must be no calls to it */
5352 } /* read_contained */
5353
5354 /* Replicate prefix string a number of times */
5355 static void
put_prefix(FILE * dfile,char * str,int cnt)5356 put_prefix(FILE *dfile, char *str, int cnt)
5357 {
5358 int i;
5359
5360 fprintf(dfile, " ");
5361 for (i = 0; i < cnt; i++)
5362 fprintf(dfile, "%s", str);
5363 }
5364
5365 void
dmp_const(CONST * acl,int indent)5366 dmp_const(CONST *acl, int indent)
5367 {
5368 CONST *c_aclp;
5369 char two_spaces[3] = " ";
5370 FILE *dfile;
5371
5372 dfile = gbl.dbgfil ? gbl.dbgfil : stderr;
5373
5374 if (!acl) {
5375 return;
5376 }
5377
5378 if (indent == 0)
5379 fprintf(dfile, "line %d:\n", gbl.lineno);
5380
5381 for (c_aclp = acl; c_aclp; c_aclp = c_aclp->next) {
5382 switch (c_aclp->id) {
5383 case AC_IDENT:
5384 put_prefix(dfile, two_spaces, indent);
5385 fprintf(dfile, "AC_IDENT: '%s' (%d), repeatc=%ld\n",
5386 SYMNAME(c_aclp->sptr), c_aclp->sptr, c_aclp->repeatc);
5387 break;
5388 case AC_CONST:
5389 put_prefix(dfile, two_spaces, indent);
5390 fprintf(dfile, "AC_CONST: %d, sptr %d repeatc=%ld\n", c_aclp->u1.conval,
5391 c_aclp->sptr, c_aclp->repeatc);
5392 break;
5393 case AC_IEXPR:
5394 put_prefix(dfile, two_spaces, indent);
5395 fprintf(dfile, "AC_IEXPR: op %d, repeatc %ld\n", c_aclp->u1.expr.op,
5396 c_aclp->repeatc);
5397 dmp_const(c_aclp->u1.expr.lop, indent + 1);
5398 dmp_const(c_aclp->u1.expr.rop, indent + 1);
5399 break;
5400 case AC_IDO:
5401 put_prefix(dfile, two_spaces, indent);
5402 fprintf(dfile,
5403 "AC_IDO: sptr %d, index var sptr %d, init val %p, "
5404 "limit val %p, step val %p, repeatc %ld\n",
5405 c_aclp->sptr, c_aclp->u1.ido.index_var, c_aclp->u1.ido.initval,
5406 c_aclp->u1.ido.limitval, c_aclp->u1.ido.stepval, c_aclp->repeatc);
5407 put_prefix(dfile, two_spaces, indent);
5408 fprintf(dfile, " Initialization Values:\n");
5409 dmp_const(c_aclp->subc, indent + 1);
5410 break;
5411 case AC_ACONST:
5412 put_prefix(dfile, two_spaces, indent);
5413 fprintf(dfile, "AC_ACONST: sptr %d, repeatc %ld\n", c_aclp->sptr,
5414 c_aclp->repeatc);
5415 put_prefix(dfile, two_spaces, indent);
5416 fprintf(dfile, " Initialization Values:\n");
5417 dmp_const(c_aclp->subc, indent + 1);
5418 break;
5419 case AC_SCONST:
5420 put_prefix(dfile, two_spaces, indent);
5421 fprintf(dfile, "AC_SCONST: sptr %d, repeatc %ld\n", c_aclp->sptr,
5422 c_aclp->repeatc);
5423 put_prefix(dfile, two_spaces, indent);
5424 fprintf(dfile, " Initialization Values:\n");
5425 dmp_const(c_aclp->subc, indent + 1);
5426 break;
5427 default:
5428 put_prefix(dfile, two_spaces, indent);
5429 fprintf(dfile, "*** UNKNOWN/UNUSED CONST id %d\n", c_aclp->id);
5430 break;
5431 }
5432 }
5433 }
5434
5435 /*
5436 * given string and some other information, produce the
5437 * external name that assem will produce
5438 * (copied from ipasave.c)
5439 */
5440 char *
getexnamestring(char * string,int sptr,int stype,int scg,int extraunderscore)5441 getexnamestring(char *string, int sptr, int stype, int scg, int extraunderscore)
5442 {
5443 static char *id = NULL;
5444 static int idsize = 0;
5445 char *s;
5446 s = string;
5447 if (idsize == 0) {
5448 idsize = 200;
5449 NEW(id, char, idsize);
5450 }
5451 if (s[0] == '.') {
5452 sprintf(id, "%s%d", s, sptr);
5453 } else {
5454 char *ss;
5455 int l, ll;
5456 int has_underscore;
5457 l = 0;
5458 switch (stype) {
5459 case ST_VAR:
5460 case ST_ARRAY:
5461 case ST_STRUCT:
5462 case ST_UNION:
5463 ll = strlen(s);
5464 /* l+ll+2 = ll for string, 1 for optional _, 1 for null */
5465 NEED(l + ll + 2, id, char, idsize, l + ll + 200);
5466 switch (scg) {
5467 case SC_EXTERN:
5468 id[l++] = '_';
5469 break;
5470 default:
5471 break;
5472 }
5473 strcpy(id + l, s);
5474 l += ll;
5475 break;
5476 case ST_ENTRY:
5477 case ST_PROC:
5478 if (gbl.internal >= 1 && CONTAINEDG(sptr)) {
5479 int m;
5480 m = INMODULEG(gbl.outersub);
5481 if (m) {
5482 ss = SYMNAME(m);
5483 ll = strlen(ss);
5484 NEED(l + ll + 1, id, char, idsize, l + ll + 200);
5485 for (; *ss; ++ss) {
5486 if (*ss == '$') {
5487 id[l++] = flg.dollar;
5488 } else {
5489 id[l++] = *ss;
5490 }
5491 }
5492 id[l++] = '_';
5493 }
5494 ss = SYMNAME(gbl.outersub);
5495 ll = strlen(ss);
5496 NEED(l + ll + 1, id, char, idsize, l + ll + 200);
5497 for (; *ss; ++ss) {
5498 if (*ss == '$') {
5499 id[l++] = flg.dollar;
5500 } else {
5501 id[l++] = *ss;
5502 }
5503 }
5504 id[l++] = '_';
5505 ss = SYMNAME(sptr);
5506 ll = strlen(ss);
5507 NEED(l + ll + 1, id, char, idsize, l + ll + 200);
5508 for (; *ss; ++ss) {
5509 if (*ss == '$') {
5510 id[l++] = flg.dollar;
5511 } else {
5512 id[l++] = *ss;
5513 }
5514 }
5515 id[l] = '\0';
5516 } else {
5517 int m;
5518 if (XBIT(119, 0x1000)) { /* add leading underscore */
5519 NEED(l + 1, id, char, idsize, l + 200);
5520 id[l++] = '_';
5521 }
5522 m = INMODULEG(sptr);
5523 if (m) {
5524 ss = SYMNAME(m);
5525 ll = strlen(ss);
5526 NEED(l + ll + 1, id, char, idsize, l + ll + 200);
5527 for (; *ss; ++ss) {
5528 if (*ss == '$') {
5529 id[l++] = flg.dollar;
5530 } else {
5531 id[l++] = *ss;
5532 }
5533 }
5534 id[l++] = '_';
5535 }
5536 has_underscore = 0;
5537 ll = strlen(s);
5538 /* l+ll+3 = ll for string, 2 for optional __, 1 for null */
5539 NEED(l + ll + 3, id, char, idsize, l + ll + 200);
5540 for (ss = s; *ss; ++ss) {
5541 if (*ss == '_') {
5542 id[l++] = *ss;
5543 has_underscore = 1;
5544 } else if (*ss == '$') {
5545 id[l++] = flg.dollar;
5546 } else {
5547 id[l++] = *ss;
5548 }
5549 }
5550 id[l] = '\0';
5551 }
5552 if (stype == ST_ENTRY || extraunderscore) {
5553 if (!XBIT(119, 0x01000000)) {
5554 id[l++] = '_';
5555 if (XBIT(119, 0x2000000) && has_underscore && !LIBSYMG(sptr)) {
5556 id[l++] = '_';
5557 }
5558 }
5559 }
5560 id[l] = '\0';
5561 #if defined(TARGET_WIN_X86) && defined(PGFTN)
5562 if (STYPEG(sptr) == ST_CMBLK && !CCSYMG(sptr) && XBIT(119, 0x01000000))
5563 upcase_name(id);
5564 if ((STYPEG(sptr) == ST_ENTRY || STYPEG(sptr) == ST_PROC) &&
5565 MSCALLG(sptr) && !STDCALLG(sptr))
5566 upcase_name(id);
5567 #endif
5568 break;
5569 case ST_CMBLK: /* just leading/trailing underscores */
5570 if (XBIT(119, 0x1000)) { /* add leading underscore */
5571 NEED(l + 1, id, char, idsize, l + 200);
5572 id[l++] = '_';
5573 }
5574 has_underscore = 0;
5575 ll = strlen(s);
5576 /* l+ll+3 = ll for string, 2 for optional __, 1 for null */
5577 NEED(l + ll + 1, id, char, idsize, l + ll + 200);
5578 for (ss = s; *ss; ++ss) {
5579 if (*ss == '_') {
5580 id[l++] = *ss;
5581 has_underscore = 1;
5582 } else if (*ss == '$') {
5583 id[l++] = flg.dollar;
5584 } else {
5585 id[l++] = *ss;
5586 }
5587 }
5588 id[l] = '\0';
5589 break;
5590 default:
5591 ll = strlen(s);
5592 NEED(l + ll + 1, id, char, idsize, l + ll + 200);
5593 strcpy(id + l, s);
5594 l += ll;
5595 break;
5596 }
5597 }
5598 return id;
5599 } /* getexnamestring */
5600
5601 /*
5602 * find index for sptr, or add one
5603 */
5604 static int
newindex(int sptr)5605 newindex(int sptr)
5606 {
5607 int l, h, i, j;
5608 l = 0;
5609 h = ipab.indexavl - 1;
5610 while (l <= h) {
5611 i = (l + h) >> 1; /* (l+h)/2 */
5612 if (IPNDX_SPTR(i) > sptr) {
5613 h = i - 1;
5614 } else if (IPNDX_SPTR(i) < sptr) {
5615 l = i + 1;
5616 } else {
5617 break;
5618 }
5619 }
5620 if (l <= h) { /* found it */
5621 return i;
5622 }
5623 NEED(ipab.indexavl + 1, ipab.index, IPAindex, ipab.indexsize,
5624 ipab.indexsize + 100);
5625 i = h + 1; /* where to insert */
5626 for (j = ipab.indexavl - 1; j >= i; --j) {
5627 IPNDX_SPTR(j + 1) = IPNDX_SPTR(j);
5628 IPNDX_INFO(j + 1) = IPNDX_INFO(j);
5629 }
5630 ++ipab.indexavl;
5631 IPNDX_SPTR(i) = sptr;
5632 IPNDX_INFO(i) = 0;
5633 Trace(("add info index for symbol %d:%s at index %d of %d", sptr,
5634 SYMNAME(sptr), i, ipab.indexavl));
5635 return i;
5636 } /* newindex */
5637
5638 /*
5639 * return new ipab.info index
5640 */
5641 static int
newinfo(void)5642 newinfo(void)
5643 {
5644 int i = ipab.infoavl;
5645 ++ipab.infoavl;
5646 NEED(ipab.infoavl, ipab.info, IPAinfo, ipab.infosize, ipab.infosize + 100);
5647 return i;
5648 } /* newinfo */
5649
5650 /*
5651 * find index for sptr or return -1
5652 */
5653 static int
findindex(int sptr)5654 findindex(int sptr)
5655 {
5656 int l, h, i, j;
5657 l = 0;
5658 h = ipab.indexavl - 1;
5659 while (l <= h) {
5660 i = (l + h) >> 1; /* (l+h)/2 */
5661 if (IPNDX_SPTR(i) > sptr) {
5662 h = i - 1;
5663 } else if (IPNDX_SPTR(i) < sptr) {
5664 l = i + 1;
5665 } else {
5666 break;
5667 }
5668 }
5669 if (l <= h) { /* found it */
5670 return i;
5671 }
5672 return -1;
5673 } /* findindex */
5674
5675 /**
5676 * return -1 if nme1/nme2 point to the same address;
5677 * return 0 if they point to different addresses;
5678 * return 1 if they may point to the same address
5679 */
5680 int
IPA_nme_conflict(int nme1,int nme2)5681 IPA_nme_conflict(int nme1, int nme2)
5682 {
5683 int t2, vnme1, sym1, sym2, i1, n1;
5684
5685 if (!XBIT(89, 0x100) || XBIT(89, 0x80))
5686 return 1;
5687
5688 /* nme1 must be an indirection; see if we have information about it */
5689 if (NME_TYPE(nme1) != NT_IND)
5690 return 1;
5691 /* single direction? */
5692 vnme1 = NME_NM(nme1);
5693 if (NME_TYPE(vnme1) != NT_VAR)
5694 return 1;
5695 sym1 = NME_SYM(vnme1);
5696 n1 = findindex(sym1);
5697 if (n1 < 0)
5698 return 1;
5699 i1 = IPNDX_INFO(n1);
5700
5701 t2 = NME_TYPE(nme2);
5702 if (t2 == NT_VAR) {
5703 int j1, count;
5704 /* see if nme2 is in the list of symbols pointed to by nme1 */
5705 sym2 = NME_SYM(nme2);
5706 count = 0;
5707 for (j1 = i1; j1 > 0; j1 = IPNFO_NEXT(j1)) {
5708 switch (IPNFO_TYPE(j1)) {
5709 case INFO_LTARGET:
5710 case INFO_GTARGET:
5711 if (IPNFO_TARGET(j1) == sym2) {
5712 if (j1 == i1 && IPNFO_NEXT(j1) == 0 && IPNFO_INDIRECT(j1) == 0 &&
5713 IPNFO_IMPRECISE(j1) == 0) {
5714 /* the only target, no stars, not imprecise */
5715 return -1;
5716 }
5717 return 1;
5718 }
5719 ++count;
5720 break;
5721 case INFO_OGTARGET:
5722 case INFO_OTARGET:
5723 ++count;
5724 break;
5725 }
5726 /* if we have some targets, none of them are this symbol */
5727 if (count) {
5728 ++IPA_Pointer_Targets_Disambiguated;
5729 return 0;
5730 }
5731 }
5732 } else if (t2 == NT_IND) {
5733 int vnme2, i2, j1, count1, n2;
5734 /* t2 is an indirection, too; see if we have info about it! */
5735 /* single direction? */
5736 vnme2 = NME_NM(nme2);
5737 if (NME_TYPE(vnme2) != NT_VAR)
5738 return 1;
5739 sym2 = NME_SYM(vnme2);
5740 n2 = findindex(sym2);
5741 if (n2 < 0)
5742 return 1;
5743 i2 = IPNDX_INFO(n2);
5744
5745 /* two pointers, we have information about both pointers;
5746 * they may point to the same item precisely: SAME
5747 * they may point to to different items: NO CONFLICT
5748 * otherwise: CONFLICT */
5749 if (IPNFO_NEXT(i1) == 0 && IPNFO_NEXT(i2) == 0) {
5750 /* Both the same type, both precise? */
5751 if (IPNFO_TYPE(i1) == IPNFO_TYPE(i2)) {
5752 switch (IPNFO_TYPE(i1)) {
5753 case INFO_LTARGET:
5754 case INFO_GTARGET:
5755 if (IPNFO_IMPRECISE(i1) == 0 && IPNFO_IMPRECISE(i2) == 0) {
5756 /* same symbol? */
5757 if (IPNFO_TARGET(i1) == IPNFO_TARGET(i2) &&
5758 IPNFO_TARGET(i1) != sym1 && IPNFO_TARGET(i1) != sym2 &&
5759 IPNFO_INDIRECT(i1) == IPNFO_INDIRECT(i2)) {
5760 /* only one target, same target */
5761 return -1;
5762 }
5763 }
5764 break;
5765 case INFO_OTARGET:
5766 case INFO_OGTARGET:
5767 if (IPNFO_IMPRECISE(i1) == 0 && IPNFO_IMPRECISE(i2) == 0) {
5768 /* same symbol? */
5769 if (IPNFO_TARGET(i1) == IPNFO_TARGET(i2) &&
5770 IPNFO_INDIRECT(i1) == IPNFO_INDIRECT(i2)) {
5771 /* only one target, same target */
5772 return -1;
5773 }
5774 }
5775 break;
5776 }
5777 }
5778 }
5779 count1 = 0;
5780 for (j1 = i1; j1 > 0; j1 = IPNFO_NEXT(j1)) {
5781 int j2;
5782 switch (IPNFO_TYPE(j1)) {
5783 case INFO_LTARGET:
5784 if (IPNFO_TARGET(j1) == sym1) {
5785 /* S1 -> *S1, ignore */
5786 continue;
5787 }
5788 if (IPNFO_TARGET(j1) == sym2) {
5789 /* probably S1 -> *S2, conflict */
5790 return 1;
5791 }
5792 /* fall through */
5793 case INFO_GTARGET:
5794 case INFO_OGTARGET:
5795 case INFO_OTARGET:
5796 ++count1;
5797 /* look for this pointee in the i2 list */
5798 for (j2 = i2; j2 > 0; j2 = IPNFO_NEXT(j2)) {
5799 if (IPNFO_TYPE(j2) == IPNFO_TYPE(j1) &&
5800 IPNFO_TARGET(j2) == IPNFO_TARGET(j1)) {
5801 /* S2 -> Y and S1 -> Y */
5802 return 1;
5803 }
5804 }
5805 }
5806 }
5807 /* no shared targets, independent */
5808 if (count1) {
5809 ++IPA_Pointer_Targets_Disambiguated;
5810 return 0;
5811 }
5812 }
5813 return 1;
5814 } /* IPA_nme_conflict */
5815
5816 /** \brief Detect Fortran 90 name conflicts.
5817 *
5818 * return -1 if nme1/nme2 point to the same address;
5819 * return 0 if they point to different addresses;
5820 * return 1 if they may point to the same address
5821 */
5822 int
F90_nme_conflict(int nme1,int nme2)5823 F90_nme_conflict(int nme1, int nme2)
5824 {
5825 int t2, vnme1, sym1, sym2, i1, n1;
5826
5827 /* special case: see if at least one of these input pointers is a structure member */
5828 if (F90_struct_mbr_nme_conflict(nme1, nme2) == 0) {
5829 return 0;
5830 }
5831 /* nme1 must be an indirection; see if we have information about it */
5832 if (NME_TYPE(nme1) != NT_IND)
5833 return 1;
5834 /* single direction? */
5835 vnme1 = NME_NM(nme1);
5836 if (NME_TYPE(vnme1) != NT_VAR)
5837 return 1;
5838 sym1 = NME_SYM(vnme1);
5839 n1 = findindex(sym1);
5840 if (n1 < 0)
5841 return 1;
5842 i1 = IPNDX_INFO(n1);
5843
5844 t2 = NME_TYPE(nme2);
5845 if (t2 == NT_VAR) {
5846 int j1, count;
5847 sym2 = NME_SYM(nme2);
5848 /* see if sym2 is in the list of symbols pointed to by nme1 */
5849 count = 0;
5850 for (j1 = i1; j1 > 0; j1 = IPNFO_NEXT(j1)) {
5851 switch (IPNFO_TYPE(j1)) {
5852 case INFO_FSTARGET:
5853 if (IPNFO_TARGET(j1) == sym2) {
5854 return 1;
5855 }
5856 ++count;
5857 break;
5858 case INFO_FLDYNTARGET:
5859 case INFO_FGDYNTARGET:
5860 case INFO_FOTARGET:
5861 case INFO_FOSTARGET:
5862 ++count;
5863 break;
5864 case INFO_FUNKTARGET:
5865 return 1;
5866 break;
5867 }
5868 }
5869 if (SCG(sym2) == SC_BASED) {
5870 int i2, n2, count1;
5871 /* see if the base pointer might conflict with this pointer */
5872 sym2 = MIDNUMG(sym2);
5873 n2 = findindex(sym2);
5874 if (n2 < 0)
5875 return 1;
5876 i2 = IPNDX_INFO(n2);
5877 /* two pointers, we have information about both pointers;
5878 * they may point to to different items: NO CONFLICT
5879 * otherwise: CONFLICT */
5880 count1 = 0;
5881 for (j1 = i1; j1 > 0; j1 = IPNFO_NEXT(j1)) {
5882 int j2;
5883 switch (IPNFO_TYPE(j1)) {
5884 case INFO_FSTARGET:
5885 if (IPNFO_TARGET(j1) == sym1) {
5886 /* S1 -> *S1, ignore */
5887 continue;
5888 }
5889 if (IPNFO_TARGET(j1) == sym2) {
5890 /* probably S1 -> *S2, conflict */
5891 return 1;
5892 }
5893 /* fall through */
5894 case INFO_FLDYNTARGET:
5895 case INFO_FGDYNTARGET:
5896 case INFO_FOTARGET:
5897 case INFO_FOSTARGET:
5898 ++count1;
5899 /* look for this pointee in the i2 list */
5900 for (j2 = i2; j2 > 0; j2 = IPNFO_NEXT(j2)) {
5901 if (IPNFO_TYPE(j2) == IPNFO_TYPE(j1) &&
5902 IPNFO_TARGET(j2) == IPNFO_TARGET(j1)) {
5903 /* S2 -> Y and S1 -> Y */
5904 return 1;
5905 }
5906 }
5907 break;
5908 case INFO_FUNKTARGET:
5909 return 1;
5910 break;
5911 }
5912 }
5913 /* no shared targets, independent */
5914 if (count1) {
5915 return 0;
5916 }
5917 } else {
5918 /* if we have some targets, none of them are this symbol */
5919 if (count) {
5920 return 0;
5921 }
5922 }
5923 } else if (t2 == NT_IND) {
5924 int vnme2, i2, j1, count1, n2;
5925 /* t2 is an indirection, too; see if we have info about it! */
5926 /* single direction? */
5927 vnme2 = NME_NM(nme2);
5928 if (NME_TYPE(vnme2) != NT_VAR)
5929 return 1;
5930 sym2 = NME_SYM(vnme2);
5931 n2 = findindex(sym2);
5932 if (n2 < 0)
5933 return 1;
5934 i2 = IPNDX_INFO(n2);
5935
5936 /* two pointers, we have information about both pointers;
5937 * they may point to to different items: NO CONFLICT
5938 * otherwise: CONFLICT */
5939 count1 = 0;
5940 for (j1 = i1; j1 > 0; j1 = IPNFO_NEXT(j1)) {
5941 int j2;
5942 switch (IPNFO_TYPE(j1)) {
5943 case INFO_FSTARGET:
5944 if (IPNFO_TARGET(j1) == sym1) {
5945 /* S1 -> *S1, ignore */
5946 continue;
5947 }
5948 if (IPNFO_TARGET(j1) == sym2) {
5949 /* probably S1 -> *S2, conflict */
5950 return 1;
5951 }
5952 /* fall through */
5953 case INFO_FLDYNTARGET:
5954 case INFO_FGDYNTARGET:
5955 case INFO_FOTARGET:
5956 case INFO_FOSTARGET:
5957 ++count1;
5958 /* look for this pointee in the i2 list */
5959 for (j2 = i2; j2 > 0; j2 = IPNFO_NEXT(j2)) {
5960 if (IPNFO_TYPE(j2) == IPNFO_TYPE(j1) &&
5961 IPNFO_TARGET(j2) == IPNFO_TARGET(j1)) {
5962 /* S2 -> Y and S1 -> Y */
5963 return 1;
5964 }
5965 }
5966 break;
5967 case INFO_FUNKTARGET:
5968 return 1;
5969 break;
5970 }
5971 }
5972 /* no shared targets, independent */
5973 if (count1) {
5974 return 0;
5975 }
5976 }
5977 return 1;
5978 } /* F90_nme_conflict */
5979
5980 /** \brief Detect Fortran 90 structure member name conflicts.
5981 *
5982 * return 0 if they point to different addresses;
5983 * return 1 otherwise
5984 */
5985 int
F90_struct_mbr_nme_conflict(int nme1,int nme2)5986 F90_struct_mbr_nme_conflict(int nme1, int nme2)
5987 {
5988 int mbr1, struct1, is_struct_mbr1, sptr1;
5989 int mbr2, struct2, is_struct_mbr2, sptr2;
5990 is_struct_mbr1 = 0;
5991 is_struct_mbr2 = 0;
5992
5993 /* handles one level of struct%mbr only */
5994
5995 /* input 1 */
5996 if (NME_TYPE(nme1) == NT_IND) {
5997 mbr1 = NME_NM(nme1);
5998 if (NME_TYPE(mbr1) == NT_MEM) {
5999 /* struct member */
6000 struct1 = NME_NM(mbr1);
6001 if (NME_TYPE(struct1) == NT_VAR) {
6002 sptr1 = NME_SYM(struct1);
6003 if (sptr1 > 0) {
6004 is_struct_mbr1 = 1;
6005 }
6006 }
6007 }
6008 }
6009 /* input 2 */
6010 if (NME_TYPE(nme2) == NT_IND) {
6011 mbr2 = NME_NM(nme2);
6012 if (NME_TYPE(mbr2) == NT_MEM) {
6013 /* struct member */
6014 struct2 = NME_NM(mbr2);
6015 if (NME_TYPE(struct2) == NT_VAR) {
6016 sptr2 = NME_SYM(struct2);
6017 if (sptr2 > 0) {
6018 is_struct_mbr2 = 1;
6019 }
6020 }
6021 }
6022 }
6023 if (is_struct_mbr1 && is_struct_mbr2) {
6024 /* both are structure member pointers */
6025 if (struct1 == struct2 && mbr1 == mbr2) {
6026 return 1; /* same */
6027 }
6028 if (NOCONFLICTG(sptr1) && NOCONFLICTG(sptr1)) {
6029 return 0;
6030 }
6031 }
6032 else if (is_struct_mbr1) {
6033 if (NME_TYPE(nme2) == NT_IND && NME_TYPE(NME_NM(nme2)) == NT_VAR) {
6034 /* first one is a structure member pointer, the other is not */
6035 sptr2 = NME_SYM(NME_NM(nme2));
6036 if (sptr2 > 0 && NOCONFLICTG(sptr2) && NOCONFLICTG(sptr1)) {
6037 return 0;
6038 }
6039 }
6040 }
6041 else if (is_struct_mbr2) {
6042 if (NME_TYPE(nme1) == NT_IND && NME_TYPE(NME_NM(nme1)) == NT_VAR) {
6043 /* second one is a structure member pointer, the other is not */
6044 sptr1 = NME_SYM(NME_NM(nme1));
6045 if (sptr1 > 0 && NOCONFLICTG(sptr1) && NOCONFLICTG(sptr2)) {
6046 return 0;
6047 }
6048 }
6049 }
6050 return 1; /* anything else */
6051 } /* F90_struct_mbr_nme_conflict */
6052
6053 /**
6054 * \return 1 if sptr is a pointer which has its pointer targets identified,
6055 * and its pointer targets do not conflict with any other pointers in
6056 * the program, and do not conflict which any array used in the program.
6057 * return 0 otherwise
6058 */
6059 int
IPA_pointer_safe(int nme)6060 IPA_pointer_safe(int nme)
6061 {
6062 int vnme, sym, n, subnme, nme2;
6063 /* both -x 89 0x20000000 and -x 89 0x100 must be set */
6064 if (XBIT(89, 0x20000100) != 0x20000100 || XBIT(89, 0x80))
6065 return 0;
6066 if (NME_TYPE(nme) != NT_IND)
6067 return 0;
6068 /* single direction? */
6069 vnme = NME_NM(nme);
6070 if (NME_TYPE(vnme) != NT_VAR)
6071 return 0;
6072 sym = NME_SYM(vnme);
6073 n = findindex(sym);
6074 if (n < 0)
6075 return 0;
6076
6077 /* go through other NMEs, see if nme conflicts with other nmes */
6078 for (nme2 = 2; nme2 < nmeb.stg_avail; ++nme2) {
6079 switch (NME_TYPE(nme2)) {
6080 case NT_VAR:
6081 /* don't compare against itself */
6082 if (nme2 != vnme) {
6083 if (IPA_nme_conflict(nme, nme2)) {
6084 /* nme conflicts with nme2, not safe */
6085 return 0;
6086 }
6087 }
6088 break;
6089 case NT_IND:
6090 /* don't compare against itself */
6091 if (NME_NM(nme2) != vnme) {
6092 if (IPA_nme_conflict(nme, nme2)) {
6093 /* nme conflicts with nme2, not safe */
6094 return 0;
6095 }
6096 }
6097 break;
6098 default:
6099 break;
6100 }
6101 }
6102 return 1;
6103 } /* IPA_pointer_safe */
6104
6105 /**
6106 * \return 1 if sptr is known to be within a limited integer range
6107 * at the start of the function.
6108 * return 0 otherwise
6109 */
6110 int
IPA_range(int sptr,int * plo,int * phi)6111 IPA_range(int sptr, int *plo, int *phi)
6112 {
6113 int n, i;
6114 if (XBIT(89, 0x80))
6115 return 0;
6116 n = findindex(sptr);
6117 if (n < 0)
6118 return 0;
6119 for (i = IPNDX_INFO(n); i > 0; i = IPNFO_NEXT(i)) {
6120 if (IPNFO_TYPE(i) == INFO_RANGE) {
6121 ++IPA_Range_Propagated;
6122 *plo = IPNFO_LOW(i);
6123 *phi = IPNFO_HIGH(i);
6124 return 1;
6125 }
6126 }
6127 return 0;
6128 } /* IPA_range */
6129
6130 /*
6131 * return 1 if sptr has never had its address taken.
6132 * return 0 otherwise
6133 */
6134 int
IPA_noaddr(int sptr)6135 IPA_noaddr(int sptr)
6136 {
6137 int n, i;
6138 if (!XBIT(89, 0x20000) || XBIT(89, 0x80))
6139 return 0;
6140 n = findindex(sptr);
6141 if (n < 0)
6142 return 0;
6143 for (i = IPNDX_INFO(n); i > 0; i = IPNFO_NEXT(i)) {
6144 if (IPNFO_TYPE(i) == INFO_NOADDR) {
6145 ++IPA_Safe_Globals_Confirmed;
6146 return 1;
6147 }
6148 }
6149 return 0;
6150 } /* IPA_noaddr */
6151
6152 /** \brief detect pure function from IPA standpoint
6153 *
6154 * \return 1 if function sptr is known to be 'pure'
6155 * that means it does not read or modify globals
6156 * or arguments or file statics.
6157 */
6158 int
IPA_func_pure(int sptr)6159 IPA_func_pure(int sptr)
6160 {
6161 int n, i;
6162 if (!XBIT(66, 0x10000))
6163 return 0;
6164 n = findindex(sptr);
6165 if (n < 0)
6166 return 0;
6167 for (i = IPNDX_INFO(n); i > 0; i = IPNFO_NEXT(i)) {
6168 if (IPNFO_TYPE(i) == INFO_FUNC) {
6169 if (IPNFO_FUNCINFO(i))
6170 return 0;
6171 ++IPA_Func_Propagated;
6172 return 1;
6173 }
6174 }
6175 return 0;
6176 } /* IPA_func_pure */
6177
6178 /** \brief detect "almost pure" function for IPA
6179 *
6180 * \return 1 if function sptr is known to be 'almost pure'
6181 * that means it does not read or modify globals that are
6182 * visible in the current file, and does not modify its arguments.
6183 */
6184 int
IPA_func_almostpure(int sptr)6185 IPA_func_almostpure(int sptr)
6186 {
6187 int n, i;
6188 if (!XBIT(66, 0x10000))
6189 return 0;
6190 n = findindex(sptr);
6191 if (n < 0)
6192 return 0;
6193 for (i = IPNDX_INFO(n); i > 0; i = IPNFO_NEXT(i)) {
6194 if (IPNFO_TYPE(i) == INFO_FUNC) {
6195 if (IPNFO_FUNCINFO(i) &
6196 (FINFO_WRITEARG | FINFO_READGLOB | FINFO_WRITEGLOB))
6197 return 0;
6198 /* if defined in this file, have to pay attention to statics also */
6199 if (FUNCLINEG(sptr) &&
6200 (IPNFO_FUNCINFO(i) & (FINFO_READSTATIC | FINFO_WRITESTATIC)))
6201 return 0;
6202 ++IPA_Func_Propagated;
6203 return 1;
6204 }
6205 }
6206 return 0;
6207 } /* IPA_func_almostpure */
6208
6209 /*
6210 * return stride for pointers
6211 */
6212 long
IPA_pstride(int sptr)6213 IPA_pstride(int sptr)
6214 {
6215 int n, i;
6216 if (!XBIT(66, 0x1000000))
6217 return 0;
6218 n = findindex(sptr);
6219 if (n < 0)
6220 return 0;
6221 for (i = IPNDX_INFO(n); i > 0; i = IPNFO_NEXT(i)) {
6222 if (IPNFO_TYPE(i) == INFO_PSTRIDE) {
6223 ++IPA_Pointer_Strides_Propagated;
6224 return IPNFO_PSTRIDE(i);
6225 }
6226 }
6227 return 0;
6228 } /* IPA_pstride */
6229
6230 /*
6231 * return section stride for pointers
6232 */
6233 long
IPA_sstride(int sptr)6234 IPA_sstride(int sptr)
6235 {
6236 int n, i;
6237 if (!XBIT(66, 0x1000000))
6238 return 0;
6239 n = findindex(sptr);
6240 if (n < 0)
6241 return 0;
6242 for (i = IPNDX_INFO(n); i > 0; i = IPNFO_NEXT(i)) {
6243 if (IPNFO_TYPE(i) == INFO_SSTRIDE) {
6244 ++IPA_Pointer_Strides_Propagated;
6245 return IPNFO_SSTRIDE(i);
6246 }
6247 }
6248 return 0;
6249 } /* IPA_sstride */
6250
6251 /*
6252 * return '1' if 'free' is never called anywhere in the application
6253 */
6254 int
IPA_NoFree(void)6255 IPA_NoFree(void)
6256 {
6257 return 0; /* until we know */
6258 } /* IPA_NoFree */
6259
6260 /*
6261 * return 1 if sptr is a 'safe' symbol, not modified by any calls.
6262 * return 0 otherwise
6263 */
6264 int
IPA_safe(int sptr)6265 IPA_safe(int sptr)
6266 {
6267 int n, i;
6268 if (!XBIT(89, 0x20000) || XBIT(89, 0x80))
6269 return 0;
6270 n = findindex(sptr);
6271 if (n < 0)
6272 return 0;
6273 for (i = IPNDX_INFO(n); i > 0; i = IPNFO_NEXT(i)) {
6274 if (IPNFO_TYPE(i) == INFO_SAFE) {
6275 ++IPA_Safe_Globals_Confirmed;
6276 return 1;
6277 }
6278 }
6279 return 0;
6280 } /* IPA_safe */
6281
6282 /*
6283 * return 1 if sptr is 'safe' in a call to 'funcsptr',i
6284 * not modified by funcsptr or any calls within funcsptr
6285 * return 0 otherwise
6286 */
6287 int
IPA_call_safe(int funcsptr,int sptr)6288 IPA_call_safe(int funcsptr, int sptr)
6289 {
6290 int n, i;
6291 if (!XBIT(89, 0x20000) || XBIT(89, 0x80))
6292 return 0;
6293 n = findindex(sptr);
6294 if (n < 0)
6295 return 0;
6296 for (i = IPNDX_INFO(n); i > 0; i = IPNFO_NEXT(i)) {
6297 if (IPNFO_TYPE(i) == INFO_SAFE || IPNFO_TYPE(i) == INFO_ALLCALLSAFE) {
6298 ++IPA_Safe_Globals_Confirmed;
6299 return 1;
6300 }
6301 if (IPNFO_TYPE(i) == INFO_CALLSAFE && IPNFO_VAL(i) == funcsptr) {
6302 ++IPA_Safe_Globals_Confirmed;
6303 return 1;
6304 }
6305 }
6306 return 0;
6307 } /* IPA_call_safe */
6308
6309 /*
6310 * return 1 if sptr is 'safe' in any call from this function
6311 * even if it is modified by this function itself
6312 */
6313 int
IPA_allcall_safe(int sptr)6314 IPA_allcall_safe(int sptr)
6315 {
6316 int n, i;
6317 if (!XBIT(89, 0x20000) || XBIT(89, 0x80))
6318 return 0;
6319 n = findindex(sptr);
6320 if (n < 0)
6321 return 0;
6322 for (i = IPNDX_INFO(n); i > 0; i = IPNFO_NEXT(i)) {
6323 if (IPNFO_TYPE(i) == INFO_SAFE || IPNFO_TYPE(i) == INFO_ALLCALLSAFE) {
6324 ++IPA_Safe_Globals_Confirmed;
6325 return 1;
6326 }
6327 }
6328 return 0;
6329 } /* IPA_allcall_safe */
6330
6331 static struct {
6332 bool smp;
6333 bool recursive;
6334 int profile;
6335 int x5;
6336 int x121;
6337 int x123;
6338 } cusv;
6339
6340 void
cuda_emu_start(void)6341 cuda_emu_start(void)
6342 {
6343 gbl.cudaemu = cudaemu;
6344 if (cudaemu) {
6345 cusv.smp = flg.smp;
6346 cusv.recursive = flg.recursive;
6347 cusv.profile = flg.profile;
6348 cusv.x5 = flg.x[5];
6349 cusv.x121 = flg.x[121];
6350 cusv.x123 = flg.x[123];
6351 flg.smp = false;
6352 flg.recursive = true;
6353 flg.profile = 0;
6354 flg.x[121] |= 0x1; /* -Mnoframe */
6355 if (flg.debug) {
6356 flg.x[5] |= 1;
6357 flg.x[123] |= 0x400;
6358 }
6359 }
6360 }
6361
6362 void
cuda_emu_end(void)6363 cuda_emu_end(void)
6364 {
6365 if (cudaemu) {
6366 flg.smp = cusv.smp;
6367 flg.recursive = cusv.recursive;
6368 flg.profile = cusv.profile;
6369 flg.x[5] = cusv.x5;
6370 flg.x[121] = cusv.x121;
6371 flg.x[123] = cusv.x123;
6372 cudaemu = 0;
6373 gbl.cudaemu = 0;
6374 }
6375 }
6376
6377 /* get the size of STATICS/BSS - this has to be done after fix_datatype so that
6378 we can get the size of sptr if it is an array. AD_DPTR is done in
6379 fix_datatype.
6380 */
6381 static void
do_llvm_sym_is_refd(void)6382 do_llvm_sym_is_refd(void)
6383 {
6384 SPTR sptr;
6385 for (sptr = stb.firstusym; sptr < stb.stg_avail; ++sptr) {
6386 switch (STYPEG(sptr)) {
6387 case ST_VAR:
6388 case ST_ARRAY:
6389 case ST_STRUCT:
6390 case ST_UNION:
6391 case ST_PLIST:
6392 if (REFG(sptr) == 0) {
6393 switch (SCG(sptr)) {
6394 case SC_LOCAL:
6395 case SC_STATIC:
6396 sym_is_refd(sptr);
6397 break;
6398 default:
6399 break;
6400 }
6401 }
6402 break;
6403 default:
6404 break;
6405 }
6406 }
6407 }
6408
6409 /**
6410 \brief ...
6411 */
6412 void
stb_upper_init(void)6413 stb_upper_init(void)
6414 {
6415 int end;
6416 end = read_line();
6417 while (line[0] == 'i') {
6418 char *name, *cname, *filename;
6419 int level, which, namelen, cnamelen, filenamelen, base, size;
6420 long offset, objoffset;
6421 /* an 'inline' line */
6422 level = getval("inline");
6423 offset = getlval("offset");
6424 which = getval("which");
6425 cnamelen = getnamelen();
6426 cname = line + pos;
6427 pos += cnamelen;
6428 namelen = getnamelen();
6429 name = line + pos;
6430 pos += namelen;
6431 filenamelen = getnamelen();
6432 filename = line + pos;
6433 pos += filenamelen;
6434 objoffset = getlval("objoffset");
6435 base = getval("base");
6436 size = getval("size");
6437 name[namelen] = '\0';
6438 cname[cnamelen] = '\0';
6439 filename[filenamelen] = '\0';
6440 end = read_line();
6441 }
6442
6443 } /* upper_init */
6444
6445 SPTR
llvm_get_uplevel_newsptr(int oldsptr)6446 llvm_get_uplevel_newsptr(int oldsptr)
6447 {
6448 SPTR sptr = symbolxref[oldsptr];
6449 if (SCG(sptr) == SC_BASED)
6450 sptr = MIDNUMG(sptr);
6451 return sptr;
6452 }
6453
6454 static void
build_agoto(void)6455 build_agoto(void)
6456 {
6457 extern void exp_build_agoto(int *, int); /* exp_rte.c */
6458 int i;
6459 if (agotosz == 0)
6460 return;
6461 exp_build_agoto(agototab, agotomax);
6462 FREE(agototab);
6463 agotosz = 0;
6464 }
6465
6466 const char *
lookup_modvar_alias(SPTR sptr)6467 lookup_modvar_alias(SPTR sptr)
6468 {
6469 alias_syminfo *node = modvar_alias_list;
6470 while (node) {
6471 if (node->sptr == sptr) {
6472 return node->alias;
6473 }
6474 node = node->next;
6475 }
6476 return NULL;
6477 }
6478
6479 /**
6480 \brief Given a alias name of a mod var sptr, create a new alias_syminfo node
6481 and add it to the linked list for later lookup.
6482 */
6483 static void
save_modvar_alias(SPTR sptr,const char * alias_name)6484 save_modvar_alias(SPTR sptr, const char *alias_name)
6485 {
6486 alias_syminfo *new_alias_info;
6487 if (!alias_name || lookup_modvar_alias(sptr))
6488 return;
6489 NEW(new_alias_info, alias_syminfo, 1);
6490 new_alias_info->sptr = sptr;
6491 new_alias_info->alias = alias_name;
6492 new_alias_info->next = modvar_alias_list;
6493 modvar_alias_list = new_alias_info;
6494 }
6495
6496 /**
6497 \brief Release the memory space ocupied by the linked list of alias_symifo nodes.
6498 */
6499 static void
free_modvar_alias_list()6500 free_modvar_alias_list()
6501 {
6502 alias_syminfo *node;
6503 while (modvar_alias_list) {
6504 node = modvar_alias_list;
6505 modvar_alias_list = modvar_alias_list->next;
6506 FREE(node->alias);
6507 FREE(node);
6508 }
6509 }
6510
6511