1 /*
2 * Copyright (c) 1994-2019, NVIDIA CORPORATION. All rights reserved.
3 *
4 * Licensed under the Apache License, Version 2.0 (the "License");
5 * you may not use this file except in compliance with the License.
6 * You may obtain a copy of the License at
7 *
8 * http://www.apache.org/licenses/LICENSE-2.0
9 *
10 * Unless required by applicable law or agreed to in writing, software
11 * distributed under the License is distributed on an "AS IS" BASIS,
12 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13 * See the License for the specific language governing permissions and
14 * limitations under the License.
15 *
16 */
17
18 /** \file
19 \brief Fortran Semantic action routines to resolve symbol references as to
20 overloading class.
21
22 This module hides the walking of hash chains and overloading class checks.
23 */
24
25 #include "gbldefs.h"
26 #include "global.h"
27 #include "error.h"
28 #include "symtab.h"
29 #include "symutl.h"
30 #include "dtypeutl.h"
31 #include "gramtk.h"
32 #include "semant.h"
33 #include "ast.h"
34 #include "rte.h"
35 #include "interf.h"
36
37 static int find_in_host(int);
38 static void internref_bnd(int);
39 static int add_private_allocatable(int, int);
40 static void check_parref(int, int, int);
41
42 static LOGICAL checking_scope = FALSE;
43
44 static LOGICAL
isGenericOrProcOrModproc(SPTR sptr)45 isGenericOrProcOrModproc(SPTR sptr)
46 {
47 SPTR localSptr = STYPEG(sptr) == ST_ALIAS ? SYMLKG(sptr) : sptr;
48 switch (STYPEG(localSptr)) {
49 case ST_PROC:
50 case ST_MODPROC:
51 case ST_USERGENERIC:
52 return TRUE;
53 default:
54 return FALSE;
55 }
56 }
57
58 static LOGICAL
isSameNameGenericOrProcOrModproc(SPTR sptr1,SPTR sptr2)59 isSameNameGenericOrProcOrModproc(SPTR sptr1, SPTR sptr2)
60 {
61 if (GSAMEG(sptr2) && isGenericOrProcOrModproc(sptr1) &&
62 isGenericOrProcOrModproc(sptr2)) {
63 return NMPTRG(sptr1) == NMPTRG(GSAMEG(sptr2));
64 }
65 return FALSE;
66 }
67
68 static int
getEnclFunc(SPTR sptr)69 getEnclFunc(SPTR sptr)
70 {
71 int currencl;
72 int enclsptr;
73 currencl = enclsptr = ENCLFUNCG(sptr);
74 while (enclsptr && STYPEG(enclsptr) != ST_ENTRY) {
75 currencl = enclsptr;
76 enclsptr = ENCLFUNCG(enclsptr);
77 }
78
79 if (currencl)
80 return SCOPEG(currencl);
81 return 0;
82 }
83
84 static LOGICAL
isLocalPrivate(SPTR sptr)85 isLocalPrivate(SPTR sptr)
86 {
87 int scope = getEnclFunc(sptr);
88
89 if (scope && STYPEG(scope) == ST_ENTRY && scope != gbl.currsub)
90 return FALSE;
91
92 /* have to return TRUE if ENCLFUNC nor SCOPE is set */
93 return TRUE;
94 }
95
96 /** \brief Look for symbol with same name as first and in a currectly active
97 scope.
98 \param first the symbol to match by name
99 \param overloadclass 0 or the value of stb.ovclass to match
100 \param paliassym return the symbol the result is an alias of
101 \param plevel return the scope nest at which symbol was found
102 \param multiple_use_error if true, report error if name is USE-associated
103 from two different modules
104 \return symbol (or alias) if found, else 0
105 */
106 int
sym_in_scope(int first,OVCLASS overloadclass,int * paliassym,int * plevel,int multiple_use_error)107 sym_in_scope(int first, OVCLASS overloadclass, int *paliassym, int *plevel,
108 int multiple_use_error)
109 {
110 int sptrloop, bestsptr, bestsptrloop, bestsl, bestuse, bestuse2, bestusecount,
111 bestuse2count;
112 int cc_alias;
113
114 if (paliassym)
115 *paliassym = 0;
116 if (plevel)
117 *plevel = 0;
118 bestsptr = bestsptrloop = 0;
119 bestuse = bestuse2 = bestusecount = bestuse2count = 0;
120 bestsl = -1;
121 for (sptrloop = first_hash(first); sptrloop; sptrloop = HASHLKG(sptrloop)) {
122 int want_scope, usecount, sptrlink;
123 SCOPESTACK *scope;
124 int sptr = sptrloop;
125 if (NMPTRG(sptr) != NMPTRG(first))
126 continue;
127 switch (STYPEG(sptr)) {
128 case ST_ISOC:
129 case ST_CRAY:
130 /* predefined symbol, but not active in this routine */
131 continue;
132 case ST_MODPROC:
133 case ST_PROC:
134 case ST_IDENT:
135 case ST_VAR:
136 case ST_ARRAY:
137 case ST_STRUCT:
138 case ST_UNION:
139 case ST_DESCRIPTOR:
140 case ST_TYPEDEF:
141 if (HIDDENG(sptr))
142 continue;
143 /* make sure it is in current function scope */
144 if (gbl.internal > 1 && SCG(sptr) == SC_PRIVATE && ENCLFUNCG(sptr)) {
145 if (!isLocalPrivate(sptr))
146 continue;
147 }
148 break;
149 default:;
150 }
151 if (sem.scope_stack == NULL) {
152 /* must be after the parser, such as in static-init */
153 if (overloadclass == 0 || STYPEG(sptr) == ST_UNKNOWN ||
154 stb.ovclass[STYPEG(sptr)] == overloadclass) {
155 if (STYPEG(sptr) == ST_ALIAS)
156 sptr = SYMLKG(sptr);
157 if (paliassym != NULL)
158 *paliassym = sptrloop;
159 if (plevel != NULL)
160 *plevel = -1;
161 return sptr;
162 }
163 continue;
164 }
165
166 /* in a current scope? */
167 want_scope = SCOPEG(sptr);
168 if (want_scope == 0 && STYPEG(sptr) == ST_MODULE) {
169 /* see if there is a USE clause for this module, use that level */
170 SCOPESTACK *scope = next_scope_kind_sptr(0, SCOPE_USE, sptr);
171 if (scope != 0) {
172 want_scope = scope->sptr; /* treat module as scoped at itself */
173 }
174 }
175 if (want_scope == 0) {
176 if (STYPEG(sptr) == ST_ALIAS)
177 sptr = SYMLKG(sptr);
178 if (bestsl == -1) {
179 bestsl = 0;
180 bestsptr = sptr;
181 bestsptrloop = sptrloop;
182 }
183 continue;
184 }
185 cc_alias = 0;
186 if (STYPEG(sptr) == ST_ALIAS && DCLDG(sptr) &&
187 NMPTRG(sptr) == NMPTRG(SYMLKG(sptr))) {
188 /* from a 'use module, only: i' statement;
189 * compiler inserts an alias 'i' in this scope,
190 * but the alias in this scope has no meaning; look at the
191 * original symbol 'i'.
192 * This is very different from 'use module, only: j=>i',
193 * where the alias 'j' in this scope DOES have meaning
194 *
195 * But (fs16195), do keep track of alias as an additional
196 * check of the except list.
197 */
198 cc_alias = sptr;
199 sptr = SYMLKG(sptr);
200 }
201 sptrlink = sptr;
202 while ((STYPEG(sptrlink) == ST_ALIAS || STYPEG(sptrlink) == ST_MODPROC) &&
203 SYMLKG(sptrlink)) {
204 sptrlink = SYMLKG(sptrlink);
205 }
206 usecount = 0;
207 /* look in the scope stack for an active scope containing this symbol */
208 scope = 0;
209 while ((scope = next_scope(scope)) != 0) {
210 /* past a SCOPE_NORMAL, association is HOST-association,
211 * not USE-association */
212 if (scope->kind == SCOPE_NORMAL)
213 ++usecount;
214 if (scope->sptr == want_scope ||
215 /* module procedures are 'scoped' at module level.
216 * treat as if they are scoped here */
217 scope->sptr == sptrloop ||
218 (scope->sptr && want_scope < stb.stg_avail &&
219 scope->sptr == find_explicit_interface(want_scope))) {
220 LOGICAL found = is_except_in_scope(scope, sptr) ||
221 is_except_in_scope(scope, cc_alias);
222 if (scope->Private &&
223 ((STYPEG(sptr) != ST_PROC && STYPEG(sptr) != ST_OPERATOR &&
224 STYPEG(sptr) != ST_USERGENERIC) ||
225 (!VTOFFG(sptr) && !TBPLNKG(sptr)) ||
226 (IS_TBP(sptr) && PRIVATEG(sptr)))) {
227 found = TRUE; /* in a private USE */
228 } else if (scope->kind == SCOPE_USE &&
229 (PRIVATEG(sptr) ||
230 PRIVATEG(sptrloop))) {
231 /* FE creates an alias when processing the case like:
232 'use mod_name, only : i'.
233 So, if found sptrloop is a type of ST_ALIAS, we need to check whether
234 current module is a submod of ENCLFUNCG(sptrloop). If yes, then this
235 variable is accessible.
236 */
237 if (STYPEG(sptrloop) == ST_ALIAS && ANCESTORG(gbl.currmod))
238 found = ENCLFUNCG(sptrloop) != ANCESTORG(gbl.currmod);
239 else
240 found = TRUE; /* private module variable */
241 /* private module variables are visible to inherited submodules*/
242 if (is_used_by_submod(gbl.currsub, sptr))
243 return sptr;
244 }
245 if (!found) { /* not found in 'except' list */
246 if (STYPEG(sptr) == ST_ALIAS)
247 sptr = SYMLKG(sptr);
248 if (overloadclass == 0 || STYPEG(sptrlink) == ST_UNKNOWN ||
249 stb.ovclass[STYPEG(sptrlink)] == overloadclass) {
250 int sl = get_scope_level(scope);
251 if (sl > bestsl) {
252 if (scope->kind == SCOPE_USE &&
253 STYPEG(sptrlink) != ST_USERGENERIC &&
254 STYPEG(sptrlink) != ST_ENTRY && !VTOFFG(sptrlink) &&
255 !TBPLNKG(sptrlink)) {
256 if (bestuse && bestuse2 == 0 && bestsptr != sptrlink) {
257 bestuse2 = bestuse;
258 bestuse2count = bestusecount;
259 }
260 bestuse = scope->sptr;
261 bestusecount = usecount;
262 } else {
263 bestuse = 0;
264 }
265 bestsl = sl;
266 bestsptr = sptrlink;
267 bestsptrloop = sptrloop;
268 } else if (bestuse && scope->kind == SCOPE_USE &&
269 /* for submodule, use-association overwrites host-association*/
270 STYPEG(scope->sptr) == ST_MODULE &&
271 ANCESTORG(gbl.currmod) != scope->sptr &&
272 scope->sptr != bestuse &&
273 STYPEG(sptrlink) != ST_USERGENERIC &&
274 STYPEG(sptrlink) != ST_ENTRY && !VTOFFG(sptrlink) &&
275 !TBPLNKG(sptrlink) && bestsptr != sptrlink) {
276 bestuse2 = scope->sptr;
277 bestuse2count = usecount;
278 }
279 }
280 }
281 }
282 if (!scope->open && scope->kind != SCOPE_INTERFACE) {
283 if (!bestsptr && scope->kind == SCOPE_NORMAL && scope->import) {
284 if (sym_in_sym_list(sptr, scope->import)) {
285 if (STYPEG(sptr) == ST_ALIAS)
286 sptr = SYMLKG(sptr);
287 return sptr;
288 }
289 }
290 break; /* can't go farther out anyway */
291 }
292 }
293 }
294
295 if (bestuse && bestuse2 && multiple_use_error && bestuse != bestuse2 &&
296 !isSameNameGenericOrProcOrModproc(bestsptr, bestsptrloop) &&
297 bestusecount == bestuse2count && sem.which_pass == 1) {
298 /* oops; this name is USE-associated from two
299 * different modules */
300 char msg[200];
301 sprintf(msg,
302 "is use-associated from modules %s and %s,"
303 " and cannot be accessed",
304 SYMNAME(bestuse), SYMNAME(bestuse2));
305 error(155, 3, gbl.lineno, SYMNAME(first), msg);
306 }
307 if (paliassym != NULL)
308 *paliassym = bestsptrloop;
309 if (plevel != NULL)
310 *plevel = bestsl;
311 return bestsptr;
312 } /* sym_in_scope */
313
314 /** \brief IMPORT symbol from host scope -- not to be confused with interf
315 import stuff.
316 */
317 void
sem_import_sym(int s)318 sem_import_sym(int s)
319 {
320 int sptr;
321 int smi;
322 SCOPESTACK *scope;
323
324 sptr = find_in_host(s);
325 while (sptr > NOSYM && STYPEG(sptr) == ST_ALIAS && SYMLKG(sptr) > NOSYM &&
326 strcmp(SYMNAME(sptr), SYMNAME(SYMLKG(sptr))) == 0)
327 sptr = SYMLKG(sptr); /* FS#17251 - need to resolve alias */
328 if (sptr <= NOSYM) {
329 error(155, 3, gbl.lineno, "Cannot IMPORT", SYMNAME(s));
330 return;
331 }
332 /*
333 * <zero or more> SCOPE_USE
334 */
335 scope = next_scope_kind(0, SCOPE_NORMAL);
336 smi = add_symitem(sptr, scope->import);
337 scope->import = smi;
338 }
339
340 /*
341 * The current context is:
342 * interface
343 * ...
344 * subroutine/function ...
345 * INPORT FROMHOST <<< current context, find FROMHOST>>>>
346 * endsubroutine/endfunction
347 * ...
348 * endinterface
349 *
350 * There should be three scope entries corresponding to this context:
351 *
352 * scope_level-2 : SCOPE_INTERFACE
353 * scope_level-1 : SCOPE_NORMAL
354 * <zero or more> SCOPE_USE
355 * scope_level : SCOPE_SUBPROGRAM
356 *
357 */
358 static int
find_in_host(int s)359 find_in_host(int s)
360 {
361 int cap;
362 int sptr;
363 SCOPESTACK *scope, *iface_scope;
364
365 /*
366 * First check for the minimal scope entries.
367 */
368 cap = sem.scope_level - 3 * (sem.interface - 1);
369 if (cap < 4)
370 return -1;
371
372 scope = get_scope(cap);
373 if (scope->kind != SCOPE_SUBPROGRAM) {
374 return -1;
375 }
376 scope = next_scope_kind(scope, SCOPE_NORMAL);
377 if (scope == 0 || get_scope_level(scope) < 4) {
378 return -1;
379 }
380
381 iface_scope = next_scope(scope);
382 if (iface_scope->kind != SCOPE_INTERFACE) {
383 return -1;
384 }
385
386 /*
387 * Find symbol suitable for IMPORT from the hash list.
388 */
389 for (sptr = first_hash(s); sptr; sptr = HASHLKG(sptr)) {
390 if (NMPTRG(sptr) != NMPTRG(s))
391 continue;
392 if (stb.ovclass[STYPEG(sptr)] != OC_OTHER)
393 continue;
394 /*
395 * Now, search the scope entries.
396 */
397 /*
398 * Now, search the scope entries starting below the scope for the interface
399 */
400 scope = iface_scope;
401 while ((scope = next_scope(scope)) != 0) {
402 if (scope->sptr == SCOPEG(sptr)) {
403 LOGICAL ex;
404 if (scope->except) {
405 ex = is_except_in_scope(scope, sptr);
406 } else if (scope->Private) {
407 for (ex = scope->only; ex; ex = SYMI_NEXT(ex)) {
408 int sptr2 = SYMI_SPTR(ex);
409 if (sptr2 == sptr)
410 return sptr;
411 /* FS#14811 Check for symbol in GNDSC list. */
412 if (STYPEG(sptr2) == ST_ALIAS)
413 sptr2 = SYMLKG(sptr2);
414 if (sym_in_sym_list(sptr2, GNDSCG(sptr))) {
415 return sptr;
416 }
417 }
418 ex = TRUE; /* in a private USE */
419 } else {
420 ex = FALSE;
421 }
422 if (!ex) /* not on a 'except' list */
423 return sptr;
424 }
425 if (!scope->open)
426 break; /* can't go farther out anyway */
427 }
428 }
429 return -1;
430 }
431
432 int
test_scope(int sptr)433 test_scope(int sptr)
434 {
435 int sl;
436 for (sl = sem.scope_level; sl >= 0; --sl) {
437 SCOPESTACK *scope = get_scope(sl);
438 if (scope->sptr == SCOPEG(sptr)) {
439 int ex = is_except_in_scope(scope, sptr);
440 if (scope->Private) {
441 for (ex = scope->only; ex; ex = SYMI_NEXT(ex)) {
442 int sptr2 = SYMI_SPTR(ex);
443 if (sptr2 == sptr)
444 return sl;
445 /* FS#14811 Check for symbol in GNDSC list. */
446 if (STYPEG(sptr2) == ST_ALIAS)
447 sptr2 = SYMLKG(sptr2);
448 if (sym_in_sym_list(sptr2, GNDSCG(sptr))) {
449 return sl;
450 }
451 }
452 ex = 1; /* in a private USE */
453 } else if (scope->kind == SCOPE_USE && scope->sptr != gbl.currmod &&
454 PRIVATEG(sptr)) {
455 ex = 1; /* private module variable */
456 }
457 if (ex == 0) /* not on a 'except' list */
458 return sl;
459 }
460 if (!scope->open)
461 break; /* can't go farther out anyway */
462 }
463 return -1;
464 } /* test_scope */
465
466 /* **********************************************************************/
467
468 /** \brief Look up symbol having a specific symbol type.
469
470 If a symbol is found in the same overloading class and has
471 the same symbol type, it is returned to the caller.
472 If a symbol is found in the same overloading class, the action
473 of declref depends on the stype of the existing symbol and
474 value of the argument def:
475 1. if symbol is an unfrozen intrinsic and def is 'd' (define),
476 its intrinsic property is removed and a new symbol is declared,
477 2. if def is 'd', a multiple declaration error occurs, or
478 3. if def is not 'd', an 'illegal use' error occurs
479
480 If an error occurs or a matching symbol is not found, one is
481 created and its symbol type is initialized.
482 */
483 int
declref(int first,SYMTYPE stype,int def)484 declref(int first, SYMTYPE stype, int def)
485 {
486 int sptr1, sptr;
487
488 sptr = sym_in_scope(first, stb.ovclass[stype], NULL, NULL, 0);
489 if (sptr) {
490 SYMTYPE st = STYPEG(sptr);
491 if (st == ST_UNKNOWN && sptr == first)
492 goto return1; /* stype not set yet, set it */
493 if ((int)SCOPEG(sptr) != stb.curr_scope && def == 'd')
494 goto return0;
495 if (stype != st) {
496 if (def == 'd') {
497 /* Redeclare of intrinsic symbol is okay unless frozen */
498 if (IS_INTRINSIC(st)) {
499 if ((sptr1 = newsym(sptr)) != 0)
500 sptr = sptr1;
501 goto return1;
502 }
503 /* multiple declaration */
504 error(44, 3, gbl.lineno, SYMNAME(first), CNULL);
505 } else
506 /* illegal use of symbol */
507 error(84, 3, gbl.lineno, SYMNAME(first), CNULL);
508 goto return0;
509 }
510 goto return2; /* found, return it */
511 }
512 return0:
513 sptr = insert_sym(first); /* create new one if def or illegal use */
514 return1:
515 STYPEP(sptr, stype);
516 SCOPEP(sptr, stb.curr_scope);
517 if (!sem.interface)
518 IGNOREP(sptr, 0);
519 return2:
520 if (flg.xref)
521 xrefput(sptr, def);
522 return sptr;
523 }
524
525 /* If we see an ENTRY in a module with the same name as a variable
526 * in the module, we must change the variable into an ENTRY.
527 * We must remove the variable from the module common
528 * (actually, to simplify things, we replace it with another variable)
529 * and change the sptr to be an ENTRY. We can't add another ENTRY to
530 * the end, because postprocessing of the symbols added by this subprogram
531 * assumes that all new symbols are undeclared in the module specification
532 * part, and changes things like the PRIVATE/PUBLIC bit. */
533 static int
replace_variable(int sptr,SYMTYPE stype)534 replace_variable(int sptr, SYMTYPE stype)
535 {
536 int newsptr;
537 ACCL *accessp;
538 newsptr = insert_sym(sptr);
539 STYPEP(newsptr, stype);
540 DTYPEP(newsptr, DTYPEG(sptr));
541 /* add 'private' or 'public' for this symbol */
542 accessp = (ACCL *)getitem(3, sizeof(ACCL));
543 accessp->next = sem.accl.next;
544 sem.accl.next = accessp;
545 accessp->sptr = newsptr;
546 accessp->oper = ' ';
547 if (PRIVATEG(sptr)) {
548 accessp->type = 'v';
549 } else {
550 accessp->type = 'u';
551 }
552 HIDDENP(sptr, 1);
553 module_must_hide_this_symbol(sptr);
554 return newsptr;
555 } /* replace_variable */
556
557 static void
set_internref_flag(int sptr)558 set_internref_flag(int sptr)
559 {
560 INTERNREFP(sptr, 1);
561 if (DTY(DTYPEG(sptr)) == TY_ARRAY || POINTERG(sptr) || ALLOCATTRG(sptr) ||
562 IS_PROC_DUMMYG(sptr) || ADJLENG(sptr)) {
563 int descr, sdsc, midnum, devcopy;
564 int cvlen = 0;
565 descr = DESCRG(sptr);
566 sdsc = SDSCG(sptr);
567 midnum = MIDNUMG(sptr);
568 devcopy = DEVCOPYG(sptr);
569 // adjustable char arrays can exist as single vars or array of arrays
570 if (STYPEG(sptr) == ST_VAR || STYPEG(sptr) == ST_ARRAY ||
571 STYPEG(sptr) == ST_IDENT)
572 cvlen = CVLENG(sptr);
573 if (descr)
574 INTERNREFP(descr, 1);
575 if (sdsc)
576 INTERNREFP(sdsc, 1);
577 if (midnum)
578 INTERNREFP(midnum, 1);
579 if (cvlen)
580 INTERNREFP(cvlen, 1);
581 if (devcopy)
582 INTERNREFP(devcopy, 1);
583 }
584 if (DTY(DTYPEG(sptr)) == TY_ARRAY) {
585 ADSC *ad;
586 ad = AD_DPTR(DTYPEG(sptr));
587 if (AD_ADJARR(ad) || ALLOCATTRG(sptr) || ASSUMSHPG(sptr)) {
588 int i, ndim;
589 ndim = AD_NUMDIM(ad);
590 for (i = 0; i < ndim; i++) {
591 internref_bnd(AD_LWAST(ad, i));
592 internref_bnd(AD_UPAST(ad, i));
593 internref_bnd(AD_MLPYR(ad, i));
594 internref_bnd(AD_EXTNTAST(ad, i));
595 }
596 internref_bnd(AD_NUMELM(ad));
597 internref_bnd(AD_ZBASE(ad));
598 }
599 }
600 if (SCG(sptr) == SC_DUMMY && CLASSG(sptr)) {
601 int parent = PARENTG(sptr);
602 if (parent && CLASSG(parent))
603 set_internref_flag(parent);
604 }
605 }
606
607 static void
internref_bnd(int ast)608 internref_bnd(int ast)
609 {
610 if (ast && A_TYPEG(ast) == A_ID) {
611 int sptr;
612 sptr = A_SPTRG(ast);
613 INTERNREFP(sptr, 1);
614 }
615 }
616
617 void
set_internref_stfunc(int ast)618 set_internref_stfunc(int ast)
619 {
620 if (ast && A_TYPEG(ast) == A_ID) {
621 int sptr;
622 sptr = A_SPTRG(ast);
623 if (SCOPEG(sptr) && SCOPEG(sptr) != gbl.currsub)
624 set_internref_flag(sptr);
625 }
626 }
627
628 /** \brief Declare a new symbol.
629
630 An error can occur if the symbol is already in the symbol table.<br>
631 If the symbol types match: treat as in error if \a errflg is true; otherwise
632 return the symbol.<br>
633 If they don't match: if symbol is an intrinsic attempt to remove symbol's
634 intrinsic property; otherwise it is an error.
635 */
636 int
declsym(int first,SYMTYPE stype,LOGICAL errflg)637 declsym(int first, SYMTYPE stype, LOGICAL errflg)
638 {
639 SYMTYPE st;
640 int sptr1, sptr, sptralias, oldsptr, level;
641 int sptr2, gnr;
642 int symi;
643
644 sptr = sym_in_scope(first, stb.ovclass[stype], &sptralias, &level, 0);
645 if (sptr) {
646 if (STYPEG(sptr) == ST_ENTRY && FVALG(sptr))
647 sptr = FVALG(sptr);
648 st = STYPEG(sptr);
649 if (st == ST_UNKNOWN && sptr == first && gbl.internal &&
650 sptr < stb.firstusym)
651 goto return0; /* New symbol at this scope. */
652 if ((st == ST_UNKNOWN ||
653 (st == ST_MODPROC && !SEPARATEMPG(sptr) && sem.interface)) &&
654 sptr == first && sptr >= stb.firstusym)
655 goto return1; /* Brand new symbol, return it. */
656 if ((int)SCOPEG(sptr) == stb.curr_scope && st == ST_IDENT &&
657 stb.ovclass[st] == stb.ovclass[stype]) {
658 /* Found an ST_IDENT in the same overloading class */
659 goto return1; /* OK (?) */
660 }
661 if (stype == ST_USERGENERIC) {
662 if ((STYPEG(sptr) == ST_PROC || STYPEG(sptr) == ST_MODPROC) &&
663 GSAMEG(sptr)) {
664 /* Looking for a generic, found a subroutine by the same name.
665 * Get the generic
666 */
667 sptr = GSAMEG(sptr);
668 st = STYPEG(sptr);
669 } else if (STYPEG(sptr) == ST_TYPEDEF) {
670 oldsptr = sptr;
671 sptr = insert_sym(first);
672 GTYPEP(sptr, oldsptr);
673 goto return1;
674 }
675 }
676 if (stype == ST_ENTRY && st == ST_USERGENERIC) {
677 /* looking for a subroutine (modproc) found a generic, look for a
678 * modproc with the same name */
679 for (sptr1 = first_hash(sptr); sptr1 > NOSYM; sptr1 = HASHLKG(sptr1)) {
680 if (NMPTRG(sptr) == NMPTRG(sptr1) && STYPEG(sptr1) == ST_USERGENERIC &&
681 GSAMEG(sptr1)) {
682 sptr = GSAMEG(sptr1);
683 st = STYPEG(sptr);
684 break;
685 }
686 }
687 }
688 if (stype == ST_MODPROC && IN_MODULE_SPEC) {
689 for (sptr1 = first_hash(sptr); sptr1 > NOSYM; sptr1 = HASHLKG(sptr1)) {
690 if (NMPTRG(sptr) == NMPTRG(sptr1) && STYPEG(sptr1) == ST_MODPROC &&
691 SCOPEG(sptr1) == gbl.currmod) {
692 sptr = sptr1;
693 st = STYPEG(sptr);
694 break;
695 }
696 }
697 }
698 if (SCOPEG(sptr) == 0) { /* predeclared, overwrite it */
699 oldsptr = sptr;
700 sptr = insert_sym(first);
701 if (st != ST_MODULE && DCLDG(oldsptr)) {
702 DCLDP(sptr, 1);
703 DTYPEP(sptr, DTYPEG(oldsptr));
704 DCLDP(oldsptr, 0);
705 }
706 goto return1;
707 }
708 if (stype == st) {
709 if (st == ST_GENERIC && sptr < stb.firstusym) {
710 if ((sptr1 = newsym(sptr)) != 0) {
711 sptr = sptr1;
712 goto return1;
713 }
714 }
715 /* is this a symbol that was host-associated?
716 * if so, declare a new symbol */
717 if (level > 0) {
718 if (get_scope_level(next_scope_kind(0, SCOPE_NORMAL)) > level) {
719 /* declare a new symbol; the level at which
720 * the existing symbol was found is outside the
721 * current scope */
722 goto return0;
723 }
724 }
725 /* Possible attempt to multiply define symbol */
726 if (errflg) {
727 if (stype == ST_ENTRY && sem.interface == 1) {
728 /* interface for a subprogram appears in the
729 * the subprogram; just create another instance
730 * of the ST_ENTRY.
731 */
732 sptr = insert_sym(first);
733 STYPEP(sptr, stype);
734 SCOPEP(sptr, stb.curr_scope);
735 return sptr;
736 }
737 if (stype == ST_IDENT && STYPEG(first) == ST_ENTRY) {
738 if (SCOPEG(first) == 0 && stb.curr_scope) {
739 /* host (outer) routine with same-named
740 * identifier in inner scope
741 */
742 sptr = insert_sym(first);
743 STYPEP(sptr, stype);
744 SCOPEP(sptr, stb.curr_scope);
745 return sptr;
746 }
747 }
748
749 if (sptr == first && (int)SCOPEG(sptr) != stb.curr_scope && sem.interface == 1) {
750 sptr = insert_sym(first);
751 STYPEP(sptr, stype);
752 SCOPEP(sptr, stb.curr_scope);
753 return sptr;
754 }
755 error(44, 3, gbl.lineno, SYMNAME(first), CNULL);
756 goto return0;
757 }
758 goto return2;
759 }
760 /* stype != st */
761 if (sem.interface && stype == ST_ENTRY && st == ST_PROC &&
762 (int)SCOPEG(sptr) == stb.curr_scope) {
763 /* nested interface for a subprogram which is an
764 * argument to the current subprogram; make it an
765 * entry and return it;
766 */
767
768 if (SCG(sptr) == SC_DUMMY) {
769 STYPEP(sptr, stype);
770 }
771 return sptr;
772 }
773 /* Redeclare of intrinsic symbol is okay unless frozen */
774 if (IS_INTRINSIC(st)) {
775 if (EXPSTG(sptr) && stype == ST_GENERIC) {
776 /* used intrinsic before (in an initializatn?),
777 now want to use name as a generic.
778 Should be o.k. */
779 sptr = sptr1 = insert_sym(first);
780 goto return1;
781 }
782 if ((sptr1 = newsym(sptr)) != 0)
783 sptr = sptr1;
784 goto return1;
785 }
786 if (st == ST_USERGENERIC) {
787 if (GSAMEG(sptr) == 0 && (stype == ST_ENTRY || stype == ST_MODPROC)) {
788 sptr1 = insert_sym(first);
789 if (ENCLFUNCG(sptr) && STYPEG(ENCLFUNCG(sptr)) == ST_MODULE &&
790 ENCLFUNCG(sptr) != gbl.currmod) {
791 /* user generic was from a USE MODULE statement */
792 } else {
793 GSAMEP(sptr, sptr1);
794 GSAMEP(sptr1, sptr);
795 /* find MODPROC and fix up its SYMLK if necessary */
796 for (symi = GNDSCG(sptr); symi; symi = SYMI_NEXT(symi)) {
797 int sptr_modproc = SYMI_SPTR(symi);
798 if (NMPTRG(sptr1) != NMPTRG(sptr_modproc))
799 continue;
800 if (STYPEG(sptr_modproc) == ST_MODPROC && !SYMLKG(sptr_modproc)) {
801 SYMLKP(sptr_modproc, sptr1);
802 export_append_sym(sptr_modproc);
803 }
804 break;
805 }
806 }
807 sptr = sptr1;
808 goto return1;
809 }
810 }
811 if (stype == ST_ENTRY && st == ST_MODPROC && IN_MODULE &&
812 sem.interface == 0 && SYMLKG(sptr) == 0) {
813 sptr1 = insert_sym(first);
814 SYMLKP(sptr, sptr1);
815 export_append_sym(sptr);
816 if (GSAMEG(sptr)) {
817 GSAMEP(sptr1, GSAMEG(sptr));
818 GSAMEP(GSAMEG(sptr), sptr1);
819 }
820 if (PRIVATEG(sptr)) {
821 PRIVATEP(sptr1, 1);
822 }
823 sptr = sptr1;
824 goto return1;
825 }
826 if (stype == ST_ENTRY && STYPEG(sptralias) == ST_ALIAS && sem.mod_sym &&
827 st == ST_PROC && ENCLFUNCG(sptr) == sem.mod_sym) {
828 /* the existing symbol is the interface (ST_PROC) for
829 * a module contained subprogram.
830 */
831 /*pop_sym(sptr);*/ /* Hide the module subprogram symbol */
832 IGNOREP(sptr, 1);
833 HIDDENP(sptr, 1);
834 sptr = sptralias;
835 goto return1;
836 }
837 if (stype == ST_ENTRY && sptralias == sptr && sem.mod_sym &&
838 st == ST_PROC && ENCLFUNCG(sptr) == sem.mod_sym) {
839 /* the existing symbol is the interface (ST_PROC) for
840 * a module contained subprogram; no ST_ALIAS added
841 * for native-mode.
842 */
843 IGNOREP(sptr, 1); /* hide the subprogram symbol */
844 oldsptr = sptr;
845 /* create new one if def or illegal use */
846 sptr = insert_sym(first);
847 /* make sure this is the first symbol on the hash list */
848 pop_sym(sptr);
849 push_sym(sptr);
850 INMODULEP(sptr, INMODULEG(oldsptr));
851 goto return1;
852 }
853 if (stype == ST_ENTRY && sptralias == sptr &&
854 SCOPEG(sptr) == stb.curr_scope && st == ST_PROC &&
855 ENCLFUNCG(sptr) == sem.mod_sym && !INTERNALG(sptr)) {
856 /* the existing symbol was added for a CALL, and now we see
857 * an ENTRY of that name.
858 */
859 SCP(sptr, SC_NONE);
860 goto return1;
861 }
862 /* is this a symbol that was host-associated?
863 * if so, declare a new symbol */
864 if (level >= 0) {
865 if (get_scope_level(next_scope_kind(0, SCOPE_NORMAL)) > level) {
866 /* declare a new symbol; the level at which
867 * the existing symbol was found is outside the
868 * current scope */
869 goto return0;
870 }
871 }
872 if (stype == ST_ENTRY && st == ST_PROC) {
873 goto return0;
874 }
875 /* if we are declaring a MODULE PROCEDURE, but we have found
876 * a name from an USE or outer associated scope level, create a new
877 * symbol */
878 if (stype == ST_MODPROC) {
879 switch (get_scope(level)->kind) {
880 case SCOPE_OUTER:
881 goto return0;
882 case SCOPE_MODULE:
883 if (STYPEG(sptr) == ST_PROC) {
884 oldsptr = sptr;
885 sptr = insert_sym(first); /* create new one */
886 SYMLKP(sptr, oldsptr); /* resolve ST_MODPROC */
887 goto return1;
888 }
889 break;
890 case SCOPE_USE:
891 if (STYPEG(sptr) == ST_PROC) {
892 oldsptr = sptr;
893 sptr = insert_sym(first); /* create new one */
894 SYMLKP(sptr, oldsptr); /* resolve ST_MODPROC */
895 goto return1;
896 }
897 goto return0;
898 default:;
899 }
900 }
901 /* if we are in a module, creating a module subprogram,
902 * and the old symbol is a 'variable', override the variable. */
903 if (sem.mod_sym && sem.which_pass == 0 && gbl.internal == 0 &&
904 stype == ST_ENTRY && st == ST_VAR) {
905 sptr = replace_variable(sptr, stype);
906 goto return1;
907 }
908 error(43, 3, gbl.lineno, "symbol", SYMNAME(first));
909 }
910
911 return0:
912 sptr = insert_sym(first); /* create new one if def or illegal use */
913 return1:
914 STYPEP(sptr, stype);
915 SCOPEP(sptr, stb.curr_scope);
916 if (!sem.interface)
917 IGNOREP(sptr, 0);
918 return2:
919 if (flg.xref)
920 xrefput(sptr, 'd');
921 #ifdef GSCOPEP
922 if (sem.which_pass && gbl.internal <= 1 &&
923 internal_proc_has_ident(sptr, gbl.currsub)) {
924 GSCOPEP(sptr, 1);
925 }
926 #endif
927 if (gbl.internal > 1 && first == sptr) {
928 set_internref_flag(sptr);
929 }
930
931 return sptr;
932 }
933
934 /** \brief Look up a symbol having the given overloading class.
935
936 If the symbol with the overloading class is found its sptr is returned. If
937 no symbol with the given overloading class is found, a new sptr is returned.
938 */
939 int
refsym(int first,OVCLASS oclass)940 refsym(int first, OVCLASS oclass)
941 {
942 int sptr, sl, scope, sptrloop;
943 int save_par, save_target, save_teams;
944
945 sptr = sym_in_scope(first, oclass, NULL, NULL, 1);
946 if (sptr) {
947 SYMTYPE st = STYPEG(sptr);
948 if (st == ST_UNKNOWN && sptr == first)
949 goto return1;
950 if (stb.ovclass[st] == oclass) {
951 /* was this a reference to the return value? */
952 if (st == ST_ENTRY && !RESULTG(sptr) &&
953 (gbl.rutype == RU_FUNC || (sptr == gbl.outersub && FVALG(sptr)))) {
954 /* always a reference to the result variable */
955 sl = sptr;
956 sptr = ref_entry(sptr);
957 if (FVALG(sl) == sptr) {
958 if (gbl.internal > 1) {
959 set_internref_flag(sptr);
960 }
961 if ((sem.parallel || sem.task || sem.target || sem.teams)) {
962 set_parref_flag(sptr, sptr, BLK_UPLEVEL_SPTR(sem.scope_level));
963 }
964 }
965
966 } else if (SCG(sptr) == SC_DUMMY) {
967 if (gbl.internal > 1) {
968 if (SCOPEG(sptr) && SCOPEG(sptr) == SCOPEG(gbl.currsub))
969 set_internref_flag(sptr);
970 }
971 if ((sem.parallel || sem.task || sem.target || sem.teams)) {
972 set_parref_flag(sptr, sptr, BLK_UPLEVEL_SPTR(sem.scope_level));
973 }
974 }
975 goto returnit;
976 }
977 }
978
979 /* Symbol in given overloading class not found, create new one */
980 sptr = insert_sym(first);
981 return1:
982 if (flg.xref)
983 xrefput(sptr, 'd');
984 if (!sem.interface)
985 IGNOREP(sptr, 0);
986 returnit:
987 if (gbl.internal > 1 && first == sptr) {
988 if (STYPEG(sptr) == ST_PROC && SCG(sptr) == SC_DUMMY)
989 set_internref_flag(sptr);
990 else if (STYPEG(sptr) != ST_PROC && STYPEG(sptr) != ST_STFUNC)
991 set_internref_flag(sptr);
992 }
993 return sptr;
994 }
995
996 /** \brief Similar to refsym() except that the current scope is taken into
997 consideration.
998
999 If the symbol with the overloading class is found its sptr is returned.
1000 If no symbol with the given overloading class is found, a new sptr is
1001 returned.
1002 */
1003 int
refsym_inscope(int first,OVCLASS oclass)1004 refsym_inscope(int first, OVCLASS oclass)
1005 {
1006 int sptr, level;
1007
1008 sptr = sym_in_scope(first, oclass, NULL, &level, 0);
1009 if (sptr) {
1010 SYMTYPE st = STYPEG(sptr);
1011 /* if this is the symbol just created for this subprogram, use it */
1012 if (st == ST_UNKNOWN && sptr == first && sptr >= stb.firstusym)
1013 goto return1;
1014 if (stb.ovclass[st] == oclass) {
1015 if (gbl.currsub == sptr)
1016 /* && (int)SCOPEG(sptr) == (stb.curr_scope - 1)) */
1017 goto returnit;
1018 /* is this a symbol that was host-associated?
1019 * if so, declare a new symbol */
1020 if (level > 0) {
1021 int sl;
1022 for (sl = sem.scope_level; sl > level; --sl) {
1023 if (sem.scope_stack[sl].kind == SCOPE_NORMAL) {
1024 /* declare a new symbol; the level at which
1025 * the existing symbol was found is outside the
1026 * current scope */
1027 goto return0;
1028 }
1029 }
1030 } else if (level == 0 && st == ST_MODULE &&
1031 sptr == sem.mod_sym /* is the current module */
1032 && sptr != stb.curr_scope /* not in outer host scope */
1033 ) {
1034 /* context is a module which is being defined but not in its
1035 * module specification part -- the symbol is being declared
1036 * in a scope contained within the module.
1037 */
1038 goto return0;
1039 }
1040 if (gbl.internal > 1 && !INTERNALG(sptr)) {
1041 /* This is a non-internal symbol in an internal subprogram. */
1042 if (IS_INTRINSIC(STYPEG(sptr)))
1043 goto returnit; // tentative intrinsic; may be overridden later
1044 goto return0; // declare a new symbol
1045 }
1046 if (ENCLFUNCG(sptr) && STYPEG(ENCLFUNCG(sptr)) == ST_MODULE &&
1047 ENCLFUNCG(sptr) != gbl.currmod) {
1048 /* see if the scope level makes this host associated */
1049 int sl;
1050 if (level < 0)
1051 goto return0;
1052 /* use associated symbol */
1053 if (IGNOREG(sptr) || PRIVATEG(sptr) ||
1054 (st == ST_PROC && PRIVATEG(SCOPEG(sptr))) ||
1055 ((st == ST_USERGENERIC || st == ST_OPERATOR) &&
1056 TBPLNKG(sptr)) /* FS#20696: needed for overloading */
1057 )
1058 goto return0; /* create new symbol */
1059 if (oclass == OC_CMBLK ||
1060 /* Check whether the gbl.currmod and ENCLFUNCG(sptr) share
1061 with the same ancestor, if yes then use host-association
1062 */
1063 (oclass == OC_OTHER &&
1064 (ANCESTORG(gbl.currmod) ?
1065 ANCESTORG(gbl.currmod) : gbl.currmod) ==
1066 (ANCESTORG(ENCLFUNCG(sptr)) ?
1067 ANCESTORG(ENCLFUNCG(sptr)) : ENCLFUNCG(sptr))))
1068 goto return0;
1069 error(155, 3, gbl.lineno, SYMNAME(sptr),
1070 "is use associated and cannot be redeclared");
1071 goto return0;
1072 }
1073 /*if ((int)SCOPEG(sptr) == stb.curr_scope)*/
1074 goto returnit;
1075 /* break; don't create new symbol */
1076 }
1077 }
1078
1079 return0:
1080 /* Symbol in given overloading class not found, create new one */
1081 sptr = insert_sym(first);
1082 return1:
1083 SCOPEP(sptr, stb.curr_scope);
1084 if (!sem.interface)
1085 IGNOREP(sptr, 0);
1086 if (flg.xref)
1087 xrefput(sptr, 'd');
1088 returnit:
1089 if (gbl.internal > 1 && first == sptr) {
1090 set_internref_flag(sptr);
1091 }
1092 return sptr;
1093 }
1094
1095 void
enforce_denorm(void)1096 enforce_denorm(void)
1097 {
1098 int st, first, sptr, sl, scope, sptrloop;
1099
1100 if (!sem.ieee_features || STYPEG(gbl.currsub) == ST_MODULE)
1101 return;
1102 first = lookupsymbol("ieee_denormal");
1103 if (!first)
1104 return;
1105 sptr = sym_in_scope(first, OC_OTHER, NULL, NULL, 1);
1106 if (sptr && STYPEG(sptr) == ST_PARAM && SCOPEG(sptr) &&
1107 strcmp(SYMNAME(SCOPEG(sptr)), "ieee_features") == 0) {
1108 gbl.denorm = TRUE;
1109 return;
1110 }
1111 }
1112
1113 /** \brief Look up symbol matching overloading class of given symbol type.
1114 \param first the symbol to match by name
1115 \param oclass the overloading class to match
1116 \param alias if true and the symbol is an `ST_ALIAS`, return the
1117 dereferenced symbol
1118 \return The symbol whose overloading class matches the overloading class of
1119 the symbol type given. If no symbol is found in the given
1120 overloading class one is created.
1121 */
1122 int
getocsym(int first,OVCLASS oclass,LOGICAL alias)1123 getocsym(int first, OVCLASS oclass, LOGICAL alias)
1124 {
1125 int sptr, sptralias;
1126
1127 sptr = sym_in_scope(first, oclass, &sptralias, NULL, 0);
1128 if (!alias)
1129 sptr = sptralias;
1130 if (sptr) {
1131 SYMTYPE st = STYPEG(sptr);
1132 if (st == ST_UNKNOWN && sptr == first)
1133 goto return1;
1134 if (stb.ovclass[st] == oclass)
1135 goto returnit; /* found it! */
1136 }
1137
1138 /* create new symbol if undefined or illegal use */
1139 sptr = insert_sym(first);
1140 return1:
1141 if (flg.xref)
1142 xrefput(sptr, 'd');
1143 if (!sem.interface)
1144 IGNOREP(sptr, 0);
1145 returnit:
1146 return sptr;
1147 }
1148
1149 /* declobject - certain symbols which are non-data objects (e.g.,
1150 * TEMPLATE and PROCESSOR). In these cases, it's legal to
1151 * specify the object's shape before the actual object type.
1152 * The symbol representing the object is returned.
1153 */
1154 int
declobject(int sptr,SYMTYPE stype)1155 declobject(int sptr, SYMTYPE stype)
1156 {
1157 sptr = refsym(sptr, OC_OTHER); /* all objects (data, non-data) */
1158 if (STYPEG(sptr) == ST_ARRAY && !DCLDG(sptr) && SCG(sptr) == SC_NONE) {
1159 ADSC *ad;
1160 ad = AD_DPTR(DTYPEG(sptr));
1161 if (AD_ASSUMSZ(ad) || AD_DEFER(ad))
1162 error(30, 3, gbl.lineno, SYMNAME(sptr), CNULL);
1163 STYPEP(sptr, stype);
1164 if (flg.xref)
1165 xrefput(sptr, 'd');
1166 } else
1167 sptr = declsym(sptr, stype, TRUE);
1168
1169 return sptr;
1170 }
1171
1172 /** \brief Reset fields of intrinsic or generic symbol, sptr, to zero in
1173 preparation for changing its symbol type by the Semantic Analyzer.
1174
1175 If the symbol type of the symbol has been 'frozen', issue an error message
1176 and notify the caller by returning a zero symbol pointer.
1177 */
1178 int
newsym(int sptr)1179 newsym(int sptr)
1180 {
1181 int sp2, sp1;
1182
1183 if (EXPSTG(sptr)) {
1184 /* Symbol previously frozen as an intrinsic */
1185 error(43, 3, gbl.lineno, "intrinsic", SYMNAME(sptr));
1186 return 0;
1187 }
1188 /*
1189 * try to find another sym in the same overloading class; we need to
1190 * try this first since there could be multiple occurrences of an
1191 * intrinsic and therefore the sptr appears more than once in the
1192 * semantic stack. E.g.,
1193 * call sub (sin, sin)
1194 * NOTE that in order for this to work we need to perform another getsym
1195 * to start at the beginning of the hash links for symbols whose names
1196 * are the same.
1197 */
1198 sp1 = getsym(LOCAL_SYMNAME(sptr), strlen(SYMNAME(sptr)));
1199 sp2 = getocsym(sp1, OC_OTHER, FALSE);
1200 if (sp2 != sptr)
1201 return sp2;
1202 /*
1203 * Create a new symbol with the same name:
1204 */
1205 error(35, 1, gbl.lineno, SYMNAME(sptr), CNULL);
1206 sp2 = insert_sym(sp1);
1207
1208 /* transfer dtype if it was explicitly declared for sptr: */
1209
1210 if (DCLDG(sptr)) {
1211 DTYPEP(sp2, DTYPEG(sptr));
1212 DCLDP(sp2, 1);
1213 DCLDP(sptr, 0);
1214 ADJLENP(sp2, ADJLENG(sptr));
1215 ADJLENP(sptr, 0);
1216 }
1217
1218 return sp2;
1219 }
1220
1221 /*---------------------------------------------------------------------*/
1222
1223 /** \brief Reference a symbol when it's known the context requires an
1224 identifier.
1225
1226 If an error occurs (e.g., symbol which is frozen as an intrinsic),
1227 a new symbol is created so that processing can continue. If the symbol
1228 found is ST_UNKNOWN, its stype is changed to ST_IDENT.
1229 */
1230 int
ref_ident(int sptr)1231 ref_ident(int sptr)
1232 {
1233 int sym;
1234
1235 sym = refsym(sptr, OC_OTHER);
1236 if (IS_INTRINSIC(STYPEG(sym))) {
1237 sym = newsym(sym);
1238 if (sym == 0)
1239 sym = insert_sym(sptr);
1240 }
1241 if (STYPEG(sym) == ST_UNKNOWN)
1242 STYPEP(sym, ST_IDENT);
1243
1244 return sym;
1245 }
1246
1247 int
ref_ident_inscope(int sptr)1248 ref_ident_inscope(int sptr)
1249 {
1250 int sym;
1251
1252 sym = refsym_inscope(sptr, OC_OTHER);
1253 if (IS_INTRINSIC(STYPEG(sym))) {
1254 sym = newsym(sym);
1255 if (sym == 0)
1256 sym = insert_sym(sptr);
1257 }
1258 if (STYPEG(sym) == ST_UNKNOWN)
1259 STYPEP(sym, ST_IDENT);
1260
1261 return sym;
1262 }
1263
1264 /*---------------------------------------------------------------------*/
1265
1266 /** \brief Reference a symbol when it's known the context requires storage,
1267 e.g.,
1268 a variable or the result of a function.
1269
1270 If an error occurs (e.g., symbol which is frozen as an intrinsic), a new
1271 symbol is created so that processing can continue. If the symbol found is
1272 ST_UNKNOWN, its stype is changed to ST_IDENT.
1273 */
1274 int
ref_storage(int sptr)1275 ref_storage(int sptr)
1276 {
1277 int sym;
1278
1279 sym = ref_ident(sptr);
1280 switch (STYPEG(sym)) {
1281 case ST_ENTRY:
1282 if (gbl.rutype == RU_FUNC && !RESULTG(sptr)) {
1283 sym = ref_entry(sptr);
1284 }
1285 break;
1286 case ST_IDENT:
1287 if (DTY(DTYPEG(sym)) == TY_ARRAY)
1288 STYPEP(sym, ST_ARRAY);
1289 else
1290 STYPEP(sym, ST_VAR);
1291 break;
1292 default:
1293 break;
1294 }
1295
1296 return sym;
1297 }
1298
1299 int
ref_storage_inscope(int sptr)1300 ref_storage_inscope(int sptr)
1301 {
1302 int sym;
1303
1304 sym = refsym_inscope(sptr, OC_OTHER);
1305 if (IS_INTRINSIC(STYPEG(sym))) {
1306 sym = newsym(sym);
1307 if (sym == 0)
1308 sym = insert_sym(sptr);
1309 }
1310 if (STYPEG(sym) == ST_UNKNOWN)
1311 STYPEP(sym, ST_IDENT);
1312 switch (STYPEG(sym)) {
1313 case ST_ENTRY:
1314 if (gbl.rutype == RU_FUNC && !RESULTG(sym)) {
1315 sym = ref_entry(sym);
1316 }
1317 break;
1318 case ST_IDENT:
1319 if (DTY(DTYPEG(sym)) == TY_ARRAY)
1320 STYPEP(sym, ST_ARRAY);
1321 else
1322 STYPEP(sym, ST_VAR);
1323 break;
1324 default:
1325 break;
1326 }
1327
1328 return sym;
1329 }
1330
1331 /*---------------------------------------------------------------------*/
1332
1333 /** \brief Reference a symbol when it's known the context requires an integer
1334 scalar variable.
1335
1336 If an error occurs (e.g., symbol which is frozen as an intrinsic),
1337 a new symbol is created so that processing can continue. If the symbol
1338 found is ST_UNKNOWN, its stype is changed to ST_IDENT.
1339 */
1340 int
ref_int_scalar(int sptr)1341 ref_int_scalar(int sptr)
1342 {
1343 int sym;
1344
1345 sym = refsym(sptr, OC_OTHER);
1346 if (IS_INTRINSIC(STYPEG(sym))) {
1347 sym = newsym(sym);
1348 if (sym == 0)
1349 sym = insert_sym(sptr);
1350 }
1351 if (STYPEG(sym) == ST_UNKNOWN)
1352 STYPEP(sym, ST_IDENT);
1353 if (STYPEG(sym) == ST_PARAM || !DT_ISINT(DTYPEG(sptr)))
1354 error(84, 3, gbl.lineno, SYMNAME(sptr),
1355 "-must be an integer scalar variable");
1356
1357 return sym;
1358 }
1359
1360 /** \brief Mark a compiler-created temp as static.
1361 */
1362 static void
mark_static(int astx)1363 mark_static(int astx)
1364 {
1365 if (A_TYPEG(astx) == A_ID || A_TYPEG(astx) == A_SUBSCR ||
1366 A_TYPEG(astx) == A_MEM) {
1367 int sptr;
1368 sptr = sym_of_ast(astx);
1369 if (CCSYMG(sptr) || HCCSYMG(sptr)) {
1370 SCP(sptr, SC_STATIC);
1371 SAVEP(sptr, 1);
1372 }
1373 }
1374 } /* mark_static */
1375
1376 /** \brief Reference a based object.
1377
1378 Since it's possible to have more than one level of 'based' storage, need to
1379 scan through the MIDNUM fields until the "pointer" variable is found. Along
1380 the way, it may be necessary to fix the stypes of the based variables and to
1381 create xref 'r' records. Also, the storage class of the 'pointer' variable
1382 is fixed if necessary. The symbol table index of the 'pointer' variable is
1383 returned.
1384 */
1385 int
ref_based_object(int sptr)1386 ref_based_object(int sptr)
1387 {
1388 int sptr1;
1389 sptr1 = ref_based_object_sc(sptr, SC_LOCAL);
1390 return sptr1;
1391 }
1392
1393 int
ref_based_object_sc(int sptr,SC_KIND sc)1394 ref_based_object_sc(int sptr, SC_KIND sc)
1395 {
1396 int sptr1;
1397 #if DEBUG
1398 assert(SCG(sptr) == SC_BASED || POINTERG(sptr) || ALLOCATTRG(sptr) ||
1399 (SCG(sptr) == SC_CMBLK && ALLOCG(sptr)),
1400 "ref_based_object: sptr not based", sptr, 3);
1401 #endif
1402 if (flg.xref)
1403 xrefput(sptr, 'r');
1404
1405 if (DTY(DTYPEG(sptr)) != TY_ARRAY) {
1406 /* test for scalar pointer */
1407 if (POINTERG(sptr) && SDSCG(sptr) == 0 && !F90POINTERG(sptr)) {
1408 if (SCG(sptr) == SC_NONE)
1409 SCP(sptr, SC_BASED);
1410 get_static_descriptor(sptr);
1411 get_all_descriptors(sptr);
1412 }
1413 }
1414
1415 /*
1416 * for an allocatable array, it's possible that the array is not
1417 * associated with a pointer (did not appear in a POINTER statement).
1418 * Create a compiler temporary to represent the pointer variable.
1419 */
1420 if (MIDNUMG(sptr) <= NOSYM && !F90POINTERG(sptr)) {
1421 if (F77OUTPUT) {
1422 sptr1 = sym_get_ptr(sptr);
1423 } else {
1424 sptr1 = getccsym('Z', sptr, ST_VAR);
1425 DTYPEP(sptr1, DT_PTR);
1426 }
1427 MIDNUMP(sptr, sptr1);
1428 /*
1429 * if an allocatable array is saved, need to ensure that all of its
1430 * associated temporary variables are marked save -- e.g., the internal
1431 * pointer variable, its bounds' variables, its zero-base temporary,
1432 * etc.
1433 */
1434 if ((sem.savall && !CCSYMG(sptr) && !HCCSYMG(sptr)) || SAVEG(sptr)) {
1435 ADSC *ad;
1436 int i, numdim, s;
1437
1438 SCP(sptr1, SC_STATIC);
1439 SAVEP(sptr1, 1);
1440
1441 if (DTY(DTYPEG(sptr)) == TY_ARRAY) {
1442 ad = AD_PTR(sptr);
1443 numdim = AD_NUMDIM(ad);
1444
1445 mark_static(AD_NUMELM(ad));
1446 mark_static(AD_ZBASE(ad));
1447 for (i = 0; i < numdim; i++) {
1448 mark_static(AD_LWAST(ad, i));
1449 mark_static(AD_UPAST(ad, i));
1450 mark_static(AD_MLPYR(ad, i));
1451 mark_static(AD_EXTNTAST(ad, i));
1452 }
1453 }
1454 }
1455 else if (GSCOPEG(sptr)) {
1456 fixup_reqgs_ident(sptr);
1457 }
1458 else
1459 SCP(sptr1, sc);
1460 }
1461 sptr1 = sptr;
1462 while (TRUE) {
1463 if (STYPEG(sptr1) == ST_IDENT)
1464 STYPEP(sptr1, ST_VAR);
1465 sptr1 = MIDNUMG(sptr1);
1466 if (SAVEG(sptr))
1467 SAVEP(sptr1, 1);
1468 if (flg.xref)
1469 xrefput(sptr1, 'r');
1470 if (SCG(sptr1) != SC_BASED)
1471 break;
1472 #if DEBUG
1473 assert(sptr1 > NOSYM, "ref_based_object: bad list", sptr, 0);
1474 #endif
1475 }
1476 if (SCG(sptr1) == SC_NONE)
1477 SCP(sptr1, sc);
1478 if (gbl.internal > 1 && SCOPEG(sptr) == SCOPEG(gbl.currsub)) {
1479 set_internref_flag(sptr);
1480 }
1481 if (flg.smp)
1482 check_parref(sptr, sptr, sptr);
1483 return sptr1;
1484 }
1485
1486 /** \brief Reference the first symbol of the given overloading class in the
1487 current scope. If not found, zero is returned.
1488 */
1489 int
refocsym(int first,OVCLASS oclass)1490 refocsym(int first, OVCLASS oclass)
1491 {
1492 int sptr;
1493
1494 sptr = sym_in_scope(first, oclass, NULL, NULL, 0);
1495 if (sptr) {
1496 SYMTYPE st = STYPEG(sptr);
1497 if (stb.ovclass[st] == oclass) {
1498 if (st == ST_ALIAS)
1499 return DTYPEG(sptr); /* should this be SYMLKG? */
1500 return sptr;
1501 }
1502 }
1503 /*
1504 * error - symbol used in wrong overloading class, except may be
1505 * function call, so no message:
1506 */
1507 return 0;
1508 }
1509
1510 int
sym_skip_construct(int first)1511 sym_skip_construct(int first)
1512 {
1513 if (first > NOSYM && STYPEG(first) == ST_CONSTRUCT) {
1514 int sptr = first;
1515 while ((sptr = HASHLKG(sptr)) > NOSYM) {
1516 if (NMPTRG(sptr) == NMPTRG(first))
1517 return sptr;
1518 }
1519 }
1520 return first;
1521 }
1522
1523 /** \brief Declare a symbol in the most current scope; if one already exists
1524 return it.
1525 */
1526 int
declsym_newscope(int sptr,SYMTYPE stype,int dtype)1527 declsym_newscope(int sptr, SYMTYPE stype, int dtype)
1528 {
1529 sptr = getocsym(sptr, stb.ovclass[stype], FALSE);
1530 if (STYPEG(sptr) != stype || SCOPEG(sptr) != stb.curr_scope) {
1531 if (STYPEG(sptr) != ST_UNKNOWN)
1532 sptr = insert_sym(sptr);
1533 /* enter symbol into a separate scope */
1534 STYPEP(sptr, stype);
1535 SCOPEP(sptr, stb.curr_scope);
1536 DTYPEP(sptr, dtype);
1537 DCLDP(sptr, 1);
1538 if (gbl.internal > 1)
1539 INTERNALP(sptr, 1);
1540 }
1541 return sptr;
1542 }
1543
1544 static void
nullify_member_after(int ast,int std,int sptr)1545 nullify_member_after(int ast, int std, int sptr)
1546 {
1547 int dtype = DTYPEG(sptr);
1548 int sptrmem, aast, mem_sptr_id;
1549
1550 for (sptrmem = DTY(DDTG(dtype) + 1); sptrmem > NOSYM;
1551 sptrmem = SYMLKG(sptrmem)) {
1552 if (ALLOCATTRG(sptrmem)) {
1553 aast = mk_id(sptrmem);
1554 mem_sptr_id = mk_member(ast, aast, DTYPEG(sptrmem));
1555 std = add_stmt_after(add_nullify_ast(mem_sptr_id), std);
1556 }
1557 if (is_tbp_or_final(sptrmem)) {
1558 /* skip tbp */
1559 continue;
1560 }
1561 if (dtype != DTYPEG(sptrmem) && !POINTERG(sptrmem) &&
1562 allocatable_member(sptrmem)) {
1563 aast = mk_id(sptrmem);
1564 mem_sptr_id = mk_member(ast, aast, DTYPEG(sptrmem));
1565 nullify_member_after(mem_sptr_id, std, sptrmem);
1566 }
1567 }
1568 }
1569 /*---------------------------------------------------------------------*/
1570
1571 /** \brief Declare a private symbol which may be based on the attributes of
1572 an existing symbol.
1573
1574 If the symbol doesn't exist (its stype is ST_UNKNOWN), it's assumed that the
1575 private variable will be a scalar variable.
1576 */
1577 int
decl_private_sym(int sptr)1578 decl_private_sym(int sptr)
1579 {
1580 int sptr1;
1581 SYMTYPE stype;
1582 char *name;
1583 int new = 0;
1584 int pvar;
1585 int rgn_level;
1586 /*
1587 * First, retrieve the first symbol in the hash list whose name is the same.
1588 * Then, use refsym to retrieve the first symbol whose overloading class
1589 * is the same. This is all necessary because a private symbol could
1590 * have already been created ahead of the existing symbol (sptr).
1591 */
1592 name = SYMNAME(sptr);
1593 sptr1 = getsymbol(name);
1594 sptr = refsym(sptr1, stb.ovclass[STYPEG(sptr)]);
1595 if (SCOPEG(sptr) == sem.scope_stack[sem.scope_level].sptr)
1596 return sptr; /* a variable can appear in more than 1 clause */
1597 if (checking_scope && sem.scope_stack[sem.scope_level].kind == SCOPE_PAR) {
1598 rgn_level = sem.scope_stack[sem.scope_level].rgn_scope;
1599 if (SCOPEG(sptr) == sem.scope_stack[rgn_level].sptr) {
1600 return sptr; /* a variable can appear in more than 1 clause */
1601 }
1602 }
1603 if (ALLOCG(sptr) || POINTERG(sptr)) {
1604 new = insert_sym(sptr1);
1605 STYPEP(new, STYPEG(sptr));
1606 if (DTY(DTYPEG(sptr)) == TY_ARRAY)
1607 DTYPEP(new, dup_array_dtype(DTYPEG(sptr)));
1608 else
1609 DTYPEP(new, DTYPEG(sptr));
1610 ALLOCP(new, ALLOCG(sptr));
1611 POINTERP(new, POINTERG(sptr));
1612 ALLOCATTRP(new, ALLOCATTRG(sptr));
1613 SCP(new, SC_BASED);
1614 set_descriptor_sc(SC_PRIVATE);
1615 get_static_descriptor(new);
1616 get_all_descriptors(new);
1617 new = add_private_allocatable(sptr, new);
1618 set_descriptor_sc(SC_LOCAL);
1619 if (ADJLENG(sptr)) {
1620 int cvlen = CVLENG(sptr);
1621 if (cvlen == 0) {
1622 cvlen = sym_get_scalar(SYMNAME(sptr), "len", DT_INT);
1623 CVLENP(sptr, cvlen);
1624 if (SCG(sptr) == SC_DUMMY)
1625 CCSYMP(cvlen, 1);
1626 }
1627 CVLENP(new, cvlen);
1628 ADJLENP(new, 1);
1629 }
1630 goto return_it;
1631 }
1632 stype = STYPEG(sptr);
1633 switch (stype) {
1634 case ST_UNKNOWN:
1635 new = sptr;
1636 STYPEP(new, ST_VAR);
1637 break;
1638 case ST_IDENT:
1639 case ST_VAR:
1640 new = insert_sym(sptr1);
1641 STYPEP(new, ST_VAR);
1642 DTYPEP(new, DTYPEG(sptr));
1643 if (ADJLENG(sptr)) {
1644 new = add_private_allocatable(sptr, new);
1645 goto return_it;
1646 } else if (ASSUMLENG(sptr)) {
1647 new = add_private_allocatable(sptr, new);
1648 goto return_it;
1649 }
1650 if (allocatable_member(sptr)) {
1651 if (checking_scope && sem.scope_stack[sem.scope_level].end_prologue != 0)
1652 nullify_member_after(
1653 mk_id(new), sem.scope_stack[sem.scope_level].end_prologue, sptr1);
1654 else
1655 nullify_member_after(mk_id(new), STD_PREV(0), sptr1);
1656 }
1657 break;
1658 case ST_STRUCT:
1659 case ST_UNION:
1660 new = insert_sym(sptr1);
1661 STYPEP(new, stype);
1662 DTYPEP(new, DTYPEG(sptr));
1663 break;
1664 case ST_ARRAY:
1665 new = insert_sym(sptr1);
1666 STYPEP(new, ST_ARRAY);
1667 DTYPEP(new, DTYPEG(sptr));
1668 if (SCG(sptr) == SC_DUMMY) {
1669 if (ASUMSZG(sptr))
1670 error(155, 3, gbl.lineno,
1671 "Assumed-size arrays cannot be specified as private",
1672 SYMNAME(sptr));
1673 }
1674 if (SCG(sptr) == SC_BASED && MIDNUMG(sptr) && !CCSYMG(MIDNUMG(sptr)) &&
1675 !HCCSYMG(MIDNUMG(sptr))) {
1676 /* Cray pointee: just copy ADJARR flag (fixes tpr3374) */
1677 ADJARRP(new, ADJARRG(sptr));
1678 } else if (ADJARRG(sptr) || RUNTIMEG(sptr) || ADJLENG(sptr)) {
1679 /*
1680 * The private copy of an adjustable/automatic array is an
1681 * allocated array. The bounds information of the adjustable array
1682 * and its private copy is the same. The private array will
1683 * be allocated from the heap; need to save the sptr of the
1684 * private copy so that it can be deallocated at the end
1685 * of the parallel construct.
1686 */
1687 new = add_private_allocatable(sptr, new);
1688 goto return_it;
1689 } else if (ASSUMSHPG(sptr)) {
1690 /*
1691 * The private copy of an assumed-shape array is an allocated
1692 * array. The bounds information of the assume-shape array
1693 * will be assigned to its private copy. The private array will
1694 * be allocated from the heap; need to save the sptr of the
1695 * private copy so that it can be deallocated at the end
1696 * of the parallel construct.
1697 */
1698 ADSC *ad;
1699 int i, ndim;
1700 int dt;
1701
1702 ad = AD_DPTR(DTYPEG(sptr));
1703 ndim = AD_NUMDIM(ad);
1704 for (i = 0; i < ndim; i++) {
1705 int lb;
1706 lb = AD_LWBD(ad, i);
1707 if (A_ALIASG(lb)) {
1708 sem.bounds[i].lowtype = S_CONST;
1709 sem.bounds[i].lowb = get_isz_cval(A_SPTRG(lb));
1710 } else {
1711 sem.bounds[i].lowtype = S_EXPR;
1712 sem.bounds[i].lowb = lb;
1713 }
1714 sem.bounds[i].lwast = lb;
1715 sem.bounds[i].uptype = S_EXPR;
1716 sem.bounds[i].upb = AD_UPBD(ad, i);
1717 sem.bounds[i].upast = AD_UPBD(ad, i);
1718 }
1719 sem.arrdim.ndim = ndim;
1720 sem.arrdim.ndefer = 0;
1721 dt = mk_arrdsc();
1722 DTY(dt + 1) = DTY(DTYPEG(sptr) + 1);
1723 DTYPEP(new, dt);
1724 new = add_private_allocatable(sptr, new);
1725 goto return_it;
1726 }
1727 break;
1728 default:
1729 sptr = new = insert_sym(sptr1);
1730 STYPEP(new, ST_VAR);
1731 break;
1732 }
1733
1734 if (SCG(sptr) != SC_BASED)
1735 SCP(new, sem.sc);
1736 else {
1737 int stp;
1738 stp = decl_private_sym(MIDNUMG(sptr));
1739 MIDNUMP(new, stp);
1740 SCP(new, SC_BASED);
1741 }
1742 if (sem.task && SCG(new) == SC_PRIVATE) {
1743 int i;
1744 for (i = sem.doif_depth; i; i--) {
1745 switch (DI_ID(i)) {
1746 case DI_TASK:
1747 case DI_TASKLOOP:
1748 TASKP(new, 1);
1749 goto td_exit;
1750 case DI_PAR:
1751 case DI_PARDO:
1752 case DI_PARSECTS:
1753 goto td_exit;
1754 }
1755 }
1756 td_exit:;
1757 }
1758 return_it:
1759 if (checking_scope && sem.scope_stack[sem.scope_level].kind == SCOPE_PAR) {
1760 rgn_level = sem.scope_stack[sem.scope_level].rgn_scope;
1761 SCOPEP(new, sem.scope_stack[rgn_level].sptr);
1762 } else
1763 SCOPEP(new, sem.scope_stack[sem.scope_level].sptr);
1764 ENCLFUNCP(new, BLK_SYM(sem.scope_level));
1765 CCSYMP(new, CCSYMG(sptr));
1766 DCLDP(new, 1); /* so DCLCHK is quiet */
1767 TARGETP(new, TARGETG(sptr));
1768 if (flg.smp) {
1769 if (!ENCLFUNCG(new)) {
1770 ENCLFUNCP(new, BLK_SCOPE_SPTR(sem.scope_level));
1771 }
1772 set_private_encl(sptr, new);
1773 if (sem.task && SCG(new) == SC_BASED) {
1774 set_private_taskflag(new);
1775 }
1776 }
1777 return new;
1778 }
1779
1780 static void
check_adjustable_array(int sptr)1781 check_adjustable_array(int sptr)
1782 {
1783 if (STYPEG(sptr) == ST_ARRAY && ADJARRG(sptr) && SCG(sptr) != SC_DUMMY) {
1784 if (!POINTERG(sptr) && !ALLOCATTRG(sptr) && !MIDNUMG(sptr)) {
1785 int pvar = sym_get_ptr(sptr);
1786
1787 SCP(pvar, SCG(sptr));
1788 SCOPEP(pvar, SCOPEG(sptr));
1789 ENCLFUNCP(pvar, ENCLFUNCG(sptr));
1790 MIDNUMP(sptr, pvar);
1791 PTRSAFEP(MIDNUMG(sptr), 1);
1792 }
1793 }
1794 }
1795
1796 static int
add_private_allocatable(int old,int new)1797 add_private_allocatable(int old, int new)
1798 {
1799 /*
1800 * The private copy of an adjustable/automatic array is an allocated
1801 * array. The bounds information of the original object and its private
1802 * copy are the same. The private array will be allocated from the heap;
1803 * need to save the sptr of the private copy so that it can be deallocated
1804 * at the end of the parallel construct.
1805 *
1806 * NOTE, need to distinguish:
1807 * 1. allocatables - conditionally allocate/deallocate
1808 * 2. pointer - no allocate/deallocate
1809 * 3. other (adj., automatic) - unconditionally allocate/deallocate
1810 */
1811 ITEM *itemp;
1812 int pvar;
1813 int allo_obj;
1814 int where;
1815
1816 SCP(new, SC_BASED);
1817 if (!POINTERG(old) && !ALLOCATTRG(old)) {
1818 pvar = getccsym('Z', new, ST_VAR);
1819 DTYPEP(pvar, DT_PTR);
1820 SCP(pvar, sem.sc);
1821 SCOPEP(pvar, sem.scope_stack[sem.scope_level].sptr);
1822 ENCLFUNCP(pvar, BLK_SYM(sem.scope_level));
1823 MIDNUMP(new, pvar);
1824 }
1825 if (ADJLENG(old)) {
1826 int cvlen = CVLENG(old);
1827 if (cvlen == 0) {
1828 cvlen = sym_get_scalar(SYMNAME(old), "len", DT_INT);
1829 CVLENP(old, cvlen);
1830 if (SCG(old) == SC_DUMMY)
1831 CCSYMP(cvlen, 1);
1832 }
1833 CVLENP(new, cvlen);
1834 ADJLENP(new, 1);
1835 if (flg.smp) {
1836 if (SCG(old) == SC_BASED)
1837 ref_based_object(old);
1838 set_parref_flag(cvlen, cvlen, BLK_UPLEVEL_SPTR(sem.scope_level));
1839 set_parref_flag(old, old, BLK_UPLEVEL_SPTR(sem.scope_level));
1840 }
1841 } else if (STYPEG(new) != ST_ARRAY && ASSUMLENG(old)) {
1842 /* 1) we don't know the size of assumlen char at compile time
1843 * 2) make private copy adjustable len char
1844 * 3) make CVLEN a private copy for convenience.
1845 */
1846 int ast;
1847 int oldlen = ast_intr(I_LEN, astb.bnd.dtype, 1, mk_id(old));
1848 int cvlen = sym_get_scalar(SYMNAME(old), "len", DT_INT);
1849 ast = mk_assn_stmt(mk_id(cvlen), oldlen, DT_INT);
1850 (void)add_stmt(ast);
1851 CVLENP(new, cvlen);
1852 ADJLENP(new, 1);
1853 SCP(cvlen, SCG(MIDNUMG(new)));
1854 ENCLFUNCP(cvlen, ENCLFUNCG(new));
1855 SCOPEP(cvlen, sem.scope_stack[sem.scope_level].sptr);
1856 if (SCG(new) == SC_DUMMY)
1857 CCSYMP(cvlen, 1);
1858 if (flg.smp) {
1859 if (SCG(old) == SC_BASED)
1860 ref_based_object(old);
1861 set_parref_flag(old, old, BLK_UPLEVEL_SPTR(sem.scope_level));
1862 }
1863 }
1864 allo_obj = mk_id(new); /* base symbol of allocation */
1865 if (STYPEG(new) == ST_ARRAY) {
1866 int dt;
1867 if (ADJARRG(old) || RUNTIMEG(old))
1868 ADJARRP(new, 1);
1869 dt = DTYPEG(new);
1870 if (ASSUMSHPG(old)) {
1871 ADJARRP(new, 1);
1872 ADD_NOBOUNDS(dt) = 1;
1873 }
1874 if (ADD_NOBOUNDS(dt)) {
1875 /*
1876 * an adjustable array with this flag set is an automatic
1877 * array. Need to use the bounds of the array in the allocation
1878 * so that lower() will correctly assign the .A temporaries.
1879 */
1880 int numdim;
1881 int subs[MAXRANK];
1882 int i;
1883 if (ALLOCATTRG(old)) {
1884 /*
1885 * an allocatable inherits its bounds from the original;
1886 * switch to the dtype of the original to get the correct
1887 * bounds.
1888 */
1889 dt = DTYPEG(old);
1890 }
1891 numdim = ADD_NUMDIM(dt);
1892 for (i = 0; i < numdim; i++) {
1893 int lb, ub;
1894
1895 lb = ADD_LWAST(dt, i);
1896 if (!lb)
1897 lb = astb.bnd.one;
1898 ub = ADD_UPAST(dt, i);
1899 if (!ub)
1900 ub = astb.bnd.one;
1901 subs[i] = mk_triple(lb, ub, 0);
1902 }
1903 allo_obj = mk_subscr(allo_obj, subs, numdim, dt);
1904 }
1905 }
1906 if (checking_scope) {
1907 /* If checking_scope (handling variables in a PARALLEL directive
1908 * with a DEFAULT(PRIVATE) or DEFAULT(FIRSTPRIVATE) clause),
1909 * we have to do the allocation in the prologue of the PARALLEL
1910 * directive. We saved "end_prologue" in do_default_clause()
1911 * in semsmp.c
1912 */
1913 where = sem.scope_stack[sem.scope_level].end_prologue;
1914 if (where == 0)
1915 interr("add_private_allocatable - can't find prologue", 0, 3);
1916 } else
1917 where = STD_PREV(0); /* Just add to the end. */
1918
1919 if (!POINTERG(old)) {
1920 itemp = (ITEM *)getitem(1, sizeof(ITEM));
1921 itemp->t.sptr = new;
1922 itemp->next = DI_ALLOCATED(sem.doif_depth);
1923 DI_ALLOCATED(sem.doif_depth) = itemp;
1924 if (ALLOCATTRG(old)) {
1925 where = add_stmt_after(add_nullify_ast(mk_id(new)), where);
1926 where = gen_conditional_alloc(mk_id(old), allo_obj, where);
1927 } else
1928 where = gen_conditional_alloc(0, allo_obj, where);
1929 if (checking_scope)
1930 sem.scope_stack[sem.scope_level].end_prologue = where;
1931 if (flg.smp) {
1932 if (SCG(old) == SC_BASED)
1933 ref_based_object(old);
1934 set_parref_flag(old, old, BLK_UPLEVEL_SPTR(sem.scope_level));
1935 }
1936 }
1937
1938 return new;
1939 }
1940
1941 static void
check_parref(int sym,int new,int orig)1942 check_parref(int sym, int new, int orig)
1943 {
1944 /* Only set parref in parallel, task, or target.
1945 * Target should cover teams and distribute.
1946 */
1947 if (!(sem.parallel || sem.task || sem.target))
1948 return;
1949
1950 if (sym == new) { /* no new private var created - set parref flag */
1951 check_adjustable_array(sym);
1952 if (STYPEG(orig) == ST_PROC && FVALG(orig) == new &&SCG(orig) == SC_EXTERN)
1953 return;
1954 if (sem.scope_stack[sem.scope_level].par_scope == PAR_SCOPE_SHARED)
1955 set_parref_flag(sym, new, BLK_UPLEVEL_SPTR(sem.scope_level));
1956 else if (is_sptr_in_shared_list(sym))
1957 set_parref_flag(sym, new, BLK_UPLEVEL_SPTR(sem.scope_level));
1958 else if (SCG(sym) == SC_DUMMY && (sem.parallel || sem.teams || sem.target))
1959 /* case where dummy argument is omp do loop upper bound */
1960 set_parref_flag(sym, new, BLK_UPLEVEL_SPTR(sem.scope_level));
1961 else if (SCOPEG(sym) && sem.scope_level && SCOPEG(sym) < sem.scope_level)
1962 set_parref_flag(sym, new, BLK_UPLEVEL_SPTR(sem.scope_level));
1963 else if (sem.task)
1964 set_parref_flag(sym, new, BLK_UPLEVEL_SPTR(sem.scope_level));
1965 }
1966 }
1967
1968 /** \brief Check the current parallel scope of a variable.
1969 \param sym Represents the variable which actually references storage.
1970 \param orig Identifier to which the sym refers; for entries, orig will be
1971 the ST_ENTRY and sym will be its FVAL.
1972
1973 If the current scope is default private, need to ensure that any variables
1974 which have not been declared in this scope are declared as private
1975 variables. If the current scope is 'none', then need to ensure that the
1976 variables were actually declared in this scope.
1977
1978 Note that at this time, ST_UNKNOWN and ST_IDENT symbols should be have
1979 been resolved.
1980 */
1981 int
sem_check_scope(int sym,int orig)1982 sem_check_scope(int sym, int orig)
1983 {
1984 int new;
1985 int no_scope;
1986
1987 checking_scope = TRUE;
1988 new = sym;
1989 if (sem.parallel || sem.task || sem.target || sem.teams
1990 || sem.orph
1991 ) {
1992 /* Cray pointees are special cases:
1993 * 1. the pointee is unaffected by the DEFAULT clause.
1994 * 2. the pointer's scope is determined at the point of the
1995 * pointee's use.
1996 *
1997 * For a Cray pointee, need to recursively check its pointer.
1998 * Check the scope of each pointer and create a private copy if
1999 * one is needed.
2000 */
2001 switch (STYPEG(orig)) {
2002 case ST_VAR:
2003 case ST_ARRAY:
2004 case ST_STRUCT:
2005 case ST_UNION:
2006 if (SCG(new) == SC_BASED && MIDNUMG(new) && !CCSYMG(MIDNUMG(new)) &&
2007 !HCCSYMG(MIDNUMG(new))) {
2008 int ptr;
2009 ptr = MIDNUMG(new);
2010 ptr = refsym(ptr, OC_OTHER);
2011 ptr = sem_check_scope(ptr, ptr);
2012 if (ptr != MIDNUMG(new)) {
2013 /* A new pointer was created, create a new pointee. */
2014 checking_scope = TRUE;
2015 new = decl_private_sym(new);
2016 }
2017 goto returnit;
2018 }
2019 break;
2020 default:
2021 break;
2022 }
2023 if (sem.scope_stack[sem.scope_level].par_scope != PAR_SCOPE_SHARED) {
2024 int s;
2025 switch (STYPEG(orig)) {
2026 case ST_ENTRY:
2027 case ST_VAR:
2028 case ST_ARRAY:
2029 case ST_STRUCT:
2030 case ST_UNION:
2031 if (STYPEG(new) != ST_ENTRY) {
2032 if (SCG(new) == SC_CMBLK) {
2033 if (THREADG(CMBLKG(new)))
2034 goto returnit;
2035 } else if (THREADG(new)) {
2036 goto returnit;
2037 }
2038 if (CCSYMG(new) || HCCSYMG(new))
2039 goto returnit;
2040 if (STYPEG(new) == ST_ARRAY && SCG(new) == SC_DUMMY && ASUMSZG(new)) {
2041 goto returnit;
2042 }
2043 }
2044 for (s = sem.scope_stack[sem.scope_level].rgn_scope;
2045 s <= sem.scope_level; s++) {
2046 if (SCOPEG(new) == sem.scope_stack[s].sptr)
2047 goto sym_ok;
2048 }
2049 no_scope = 0;
2050 if (!sem.ignore_default_none &&
2051 sem.scope_stack[sem.scope_level].par_scope == PAR_SCOPE_NONE) {
2052 no_scope = 1;
2053 }
2054 if (STYPEG(new) == ST_ENTRY)
2055 goto returnit;
2056 if (sem.scope_stack[sem.scope_level].par_scope ==
2057 PAR_SCOPE_TASKNODEFAULT) {
2058 if (sem.parallel) {
2059 /*
2060 * for a task appearing within the lexical extent
2061 * of a parallel region, only the private objects are
2062 * firstprivate
2063 */
2064 if (SCG(new) == SC_BASED && MIDNUMG(new)) {
2065 int ss, ptr;
2066 ss = new;
2067 ptr = MIDNUMG(new);
2068 while (TRUE) {
2069 if (SCG(ptr) != SC_PRIVATE)
2070 goto returnit;
2071 if (SCG(ptr) != SC_BASED)
2072 break;
2073 ss = ptr;
2074 }
2075 } else if (SCG(new) != SC_PRIVATE)
2076 goto returnit;
2077 } else {
2078 /*
2079 * for an orphaned task, all non-static objects are
2080 * firstprivate
2081 */
2082 if (SCG(new) == SC_CMBLK || SCG(new) == SC_STATIC || SAVEG(new))
2083 goto returnit;
2084 if (SCG(new) == SC_BASED && MIDNUMG(new)) {
2085 int ss, ptr;
2086 ss = new;
2087 ptr = MIDNUMG(new);
2088 while (TRUE) {
2089 if (SCG(ptr) == SC_STATIC || SCG(ptr) == SC_CMBLK)
2090 goto returnit;
2091 if (SCG(ptr) != SC_BASED)
2092 break;
2093 ss = ptr;
2094 }
2095 }
2096 }
2097 }
2098 new = decl_private_sym(new);
2099 if (no_scope) {
2100 add_no_scope_sptr(sym, new, gbl.lineno);
2101 }
2102 if (sem.scope_stack[sem.scope_level].par_scope ==
2103 PAR_SCOPE_FIRSTPRIVATE)
2104 add_assign_firstprivate(new, sym);
2105 else if (sem.scope_stack[sem.scope_level].par_scope ==
2106 PAR_SCOPE_TASKNODEFAULT)
2107 add_assign_firstprivate(new, sym);
2108 break;
2109 default:
2110 break;
2111 }
2112 sym_ok:;
2113 }
2114 }
2115 returnit:
2116 check_parref(sym, new, orig);
2117 checking_scope = FALSE;
2118 return new;
2119 }
2120