1 /*
2 * Copyright (c) 1994-2019, NVIDIA CORPORATION. All rights reserved.
3 *
4 * Licensed under the Apache License, Version 2.0 (the "License");
5 * you may not use this file except in compliance with the License.
6 * You may obtain a copy of the License at
7 *
8 * http://www.apache.org/licenses/LICENSE-2.0
9 *
10 * Unless required by applicable law or agreed to in writing, software
11 * distributed under the License is distributed on an "AS IS" BASIS,
12 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13 * See the License for the specific language governing permissions and
14 * limitations under the License.
15 *
16 */
17
18 /**
19 \file
20 \brief Process data initialization statements. Called by semant.
21 */
22
23 #include "gbldefs.h"
24 #include "global.h"
25 #include "error.h"
26 #include "symtab.h"
27 #include "symutl.h"
28 #include "dtypeutl.h"
29 #include "semant.h"
30 #include "semstk.h"
31 #include "dinit.h"
32 #include "ast.h"
33 #include "state.h"
34 #include "pd.h"
35
36 static int chk_doindex(int);
37 extern void dmp_ivl(VAR *, FILE *);
38 extern void dmp_ict(ACL *, FILE *);
39 static char *acl_idname(int);
40 static char *ac_opname(int);
41 static void dinit_data(VAR *, ACL *, int);
42 static ISZ_T arrayref_size(ACL *);
43 static void mark_dinit(VAR *, ACL *);
44 static void dinit_acl_val(int, int, ACL *);
45 static void dinit_intr_call(int, int, ACL *);
46 static void dinit_subs(ACL *);
47 static int dinit_val(int, int, int, int, int);
48 static int dinit_hollerith(int, int, int);
49 static void find_base(int, int *, int *);
50 static void sym_is_dinitd(int);
51
52 static LOGICAL no_dinitp = FALSE;
53
54 #define ERR170(s1, s2) error(170, 2, gbl.lineno, s1, s2)
55
56 /**
57 Instead of creating dinit records during the processing of data
58 initializations, we need to save information so the records are written
59 at the end of semantic analysis (during semfin). This is necessary for
60 at least a couple of reasons: 1). a record dcl with inits in its STRUCTURE
61 could occur before resolution of its storage class (problematic is
62 SC_CMBLK) 2). with VMS ftn, an array may be initialized (not by implied
63 DO) before resolution of its stype (i.e., its DIMENSION).
64
65 The information we need to save is the pointers to the var list and
66 constant tree. This also implies that the getitem areas
67 (4, 5) need to stay around until dinit output.
68 */
69 void
dinit(VAR * ivl,ACL * ict)70 dinit(VAR *ivl, ACL *ict)
71 {
72 int nw;
73 char *ptr;
74
75 if (astb.df == NULL) {
76 if ((astb.df = tmpf("b")) == NULL)
77 errfatal(5);
78 sem.dinit_nbr_inits = 0;
79 }
80 nw = fwrite(&gbl.lineno, sizeof(gbl.lineno), 1, astb.df);
81 if (nw != 1)
82 error(10, 40, 0, "(data init file)", CNULL);
83 nw = fwrite(&gbl.findex, sizeof(gbl.findex), 1, astb.df);
84 if (nw != 1)
85 error(10, 40, 0, "(data init file)", CNULL);
86 ptr = (char *)ivl;
87 nw = fwrite(&ptr, sizeof(ivl), 1, astb.df);
88 if (nw != 1)
89 error(10, 40, 0, "(data init file)", CNULL);
90 ptr = (char *)ict;
91 nw = fwrite(&ptr, sizeof(ict), 1, astb.df);
92 if (nw != 1)
93 error(10, 40, 0, "(data init file)", CNULL);
94
95 if (ivl && ivl->u.varref.id == S_IDENT &&
96 (STYPEG(A_SPTRG(ivl->u.varref.ptr)) == ST_PARAM ||
97 PARAMG(A_SPTRG(ivl->u.varref.ptr)))) {
98 sem.dinit_nbr_inits++;
99 }
100 mark_dinit(ivl, ict);
101 }
102
103 /** \brief Read in the information a "record" (1 word, 2 pointers) at a time
104 saved by dinit(), and write dinit records for each record.
105 */
106 void
do_dinit(void)107 do_dinit(void)
108 {
109 VAR *ivl;
110 ACL *ict;
111 char *ptr;
112 int nw;
113 int fileno;
114
115 if (astb.df == NULL)
116 return;
117 nw = fseek(astb.df, 0L, 0);
118 #if DEBUG
119 assert(nw == 0, "do_dinit:bad rewind", nw, 4);
120 #endif
121
122 while (TRUE) {
123 nw = fread(&gbl.lineno, sizeof(gbl.lineno), 1, astb.df);
124 if (nw == 0)
125 break;
126 #if DEBUG
127 assert(nw == 1, "do_dinit: lineno error", nw, 4);
128 #endif
129 /* Don't use gbl.findex here because we don't want its value to change */
130 nw = fread(&fileno, sizeof(fileno), 1, astb.df);
131 if (nw == 0)
132 break;
133 #if DEBUG
134 assert(nw == 1, "do_dinit: fileno error", nw, 4);
135 #endif
136
137 nw = fread(&ptr, sizeof(ivl), 1, astb.df);
138 if (nw == 0)
139 break;
140 #if DEBUG
141 assert(nw == 1, "do_dinit: ict error", nw, 4);
142 #endif
143 ivl = (VAR *)ptr;
144 nw = fread(&ptr, sizeof(ict), 1, astb.df);
145 #if DEBUG
146 assert(nw == 1, "do_dinit: ivl error", nw, 4);
147 #endif
148 ict = (ACL *)ptr;
149 #if DEBUG
150 if (DBGBIT(6, 32)) {
151 fprintf(gbl.dbgfil, "---- deferred dinit read: ivl %p, ict %p\n",
152 (void *)ivl, (void *)ict);
153 }
154 #endif
155 if (ict && ict->no_dinitp)
156 no_dinitp = TRUE;
157 df_dinit(ivl, ict);
158 no_dinitp = FALSE;
159 }
160
161 if (gbl.maxsev >= 3) {
162 /* since errors occur during semant, print_stmts() will not
163 * be called; need to clean up the ast dinit file stuff.
164 */
165 fclose(astb.df);
166 astb.df = NULL;
167 /* freearea(15); */ /* saved dinit records & equivalence lists */
168 }
169
170 }
171
172 void
dinit_no_dinitp(VAR * ivl,ACL * ict)173 dinit_no_dinitp(VAR *ivl, ACL *ict)
174 {
175 no_dinitp = TRUE;
176 ict->no_dinitp = 1;
177 dinit(ivl, ict);
178 no_dinitp = FALSE;
179 }
180
181 void
df_dinit_end()182 df_dinit_end()
183 {
184 if (astb.df)
185 fclose(astb.df);
186 astb.df = NULL;
187 } /* df_dinit_end */
188
189 /**
190 \param ivl pointer to initializer variable list
191 \param ict pointer to initializer constant tree
192 */
193 void
df_dinit(VAR * ivl,ACL * ict)194 df_dinit(VAR *ivl, ACL *ict)
195 {
196 if (DBGBIT(6, 3)) {
197 fprintf(gbl.dbgfil, "\nDINIT CALLED ----------------\n");
198 if (DBGBIT(6, 2)) {
199 if (ivl) {
200 fprintf(gbl.dbgfil, " Dinit Variable List:\n");
201 dmp_ivl(ivl, gbl.dbgfil);
202 }
203 if (ict) {
204 fprintf(gbl.dbgfil, " Dinit Constant List:\n");
205 dmp_ict(ict, gbl.dbgfil);
206 }
207 }
208 if (DBGBIT(6, 1))
209 fprintf(gbl.dbgfil, "\n DINIT Records:\n");
210 }
211
212 if (ivl) {
213 sem.top = &sem.dostack[0];
214 dinit_data(ivl, ict, 0); /* Process DATA statements */
215 } else {
216 sym_is_dinitd((int)ict->sptr);
217 dinit_subs(ict); /* Process type dcl inits and */
218 } /* init'ed structures */
219
220 if (DBGBIT(6, 3))
221 fprintf(gbl.dbgfil, "\nDINIT RETURNING ----------------\n\n");
222 }
223
224 static void
dinit_data(VAR * ivl,ACL * ict,int dtype)225 dinit_data(VAR *ivl, ACL *ict, int dtype)
226 {
227 /* ivl : pointer to initializer variable list */
228 /* ict : pointer to initializer constant tree */
229 /* dtype : if this is a structure initialization, the ptr to dtype */
230
231 int sptr, memptr;
232 INT num_elem = 0;
233 INT ict_rc = 0;
234 LOGICAL is_array;
235 int member = 0;
236 int substr_dtype;
237
238 if (ivl == NULL) {
239 assert(dtype, "dinit_data: no object to initialize", 0, 2);
240 member = DTY(dtype + 1);
241 /* for derived type extension */
242 if (PARENTG(DTY(dtype + 3)) && get_seen_contains()
243 && (DTY(DTYPEG(member)) == TY_DERIVED)
244 && (DTY(ict->dtype) != TY_DERIVED)) {
245 member = SYMLKG(member);
246 }
247 }
248
249 do {
250 substr_dtype = 0;
251 if (member && (is_empty_typedef(DTYPEG(member)) ||
252 is_tbp_or_final(member))) {
253 memptr = SYMLKG(member);
254 member = memptr == NOSYM ? 0 : memptr;
255 continue;
256 }
257 if ((ivl && ivl->id == Varref) || member) {
258 is_array = FALSE;
259 num_elem = 1;
260 if (member) {
261 memptr = sptr = member;
262 if (!POINTERG(sptr) && !ALLOCATTRG(sptr) &&
263 DTY(DTYPEG(sptr)) == TY_ARRAY) {
264 /* A whole array; determine number of elements to init */
265 if (size_of_array(DTYPEG(sptr)))
266 num_elem = get_int_cval(sym_of_ast(AD_NUMELM(AD_PTR(sptr))));
267 else
268 num_elem = 0;
269 is_array = TRUE;
270 }
271 } else {
272 int ast = ivl->u.varref.ptr;
273
274 find_base(ast, &sptr, &memptr);
275 if (sem.dinit_error)
276 goto error_exit;
277 if (A_TYPEG(ast) == A_ID || A_TYPEG(ast) == A_MEM) {
278 /* We're initialising a scalar or whole array,
279 * which may or may not be a derived type component.
280 * (N.B. The derived type case may be an A_ID or
281 * A_MEM node, depending on the value of DTF90OUTPUT.
282 * In the former case, memptr == sptr.)
283 */
284 if (!POINTERG(sptr) && DTY(DTYPEG(memptr)) == TY_ARRAY) {
285 /* A whole array */
286 if (size_of_array(DTYPEG(memptr)))
287 num_elem = get_int_cval(sym_of_ast(AD_NUMELM(AD_PTR(memptr))));
288 else
289 num_elem = 0;
290 is_array = TRUE;
291 }
292 } else if (A_TYPEG(ast) == A_SUBSTR) {
293 ISZ_T len;
294 int s;
295 s = A_SPTRG(A_ALIASG(A_RIGHTG(ast)));
296 if (s)
297 len = get_isz_cval(s);
298 else
299 len = string_length(DDTG(DTYPEG(memptr)));
300 s = A_SPTRG(A_ALIASG(A_LEFTG(ast)));
301 if (s)
302 len = len - get_isz_cval(s) + 1;
303 if (len < 0)
304 len = 1;
305 substr_dtype = get_type(2, DTY(A_DTYPEG(ast)), mk_cval(len, DT_INT4));
306 } else {
307 /* We're initialising an array element or section,
308 */
309 if (ivl->u.varref.shape != 0)
310 uf("- initializing an array section");
311 }
312 }
313
314 sym_is_dinitd(sptr);
315
316 /* now process enough dinit constant list items to
317 * take care of the current varref item. For a Cray target,
318 * a Hollerith constant may initialize more than one array
319 * element.
320 */
321 do {
322 if (ict_rc == 0) {
323 if (ict == NULL) {
324 if (is_array && XBIT(49, 0x1040000)) {
325 /* T3D/T3E or C90 target: the number of initializers
326 * may be less than the number of elements
327 */
328 if (flg.standard)
329 ERR170("The number of initializers is less than number of "
330 "elements of",
331 SYMNAME(memptr));
332 break;
333 }
334 errsev(66);
335 goto error_exit;
336 }
337 ict_rc = dinit_eval(ict->repeatc);
338 }
339 if (ict_rc > 0) {
340 /* Note: repeat factor ict_rc == 0 is allowed! */
341 int ni; /* number of elements consumed by a constant */
342
343 ni = 1;
344 if (ivl && DTY(ivl->u.varref.dtype) == TY_DERIVED && !POINTERG(sptr))
345 dinit_data(ivl->u.varref.subt, ict->subc, ict->dtype);
346 else if (member && DTY(ict->dtype) == TY_DERIVED && !POINTERG(sptr))
347 if (ict->subc) {
348 /* derived type member-by-memeber initialization */
349 dinit_data(NULL, ict->subc, ict->dtype);
350 } else {
351 /* derived type initialized by a named constant */
352 dinit_acl_val(member, ict->dtype, ict);
353 return;
354 }
355 else if (is_array && ict->dtype == DT_HOLL)
356 ni = dinit_hollerith(sptr, DDTG(DTYPEG(memptr)),
357 A_SPTRG(A_ALIASG(ict->u1.ast)));
358 else if (is_array) {
359 if (ict->id == AC_IEXPR) {
360 if (DTY(ict->dtype) == TY_ARRAY) {
361 if (ict->u1.expr->op == AC_ARRAYREF) {
362 ni = arrayref_size(ict->u1.expr->rop);
363 } else {
364 ni = dinit_eval(ADD_NUMELM(ict->dtype));
365 }
366 dinit_acl_val(sptr, DDTG(DTYPEG(memptr)), ict);
367 } else {
368 dinit_acl_val(sptr, DTYPEG(memptr), ict);
369 }
370 } else if (ict->id == AC_ACONST) {
371 ACL *subict;
372 /* MORE most of these calls to dinit_eval should be calls to
373 * get_int_cval, dinit_eval is
374 * for evaluating implied so expressions only */
375 ni = dinit_eval(ADD_NUMELM(ict->dtype));
376 dinit_acl_val(sptr, DTYPEG(sptr), ict);
377 } else {
378 /* AC_AST, either a constant or a named constant */
379 if (DTY(ict->dtype) == TY_ARRAY) {
380 ni = dinit_eval(ADD_NUMELM(ict->dtype));
381 }
382 (void)dinit_val(sptr, DDTG(DTYPEG(memptr)), ict->dtype,
383 ict->u1.ast, 0);
384 }
385 } else if (substr_dtype) {
386 dinit_acl_val(sptr, substr_dtype, ict);
387 } else {
388 /* Could be Superfluous ict if POINTER is set:
389 * dinit_acl_val() will catch!
390 */
391 dinit_acl_val(sptr, DDTG(DTYPEG(memptr)), ict);
392 }
393
394 switch (ni) {
395 case 1:
396 ni = (ict_rc < num_elem) ? ict_rc : num_elem;
397 num_elem -= ni;
398 ict_rc -= ni;
399 break;
400 default:
401 num_elem -= ni;
402 ict_rc--;
403 break;
404 }
405 }
406 if (ict_rc == 0)
407 ict = ict->next;
408 } while (num_elem > 0);
409 if (num_elem < 0)
410 errsev(67);
411 } else if (ivl->id == Dostart) {
412 if (sem.top == &sem.dostack[MAX_DOSTACK]) {
413 /* nesting maximum exceeded. */
414 errsev(34);
415 return;
416 }
417 sem.top->sptr = chk_doindex(ivl->u.dostart.indvar);
418 if (sem.top->sptr == 1)
419 return;
420 sem.top->currval = dinit_eval(ivl->u.dostart.lowbd);
421 sem.top->upbd = dinit_eval(ivl->u.dostart.upbd);
422 sem.top->step = dinit_eval(ivl->u.dostart.step);
423 if ((sem.top->step > 0 && sem.top->currval <= sem.top->upbd) ||
424 (sem.top->step <= 0 && sem.top->currval >= sem.top->upbd))
425 ++sem.top;
426 else {
427 /* A 'zero trip' implied DO loop. Go directly to the
428 corresponding 'Doend' node */
429 int depth;
430
431 depth = 1;
432 do {
433 ivl = ivl->next;
434 if (!ivl)
435 break;
436 switch (ivl->id) {
437 case Dostart:
438 ++depth;
439 break;
440 case Doend:
441 --depth;
442 break;
443 }
444 } while (depth);
445 }
446 } else {
447 assert(ivl->id == Doend, "dinit:badid", 0, 3);
448 --sem.top;
449 sem.top->currval += sem.top->step;
450 if ((sem.top->step > 0 && sem.top->currval <= sem.top->upbd) ||
451 (sem.top->step <= 0 && sem.top->currval >= sem.top->upbd)) {
452 /* go back to start of this do loop */
453 ++sem.top;
454 ivl = ivl->u.doend.dostart;
455 }
456 }
457 if (sem.dinit_error)
458 goto error_exit;
459 if (ivl)
460 ivl = ivl->next;
461 if (member) {
462 if (POINTERG(member) || ALLOCATTRG(member))
463 member = SYMLKG(member); // skip <ptr>$p
464 memptr = SYMLKG(member);
465 member = memptr == NOSYM ? 0 : memptr;
466 }
467 } while (ivl || member);
468
469 while (ict && num_elem > 0) {
470 /* Some dinit constants remain. That's OK if they have 0
471 * repeat factor, otherwise it's an error. */
472 if (ict_rc == 0)
473 ict_rc = dinit_eval(ict->repeatc);
474 if (ict_rc == 0)
475 ict = ict->next;
476 else {
477 errsev(67);
478 goto error_exit;
479 }
480 }
481 error_exit:
482 return;
483 }
484
485 /*
486 * compute the size of an arrayref (a section). The section information is
487 * created by semant and consists of a list of ACL items of the form:
488 * subscr_ast <-(lop) [array_ref] (rop)-> lb -> ub -> stride, ...
489 * repeated for the remaining dimensions.
490 * Each ACL contains an const AST representing the value of the bounds/stride.
491 */
492 static ISZ_T
arrayref_size(ACL * sect)493 arrayref_size(ACL *sect)
494 {
495 ACL *c, *t;
496 ISZ_T size, nelem;
497 ISZ_T lowb, upb, stride;
498
499 size = 1;
500 t = sect;
501 do {
502 if (t == 0) {
503 interr("dinit: arrayref: missing subscript array \n", 0, 3);
504 return 1;
505 }
506
507 c = t->u1.expr->rop;
508
509 if (c == 0) {
510 interr("dinit: arrayref: missing array section lb\n", 0, 3);
511 return 1;
512 }
513 lowb = get_isz_cval(A_SPTRG(c->u1.ast));
514
515 if ((c = c->next) == 0) {
516 interr("dinit: arrayref: missing array section ub\n", 0, 3);
517 return 1;
518 }
519 upb = get_isz_cval(A_SPTRG(c->u1.ast));
520
521 if ((c = c->next) == 0) {
522 interr("dinit: arrayref: missing array section stride\n", 0, 3);
523 return 1;
524 }
525 stride = get_isz_cval(A_SPTRG(c->u1.ast));
526
527 if (stride < 0)
528 nelem = (lowb - upb + (-stride)) / (-stride);
529 else if (stride != 0)
530 nelem = (upb - lowb + stride) / stride;
531 else
532 interr("dinit: arrayref: array section stride is 0\n", 0, 3);
533 if (nelem > 0)
534 size *= nelem;
535 else
536 size = 0;
537 t = t->next;
538 } while (t);
539 return size;
540 }
541
542 /*---------------------------------------------------------------*/
543
544 /* pointer to initializer constant tree */
545 static void
dinit_subs(ACL * ict)546 dinit_subs(ACL *ict)
547 {
548 int sptr; /* symbol ptr to identifier to get initialized */
549 int i;
550
551 /*
552 * We come into this routine to follow the ict links for a substructure.
553 */
554 while (ict) {
555 switch (ict->id) {
556 case AC_TYPEINIT:
557 dinit_subs(ict->subc);
558 break;
559 case AC_IDENT:
560 case AC_CONST:
561 case AC_IEXPR:
562 case AC_AST:
563 case AC_IDO:
564 case AC_ACONST:
565 case AC_SCONST:
566 case AC_EXPR:
567 case AC_REPEAT:
568 dinit_acl_val(ict->sptr, DDTG(ict->dtype), ict);
569 break;
570 default:
571 if (ict->subc) {
572 /* Follow substructure down before continuing at this level */
573 for (i = dinit_eval(ict->repeatc); i != 0; i--)
574 dinit_subs(ict->subc);
575 } else {
576 /* Handle basic type declaration init statement */
577 /* If new member or member has a repeat start a new block */
578 if (ict->sptr) {
579 /* A new member to initialize */
580 sptr = ict->sptr;
581 }
582 (void)dinit_val(sptr, DDTG(DTYPEG(sptr)), ict->dtype, ict->u1.ast, 0);
583 }
584 }
585 ict = ict->next;
586 } /* End of while */
587 }
588
589 static void
setConval(int sptr,int conval,int op)590 setConval(int sptr, int conval, int op)
591 {
592 if (conval && !PARMFING(sptr)) {
593 int val = PARMINITG(sptr);
594 switch (op) {
595 case AC_ADD:
596 val += conval;
597 break;
598 case AC_SUB:
599 val -= conval;
600 break;
601 case AC_MUL:
602 val *= conval;
603 break;
604 case AC_DIV:
605 val /= conval;
606 break;
607 case AC_NEG:
608 val = -conval;
609 break;
610 case AC_LNOT:
611 val = ~conval;
612 break;
613 case AC_LOR:
614 val |= conval;
615 break;
616 case AC_LAND:
617 val &= conval;
618 break;
619 case AC_EQ:
620 val = (val == conval) ? -1 : 0;
621 break;
622 case AC_GE:
623 val = (val >= conval) ? -1 : 0;
624 break;
625 case AC_GT:
626 val = (val > conval) ? -1 : 0;
627 break;
628 case AC_LE:
629 val = (val <= conval) ? -1 : 0;
630 break;
631 case AC_LT:
632 val = (val < conval) ? -1 : 0;
633 break;
634 case AC_NE:
635 val = (val != conval) ? -1 : 0;
636 break;
637 case 0:
638 val = conval;
639 break;
640 default:
641 val = conval;
642 error(155, 3, gbl.lineno, "Invalid operator for kind type parameter "
643 "initialization",
644 NULL);
645 }
646 PARMINITP(sptr, val);
647 }
648 }
649
650 static void
process_real_kind(int sptr,ACL * ict,int op)651 process_real_kind(int sptr, ACL *ict, int op)
652 {
653 int ast, con1, conval;
654
655 ast = ict->u1.ast;
656 conval = 0;
657 if (A_TYPEG(ast) == A_CNST) {
658
659 con1 = A_SPTRG(ast);
660 con1 = CONVAL2G(con1);
661 if (con1 <= 6)
662 conval = 4;
663 else if (con1 <= 15)
664 conval = 8;
665 else if (con1 <= 31 && !XBIT(57, 4))
666 conval = 16;
667 else
668 conval = -1;
669 }
670
671 ict = ict->next;
672 if (ict) {
673 ast = ict->u1.ast;
674
675 if (A_TYPEG(ast) == A_CNST) {
676 con1 = A_SPTRG(ast);
677 con1 = CONVAL2G(con1);
678 if (XBIT(49, 0x40000)) {
679 /* Cray C90 */
680 if (con1 <= 37) {
681 if (conval > 0 && conval < 4)
682 conval = 4;
683 } else if (con1 <= 2465) {
684 if (conval > 0 && conval < 8)
685 conval = 8;
686 } else {
687 if (conval > 0)
688 conval = 0;
689 conval -= 2;
690 }
691 } else {
692 /* ANSI */
693 if (con1 <= 37) {
694 if (conval > 0 && conval < 4)
695 conval = 4;
696 } else if (con1 <= 307) {
697 if (conval > 0 && conval < 8)
698 conval = 8;
699 } else if (con1 <= 4931 && !XBIT(57, 4)) {
700 if (conval > 0 && conval < 16)
701 conval = 16;
702 } else {
703 if (conval > 0)
704 conval = 0;
705 conval -= 2;
706 }
707 }
708 }
709 }
710 if (conval) {
711 setConval(sptr, conval, op);
712 }
713 }
714
715 static void
dinit_acl_val2(int sptr,int dtype,ACL * ict,int op)716 dinit_acl_val2(int sptr, int dtype, ACL *ict, int op)
717 {
718 int dvl_val = 0;
719
720 if (ict->id == AC_IEXPR) {
721 switch (ict->u1.expr->op) {
722 case AC_LNOT:
723 case AC_NEG:
724 case AC_CONV:
725 dinit_acl_val2(sptr, dtype, ict->u1.expr->lop, 0);
726 break;
727 case AC_ADD:
728 case AC_SUB:
729 case AC_MUL:
730 case AC_DIV:
731 case AC_EXP:
732 case AC_LOR:
733 case AC_LAND:
734 case AC_LEQV:
735 case AC_LNEQV:
736 case AC_EQ:
737 case AC_GE:
738 case AC_GT:
739 case AC_LE:
740 case AC_LT:
741 case AC_NE:
742 dinit_acl_val2(sptr, dtype, ict->u1.expr->lop, ict->u1.expr->op);
743 dinit_acl_val2(sptr, dtype, ict->u1.expr->rop, ict->u1.expr->op);
744 break;
745 case AC_ARRAYREF:
746 if (!cmpat_dtype_with_size(dtype, ict->dtype)) {
747 errsev(91);
748 }
749 break;
750 case AC_MEMBR_SEL:
751 if (!cmpat_dtype_with_size(dtype, ict->dtype)) {
752 errsev(91);
753 }
754 break;
755 case AC_INTR_CALL:
756 if (ict->id == AC_IEXPR) {
757 ACL *subict = ict->u1.expr->rop;
758 int intr = ict->u1.expr->lop->u1.i;
759 int conval, con1, ast;
760 if (subict && subict->id == AC_AST) {
761 conval = 0;
762 switch (intr) {
763 case AC_I_selected_int_kind:
764 ast = subict->u1.ast;
765 if (A_TYPEG(ast) == A_CNST) {
766 con1 = CONVAL2G(A_SPTRG(ast));
767 conval = 4;
768 if (con1 > 18 || (con1 > 9 && XBIT(57, 2)))
769 conval = -1;
770 else if (con1 > 9)
771 conval = 8;
772 else if (con1 > 4)
773 conval = 4;
774 else if (con1 > 2)
775 conval = 2;
776 else
777 conval = 1;
778 }
779 setConval(sptr, conval, op);
780 break;
781 case AC_I_selected_real_kind:
782 process_real_kind(sptr, subict, op);
783 break;
784 }
785 case AC_I_selected_char_kind:
786 ast = subict->u1.ast;
787 if (A_TYPEG(ast) == A_CNST) {
788 int dty;
789 con1 = A_SPTRG(ast);
790 dty = DTY(DTYPEG(con1));
791 if (dty == TY_CHAR || dty == TY_NCHAR)
792 conval = _selected_char_kind(con1);
793 else
794 break;
795 }
796 setConval(sptr, conval, op);
797 break;
798 default:
799 error(155, 3, gbl.lineno,
800 "Invalid initialization of kind type parameter", SYMNAME(sptr));
801 }
802 }
803 dinit_intr_call(sptr, dtype, ict);
804 break;
805 }
806 } else if (ict->id == AC_ACONST) {
807 ACL *subict;
808 int list_dtype;
809 if (!cmpat_dtype_with_size(dtype, ict->dtype)) {
810 errsev(91);
811 }
812 subict = ict->subc;
813 list_dtype = subict->dtype;
814 if (!cmpat_dtype_with_size(DDTG(dtype), DDTG(ict->dtype))) {
815 errsev(91);
816 }
817 } else if (ict->id == AC_IDO) {
818 dinit_acl_val2(sptr, dtype, ict->subc, 0);
819 } else if (ict->id == AC_AST) {
820 /*
821 * Superfluous ict if POINTER is set; would be better if we
822 * didn't generate the entry, but ss a hack, just ignore it.
823 */
824 if (!POINTERG(sptr))
825 dvl_val =
826 dinit_val(sptr, dtype, DDTG(A_DTYPEG(ict->u1.ast)), ict->u1.ast, op);
827
828 if (STYPEG(sptr) == ST_MEMBER && KINDG(sptr) && !USEKINDG(sptr) &&
829 A_TYPEG(ict->u1.ast) == A_CNST) {
830 int val = CONVAL2G(A_SPTRG(ict->u1.ast));
831 setConval(sptr, val, op);
832 }
833
834 } else if (ict->id == AC_IDENT || ict->id == AC_CONST) {
835 dvl_val =
836 dinit_val(sptr, dtype, DDTG(A_DTYPEG(ict->u1.ast)), ict->u1.ast, op);
837 }
838 if (!XBIT(7, 0x100000)) {
839 if (flg.opt >= 2 && sptr && STYPEG(sptr) == ST_VAR &&
840 SCG(sptr) == SC_LOCAL && !ARGG(sptr) && !ASSNG(sptr) && dvl_val) {
841 if (DTY(dtype) == TY_CHAR) {
842 if (sptr && DTYPEG(sptr) != dtype)
843 return;
844 if (string_length(dtype) != string_length(DDTG(A_DTYPEG(ict->u1.ast))))
845 return;
846 } else if (DTY(dtype) == TY_NCHAR) {
847 if (sptr && DTYPEG(sptr) != dtype)
848 return;
849 if (string_length(dtype) != string_length(DDTG(A_DTYPEG(ict->u1.ast))))
850 return;
851 }
852 NEED(aux.dvl_avl + 1, aux.dvl_base, DVL, aux.dvl_size, aux.dvl_size + 32);
853 DVL_SPTR(aux.dvl_avl) = sptr;
854 DVL_CONVAL(aux.dvl_avl) = dvl_val;
855 aux.dvl_avl++;
856 }
857 }
858 }
859
860 static void
dinit_acl_val(int sptr,int dtype,ACL * ict)861 dinit_acl_val(int sptr, int dtype, ACL *ict)
862 {
863
864 dinit_acl_val2(sptr, dtype, ict, 0);
865 if (STYPEG(sptr) == ST_MEMBER && KINDG(sptr) && !USEKINDG(sptr))
866 PARMFINP(sptr, 1);
867 }
868
869 static void
dinit_intr_call(int sptr,int dtype,ACL * ict)870 dinit_intr_call(int sptr, int dtype, ACL *ict)
871 {
872 ACL *aclp, *next_save;
873
874 assert(ict->u1.expr->lop->id == AC_ICONST,
875 "dinit_intr_call: incorrect ACL type for intrinsic selector\n", 0, 4);
876
877 if (ict->u1.expr->lop->u1.i == AC_I_null) {
878 /* Currently handles only NULL() */
879 if (!POINTERG(sptr) && !PTRVG(sptr) && !ALLOCATTRG(sptr)) {
880 errsev(459);
881 }
882 /* HACK: this is the only place before the backend where there is any
883 * linkage between the VAR list and the ACL list (?). Therefore it is
884 * the only place where initialization of a <ptr> object with a NULL()
885 * call can be modified. First change the intrinsic call to a constant
886 * zero initialization. Then, if <ptr> is a derived type member, add
887 * constant zeros to the ACL list to initialize any associated <ptr>$o,
888 * <ptr>$sd, and/or <ptr>$td values that have been added as hidden
889 * members of the type, but skip <ptr>$p values. Processing for
890 * non-derived type pointers is done in lower_pointer_init.
891 */
892
893 ict->id = AC_AST;
894 ict->dtype = DT_PTR; /* may have problems with XBIT(125,0x2000) */
895 if (!ict->ptrdtype) {
896 /* build pointer type for backend upper/dinit */
897 ict->ptrdtype = get_type(2, TY_PTR, DDTG(DTYPEG(sptr)));
898 }
899 if (ict->sptr && (POINTERG(ict->sptr) || ALLOCATTRG(sptr))) {
900 /* use <ptr>$p */
901 ict->sptr = MIDNUMG(sptr);
902 }
903
904 /* If astb.i0 will be changed to something else, it must change in
905 * chk_struct_constructor as well.
906 */
907 ict->u1.ast = astb.i0;
908 ict->is_const = 1;
909
910 if (STYPEG(sptr) != ST_MEMBER)
911 return;
912
913 aclp = ict;
914 next_save = ict->next;
915
916 for (sptr = SYMLKG(SYMLKG(sptr)); HCCSYMG(sptr); sptr = SYMLKG(sptr)) {
917 aclp = aclp->next = GET_ACL(15);
918 aclp->id = AC_AST;
919 aclp->is_const = 1;
920 aclp->dtype = DDTG(DTYPEG(sptr));
921 aclp->u1.ast = aclp->dtype == DT_INT8 ? astb.k0 : astb.i0;
922 if (ict->sptr)
923 aclp->sptr = sptr;
924 if (DTY(DTYPEG(sptr)) == TY_ARRAY)
925 aclp->repeatc = ADD_NUMELM(DTYPEG(sptr));
926 }
927
928 aclp->next = next_save;
929 }
930 }
931
932 /*---------------------------------------------------------------*/
933
934 /* dinit_val - make sure constant value is correct data type to initialize
935 * symbol (sptr) to. Then call dinit_put to generate dinit record.
936 */
937 static int
dinit_val(int sptr,int dtype,int dtypev,int astval,int op)938 dinit_val(int sptr, int dtype, int dtypev, int astval, int op)
939 {
940 INT val;
941 INT newval[2];
942 int newast;
943 char buf[2];
944 int do_dvl = 0;
945
946 if (DTY(dtypev) == TY_DERIVED) {
947 if (!eq_dtype(dtype, dtypev))
948 errsev(91);
949 return 0;
950 }
951 if (A_ALIASG(astval))
952 astval = A_ALIASG(astval);
953
954 if (POINTERG(sptr)) {
955 error(457, 3, gbl.lineno, SYMNAME(sptr), CNULL);
956 return 0;
957 }
958 if (!XBIT(7, 0x100000)) {
959 if (flg.opt >= 2 && sptr && STYPEG(sptr) == ST_VAR &&
960 SCG(sptr) == SC_LOCAL && !ARGG(sptr) && !ASSNG(sptr) &&
961 DTY(DTYPEG(sptr)) != TY_DERIVED && op == 0) {
962 do_dvl = 1;
963 }
964 }
965
966 switch (DTY(A_DTYPEG(astval))) {
967 case TY_DWORD:
968 case TY_DBLE:
969 case TY_CMPLX:
970 case TY_DCMPLX:
971 case TY_CHAR:
972 case TY_NCHAR:
973 case TY_QUAD:
974 case TY_QCMPLX:
975 case TY_INT8:
976 case TY_LOG8:
977 val = A_SPTRG(astval);
978 break;
979 case TY_ARRAY:
980 /*
981 * an array value does not require any special processing and
982 * do not want to let it fall into the CHAR case; the CONVAL1
983 * field of its sptr isn't defined.
984 */
985 return 0;
986 case TY_HOLL:
987 val = CONVAL1G(A_SPTRG(astval));
988 break;
989 default:
990 val = CONVAL2G(A_SPTRG(astval));
991 }
992
993 if (DTYG(dtypev) == TY_HOLL) {
994 /* convert hollerith character string to one of proper length */
995 val = cngcon(val, (int)DTYPEG(val), dtype);
996 if (do_dvl == 1) {
997 switch (dtype) {
998 case TY_DBLE:
999 case TY_INT8:
1000 case TY_LOG8:
1001 case TY_CMPLX:
1002 case TY_DCMPLX:
1003 case TY_QUAD:
1004 case TY_QCMPLX:
1005 newast = mk_cnst(val);
1006 break;
1007 default:
1008 newval[0] = 0;
1009 newval[1] = val;
1010 val = getcon(newval, dtype);
1011 newast = mk_cnst(val);
1012 }
1013 }
1014 } else if (DTYG(dtypev) == TY_CHAR || DTYG(dtypev) == TY_NCHAR ||
1015 DTYG(dtypev) != DTY(dtype)) {
1016 /* check for special case of initing character*1 to numeric. */
1017 if (DTY(dtype) == TY_CHAR && DTY(dtype + 1) == astb.i1) {
1018 if (DT_ISINT(dtypev) && !DT_ISLOG(dtypev)) {
1019 if (flg.standard)
1020 error(172, 2, gbl.lineno, SYMNAME(sptr), CNULL);
1021 if (val < 0 || val > 255) {
1022 error(68, 3, gbl.lineno, SYMNAME(sptr), CNULL);
1023 val = getstring(" ", 1);
1024 } else {
1025 buf[0] = (char)val;
1026 buf[1] = 0;
1027 val = getstring(buf, 1);
1028 }
1029 dtypev = DT_CHAR;
1030 }
1031 }
1032 /* Convert character string to one of proper length or,
1033 * convert constant to type of identifier.
1034 */
1035 val = cngcon(val, dtypev, dtype);
1036 if (do_dvl == 1) {
1037 if (DTYG(dtypev) != DTY(dtype)) {
1038 switch (DTY(dtype)) {
1039 case TY_HOLL:
1040 val = getcon(&val, dtype);
1041 break;
1042 case TY_CHAR:
1043 case TY_NCHAR:
1044 break;
1045 case TY_LOG:
1046 case TY_SLOG:
1047 case TY_BLOG:
1048 case TY_INT:
1049 case TY_SINT:
1050 case TY_BINT:
1051 case TY_WORD:
1052 case TY_FLOAT:
1053 newval[0] = 0;
1054 newval[1] = val;
1055 val = getcon(newval, dtype);
1056 break;
1057 }
1058 newast = mk_cnst(val);
1059 } else {
1060 newast = mk_cnst(val);
1061 }
1062 }
1063 } else if (do_dvl == 1) {
1064 if (DTYG(dtypev) != DTY(dtype))
1065 newast = mk_cnst(val);
1066 else
1067 newast = astval;
1068 }
1069
1070 if (do_dvl == 1 && op == 0) {
1071 return newast;
1072 }
1073 return 0;
1074 }
1075
1076 /*
1077 * A Hollerith constant appears as a data item in the initialization of an
1078 * array. For the certain targets (e.g., Cray), the constant may spill into
1079 * subsequent elements of the array.
1080 */
1081 static int
dinit_hollerith(int sptr,int dtype,int holl_const)1082 dinit_hollerith(int sptr, int dtype, int holl_const)
1083 {
1084 INT val;
1085 int ni; /* number of elements initialized by the constant */
1086
1087 ni = 1; /* default number of initialized elements */
1088
1089 val = CONVAL1G(holl_const); /* associated character constant */
1090
1091 return ni;
1092 }
1093
1094 /*---------------------------------------------------------------*/
1095
1096 /** \brief Dump an initializer variable list to a file (or stderr if no file
1097 provided).
1098 */
1099 void
dmp_ivl(VAR * ivl,FILE * f)1100 dmp_ivl(VAR *ivl, FILE *f)
1101 {
1102 FILE *dfil;
1103 dfil = f ? f : stderr;
1104 while (ivl) {
1105 if (ivl->id == Dostart) {
1106 fprintf(dfil, " Do begin marker (%p):", (void *)ivl);
1107 fprintf(dfil, " indvar: %4d lowbd:%4d", ivl->u.dostart.indvar,
1108 ivl->u.dostart.lowbd);
1109 fprintf(dfil, " upbd:%4d step:%4d\n", ivl->u.dostart.upbd,
1110 ivl->u.dostart.step);
1111 } else if (ivl->id == Varref) {
1112 if (ivl->u.varref.subt) {
1113 fprintf(dfil, " DERIVED TYPE members:\n");
1114 dmp_ivl(ivl->u.varref.subt, dfil);
1115 fprintf(dfil, " end DERIVED TYPE\n");
1116 } else {
1117 fprintf(dfil, " Variable reference (");
1118 if (ivl->u.varref.id == S_IDENT) {
1119 fprintf(dfil, " S_IDENT):");
1120 fprintf(dfil, " sptr: %d(%s)", A_SPTRG(ivl->u.varref.ptr),
1121 A_SPTRG(ivl->u.varref.ptr)
1122 ? SYMNAME(A_SPTRG(ivl->u.varref.ptr))
1123 : "");
1124 fprintf(dfil, " dtype: %4d\n", A_DTYPEG(ivl->u.varref.ptr + 1));
1125 } else {
1126 fprintf(dfil, "S_LVALUE):");
1127 fprintf(dfil, " ast:%4d", ivl->u.varref.ptr);
1128 fprintf(dfil, " shape:%4d\n", ivl->u.varref.shape);
1129 }
1130 }
1131 } else {
1132 assert(ivl->id == Doend, "dmp_ivl: badid", 0, 3);
1133 fprintf(dfil, " Do end marker:");
1134 fprintf(dfil, " Pointer to Do Begin: %p\n",
1135 (void *)(ivl->u.doend.dostart));
1136 }
1137 ivl = ivl->next;
1138 }
1139 }
1140
1141 /** \brief Dump an initializer constant tree to a file (dfil==0 --> stderr).
1142 */
1143 void
dmp_ict(ACL * ict,FILE * dfil)1144 dmp_ict(ACL *ict, FILE *dfil)
1145 {
1146 static int level = 0;
1147 int i;
1148
1149 if (!dfil)
1150 dfil = stderr;
1151
1152 for (; ict; ict = ict->next) {
1153 for (i = level; i > 0; --i)
1154 fprintf(dfil, " ");
1155
1156 fprintf(dfil, "%p(%s):", (void *)ict, acl_idname(ict->id));
1157 if (ict->subc) {
1158 fprintf(dfil, " subc:%p", ict->subc);
1159 if (ict->sptr) {
1160 fprintf(dfil, " sptr:%d", ict->sptr);
1161 fprintf(dfil, "(%s)", SYMNAME(ict->sptr));
1162 }
1163 if (ict->repeatc)
1164 fprintf(dfil, " rc:%d", ict->repeatc);
1165 fprintf(dfil, " next:%p\n", (void *)(ict->next));
1166 ++level; dmp_ict(ict->subc, dfil);
1167 } else {
1168 if (ict->u1.ast)
1169 switch (ict->id) {
1170 case AC_EXPR: fprintf(dfil, " stkp:%p", ict->u1.stkp); break;
1171 case AC_IEXPR: fprintf(dfil, " expr:%p", ict->u1.expr); break;
1172 case AC_AST:
1173 case AC_CONST:
1174 case AC_IDENT: fprintf(dfil, " ast:%d", ict->u1.ast); break;
1175 case AC_ICONST: fprintf(dfil, " iconst:%d", ict->u1.i); break;
1176 case AC_REPEAT: fprintf(dfil, " count:%d", ict->u1.count); break;
1177 case AC_IDO: fprintf(dfil, " doinfo:%p", ict->u1.doinfo); break;
1178 default: fprintf(dfil, " <u1>:%d", ict->u1.i);
1179 }
1180 if (ict->dtype)
1181 fprintf(dfil, " dtype:%d", ict->dtype);
1182 if (ict->repeatc)
1183 fprintf(dfil, " rc:%d", ict->repeatc);
1184 if (ict->sptr) {
1185 fprintf(dfil, " sptr:%d", ict->sptr);
1186 fprintf(dfil, "(%s)", SYMNAME(ict->sptr));
1187 }
1188 fprintf(dfil, " next:%p\n", (void *)(ict->next));
1189 }
1190
1191 if (ict->id == AC_IEXPR) {
1192 fprintf(dfil, " lop:%p <OP %s> rop:%p\n", ict->u1.expr->lop,
1193 ac_opname(ict->u1.expr->op), ict->u1.expr->rop);
1194 ++level; dmp_ict(ict->u1.expr->lop, dfil);
1195 if (ict->u1.expr->rop) {
1196 ++level; dmp_ict(ict->u1.expr->rop, dfil);
1197 }
1198 }
1199 }
1200
1201 if (level > 0)
1202 --level;
1203 }
1204
1205 static char *
acl_idname(int id)1206 acl_idname(int id)
1207 {
1208 static char bf[32];
1209 switch (id) {
1210 case AC_IDENT:
1211 strcpy(bf, "IDENT");
1212 break;
1213 case AC_CONST:
1214 strcpy(bf, "CONST");
1215 break;
1216 case AC_EXPR:
1217 strcpy(bf, "EXPR");
1218 break;
1219 case AC_IEXPR:
1220 strcpy(bf, "IEXPR");
1221 break;
1222 case AC_AST:
1223 strcpy(bf, "AST");
1224 break;
1225 case AC_IDO:
1226 strcpy(bf, "IDO");
1227 break;
1228 case AC_REPEAT:
1229 strcpy(bf, "REPEAT");
1230 break;
1231 case AC_ACONST:
1232 strcpy(bf, "ACONST");
1233 break;
1234 case AC_SCONST:
1235 strcpy(bf, "SCONST");
1236 break;
1237 case AC_LIST:
1238 strcpy(bf, "LIST");
1239 break;
1240 case AC_VMSSTRUCT:
1241 strcpy(bf, "VMSSTRUCT");
1242 break;
1243 case AC_VMSUNION:
1244 strcpy(bf, "VMSUNION");
1245 break;
1246 case AC_TYPEINIT:
1247 strcpy(bf, "TYPEINIT");
1248 break;
1249 case AC_ICONST:
1250 strcpy(bf, "ICONST");
1251 break;
1252 case AC_CONVAL:
1253 strcpy(bf, "CONVAL");
1254 break;
1255 case AC_TRIPLE:
1256 strcpy(bf, "TRIPLE");
1257 break;
1258 default:
1259 sprintf(bf, "UNK_%d", id);
1260 break;
1261 }
1262 return bf;
1263 }
1264
1265 static char *
ac_opname(int id)1266 ac_opname(int id)
1267 {
1268 static char bf[32];
1269 switch (id) {
1270 case AC_ADD:
1271 strcpy(bf, "ADD");
1272 break;
1273 case AC_SUB:
1274 strcpy(bf, "SUB");
1275 break;
1276 case AC_MUL:
1277 strcpy(bf, "MUL");
1278 break;
1279 case AC_DIV:
1280 strcpy(bf, "DIV");
1281 break;
1282 case AC_NEG:
1283 strcpy(bf, "NEG");
1284 break;
1285 case AC_EXP:
1286 strcpy(bf, "EXP");
1287 break;
1288 case AC_INTR_CALL:
1289 strcpy(bf, "INTR_CALL");
1290 break;
1291 case AC_ARRAYREF:
1292 strcpy(bf, "ARRAYREF");
1293 break;
1294 case AC_MEMBR_SEL:
1295 strcpy(bf, "MEMBR_SEL");
1296 break;
1297 case AC_CONV:
1298 strcpy(bf, "CONV");
1299 break;
1300 case AC_CAT:
1301 strcpy(bf, "CAT");
1302 break;
1303 case AC_EXPK:
1304 strcpy(bf, "EXPK");
1305 break;
1306 case AC_LEQV:
1307 strcpy(bf, "LEQV");
1308 break;
1309 case AC_LNEQV:
1310 strcpy(bf, "LNEQV");
1311 break;
1312 case AC_LOR:
1313 strcpy(bf, "LOR");
1314 break;
1315 case AC_LAND:
1316 strcpy(bf, "LAND");
1317 break;
1318 case AC_EQ:
1319 strcpy(bf, "EQ");
1320 break;
1321 case AC_GE:
1322 strcpy(bf, "GE");
1323 break;
1324 case AC_GT:
1325 strcpy(bf, "GT");
1326 break;
1327 case AC_LE:
1328 strcpy(bf, "LE");
1329 break;
1330 case AC_LT:
1331 strcpy(bf, "LT");
1332 break;
1333 case AC_NE:
1334 strcpy(bf, "NE");
1335 break;
1336 case AC_LNOT:
1337 strcpy(bf, "LNOT");
1338 break;
1339 case AC_EXPX:
1340 strcpy(bf, "EXPX");
1341 break;
1342 case AC_TRIPLE:
1343 strcpy(bf, "TRIPLE");
1344 break;
1345 default:
1346 sprintf(bf, "ac_opnameUNK_%d", id);
1347 break;
1348 }
1349 return bf;
1350 }
1351
1352 /*---------------------------------------------------------------*/
1353
1354 /* find_base - dereference an ast pointer to determine the base
1355 * of an array reference (i.e. base sptr).
1356 */
1357 static void
find_base(int ast,int * psptr,int * pmemptr)1358 find_base(int ast, int *psptr, int *pmemptr)
1359 {
1360 int sptr, memptr, a;
1361 int i;
1362 int asd;
1363 ADSC *ad;
1364 int ndim;
1365 int lwbd;
1366 int offset;
1367
1368 switch (A_TYPEG(ast)) {
1369 case A_SUBSTR:
1370 find_base((int)A_LOPG(ast), &sptr, &memptr);
1371 if (sem.dinit_error)
1372 break;
1373 /* check left & right indices */
1374 (void)dinit_eval((int)A_LEFTG(ast));
1375 (void)dinit_eval((int)A_RIGHTG(ast));
1376 break;
1377
1378 case A_SUBSCR:
1379 find_base((int)A_LOPG(ast), &sptr, &memptr);
1380 if (sem.dinit_error)
1381 break;
1382 asd = A_ASDG(ast);
1383 ad = AD_PTR(memptr);
1384 ndim = ASD_NDIM(asd);
1385 for (i = 0; i < ndim; i++) {
1386 lwbd = get_int_cval(sym_of_ast(AD_LWAST(ad, i)));
1387 offset = dinit_eval((int)ASD_SUBS(asd, i));
1388 if (offset < lwbd || offset > get_int_cval(sym_of_ast(AD_UPAST(ad, i)))) {
1389 error(80, 3, gbl.lineno, SYMNAME(sptr), CNULL);
1390 sem.dinit_error = TRUE;
1391 break;
1392 }
1393 }
1394 break;
1395
1396 case A_ID:
1397 if (A_ALIASG(ast))
1398 goto err;
1399 memptr = sptr = A_SPTRG(ast);
1400 (void)dinit_ok(sptr);
1401 break;
1402
1403 case A_MEM:
1404 a = A_PARENTG(ast);
1405 if (A_TYPEG(a) == A_SUBSCR)
1406 a = A_LOPG(a);
1407 sptr = A_SPTRG(a);
1408 a = A_MEMG(ast);
1409 memptr = A_SPTRG(a);
1410 break;
1411
1412 case A_FUNC:
1413 sptr = A_LOPG(ast);
1414 error(76, 3, gbl.lineno, SYMNAME(sptr), CNULL);
1415 sem.dinit_error = TRUE;
1416 break;
1417
1418 default:
1419 err:
1420 memptr = sptr = 0;
1421 sem.dinit_error = TRUE;
1422 break;
1423 }
1424 *psptr = sptr;
1425 *pmemptr = memptr;
1426 }
1427
1428 /*---------------------------------------------------------------*/
1429
1430 /*
1431 * find the sptr for the implied do index variable; the ilm in this
1432 * context represents the ilms generated to load the index variable
1433 * and perhaps "type" convert (if it's integer*2, etc.).
1434 */
1435 static int
chk_doindex(int ast)1436 chk_doindex(int ast)
1437 {
1438 again:
1439 switch (A_TYPEG(ast)) {
1440 case A_CONV:
1441 ast = A_LOPG(ast);
1442 goto again;
1443 case A_ID:
1444 if (!DT_ISINT(A_DTYPEG(ast)) || A_ALIASG(ast))
1445 break;
1446 return A_SPTRG(ast);
1447 }
1448 /* could use a better error message - illegal implied do index variable */
1449 errsev(106);
1450 sem.dinit_error = TRUE;
1451 return 1L;
1452 }
1453
1454 INT
dinit_eval(int ast)1455 dinit_eval(int ast)
1456 {
1457 DOSTACK *p;
1458 int sptr;
1459
1460 if (ast == 0)
1461 return 1L;
1462 if (!DT_ISINT(A_DTYPEG(ast)))
1463 goto err;
1464 if (A_ALIASG(ast)) {
1465 ast = A_ALIASG(ast);
1466 goto eval_cnst;
1467 }
1468 switch (A_TYPEG(ast) /* opc */) {
1469 case A_ID:
1470 if (!DT_ISINT(A_DTYPEG(ast)))
1471 goto err;
1472 if (A_ALIASG(ast)) {
1473 ast = A_ALIASG(ast);
1474 goto eval_cnst;
1475 }
1476 /* see if this ident is an active do index variable: */
1477 sptr = A_SPTRG(ast);
1478 for (p = sem.dostack; p < sem.top; p++)
1479 if (p->sptr == sptr)
1480 return p->currval;
1481 /* else - illegal use of variable: */
1482 error(64, 3, gbl.lineno, SYMNAME(sptr), CNULL);
1483 sem.dinit_error = TRUE;
1484 return 1L;
1485
1486 case A_CNST:
1487 goto eval_cnst;
1488
1489 case A_UNOP:
1490 if (A_OPTYPEG(ast) == OP_SUB)
1491 return -dinit_eval((int)A_LOPG(ast));
1492 return dinit_eval((int)A_LOPG(ast));
1493 case A_BINOP:
1494 switch (A_OPTYPEG(ast)) {
1495 case OP_ADD:
1496 return dinit_eval((int)A_LOPG(ast)) + dinit_eval((int)A_ROPG(ast));
1497 case OP_SUB:
1498 return dinit_eval((int)A_LOPG(ast)) - dinit_eval((int)A_ROPG(ast));
1499 case OP_MUL:
1500 return dinit_eval((int)A_LOPG(ast)) * dinit_eval((int)A_ROPG(ast));
1501 case OP_DIV:
1502 return dinit_eval((int)A_LOPG(ast)) / dinit_eval((int)A_ROPG(ast));
1503 }
1504 break;
1505 case A_CONV:
1506 case A_PAREN:
1507 return dinit_eval((int)A_LOPG(ast));
1508
1509 case A_INTR:
1510 if (A_OPTYPEG(ast) == I_NULL) {
1511 return 0;
1512 }
1513 default:
1514 break;
1515 }
1516 err:
1517 errsev(69);
1518 sem.dinit_error = TRUE;
1519 return 1L;
1520 eval_cnst:
1521 return get_int_cval(A_SPTRG(ast));
1522 }
1523
1524 /*---------------------------------------------------------------*/
1525
1526 /*
1527 * sym_is_dinitd: a symbol is being initialized - update certain
1528 * attributes of the symbol including its dinit flag.
1529 */
1530 static void
sym_is_dinitd(int sptr)1531 sym_is_dinitd(int sptr)
1532 {
1533 if (no_dinitp)
1534 return;
1535 DINITP(sptr, 1);
1536 if (ST_ISVAR(STYPEG(sptr)) && SCG(sptr) == SC_CMBLK)
1537 /* set DINIT flag for common block: */
1538 DINITP(CMBLKG(sptr), 1);
1539
1540 /* For identifiers the DATA statement ensures that the identifier
1541 * is a variable and not an intrinsic. For arrays, either
1542 * compute the element offset or if a whole array reference
1543 * compute the number of elements to initialize.
1544 */
1545 if (STYPEG(sptr) == ST_IDENT || STYPEG(sptr) == ST_UNKNOWN)
1546 STYPEP(sptr, ST_VAR);
1547
1548 }
1549
1550 static void
mark_ivl_dinit(VAR * ivl)1551 mark_ivl_dinit(VAR *ivl)
1552 {
1553 while (ivl != NULL && ivl->id == Varref) {
1554 if (ivl->u.varref.subt) {
1555 mark_ivl_dinit(ivl->u.varref.subt);
1556 } else {
1557 int sptr;
1558 sptr = sym_of_ast(ivl->u.varref.ptr);
1559 sym_is_dinitd(sptr);
1560 }
1561 ivl = ivl->next;
1562 }
1563 } /* mark_ivl_dinit */
1564
1565 static void
mark_dinit(VAR * ivl,ACL * ict)1566 mark_dinit(VAR *ivl, ACL *ict)
1567 {
1568 if (ivl == NULL) {
1569 sym_is_dinitd(ict->sptr);
1570 } else {
1571 mark_ivl_dinit(ivl);
1572 }
1573 } /* mark_dinit */
1574
1575 /*---------------------------------------------------------------*/
1576
1577 /* determine if the symbol can be legally data initialized */
1578 LOGICAL
dinit_ok(int sptr)1579 dinit_ok(int sptr)
1580 {
1581 switch (SCG(sptr)) {
1582 case SC_DUMMY:
1583 error(41, 3, gbl.lineno, SYMNAME(sptr), CNULL);
1584 goto error_exit;
1585 case SC_CMBLK:
1586 if (ALLOCG(MIDNUMG(sptr))) {
1587 error(163, 3, gbl.lineno, SYMNAME(sptr), SYMNAME(MIDNUMG(sptr)));
1588 goto error_exit;
1589 }
1590 break;
1591 default:
1592 break;
1593 }
1594 if (STYPEG(sptr) == ST_ARRAY && !POINTERG(sptr)) {
1595 if (ALLOCG(sptr)) {
1596 error(84, 3, gbl.lineno, SYMNAME(sptr),
1597 "- initializing an allocatable array");
1598 goto error_exit;
1599 }
1600 if (ASUMSZG(sptr)) {
1601 error(84, 3, gbl.lineno, SYMNAME(sptr),
1602 "- initializing an assumed size array");
1603 goto error_exit;
1604 }
1605 if (ADJARRG(sptr)) {
1606 error(84, 3, gbl.lineno, SYMNAME(sptr),
1607 "- initializing an adjustable array");
1608 goto error_exit;
1609 }
1610 }
1611 if (ADJLENG(sptr)) {
1612 error(84, 3, gbl.lineno, SYMNAME(sptr),
1613 "- initializing an adjustable length object");
1614 goto error_exit;
1615 }
1616
1617 return TRUE;
1618
1619 error_exit:
1620 sem.dinit_error = TRUE;
1621 return FALSE;
1622 }
1623
rw_dinit_state(RW_ROUTINE,RW_FILE)1624 void rw_dinit_state(RW_ROUTINE, RW_FILE)
1625 {
1626
1627 VAR *ivl;
1628 ACL *ict;
1629 int nw;
1630 int lineno;
1631 FILE *readfile;
1632 FILE *writefile;
1633 int i;
1634 int sptr;
1635 int seq_astb_df;
1636 int fileno = 1;
1637
1638 seq_astb_df = 0;
1639 if (ISREAD()) {
1640 if (astb.df == NULL) {
1641 if ((astb.df = tmpf("b")) == NULL)
1642 errfatal(5);
1643 } else {
1644 nw = fseek(astb.df, 0L, 0);
1645 #if DEBUG
1646 assert(nw == 0, "do_dinit:bad rewind", nw, 4);
1647 #endif
1648 }
1649
1650 /* restore, read saved state and write dinit file */
1651 readfile = fd; /* from parameter RW_FILE */
1652 writefile = astb.df;
1653 } else {
1654 if (astb.df == NULL) {
1655 /* this can happen if there are errors */
1656 sem.dinit_nbr_inits = 0;
1657 RW_SCALAR(sem.dinit_nbr_inits);
1658 return;
1659 }
1660 nw = fseek(astb.df, 0L, 0);
1661 #if DEBUG
1662 assert(nw == 0, "do_dinit:bad rewind", nw, 4);
1663 #endif
1664 /* save, read dinit file and write saved state */
1665 readfile = astb.df;
1666 seq_astb_df = 1;
1667 writefile = fd; /* from parameter RW_FILE */
1668 }
1669
1670 RW_SCALAR(sem.dinit_nbr_inits);
1671
1672 for (i = sem.dinit_nbr_inits; i;) {
1673 nw = fread(&lineno, sizeof(lineno), 1, readfile);
1674 if (nw != 1)
1675 break;
1676
1677 nw = fread(&fileno, sizeof(fileno), 1, readfile);
1678 if (nw != 1)
1679 break;
1680
1681 nw = fread(&ivl, sizeof(VAR *), 1, readfile);
1682 if (nw != 1)
1683 break;
1684
1685 nw = fread(&ict, sizeof(ACL *), 1, readfile);
1686 if (nw != 1)
1687 break;
1688
1689 /* save/restore only parameter initializations */
1690 if (!ivl || ivl->u.varref.id != S_IDENT ||
1691 (STYPEG(A_SPTRG(ivl->u.varref.ptr)) != ST_PARAM &&
1692 !PARAMG(A_SPTRG(ivl->u.varref.ptr)))) {
1693 continue;
1694 }
1695
1696 nw = fwrite(&lineno, sizeof(lineno), 1, writefile);
1697 if (nw != 1)
1698 break;
1699
1700 nw = fwrite(&fileno, sizeof(fileno), 1, writefile);
1701 if (nw != 1)
1702 break;
1703
1704 nw = fwrite(&ivl, sizeof(VAR *), 1, writefile);
1705 if (nw != 1)
1706 break;
1707
1708 nw = fwrite(&ict, sizeof(ACL *), 1, writefile);
1709 if (nw != 1)
1710 break;
1711
1712 i--;
1713 }
1714
1715 if (i != 0) {
1716 interr("dinit save/restore failed", 0, 4);
1717 }
1718
1719 if (seq_astb_df) {
1720 /*
1721 * If the next I/O operation on astb.df is a write, the write will
1722 * fail on win. Strictly speaking, a file positioning operation
1723 * must be performed before the write. This was the cause of
1724 * "data init file" write errors when compiling relatively simple
1725 * f90 programs; all that's needed to be present is dinits in
1726 * modules or host subprograms and contained subprograms.
1727 */
1728 long file_pos;
1729 file_pos = ftell(astb.df);
1730 (void)fseek(astb.df, file_pos, 0);
1731 }
1732 }
1733