1 /*
2 * Copyright (c) 1994-2018, 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 routines called at the end of semantic processing
20 */
21
22 #include "gbldefs.h"
23 #include "global.h"
24 #include "symtab.h"
25 #include "symutl.h"
26 #include "dtypeutl.h"
27 #include "semant.h"
28 #include "error.h"
29 #include "semstk.h"
30 #include "soc.h"
31 #include "dinit.h"
32 #include "machar.h"
33 #include "state.h"
34 #include "ast.h"
35 #include "rte.h"
36 #include "rtlRtns.h"
37
38 static void do_common_blocks(void);
39 static LOGICAL is_in_currsub(int sptr);
40 static void expand_common_pointers(int);
41 static void reorder_common_pointers(int);
42 static void fix_args(int, LOGICAL);
43 static void fix_func(void);
44
45 static void do_access(void);
46 static LOGICAL chk_evar(int);
47 static void equivalence(int, int);
48 static void add_socs(int, ISZ_T, ISZ_T);
49 static void do_nml(void);
50 static void do_save(void);
51 static void do_sequence(void);
52 static void nml_equiv(int socp);
53 static void dinit_name(int sptr);
54 static void put_name(int sptr);
55 static void misc_checks(void);
56
57 static void vol_equiv(int socp);
58
59 /* define data used for equivalence processing */
60
61 typedef struct {
62 int cmblk; /* pointer to common block, or 0, or -1 */
63 int memlist; /* list of variables in this psect */
64 } PSECT;
65
66 static PSECT *psect_base;
67 static int psect_num; /* next psect number to be assigned */
68 static int psect_size; /* size of currently allocated psect array */
69 static LOGICAL in_module; /* gbl.currsub is a MODULE */
70
71 /*------------------------------------------------------------------*/
72 #define NO_PTR XBIT(49, 0x8000)
73 #define NO_CHARPTR XBIT(58, 0x1)
74 #define NO_DERIVEDPTR XBIT(58, 0x40000)
75
76 /** \brief Increment a type bound procedure's (tbp's) pass object argument
77 * position (its INVOBJ field) if we are adding a result variable as the
78 * function's first argument.
79 *
80 * The pass object's argument position of a tbp is stored in the INVOBJ
81 * field. We need to increment it when we are about to add the result
82 * variable as the first argument in the function (e.g., pointer and
83 * allocatable results). This function is passed a symbol table pointer
84 * (sptr) to a function. We check to see if there are any tbps that use
85 * the function as an implementation (i.e., the RHS of the => in a tbp
86 * declaration). If so, we check whether the first argument is already a
87 * result variable. If it is not, we increment the pass object argument
88 * position (INVOBJ field). If there is already a result variable, we
89 * skip it. If a derived type inherits from a type defined in a
90 * use associated module, it can have function tbps that already have
91 * had their argument lists set-up. That's why we can't just arbitrarily
92 * increment the INVOBJ field of a tbp.
93 *
94 * If the addit field is set, then this function is being called by
95 * ipa_semfin(). It handles a special case for IPA in which the result
96 * argument may already have been set in the semfin() function during
97 * the first compilation, but the INVOBJ has not yet been set.
98 *
99 * If a tbp has an explicit pass(arg) attribute defined, then
100 * we can just update the INVOBJ field by searching the argument list for
101 * the specified pass argument.
102 *
103 * \param sptr is the function symbol to search.
104 *
105 * \param addit is true when this is a special case for IPA (see the verbose
106 * description of this function).
107 *
108 */
109 static void
incr_invobj_for_retval_add(int impl_sptr,LOGICAL addit)110 incr_invobj_for_retval_add(int impl_sptr, LOGICAL addit)
111 {
112 int sptr2;
113
114 for (sptr2 = 1; sptr2 < stb.stg_avail; ++sptr2) {
115 int bind_sptr;
116 if (STYPEG(sptr2) == ST_MEMBER && CLASSG(sptr2) &&
117 VTABLEG(sptr2) == impl_sptr && !NOPASSG(sptr2) &&
118 (bind_sptr = BINDG(sptr2)) > NOSYM && STYPEG(bind_sptr) == ST_PROC &&
119 !INVOBJINCG(bind_sptr)) {
120 int invobj = INVOBJG(bind_sptr);
121 if (invobj == 0) {
122 invobj = find_dummy_position(impl_sptr, PASSG(sptr2));
123 if (invobj == 0) {
124 if ((addit && PASSG(sptr2) <= NOSYM) || PARAMCTG(impl_sptr) > 0)
125 invobj = 1;
126 }
127 }
128 if (invobj > 0 && (PARAMCTG(impl_sptr) < 1 ||
129 !RESULTG(aux.dpdsc_base[DPDSCG(impl_sptr)]))) {
130 INVOBJP(bind_sptr, invobj + 1);
131 INVOBJINCP(bind_sptr, TRUE);
132 }
133 }
134 }
135 }
136
137 #define USER_GNRIC_OR_OPR(sptr) \
138 (sptr > stb.firstusym && \
139 (STYPEG(sptr) == ST_USERGENERIC || STYPEG(sptr) == ST_OPERATOR))
140
141 static void
merge_generics(void)142 merge_generics(void)
143 {
144 int sptr;
145 int sptr1;
146 int sptr_genr_curscope;
147 int sptr_alias;
148 int sptr_alias_currscope;
149
150 if (sem.pgphase != PHASE_CONTAIN && !sem.use_seen)
151 return;
152
153 for (sptr = stb.firstusym; sptr < stb.stg_avail; ++sptr) {
154 sptr_genr_curscope = 0;
155 if (!USER_GNRIC_OR_OPR(sptr))
156 continue;
157 if (test_scope(sptr) == -1)
158 continue;
159 if (SCOPEG(sptr) == stb.curr_scope) {
160 sptr_genr_curscope = sptr;
161 }
162
163 /* if there is more that one user generic by this name, then they must be
164 * merged into
165 * a single generic in the current scope
166 */
167 sptr_alias_currscope = 0;
168 for (sptr1 = first_hash(sptr); sptr1 && sptr1 != NOSYM;
169 sptr1 = HASHLKG(sptr1)) {
170 if (sptr1 < stb.firstusym)
171 continue;
172 if (NMPTRG(sptr1) != NMPTRG(sptr))
173 continue;
174 if (IGNOREG(sptr) || (PRIVATEG(sptr1) && SCOPEG(sptr1) != stb.curr_scope))
175 continue;
176 if (test_scope(sptr1) == -1)
177 continue;
178
179 if (sptr1 == sptr_genr_curscope || sptr1 == sptr)
180 continue;
181 if (STYPEG(sptr1) == ST_ALIAS && USER_GNRIC_OR_OPR(sptr) &&
182 SCOPEG(sptr1) == stb.curr_scope) {
183 if (sptr_alias_currscope) {
184 /* more than one alias in current scope */
185 IGNOREP(sptr1, 1);
186 } else {
187 sptr_alias_currscope = sptr1; /* alias inserted by do_access */
188 }
189 }
190 if (!USER_GNRIC_OR_OPR(sptr1))
191 continue;
192
193 if (!sptr_genr_curscope) {
194 /* use the generic in the current scope */
195 if (SCOPEG(sptr1) == stb.curr_scope) {
196 sptr_genr_curscope = sptr1;
197 }
198 } else if (SCOPEG(sptr1) == stb.curr_scope &&
199 PRIVATEG(sptr_genr_curscope) && !PRIVATEG(sptr1)) {
200 /* if more than one generic in current scope, prefer a non-PRIVATE */
201 copy_specifics(sptr_genr_curscope, sptr1);
202 IGNOREP(sptr_genr_curscope, 1);
203 sptr_genr_curscope = sptr1;
204 }
205
206 IGNOREP(sptr, sptr != sptr_genr_curscope);
207 IGNOREP(sptr1, sptr1 != sptr_genr_curscope);
208
209 if (!sptr_genr_curscope) {
210 sptr_genr_curscope = declsym_newscope(sptr, STYPEG(sptr), DTYPEG(sptr));
211 }
212
213 if (sptr != sptr_genr_curscope) {
214 copy_specifics(sptr, sptr_genr_curscope);
215 }
216 if (sptr1 != sptr_genr_curscope) {
217 copy_specifics(sptr1, sptr_genr_curscope);
218 }
219
220 if (sptr_alias_currscope) {
221 SYMLKP(sptr_alias_currscope, sptr_genr_curscope);
222 PRIVATEP(sptr_genr_curscope, 0);
223 }
224 }
225 }
226 }
227
228 static void
inject_arg(int func_sptr,int arg_sptr,int position)229 inject_arg(int func_sptr, int arg_sptr, int position)
230 {
231 int old_args = PARAMCTG(func_sptr);
232 int new_dsc = ++aux.dpdsc_avl;
233
234 aux.dpdsc_avl += old_args + 1;
235 NEED(aux.dpdsc_avl, aux.dpdsc_base, int, aux.dpdsc_size, aux.dpdsc_avl + 50);
236 memcpy(&aux.dpdsc_base[new_dsc], &aux.dpdsc_base[DPDSCG(func_sptr)],
237 old_args * sizeof *aux.dpdsc_base);
238 memmove(&aux.dpdsc_base[new_dsc + position + 1],
239 &aux.dpdsc_base[new_dsc + position],
240 (old_args - position) * sizeof *aux.dpdsc_base);
241 aux.dpdsc_base[new_dsc + position] = arg_sptr;
242 DPDSCP(func_sptr, new_dsc);
243 PARAMCTP(func_sptr, old_args + 1);
244 }
245
246 static LOGICAL
have_class_args_been_fixed_already(int func_sptr)247 have_class_args_been_fixed_already(int func_sptr)
248 {
249 int dscptr = DPDSCG(func_sptr);
250 int count = PARAMCTG(func_sptr);
251 int j;
252
253 for (j = 0; j < count; ++j) {
254 int arg_sptr = aux.dpdsc_base[dscptr + j];
255 if (CLASSG(arg_sptr) && CCSYMG(arg_sptr))
256 return TRUE;
257 }
258 return FALSE;
259 }
260
261 static LOGICAL
add_class_arg_descr_arg(int func_sptr,int arg_sptr,int new_arg_position)262 add_class_arg_descr_arg(int func_sptr, int arg_sptr, int new_arg_position)
263 {
264 if (!CCSYMG(arg_sptr) && CLASSG(arg_sptr)) {
265 if (!needs_descriptor(arg_sptr)) {
266 /* add type descriptor argument */
267 static int tmp = 0;
268 int new_arg_sptr = getccsym_sc('O', tmp++, ST_VAR, SC_DUMMY);
269 DTYPE dtype = get_array_dtype(1, astb.bnd.dtype);
270 ADD_LWBD(dtype, 0) = 0;
271 ADD_LWAST(dtype, 0) = astb.bnd.one;
272 ADD_NUMELM(dtype) = ADD_UPBD(dtype, 0) = ADD_UPAST(dtype, 0) =
273 mk_isz_cval(get_descriptor_len(0), astb.bnd.dtype);
274 CLASSP(new_arg_sptr, 1);
275 DTYPEP(new_arg_sptr, dtype);
276 inject_arg(func_sptr, new_arg_sptr, new_arg_position);
277 PARENTP(arg_sptr, new_arg_sptr);
278 if (PARREFG(arg_sptr))
279 set_parref_flag2(new_arg_sptr, arg_sptr, 0);
280 return TRUE;
281 }
282 if (!SDSCG(arg_sptr)) {
283 /* FS#19541 - create normal descr dummy now */
284 int descr_sptr = sym_get_arg_sec(arg_sptr);
285 SDSCP(arg_sptr, descr_sptr);
286 CCSYMP(descr_sptr, TRUE);
287 }
288 }
289 return FALSE;
290 }
291
292 static void
prepend_func_result_as_first_arg(int func_sptr)293 prepend_func_result_as_first_arg(int func_sptr)
294 {
295 int fval_sptr = FVALG(func_sptr);
296
297 if (fval_sptr > NOSYM && DPDSCG(func_sptr) > 0 &&
298 aux.dpdsc_base[DPDSCG(func_sptr) + 0] != fval_sptr) {
299
300 /* Push the function result variable into the argument list as
301 * its new first argument.
302 */
303 incr_invobj_for_retval_add(func_sptr, FALSE);
304 inject_arg(func_sptr, fval_sptr, 0 /* first argument position */);
305
306 /* If fix_class_args() has already been run, and if it would have
307 * added a type descriptor argument for the new argument that we
308 * just prepended to convey the function result (i.e., it's
309 * a polymorphic pointer), then we need to create the new argument's
310 * type descriptor argument and insert it into the list at the right
311 * position.
312 */
313 if (have_class_args_been_fixed_already(func_sptr)) {
314 int last_real_arg_position = PARAMCTG(func_sptr);
315 while (--last_real_arg_position > 0) {
316 int arg_sptr =
317 aux.dpdsc_base[DPDSCG(func_sptr) + last_real_arg_position];
318 if (!CLASSG(arg_sptr) || !CCSYMG(arg_sptr))
319 break;
320 }
321 add_class_arg_descr_arg(func_sptr, fval_sptr, last_real_arg_position + 1);
322 }
323 }
324 }
325
326 /** \brief Finalize semantic processing.
327 */
328 void
semfin(void)329 semfin(void)
330 {
331 int sptr, dtype, ssptr;
332 int last_lineno;
333 INT arg;
334 int i;
335 int agoto;
336
337 last_lineno = gbl.lineno; /* presumably, line # of the END statement */
338 gbl.nowarn = FALSE; /* warnings may be inhibited for second parse */
339
340 if (sem.which_pass) {
341 if (gbl.rutype == RU_PROG)
342 flg.recursive = FALSE; /* ensure static locals for the main */
343 else if (flg.smp || flg.accmp)
344 flg.recursive = TRUE; /* no static locals */
345 }
346 if (SCOPEG(gbl.currsub)) {
347 if (STYPEG(SCOPEG(gbl.currsub)) != ST_MODULE) {
348 push_scope_level(SCOPEG(gbl.currsub), SCOPE_NORMAL);
349 } else {
350 /* Do not want to go from the contained routine to its module.
351 * As a general rule, the SCOPE field of a module routine is
352 * set to its ST_ALIAS. However, there are cases (see fs17256)
353 * where its SCOPE field is set directly to it module.
354 */
355 push_scope_level(gbl.currsub, SCOPE_NORMAL);
356 }
357 } else {
358 push_scope_level(gbl.currsub, SCOPE_NORMAL);
359 }
360
361 if (sem.which_pass || IN_MODULE) {
362 do_dinit(); /* process dinits which were deferred */
363 }
364
365 gbl.lineno = 0;
366
367 in_module = (STYPEG(gbl.currsub) == ST_MODULE);
368
369 gbl.entries =
370 (gbl.rutype == RU_BDATA) ? NOSYM : (gbl.currsub ? gbl.currsub : NOSYM);
371
372 if (sem.which_pass) {
373 #if DEBUG
374 if (DBGBIT(3, 1024)) {
375 fprintf(gbl.dbgfil, "dscptr area before modification\n");
376 for (i = 0; i < aux.dpdsc_avl; i++) {
377 arg = aux.dpdsc_base[i];
378 fprintf(gbl.dbgfil, "dscptr[%d] = %d (%s)\n", i, arg,
379 (arg ? SYMNAME(arg) : ""));
380 }
381 }
382 #endif
383
384 /* walk thru all of the dummy arguments of the entries in the
385 * subprogram to fix stypes of the args which were not referenced.
386 * Expand the parameter descriptor for an entry which returns a
387 * derived type and/or has derived-type arguments.
388 */
389 for (sptr = gbl.entries; sptr != NOSYM; sptr = SYMLKG(sptr)) {
390 ENDLINEP(sptr, last_lineno);
391 gbl.lineno = FUNCLINEG(sptr);
392 if (gbl.rutype == RU_FUNC) {
393 (void)ref_entry(sptr);
394 }
395 if (STYPEG(sptr) != ST_MODULE)
396 fix_args(sptr, gbl.rutype == RU_FUNC);
397 }
398
399 #if DEBUG
400 if (DBGBIT(3, 1024)) {
401 fprintf(gbl.dbgfil, "dscptr area after modification\n");
402 for (i = 0; i < aux.dpdsc_avl; i++) {
403 arg = aux.dpdsc_base[i];
404 fprintf(gbl.dbgfil, "dscptr[%d] = %d (%s)\n", i, arg,
405 (arg ? SYMNAME(arg) : ""));
406 }
407 }
408 #endif
409
410 /* If this is a function subprogram, loop thru entries to check
411 * data type and do some stuff for character functions:
412 */
413 if (gbl.rutype == RU_FUNC) {
414 int ent_dtype; /* dtype of ENTRY */
415
416 sptr = gbl.entries;
417 dtype = DTYPEG(sptr);
418 for (; sptr != NOSYM; sptr = SYMLKG(sptr)) {
419 gbl.lineno = FUNCLINEG(sptr);
420 ent_dtype = DTYPEG(sptr);
421 if (POINTERG(sptr))
422 PTRARGP(sptr, 1);
423 /*Constraint: A function name must not be declared with an asterisk
424 *type-param-value if the function is an internal or module
425 *function,array-valued, pointer-valued, or recursive.
426 */
427 if (ASSUMLENG(sptr) &&
428 (POINTERG(sptr) || RECURG(sptr) || DTY(ent_dtype) == TY_ARRAY ||
429 gbl.internal > 1)) {
430 error(48, 3, gbl.lineno, SYMNAME(sptr), SYMNAME(gbl.entries));
431 }
432 if (DTYG(dtype) == TY_DERIVED) {
433 if (DTYG(ent_dtype) != DTYG(dtype)) {
434 error(45, 3, gbl.lineno, SYMNAME(sptr), SYMNAME(gbl.entries));
435 continue;
436 }
437 }
438 switch (DTY(dtype)) {
439 case TY_ARRAY:
440 /*
441 * If an array function, all entries must return arrays of the
442 * same type and shape; make the temporary the first argument.
443 */
444 prepend_func_result_as_first_arg(sptr);
445 if (DTY(ent_dtype) != TY_ARRAY ||
446 DTY(ent_dtype + 1) != DTY(dtype + 1) ||
447 !conformable(ent_dtype, dtype))
448 error(45, 3, gbl.lineno, SYMNAME(sptr), SYMNAME(gbl.entries));
449 gbl.rutype = RU_SUBR;
450 SCP(FVALG(sptr), SC_DUMMY);
451 STYPEP(FVALG(sptr), ST_ARRAY);
452 DTYPEP(sptr, DT_NONE);
453 if (ASUMSZG(FVALG(sptr)))
454 error(155, 3, gbl.lineno,
455 "Array function result may not be assumed-size -",
456 SYMNAME(sptr));
457 break;
458 case TY_CHAR:
459 case TY_NCHAR: /* kanji */
460 /*
461 * Character Functions must return the same type.
462 */
463 if (dtype != ent_dtype)
464 error(45, 3, gbl.lineno, SYMNAME(sptr), SYMNAME(gbl.entries));
465 if (!POINTERG(sptr) && ADJLENG(FVALG(sptr))) {
466 prepend_func_result_as_first_arg(sptr);
467 gbl.rutype = RU_SUBR;
468 DTYPEP(sptr, DT_NONE);
469 SCP(FVALG(sptr), SC_DUMMY);
470 break;
471 }
472 goto pointer_check;
473 case TY_DCMPLX:
474 if (DTY(ent_dtype) != TY_DCMPLX) {
475 error(45, 3, gbl.lineno, SYMNAME(sptr), SYMNAME(gbl.entries));
476 break;
477 }
478 goto pointer_check;
479 default:
480 if (DTY(ent_dtype) == TY_DCMPLX || DTY(ent_dtype) == TY_CHAR ||
481 DTY(ent_dtype) == TY_NCHAR)
482 error(45, 3, gbl.lineno, SYMNAME(sptr), SYMNAME(gbl.entries));
483 pointer_check:
484 STYPEP(FVALG(sptr), ST_VAR);
485 if (POINTERG(sptr) || ALLOCATTRG(FVALG(sptr))) {
486 /* We convert a pointer-valued function into a subroutine whose
487 * first dummy argument is the result now, really late in
488 * semantic analysis.
489 */
490 prepend_func_result_as_first_arg(sptr);
491 gbl.rutype = RU_SUBR;
492 DTYPEP(sptr, DT_NONE);
493 SCP(FVALG(sptr), SC_DUMMY);
494 }
495 break;
496 }
497 }
498 }
499
500 /* Check for undefined labels */
501
502 gbl.lineno = 0;
503 agoto = 0;
504 for (sptr = sem.flabels; sptr; sptr = SYMLKG(sptr)) {
505 int fmt;
506 if (!DEFDG(sptr))
507 errlabel(113, 3, gbl.lineno, SYMNAME(sptr), CNULL);
508 else if ((fmt = FMTPTG(sptr))) {
509 if (!DINITG(fmt))
510 errlabel(218, 3, gbl.lineno, SYMNAME(sptr), "is not a FORMAT");
511 else if (TARGETG(sptr))
512 errlabel(218, 3, gbl.lineno, SYMNAME(sptr),
513 "must be a branch target statement");
514 if (RFCNTG(sptr))
515 REFP(fmt, 1);
516 if (ASSNG(sptr)) {
517 (void)sym_mkfunc_nodesc(mkRteRtnNm(RTE_loc), DT_ADDR);
518 }
519 } else if (ASSNG(sptr)) {
520 agoto++;
521 AGOTOP(sptr, agoto);
522 }
523 }
524 } else {
525 for (sptr = gbl.entries; sptr != NOSYM; sptr = SYMLKG(sptr)) {
526 int dpdsc, paramct, i;
527 if (STYPEG(sptr) != ST_MODULE) {
528 paramct = PARAMCTG(sptr);
529 dpdsc = DPDSCG(sptr);
530 for (i = 0; i < paramct; ++i) {
531 int arg;
532 arg = aux.dpdsc_base[dpdsc + i];
533 if (ASSUMSHPG(arg) && !XBIT(54, 2) &&
534 !(XBIT(58, 0x400000) && TARGETG(arg))) {
535 SDSCS1P(arg, 1);
536 }
537 }
538 }
539 }
540 }
541
542 do_common_blocks();
543
544 /* Process PUBLIC/PRIVATE data */
545
546 do_access();
547
548 merge_generics();
549
550 /* Process data from EQUIVALENCE statements */
551
552 if (sem.eqvlist != 0)
553 do_equiv();
554
555 /* Process data from SAVE statements */
556
557 if (sem.savloc || sem.savall)
558 do_save();
559
560 /* Process data from NAMELIST statements */
561
562 do_nml();
563
564 /* Process data from [NO]SEQUENCE statements */
565
566 flg.sequence = TRUE;
567 flg.hpf = FALSE;
568 do_sequence();
569
570 if (sem.which_pass) {
571 /* fixup argument area for array-valued functions */
572
573 for (sptr = aux.list[ST_PROC]; sptr != NOSYM; sptr = SLNKG(sptr)) {
574 #if DEBUG
575 /* aux.list[ST_PROC] must be terminated with NOSYM, not 0 */
576 assert(sptr > 0, "semfin: corrupted aux.list[ST_PROC]", sptr, 4);
577 #endif
578 dtype = DTYPEG(sptr);
579 if (PARAMCTG(sptr)) {
580 fix_args(sptr, dtype != DT_NONE);
581 fix_class_args(sptr);
582 }
583 if (POINTERG(sptr))
584 PTRARGP(sptr, 1);
585 if (DTY(dtype) == TY_ARRAY) {
586 /*
587 * If an array function, all entries must return arrays of the
588 * same type and shape; make the temporary the first argument.
589 */
590 STYPEP(FVALG(sptr), ST_ARRAY);
591 prepend_func_result_as_first_arg(sptr);
592 FUNCP(sptr, 0);
593 if (ASUMSZG(FVALG(sptr)))
594 error(155, 3, gbl.lineno,
595 "Array function result may not be assumed-size -",
596 SYMNAME(sptr));
597 } else {
598 STYPEP(FVALG(sptr), ST_VAR);
599 if (POINTERG(sptr) || ALLOCATTRG(FVALG(sptr)) ||
600 allocatable_member(FVALG(sptr)) || ADJLENG(FVALG(sptr))) {
601 prepend_func_result_as_first_arg(sptr);
602 (void)ref_entry(sptr);
603 IGNOREP(FVALG(sptr), TRUE);
604 FUNCP(sptr, 0);
605 DTYPEP(sptr, DT_NONE);
606 }
607 }
608 }
609 /* fixing up procedure pointer dtype that contain interfaces and convert
610 * from function to subroutine.
611 */
612 for (i = 0; i < sem.typroc_avail; i++) {
613 int fval;
614 int procdt, iface;
615 procdt = sem.typroc_base[i];
616 iface = DTY(procdt + 2);
617 fval = FVALG(iface);
618 if (iface && fval) {
619 dtype = DTY(procdt + 1); /* result type */
620 if (DTY(dtype) == TY_ARRAY || POINTERG(iface) || ALLOCATTRG(fval) ||
621 allocatable_member(fval)) {
622 if (iface) {
623 prepend_func_result_as_first_arg(iface);
624 (void)ref_entry(iface);
625 IGNOREP(FVALG(iface), TRUE);
626 FUNCP(iface, 0);
627 DTYPEP(iface, DT_NONE);
628 }
629 /* insert function result -- there is a space reserved for it */
630 DTY(procdt + 3) += 1; /* PARAMCT */
631 DTY(procdt + 4) -= 1; /* DPDSC */
632 aux.dpdsc_base[DTY(procdt + 4)] = fval;
633 }
634 }
635 }
636 }
637
638 misc_checks();
639
640 if (sem.which_pass == 0 && !in_module) {
641 df_dinit_end();
642 }
643
644 gbl.lineno = last_lineno;
645 queue_tbp(0, 0, 0, 0, TBP_COMPLETE_FIN);
646 if (sem.which_pass) {
647 for (sptr = stb.firstosym; sptr < stb.stg_avail; ++sptr) {
648 fixup_reqgs_ident(sptr);
649 }
650 }
651 pop_scope_level(SCOPE_NORMAL);
652 }
653
654 /*
655 * Put pointer member pointer/offset/descriptor into common block.
656 * Assign addresses to common block elements and compute size of
657 * common blocks:
658 */
659 static void
do_common_blocks(void)660 do_common_blocks(void)
661 {
662 int sptr;
663
664 for (sptr = gbl.cmblks; sptr != NOSYM; sptr = SYMLKG(sptr)) {
665 int std_err, member, ssptr;
666 ISZ_T size;
667 int aln_n = 1;
668
669 if (!XBIT(49, 0x10000000)) {
670 expand_common_pointers(sptr);
671 } else {
672 reorder_common_pointers(sptr);
673 }
674
675 for (member = CMEMFG(sptr); member != NOSYM; member = SYMLKG(member)) {
676 if (EQVG(member) && SOCPTRG(member)) {
677 /* this was already processed, probably part of
678 * a module common block, and we are in a contained function */
679 int socptr;
680 for (socptr = SOCPTRG(member); socptr; socptr = SOC_NEXT(socptr)) {
681 int socsptr = SOC_SPTR(socptr);
682 if (!EQVG(socsptr)) {
683 ISZ_T diff = ADDRESSG(member) - ADDRESSG(socsptr);
684 ADDRESSP(member, diff);
685 break;
686 }
687 }
688 }
689 }
690 std_err = 0;
691 size = 0;
692 for (member = CMEMFG(sptr); member != NOSYM; member = SYMLKG(member)) {
693 ISZ_T next_off, msz;
694 int addr, dtype, ssptr;
695 const char *errmsg = 0;
696
697 if (EQVG(member))
698 continue;
699 addr = alignment_of_var(member);
700 next_off = size;
701 size = ALIGN(size, addr);
702 if (!CCSYMG(sptr) && !HCCSYMG(sptr) && next_off != size &&
703 sem.which_pass == 1) {
704 error(63, ERR_Informational, LINENOG(member), SYMNAME(sptr),
705 SYMNAME(member));
706 }
707 ADDRESSP(member, size);
708 REFP(member, 1);
709 dtype = DTYPEG(member);
710 msz = 0;
711
712 if (STYPEG(member) == ST_ARRAY) {
713 /* NEC 301 / tpr 2583
714 * Added check for deferred shape array in `if' below.
715 * Deferred shape is set for common block members that
716 * are aligned or distributed.
717 */
718 if (ALLOCG(member) && !POINTERG(member) && !HCCSYMG(sptr) &&
719 !ADD_DEFER(dtype)) {
720 errmsg = "- an allocatable array cannot be in COMMON";
721 } else if (ADJARRG(member)) {
722 errmsg = "- an adjustable array cannot be in COMMON";
723 } else if ((DTY(dtype) == TY_CHAR || DTY(dtype) == TY_NCHAR) &&
724 ADJLENG(member)) {
725 errmsg = "- an adjustable-length character array cannot be in COMMON";
726 }
727 } else if ((DTY(dtype) == TY_CHAR || DTY(dtype) == TY_NCHAR) &&
728 ADJLENG(member)) {
729 errmsg =
730 "- an adjustable-length character variable cannot be in COMMON";
731 }
732 if (ALLOCATTRG(member)) {
733 errmsg = "- an allocatable object cannot be in COMMON";
734 }
735 if (errmsg) {
736 if (is_in_currsub(sptr)) {
737 error(84, ERR_Severe, LINENOG(member), SYMNAME(member), errmsg);
738 }
739 msz = 0;
740 } else {
741 msz = size_of_var(member);
742 }
743
744 size += pad_cmn_mem(member, msz, &aln_n);
745
746 if (DTYG(dtype) == TY_CHAR) {
747 std_err |= 1;
748 } else if (DTYG(dtype) == TY_NCHAR) {
749 std_err |= 4;
750 } else {
751 std_err |= 2;
752 }
753 if (VOLG(sptr)) { /* note: common may not be volatile but */
754 VOLP(member, 1); /* a member may */
755 }
756 }
757 for (member = CMEMFG(sptr); member != NOSYM; member = SYMLKG(member)) {
758 if (EQVG(member) && SOCPTRG(member)) {
759 /* finish up: set address of equivalenced member relative
760 * to address of its overlap member */
761 int socptr;
762 for (socptr = SOCPTRG(member); socptr; socptr = SOC_NEXT(socptr)) {
763 int socsptr = SOC_SPTR(socptr);
764 if (!EQVG(socsptr)) {
765 ISZ_T diff = ADDRESSG(member) + ADDRESSG(socsptr);
766 ADDRESSP(member, diff);
767 break;
768 }
769 }
770 }
771 }
772 SIZEP(sptr, size);
773 if (sem.savall) {
774 SAVEP(sptr, 1);
775 }
776 if (is_in_currsub(sptr)) {
777 if (flg.standard) {
778 if (std_err != 1 && std_err != 2) {
779 error(182, ERR_Warning, LINENOG(sptr), SYMNAME(sptr), CNULL);
780 }
781 } else if (std_err & 4 && std_err != 4) {
782 error(184, ERR_Warning, LINENOG(sptr), SYMNAME(sptr), CNULL);
783 }
784 /* check for name conflict between common name and program unit
785 * or other entry points */
786 for (ssptr = first_hash(sptr); ssptr >= stb.firstusym;
787 ssptr = HASHLKG(ssptr)) {
788 if (NMPTRG(ssptr) != NMPTRG(sptr))
789 continue;
790 if (IGNOREG(ssptr))
791 continue;
792 if (ssptr == gbl.currsub || STYPEG(ssptr) == ST_ENTRY) {
793 /* conflict between common block and entry point name */
794 error(166, ERR_Severe, LINENOG(sptr), SYMNAME(sptr), CNULL);
795 }
796 }
797 }
798 }
799 }
800
801 /* is the scope this symbol the currsub */
802 static LOGICAL
is_in_currsub(int sptr)803 is_in_currsub(int sptr)
804 {
805 int scope = SCOPEG(sptr);
806 while (STYPEG(scope) == ST_ALIAS) {
807 scope = SYMLKG(scope);
808 }
809 return scope == gbl.currsub;
810 }
811
812 static void
expand_common_pointers(int sptr)813 expand_common_pointers(int sptr)
814 {
815 /*
816 * Expand POINTER members in the common by placing the pointer/offset
817 * descriptor with respect to the order of the member's appearance
818 * in the common block -- this is standard f90/f95/f2003 behavior.
819 */
820 int member;
821 int nextmember, lastmember, nextlastmember, firstpointer;
822
823 firstpointer = 0;
824 lastmember = 0;
825 for (member = CMEMFG(sptr); member != NOSYM;
826 lastmember = nextlastmember, member = nextmember) {
827 nextlastmember = member;
828 nextmember = SYMLKG(member);
829 if (STYPEG(member) == ST_IDENT || STYPEG(member) == ST_UNKNOWN)
830 STYPEP(member, ST_VAR);
831
832 if (SDSCG(member) == 0 && !F90POINTERG(member) &&
833 (POINTERG(member) || ALLOCG(member))) {
834 get_static_descriptor(member);
835 get_all_descriptors(member);
836 SCP(member, SC_BASED);
837 }
838 if (POINTERG(member)) {
839 int ptr, off, sdsc, added;
840 added = 0;
841 ptr = MIDNUMG(member);
842 if (ptr && SCG(ptr) != SC_CMBLK) {
843 SCP(ptr, SC_CMBLK);
844 CMBLKP(ptr, sptr);
845 if (lastmember)
846 SYMLKP(lastmember, ptr);
847 else
848 firstpointer = ptr;
849 lastmember = ptr;
850 added = 1;
851 }
852 off = PTROFFG(member);
853 if (off && SCG(off) != SC_CMBLK) {
854 SCP(off, SC_CMBLK);
855 CMBLKP(off, sptr);
856 if (lastmember)
857 SYMLKP(lastmember, off);
858 else
859 firstpointer = off;
860 lastmember = off;
861 added = 1;
862 }
863 sdsc = SDSCG(member);
864 if (sdsc && SCG(sdsc) != SC_CMBLK) {
865 SCP(sdsc, SC_CMBLK);
866 CMBLKP(sdsc, sptr);
867 if (lastmember)
868 SYMLKP(lastmember, sdsc);
869 else
870 firstpointer = sdsc;
871 lastmember = sdsc;
872 added = 1;
873 }
874 if (added) {
875 /* remove base variable from common block? leave it? */
876 int dtype, dty;
877 int useptr = 1;
878 dtype = DTYPEG(member);
879 dty = DTYG(dtype);
880 if (NO_PTR) {
881 useptr = 0;
882 } else if ((dty == TY_NCHAR || dty == TY_CHAR) && NO_CHARPTR) {
883 useptr = 0;
884 } else if (dty == TY_DERIVED && NO_DERIVEDPTR) {
885 useptr = 0;
886 }
887 if (useptr) {
888 /* remove the base variable from the common block */
889 SYMLKP(lastmember, nextmember);
890 nextlastmember = lastmember;
891 CMBLKP(member, 0);
892 SYMLKP(member, NOSYM);
893 SCP(member, SC_BASED);
894 } else {
895 SYMLKP(lastmember, member);
896 }
897 }
898 }
899 }
900 /* link list of pointer/offset/descriptor at from of common block */
901 if (firstpointer)
902 CMEMFP(sptr, firstpointer);
903 CMEMLP(sptr, lastmember);
904 }
905
906 static void
reorder_common_pointers(int sptr)907 reorder_common_pointers(int sptr)
908 {
909 /*
910 * Expand POINTER members in the common by placing the pointer/offset
911 * descriptor near the beginning of common block because of alignment
912 * restrictions This is not standard f90/f95/f2003 behavior, but
913 * ok for HPF since storage association rules are allowed to be violated.
914 */
915 int member, nextmember, lastmember, nextlastmember, firstpointer, lastpointer;
916
917 firstpointer = lastpointer = 0;
918 lastmember = 0;
919 for (member = CMEMFG(sptr); member != NOSYM;
920 lastmember = nextlastmember, member = nextmember) {
921 nextlastmember = member;
922 nextmember = SYMLKG(member);
923 if (STYPEG(member) == ST_IDENT || STYPEG(member) == ST_UNKNOWN)
924 STYPEP(member, ST_VAR);
925 if (SDSCG(member) == 0 && !F90POINTERG(member) &&
926 (POINTERG(member) || ALLOCG(member))) {
927 get_static_descriptor(member);
928 get_all_descriptors(member);
929 SCP(member, SC_BASED);
930 }
931 if (POINTERG(member)) {
932 int ptr, off, sdsc, added;
933 added = 0;
934 ptr = MIDNUMG(member);
935 if (ptr && SCG(ptr) != SC_CMBLK) {
936 SCP(ptr, SC_CMBLK);
937 CMBLKP(ptr, sptr);
938 if (lastpointer)
939 SYMLKP(lastpointer, ptr);
940 else
941 firstpointer = ptr;
942 lastpointer = ptr;
943 added = 1;
944 }
945 off = PTROFFG(member);
946 if (off && SCG(off) != SC_CMBLK) {
947 SCP(off, SC_CMBLK);
948 CMBLKP(off, sptr);
949 if (lastpointer)
950 SYMLKP(lastpointer, off);
951 else
952 firstpointer = off;
953 lastpointer = off;
954 added = 1;
955 }
956 sdsc = SDSCG(member);
957 if (sdsc && SCG(sdsc) != SC_CMBLK) {
958 SCP(sdsc, SC_CMBLK);
959 CMBLKP(sdsc, sptr);
960 if (lastpointer)
961 SYMLKP(lastpointer, sdsc);
962 else
963 firstpointer = sdsc;
964 lastpointer = sdsc;
965 added = 1;
966 }
967 if (added) {
968 /* remove base variable from common block? leave it? */
969 int dtype, dty;
970 int useptr = 1;
971 dtype = DTYPEG(member);
972 dty = DTYG(dtype);
973 if (NO_PTR) {
974 useptr = 0;
975 } else if ((dty == TY_NCHAR || dty == TY_CHAR) && NO_CHARPTR) {
976 useptr = 0;
977 } else if (dty == TY_DERIVED && NO_DERIVEDPTR) {
978 useptr = 0;
979 }
980 if (useptr) {
981 /* remove the base variable from the common block */
982 if (lastmember) {
983 SYMLKP(lastmember, nextmember);
984 } else {
985 CMEMFP(sptr, nextmember);
986 }
987 nextlastmember = lastmember;
988 CMBLKP(member, 0);
989 SYMLKP(member, NOSYM);
990 SCP(member, SC_BASED);
991 }
992 }
993 }
994 }
995 /* link list of pointer/offset/descriptor at from of common block */
996 if (lastpointer) {
997 SYMLKP(lastpointer, CMEMFG(sptr));
998 CMEMFP(sptr, firstpointer);
999 if (lastmember == 0)
1000 lastmember = lastpointer;
1001 }
1002 CMEMLP(sptr, lastmember);
1003 }
1004
1005 /** \brief Deallocate data structures for semantic analysis.
1006 */
1007 void
semfin_free_memory(void)1008 semfin_free_memory(void)
1009 {
1010 if (sem.doif_base == NULL)
1011 return;
1012 FREE(sem.doif_base);
1013 sem.doif_base = NULL;
1014 FREE(sem.stsk_base);
1015 sem.stsk_base = NULL;
1016 FREE(switch_base);
1017 switch_base = NULL;
1018 FREE(sem.interf_base);
1019 sem.interf_base = NULL;
1020 FREE(sem.scope_stack);
1021 sem.scope_stack = NULL;
1022 FREE(sem.typroc_base);
1023 sem.typroc_base = NULL;
1024 FREE(sem.iface_base);
1025 sem.iface_base = NULL;
1026 freearea(3); /* free area used for stmt function,
1027 * [NO]SEQUENCE info, and access info
1028 *
1029 * NOTE: 9/17/97, area 8 is used for stmt
1030 * functions -- need to keep just in case
1031 * the defs appear in a containing subprogram.
1032 */
1033 freearea(1); /* DOINFO records */
1034 }
1035
1036 /** \brief Add type descriptor arguments to a specified function if they have
1037 not already been added.
1038 \param sptr is the symbol table pointer of the specified function.
1039 */
1040 void
fix_class_args(int func_sptr)1041 fix_class_args(int func_sptr)
1042 {
1043 int orig_count, new_arg_position, j;
1044
1045 if (!have_class_args_been_fixed_already(func_sptr)) {
1046 /* type descriptors have not yet been added, so now we add them */
1047 int orig_count = PARAMCTG(func_sptr);
1048 int new_arg_position = orig_count;
1049 int j;
1050 for (j = 0; j < orig_count; ++j) {
1051 int arg_sptr = aux.dpdsc_base[DPDSCG(func_sptr) + j];
1052 if (add_class_arg_descr_arg(func_sptr, arg_sptr, new_arg_position))
1053 ++new_arg_position;
1054 }
1055 }
1056 }
1057
1058 static void
fix_args(int sptr,LOGICAL is_func)1059 fix_args(int sptr, LOGICAL is_func)
1060 {
1061 /* walk thru all of the dummy arguments of the entries in the
1062 * subprogram to fix stypes of the args which were not referenced or
1063 * to replace a derived argument with its components.
1064 */
1065 int arg, arg1;
1066 int count;
1067 int dscptr, i;
1068 /*
1069 * use a true pointer for locating the arguments; don't reallocate
1070 * aux.dpsdc_base between this assignment and its uses.
1071 */
1072 dscptr = DPDSCG(sptr);
1073 for (i = 0; i < PARAMCTG(sptr); ++i) {
1074 arg = aux.dpdsc_base[dscptr + i];
1075 /* watch for alternate return specifier */
1076 if (arg) {
1077 #if DEBUG
1078 assert(SCG(arg) == SC_DUMMY, "fix_args: arg not dummy", arg, 3);
1079 #endif
1080 switch (STYPEG(arg)) {
1081 case ST_UNKNOWN:
1082 case ST_IDENT:
1083 STYPEP(arg, ST_VAR);
1084 break;
1085 case ST_ARRAY:
1086 if (ELEMENTALG(sptr)) {
1087 errsev(461);
1088 continue;
1089 }
1090 break;
1091 case ST_PROC:
1092 /* don't DCLCHK if used as a subroutine */
1093 if (ELEMENTALG(sptr)) {
1094 errsev(463);
1095 }
1096 if (FUNCG(arg) == 0) {
1097 if (!SDSCG(arg) && IS_PROC_DUMMYG(arg)) {
1098 get_static_descriptor(arg);
1099 }
1100 continue;
1101 }
1102 break;
1103 default:
1104 break;
1105 }
1106 if (ASSNG(arg) && INTENTG(arg) == INTENT_IN) {
1107 error(194, 2, gbl.lineno, SYMNAME(arg), CNULL);
1108 INTENTP(arg, INTENT_DFLT);
1109 }
1110
1111 if (sptr == gbl.currsub && ALLOCATTRG(arg) &&
1112 INTENTG(arg) == INTENT_OUT) {
1113 gen_conditional_dealloc_for_sym(arg, ENTSTDG(sptr));
1114 }
1115 if (!SDSCG(arg) && IS_PROC_DUMMYG(arg)) {
1116 get_static_descriptor(arg);
1117 } else if (POINTERG(arg)) {
1118 if (ELEMENTALG(sptr)) {
1119 errsev(462);
1120 }
1121 PTRARGP(sptr, 1);
1122 if (!SDSCG(arg) && !F90POINTERG(arg)) {
1123 /* only unreferenced dummies should get here.
1124 we could give an informational message.
1125 */
1126 get_static_descriptor(arg);
1127 get_all_descriptors(arg);
1128 }
1129 }
1130 }
1131 }
1132 if (FVALG(sptr)) {
1133 arg = FVALG(sptr);
1134 if (POINTERG(arg)) {
1135 if (ELEMENTALG(sptr)) {
1136 errsev(462);
1137 }
1138 PTRARGP(sptr, 1);
1139 if (!SDSCG(arg) && !F90POINTERG(arg)) {
1140 /* unreferenced return value.
1141 we could give an informational message.
1142 */
1143 get_static_descriptor(arg);
1144 get_all_descriptors(arg);
1145 }
1146 }
1147 }
1148
1149 }
1150
1151 void
llvm_fix_args(int sptr,LOGICAL is_func)1152 llvm_fix_args(int sptr, LOGICAL is_func)
1153 {
1154 fix_args(sptr, is_func);
1155 }
1156
1157 static int
gen_accl_alias(int sptr,ACCL * accessp)1158 gen_accl_alias(int sptr, ACCL *accessp)
1159 {
1160 int osptr = sptr;
1161
1162 sptr = insert_sym(accessp->sptr);
1163 STYPEP(sptr, ST_ALIAS);
1164 SCOPEP(sptr, stb.curr_scope);
1165 IGNOREP(sptr, 0);
1166 if (STYPEG(osptr) == ST_ALIAS) {
1167 SYMLKP(sptr, SYMLKG(osptr));
1168 } else {
1169 SYMLKP(sptr, osptr);
1170 }
1171 return sptr;
1172 }
1173
1174 static void
do_access(void)1175 do_access(void)
1176 {
1177 int sptr, a, encl, ssptr;
1178 int sptrmem;
1179 int nsyms;
1180 int stype;
1181 ACCL *accessp;
1182
1183 if (sem.accl.type == 'v') {
1184 /* scan entire symbol table to find variables to mark private */
1185 nsyms = stb.stg_avail - 1;
1186 for (sptr = stb.firstusym; sptr <= nsyms; ++sptr) {
1187 stype = STYPEG(sptr);
1188 switch (stype) {
1189 case ST_IDENT:
1190 case ST_VAR:
1191 case ST_ARRAY:
1192 case ST_STRUCT:
1193 case ST_UNION:
1194 /*
1195 ** PUBLIC/PRIVATE attribute *is* allowed for common block variables! **
1196
1197 if (SCG(sptr) == SC_CMBLK)
1198 break;
1199 */
1200 case ST_UNKNOWN:
1201 case ST_NML:
1202 case ST_PROC:
1203 case ST_PARAM:
1204 case ST_TYPEDEF:
1205 case ST_OPERATOR:
1206 case ST_MODPROC:
1207 case ST_CMBLK:
1208 case ST_USERGENERIC:
1209 encl = ENCLFUNCG(sptr);
1210 if (encl && STYPEG(encl) == ST_MODULE && encl != gbl.currsub)
1211 break;
1212 if ((stype == ST_PROC || stype == ST_OPERATOR ||
1213 stype == ST_USERGENERIC) &&
1214 CLASSG(sptr) && VTOFFG(sptr))
1215 break; /* tbp PRIVATE set in derived type */
1216 if (is_procedure_ptr(sptr))
1217 break; /* FS#21906: proc ptr PRIVATE set at declaration */
1218 PRIVATEP(sptr, 1);
1219 break;
1220 case ST_ALIAS:
1221 encl = SCOPEG(sptr);
1222 if (encl && STYPEG(encl) == ST_MODULE && encl != gbl.currsub)
1223 break;
1224 PRIVATEP(sptr, 1);
1225 break;
1226 case ST_MODULE:
1227 if (sptr == gbl.currsub) {
1228 /* the module being defined contains PRIVATE */
1229 PRIVATEP(sptr, 1);
1230 }
1231 break;
1232 default:
1233 break;
1234 }
1235 }
1236 }
1237 /*
1238 * traverse access list and process any variables which appeared with
1239 * the access attribute
1240 */
1241 for (accessp = sem.accl.next; accessp != NULL; accessp = accessp->next) {
1242 int rsptr;
1243 if (accessp->oper == 'o') {
1244 rsptr = sym_in_scope(accessp->sptr, OC_OPERATOR, &sptr, NULL, 0);
1245 } else {
1246 rsptr = sym_in_scope(accessp->sptr, OC_OTHER, &sptr, NULL, 0);
1247 }
1248 /* the original symbol may have been from a module
1249 * or be overloaded with a predefined name */
1250 if (sptr < stb.firstosym) {
1251 if (in_module) {
1252 if (TYPDG(accessp->sptr)) {
1253 /* can't issue public/private for intrinsics */
1254 error(155, 2, gbl.lineno, "PUBLIC/PRIVATE attribute ignored for",
1255 SYMNAME(sptr));
1256 continue;
1257 } else if (DCLDG(accessp->sptr) && STYPEG(accessp->sptr) != ST_MEMBER) {
1258 /* type declared, make a variable of this type */
1259 sptr = insert_sym(accessp->sptr);
1260 STYPEP(sptr, ST_VAR);
1261 SCOPEP(sptr, stb.curr_scope);
1262 IGNOREP(sptr, 0);
1263 SYMLKP(sptr, 0);
1264 DCLDP(sptr, 1);
1265 DTYPEP(sptr, DTYPEG(accessp->sptr));
1266 } else {
1267 /* otherwise, treat like a new symbol */
1268 sptr = insert_sym(accessp->sptr);
1269 if (in_module) {
1270 STYPEP(sptr, ST_UNKNOWN);
1271 } else {
1272 STYPEP(sptr, ST_IDENT);
1273 }
1274 SCOPEP(sptr, stb.curr_scope);
1275 IGNOREP(sptr, 0);
1276 SYMLKP(sptr, 0);
1277 }
1278 }
1279 } else if (sptr < stb.firstusym ||
1280 ((SCOPEG(sptr) && SCOPEG(sptr) != gbl.currsub &&
1281 STYPEG(SCOPEG(sptr)) == ST_MODULE) &&
1282 (STYPEG(sptr) != ST_ALIAS || SCOPEG(sptr) != stb.curr_scope))) {
1283 /* insert an ST_ALIAS for that symbol */
1284 int osptr;
1285 osptr = gen_accl_alias(sptr, accessp);
1286 PRIVATEP(osptr, accessp->type == 'v');
1287 continue;
1288 }
1289 stype = STYPEG(sptr);
1290 switch (stype) {
1291 case ST_UNKNOWN:
1292 if (in_module) {
1293 if (sem.none_implicit) {
1294 /* can't be a variable, wouldn't be an unknown */
1295 SPTR sptr2 = findByNameStypeScope(SYMNAME(sptr), ST_INTRIN, 0);
1296 if (sptr2 > NOSYM && sptr != sptr2) {
1297 STYPEP(sptr, ST_ALIAS);
1298 PRIVATEP(sptr, accessp->type == 'v');
1299 SYMLKP(sptr, sptr2);
1300 SCOPEP(sptr, stb.curr_scope);
1301 break;
1302 }
1303 STYPEP(sptr, ST_MODPROC);
1304 } else {
1305 /* assume it's a variable to start out with */
1306 STYPEP(sptr, ST_IDENT);
1307 }
1308 SYMLKP(sptr, 0);
1309 }
1310 PRIVATEP(sptr, accessp->type == 'v');
1311 break;
1312 case ST_ALIAS:
1313 PRIVATEP(sptr, accessp->type == 'v');
1314 break;
1315 case ST_IDENT:
1316 case ST_VAR:
1317 case ST_ARRAY:
1318 case ST_STRUCT:
1319 case ST_UNION:
1320 /*
1321 ** PUBLIC/PRIVATE attribute *is* allowed for common block variables! **
1322
1323 if (SCG(sptr) == SC_CMBLK) {
1324 error(155, 2, gbl.lineno,
1325 "PUBLIC/PRIVATE attribute ignored for common block
1326 member",
1327 SYMNAME(sptr));
1328 break;
1329 }
1330 PRIVATEP(sptr, accessp->type == 'v');
1331 break;
1332 */
1333 case ST_NML:
1334 case ST_PROC:
1335 case ST_ENTRY:
1336 case ST_PARAM:
1337 case ST_TYPEDEF:
1338 case ST_OPERATOR:
1339 case ST_CMBLK:
1340 if (STYPEG(sptr) == ST_PROC && GSAMEG(sptr)) {
1341 /* FS#20565 & FS#20566: Need to set public/private on the
1342 * generic name, not the procedure.
1343 */
1344 PRIVATEP(GSAMEG(sptr), accessp->type == 'v');
1345 } else {
1346 PRIVATEP(sptr, accessp->type == 'v');
1347 }
1348 /* make sure the $ac of this sptr also has the same access */
1349
1350 if (PARAMG(sptr)) {
1351 if (DTY(DTYPEG(sptr)) == TY_ARRAY) {
1352 PRIVATEP(CONVAL1G(sptr), accessp->type == 'v');
1353 } else if (DTY(DTYPEG(sptr)) == TY_DERIVED) {
1354 PRIVATEP(CONVAL1G(sptr), accessp->type == 'v');
1355 }
1356 }
1357 break;
1358
1359 case ST_USERGENERIC:
1360 PRIVATEP(sptr, accessp->type == 'v');
1361 if (GTYPEG(sptr))
1362 PRIVATEP(GTYPEG(sptr), PRIVATEG(sptr));
1363 break;
1364
1365 case ST_MODPROC:
1366 PRIVATEP(sptr, accessp->type == 'v');
1367 if (GSAMEG(sptr))
1368 PRIVATEP(GSAMEG(sptr), accessp->type == 'v');
1369 break;
1370
1371 case ST_PD:
1372 case ST_GENERIC:
1373 case ST_INTRIN:
1374 sptr = refsym(sptr, OC_OTHER);
1375 PRIVATEP(sptr, accessp->type == 'v');
1376 break;
1377
1378 default:
1379 error(155, 3, gbl.lineno, "PUBLIC/PRIVATE cannot be applied to",
1380 SYMNAME(sptr));
1381 break;
1382 }
1383 }
1384 if (IN_MODULE && in_module) {
1385 /* save public state */
1386 if (sem.accl.type == 'v') {
1387 /* default is private */
1388 sem.mod_public_flag = 0;
1389 } else {
1390 sem.mod_public_flag = 1;
1391 }
1392 /* look for PUBLIC symbols that are declared with a PRIVATE type */
1393 nsyms = stb.stg_avail - 1;
1394 for (sptr = stb.firstusym; sptr <= nsyms; ++sptr) {
1395 stype = STYPEG(sptr);
1396 switch (stype) {
1397 case ST_VAR:
1398 case ST_ARRAY:
1399 case ST_STRUCT:
1400 case ST_UNION:
1401 case ST_PROC:
1402 case ST_PARAM:
1403 case ST_OPERATOR:
1404 case ST_MODPROC:
1405 break;
1406 case ST_TYPEDEF:
1407 break;
1408 default:
1409 break;
1410 }
1411 }
1412 }
1413 }
1414
1415 /* ******************************************************************/
1416
1417 void
do_equiv(void)1418 do_equiv(void)
1419 {
1420 int evp, first_evp;
1421 int sptr, ps;
1422 ISZ_T addr, size, temp;
1423 ISZ_T loc_addr, s_addr;
1424 LOGICAL first_ok, saveflg, dinitflg;
1425 int loc_list;
1426 int first_save; /* first saved local variable in list */
1427 int last_save; /* last saved local variable in list */
1428 int maxa; /* maximum alignment used for equiv'd variables */
1429 int a; /* alignment of variable */
1430
1431 /* Allocate space for PSECT records */
1432 psect_size = 100;
1433 NEW(psect_base, PSECT, psect_size);
1434 psect_num = 1;
1435
1436 #if DEBUG
1437 if (DBGBIT(3, 8))
1438 fprintf(gbl.dbgfil, "EQUIVALENCE LIST");
1439 #endif
1440
1441 first_save = last_save = 0;
1442
1443 /* loop thru equivalence list, performing error checking and
1444 * equivalence operations:
1445 */
1446 first_evp = 0;
1447 for (evp = sem.eqvlist; evp != 0; evp = EQV(evp).next) {
1448 if (EQV(evp).is_first < 0) {
1449 /* already handled when imported */
1450 first_evp = 0;
1451 } else if (EQV(evp).is_first > 0) { /* first member of group */
1452 first_evp = evp;
1453 first_ok = chk_evar(evp);
1454 } else if (first_evp != 0 && chk_evar(evp) && first_ok) {
1455 equivalence(first_evp, evp);
1456 /*
1457 * if the psect represented by first_evp was eliminated
1458 * (merged into evp), use evp for subsequent equivalences
1459 * in this group instead of first_evp:
1460 */
1461 if (psect_base[EQV(first_evp).ps].cmblk == -1)
1462 first_evp = evp;
1463 }
1464 }
1465 /*
1466 * loop thru psects and
1467 * (1) issue error if any element of a psect is not aligned correctly
1468 * (2) assign addresses to symbols in local psects:
1469 */
1470 if (soc.size == 0) {
1471 soc.size = 1000;
1472 NEW(soc.base, SOC_ITEM, soc.size);
1473 }
1474
1475 s_addr = loc_addr = 0; /* first available local variable address */
1476 loc_list = NOSYM; /* list of equivalenced locals */
1477 dinitflg = FALSE;
1478 for (ps = 1; ps < psect_num; ++ps) {
1479 LOGICAL dinitd;
1480 LOGICAL vold;
1481 LOGICAL nmld;
1482 int cmblk = psect_base[ps].cmblk;
1483
1484 if (cmblk == -1) /* ignore deleted psects */
1485 continue;
1486 for (sptr = psect_base[ps].memlist; sptr != NOSYM; sptr = SYMLKG(sptr)) {
1487 /*
1488 * storage overlap chains are terminated by 0; clean up the SOCPTR
1489 * fields since they were used temporarily to locate the ps index
1490 * of the equivalenced symbols.
1491 */
1492 assert(sptr, "equiv:bsym", 0, 3);
1493 SOCPTRP(sptr, 0);
1494 }
1495 maxa = size = 0;
1496 saveflg = sem.savall | (!(flg.recursive & 1));
1497 nmld = vold = dinitd = FALSE;
1498 for (sptr = psect_base[ps].memlist; sptr != NOSYM; sptr = SYMLKG(sptr)) {
1499 assert(sptr, "equiv:bsym", 1, 3);
1500 saveflg |= SAVEG(sptr);
1501 dinitd |= DINITG(sptr);
1502 saveflg |= dinitd;
1503 vold |= VOLG(sptr);
1504 nmld |= NMLG(sptr);
1505 addr = ADDRESSG(sptr);
1506 temp = size_of((int)DTYPEG(sptr));
1507 if (addr + temp > size)
1508 size = addr + temp;
1509 a = alignment((int)DTYPEG(sptr));
1510 if (a & addr)
1511 error(62, 2, gbl.lineno, SYMNAME(sptr), CNULL);
1512 if (a > maxa)
1513 maxa = a;
1514 add_socs(sptr, addr, temp);
1515 if (cmblk > 0 && SCG(sptr) != SC_CMBLK) {
1516 /* add sptr to common block psect */
1517 SCP(sptr, SC_CMBLK);
1518 SYMLKP(CMEMLG(cmblk), sptr);
1519 CMEMLP(cmblk, sptr);
1520 SYMLKP(sptr, NOSYM);
1521 }
1522 }
1523 if (vold) {
1524 for (sptr = psect_base[ps].memlist; sptr != NOSYM; sptr = SYMLKG(sptr))
1525 if (VOLG(sptr) && SOCPTRG(sptr))
1526 vol_equiv((int)SOCPTRG(sptr));
1527 }
1528 if (nmld) {
1529 for (sptr = psect_base[ps].memlist; sptr != NOSYM; sptr = SYMLKG(sptr))
1530 if (NMLG(sptr) && SOCPTRG(sptr))
1531 nml_equiv((int)SOCPTRG(sptr));
1532 }
1533 if (cmblk != 0) /* common block psect */
1534 /* common block may have increased in size */
1535 SIZEP(cmblk, size);
1536 else if (!in_module) { /* local psect */
1537 addr = ((saveflg | nmld) ? s_addr : loc_addr);
1538 addr = ALIGN(addr, maxa); /* round up addr to max boundary */
1539 if ((sptr = psect_base[ps].memlist) != NOSYM)
1540 for (;; sptr = SYMLKG(sptr)) {
1541 assert(sptr, "equiv:bsym", 2, 3);
1542 ADDRESSP(sptr, ADDRESSG(sptr) + addr);
1543 REFP(sptr, 1);
1544 if (SYMLKG(sptr) == NOSYM) /* NOTE: last sptr needs to */
1545 break; /* saved for next section */
1546 }
1547 if (saveflg | nmld) {
1548 /* link psect list into end of saved variables list */
1549 if (last_save)
1550 SYMLKP(last_save, psect_base[ps].memlist);
1551 else
1552 first_save = psect_base[ps].memlist;
1553 last_save = sptr;
1554 s_addr = addr + size;
1555 dinitflg |= dinitd;
1556 } else {
1557 /* link psect list into front of referenced locals list */
1558 SYMLKP(sptr, loc_list);
1559 loc_list = psect_base[ps].memlist;
1560 loc_addr = addr + size;
1561 }
1562 }
1563 }
1564
1565 /* for the equivalenced locals, assign the target addresses to the
1566 * variables and add to the gbl.locals list.
1567 */
1568 fix_equiv_locals(loc_list, loc_addr);
1569
1570 /* for the equivalence locals which were saved and/or dinitd, assign
1571 * the target addresses to the variables and classify as SC_STATIC.
1572 */
1573
1574 if (first_save)
1575 fix_equiv_statics(first_save, s_addr, dinitflg);
1576
1577 FREE(psect_base);
1578 #if DEBUG
1579 if (DBGBIT(3, 8))
1580 fprintf(gbl.dbgfil, "\nEQUIVALENCE LIST END\n");
1581 #endif
1582 }
1583
1584 /*
1585 * Check that a variable or array reference in an equivalence
1586 * list is a valid reference. Return TRUE if okay, FALSE otherwise.
1587 */
1588 static LOGICAL
chk_evar(int evp)1589 chk_evar(int evp)
1590 {
1591 int sptr, ps, dim, cmblk;
1592 int ss, j, numss, dty, ssast, savelineno;
1593 ADSC *ad;
1594 ISZ_T offset;
1595 #define EVARERR(n, m) \
1596 { \
1597 error(n, 3, gbl.lineno, SYMNAME(sptr), m); \
1598 return FALSE; \
1599 }
1600
1601 /* Get symbol & check if an error occured earlier */
1602 sptr = EQV(evp).sptr;
1603 if (sptr == 0)
1604 return (FALSE);
1605 if (gbl.internal > 1 && !INTERNALG(sptr))
1606 return FALSE;
1607 ss = EQV(evp).subscripts;
1608 savelineno = gbl.lineno;
1609 gbl.lineno = EQV(evp).lineno;
1610
1611 #if DEBUG
1612 if (DBGBIT(3, 8)) {
1613 if (EQV(evp).is_first)
1614 fprintf(gbl.dbgfil, "\nline(%5d) ", EQV(evp).lineno);
1615 else
1616 fprintf(gbl.dbgfil, "\n ");
1617 fprintf(gbl.dbgfil, "%s", SYMNAME(sptr));
1618 if (ss > 0) {
1619 numss = EQV_NUMSS(ss);
1620 for (j = 0; j < numss; ++j) {
1621 if (j)
1622 fprintf(gbl.dbgfil, ",");
1623 else
1624 fprintf(gbl.dbgfil, "(");
1625 ssast = EQV_SS(ss, j);
1626 if (A_TYPEG(ssast) == A_ID || A_TYPEG(ssast) == A_CNST) {
1627 fprintf(gbl.dbgfil, "sym %d (%d)", A_SPTRG(ssast),
1628 CONVAL2G(A_SPTRG(ssast)));
1629 } else {
1630 fprintf(gbl.dbgfil, "unknownast[%d]", ssast);
1631 }
1632 }
1633 fprintf(gbl.dbgfil, ")");
1634 }
1635 fprintf(gbl.dbgfil, " (%" ISZ_PF "d)", EQV(evp).byte_offset);
1636 fprintf(gbl.dbgfil, ",");
1637 fprintf(gbl.dbgfil, "\n");
1638 }
1639 #endif
1640
1641 /* check for variables which are illegal in equivalences */
1642
1643 if (SCG(sptr) == SC_DUMMY)
1644 EVARERR(57, CNULL);
1645 if (SCG(sptr) == SC_BASED)
1646 EVARERR(116, "(EQUIVALENCE)");
1647 dty = DTYPEG(sptr);
1648 if (DTY(dty) == TY_STRUCT || DTY(dty) == TY_UNION)
1649 EVARERR(60, CNULL);
1650 if (DTY(dty) == TY_DERIVED) {
1651 int tag;
1652 /* see if the derived type has the SEQUENCE attribute */
1653 tag = DTY(dty + 3);
1654 if (tag == 0 || !SEQG(tag)) {
1655 EVARERR(444, CNULL);
1656 }
1657 }
1658
1659 offset = 0;
1660 if (STYPEG(sptr) == ST_IDENT || STYPEG(sptr) == ST_UNKNOWN)
1661 STYPEP(sptr, ST_VAR);
1662 if (STYPEG(sptr) == ST_VAR) {
1663 if (DTY(DTYPEG(sptr)) == TY_CHAR || DTY(DTYPEG(sptr)) == TY_NCHAR) {
1664 /* Check if char variable was referenced as an array */
1665 if (ss > 0) {
1666 if (EQV(evp).byte_offset)
1667 EVARERR(76, CNULL);
1668 if (EQV_NUMSS(ss) != 1)
1669 EVARERR(76, CNULL);
1670 ssast = EQV_SS(ss, 0);
1671 if (A_TYPEG(ssast) == A_ID || A_TYPEG(ssast) == A_CNST) {
1672 EQV(evp).byte_offset = CONVAL2G(A_SPTRG(ssast));
1673 if (flg.standard)
1674 error(76, 2, gbl.lineno, SYMNAME(sptr), CNULL);
1675 } else {
1676 EQV(evp).byte_offset = 0;
1677 /* error already issued */
1678 /*error(155, 3, gbl.lineno, SYMNAME(sptr), "- nonconstant equivalence
1679 * subscript" );*/
1680 }
1681 }
1682 } else {
1683 if (ss > 0 || EQV(evp).byte_offset)
1684 EVARERR(76, CNULL);
1685 }
1686 } else if (STYPEG(sptr) == ST_ARRAY) {
1687 if (ALLOCG(sptr)) {
1688 error(84, 3, gbl.lineno, SYMNAME(sptr),
1689 "- an allocatable array cannot be equivalenced");
1690 gbl.lineno = savelineno;
1691 return FALSE;
1692 }
1693 if (ADJARRG(sptr)) {
1694 error(84, 3, gbl.lineno, SYMNAME(sptr),
1695 "- an adjustable array cannot be equivalenced");
1696 gbl.lineno = savelineno;
1697 return FALSE;
1698 }
1699 if (ss > 0) {
1700 int err = 0;
1701 ad = AD_PTR(sptr);
1702 numss = EQV_NUMSS(ss);
1703 for (dim = 0; dim < numss; ++dim) {
1704 if (dim >= AD_NUMDIM(ad))
1705 EVARERR(78, CNULL);
1706 ssast = EQV_SS(ss, dim);
1707 if (A_TYPEG(ssast) == A_ID || A_TYPEG(ssast) == A_CNST) {
1708 offset += (CONVAL2G(A_SPTRG(ssast)) -
1709 get_int_cval(sym_of_ast(AD_LWAST(ad, dim)))) *
1710 get_int_cval(sym_of_ast(AD_MLPYR(ad, dim)));
1711 } else {
1712 /* error already issued */
1713 /*error(155, 3, gbl.lineno, SYMNAME(sptr),
1714 "- nonconstant equivalence subscript" );*/
1715 err = 1;
1716 }
1717 }
1718 if (dim != AD_NUMDIM(ad)) {
1719 if (dim == 1) {
1720 if (flg.standard)
1721 error(78, 2, gbl.lineno, SYMNAME(sptr), CNULL);
1722 } else
1723 EVARERR(78, CNULL);
1724 } else if (flg.standard && err == 0) {
1725 for (dim = 0; dim < numss; ++dim) {
1726 int val;
1727 val = CONVAL2G(A_SPTRG(EQV_SS(ss, dim)));
1728 if (val < get_int_cval(sym_of_ast(AD_LWAST(ad, dim))) ||
1729 val > get_int_cval(sym_of_ast(AD_UPAST(ad, dim))))
1730 error(80, 2, gbl.lineno, SYMNAME(sptr), CNULL);
1731 }
1732 }
1733 offset *= size_of((int)DDTG(DTYPEG(sptr)));
1734 }
1735 } else
1736 EVARERR(84, CNULL);
1737
1738 if (EQV(evp).byte_offset) {
1739 if (DTYG(DTYPEG(sptr)) == TY_CHAR)
1740 EQV(evp).byte_offset--;
1741 else if (DTYG(DTYPEG(sptr)) == TY_NCHAR)
1742 EQV(evp).byte_offset = 2 * (EQV(evp).byte_offset - 1);
1743 else
1744 EVARERR(75, CNULL);
1745 }
1746 /*
1747 * assign to EQV(evp).byte_offset, the total byte offset from the
1748 * beginning of the psect:
1749 */
1750 EQV(evp).byte_offset += (offset + ADDRESSG(sptr));
1751
1752 /* allocate a new psect if necessary */
1753 if (SC_ISCMBLK(SCG(sptr))) {
1754 cmblk = CMBLKG(sptr); /* sym pointer to common block name */
1755 ps = CMBLKG(cmblk);
1756 } else {
1757 /* local variable */
1758 cmblk = 0;
1759 ps = SOCPTRG(sptr);
1760 }
1761 if (ps == 0) { /* allocate new psect */
1762 ps = psect_num++;
1763 NEED(psect_num, psect_base, PSECT, psect_size, psect_size + 100);
1764 psect_base[ps].cmblk = cmblk;
1765 if (cmblk) {
1766 CMBLKP(cmblk, ps);
1767 psect_base[ps].memlist = CMEMFG(cmblk);
1768 } else {
1769 assert(SYMLKG(sptr) == 0 || SYMLKG(sptr) == NOSYM, "chk_evar:b slnk",
1770 sptr, 2);
1771 SOCPTRP(sptr, ps);
1772 psect_base[ps].memlist = sptr;
1773 }
1774 }
1775 EQV(evp).ps = ps; /* save psect number */
1776 gbl.lineno = savelineno;
1777 return TRUE;
1778 }
1779
1780 static void
equivalence(int evp,int evp2)1781 equivalence(int evp, int evp2)
1782 {
1783 int ps, ps2;
1784 ISZ_T offset, offset2;
1785 int sptr, sptr2;
1786 int pstemp;
1787
1788 ps = EQV(evp).ps;
1789 ps2 = EQV(evp2).ps;
1790 offset = EQV(evp).byte_offset;
1791 offset2 = EQV(evp2).byte_offset;
1792 sptr = EQV(evp).sptr;
1793 sptr2 = EQV(evp2).sptr;
1794
1795 if (DBGBIT(3, 8))
1796 fprintf(gbl.dbgfil, ">>>>> equivalence of %s/psect(%d):%" ISZ_PF
1797 "d and %s/psect(%d):%" ISZ_PF "d\n",
1798 SYMNAME(sptr), ps, offset, SYMNAME(sptr2), ps2, offset2);
1799
1800 if (in_module) {
1801 if ((DTYG(DTYPEG(sptr)) == TY_CHAR && DTYG(DTYPEG(sptr2)) != TY_CHAR) ||
1802 (DTYG(DTYPEG(sptr2)) == TY_CHAR && DTYG(DTYPEG(sptr)) != TY_CHAR) ||
1803 (DTYG(DTYPEG(sptr)) == TY_NCHAR || DTYG(DTYPEG(sptr2)) == TY_NCHAR))
1804 error(310, 3, gbl.lineno,
1805 "Cannot EQUIVALENCE non-character and character",
1806 "in the specification part of a MODULE");
1807 } else if (flg.standard) {
1808 if (DTYG(DTYPEG(sptr)) == TY_CHAR && DTYG(DTYPEG(sptr2)) != TY_CHAR)
1809 error(183, 2, gbl.lineno, SYMNAME(sptr2), SYMNAME(sptr));
1810 else if (DTYG(DTYPEG(sptr2)) == TY_CHAR && DTYG(DTYPEG(sptr)) != TY_CHAR)
1811 error(183, 2, gbl.lineno, SYMNAME(sptr), SYMNAME(sptr2));
1812 else if (DTYG(DTYPEG(sptr)) == TY_NCHAR || DTYG(DTYPEG(sptr2)) == TY_NCHAR)
1813 error(183, 2, gbl.lineno, SYMNAME(sptr), SYMNAME(sptr2));
1814 } else {
1815 if (DTYG(DTYPEG(sptr)) == TY_NCHAR && DTYG(DTYPEG(sptr2)) != TY_NCHAR)
1816 error(185, 2, gbl.lineno, SYMNAME(sptr2), SYMNAME(sptr));
1817 else if (DTYG(DTYPEG(sptr2)) == TY_NCHAR && DTYG(DTYPEG(sptr)) != TY_NCHAR)
1818 error(185, 2, gbl.lineno, SYMNAME(sptr), SYMNAME(sptr2));
1819 }
1820
1821 if (ps == ps2) {
1822 /* redundant equivalence - must not be inconsistent */
1823 if (offset != offset2)
1824 error(59, 3, gbl.lineno, SYMNAME(sptr), SYMNAME(sptr2));
1825 } else {
1826 /* decide whether to merge ps into ps2, or vice versa */
1827 offset = offset2 - offset;
1828 if (offset < 0 || (offset == 0 && psect_base[ps].cmblk)) {
1829 /* ps2 will be merged ... switch ps and ps2 */
1830 offset = -offset;
1831 pstemp = ps;
1832 ps = ps2;
1833 ps2 = pstemp;
1834 }
1835 /*
1836 * not allowed to equivalence two common blocks, and -
1837 * not allowed to extend common block backwards:
1838 */
1839 if (psect_base[ps].cmblk) {
1840 if (psect_base[ps2].cmblk)
1841 error(58, 3, gbl.lineno, SYMNAME(sptr), SYMNAME(sptr2));
1842 else
1843 error(61, 3, gbl.lineno, SYMNAME(sptr), SYMNAME(sptr2));
1844 return;
1845 }
1846 /*
1847 * eliminate ps - update the addresses of its members, and
1848 * insert its member list after the first member of ps2:
1849 */
1850 for (sptr = psect_base[ps].memlist;; sptr = SYMLKG(sptr)) {
1851 assert(sptr, "equiv:bsym", 3, 3);
1852 ADDRESSP(sptr, ADDRESSG(sptr) + offset);
1853 SOCPTRP(sptr, ps2); /* assign new psect number */
1854 if (psect_base[ps2].cmblk) { /* update true psect */
1855 SCP(sptr, SC_CMBLK);
1856 CMBLKP(sptr, psect_base[ps2].cmblk);
1857 if (DINITG(sptr))
1858 DINITP(psect_base[ps2].cmblk, 1);
1859 }
1860 /* hack - mark symbol as being added to a common block or other
1861 * memory area due to an equivalence
1862 */
1863 EQVP(sptr, 1);
1864 if (SYMLKG(sptr) == NOSYM) /* NOTE: last sptr is needed */
1865 break; /* for the ensuing code */
1866 }
1867 sptr2 = psect_base[ps2].memlist; /* first member of ps2 */
1868 SYMLKP(sptr, SYMLKG(sptr2));
1869 SYMLKP(sptr2, psect_base[ps].memlist);
1870 psect_base[ps].cmblk = -1;
1871 }
1872
1873 }
1874
1875 /*
1876 * add elements to SOC lists for those elements following sptr in psect
1877 * list which overlap sptr
1878 * sptr: equivalenced symbol
1879 * addr: address (relative) of sptr
1880 * size: size in bytes of sptr
1881 */
1882 static void
add_socs(int sptr,ISZ_T addr,ISZ_T size)1883 add_socs(int sptr, ISZ_T addr, ISZ_T size)
1884 {
1885 int sptr2;
1886 ISZ_T addr2;
1887
1888 for (sptr2 = SYMLKG(sptr); sptr2 != NOSYM; sptr2 = SYMLKG(sptr2)) {
1889 assert(sptr2, "equiv:bsym", 4, 3);
1890 addr2 = ADDRESSG(sptr2);
1891 if (addr <= addr2) {
1892 if (addr + size <= addr2)
1893 continue;
1894 } else if (addr >= addr2 + size_of((int)DTYPEG(sptr2)))
1895 continue;
1896
1897 /* add item to Storage Overlap Chain for both sptr and sptr2 */
1898
1899 NEED(soc.avail + 2, soc.base, SOC_ITEM, soc.size, soc.size + 1000);
1900 SOC_SPTR(soc.avail) = sptr2;
1901 SOC_NEXT(soc.avail) = SOCPTRG(sptr);
1902 SOCPTRP(sptr, soc.avail);
1903 SEQP(sptr, 1);
1904 soc.avail++;
1905 SOC_SPTR(soc.avail) = sptr;
1906 SOC_NEXT(soc.avail) = SOCPTRG(sptr2);
1907 SOCPTRP(sptr2, soc.avail);
1908 SEQP(sptr2, 1);
1909 soc.avail++;
1910 if (DBGBIT(3, 8))
1911 fprintf(gbl.dbgfil, " %s overlaps %s\n", SYMNAME(sptr), SYMNAME(sptr2));
1912 }
1913
1914 }
1915
1916 /**
1917 \brief set VOL of all symbols which are equivalenced (closure of socs)
1918 */
1919 static void
vol_equiv(int socp)1920 vol_equiv(int socp)
1921 {
1922 int sptr;
1923 int p;
1924
1925 sptr = SOC_SPTR(socp);
1926 if (VOLG(sptr))
1927 return;
1928 VOLP(sptr, 1);
1929 p = socp;
1930 while ((p = SOC_NEXT(p))) {
1931 vol_equiv(p);
1932 if (socp == p)
1933 break;
1934 socp = p;
1935 }
1936 }
1937
1938 /**
1939 \brief set NML of all symbols which are equivalenced (closure of socs)
1940 */
1941 static void
nml_equiv(int socp)1942 nml_equiv(int socp)
1943 {
1944 int sptr;
1945 int p;
1946
1947 sptr = SOC_SPTR(socp);
1948 if (NMLG(sptr))
1949 return;
1950 NMLP(sptr, 1);
1951 p = socp;
1952 while ((p = SOC_NEXT(p))) {
1953 nml_equiv(p);
1954 if (socp == p)
1955 break;
1956 socp = p;
1957 }
1958 }
1959
1960 /* ******************************************************************/
1961
1962 static int nml; /* current namelist group */
1963 static LOGICAL nml_err; /* any errors in the namelist groups */
1964 static int nml_size; /* size of the namelist group array */
1965 static LOGICAL new_nml; /* for adjustable array */
1966
1967 static void _put(INT);
1968 #define PUT(n) (_put((INT)(n)))
1969 #define PUTA(n) (dinit_put(DINIT_LABEL, (INT)(n)))
1970
1971 static void nml_traverse(int, void (*p)(int));
1972 static void nml_check_item(int);
1973 static void nml_emit_desc(int);
1974
1975 static void
do_nml(void)1976 do_nml(void)
1977 {
1978 int sptr, item, cnt, nmlinmodule;
1979 int plist;
1980 LOGICAL ref_nml;
1981
1982 ref_nml = FALSE;
1983 new_nml = FALSE;
1984 for (nml = sem.nml; nml != NOSYM; nml = SYMLKG(nml)) {
1985 /* set 'nmlinmodule' if this namelist was from a module */
1986 nmlinmodule = ENCLFUNCG(nml);
1987 if (!nmlinmodule || STYPEG(nmlinmodule) != ST_MODULE) {
1988 nmlinmodule = 0;
1989 }
1990 /* always generate error messages, compute size */
1991 nml_err = FALSE;
1992 nml_size = 3; /* namelen, name, count */
1993 cnt = 0; /* number of items in group */
1994 plist = ADDRESSG(nml);
1995 for (item = CMEMFG(nml); item; item = NML_NEXT(item)) {
1996 sptr = NML_SPTR(item);
1997 gbl.lineno = NML_LINENO(item);
1998 nml_traverse(sptr, nml_check_item);
1999 if (nml_err)
2000 continue;
2001
2002 /* VALID namelist symbol */
2003
2004 if (!in_module && SCG(sptr) == SC_NONE) {
2005 /*
2006 * When the namelist declaration appears a MODULE, we know that
2007 * the items are 'global' and the items' storage class will be
2008 * defined by module.c:fix_module_common(). Clearly, making the
2009 * items SC_LOCAL is incorrect.
2010 */
2011 SCP(sptr, SC_LOCAL);
2012 }
2013 ASSNP(sptr, 1);
2014 cnt++;
2015 }
2016 PLLENP(plist, nml_size);
2017 if ((REFG(nml) == 0 && !in_module && gbl.internal != 1) || nml_err ||
2018 nmlinmodule)
2019 continue;
2020 /*
2021 * Create data initialized character variables for the names of
2022 * the namelist group and its members if character constants aren't
2023 * allowed as arguments to RTE_loc().
2024 */
2025 if (XBIT(49, 0x100000)) {
2026 dinit_name(nml);
2027 for (item = CMEMFG(nml); item; item = NML_NEXT(item)) {
2028 sptr = NML_SPTR(item);
2029 dinit_name(sptr);
2030 }
2031 }
2032 /*
2033 * data initialize the descriptor of the namelist group which is
2034 * addressed by the group's associated plist - this descriptor
2035 * is defined by the PGI Fortran I/O spec.
2036 */
2037 dinit_put(DINIT_NML, (INT)plist);
2038 put_name(nml); /* name of namelist group */
2039 PUT(cnt);
2040 /*
2041 * scan through all of the items in the group and create a descriptor
2042 * for each item.
2043 */
2044 new_nml = TRUE; /* set for adjustable array */
2045 for (item = CMEMFG(nml); item; item = NML_NEXT(item)) {
2046 sptr = NML_SPTR(item);
2047 nml_traverse(sptr, nml_emit_desc);
2048 new_nml = FALSE;
2049 }
2050 new_nml = FALSE;
2051 DINITP(plist, 1);
2052 #ifdef USE_MPC
2053 /* Need to be done before sym_is_refd on the plist */
2054 etls_privatize(nml);
2055 #endif
2056 sym_is_refd(plist);
2057 dinit_put(DINIT_END, 0);
2058 ref_nml = TRUE;
2059 }
2060 if (ref_nml)
2061 (void)sym_mkfunc_nodesc(mkRteRtnNm(RTE_loc), DT_ADDR);
2062
2063 }
2064
2065 static void
nml_sym_is_refd(int sptr)2066 nml_sym_is_refd(int sptr)
2067 {
2068 if (sptr > 0) {
2069 if (STYPEG(sptr) == ST_MEMBER || ALLOCG(sptr) || POINTERG(sptr))
2070 return;
2071 if (STYPEG(sptr) == ST_ARRAY && ADJARRG(sptr))
2072 return;
2073 sym_is_refd(sptr);
2074 }
2075 }
2076
2077 static void
do_nml_sym_is_refd(void)2078 do_nml_sym_is_refd(void)
2079 {
2080 int sptr, item, nml;
2081
2082 for (nml = sem.nml; nml != NOSYM; nml = SYMLKG(nml)) {
2083 for (item = CMEMFG(nml); item; item = NML_NEXT(item)) {
2084 sptr = NML_SPTR(item);
2085 nml_traverse(sptr, nml_sym_is_refd);
2086 }
2087 }
2088 }
2089
2090 static void
_put(INT n)2091 _put(INT n)
2092 {
2093 if (size_of(DT_PTR) == 8) {
2094 n = cngcon(n, DT_INT4, DT_INT8);
2095 dinit_put(DT_INT8, n);
2096 } else
2097 dinit_put(DT_INT4, n);
2098 }
2099
2100 #if defined(PARENTG)
2101
2102 static void
nml_traverse_parenttype(int dtype,void (* visitf)(int))2103 nml_traverse_parenttype(int dtype, void (*visitf)(int))
2104 {
2105 int possible_ext = 1;
2106 int parent, m;
2107 for (m = DTY(dtype + 1); m != NOSYM; m = SYMLKG(m)) {
2108 parent = PARENTG(m);
2109 /* check extended type , traverse member instead */
2110 if (possible_ext && parent && parent == m && DTY(DTYPEG(m) == TY_DERIVED)) {
2111 nml_traverse_parenttype(DTYPEG(m), visitf);
2112
2113 } else {
2114 nml_traverse(m, visitf);
2115 }
2116 possible_ext = 0;
2117 }
2118 }
2119 #endif
2120
2121 /* nml traversal in linear order */
2122 static void
nml_traverse(int sptr,void (* visitf)(int))2123 nml_traverse(int sptr, void (*visitf)(int))
2124 {
2125 int dtype, ty, possible_ext, parent, i;
2126 possible_ext = 1;
2127
2128 (*visitf)(sptr);
2129 if (STYPEG(sptr) == ST_MEMBER && (POINTERG(sptr) || ALLOCG(sptr)))
2130 /* don't traverse the member with the POINTER or ALLOCATABLE
2131 * attribute for fear of self-referential structures -- these
2132 * are illegal, an error will be reported, but nml_traverse()
2133 * would infinitely recurse without this check.
2134 */
2135 return;
2136 dtype = DDTG(DTYPEG(sptr)); /* get element dtype if array */
2137 ty = DTY(dtype);
2138 i = dtype_has_defined_io(dtype) & (DT_IO_FWRITE | DT_IO_FREAD);
2139 if (ty == TY_DERIVED && !i) {
2140 int m;
2141 for (m = DTY(dtype + 1); m != NOSYM; m = SYMLKG(m)) {
2142 #ifdef PARENTG
2143 parent = PARENTG(m);
2144 /* check extended type , traverse member instead */
2145 if (possible_ext && parent && parent == m &&
2146 DTY(DTYPEG(m)) == TY_DERIVED) {
2147 nml_traverse_parenttype(DTYPEG(m), visitf);
2148
2149 } else {
2150 #endif
2151 nml_traverse(m, visitf);
2152 #if defined(PARENTG)
2153 }
2154 #endif
2155 possible_ext = 0;
2156 }
2157 (*visitf)(0); /* and to mark the end of the members */
2158 }
2159 }
2160
2161 /* check for a valid namelist item and compute its descriptor size */
2162 static void
nml_check_item(int sptr)2163 nml_check_item(int sptr)
2164 {
2165 int dtype, ty, ndims, dtio, i;
2166
2167 if (sptr <= 0) {
2168 /* end of derived type members */
2169 nml_size++;
2170 return;
2171 }
2172
2173 nml_size += 5; /* namelen, name, address, datatype, charlen */
2174 dtype = DTYPEG(sptr);
2175 if ((POINTERG(sptr) || ALLOCG(sptr)) && STYPEG(sptr) != ST_MEMBER) {
2176 ndims = 1;
2177 } else if (DTY(dtype) == TY_ARRAY) {
2178 ndims = ADD_NUMDIM(dtype);
2179 dtype = DTY(dtype + 1);
2180 } else
2181 ndims = 0;
2182
2183 /* defined io: 0, readptr, writeptr, dtv, v_list,
2184 * dtv$sd, v_list$sd, iotype$cl
2185 * dtv is already counted
2186 */
2187 dtio = 0;
2188 i = dtype_has_defined_io(dtype) & (DT_IO_FWRITE | DT_IO_FREAD);
2189 if (i) {
2190 dtio = 7;
2191 }
2192 nml_size += 1 + dtio + 2 * ndims; /* ndims, [lower, upper]... */
2193
2194 ty = DTY(dtype);
2195 if (ty >= TY_STRUCT && ty != TY_DERIVED) {
2196 error(108, 3, gbl.lineno, SYMNAME(sptr), SYMNAME(nml));
2197 nml_err = TRUE;
2198 return;
2199 }
2200
2201 switch (STYPEG(sptr)) {
2202 case ST_UNKNOWN:
2203 case ST_IDENT:
2204 STYPEP(sptr, ST_VAR); /* fall thru */
2205 case ST_VAR:
2206 if (SCG(sptr) == SC_DUMMY) {
2207 if (DTY(DDTG(dtype)) != TY_CHAR)
2208 break;
2209 if (!ASSUMLENG(sptr))
2210 break;
2211 } else if (SCG(sptr) != SC_BASED)
2212 break;
2213 if (DTY(DDTG(dtype)) != TY_CHAR)
2214 break;
2215 if ((DDTG(dtype)) == DT_DEFERCHAR || (DDTG(dtype)) == DT_DEFERNCHAR)
2216 break;
2217 if (!ASSUMLENG(sptr))
2218 break;
2219 /** assumed-size char not allowed **/
2220 error(108, 3, gbl.lineno, SYMNAME(sptr), SYMNAME(nml));
2221 nml_err = TRUE;
2222 break;
2223 case ST_ARRAY:
2224 /** assumed-size arrays not allowed **/
2225 if (SCG(sptr) == SC_NONE && ASUMSZG(sptr)) {
2226 error(108, 3, gbl.lineno, SYMNAME(sptr), SYMNAME(nml));
2227 nml_err = TRUE;
2228 }
2229 break;
2230 case ST_MEMBER:
2231 break;
2232 default:
2233 error(108, 3, gbl.lineno, SYMNAME(sptr), SYMNAME(nml));
2234 nml_err = TRUE;
2235 break;
2236 }
2237
2238 }
2239
2240 static int
gen_vlist(void)2241 gen_vlist(void)
2242 {
2243 ITEM *p;
2244 int sptr, vlist_ast;
2245 ADSC *ad;
2246
2247 /* make array of size 0 */
2248 /* set it as array size 0 first */
2249
2250 int dtype;
2251 if (XBIT(124, 0x10))
2252 dtype = get_array_dtype(1, DT_INT8);
2253 else
2254 dtype = get_array_dtype(1, DT_INT);
2255 ad = AD_DPTR(dtype);
2256 AD_LWAST(ad, 0) = astb.i1;
2257 AD_LWBD(ad, 0) = astb.i1;
2258 AD_UPAST(ad, 0) = astb.i0;
2259 AD_UPBD(ad, 0) = astb.i0;
2260 AD_MLPYR(ad, 0) = astb.i1;
2261
2262 sptr = getcctmp_sc('d', sem.dtemps++, ST_VAR, dtype, SC_LOCAL);
2263 ALLOCP(sptr, 1);
2264 get_static_descriptor(sptr);
2265 get_all_descriptors(sptr);
2266 vlist_ast = mk_id(sptr);
2267 DESCUSEDP(sptr, 1);
2268 ARGP(sptr, 1);
2269
2270 return vlist_ast;
2271 }
2272
2273 static ITEM *
gen_dtio_arglist(int sptr,int vlist_ast)2274 gen_dtio_arglist(int sptr, int vlist_ast)
2275 {
2276 ITEM *p, *arglist;
2277 INT v[2];
2278 int ast_type, iostat_ast, iomsg_ast, unit_ast;
2279 int tast, iotype_ast;
2280 int tsptr, tdtype;
2281 int argdtyp;
2282 if (XBIT(124, 0x10))
2283 argdtyp = DT_INT8;
2284 else
2285 argdtyp = DT_INT;
2286
2287 /* dtv , must be scalar*/
2288 tsptr = sptr;
2289 p = (ITEM *)getitem(0, sizeof(ITEM));
2290 p->t.stkp = (SST *)getitem(0, sizeof(SST));
2291 p->next = ITEM_END;
2292 p->next = NULL;
2293 if (DTY(DTYPEG(sptr)) == TY_ARRAY) {
2294 tdtype = DDTG(DTYPEG(sptr));
2295 tsptr = getcctmp_sc('d', sem.dtemps++, ST_VAR, tdtype, SC_LOCAL);
2296 }
2297 p->ast = mk_id(tsptr);
2298 arglist = p;
2299 SST_ASTP(p->t.stkp, p->ast);
2300 SST_DTYPEP(p->t.stkp, DTYPEG(tsptr));
2301 SST_SYMP(p->t.stkp, tsptr);
2302 SST_PARENP(p->t.stkp, 0);
2303 /* need to check if this is S_IDENT or S_SCONST */
2304 SST_IDP(p->t.stkp, S_IDENT);
2305 SST_SHAPEP(p->t.stkp, A_SHAPEG(p->ast));
2306
2307 /* make fake unit */
2308 if (A_DTYPEG(astb.i0) != argdtyp)
2309 unit_ast = mk_convert(astb.i0, argdtyp);
2310 else
2311 unit_ast = astb.i0;
2312 p->next = (ITEM *)getitem(0, sizeof(ITEM));
2313 p = p->next;
2314 p->t.stkp = (SST *)getitem(0, sizeof(SST));
2315 SST_ASTP(p->t.stkp, unit_ast);
2316 SST_DTYPEP(p->t.stkp, A_DTYPEG(unit_ast));
2317 ast_type = A_TYPEG(unit_ast);
2318 SST_SHAPEP(p->t.stkp, 0);
2319 SST_IDP(p->t.stkp, S_CONST);
2320 SST_SYMP(p->t.stkp, A_SPTRG(unit_ast));
2321 SST_LSYMP(p->t.stkp, 0);
2322 SST_CVALP(p->t.stkp, CONVAL2G(A_SPTRG(unit_ast)));
2323 p->ast = unit_ast;
2324
2325 /* fake iotype */
2326 iotype_ast = mk_cnst(getstring("NAMELIST", strlen("NAMELIST")));
2327 p->next = (ITEM *)getitem(0, sizeof(ITEM));
2328 p = p->next;
2329 p->t.stkp = (SST *)getitem(0, sizeof(SST));
2330 p->ast = iotype_ast;
2331 SST_ASTP(p->t.stkp, iotype_ast);
2332 SST_DTYPEP(p->t.stkp, A_DTYPEG(iotype_ast));
2333 SST_SYMP(p->t.stkp, A_SPTRG(iotype_ast));
2334 SST_PARENP(p->t.stkp, 0);
2335 SST_SHAPEP(p->t.stkp, 0);
2336 SST_IDP(p->t.stkp, S_CONST);
2337
2338 /* v_list */
2339 p->next = (ITEM *)getitem(0, sizeof(ITEM));
2340 p = p->next;
2341 p->t.stkp = (SST *)getitem(0, sizeof(SST));
2342 p->next = NULL;
2343 p->ast = vlist_ast;
2344 SST_ASTP(p->t.stkp, vlist_ast);
2345 SST_DTYPEP(p->t.stkp, A_DTYPEG(vlist_ast));
2346 SST_SYMP(p->t.stkp, A_SPTRG(vlist_ast));
2347 SST_PARENP(p->t.stkp, 0);
2348 SST_SHAPEP(p->t.stkp, 0);
2349 SST_IDP(p->t.stkp, S_IDENT);
2350
2351 /* fake iostat */
2352 if (A_DTYPEG(astb.i0) != argdtyp)
2353 iostat_ast = mk_convert(astb.i0, argdtyp);
2354 else
2355 iostat_ast = astb.i0;
2356 p->next = (ITEM *)getitem(0, sizeof(ITEM));
2357 p = p->next;
2358 p->t.stkp = (SST *)getitem(0, sizeof(SST));
2359 p->ast = iostat_ast;
2360 SST_ASTP(p->t.stkp, iostat_ast);
2361 SST_DTYPEP(p->t.stkp, A_DTYPEG(iostat_ast));
2362 SST_SYMP(p->t.stkp, A_SPTRG(iostat_ast));
2363 SST_IDP(p->t.stkp, S_CONST);
2364 SST_PARENP(p->t.stkp, 0);
2365 SST_SHAPEP(p->t.stkp, 0);
2366
2367 /* fake iomsg */
2368 sptr = getcctmp_sc('d', sem.dtemps++, ST_VAR, DT_CHAR, SC_LOCAL);
2369 iomsg_ast = mk_id(sptr);
2370 p->next = (ITEM *)getitem(0, sizeof(ITEM));
2371 p = p->next;
2372 p->t.stkp = (SST *)getitem(0, sizeof(SST));
2373 p->next = ITEM_END;
2374 p->ast = iomsg_ast;
2375 SST_ASTP(p->t.stkp, iomsg_ast);
2376 SST_DTYPEP(p->t.stkp, A_DTYPEG(iomsg_ast));
2377 SST_SYMP(p->t.stkp, A_SPTRG(iomsg_ast));
2378 SST_IDP(p->t.stkp, S_IDENT);
2379 SST_PARENP(p->t.stkp, 0);
2380 SST_SHAPEP(p->t.stkp, 0);
2381
2382 return arglist;
2383 }
2384
2385 static int static_cnt = 0;
2386 /* emit a descriptor for a namelist item. For derived types, the descriptors
2387 * for members immediately follow the derived type's descriptor. The
2388 * last member is followed by a single word whose value is 0.
2389 */
2390 static void
nml_emit_desc(int sptr)2391 nml_emit_desc(int sptr)
2392 {
2393 int cnt, dtype, ndims, a, dttype, i;
2394 ADSC *ad;
2395
2396 if (new_nml == TRUE) {
2397 static_cnt = 3; /* nml header (name, size, len)*/
2398 new_nml = FALSE;
2399 }
2400
2401 if (sptr <= 0) {
2402 /* end of derived type members */
2403 PUT(0);
2404 ++static_cnt;
2405 return;
2406 }
2407
2408 if (SCG(sptr) == SC_LOCAL) {
2409 if (DINITG(sptr) || SAVEG(sptr))
2410 SCP(sptr, SC_STATIC); /* ensure item's addr is static */
2411 }
2412
2413 put_name(sptr); /* name of item in group */
2414 static_cnt = static_cnt + 2;
2415
2416 if (ALLOCG(sptr) || POINTERG(sptr)) {
2417 if (SDSCG(sptr) == 0) {
2418 if (ALLOCATTRG(sptr)) {
2419 get_static_descriptor(sptr);
2420 DESCUSEDP(sptr, 1);
2421 if (DTY(DTYPEG(sptr)) == TY_ARRAY) {
2422 if (SCOPEG(sptr) && STYPEG(SCOPEG(sptr)) == ST_MODULE) {
2423 get_all_descriptors(sptr);
2424 } else {
2425 trans_mkdescr(sptr);
2426 NODESCP(sptr, 0);
2427 SECDSCP(DESCRG(sptr), SDSCG(sptr));
2428 }
2429 }
2430 } else {
2431 DESCUSEDP(sptr, 1);
2432 get_static_descriptor(sptr);
2433 get_all_descriptors(sptr);
2434 }
2435 ALLOCDESCP(sptr, 1);
2436 SCP(sptr, SC_BASED);
2437 }
2438 if (!MIDNUMG(sptr)) {
2439 PUTA(sptr); /* item's address */
2440 ADDRTKNP(sptr, 1); /* item appears as an argument */
2441 } else {
2442 ADDRTKNP(MIDNUMG(sptr), 1); /* item appears as an argument */
2443 PUTA(MIDNUMG(sptr)); /* item's address */
2444 }
2445 ++static_cnt;
2446 } else if (STYPEG(sptr) != ST_MEMBER) {
2447 ADDRTKNP(sptr, 1); /* item appears as an argument */
2448 PUTA(sptr); /* item's address */
2449 ++static_cnt;
2450 } else {
2451 PUT(ADDRESSG(sptr)); /* member's offset */
2452 ++static_cnt;
2453 }
2454 dtype = DTYPEG(sptr);
2455 if (DTY(dtype) != TY_ARRAY) {
2456 ndims = 0;
2457 } else { /* ST_ARRAY */
2458 ad = AD_PTR(sptr);
2459 ndims = AD_NUMDIM(ad);
2460 dtype = DTY(dtype + 1);
2461 }
2462 PUT(dtype_to_arg(dtype));
2463 ++static_cnt;
2464 if ((DDTG(dtype)) == DT_DEFERCHAR || (DDTG(dtype)) == DT_DEFERNCHAR) {
2465 PUT(0); /* character length */
2466 ++static_cnt;
2467 } else if (DTY(dtype) == TY_CHAR || DTY(dtype) == TY_NCHAR) {
2468 int clen = string_length(dtype);
2469 PUT(clen); /* character length */
2470 ++static_cnt;
2471 } else if (DTY(dtype) == TY_DERIVED) {
2472 PUT(DTY(dtype + 2)); /* size of the derived type */
2473 ++static_cnt;
2474 } else {
2475 PUT(0);
2476 ++static_cnt;
2477 }
2478
2479 /* IMPORTANT: If more data is added between sptr and after ndims,
2480 * an update needs to be done in lower_data_stmt()
2481 * in lowerilm.c for adjustable array because
2482 * it counts many data between sptr and ndims
2483 * to start lower/upperbounds information.
2484 */
2485
2486 dttype = DDTG(DTYPEG(sptr));
2487 i = dtype_has_defined_io(dttype) & (DT_IO_FWRITE | DT_IO_FREAD);
2488 if (SDSCG(sptr) && (POINTERG(sptr) || ALLOCG(sptr)))
2489 if (DTY(dttype) == TY_DERIVED && i) {
2490 PUT(-2); /* number of dimensions */
2491 } else {
2492 PUT(-1); /* number of dimensions */
2493 }
2494 else {
2495 if (DTY(dttype) == TY_DERIVED && i) {
2496 PUT(ndims + 30); /* number of dimensions+30 */
2497 } else {
2498 PUT(ndims); /* number of dimensions */
2499 }
2500 }
2501 ++static_cnt;
2502 if (ndims && !POINTERG(sptr) && !ALLOCG(sptr) && !ADJARRG(sptr)) {
2503 cnt = 0;
2504 /* lower and upper bounds for each dimension */
2505 do {
2506 PUT(get_int_cval(sym_of_ast(AD_LWAST(ad, cnt))));
2507 PUT(get_int_cval(sym_of_ast(AD_UPAST(ad, cnt))));
2508 static_cnt = static_cnt + 2;
2509 cnt++;
2510 } while (--ndims);
2511 } else if (ndims && ADJARRG(sptr)) {
2512 int dt = DTYPEG(sptr);
2513 int subs[MAXRANK];
2514 cnt = 0;
2515 if (SCG(sptr) != SC_DUMMY) {
2516 /*
2517 * Namelist of automatic array - its pointer is to be stored at
2518 * nml [static_cnt-3]
2519 */
2520 int std = STD_NEXT(0);
2521 int from, astplist, ast, dest;
2522 from = mk_id(sptr);
2523 from = mk_unop(OP_LOC, from, DT_PTR);
2524 subs[0] = mk_cval(static_cnt - 3, DT_INT);
2525 astplist = mk_id(ADDRESSG(nml));
2526 dest = mk_subscr(astplist, subs, 1, DT_PTR);
2527 ast = mk_assn_stmt(dest, from, DTYPEG(dest));
2528 add_stmt_after(ast, 0);
2529 }
2530 do {
2531 if (ADD_LWBD(dt, cnt)) {
2532 int std = STD_NEXT(0);
2533 int from, astplist, ast, dest;
2534 ++static_cnt;
2535 from = mk_id(sym_of_ast(AD_LWAST(ad, cnt)));
2536 subs[0] = mk_cval(static_cnt, DT_INT);
2537 astplist = mk_id(ADDRESSG(nml));
2538 dest = mk_subscr(astplist, subs, 1, DT_PTR);
2539 ast = mk_assn_stmt(dest, from, DTYPEG(dest));
2540 PUT(-99);
2541 add_stmt_after(ast, 0);
2542 } else {
2543 ++static_cnt;
2544 PUT(get_int_cval(sym_of_ast(AD_LWAST(ad, cnt))));
2545 }
2546
2547 if (ADD_UPBD(dt, cnt)) {
2548 int std = STD_NEXT(0);
2549 int from, astplist, ast, dest;
2550 ++static_cnt;
2551 from = mk_id(sym_of_ast(AD_UPAST(ad, cnt)));
2552 astplist = mk_id(ADDRESSG(nml));
2553 subs[0] = mk_cval(static_cnt, DT_INT);
2554 dest = mk_subscr(astplist, subs, 1, DT_PTR);
2555 ast = mk_assn_stmt(dest, from, DTYPEG(dest));
2556 add_stmt_after(ast, 0);
2557 PUT(-99);
2558 } else {
2559 PUT(get_int_cval(sym_of_ast(AD_UPAST(ad, cnt))));
2560 ++static_cnt;
2561 }
2562 cnt++;
2563 } while (--ndims);
2564 } else if (POINTERG(sptr) || ALLOCATTRG(sptr)) {
2565 PUT(ndims); /* number of dimensions */
2566 ++static_cnt;
2567 PUTA(SDSCG(sptr)); /* item's descriptor address */
2568 ++static_cnt;
2569 ADDRTKNP(SDSCG(sptr), 1);
2570 }
2571
2572 /* defined io */
2573 i = dtype_has_defined_io(dttype) & (DT_IO_FWRITE | DT_IO_FREAD);
2574 if (DTY(dttype) == TY_DERIVED && i) {
2575 int rsptr, wsptr, vlist, vlistsd, dtvsd;
2576 ITEM *arglist;
2577 SST *stkptr;
2578
2579 vlist = gen_vlist();
2580 arglist = gen_dtio_arglist(sptr, vlist);
2581
2582 rsptr = resolve_defined_io(0, arglist->t.stkp, arglist);
2583 wsptr = resolve_defined_io(1, arglist->t.stkp, arglist);
2584 #if DEBUG
2585 if (rsptr == 0 && wsptr == 0) {
2586 printf("ERROR can't find either read or write user defined io\n");
2587 }
2588 #endif
2589 vlistsd = SDSCG(A_SPTRG(vlist));
2590 dtvsd = SDSCG(sptr);
2591 ADDRTKNP(vlistsd, 1);
2592 ADDRTKNP(vlistsd, 1);
2593 ADDRTKNP(MIDNUMG(A_SPTRG(vlist)), 1);
2594
2595 PUTA(-98); /* derived type with defined io */
2596 if (CLASSG(rsptr) && TBPLNKG(rsptr)) {
2597 /* FS#21015: Read is a type bound procedure. Need to resolve it to a
2598 * static routine.
2599 */
2600 rsptr = get_implementation(TBPLNKG(rsptr), rsptr, 0, 0);
2601 }
2602 PUTA(rsptr); /* read funcptr address */
2603 if (CLASSG(wsptr) && TBPLNKG(wsptr)) {
2604 /* FS#21015: Write is a type bound procedure. Need to resolve it to a
2605 * static routine.
2606 */
2607 wsptr = get_implementation(TBPLNKG(wsptr), wsptr, 0, 0);
2608 }
2609 PUTA(wsptr); /* write funcptr address */
2610 PUTA(sptr); /* dtv address */
2611 PUTA(0); /* dtv$sd address */
2612 PUTA(MIDNUMG(A_SPTRG(vlist))); /* v_list address */
2613 PUTA(vlistsd); /* v_list$sd address */
2614 static_cnt += 7;
2615 }
2616 }
2617
2618 /*
2619 * Create a character variable which is data initialized with the name
2620 * of the symbol.
2621 */
2622 static void
dinit_name(int sptr)2623 dinit_name(int sptr)
2624 {
2625 char *name;
2626 int sym_name;
2627 int new_var;
2628
2629 name = SYMNAME(sptr);
2630 sym_name = getstring(local_sname(name), strlen(name));
2631 new_var = getcctmp('t', sym_name, ST_UNKNOWN, DTYPEG(sym_name));
2632 if (STYPEG(new_var) == ST_UNKNOWN) {
2633 STYPEP(new_var, ST_VAR);
2634 DINITP(new_var, 1);
2635 sym_is_refd(new_var);
2636 dinit_put(DINIT_LOC, new_var);
2637 dinit_put(DINIT_STR, (INT)sym_name);
2638 dinit_put(DINIT_END, (INT)0);
2639 }
2640 }
2641
2642 /*
2643 * emit the length and the address of a character string constant which
2644 * is the name of this symbol. In order ensure that the character string is
2645 * initialized by the Assembler, sym_is_refd is called.
2646 */
2647 static void
put_name(int sptr)2648 put_name(int sptr)
2649 {
2650 char *name;
2651 int sym_name;
2652
2653 name = SYMNAME(sptr);
2654 PUT(strlen(name));
2655 sym_name = getstring(local_sname(name), strlen(name));
2656 sym_is_refd(sym_name);
2657 if (XBIT(49, 0x100000)) {
2658 int new_var;
2659 new_var = getcctmp('t', sym_name, ST_UNKNOWN, DTYPEG(sym_name));
2660 sym_name = new_var;
2661 }
2662 dinit_put(DINIT_LABEL, (INT)sym_name);
2663 }
2664
2665 /*------------------------------------------------------------------*/
2666
2667 static LOGICAL in_local_scope(int, int);
2668
2669 static void
do_save(void)2670 do_save(void)
2671 {
2672 int sptr, a;
2673 int nsyms;
2674 int stype;
2675 int local_scope;
2676
2677 /* scan entire symbol table to find variables to add to .save. */
2678
2679 local_scope = stb.curr_scope;
2680 if (gbl.currsub && gbl.currsub != stb.curr_scope) {
2681 local_scope = gbl.currsub;
2682 }
2683 nsyms = stb.stg_avail - 1;
2684 for (sptr = stb.firstusym; sptr <= nsyms; ++sptr) {
2685 stype = STYPEG(sptr);
2686 if (stype == ST_ARRAY && (ADJARRG(sptr) || RUNTIMEG(sptr)) &&
2687 (SCG(sptr) == SC_NONE || SCG(sptr) == SC_LOCAL) && !CCSYMG(sptr) &&
2688 !HCCSYMG(sptr)) {
2689 /* automatic array */
2690 if (SAVEG(sptr))
2691 error(39, 3, gbl.lineno, SYMNAME(sptr), CNULL);
2692 } else if (ST_ISVAR(stype) && SCG(sptr) == SC_LOCAL &&
2693 in_local_scope(sptr, local_scope) && !REFG(sptr) &&
2694 !CCSYMG(sptr) && !(HCCSYMG(sptr) && ALLOCG(sptr)) &&
2695 (sem.savall || SAVEG(sptr))) {
2696 int dt_dtype = DDTG(DTYPEG(sptr));
2697 if (
2698 (DTY(dt_dtype) == TY_CHAR || DTY(dt_dtype) == TY_NCHAR) &&
2699 !A_ALIASG(DTY(dt_dtype + 1))) {
2700 /* non-constant length character string */
2701 if (SAVEG(sptr))
2702 error(39, 3, gbl.lineno, SYMNAME(sptr), CNULL);
2703 }
2704 else {
2705 SCP(sptr, SC_STATIC);
2706 SAVEP(sptr, 1);
2707 /* see if the DINIT flag is going to be set */
2708 if (DTY(dt_dtype) == TY_DERIVED && DTY(dt_dtype + 5) &&
2709 !POINTERG(sptr) && !ALLOCG(sptr) && !ADJARRG(sptr)) {
2710 DINITP(sptr, 1);
2711 }
2712 sym_is_refd(sptr);
2713 }
2714 } else if (sem.savall && ST_ISVAR(stype) && SCG(sptr) == SC_BASED &&
2715 ALLOCATTRG(sptr) && in_local_scope(sptr, local_scope)) {
2716 SAVEP(sptr, 1);
2717 }
2718 }
2719
2720 }
2721
2722 static LOGICAL
in_local_scope(int sym,int local_scope)2723 in_local_scope(int sym, int local_scope)
2724 {
2725 int scp;
2726 scp = SCOPEG(sym);
2727 if (scp && STYPEG(scp) == ST_ALIAS)
2728 scp = SYMLKG(scp);
2729 if (scp == local_scope)
2730 return TRUE;
2731 return FALSE;
2732 }
2733
2734 static void
do_sequence(void)2735 do_sequence(void)
2736 {
2737 int sptr, a;
2738 int nsyms;
2739 int stype;
2740 SEQL *seqp;
2741
2742 if ((sem.seql.type == 0 && flg.sequence) || sem.seql.type == 's') {
2743 /* scan entire symbol table to find variables to mark
2744 * sequential
2745 */
2746 nsyms = stb.stg_avail - 1;
2747 for (sptr = stb.firstusym; sptr <= nsyms; ++sptr) {
2748 stype = STYPEG(sptr);
2749 if (ST_ISVAR(stype)) {
2750 if (SOCPTRG(sptr) == 0 && !ASUMSZG(sptr) && !ASSUMSHPG(sptr))
2751 SEQP(sptr, 1);
2752 } else if (stype == ST_CMBLK) {
2753 SEQP(sptr, 1);
2754 } else if (stype == ST_MEMBER) {
2755 SEQP(sptr, 1);
2756 }
2757 }
2758 } else if (sem.seql.type == 'n') {
2759 /* scan entire symbol table to find variables to mark
2760 * nonsequential
2761 */
2762 nsyms = stb.stg_avail - 1;
2763 for (sptr = stb.firstusym; sptr <= nsyms; ++sptr) {
2764 stype = STYPEG(sptr);
2765 if (ST_ISVAR(stype)) {
2766 if (SOCPTRG(sptr) == 0 && !ASUMSZG(sptr) && !ASSUMSHPG(sptr))
2767 SEQP(sptr, 0);
2768 } else if (stype == ST_CMBLK) {
2769 SEQP(sptr, 0);
2770 } else if (stype == ST_MEMBER) {
2771 SEQP(sptr, 0);
2772 }
2773 }
2774 }
2775 /*
2776 * traverse sequence list and process any common blocks which
2777 * appeared in the sequence statements
2778 */
2779 for (seqp = sem.seql.next; seqp != NULL; seqp = seqp->next) {
2780 sptr = seqp->sptr;
2781 stype = STYPEG(sptr);
2782 if (stype == ST_CMBLK) {
2783 if (seqp->type == 's')
2784 SEQP(sptr, 1);
2785 else
2786 SEQP(sptr, 0);
2787 }
2788 }
2789 /*
2790 * traverse common blocks and propagate storage association to the
2791 * members.
2792 */
2793 for (sptr = gbl.cmblks; sptr != NOSYM; sptr = SYMLKG(sptr)) {
2794 int elsym;
2795
2796 if (SEQG(sptr))
2797 for (elsym = CMEMFG(sptr); elsym != NOSYM; elsym = SYMLKG(elsym))
2798 SEQP(elsym, 1);
2799 }
2800 /*
2801 * traverse sequence list and process any variables which
2802 * appeared in the sequence statements
2803 */
2804 for (seqp = sem.seql.next; seqp != NULL; seqp = seqp->next) {
2805 sptr = seqp->sptr;
2806 stype = STYPEG(sptr);
2807 if (ST_ISVAR(stype)) {
2808 if (seqp->type == 's') {
2809 SEQP(sptr, 1);
2810 } else {
2811 if (SOCPTRG(sptr) || ASUMSZG(sptr))
2812 error(155, 3, gbl.lineno, SYMNAME(sptr),
2813 "cannot appear in a NOSEQUENCE statement");
2814 else if (SCG(sptr) == SC_CMBLK && SEQG(CMBLKG(sptr)))
2815 error(155, 3, gbl.lineno,
2816 "Nonsequential variable in sequential common block -",
2817 SYMNAME(sptr));
2818 else
2819 SEQP(sptr, 0);
2820 }
2821 } else if (stype == ST_IDENT) {
2822 if (seqp->type == 's')
2823 SEQP(sptr, 1);
2824 } else if (stype != ST_CMBLK)
2825 error(155, 3, gbl.lineno, SYMNAME(sptr),
2826 "cannot appear in a [NO]SEQUENCE statement");
2827 }
2828
2829 }
2830
2831 /*------------------------------------------------------------------*/
2832 /* return TRUE if the expression at 'ast' is composed of constants
2833 * the special symbol 'hpf_np$', dummy arguments, common variables, or
2834 * module variables, or is data initialized */
2835
2836 static LOGICAL available_internal;
2837 static LOGICAL _available(int ast);
2838
2839 static LOGICAL
_available_size(int ast)2840 _available_size(int ast)
2841 {
2842 int sptr, i, ss, ndim, asd, narg, argt, lop, firstarg;
2843 if (!ast)
2844 return TRUE;
2845 switch (A_TYPEG(ast)) {
2846 case A_ID:
2847 /* check for named parameter, or hpf_np$ */
2848 sptr = A_SPTRG(ast);
2849 if (STYPEG(sptr) == ST_CONST || STYPEG(sptr) == ST_PARAM)
2850 return TRUE;
2851 switch (SCG(sptr)) {
2852 case SC_CMBLK:
2853 case SC_NONE:
2854 case SC_LOCAL:
2855 case SC_DUMMY:
2856 case SC_STATIC:
2857 return TRUE;
2858 case SC_EXTERN:
2859 case SC_BASED:
2860 case SC_PRIVATE:
2861 break;
2862 }
2863 if (HCCSYMG(sptr)) /* compiler temp, must assume it'll get filled*/
2864 return TRUE;
2865 if (DINITG(sptr))
2866 return TRUE;
2867 if (SCOPEG(sptr) && STYPEG(SCOPEG(sptr)) == ST_MODULE)
2868 return TRUE;
2869 if (available_internal && !INTERNALG(sptr))
2870 return TRUE;
2871 break;
2872 case A_MEM:
2873 return _available_size(A_PARENTG(ast));
2874 case A_SUBSCR:
2875 if (!_available_size(A_LOPG(ast))) {
2876 return FALSE;
2877 }
2878 asd = A_ASDG(ast);
2879 ndim = ASD_NDIM(asd);
2880 for (i = 0; i < ndim; ++i) {
2881 ss = ASD_SUBS(asd, i);
2882 if (!_available(ss)) {
2883 return FALSE;
2884 }
2885 }
2886 return TRUE;
2887 case A_TRIPLE:
2888 if (!_available(A_LBDG(ast)))
2889 return FALSE;
2890 if (!_available(A_UPBDG(ast)))
2891 return FALSE;
2892 if (!_available(A_STRIDEG(ast)))
2893 return FALSE;
2894 return TRUE;
2895 case A_CNST:
2896 return TRUE;
2897 case A_BINOP:
2898 if (_available_size(A_LOPG(ast)) && _available_size(A_ROPG(ast))) {
2899 return TRUE;
2900 }
2901 break;
2902 case A_UNOP:
2903 if (ast == astb.ptr0)
2904 return TRUE;
2905 if (ast == astb.ptr1)
2906 return TRUE;
2907 if (ast == astb.ptr0c)
2908 return TRUE;
2909 /* fall through */
2910 case A_PAREN:
2911 case A_CONV:
2912 if (_available_size(A_LOPG(ast))) {
2913 return TRUE;
2914 }
2915 break;
2916 case A_FUNC:
2917 lop = A_LOPG(ast);
2918 if (!HCCSYMG(A_SPTRG(lop))) {
2919 return FALSE;
2920 }
2921 /* fall through */
2922 case A_INTR:
2923 firstarg = 0;
2924 narg = A_ARGCNTG(ast);
2925 argt = A_ARGSG(ast);
2926 if (A_TYPEG(ast) == A_INTR) {
2927 switch (A_OPTYPEG(ast)) {
2928 case I_SIZE:
2929 case I_LBOUND:
2930 case I_UBOUND:
2931 firstarg = 1;
2932 if (!_available_size(ARGT_ARG(argt, 0))) {
2933 return FALSE;
2934 }
2935 break;
2936 }
2937 }
2938 for (i = firstarg; i < narg; ++i) {
2939 if (!_available(ARGT_ARG(argt, i))) {
2940 return FALSE;
2941 }
2942 }
2943 return TRUE;
2944 } /* switch */
2945 return FALSE;
2946 } /* _available_size */
2947
2948 static LOGICAL
_available(int ast)2949 _available(int ast)
2950 {
2951 int sptr, i, ss, ndim, asd, narg, argt, lop, firstarg;
2952 if (!ast)
2953 return TRUE;
2954 switch (A_TYPEG(ast)) {
2955 case A_ID:
2956 /* check for named parameter, or hpf_np$ */
2957 sptr = A_SPTRG(ast);
2958 if (sptr == gbl.sym_nproc)
2959 return TRUE;
2960 if (STYPEG(sptr) == ST_CONST || STYPEG(sptr) == ST_PARAM)
2961 return TRUE;
2962 if (SCG(sptr) == SC_CMBLK)
2963 return TRUE;
2964 if (SCG(sptr) == SC_DUMMY)
2965 return TRUE;
2966 if (SCG(sptr) == SC_BASED) {
2967 if (POINTERG(sptr) && MIDNUMG(sptr)) {
2968 if (SCG(MIDNUMG(sptr)) == SC_CMBLK)
2969 return TRUE;
2970 if (SCG(MIDNUMG(sptr)) == SC_DUMMY)
2971 return TRUE;
2972 }
2973 }
2974 if (HCCSYMG(sptr)) /* compiler temp, must assume it'll get filled*/
2975 return TRUE;
2976 if (DINITG(sptr))
2977 return TRUE;
2978 if (SCOPEG(sptr) && STYPEG(SCOPEG(sptr)) == ST_MODULE)
2979 return TRUE;
2980 if (available_internal && !INTERNALG(sptr))
2981 return TRUE;
2982 break;
2983 case A_MEM:
2984 return _available(A_PARENTG(ast));
2985 case A_SUBSCR:
2986 if (!_available(A_LOPG(ast))) {
2987 return FALSE;
2988 }
2989 asd = A_ASDG(ast);
2990 ndim = ASD_NDIM(asd);
2991 for (i = 0; i < ndim; ++i) {
2992 ss = ASD_SUBS(asd, i);
2993 if (!_available(ss)) {
2994 return FALSE;
2995 }
2996 }
2997 return TRUE;
2998 case A_TRIPLE:
2999 if (!_available(A_LBDG(ast)))
3000 return FALSE;
3001 if (!_available(A_UPBDG(ast)))
3002 return FALSE;
3003 if (!_available(A_STRIDEG(ast)))
3004 return FALSE;
3005 return TRUE;
3006 case A_CNST:
3007 return TRUE;
3008 case A_BINOP:
3009 if (_available(A_LOPG(ast)) && _available(A_ROPG(ast))) {
3010 return TRUE;
3011 }
3012 break;
3013 case A_UNOP:
3014 if (ast == astb.ptr0)
3015 return TRUE;
3016 if (ast == astb.ptr1)
3017 return TRUE;
3018 if (ast == astb.ptr0c)
3019 return TRUE;
3020 /* fall through */
3021 case A_PAREN:
3022 case A_CONV:
3023 if (_available(A_LOPG(ast))) {
3024 return TRUE;
3025 }
3026 break;
3027 case A_FUNC:
3028 lop = A_LOPG(ast);
3029 if (!HCCSYMG(A_SPTRG(lop))) {
3030 return FALSE;
3031 }
3032 /* fall through */
3033 case A_INTR:
3034 firstarg = 0;
3035 narg = A_ARGCNTG(ast);
3036 argt = A_ARGSG(ast);
3037 if (A_TYPEG(ast) == A_INTR) {
3038 switch (A_OPTYPEG(ast)) {
3039 case I_SIZE:
3040 case I_LBOUND:
3041 case I_UBOUND:
3042 firstarg = 1;
3043 if (!_available_size(ARGT_ARG(argt, 0))) {
3044 return FALSE;
3045 }
3046 break;
3047 }
3048 }
3049 for (i = firstarg; i < narg; ++i) {
3050 if (!_available(ARGT_ARG(argt, i))) {
3051 return FALSE;
3052 }
3053 }
3054 return TRUE;
3055 } /* switch */
3056 return FALSE;
3057 } /* _available */
3058
3059 static LOGICAL
available(int ast,int internal)3060 available(int ast, int internal)
3061 {
3062 available_internal = internal;
3063 return _available(ast);
3064 } /* available */
3065
3066 /** \brief Check that sptr is declared if IMPLICIT NONE is set.
3067
3068 Be careful about the situation where IMPLICIT NONE is in the host,
3069 but there are IMPLICIT statements in the contained subprogram.
3070 */
3071 void
CheckDecl(int sptr)3072 CheckDecl(int sptr)
3073 {
3074 /* if symbol was declared, no problem */
3075 if (DCLDG(sptr))
3076 return;
3077 #ifdef CLASSG
3078 if (STYPEG(sptr) == ST_ENTRY && CLASSG(sptr))
3079 return; /* forward reference to a type bound procedure is OK */
3080 #endif
3081 /*
3082 *in a contained subprogram, if no IMPLICIT NONE in the
3083 * subprogram, and the symbol was implicitly typed due to
3084 * an IMPLICIT statement in the contained subprogram, no problem
3085 */
3086 if (gbl.internal > 1 && (sem.none_implicit & 0x08) == 0 &&
3087 was_implicit(sptr) != 0)
3088 return;
3089 /*
3090 * Similar to above, but in a contained subprogram of a module
3091 */
3092 if (IN_MODULE && (sem.none_implicit & 0x08) == 0 && was_implicit(sptr) != 0)
3093 return;
3094 /*
3095 * in a module subprogram, no IMPLICIT NONE in the module subprogram
3096 * (must be in the module itself), and symbol was implicitly
3097 * typed due to an IMPLICIT statement in the module subprogram,
3098 * no problem
3099 */
3100 if (gbl.internal <= 1 && sem.mod_cnt == 2 &&
3101 (sem.none_implicit & 0x04) == 0 && was_implicit(sptr))
3102 return;
3103 /* Subroutine reference in a module, could be defined later */
3104 if (sem.mod_cnt == 1 && STYPEG(sptr) == ST_PROC && sem.which_pass == 0)
3105 return;
3106
3107 error(38, !XBIT(124, 0x20000) ? 3 : 2, gbl.lineno, SYMNAME(sptr), CNULL);
3108 DCLDP(sptr, 1);
3109 } /* CheckDecl */
3110
3111 static LOGICAL
search_for_auto(int ast,int * auto_found)3112 search_for_auto(int ast, int *auto_found)
3113 {
3114 int sptr;
3115 int i;
3116
3117 if (A_TYPEG(ast) == A_ID) {
3118 sptr = A_SPTRG(ast);
3119 if (sptr && SCG(sptr) == SC_LOCAL && SCOPEG(sptr) == gbl.currsub &&
3120 DT_ISINT(DTYPEG(sptr)) && !HCCSYMG(sptr) && !PASSBYVALG(sptr)) {
3121 *auto_found = TRUE;
3122 }
3123 }
3124
3125 /* don't look at func args */
3126 if (A_TYPEG(ast) == A_FUNC || A_TYPEG(ast) == A_INTR) {
3127 int argt = A_ARGSG(ast);
3128 for (i = 0; i < A_ARGCNTG(ast); i++) {
3129 if (ARGT_ARG(argt, i)) {
3130 ast_visit(ARGT_ARG(argt, i), 1);
3131 }
3132 }
3133 }
3134 return *auto_found;
3135 }
3136
3137 static LOGICAL
bnd_contains_auto(int ast)3138 bnd_contains_auto(int ast)
3139 {
3140 LOGICAL auto_found = FALSE;
3141 ast_visit(1, 1);
3142 ast_traverse(ast, search_for_auto, NULL, &auto_found);
3143 ast_unvisit();
3144 return auto_found;
3145 }
3146
3147 static LOGICAL
bounds_contain_automatics(int sptr)3148 bounds_contain_automatics(int sptr)
3149 {
3150 int dtype = DTYPEG(sptr);
3151 ADSC *ad = AD_DPTR(dtype);
3152 int ndim = AD_NUMDIM(ad);
3153 int i;
3154
3155 for (i = 0; i < ndim; i++) {
3156 if (AD_LWBD(ad, i) && bnd_contains_auto(AD_LWBD(ad, i)))
3157 return TRUE;
3158 if (AD_UPBD(ad, i) && bnd_contains_auto(AD_UPBD(ad, i)))
3159 return TRUE;
3160 }
3161 return FALSE;
3162 }
3163
3164 static void
append_to_adjarr_list(int sptr)3165 append_to_adjarr_list(int sptr)
3166 {
3167 int i;
3168
3169 for (i = gbl.p_adjarr; i > NOSYM; i = SYMLKG(i)) {
3170 if (i == sptr) {
3171 return;
3172 }
3173 }
3174
3175 SYMLKP(sptr, gbl.p_adjarr);
3176 gbl.p_adjarr = sptr;
3177 }
3178
3179 static void
append_to_adjstr_list(int sptr)3180 append_to_adjstr_list(int sptr)
3181 {
3182 int i;
3183
3184 for (i = gbl.p_adjstr; i > NOSYM; i = ADJSTRLKG(i)) {
3185 if (i == sptr) {
3186 return;
3187 }
3188 }
3189
3190 ADJSTRLKP(sptr, gbl.p_adjstr);
3191 gbl.p_adjstr = sptr;
3192 }
3193
3194 static void
misc_checks(void)3195 misc_checks(void)
3196 {
3197 int sptr, a;
3198 int nsyms;
3199 int stype;
3200 ITEM *itemp;
3201 int s, dtype, ndim, i, dist, d, circular, alignee, axis, anygenblock;
3202
3203 /* scan entire symbol table */
3204
3205 nsyms = stb.stg_avail - 1;
3206 for (sptr = stb.firstusym; sptr <= nsyms; ++sptr) {
3207 stype = STYPEG(sptr);
3208 /* if sptr is adjustable or assumed-size array, or assumed-size
3209 character identifier, check that it is a dummy argument */
3210 switch (stype) {
3211 case ST_IDENT:
3212 if (gbl.internal == 1 && SCG(sptr) == SC_NONE && ADJLENG(sptr)) {
3213 /* unreferenced symbol in host subprogram; set storage class */
3214 STYPEP(sptr, ST_VAR);
3215 }
3216 /* fall through */
3217 case ST_ARRAY:
3218 case ST_VAR:
3219 if (gbl.internal == 1 && SCG(sptr) == SC_NONE) {
3220 /* unreferenced symbol in host subprogram; set storage class */
3221 sem_set_storage_class(sptr);
3222 }
3223 if (XBIT(58, 0x10000) && !F90POINTERG(sptr) && SDSCG(sptr) == 0 &&
3224 gbl.internal == 1 && SCG(sptr) == SC_BASED &&
3225 (POINTERG(sptr) || ALLOCG(sptr) || ADJARRG(sptr) || RUNTIMEG(sptr) ||
3226 ALLOCATTRG(sptr))) {
3227 /* need descriptor for contained subprograms */
3228 get_static_descriptor(sptr);
3229 if (POINTERG(sptr)) {
3230 get_all_descriptors(sptr);
3231 } else {
3232 trans_mkdescr(sptr);
3233 SECDSCP(DESCRG(sptr), SDSCG(sptr));
3234 if (ALLOCATTRG(sptr) && !SAVEG(sptr) && !sem.savall) {
3235 add_auto_dealloc(sptr);
3236 }
3237 }
3238 }
3239 if (SCG(sptr) == SC_DUMMY && IGNORE_TKRG(sptr) && !ignore_tkr_all(sptr)) {
3240 if ((ASSUMSHPG(sptr) && (IGNORE_TKRG(sptr) & IGNORE_C) == 0) ||
3241 POINTERG(sptr) || ALLOCATTRG(sptr)) {
3242 error(155, 3, gbl.lineno, "IGNORE_TKR may not be specified for",
3243 SYMNAME(sptr));
3244 }
3245 }
3246 if (STYPEG(sptr) == ST_ARRAY && !IGNOREG(sptr) && !HCCSYMG(sptr) &&
3247 !DEVICEG(sptr) && (SCG(sptr) == SC_NONE || SCG(sptr) == SC_LOCAL) &&
3248 bounds_contain_automatics(sptr)) {
3249 error(310, 3, LINENOG(sptr),
3250 "Adjustable array can not have automatic bounds specifiers -",
3251 SYMNAME(sptr));
3252 }
3253
3254 if (SCG(sptr) == SC_DUMMY && PASSBYVALG(sptr)) {
3255 PASSBYVALP(MIDNUMG(sptr),
3256 0); /* clear byval flag on local (copy of arg) */
3257 }
3258 if (ADJARRG(sptr) && !IGNOREG(sptr)) {
3259 append_to_adjarr_list(sptr);
3260 }
3261 if (ADJLENG(sptr) && !IGNOREG(sptr)) {
3262 append_to_adjstr_list(sptr);
3263 }
3264 #ifdef PTRRHSG
3265 if (!in_module && TARGETG(sptr) && !PTRRHSG(sptr)) {
3266 if (ALLOCATTRG(sptr)) {
3267 int ptr;
3268 ptr = MIDNUMG(sptr);
3269 if (ptr)
3270 switch (SCG(ptr)) {
3271 case SC_LOCAL:
3272 case SC_STATIC:
3273 case SC_PRIVATE:
3274 if (!gbl.internal || INTERNALG(sptr))
3275 TARGETP(sptr, 0);
3276 break;
3277 default:;
3278 }
3279 } else if (!POINTERG(sptr))
3280 switch (SCG(sptr)) {
3281 case SC_LOCAL:
3282 case SC_STATIC:
3283 case SC_PRIVATE:
3284 if (!gbl.internal || INTERNALG(sptr))
3285 TARGETP(sptr, 0);
3286 break;
3287 default:;
3288 }
3289 }
3290 #endif
3291 /* does it need data initialization? */
3292 dtype = DTYPEG(sptr);
3293 dtype = DDTG(dtype);
3294 if (sem.which_pass && !IGNOREG(sptr) &&
3295 (gbl.internal <= 1 || INTERNALG(sptr)) &&
3296 (ENCLFUNCG(sptr) == 0 || STYPEG(ENCLFUNCG(sptr)) == ST_MODULE) &&
3297 DTY(dtype) == TY_DERIVED &&
3298 (get_struct_initialization_tree(dtype) || CLASSG(sptr)) &&
3299 !CCSYMG(sptr) &&
3300 !POINTERG(sptr) && !ALLOCG(sptr) && !ADJARRG(sptr) &&
3301 !HCCSYMG(sptr)) {
3302 if (SCOPEG(sptr) && STYPEG(SCOPEG(sptr)) == ST_MODULE) {
3303 /*
3304 * a derived type module variable has component
3305 * initializers, so its inits have already been processed
3306 */
3307 break;
3308 }
3309 if (SCG(sptr) == SC_NONE && !REFG(sptr) &&
3310 has_finalized_component(sptr)) {
3311 /* unreferenced derived type with final component needs to be
3312 * initialized since its final subroutine will still get called.
3313 */
3314 sem_set_storage_class(sptr);
3315 }
3316 if (gbl.rutype == RU_PROG || SCG(sptr) == SC_STATIC ||
3317 (SCG(sptr) == SC_LOCAL && (SAVEG(sptr) || sem.savall))) {
3318 build_typedef_init_tree(sptr, dtype);
3319 SAVEP(sptr, 1);
3320 DINITP(sptr, 1);
3321 } else if (SCG(sptr) == SC_LOCAL || RESULTG(sptr) ||
3322 (SCG(sptr) == SC_DUMMY && INTENTG(sptr) == INTENT_OUT)) {
3323 init_derived_type(sptr, 0, 0);
3324 }
3325 if (SCG(sptr) == SC_LOCAL && !SAVEG(sptr) && !sem.savall &&
3326 ALLOCFLDG(DTY(dtype + 3))) {
3327 add_auto_dealloc(sptr);
3328 }
3329 }
3330 else if (RESULTG(sptr) && ALLOCATTRG(sptr) &&
3331 FVALG(gbl.currsub) == sptr) {
3332 int ast;
3333 ast = add_nullify_ast(mk_id(sptr));
3334 (void)add_stmt_after(ast, 0);
3335 }
3336 // force implicitly save for local threadprivate
3337 if (gbl.rutype == RU_PROG && sem.which_pass && THREADG(sptr)) {
3338 int midnum = 0;
3339 if (SCG(sptr) == SC_BASED) {
3340 midnum = MIDNUMG(sptr);
3341 }
3342 if (midnum && SCG(midnum) == SC_LOCAL) {
3343 int sdsc = SDSCG(sptr);
3344 int ptroff = PTROFFG(sptr);
3345 SAVEP(midnum, 1);
3346 if (sdsc) {
3347 SAVEP(sdsc, 1);
3348 }
3349 if (ptroff) {
3350 SAVEP(ptroff, 1);
3351 }
3352 }
3353 }
3354 if (gbl.rutype != RU_PROG && sem.which_pass && THREADG(sptr) &&
3355 !CCSYMG(sptr)) {
3356 if (SCOPEG(sptr) && STYPEG(SCOPEG(sptr)) == ST_MODULE)
3357 continue;
3358 if (ALLOCG(sptr) || POINTERG(sptr) || ALLOCATTRG(sptr)) {
3359 int ptr;
3360 ptr = MIDNUMG(sptr);
3361 if (ptr) {
3362 if (SCG(ptr) != SC_CMBLK) {
3363 if (!SAVEG(sptr) && !DINITG(sptr) && !sem.savall) {
3364 error(155, 3, gbl.lineno,
3365 "THREADPRIVATE variable must have the SAVE attribute -",
3366 SYMNAME(sptr));
3367 }
3368 }
3369 } else {
3370 if (!SAVEG(sptr) && !DINITG(sptr) && !sem.savall) {
3371 error(155, 3, gbl.lineno,
3372 "THREADPRIVATE variable must have the SAVE attribute -",
3373 SYMNAME(sptr));
3374 }
3375 }
3376 } else if (SCG(sptr) != SC_CMBLK) {
3377 if (!SAVEG(sptr) && !DINITG(sptr) && !sem.savall) {
3378 error(155, 3, gbl.lineno,
3379 "THREADPRIVATE variable must have the SAVE attribute -",
3380 SYMNAME(sptr));
3381 }
3382 }
3383 }
3384 break;
3385 case ST_CMBLK:
3386 if (CMEMFG(sptr) == 0 && THREADG(sptr) && !CCSYMG(sptr))
3387 error(155, 3, gbl.lineno, "THREADPRIVATE common block is empty -",
3388 SYMNAME(sptr));
3389 break;
3390 }
3391 #ifdef DEVCOPYG
3392 if (DEVCOPYG(sptr) && STYPEG(sptr) == ST_UNKNOWN)
3393 error(535, 3, gbl.lineno, SYMNAME(sptr), 0);
3394 #endif
3395 if (stype == ST_ARRAY && ASUMSZG(sptr) && SCG(sptr) != SC_DUMMY &&
3396 SCG(sptr) != SC_BASED && !CCSYMG(sptr) && !HCCSYMG(sptr)) {
3397 error(50, 3, gbl.lineno, SYMNAME(sptr), CNULL);
3398 } else if (stype == ST_ARRAY && ASSUMSHPG(sptr) && SCG(sptr) != SC_DUMMY &&
3399 !CCSYMG(sptr) && !HCCSYMG(sptr))
3400 error(196, 3, gbl.lineno, SYMNAME(sptr), CNULL);
3401 else if (stype == ST_IDENT && ALLOCATTRG(sptr) && !ALLOCG(sptr)) {
3402 /* FS#3849. In semant.c, we allow ALLOCATTR to be set on
3403 * ST_IDENT symbols to avoid false errors when the ALLOCATABLE
3404 * statement precedes the DIMENSION statement. But by this
3405 * time, an ST_IDENT symbol should not have ALLOCATTR set
3406 * unless ALLOC is set also.
3407 */
3408 error(84, 3, gbl.lineno, SYMNAME(sptr),
3409 "- must be a deferred shape array");
3410 } else if (!CCSYMG(sptr) && !HCCSYMG(sptr) &&
3411 (stype == ST_VAR || stype == ST_ARRAY || stype == ST_IDENT) &&
3412 stype != ST_CONST && stype != ST_ENTRY &&
3413 SCG(sptr) != SC_DUMMY && ASSUMLENG(sptr) &&
3414 (DTYPEG(sptr) == DT_ASSCHAR || DTYPEG(sptr) == DT_ASSNCHAR ||
3415 (DTY(DTYPEG(sptr)) == TY_ARRAY &&
3416 (DDTG(DTYPEG(sptr)) == DT_ASSCHAR ||
3417 DDTG(DTYPEG(sptr)) == DT_ASSNCHAR))))
3418 error(89, 3, gbl.lineno, SYMNAME(sptr), CNULL);
3419 else if ((stype == ST_IDENT || stype == ST_VAR || stype == ST_ARRAY) &&
3420 OPTARGG(sptr) && !HCCSYMG(sptr) && SCG(sptr) != SC_DUMMY)
3421 error(84, 3, gbl.lineno, SYMNAME(sptr), "- must be a dummy argument");
3422 else if ((stype == ST_VAR || stype == ST_ARRAY || stype == ST_IDENT) &&
3423 POINTERG(sptr) && HCCSYMG(sptr) && SCG(sptr) == SC_NONE)
3424 SCP(sptr, SC_BASED);
3425 if (stype == ST_PROC) {
3426 if (!HCCSYMG(sptr) && !CCSYMG(sptr) && !CFUNCG(sptr)) {
3427 if (WINNT_CALL)
3428 MSCALLP(sptr, 1);
3429 #ifdef CREFP
3430 if (WINNT_CREF && !STDCALLG(sptr))
3431 CREFP(sptr, 1);
3432 if (WINNT_NOMIXEDSTRLEN)
3433 NOMIXEDSTRLENP(sptr, 1);
3434 #endif
3435 }
3436 /*
3437 * tprs 3223, 3266, 3267, 3268: watch out for a dummy subroutine
3438 * which does not have DT.
3439 */
3440 if (SCG(sptr) == SC_DUMMY && DTYPEG(sptr) == DT_NONE &&
3441 FVALG(sptr) == 0 && TYPDG(sptr))
3442 DTYPEP(sptr, DT_INT);
3443 }
3444
3445 if (sem.none_implicit) {
3446 /* check that variable has a type if:
3447 * 1. IMPLICIT NONE
3448 * 2. not a temp
3449 * 3. not marked as ignored
3450 * 4. not from containing procedure
3451 * 5. not from USEd module */
3452 int encl;
3453 encl = ENCLFUNCG(sptr);
3454 if (!HCCSYMG(sptr) && !CCSYMG(sptr) && !IGNOREG(sptr) &&
3455 (gbl.internal <= 1 || INTERNALG(sptr)) && encl == 0) {
3456 switch (STYPEG(sptr)) {
3457 case ST_VAR:
3458 case ST_ARRAY:
3459 case ST_PARAM:
3460 case ST_STFUNC:
3461 DCLCHK(sptr);
3462 break;
3463 case ST_ENTRY:
3464 if (gbl.rutype == RU_FUNC) {
3465 if (FVALG(sptr)) {
3466 DCLCHK(FVALG(sptr));
3467 } else {
3468 DCLCHK(sptr);
3469 }
3470 }
3471 break;
3472 case ST_PROC:
3473 if (FUNCG(sptr)) {
3474 if (FVALG(sptr)) {
3475 DCLCHK(FVALG(sptr));
3476 } else {
3477 DCLCHK(sptr);
3478 }
3479 }
3480 break;
3481 default:
3482 break;
3483 }
3484 }
3485 /* set DCLD if this is a module variable,
3486 * since IMPLICIT NONE may not have been set in the module */
3487 if (encl && STYPEG(encl) == ST_MODULE && encl != gbl.currsub) {
3488 switch (STYPEG(sptr)) {
3489 case ST_VAR:
3490 case ST_ARRAY:
3491 case ST_PARAM:
3492 DCLDP(sptr, 1);
3493 break;
3494 case ST_PROC:
3495 if (FUNCG(sptr)) {
3496 DCLDP(sptr, 1);
3497 }
3498 break;
3499 default:
3500 break;
3501 }
3502 }
3503 }
3504 }
3505
3506 /* FS3913: Now it's safe to call sym_is_refd() for namelist items.
3507 * Items whose types have component initializations were initialized
3508 * above, so they'll correctly receive offsets into the initialized
3509 * data area now.
3510 *
3511 * When in a module, there could still be variables which are still
3512 * SC_NONE and we defer to module.c:fix_module_common() to set.
3513 * So we do not want do_nml_sym_is_refd() -> sym_is_refd() to occur.
3514 */
3515 if (!nml_err && !in_module)
3516 do_nml_sym_is_refd();
3517
3518 for (itemp = sem.intent_list; itemp != NULL; itemp = itemp->next) {
3519 sptr = itemp->t.sptr;
3520 if (SCG(sptr) != SC_DUMMY) {
3521 error(134, 3, itemp->ast, "- intent specified for nondummy argument",
3522 SYMNAME(sptr));
3523 } else if (STYPEG(sptr) == ST_PROC) {
3524 error(134, 3, itemp->ast,
3525 "- intent specified for dummy subprogram argument", SYMNAME(sptr));
3526 }
3527 }
3528 /* TPR 1692: set this to NULL now, because semant_init() (which also
3529 * initialize the intent_list) is not called between contained subprograms
3530 * within another subprogram */
3531 sem.intent_list = NULL;
3532
3533 }
3534
3535 static void
presence_test(LOGICAL * tested_presence,int * after_std,SPTR sptr)3536 presence_test(LOGICAL *tested_presence, int *after_std, SPTR sptr)
3537 {
3538 if (!*tested_presence && SCG(sptr) == SC_DUMMY && OPTARGG(sptr)) {
3539 /*
3540 * Have an OPTIONAL INTENT(OUT) argument; need to
3541 * guard the initialization with "if (PRESENT(...))"
3542 */
3543 int present, aif;
3544 (void)sym_mkfunc_nodesc(mkRteRtnNm(RTE_present), stb.user.dt_log);
3545 present = ast_intr(I_PRESENT, stb.user.dt_log, 1, mk_id(sptr));
3546 aif = mk_stmt(A_IFTHEN, 0);
3547 A_IFEXPRP(aif, present);
3548 *after_std = add_stmt_after(aif, *after_std);
3549 *tested_presence = TRUE;
3550 }
3551 }
3552
3553 void
init_derived_type(SPTR sptr,int parent_ast,int wherestd)3554 init_derived_type(SPTR sptr, int parent_ast, int wherestd)
3555 {
3556 DTYPE dtype = DTYPEG(sptr);
3557 SPTR tagsptr;
3558
3559 if (is_array_dtype(dtype))
3560 dtype = array_element_dtype(dtype);
3561 tagsptr = get_struct_tag_sptr(dtype);
3562 if (tagsptr > NOSYM) {
3563 int std = wherestd;
3564 LOGICAL need_ENDIF = FALSE;
3565 int new_ast = 0;
3566
3567 if (SCG(sptr) == SC_DUMMY &&
3568 !ALLOCATTRG(sptr) &&
3569 (ALLOCFLDG(tagsptr) || allocatable_member(tagsptr)) &&
3570 !RESULTG(sptr) &&
3571 FVALG(gbl.currsub) != sptr) {
3572 presence_test(&need_ENDIF, &std, sptr);
3573 std = gen_dealloc_for_sym(sptr, std);
3574 }
3575
3576 if (CLASSG(sptr)) {
3577 int descr_ast = find_descriptor_ast(sptr, parent_ast);
3578 if (descr_ast <= 0) {
3579 SPTR desc_sptr = get_static_type_descriptor(sptr);
3580 if (desc_sptr > NOSYM)
3581 descr_ast = mk_id(desc_sptr);
3582 }
3583 if (descr_ast > 0) {
3584 int func_ast = mk_id(sym_mkfunc_nodesc(mkRteRtnNm(RTE_init_from_desc),
3585 DT_NONE));
3586 int argt = mk_argt(3);
3587 new_ast = mk_func_node(A_CALL, func_ast, 3, argt);
3588 ARGT_ARG(argt, 0) = mk_id(sptr);
3589 ARGT_ARG(argt, 1) = descr_ast;
3590 ARGT_ARG(argt, 2) =
3591 mk_unop(OP_VAL, mk_cval(rank_of_sym(sptr), DT_INT4), DT_INT4);
3592 }
3593 }
3594
3595 if (new_ast == 0) {
3596 /* Not using RTE_init_from_desc; initialize via prototype assignment */
3597 SPTR prototype = get_dtype_init_template(dtype);
3598 if (prototype > NOSYM)
3599 new_ast = mk_assn_stmt(mk_id(sptr), mk_id(prototype), dtype);
3600 }
3601
3602 if (new_ast > 0) {
3603 presence_test(&need_ENDIF, &std, sptr);
3604 std = add_stmt_after(new_ast, std);
3605 }
3606 if (need_ENDIF)
3607 add_stmt_after(mk_stmt(A_ENDIF, 0), std);
3608 }
3609 }
3610
3611 /*------------------------------------------------------------------*/
3612
rw_semant_state(RW_ROUTINE,RW_FILE)3613 void rw_semant_state(RW_ROUTINE, RW_FILE)
3614 {
3615 int nw;
3616
3617 RW_SCALAR(sem.none_implicit);
3618 symutl.none_implicit = sem.none_implicit;
3619 RW_SCALAR(stb.curr_scope);
3620 RW_SCALAR(sem.scope_level);
3621 if (!sem.scope_stack) {
3622 fseek(fd, sizeof(SCOPESTACK) * (sem.scope_level + 1), 1);
3623 } else {
3624 if (ISREAD()) {
3625 NEED(sem.scope_level + 1, sem.scope_stack, SCOPESTACK, sem.scope_size,
3626 sem.scope_level + 10);
3627 }
3628 RW_FD(sem.scope_stack, SCOPESTACK, sem.scope_level + 1);
3629 }
3630 RW_SCALAR(sem.eqvlist);
3631 RW_SCALAR(sem.eqv_avail);
3632 if (sem.eqvlist > 0) {
3633 if (ISREAD()) {
3634 NEED(sem.eqv_avail, sem.eqv_base, EQVV, sem.eqv_size, sem.eqv_avail + 50);
3635 }
3636 RW_FD(sem.eqv_base, EQVV, sem.eqv_avail);
3637 }
3638 RW_SCALAR(sem.eqv_ss_avail);
3639 if (sem.eqv_ss_avail > 1) {
3640 if (ISREAD()) {
3641 NEED(sem.eqv_ss_avail, sem.eqv_ss_base, int, sem.eqv_ss_size,
3642 sem.eqv_ss_avail + 50);
3643 }
3644 RW_FD(sem.eqv_ss_base, int, sem.eqv_ss_avail);
3645 }
3646 }
3647