1 /*
2 * Copyright (c) 1994-2019, NVIDIA CORPORATION. All rights reserved.
3 *
4 * Licensed under the Apache License, Version 2.0 (the "License");
5 * you may not use this file except in compliance with the License.
6 * You may obtain a copy of the License at
7 *
8 * http://www.apache.org/licenses/LICENSE-2.0
9 *
10 * Unless required by applicable law or agreed to in writing, software
11 * distributed under the License is distributed on an "AS IS" BASIS,
12 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13 * See the License for the specific language governing permissions and
14 * limitations under the License.
15 *
16 */
17
18 /** \file
19 \brief Utility routines used by Semantic Analyzer.
20 */
21
22 #include "gbldefs.h"
23 #include "global.h"
24 #include "gramtk.h"
25 #include "error.h"
26 #include "symtab.h"
27 #include "symutl.h"
28 #include "dtypeutl.h"
29 #include "semant.h"
30 #include "scan.h"
31 #include "dinit.h"
32 #include "semstk.h"
33 #include "machar.h"
34 #include "ast.h"
35 #define RTE_C
36 #include "rte.h"
37 #include "pd.h"
38 #include "direct.h"
39 #include "go.h"
40 #include "rtlRtns.h"
41
42 #define ERR170(s1, s2) error(170, 2, gbl.lineno, s1, s2)
43
44 #define UFCHAR \
45 error(0, 3, gbl.lineno, "character array expressions not supported", CNULL)
46
47 /*
48 * Need quick ways of getting data types (for code readablity):
49 * 1) actual type e.g. integer or array of integer
50 * 2) basic type (no arrays) e.g. real, integer, logical, ...
51 */
52 #define TYPE_OF(s) (SST_DTYPEG(s))
53 #define TY_OF(s) (DTYG(TYPE_OF(s)))
54 #define PT_OF(s) (DDTG(TYPE_OF(s))) /* pointer to data type */
55
56 static void resolve_proc_pointer(SST *);
57
58 static int ref_array(SST *, ITEM *);
59 static INT clog_to_log(INT);
60 static int mkunion(int, int, int);
61 static INT const_xtoi(INT, int, int);
62 static INT _xtok(INT, BIGINT64, int);
63
64 static void error83(int);
65 static LOGICAL subst_lhs_arrfn(int, int, int);
66 static LOGICAL subst_lhs_pointer(int, int, int);
67 static LOGICAL not_in_arrfn(int, int);
68 static int find_pointer_variable_assign(int, int);
69
70 static int inline_contig_check(int src, SPTR src_sptr, SPTR sdsc, int std);
71 static bool is_selector(SPTR sptr);
72
73
74 /*---------------------------------------------------------------------*/
75
76 /** \brief If \a stkptr is an LVALUE that has a constant value, replace it with
77 the constant value
78 */
79 void
constant_lvalue(SST * stkptr)80 constant_lvalue(SST *stkptr)
81 {
82 int ast, sptr, dtype;
83 if (SST_IDG(stkptr) == S_LVALUE) {
84 ast = SST_ASTG(stkptr);
85 if (ast > 0 && ast < astb.stg_avail && A_ALIASG(ast)) {
86 /* make into an S_CONST */
87 ast = A_ALIASG(ast);
88 sptr = A_SPTRG(ast);
89 dtype = DTYPEG(sptr);
90 SST_DTYPEP(stkptr, dtype);
91 if (DT_ISWORD(dtype)) {
92 SST_SYMP(stkptr, CONVAL2G(sptr));
93 } else {
94 SST_SYMP(stkptr, sptr);
95 }
96 SST_ASTP(stkptr, ast);
97 SST_IDP(stkptr, S_CONST);
98 return;
99 }
100 }
101 } /* constant_lvalue */
102
103 /** \brief Check that the indicated semantic stack entry is a constant of the
104 specified type and convert constant to new type if possible.
105 \return 32-bit constant value or symbol table pointer.
106 */
107 INT
chkcon(SST * stkptr,int dtype,LOGICAL warnflg)108 chkcon(SST *stkptr, int dtype, LOGICAL warnflg)
109 {
110 INT oldval, oldtyp, oldast, oldid;
111
112 constant_lvalue(stkptr);
113 oldval = SST_SYMG(stkptr);
114 oldtyp = SST_DTYPEG(stkptr);
115 oldast = SST_ASTG(stkptr);
116 oldid = SST_IDG(stkptr);
117 if (oldid == S_EXPR && oldast && A_TYPEG(oldast) == A_CNST) {
118 oldid = S_CONST;
119 if ((DT_ISINT(oldtyp) && oldtyp != DT_INT8) || DT_ISREAL(oldtyp)) {
120 } else {
121 /* logical, complex, etc., use sptrs */
122 oldval = A_SPTRG(oldast);
123 }
124 }
125 if (oldid != S_CONST) {
126 errsev(87);
127 if (DTY(dtype) == TY_CHAR) {
128 oldval = getstring(" ", 1);
129 oldtyp = DT_CHAR;
130 }
131 else if (DTY(dtype) == TY_NCHAR) {
132 oldval = getstring(" ", 1);
133 oldtyp = DT_NCHAR;
134 }
135 else if (dtype == DT_LOG) {
136 oldval = SCFTN_TRUE; /* VMS */
137 oldtyp = DT_LOG4;
138 } else {
139 oldtyp = DT_INT4;
140 oldval = 1;
141 }
142 }
143
144 if (oldtyp != dtype) {
145 if (warnflg) {
146 if (flg.standard) {
147 if (TY_ISINT(oldtyp) && TY_ISINT(dtype)) {
148 /* any integer, treated identical */
149 } else if (TY_ISLOG(oldtyp) && TY_ISLOG(dtype)) {
150 /* any logical, treated identical */
151 } else {
152 errwarn(91);
153 }
154 } else {
155 if ((TY_ISINT(oldtyp) || TY_ISLOG(oldtyp)) &&
156 (TY_ISINT(dtype) || TY_ISLOG(dtype))) {
157 /* any integer, any logical, treated identical */
158 } else {
159 errwarn(91);
160 }
161 }
162 }
163 return cngcon(oldval, oldtyp, dtype);
164 }
165 return oldval;
166 }
167
168 /** \brief Check that the indicated semantic stack entry is a constant of any
169 integer type.
170 \return the integer value as type ISZ_T.
171
172 Issue an error message if stkptr is not a constant of the correct type.
173 */
174 ISZ_T
chkcon_to_isz(SST * stkptr,LOGICAL warnflg)175 chkcon_to_isz(SST *stkptr, LOGICAL warnflg)
176 {
177 int dtype;
178 INT cval;
179 ISZ_T iszv;
180
181 if (!XBIT(68, 0x1))
182 return chkcon(stkptr, DT_INT, warnflg);
183 if (SST_IDG(stkptr) == S_CONST) {
184 dtype = SST_DTYPEG(stkptr);
185 if (DT_ISINT(dtype))
186 cval = SST_CVALG(stkptr);
187 else {
188 cval = chkcon(stkptr, DT_INT8, warnflg);
189 dtype = DT_INT8;
190 }
191 if (size_of(dtype) > 4) {
192 INT num[2];
193 num[0] = CONVAL1G(cval);
194 num[1] = CONVAL2G(cval);
195 INT64_2_ISZ(num, iszv);
196 return iszv;
197 }
198 return cval;
199 }
200 errsev(91);
201 return 1;
202 }
203
204 /** \brief Convert expression pointed to by stkptr from its current data type
205 to data type dtype.
206 \return ILM pointer
207 */
208 INT
chktyp(SST * stkptr,int dtype,LOGICAL warnflg)209 chktyp(SST *stkptr, int dtype, LOGICAL warnflg)
210 {
211 int oldtyp;
212
213 /* Change non-decimal constants to integer before mkexpr call */
214 /* this might need to change! -nzm */
215 if (SST_ISNONDECC(stkptr))
216 cngtyp(stkptr, DT_INT);
217 if (SST_IDG(stkptr) == S_CONST) {
218 oldtyp = SST_DTYPEG(stkptr);
219 cngtyp(stkptr, dtype);
220 mkexpr1(stkptr);
221 } else {
222 mkexpr1(stkptr);
223 oldtyp = SST_DTYPEG(stkptr);
224 cngtyp(stkptr, dtype);
225 }
226 if (warnflg && (DTYG(oldtyp) != DTYG(dtype)) && DTY(dtype) != TY_NUMERIC &&
227 (!(TY_ISINT(DTYG(oldtyp)) || TY_ISLOG(DTYG(oldtyp))) ||
228 !(TY_ISINT(DTYG(dtype)) || TY_ISLOG(DTYG(dtype)))))
229 errwarn(93);
230 return 1;
231 }
232
233 /** \brief Same as chktyp() with the restriction that the expression must be a
234 scalar (i.e., not an array/vector form).
235 */
236 INT
chk_scalartyp(SST * stkptr,int dtype,LOGICAL warnflg)237 chk_scalartyp(SST *stkptr, int dtype, LOGICAL warnflg)
238 {
239 int oldtyp;
240
241 oldtyp = SST_DTYPEG(stkptr);
242 if (DTY(oldtyp) == TY_ARRAY)
243 errsev(83);
244 return (chktyp(stkptr, dtype, warnflg));
245 }
246
247 /** \brief Same as chktyp() with the restriction that the expression must be a
248 scalar (i.e., not an array/vector form) and integer (i.e., not
249 logical).
250 */
251 INT
chk_scalar_inttyp(SST * stkptr,int dtype,char * msg)252 chk_scalar_inttyp(SST *stkptr, int dtype, char *msg)
253 {
254 int oldtyp;
255
256 oldtyp = SST_DTYPEG(stkptr);
257 if (DTY(oldtyp) == TY_ARRAY)
258 errsev(83);
259 else if (!DT_ISNUMERIC(oldtyp) || DT_ISLOG(oldtyp))
260 error(155, 3, gbl.lineno, msg, "must be numeric");
261 else if (flg.standard && !DT_ISINT(oldtyp))
262 error(170, 2, gbl.lineno, msg, "is not integer");
263 return (chktyp(stkptr, dtype, FALSE));
264 }
265
266 /** \brief Restrict the expression to be suitable for an array extent.
267 */
268 INT
chk_arr_extent(SST * stkptr,char * msg)269 chk_arr_extent(SST *stkptr, char *msg)
270 {
271 if (flg.standard)
272 return chk_scalar_inttyp(stkptr, astb.bnd.dtype, msg);
273 else
274 return chk_scalartyp(stkptr, astb.bnd.dtype, FALSE);
275 }
276
277 /** \brief Convert expression pointed to by stkptr from its current data type to
278 a data type consistent with subscripting.
279 \return the ILM pointer
280 */
281 INT
chksubscr(SST * stkptr,int sptr)282 chksubscr(SST *stkptr, int sptr)
283 {
284 /* Change non-decimal constants to integer before mkexpr call */
285 if (SST_ISNONDECC(stkptr))
286 cngtyp(stkptr, astb.bnd.dtype);
287 mkexpr1(stkptr);
288 if (!TY_ISINT(DTYG(SST_DTYPEG(stkptr))))
289 error(103, 2, gbl.lineno, SYMNAME(sptr), CNULL);
290 if (rank_of_ast(SST_ASTG(stkptr)) > 1)
291 errsev(161);
292 if (DTYG(SST_DTYPEG(stkptr)) != TY_INT8 && DTY(SST_DTYPEG(stkptr)) != TY_ARRAY)
293 cngtyp(stkptr, astb.bnd.dtype);
294 return 1;
295 }
296
297 /** \brief Cast a given semantic entry into a desired type.
298 No type conversion is done.
299
300 \return 1 if no error, -1 if error
301
302 The following casts are ok:
303 1. Cast any of the data types to TY_WORD or TY_DWORD (necessary for the
304 bitwise intrinsics and relational comparisons)
305 2. Cast a TY_WORD or TY_DWORD to any of the data types (necessary for
306 casting the bitwise intrinsics back to a data type)
307
308 Since this is used primarily for the bitwise intrinsics, there is no need
309 to support TY_DBLE, TY_CHAR, TY_CMPX, or TY_DCMPX since these types are
310 illegal for these intrinsics. However, cast of TY_DWORD and TY_WORD to
311 TY_CMPX and TY_DCMPLX is needed for relational comparisons.
312 Comparisons between vector typed and typeless operands require typed
313 vectors to be casted to typeless vectors.
314 */
315 int
casttyp(SST * old,int newcast)316 casttyp(SST *old, int newcast)
317 {
318 int im, from, isvector;
319
320 from = SST_DTYPEG(old);
321 if (SST_IDG(old) == S_ACONST && DTY(from) == TY_ARRAY &&
322 DTY(newcast) == TY_ARRAY &&
323 size_of(DTY(from + 1)) == size_of(DTY(newcast + 1))) {
324 ACL *aclp;
325 aclp = SST_ACLG(old);
326 aclp->dtype = newcast;
327 SST_DTYPEP(old, newcast);
328 return 1;
329 }
330 isvector = FALSE;
331 if ((from > DT_LOG8 && DTY(from) != TY_ARRAY) || newcast > DT_LOG8)
332 goto err_exit;
333 /*
334 if (from > DT_LOG || newcast > DT_LOG)
335 goto err_exit;
336 */
337
338 if (DTY(from) == TY_ARRAY) {
339 isvector = TRUE;
340 from = DTYG(from);
341 im = 1;
342 } else if (newcast == DT_WORD || newcast == DT_DWORD)
343 im = cast_types[from][newcast - 1][0];
344 else if (from == DT_WORD || from == DT_DWORD)
345 im = cast_types[from][from - 1][1];
346 else
347 goto err_exit;
348
349 if (im < 0)
350 goto err_exit;
351
352 if (from == DT_HOLL) {
353 /* default int is integer*8 and 64-bit precision, convert to DT_INT8. */
354 if (DTY(stb.user.dt_int) == TY_INT8) {
355 cngtyp(old, DT_INT8);
356 from = DT_INT8;
357 } else if (newcast == DT_WORD)
358 cngtyp(old, DT_INT);
359 else
360 cngtyp(old, DT_REAL8);
361 }
362 /* -nzm must not make it look like an integer
363 if (from == DT_WORD)
364 SST_DTYPEP(old, DT_INT); keep mkexpr1 happy
365 */
366 mkexpr1(old);
367 if (isvector)
368 DTY(SST_DTYPEP(old, get_type(3, TY_ARRAY, newcast)) + 2) = 0;
369 else
370 SST_DTYPEP(old, newcast);
371 return 1;
372
373 err_exit:
374 errsev(95);
375 return (-1);
376 }
377
378 /** \brief Convert expression pointed-to by old to the data type newtyp.
379
380 If newtyp points to a TY_ARRAY entry or newshape is true then old is
381 converted to an array.
382
383 \param old points to the semantic stack entry with the old data type.
384 \param newtyp is the new dtype for the old semantic stack entry.
385 \param allowPolyExpr is true when we want to allow type extension in our
386 type comparison.
387 */
388 static void
cngtyp2(SST * old,DTYPE newtyp,bool allowPolyExpr)389 cngtyp2(SST *old, DTYPE newtyp, bool allowPolyExpr)
390 {
391 DTYPE oldtyp;
392 int to, from;
393 int fromisv;
394 int ast;
395 bool have_unl_poly;
396
397 if (newtyp == 0)
398 return;
399 oldtyp = SST_DTYPEG(old);
400
401 have_unl_poly = allowPolyExpr && is_dtype_unlimited_polymorphic(newtyp);
402
403 /* handle constants elsewhere */
404 if (SST_IDG(old) == S_CONST && !have_unl_poly) {
405 /* if not scalar as in structure=constant then cngcon will fail
406 * so we will assume type of integer.
407 */
408 newtyp = DDTG(newtyp);
409 if (TY_ISSCALAR(DTY(newtyp)))
410 SST_DTYPEP(old, newtyp);
411 else
412 SST_DTYPEP(old, DT_INT);
413 SST_CVALP(old, cngcon(SST_CVALG(old), oldtyp, newtyp));
414 if (newtyp == DT_NUMERIC)
415 SST_DTYPEP(old, oldtyp);
416 else if (oldtyp != newtyp) {
417 ast = mk_convert((int)SST_ASTG(old), newtyp);
418 SST_ASTP(old, ast);
419 mk_alias(ast, mk_cval1(SST_CVALG(old), newtyp));
420 SST_SHAPEP(old, A_SHAPEG(ast));
421 }
422 return;
423 }
424
425 to = DTYG(newtyp);
426 from = DTY(oldtyp);
427
428 if (from == TY_ARRAY) {
429 fromisv = TRUE;
430 from = DTYG(oldtyp);
431 } else
432 fromisv = FALSE;
433
434 /* If the conversion is FROM or TO a typeless value, perform a
435 * casting operation.
436 */
437 if (from == TY_WORD || from == TY_DWORD || to == TY_WORD || to == TY_DWORD) {
438 (void)casttyp(old, newtyp);
439 return;
440 }
441
442 if (from == to) {
443 if (from == TY_CHAR) {
444 if (DDTG(oldtyp) == DDTG(newtyp))
445 return;
446 } else if (from == TY_NCHAR) {
447 if (DDTG(oldtyp) == DDTG(newtyp))
448 return;
449 } else if (from != TY_STRUCT && from != TY_DERIVED)
450 return;
451 }
452
453 if (F77OUTPUT) {
454 if (TY_ISLOG(to) && (!TY_ISLOG(from)))
455 /* "Illegal type conversion $" */
456 error(432, 2, gbl.lineno, "to logical", CNULL);
457 if (TY_ISLOG(from) && (!TY_ISLOG(to)))
458 error(432, 2, gbl.lineno, "from logical", CNULL);
459 }
460
461 switch (to) {
462
463 case TY_BLOG:
464 case TY_SLOG:
465 cngtyp(old, DT_LOG);
466 SST_DTYPEP(old, DT_LOG);
467 break;
468 case TY_BINT:
469 case TY_SINT:
470 cngtyp(old, DT_INT);
471 SST_DTYPEP(old, DT_INT);
472 break;
473
474 case TY_LOG:
475 case TY_INT:
476 switch (from) {
477 case TY_LOG:
478 case TY_INT:
479 goto done;
480 case TY_BLOG:
481 case TY_BINT:
482 break;
483 case TY_SLOG:
484 case TY_SINT:
485 break;
486 case TY_LOG8:
487 case TY_INT8:
488 break;
489 case TY_CMPLX:
490 mkexpr1(old);
491 /* fall thru ... */
492 case TY_REAL:
493 break;
494 case TY_DCMPLX:
495 mkexpr1(old);
496 /* fall thru ... */
497 case TY_DBLE:
498 break;
499 case TY_CHAR:
500 case TY_NCHAR:
501 case TY_STRUCT:
502 case TY_DERIVED:
503 /* fall thru ... */
504 default:
505 goto type_error;
506 }
507
508 case TY_LOG8:
509 case TY_INT8:
510 switch (from) {
511 case TY_LOG8:
512 case TY_INT8:
513 goto done;
514 case TY_BLOG:
515 case TY_BINT:
516 break;
517 case TY_SLOG:
518 case TY_SINT:
519 break;
520 case TY_LOG:
521 case TY_INT:
522 break;
523 case TY_CMPLX:
524 mkexpr1(old);
525 /* fall thru ... */
526 case TY_REAL:
527 break;
528 case TY_DCMPLX:
529 mkexpr1(old);
530 /* fall thru ... */
531 case TY_DBLE:
532 break;
533 case TY_CHAR:
534 case TY_NCHAR:
535 case TY_STRUCT:
536 case TY_DERIVED:
537 /* fall thru ... */
538 default:
539 goto type_error;
540 }
541 break;
542 case TY_REAL:
543 switch (from) {
544 case TY_BLOG:
545 case TY_BINT:
546 case TY_SLOG:
547 case TY_SINT:
548 cngtyp(old, DT_INT);
549 SST_DTYPEP(old, DT_INT);
550 /* fall thru ... */
551 case TY_LOG:
552 case TY_INT:
553 case TY_LOG8:
554 case TY_INT8:
555 break;
556 case TY_CMPLX:
557 break;
558 case TY_DCMPLX:
559 mkexpr1(old);
560 /* fall thru ... */
561 case TY_DBLE:
562 break;
563 case TY_CHAR:
564 case TY_NCHAR:
565 case TY_STRUCT:
566 case TY_DERIVED:
567 /* fall thru ... */
568 default:
569 goto type_error;
570 }
571 break;
572
573 case TY_DBLE:
574 switch (from) {
575 case TY_BLOG:
576 case TY_BINT:
577 case TY_SLOG:
578 case TY_SINT:
579 cngtyp(old, DT_INT);
580 SST_DTYPEP(old, DT_INT);
581 /* fall thru ... */
582 case TY_LOG:
583 case TY_INT:
584 case TY_LOG8:
585 case TY_INT8:
586 break;
587 case TY_DCMPLX:
588 break;
589 case TY_CMPLX:
590 mkexpr1(old);
591 /* fall thru to */
592 case TY_REAL:
593 break;
594 case TY_CHAR:
595 case TY_NCHAR:
596 case TY_STRUCT:
597 case TY_DERIVED:
598 /* fall thru ... */
599 default:
600 goto type_error;
601 }
602 break;
603
604 case TY_CMPLX:
605 switch (from) {
606 case TY_BINT:
607 case TY_BLOG:
608 case TY_SINT:
609 case TY_SLOG:
610 cngtyp(old, DT_INT);
611 SST_DTYPEP(old, DT_INT);
612 /* fall thru to ... */
613 case TY_DBLE:
614 case TY_LOG:
615 case TY_INT:
616 case TY_LOG8:
617 case TY_INT8:
618 cngtyp(old, DT_REAL);
619 /* fall thru ... */
620 case TY_REAL:
621 if (fromisv)
622 mkexpr1(old);
623 else
624 mkexpr1(old);
625 SST_IDP(old, S_EXPR);
626 goto done;
627
628 case TY_DCMPLX:
629 mkexpr1(old);
630 SST_IDP(old, S_EXPR);
631 goto done;
632
633 case TY_CHAR:
634 case TY_NCHAR:
635 case TY_STRUCT:
636 case TY_DERIVED:
637 /* fall thru ... */
638
639 default:
640 goto type_error;
641 }
642
643 case TY_DCMPLX:
644 switch (from) {
645 case TY_BINT:
646 case TY_BLOG:
647 case TY_SINT:
648 case TY_SLOG:
649 cngtyp(old, DT_INT);
650 SST_DTYPEP(old, DT_INT);
651 /* fall thru ... */
652 case TY_REAL:
653 case TY_LOG:
654 case TY_INT:
655 case TY_LOG8:
656 case TY_INT8:
657 cngtyp(old, DT_REAL8);
658 /* fall thru ... */
659 case TY_DBLE:
660 if (fromisv)
661 mkexpr1(old);
662 else
663 mkexpr1(old);
664 SST_IDP(old, S_EXPR);
665 goto done;
666
667 case TY_CMPLX:
668 mkexpr1(old);
669 SST_IDP(old, S_EXPR);
670 goto done;
671
672 case TY_CHAR:
673 case TY_NCHAR:
674 case TY_STRUCT:
675 case TY_DERIVED:
676 /* fall thru ... */
677
678 default:
679 goto type_error;
680 }
681
682 case TY_CHAR:
683 case TY_NCHAR:
684 if (from != to) {
685 goto type_error;
686 }
687 break;
688
689 case TY_STRUCT:
690 if (DDTG(newtyp) != DDTG(oldtyp)) {
691 if (from == TY_STRUCT) {
692 error(99, 3, gbl.lineno, "RECORD", CNULL);
693 } else {
694 error(148, 3, gbl.lineno, "RECORD", CNULL);
695 }
696 }
697 return;
698
699 case TY_DERIVED:
700 if (DDTG(newtyp) != DDTG(oldtyp)) {
701 int new;
702 int old;
703 new = DDTG(newtyp);
704 old = DDTG(oldtyp);
705
706 /* module processing may duplicate dtypes, but if tag is
707 the same, then allow them to be considered equal */
708 if (same_dtype(old, new))
709 return;
710
711 if (DTY(new) == TY_DERIVED) {
712 int iso_dt;
713 iso_dt = is_iso_cptr(new);
714 if (iso_dt) {
715 if (is_iso_c_ptr(iso_dt)) {
716 error(148, 3, gbl.lineno, "TYPE(C_PTR) expression", CNULL);
717 return;
718 }
719 if (is_iso_c_funptr(iso_dt)) {
720 error(148, 3, gbl.lineno, "TYPE(C_FUNPTR) expression", CNULL);
721 return;
722 }
723 }
724 }
725 if (allowPolyExpr && from == TY_DERIVED &&
726 (have_unl_poly || eq_dtype2(oldtyp, newtyp, TRUE) ||
727 eq_dtype2(newtyp, oldtyp, TRUE))) {
728 return;
729 }
730 if (from == TY_DERIVED)
731 error(99, 3, gbl.lineno, "derived type", CNULL);
732 else if (to == TY_DERIVED && UNLPOLYG(DTY(new + 3)) &&
733 ((DTY(newtyp) != TY_ARRAY && DTY(oldtyp) != TY_ARRAY) ||
734 (DTY(newtyp) == TY_ARRAY && DTY(oldtyp) == TY_ARRAY &&
735 ADD_NUMDIM(newtyp) == ADD_NUMDIM(oldtyp))))
736 return;
737 else
738 error(148, 3, gbl.lineno, "derived type", CNULL);
739 }
740 return;
741
742 case TY_NUMERIC:
743 if (!TY_ISNUMERIC(from))
744 goto type_error;
745 mkexpr1(old);
746 return;
747
748 default:
749 goto type_error;
750 }
751
752 mkexpr1(old);
753
754 done:
755 if (flg.standard) {
756 if ((to == TY_BLOG || to == TY_SLOG || to == TY_LOG || to == TY_LOG8) &&
757 (from == TY_BINT || from == TY_SINT || from == TY_INT ||
758 from == TY_INT8 || from == TY_REAL || from == TY_DCMPLX ||
759 from == TY_DBLE || from == TY_CMPLX
760 ))
761 goto type_error;
762 if ((from == TY_BLOG || from == TY_SLOG || from == TY_LOG ||
763 from == TY_LOG8) &&
764 (to == TY_BINT || to == TY_SINT || to == TY_INT || to == TY_INT8 ||
765 to == TY_REAL || to == TY_DCMPLX || to == TY_DBLE || to == TY_CMPLX
766 ))
767 goto type_error;
768 }
769
770 if (fromisv) {
771 newtyp = get_type(3, TY_ARRAY, DDTG(newtyp));
772 DTY(newtyp + 2) = DTY(oldtyp + 2);
773 SST_DTYPEP(old, newtyp);
774 } else
775 SST_DTYPEP(old, DDTG(newtyp));
776 if (SST_ASTG(old)) {
777 SST_ASTP(old, mk_convert(SST_ASTG(old), newtyp));
778 SST_SHAPEP(old, A_SHAPEG(SST_ASTG(old)));
779 }
780 return;
781
782 type_error:
783 /* assertion: we get here when user mixes character or record data
784 * with numeric data or for unsupported data types such as QUAD.
785 */
786 if (to == TY_STRUCT)
787 error(148, 3, gbl.lineno, "RECORD", CNULL);
788 else if (to == TY_DERIVED)
789 error(148, 3, gbl.lineno, "derived type", CNULL);
790 else if (from == TY_STRUCT || from == TY_DERIVED || from == TY_CHAR ||
791 to == TY_CHAR) {
792 if (from == TY_STRUCT)
793 error(99, 3, gbl.lineno, "RECORD", CNULL);
794 else if (from == TY_DERIVED)
795 error(99, 3, gbl.lineno, "derived type", CNULL);
796
797 if (from == TY_CHAR)
798 errsev(147);
799 else if (to == TY_CHAR)
800 errsev(146);
801
802 SST_IDP(old, S_EXPR);
803 fromisv = FALSE;
804 goto done;
805 } else
806 errsev(95);
807 /* prevent further errors */
808 SST_DTYPEP(old, newtyp);
809 }
810
811 /**\brief Convert expression pointed-to by old to the data type newtyp.
812 *
813 * Main entry point for cngtyp2() that assumes no polymorphic expressions.
814 *
815 * \param old points to the semantic stack entry with the old data type.
816 * \param newtyp is the new dtype for the old semantic stack entry.
817 *
818 */
819 void
cngtyp(SST * old,DTYPE newtyp)820 cngtyp(SST *old, DTYPE newtyp)
821 {
822 cngtyp2(old, newtyp, false);
823 }
824
825 void
cngshape(SST * old,SST * new)826 cngshape(SST *old, SST *new)
827 {
828 int from, to;
829 LOGICAL fromisv, toisv;
830 int ast;
831 int newtyp;
832
833 fromisv = (DTY(SST_DTYPEG(old)) == TY_ARRAY) ? TRUE : FALSE;
834 from = DTYG(SST_DTYPEG(old));
835
836 newtyp = SST_DTYPEG(new);
837 toisv = (DTY(newtyp) == TY_ARRAY) ? TRUE : FALSE;
838 to = DTYG(newtyp);
839
840 if (!toisv && !fromisv)
841 return; /* both scalars */
842
843 if (fromisv && !toisv) { /* && !is_iso_c_loc(SST_ASTG(old)) */
844 /* can't demote an array to a scalar */
845 #if DEBUG
846 if (is_iso_c_loc(SST_ASTG(old))) {
847 interr("cngshape: array-value c_loc", SST_ASTG(old), 3);
848 }
849 #endif
850 errsev(83);
851 SST_IDP(old, S_EXPR);
852 SST_DTYPEP(old, DT_INT);
853 } else if (!fromisv && toisv) {
854 /* scalar promotion */
855 if (!TY_ISVEC(to)) {
856 if (to == TY_CHAR)
857 UFCHAR;
858 else
859 errsev(100);
860 } else if (!TY_ISVEC(from))
861 error83(from);
862 else {
863 mkexpr1(old);
864 if (SST_SHAPEG(new) == 0)
865 (void)mkexpr1(new);
866 if (to == TY_CHAR) {
867 /* scalar character to array of character -- don't change
868 * the element type.
869 */
870 newtyp = dup_array_dtype(newtyp);
871 DTY(newtyp + 1) = SST_DTYPEG(old);
872 }
873 ast = mk_promote_scalar((int)SST_ASTG(old), newtyp, (int)SST_SHAPEG(new));
874 SST_ASTP(old, ast);
875 SST_DTYPEP(old, newtyp);
876 SST_SHAPEP(old, A_SHAPEG(ast));
877 }
878 } else {
879 #if DEBUG
880 assert(fromisv && toisv, "chgshape:both vectors", 0, 3);
881 #endif
882 if (SST_SHAPEG(old) == 0)
883 (void)mkexpr1(old);
884 if (SST_SHAPEG(new) == 0)
885 (void)mkexpr1(new);
886 if (!conform_shape((int)SST_SHAPEG(old), (int)SST_SHAPEG(new)))
887 error(153, 3, gbl.lineno, CNULL, CNULL);
888 }
889 }
890
891 /** \brief Semantically check an operand (old) for array conformance with
892 operand new. If the operand is a scalar, change the shape of the
893 operand to conform with the expected shape. If the operand is an
894 array, check for conformance.
895 \param old operand to check
896 \param new operand to conform with
897 \param promote if true, promote scalar to vector
898 \return TRUE if shapes are conformant; false, otherwise.
899 */
900 LOGICAL
chkshape(SST * old,SST * new,LOGICAL promote)901 chkshape(SST *old, SST *new, LOGICAL promote)
902 {
903 int from, to;
904
905 from = SST_DTYPEG(old);
906 if (DTY(from) == TY_ARRAY)
907 return conform_shape((int)SST_SHAPEG(old), (int)SST_SHAPEG(new));
908
909 /* old is scalar */
910
911 if (promote) {
912 int ast;
913 int newtyp;
914 newtyp = dup_array_dtype((int)SST_DTYPEG(new));
915 DTY(newtyp + 1) = from;
916 ast = mk_promote_scalar((int)SST_ASTG(old), newtyp, (int)SST_SHAPEG(new));
917 SST_ASTP(old, ast);
918 SST_DTYPEP(old, newtyp);
919 SST_SHAPEP(old, A_SHAPEG(ast));
920 }
921
922 return TRUE;
923 }
924
925 int
chklog(SST * stkptr)926 chklog(SST *stkptr)
927 {
928 LOGICAL notlog;
929
930 notlog = (flg.standard) ? (!TY_ISLOG(DTYG(SST_DTYPEG(stkptr))))
931 : (!TY_ISINT(DTYG(SST_DTYPEG(stkptr))));
932 if (SST_IDG(stkptr) != S_CONST) {
933 if (notlog) {
934 errsev(121);
935 SST_IDP(stkptr, S_CONST);
936 SST_CVALP(stkptr, 0);
937 SST_DTYPEP(stkptr, DT_LOG);
938 mkexpr1(stkptr);
939 } else {
940 mkexpr1(stkptr);
941 /* Change only different sizes of logicals to a
942 * logical. Change to integer data type is done
943 * in chkopnds since only at that point if either of
944 * the operands is an integer we want to change the
945 * operation to bitwise logical.
946 */
947 }
948 } else {
949 /* the operand is a constant */
950 if (!flg.standard && DTYG(SST_DTYPEG(stkptr)) == TY_DWORD)
951 cngtyp(stkptr, DT_INT8);
952 else if (!flg.standard && DTYG(SST_DTYPEG(stkptr)) == TY_CHAR)
953 cngtyp(stkptr, DT_LOG);
954 else {
955 if (!SST_ISNONDECC(stkptr) && notlog) {
956 /* Fix constants that are not ultimately int, char or log */
957 errsev(121);
958 SST_CVALP(stkptr, 0);
959 SST_DTYPEP(stkptr, DT_LOG);
960 }
961 }
962 }
963
964 return 1;
965 }
966
967 void
mkident(SST * stkptr)968 mkident(SST *stkptr)
969 {
970 SST_IDP(stkptr, S_IDENT);
971 SST_ALIASP(stkptr, 0);
972 SST_CVLENP(stkptr, 0);
973 SST_SHAPEP(stkptr, 0);
974 }
975
976 int
mkexpr(SST * stkptr)977 mkexpr(SST *stkptr)
978 {
979 mkexpr1(stkptr);
980 mklogint4(stkptr);
981 return 1;
982 }
983
984 /*---------------------------------------------------------------------*/
985
986 /** \brief Given a semantic stack entry, write ILM's for the expression
987 represented by the stack entry if they have not already been written.
988 \return pointer to ILM
989 */
990 int
mkexpr1(SST * stkptr)991 mkexpr1(SST *stkptr)
992 {
993 int dtype;
994 int sptr;
995 INT num[2];
996 int shape;
997 extern int dont_issue_assumedsize_error;
998 int psptr, msptr, new_ast;
999
1000 again:
1001 switch (SST_IDG(stkptr)) {
1002 case S_STFUNC: /* delayed var ref */
1003 mkident(stkptr);
1004 (void)mkvarref(stkptr, SST_ENDG(stkptr));
1005 goto again;
1006
1007 case S_CONST:
1008 SST_CVLENP(stkptr, 0);
1009 dtype = SST_DTYPEG(stkptr);
1010 sptr = SST_SYMG(stkptr);
1011 /* generate constant ILM */
1012 switch (DTY(dtype)) {
1013 case TY_DWORD:
1014 dtype = DT_DWORD;
1015 SST_DTYPEP(stkptr, DT_DWORD);
1016 break;
1017 case TY_WORD:
1018 dtype = DT_WORD;
1019 SST_DTYPEP(stkptr, DT_WORD);
1020 break;
1021 case TY_INT:
1022 case TY_BINT:
1023 case TY_SINT:
1024 break;
1025 case TY_INT8:
1026 case TY_LOG8:
1027 break;
1028 case TY_LOG:
1029 case TY_BLOG:
1030 case TY_SLOG:
1031 break;
1032 case TY_REAL:
1033 break;
1034 case TY_DBLE:
1035 break;
1036 case TY_CMPLX:
1037 break;
1038 case TY_DCMPLX:
1039 break;
1040 case TY_CHAR:
1041 break;
1042 case TY_NCHAR:
1043 /* replace sptr to TY_CHAR const by TY_NCHAR constant: */
1044 num[0] = sptr;
1045 num[1] = 0;
1046 sptr = getcon(num, dtype);
1047 break;
1048 default:
1049 interr("mkexpr1: bad const", dtype, 3);
1050 SST_IDP(stkptr, S_EXPR);
1051 return 1;
1052 }
1053 SST_IDP(stkptr, S_EXPR);
1054 return 1;
1055
1056 case S_ACONST:
1057 shape = 0;
1058 if (SST_ACLG(stkptr) == 0) {
1059 int sdtype;
1060 sptr = sym_get_array("zs", "array", SST_DTYPEG(stkptr), 1);
1061 sdtype = DTYPEG(sptr);
1062 ADD_LWBD(sdtype, 0) = ADD_LWAST(sdtype, 0) = astb.bnd.one;
1063 ADD_UPBD(sdtype, 0) = ADD_UPAST(sdtype, 0) = astb.bnd.zero;
1064 ADD_EXTNTAST(sdtype, 0) =
1065 mk_extent(ADD_LWAST(sdtype, 0), ADD_UPAST(sdtype, 0), 0);
1066 mkident(stkptr);
1067 SST_SYMP(stkptr, sptr);
1068 SST_DTYPEP(stkptr, dtype = DTYPEG(sptr));
1069 } else {
1070 sptr = init_sptr_w_acl(0, SST_ACLG(stkptr));
1071 SST_IDP(stkptr, S_LVALUE);
1072 SST_DTYPEP(stkptr, dtype = DTYPEG(sptr));
1073 SST_LSYMP(stkptr, sptr);
1074 }
1075 SST_ASTP(stkptr, mk_id(sptr));
1076 goto lval;
1077
1078 case S_IDENT:
1079 /* need to set data type, stack type */
1080 dtype = 0;
1081 sptr = SST_SYMG(stkptr);
1082 shape = 0;
1083 get_next_hash_link(sptr, 0);
1084 retry:
1085 switch (STYPEG(sptr)) {
1086 case ST_ARRAY:
1087 if (SCG(sptr) == SC_DUMMY && ASUMSZG(sptr) &&
1088 !dont_issue_assumedsize_error)
1089 error(84, 3, gbl.lineno, SYMNAME(sptr),
1090 "- extent of assumed size array is unknown");
1091 if (ALLOCATTRG(sptr) && STYPEG(sptr) == ST_MEMBER && SDSCG(sptr) == 0 &&
1092 !F90POINTERG(sptr)) {
1093 get_static_descriptor(sptr);
1094 get_all_descriptors(sptr);
1095 ASSUMSHPP(sptr, 0);
1096 SDSCS1P(sptr, 1);
1097 }
1098 goto var_primary;
1099 case ST_PD:
1100 #ifdef I_N_PES
1101 if (sptr == intast_sym[I_N_PES])
1102 return ref_pd(stkptr, ITEM_END);
1103 #endif
1104 /* fall thru */
1105 case ST_INTRIN:
1106 case ST_GENERIC:
1107 if (sem.dinit_data) {
1108 return 1;
1109 }
1110 if (EXPSTG(sptr)) { /* Frozen as an intrinsic */
1111 return (mkvarref(stkptr, ITEM_END));
1112 }
1113 /* Not a frozen intrinsic, so assume its a variable */
1114 sptr = newsym(sptr);
1115 sem_set_storage_class(sptr);
1116 /* fall thru to ... */
1117 case ST_UNKNOWN:
1118 case ST_IDENT:
1119 STYPEP(sptr, ST_VAR);
1120 case ST_VAR:
1121 case ST_STRUCT:
1122 case ST_MEMBER:
1123 if (((ALLOCATTRG(sptr) && STYPEG(sptr) == ST_MEMBER) || POINTERG(sptr)) &&
1124 SDSCG(sptr) == 0 && !F90POINTERG(sptr)) {
1125 if (SCG(sptr) == SC_NONE)
1126 SCP(sptr, SC_BASED);
1127 get_static_descriptor(sptr);
1128 get_all_descriptors(sptr);
1129 }
1130 case ST_DESCRIPTOR:
1131 var_primary:
1132 SST_IDP(stkptr, S_LVALUE);
1133 sptr = ref_object(sptr);
1134 SST_DTYPEP(stkptr, dtype = DTYPEG(sptr));
1135 SST_LSYMP(stkptr, sptr);
1136 SST_ASTP(stkptr, mk_id(sptr));
1137 SST_SHAPEP(stkptr, A_SHAPEG(SST_ASTG(stkptr)));
1138 goto lval;
1139 case ST_ENTRY:
1140 if (gbl.rutype == RU_FUNC) {
1141 SST_IDP(stkptr, S_EXPR);
1142 SST_DTYPEP(stkptr, dtype = DTYPEG(sptr));
1143 sptr = ref_entry(sptr);
1144 SST_ASTP(stkptr, mk_id(sptr));
1145 goto lval;
1146 }
1147 error(84, 3, gbl.lineno, SYMNAME(sptr), CNULL);
1148 return 1;
1149 case ST_PROC:
1150 dtype = DTYPEG(sptr);
1151 if (dtype == 0) {
1152 error(84, 3, gbl.lineno, SYMNAME(sptr),
1153 "- attempt to use a SUBROUTINE as a FUNCTION");
1154 SST_DTYPEP(stkptr, DT_INT);
1155 return 1;
1156 }
1157 SST_DTYPEP(stkptr, dtype);
1158 SST_ASTP(stkptr, mk_id(sptr));
1159 return func_call(stkptr, (ITEM *)NULL);
1160 case ST_USERGENERIC:
1161 do {
1162 /* This symbol might be overloading the intended symbol.
1163 * Attempt to locate it.
1164 */
1165 sptr = get_next_hash_link(sptr, 2);
1166 if (test_scope(sptr)) {
1167 if (STYPEG(sptr) == ST_PARAM) {
1168 dtype = DTYPEG(sptr);
1169 SST_IDP(stkptr, S_CONST);
1170 SST_SYMP(stkptr, sptr);
1171 SST_DTYPEP(stkptr, dtype);
1172 SST_CVLENP(stkptr, 0);
1173 SST_ASTP(stkptr, mk_cnst(sptr));
1174 goto again;
1175 }
1176 goto retry;
1177 }
1178 } while (sptr > NOSYM);
1179 error(84, 3, gbl.lineno, SYMNAME(sptr),
1180 "- attempt to use a GENERIC subprogram as a FUNCTION");
1181 SST_DTYPEP(stkptr, DT_INT);
1182 return 1;
1183 default:
1184 error(84, 3, gbl.lineno, SYMNAME(sptr), CNULL);
1185 SST_DTYPEP(stkptr, DT_INT);
1186 SST_IDP(stkptr, S_EXPR);
1187 return 1;
1188 }
1189 /* NOTREACHED */;
1190
1191 case S_LVALUE:
1192 dtype = SST_DTYPEG(stkptr);
1193 sptr = SST_LSYMG(stkptr);
1194 lval:
1195 SST_CVLENP(stkptr, 0);
1196 if (dtype == 0)
1197 interr("mkexpr1: 0 dtype", dtype, 3);
1198 else if ((DTY(dtype) == TY_STRUCT) || (DTY(dtype) == TY_UNION) ||
1199 ((DTY(dtype) == TY_DERIVED)))
1200 return 1;
1201 else if (DTY(dtype) == TY_CHAR || DTY(dtype) == TY_NCHAR) {
1202 if (!DTY(dtype + 1) ||
1203 !A_ALIASG(DTY(dtype + 1))) { /* nonconstant char length */
1204 SST_CVLENP(stkptr, size_ast(sptr, dtype));
1205 }
1206 return 1;
1207 } else if (DT_ISBASIC(dtype))
1208 ;
1209 else if (DTY(dtype) == TY_ARRAY) {
1210 /* base - element handled separately; don't use 'TY_ISVEC' here!
1211 * We don't know the intended usage of this expression; it still
1212 * could be an argument and we want to allow character arrays
1213 * as arguments.
1214 */
1215 int dd;
1216 dd = DTY(dtype + 1);
1217 if (DTY(dd) == TY_STRUCT) {
1218 error83(DTY(dd));
1219 SST_DTYPEP(stkptr, DDTG(dtype));
1220 return 1;
1221 }
1222 if ((DTY(dd) == TY_CHAR || DTY(dd) == TY_NCHAR)) {
1223 if (!DTY(dd + 1) ||
1224 !A_ALIASG(DTY(dd + 1))) { /* nonconstant char length */
1225 SST_CVLENP(stkptr, size_ast(sptr, dd));
1226 }
1227 }
1228 } else
1229 interr("mkexpr1: bad dtype", dtype, 3);
1230
1231 if (DTY(dtype) != TY_ARRAY) {
1232 shape = 0;
1233 } else {
1234 shape = A_SHAPEG(SST_ASTG(stkptr));
1235 }
1236 SST_DTYPEP(stkptr, dtype);
1237 SST_IDP(stkptr, S_EXPR);
1238 SST_SHAPEP(stkptr, shape);
1239 return 1;
1240
1241 case S_LOGEXPR: /* ILMs have been written */
1242 case S_EXPR: /* ILMs have been written */
1243 return 1;
1244
1245 case S_VAL:
1246 case S_REF:
1247 /* %val(x) -- shouldn't appear here */
1248 errsev(53);
1249 SST_IDP(stkptr, S_EXPR);
1250 return 1;
1251 case S_STAR:
1252 /* (*) -- shouldn't appear here */
1253 default:
1254 interr("mkexpr1: bad id", SST_IDG(stkptr), 3);
1255 return 1;
1256 }
1257 }
1258
1259 /** \brief Same as mkexpr1(), but the expression is the target of a pointer
1260 assignment. Must handle ST_PROCs as identifiers; otherwise, just
1261 call mkexpr1().
1262 */
1263 int
mkexpr2(SST * stkptr)1264 mkexpr2(SST *stkptr)
1265 {
1266 int dt;
1267 int sptr;
1268
1269 switch (SST_IDG(stkptr)) {
1270 case S_IDENT:
1271 sptr = SST_SYMG(stkptr);
1272 switch (STYPEG(sptr)) {
1273 case ST_PROC:
1274 sptr = ref_object(sptr);
1275 SST_DTYPEP(stkptr, DTYPEG(sptr));
1276 SST_ASTP(stkptr, mk_id(sptr));
1277 SST_SHAPEP(stkptr, A_SHAPEG(SST_ASTG(stkptr)));
1278 SST_CVLENP(stkptr, 0);
1279 dt = DDTG(DTYPEG(sptr)); /* element dtype record */
1280 if ((DTY(dt) == TY_CHAR || DTY(dt) == TY_NCHAR) && ADJLENG(sptr)) {
1281 SST_CVLENP(stkptr, size_ast(sptr, dt));
1282 }
1283 return 1;
1284 default:;
1285 }
1286 }
1287 return mkexpr1(stkptr);
1288 }
1289
1290 /** \brief Convert all sizes of logicals and integers to 4 byte versions.
1291 */
1292 void
mklogint4(SST * stkptr)1293 mklogint4(SST *stkptr)
1294 {
1295 }
1296
1297 /** \brief Check for legal variable to be assigned to.
1298 \param stkptr the variable to check
1299 \param stmt_type type of statement we are processing, from the table below
1300 \return The sptr of the variable if \a stmt_type indicates an index
1301 variable.<br>
1302 Otherwise the ILM pointer to address expression for the destination.<br>
1303 Zero is returned for cases where we want to avoid assignment code
1304 generation.
1305
1306 Possible values for \a stmt_type:
1307 <pre>
1308 0 - Do index var
1309 1 - Assignment statement
1310 2 - Data statement
1311 3 - LOC reference
1312 4 - Implied do index var
1313 5 - Forall index var
1314 </pre>
1315 */
1316 int
mklvalue(SST * stkptr,int stmt_type)1317 mklvalue(SST *stkptr, int stmt_type)
1318 {
1319 int dcld, lval;
1320 DTYPE dtype;
1321 SPTR sptr;
1322 bool is_index_var = stmt_type == 0 || stmt_type == 4 || stmt_type == 5;
1323
1324 lval = 0;
1325 SST_CVLENP(stkptr, 0);
1326 switch (SST_IDG(stkptr)) {
1327 case S_IDENT: /* Scalar or whole array references */
1328 // DO CONCURRENT and FORALL index vars are construct entities that are
1329 // not visible outside of the construct. If sptr is external to the
1330 // construct, get a new var. Use an explicit type if there is one.
1331 sptr = SST_SYMG(stkptr);
1332 SST_SHAPEP(stkptr, 0);
1333 if (stmt_type == 0 && sem.doconcurrent_symavl) {
1334 dtype = sem.doconcurrent_dtype ? sem.doconcurrent_dtype : DTYPEG(sptr);
1335 dcld = sem.doconcurrent_dtype || DCLDG(sptr);
1336 if (sptr < sem.doconcurrent_symavl)
1337 sptr = insert_sym(sptr);
1338 DTYPEP(sptr, dtype);
1339 DCLDP(sptr, dcld);
1340 DCLCHK(sptr);
1341 } else if (stmt_type == 5) {
1342 int doif = sem.doif_depth;
1343 dtype = DI_FORALL_DTYPE(doif) ? DI_FORALL_DTYPE(doif) : DTYPEG(sptr);
1344 dcld = DI_FORALL_DTYPE(doif) || DCLDG(sptr);
1345 if (sptr < DI_FORALL_SYMAVL(doif))
1346 sptr = insert_sym(sptr);
1347 DTYPEP(sptr, dtype);
1348 DCLDP(sptr, dcld);
1349 DCLCHK(sptr);
1350 }
1351
1352 switch (STYPEG(sptr)) {
1353 case ST_ENTRY:
1354 if (stmt_type == 3) {
1355 SST_ASTP(stkptr, mk_id(sptr));
1356 return 1;
1357 }
1358 if (gbl.rutype == RU_FUNC && stmt_type != 2) {
1359 dtype = DTYPEG(sptr); /* use dtype of entry, not func val */
1360 sptr = ref_entry(sptr);
1361 DTYPEP(sptr, dtype);
1362 } else {
1363 if (is_index_var)
1364 goto do_error;
1365 if (stmt_type == 2)
1366 sem.dinit_error = TRUE;
1367 error(72, 3, gbl.lineno, "entry point", SYMNAME(sptr));
1368 }
1369 break;
1370
1371 case ST_UNKNOWN:
1372 case ST_IDENT:
1373 STYPEP(sptr, ST_VAR);
1374 case ST_VAR:
1375 if (POINTERG(sptr) && SDSCG(sptr) == 0 && !F90POINTERG(sptr)) {
1376 if (SCG(sptr) == SC_NONE)
1377 SCP(sptr, SC_BASED);
1378 get_static_descriptor(sptr);
1379 get_all_descriptors(sptr);
1380 }
1381 break;
1382
1383 case ST_STRUCT:
1384 struct_error:
1385 if (flg.standard)
1386 error(179, 2, gbl.lineno, SYMNAME(sptr), CNULL);
1387 if (stmt_type == 2 || is_index_var) {
1388 sem.dinit_error = TRUE;
1389 if (is_index_var)
1390 goto do_error;
1391 error(150, 3, gbl.lineno, SYMNAME(sptr), CNULL);
1392 }
1393 break;
1394
1395 case ST_ARRAY:
1396 if (is_index_var)
1397 goto do_error;
1398 else if (stmt_type == 2 && DTYG(SST_DTYPEG(stkptr)) == TY_STRUCT)
1399 goto struct_error;
1400 else if (stmt_type == 1 && SCG(sptr) == SC_DUMMY && ASUMSZG(sptr))
1401 error(84, 3, gbl.lineno, SYMNAME(sptr),
1402 "- extent of assumed size array is unknown");
1403 break;
1404
1405 case ST_PD:
1406 case ST_GENERIC:
1407 case ST_INTRIN:
1408 if (!EXPSTG(sptr)) {
1409 sptr = newsym(sptr);
1410 STYPEP(sptr, ST_VAR);
1411 /* need storage class (local) */
1412 sem_set_storage_class(sptr);
1413 break;
1414 }
1415 /* ERROR, intrinsic is frozen - give lvalue valid data type */
1416 if (STYPEG(sptr) == ST_GENERIC && DTYPEG(sptr) == DT_NONE) {
1417 if (GSAMEG(sptr))
1418 /* Specific of same name so use its data type */
1419 DTYPEP(sptr, DTYPEG(GSAMEG(sptr)));
1420 else
1421 setimplicit(sptr);
1422 }
1423 // fall through
1424
1425 case ST_PROC: /* Function/intrinsic reference used as an lvalue */
1426 if (stmt_type == 3) {
1427 SST_ASTP(stkptr, mk_id(sptr));
1428 return 1;
1429 }
1430 if (is_index_var)
1431 goto do_error;
1432 error(72, 3, gbl.lineno, "external procedure", SYMNAME(sptr));
1433 if (stmt_type == 2)
1434 sem.dinit_error = TRUE;
1435 return (0);
1436
1437 case ST_USERGENERIC:
1438 error(84, 3, gbl.lineno, SYMNAME(sptr),
1439 "- attempt to use a generic subprogram name as a variable");
1440 SST_DTYPEP(stkptr, DT_INT);
1441 return 1;
1442
1443 default:
1444 error(84, 3, gbl.lineno, SYMNAME(sptr), CNULL);
1445 SST_DTYPEP(stkptr, DT_INT);
1446 SST_ASTP(stkptr, mk_id(sptr));
1447 SST_SHAPEP(stkptr, A_SHAPEG(SST_ASTG(stkptr)));
1448 return sptr;
1449 }
1450
1451 if (sem.parallel || sem.task || sem.target || sem.teams
1452 || sem.orph
1453 ) {
1454 if (stmt_type == 0) {
1455 switch (DI_ID(sem.doif_depth)) {
1456 case DI_TARGTEAMSDIST:
1457 case DI_TEAMSDIST:
1458 case DI_TARGTEAMSDISTPARDO:
1459 case DI_TEAMSDISTPARDO:
1460 case DI_DISTRIBUTE:
1461 case DI_DISTPARDO:
1462 case DI_SIMD:
1463 case DI_PARDO:
1464 case DI_TASKLOOP:
1465 /* parallel and those work-sharing do variables must be private */
1466 sptr = decl_private_sym(sptr);
1467 if (SCG(sptr) != SC_PRIVATE) {
1468 /*
1469 * the symbol created isn't private presumably
1470 * because there was an explicit shared declaration
1471 * of the index variable on the parallel do.
1472 * Just insert a new symbol (ST_UNKNOWN) and
1473 * declare as private. Another solution to this
1474 * problem is to push 2 par scopes when the
1475 * parallel do is processed by semsmp.c.
1476 */
1477 int new;
1478 new = insert_sym(sptr);
1479 DTYPEP(new, DTYPEG(sptr));
1480 sptr = decl_private_sym(new);
1481 }
1482 break;
1483 case DI_PDO:
1484 /* parallel work-sharing do variables must be private */
1485 sptr = decl_private_sym(sptr);
1486 break;
1487 case DI_TASK:
1488 /* do variables within tasks must be private */
1489 sptr = decl_private_sym(sptr);
1490 break;
1491 case DI_ATOMIC_CAPTURE:
1492 /* no special handling for atomic capture. */
1493 break;
1494 default:
1495 /* a sequential do index variable within a parallel region,
1496 * if otherwise shared based on default rules, must be
1497 * private.
1498 * First, call sem_check_scope() to see if was explicitly
1499 * declared shared or private -- if the returned symbol has
1500 * scope 0, then must create a private copy.
1501 */
1502 sem.ignore_default_none = TRUE;
1503 sptr = sem_check_scope(sptr, sptr);
1504 sem.ignore_default_none = FALSE;
1505 if (sem.parallel || sem.task) {
1506 sptr = decl_private_sym(sptr);
1507 } else if (SCOPEG(sptr) == gbl.currsub) {
1508 sptr = decl_private_sym(sptr);
1509 } else if (SCOPEG(sptr) == stb.curr_scope) {
1510 sptr = decl_private_sym(sptr);
1511 #if DEBUG
1512 if (XBIT(69, 0x80000000))
1513 error(155, 2, gbl.lineno,
1514 "DO variable in contained procedure is PRIVATE -",
1515 SYMNAME(sptr));
1516 #endif
1517 }
1518 #if DEBUG
1519 else if (SCG(sptr) != SC_PRIVATE) {
1520 if (XBIT(69, 0x80000000))
1521 error(155, 2, gbl.lineno, "DO variable is not PRIVATE -",
1522 SYMNAME(sptr));
1523 }
1524 #endif
1525 break;
1526 }
1527 } else if (stmt_type == 4) {
1528 /* Implied do variables must be private */
1529 /* We currently have a bug where if a private variable is
1530 * created, it will not be reflected in any of the ILMs which
1531 * have already been generated for the I/O items referencing
1532 * the do variable. For now, don't create a new symbol; just
1533 * use whatever symbol is in scope -- at least the I/O
1534 * code is within a critical section and the user can just
1535 * add a PRIVATE clause as a workaround.
1536 sptr = decl_private_sym(sptr);
1537 */
1538 ;
1539 } else if (stmt_type == 5) {
1540 /* Forall variables must be private */
1541 /* if variable is already private, create another
1542 * private sptr for this forall. We call pop_sym(sptr)
1543 * hash table in check_no_scope_sptr()
1544 * once it exists forall construct.
1545 * !omp parallel private(i)
1546 * print *, i
1547 * forall(i=1:N) b(i) = k(i)
1548 * print *, i
1549 * the value of i before and after forall should be the same
1550 * i inside forall has it forall scope.
1551 */
1552 if (SCG(sptr) == SC_PRIVATE)
1553 sptr = insert_sym(sptr);
1554 sptr = decl_private_sym(sptr);
1555 }
1556 } else if (stmt_type == 0 && DI_ID(sem.doif_depth) == DI_PDO) {
1557 sptr = decl_private_sym(sptr);
1558 } else if (stmt_type == 0 && (DI_ID(sem.doif_depth) == DI_SIMD)) {
1559 sptr = decl_private_sym(sptr);
1560 }
1561 /* Induction variables can be inside of struct frame pointer that is passed
1562 by caller subroutine. To use them, the compiler needs to extract them inside
1563 of the loop. It might the compiler to think there are additional codes
1564 between the loops even though the loops are tightly nested. In this case, the
1565 compiler might not generate parallel code. Here, we create a new variable
1566 with the same name of induction variables.
1567 */
1568 if (stmt_type == 0 && flg.smp && (SCG(sptr) != SC_PRIVATE) &&
1569 sem.expect_cuf_do ) {
1570 int newsptr;
1571 newsptr = insert_sym(sptr);
1572 DCLDP(newsptr, TRUE);
1573 DTYPEP(newsptr, DTYPEG(sptr));
1574 STYPEP(newsptr, STYPEG(sptr));
1575 sptr = newsptr;
1576 sem.index_sym_to_pop = newsptr;
1577 }
1578
1579 sptr = ref_object(sptr);
1580 SST_DTYPEP(stkptr, DTYPEG(sptr));
1581 dtype = DDTG(DTYPEG(sptr)); /* element dtype record */
1582 if (stmt_type == 1) {
1583 DOCHK(sptr);
1584 }
1585 SST_ASTP(stkptr, mk_id(sptr));
1586 SST_SHAPEP(stkptr, A_SHAPEG(SST_ASTG(stkptr)));
1587 if ((DTY(dtype) == TY_CHAR || DTY(dtype) == TY_NCHAR) && ADJLENG(sptr)) {
1588 SST_CVLENP(stkptr, size_ast(sptr, dtype));
1589 }
1590 if (stmt_type == 3) {
1591 int subs[MAXDIMS], numdim, i, ast;
1592 ADSC *ad;
1593 if (SCG(sptr) == SC_DUMMY && ASSUMSHPG(sptr)) {
1594 ad = AD_DPTR(DTYPEG(sptr));
1595 numdim = AD_NUMDIM(ad);
1596 for (i = 0; i < numdim; i++) {
1597 subs[i] = AD_LWBD(ad, i);
1598 if (subs[i] == 0 || STYPEG(subs[i]) != ST_CONST) {
1599 subs[i] = AD_LWAST(ad, i);
1600 }
1601 }
1602 ast = SST_ASTG(stkptr);
1603 ast = mk_subscr(ast, subs, numdim, dtype);
1604 SST_ASTP(stkptr, ast);
1605 } else if (POINTERG(sptr) && DTY(DTYPEG(sptr)) == TY_ARRAY) {
1606 ad = AD_DPTR(DTYPEG(sptr));
1607 numdim = AD_NUMDIM(ad);
1608 for (i = 0; i < numdim; i++) {
1609 subs[i] = AD_LWAST(ad, i);
1610 }
1611 ast = SST_ASTG(stkptr);
1612 ast = mk_subscr(ast, subs, numdim, dtype);
1613 SST_ASTP(stkptr, ast);
1614 }
1615 }
1616 break;
1617
1618 case S_LVALUE:
1619 /*
1620 * We have any combination of the following: 1) subscripted array,
1621 * 2) char substring, 3) member ref.
1622 * These references are disallowed as DO index variables.
1623 */
1624 sptr = SST_LSYMG(stkptr);
1625 lval = SST_ASTG(stkptr);
1626 if (is_index_var) {
1627 if (STYPEG(sptr) != ST_VAR)
1628 goto do_error;
1629 return sptr; /* SST_OPTYPE field is correct */
1630 }
1631
1632 /* If LOC applied to an array section, build a new A_SUBSCR
1633 * replacing triples with the triplet lbound */
1634 if (stmt_type == 3) {
1635 if (A_TYPEG(lval) == A_SUBSCR) {
1636 int i;
1637 int asd;
1638 int ast = lval;
1639 int subs[MAXDIMS] = {0};
1640 LOGICAL array_section = FALSE;
1641
1642 asd = A_ASDG(ast);
1643 for (i = 0; i < (int)(ASD_NDIM(asd)); ++i) {
1644 int ss = ASD_SUBS(asd, i);
1645 if (A_TYPEG(ASD_SUBS(asd, i)) == A_TRIPLE) {
1646 subs[i] = A_LBDG(ASD_SUBS(asd, i));
1647 array_section = TRUE;
1648 } else {
1649 subs[i] = ASD_SUBS(asd, i);
1650 }
1651 }
1652 if (array_section) {
1653 ast = mk_subscr(A_LOPG(ast), subs, ASD_NDIM(asd), A_DTYPEG(ast));
1654 SST_ASTP(stkptr, ast);
1655 }
1656 } else if (A_TYPEG(lval) == A_MEM && DTY(A_DTYPEG(lval)) == TY_ARRAY &&
1657 POINTERG((sptr = memsym_of_ast(lval)))) {
1658 int subs[MAXDIMS], numdim, i, ast;
1659 ADSC *ad;
1660 ad = AD_DPTR(DTYPEG(sptr));
1661 numdim = AD_NUMDIM(ad);
1662 for (i = 0; i < numdim; i++) {
1663 subs[i] = check_member(lval, AD_LWAST(ad, i));
1664 }
1665 ast = mk_subscr(lval, subs, numdim, DTY(DTYPEG(sptr) + 1));
1666 SST_ASTP(stkptr, ast);
1667 }
1668 }
1669
1670 /* Catch structure references in DATA stmts */
1671 if (stmt_type == 2 && DTY(SST_DTYPEG(stkptr)) == TY_STRUCT) {
1672 sem.dinit_error = TRUE;
1673 error(150, 3, gbl.lineno, SYMNAME(sptr), CNULL);
1674 }
1675
1676 if (DTY(SST_DTYPEG(stkptr)) == TY_ARRAY && !SST_SHAPEG(stkptr))
1677 SST_SHAPEP(stkptr, mkshape((int)SST_DTYPEG(stkptr)));
1678 dtype = DDTG(DTYPEG(sptr)); /* element dtype record */
1679 if ((DTY(dtype) == TY_CHAR || DTY(dtype) == TY_NCHAR) && ADJLENG(sptr)) {
1680 SST_CVLENP(stkptr, size_ast(sptr, dtype));
1681 }
1682 break;
1683
1684 case S_CONST:
1685 /* If TEMP has value then constant was a PARAMETER (so get name) */
1686 if (is_index_var)
1687 goto do_error;
1688 if (SST_ERRSYMG(stkptr) && STYPEG(SST_SYMG(stkptr)) == ST_PARAM)
1689 error(33, 3, gbl.lineno, SYMNAME(SST_ERRSYMG(stkptr)), CNULL);
1690 else
1691 error(33, 3, gbl.lineno, prtsst(stkptr), CNULL);
1692 if (stmt_type == 2)
1693 sem.dinit_error = TRUE;
1694 else if (stmt_type == 3)
1695 return (0);
1696 break;
1697
1698 case S_EXPR:
1699 if (is_index_var)
1700 goto do_error;
1701 if (stmt_type == 3)
1702 errsev(52);
1703 else {
1704 /* For now assume left side was ref to external procedure */
1705 sptr = SST_ERRSYMG(stkptr);
1706 if (!sptr)
1707 sptr = getbase((int)SST_ASTG(stkptr));
1708 error(72, 3, gbl.lineno, "external procedure", SYMNAME(sptr));
1709 /*
1710 * (f21763) attempt to avoid any further errors/ICEs for the symbol,
1711 * just re-classify the symbol as a 'var' -- if resetting causes
1712 * worse errors down-stream, just delete thie STYPEP and set the
1713 * above error to 'fatal'
1714 */
1715 STYPEP(sptr, ST_VAR);
1716 if (stmt_type == 2)
1717 sem.dinit_error = TRUE;
1718 }
1719 return (0);
1720
1721 case S_ACONST:
1722 if (is_index_var)
1723 goto do_error;
1724 error(33, 3, gbl.lineno, SYMNAME(SST_SYMG(stkptr)), CNULL);
1725 if (stmt_type == 2)
1726 sem.dinit_error = TRUE;
1727 else if (stmt_type == 3)
1728 return (0);
1729 break;
1730
1731 default:
1732 interr("mklvalue: Unexpected semantic stack entry id", SST_IDG(stkptr), 3);
1733 break;
1734
1735 } /* End of switch on semantic stack id */
1736
1737 if (is_index_var) {
1738 if (stmt_type == 5 && !PRIVATEG(sptr) && INTENTG(sptr) == 1)
1739 ; /* we always create a new index variable for forall statement and never
1740 set ASSNG flag */
1741 else
1742 set_assn(sptr);
1743 } else if (stmt_type == 1 && !POINTERG(lval ? memsym_of_ast(lval) : sptr)) {
1744 if (!lval) {
1745 set_assn(sptr);
1746 }
1747 else
1748 set_assn(sym_of_ast(lval));
1749 } else if (stmt_type == 3)
1750 ADDRTKNP(sptr, 1);
1751 if (is_index_var) {
1752 /* DOCHK(sptr); perform this check in do_begin() */
1753 return (sptr);
1754 }
1755 return 1;
1756
1757 do_error:
1758 errsev(106);
1759 sptr = getccsym('.', 0, ST_VAR);
1760 DTYPEP(sptr, DT_INT);
1761 return (sptr);
1762 }
1763
1764 static INT
const_xtoi(INT conval1,INT cnt,int dtype)1765 const_xtoi(INT conval1, INT cnt, int dtype)
1766 {
1767 union {
1768 DBLINT64 i64;
1769 BIGINT64 bgi;
1770 } u;
1771
1772 u.bgi = 1;
1773 if (u.i64[0]) {
1774 /* little endian */
1775 u.i64[0] = CONVAL2G(cnt);
1776 u.i64[1] = CONVAL1G(cnt);
1777 } else {
1778 u.i64[0] = CONVAL1G(cnt);
1779 u.i64[1] = CONVAL2G(cnt);
1780 }
1781 return _xtok(conval1, u.bgi, dtype);
1782 }
1783
1784 /** \brief Link parents for type extension by adding parent as a member to
1785 the type.
1786 */
1787 void
link_parents(STSK * stsk,int sptr)1788 link_parents(STSK *stsk, int sptr)
1789 {
1790 int sptr1;
1791 int tag;
1792 if (!sptr)
1793 return;
1794 /* Need to call insert_sym() and use the new symbol because a component in
1795 * another derived type can have the same name as the derived type we're
1796 * processing. Otherwise, we may have the wrong symbol for our parent
1797 * symbol in the type extension. Also a derived type name can be overloaded by
1798 * a generic interface.
1799 */
1800 sptr1 = insert_sym(sptr);
1801 STYPEP(sptr1, ST_MEMBER);
1802 DTYPEP(sptr1, DTYPEG(sptr));
1803 /* for the parent member, we just mark it with the PARENT flag assigned
1804 * to itself since this also works for base types.
1805 */
1806 PARENTP(sptr1, sptr1);
1807 tag = DTY(DTYPEG(sptr) + 3);
1808 PRIVATEP(sptr1, PRIVATEG(tag));
1809 DINITP(sptr1, DINITG(sptr));
1810 if (DINITG(sptr))
1811 DINITP(stsk->sptr, DINITG(sptr));
1812 link_members(stsk, sptr1);
1813 }
1814
1815 /** \brief Check parents of type extension for duplicate symbols.
1816
1817 To Do: Take into account attributes such as access (private/public)
1818 and overridable.
1819 */
1820 int
check_parent(int sptr1,int sptr2)1821 check_parent(int sptr1, int sptr2)
1822 {
1823 int sptr3;
1824 for (sptr3 = DTY(DTYPEG(sptr2) + 1); sptr3 != NOSYM; sptr3 = SYMLKG(sptr3)) {
1825 if (NMPTRG(sptr1) == NMPTRG(sptr3)) {
1826 return 0;
1827 } else if (PARENTG(sptr3) == sptr3) {
1828 int rslt = check_parent(sptr1, sptr3);
1829 if (!rslt)
1830 return 0;
1831 }
1832 }
1833 return 1;
1834 }
1835
1836 /** \brief Link together members of a structure.
1837 \param stsk the structure stack item representing the structure to which
1838 members are added
1839 \param sptr points to a list of new members linked via symlk
1840
1841 The new member list is added to the end of the existing member list watching
1842 out for duplicate member names.
1843 */
1844 void
link_members(STSK * stsk,int sptr)1845 link_members(STSK *stsk, int sptr)
1846 {
1847 int dtype;
1848 int sptr1, sptr2, sptr_end;
1849 int count, last;
1850 int member_access;
1851 int entity_access;
1852
1853 dtype = stsk->dtype;
1854
1855 assert((DTY(dtype) == TY_STRUCT || DTY(dtype) == TY_UNION ||
1856 DTY(dtype) == TY_DERIVED),
1857 "link_members, unexp. dtype", dtype, 3);
1858 /*
1859 * loop thru list of symbols to be added and add them to the LIFO
1860 * list which represents a flattened list of all the members which
1861 * occur at the same level. Recall that we create special members
1862 * for each union and for each map, where each map is represented
1863 * by a structure and belongs to a union which contains as members
1864 * all maps. the LIFO is created so that we can easily search for
1865 * conflicts.
1866 */
1867 sptr_end = stsk->last; /* current end of LIFO for struct */
1868 member_access = (stsk->mem_access == 'v');
1869 entity_access = get_entity_access();
1870 for (sptr1 = sptr; sptr1 != NOSYM; sptr1 = SYMLKG(sptr1)) {
1871
1872 /* loop thru members (LIFO) currently in the structure */
1873 for (sptr2 = sptr_end; sptr2 != NOSYM; sptr2 = VARIANTG(sptr2)) {
1874 if (NMPTRG(sptr1) == NMPTRG(sptr2))
1875 error(138, 2, gbl.lineno, SYMNAME(sptr1), CNULL);
1876 if (DTY(DTYPEG(sptr2)) == TY_DERIVED && PARENTG(sptr2) == sptr2 &&
1877 PARENTG(sptr2) && !check_parent(sptr1, sptr2)) {
1878 /* type extension */
1879 error(138, 3, gbl.lineno, SYMNAME(sptr1), CNULL);
1880 }
1881 }
1882 VARIANTP(sptr1, sptr_end); /* add new member to LIFO */
1883
1884 PRIVATEP(sptr1,
1885 (member_access && entity_access != 'u') ||
1886 (!member_access && entity_access == 'v'));
1887 ENCLDTYPEP(sptr1, dtype);
1888 sptr_end = sptr1; /* current end */
1889 }
1890 stsk->last = sptr_end; /* new last */
1891 /*
1892 * loop thru all symbols which currently belong to the structure.
1893 * Find the last member so that the sptr list is added to the end
1894 * of the structure.
1895 */
1896 count = 0;
1897 if ((sptr2 = DTY(dtype + 1)) == NOSYM)
1898 /* first time members are added */
1899 DTY(dtype + 1) = sptr;
1900 else {
1901 /* find end of members, add list to the end */
1902 do {
1903 sptr_end = sptr1 = sptr2;
1904 sptr2 = SYMLKG(sptr2);
1905 } while (sptr2 != NOSYM);
1906 SYMLKP(sptr_end, sptr);
1907 }
1908 }
1909
1910 /* called if RESULTG(sptr) is set.
1911 * this must be a recursive reference; find the matching entry point */
1912 static int
test_really_an_entry(int sptr)1913 test_really_an_entry(int sptr)
1914 {
1915 int ent;
1916 /* scan all entries. NOTE: gbl.entries not yet set */
1917 for (ent = gbl.currsub; ent > NOSYM; ent = SYMLKG(ent)) {
1918 if (FVALG(ent) == sptr) {
1919 return ent;
1920 }
1921 }
1922 if (sptr == FVALG(gbl.outersub)) {
1923 /* recursive call to host */
1924 return gbl.outersub;
1925 }
1926 /* no such entry point found, must be an error */
1927 interr("dangling RESULT variable reference", sptr, 3);
1928 return 0;
1929 } /* test_really_an_entry */
1930
1931 /** \brief Make a var ref of the form: `<var primary> ( [<ssa list>] )`
1932
1933 Determine if a function call, array reference, or substring reference, and
1934 generate appropriate ILMs, shapes, data types. \a stktop is input and
1935 output.
1936 */
1937 int
mkvarref(SST * stktop,ITEM * list)1938 mkvarref(SST *stktop, ITEM *list)
1939 {
1940 int sptr, dtype, entry;
1941 int ast;
1942 ITEM *list_tmp, *list2;
1943
1944 switch (SST_IDG(stktop)) {
1945
1946 case S_ACONST:
1947 /* I don't think we should get here anymore, but if we do,
1948 give error and go ahead and process. Leave code in for now
1949 - it may be needed later for processing named constants */
1950 interr("mkvarref: array constructor seen", 0, 3);
1951 sptr = init_sptr_w_acl(0, SST_ACLG(stktop));
1952 mkident(stktop);
1953 goto varref_ident;
1954
1955 case S_DERIVED:
1956 sptr = SST_SYMG(stktop);
1957 dtype = DTYPEG(sptr);
1958 /* fall through */
1959 case S_IDENT: /* dtype has not been set in semantic stack yet */
1960 sptr = SST_SYMG(stktop);
1961 varref_ident:
1962 switch (STYPEG(sptr)) {
1963 case ST_UNKNOWN:
1964 case ST_IDENT:
1965 dtype = DTYPEG(sptr);
1966 /* A non-array identifier used with (<ssa list>) notation. Check
1967 * for a character substring otherwise it must be a function call.
1968 */
1969 if (IS_CHAR_TYPE(DTYG(dtype))) {
1970 if (list && list != ITEM_END && SST_IDG(list->t.stkp) == S_TRIPLE) {
1971 STYPEP(sptr, ST_VAR);
1972 SST_ASTP(stktop, mk_id(sptr));
1973 chksubstr(stktop, list);
1974 SST_SHAPEP(stktop, A_SHAPEG(SST_ASTG(stktop)));
1975 return 1;
1976 }
1977 }
1978 if (RESULTG(sptr) && (entry = test_really_an_entry(sptr))) {
1979 sptr = entry;
1980 SST_SYMP(stktop, sptr);
1981 goto really_an_entry;
1982 }
1983 /* must be a function reference */
1984 STYPEP(sptr, ST_PROC);
1985 FWDREFP(sptr, 1); /* FS1551, see resolve_fwd_refs() below */
1986 if (SCG(sptr) == SC_DUMMY) {
1987 /* dummy procedure not declared external: */
1988 error(125, 1, gbl.lineno, SYMNAME(sptr), CNULL);
1989 } else /* if (SCG(sptr) == SC_NONE) */
1990 /*
1991 * <var ref> ::= <ident> sets the storage class to SC_LOCAL;
1992 * make it extern.
1993 */
1994 SCP(sptr, SC_EXTERN);
1995 SST_ASTP(stktop, mk_id(sptr));
1996 return func_call(stktop, list);
1997
1998 case ST_VAR:
1999 dtype = DTYPEG(sptr);
2000
2001 if (IS_CHAR_TYPE(DTYG(dtype))) {
2002 SST_ASTP(stktop, mk_id(sptr));
2003 chksubstr(stktop, list);
2004 SST_SHAPEP(stktop, A_SHAPEG(SST_ASTG(stktop)));
2005 return 1;
2006 }
2007 if (RESULTG(sptr) && (entry = test_really_an_entry(sptr))) {
2008 sptr = entry;
2009 SST_SYMP(stktop, sptr);
2010 goto really_an_entry;
2011 }
2012 if (is_procedure_ptr(sptr)) {
2013 return ptrfunc_call(stktop, list);
2014 }
2015 /* subscripts specified for non-array variable */
2016 error(76, 3, gbl.lineno, SYMNAME(sptr), CNULL);
2017 goto add_base;
2018
2019 case ST_PROC:
2020 if (FVALG(sptr) == 0 && DTYPEG(sptr) == 0) {
2021 error(84, 3, gbl.lineno, SYMNAME(sptr),
2022 "- attempt to use a SUBROUTINE as a FUNCTION");
2023 dtype = DT_INT;
2024 SST_IDP(stktop, S_EXPR);
2025 break;
2026 }
2027 if (GSAMEG(sptr)) {
2028 /* generic has same name as specific, treat as generic call */
2029 return generic_func(GSAMEG(sptr), stktop, list);
2030 }
2031 SST_ASTP(stktop, mk_id(sptr));
2032 return func_call(stktop, list);
2033
2034 case ST_USERGENERIC:
2035 return generic_func(sptr, stktop, list);
2036
2037 case ST_ARRAY:
2038 return (ref_array(stktop, list));
2039
2040 case ST_TYPEDEF:
2041 interr("mkvarref: structure constructor seen", 0, 3);
2042 SST_IDP(stktop, S_EXPR);
2043 return 0;
2044
2045 case ST_STRUCT:
2046 if (!sem.dinit_error)
2047 dinit((VAR *)NULL, SST_CLBEGG(stktop));
2048 sem.dinit_error = FALSE;
2049 return (0);
2050 /* ??????
2051 error(76, 3, gbl.lineno, SYMNAME(sptr), CNULL);
2052 goto add_base;
2053 */
2054
2055 case ST_ENTRY:
2056 /* Possible recursive function call */
2057 really_an_entry:
2058 dtype = DTYPEG(sptr);
2059 if ((sptr == gbl.currsub && gbl.rutype == RU_FUNC) ||
2060 (sptr == gbl.outersub && STYPEG(sptr) == ST_ENTRY)) {
2061 if (GSAMEG(sptr))
2062 return generic_func(GSAMEG(sptr), stktop, list);
2063 if (DTYG(dtype) == TY_CHAR || DTYG(dtype) == TY_NCHAR) {
2064 if (list && list != ITEM_END && SST_IDG(list->t.stkp) == S_TRIPLE) {
2065 /* Character substring of character function okay */
2066 SST_ASTP(stktop, mk_id(sptr));
2067 SST_SYMP(stktop, ref_entry(sptr));
2068 chksubstr(stktop, list);
2069 SST_SHAPEP(stktop, A_SHAPEG(SST_ASTG(stktop)));
2070 return 1;
2071 }
2072 }
2073 if (list && SST_ALIASG(stktop) && DTY(dtype) == TY_ARRAY)
2074 return (ref_array(stktop, list));
2075 if (flg.recursive || RECURG(sptr)) {
2076 if (flg.standard && RECURG(sptr) && !RESULTG(sptr)) {
2077 error(155, 2, gbl.lineno, "An explicit RESULT variable should be "
2078 "present for RECURSIVE function",
2079 SYMNAME(sptr));
2080 }
2081 SST_ASTP(stktop, mk_id(sptr));
2082 return func_call(stktop, list);
2083 }
2084 if (list && DTY(dtype) == TY_ARRAY)
2085 return (ref_array(stktop, list));
2086 error(88, 3, gbl.lineno, SYMNAME(sptr), CNULL);
2087 } else { /* illegal use */
2088 switch (gbl.rutype) {
2089 case RU_SUBR:
2090 error(84, 3, gbl.lineno, SYMNAME(sptr),
2091 "- SUBROUTINE name used as function");
2092 break;
2093 case RU_PROG:
2094 error(84, 3, gbl.lineno, SYMNAME(sptr),
2095 "- PROGRAM name used as function");
2096 break;
2097 default:
2098 error(84, 3, gbl.lineno, SYMNAME(sptr), "- used as a function");
2099 break;
2100 }
2101 /* give it a datatype, prevent further errors? */
2102 dtype = DT_INT;
2103 }
2104 sptr = ref_entry(sptr);
2105 add_base:
2106 sptr = ref_object(sptr);
2107 SST_IDP(stktop, S_LVALUE);
2108 SST_LSYMP(stktop, sptr);
2109 SST_ASTP(stktop, mk_id(sptr));
2110 SST_SHAPEP(stktop, A_SHAPEG(SST_ASTG(stktop)));
2111 break;
2112
2113 case ST_STFUNC:
2114 dtype = DTYPEG(sptr);
2115 ref_stfunc(stktop, list);
2116 break;
2117
2118 case ST_INTRIN:
2119 case ST_GENERIC:
2120 dtype = DTYPEG(sptr);
2121 /*
2122 * watch for case where an intrinsic was declared as a character
2123 * variable (array is already handled) and its first reference is
2124 * a substring reference.
2125 */
2126 if (!EXPSTG(sptr) && IS_CHAR_TYPE(DTY(dtype)) && list &&
2127 list != ITEM_END && SST_IDG(list->t.stkp) == S_TRIPLE) {
2128 sptr = newsym(sptr);
2129 STYPEP(sptr, ST_VAR);
2130 sem_set_storage_class(sptr);
2131 SST_SYMP(stktop, sptr);
2132 SST_ASTP(stktop, mk_id(sptr));
2133 chksubstr(stktop, list);
2134 SST_SHAPEP(stktop, A_SHAPEG(SST_ASTG(stktop)));
2135 return 1;
2136 }
2137 ref_intrin(stktop, list);
2138 return 1;
2139
2140 case ST_PD:
2141 dtype = DTYPEG(sptr);
2142 if (!EXPSTG(sptr) && list && list != ITEM_END &&
2143 SST_IDG(list->t.stkp) == S_TRIPLE && IS_CHAR_TYPE(DTY(dtype))) {
2144 sptr = newsym(sptr);
2145 STYPEP(sptr, ST_VAR);
2146 sem_set_storage_class(sptr);
2147 SST_SYMP(stktop, sptr);
2148 SST_ASTP(stktop, mk_id(sptr));
2149 chksubstr(stktop, list);
2150 SST_SHAPEP(stktop, A_SHAPEG(SST_ASTG(stktop)));
2151 return 1;
2152 }
2153 ref_pd(stktop, list);
2154 return 1;
2155
2156 default:
2157 dtype = DTYPEG(sptr);
2158 /* illegal use */
2159 SST_IDP(stktop, S_EXPR);
2160 error(84, 3, gbl.lineno, SYMNAME(sptr), CNULL);
2161 break;
2162 }
2163 SST_DTYPEP(stktop, dtype);
2164 return 1;
2165
2166 case S_LVALUE:
2167 /* this must be array or substring reference */
2168 ast = SST_ASTG(stktop);
2169 switch (A_TYPEG(ast)) {
2170 case A_ID:
2171 case A_LABEL:
2172 case A_ENTRY:
2173 case A_SUBSCR:
2174 case A_SUBSTR:
2175 case A_MEM:
2176 sptr = memsym_of_ast(ast);
2177 dtype = DTYPEG(sptr);
2178 if (CLASSG(sptr)) {
2179 sptr = BINDG(sptr);
2180 if (VTOFFG(sptr)) {
2181 int ss;
2182 ss = sym_skip_construct(SST_SYMG(stktop));
2183 SST_SYMP(stktop, ss);
2184 if (A_TYPEG(ast) == A_MEM && A_TYPEG(A_PARENTG(ast)) == A_SUBSCR) {
2185 int ast2, asd, ndim, i;
2186 ast2 = A_PARENTG(ast);
2187 asd = A_ASDG(ast2);
2188 ndim = ASD_NDIM(asd);
2189 for (i = 0; i < ndim; i++) {
2190 if (A_TYPEG(ASD_SUBS(asd, i)) == A_TRIPLE) {
2191 /* Subscript has a triple, so remove it from the
2192 * member portion of the expression to prevent
2193 * an invalid ast type during lowering.
2194 */
2195 A_PARENTP(ast, A_LOPG(ast2));
2196 break;
2197 }
2198 }
2199 }
2200 return func_call(stktop, list);
2201 }
2202 }
2203 }
2204 sptr = SST_LSYMG(stktop);
2205 dtype = SST_DTYPEG(stktop);
2206
2207 if (IS_CHAR_TYPE(DTY(dtype))) {
2208 /* substring */
2209 if (A_TYPEG(ast) == A_SUBSTR)
2210 error(82, 3, gbl.lineno, SYMNAME(sptr), CNULL);
2211 else
2212 chksubstr(stktop, list);
2213 } else if (DTY(dtype) == TY_ARRAY) {
2214 int ddtype;
2215 ddtype = DTY(dtype + 1);
2216 if (ast && A_TYPEG(ast) == A_SUBSCR) {
2217 if (IS_CHAR_TYPE(DTY(ddtype))) {
2218 chksubstr(stktop, list);
2219 } else {
2220 /* double subscripting with vector subscripts */
2221 error(75, 3, gbl.lineno, SYMNAME(sptr), CNULL);
2222 }
2223 } else if (ast && A_TYPEG(ast) == A_MEM) {
2224 int dtmem;
2225 dtmem = DTYPEG(A_SPTRG(A_MEMG(ast)));
2226
2227 if (IS_CHAR_TYPE(DTY(dtmem)))
2228 chksubstr(stktop, list);
2229 else
2230 ref_array(stktop, list);
2231 } else {
2232 ref_array(stktop, list);
2233 }
2234 } else if (STYPEG(sptr) == ST_MEMBER && is_procedure_ptr(sptr)) {
2235 return ptrfunc_call(stktop, list);
2236 } else
2237 error(75, 3, gbl.lineno, SYMNAME(sptr), CNULL);
2238 return 1;
2239
2240 case S_CONST:
2241 dtype = SST_DTYPEG(stktop);
2242 if (list && list != ITEM_END && (DTY(dtype) == TY_NCHAR)) {
2243 SST *sp;
2244 sp = list->t.stkp;
2245 if (SST_IDG(sp) != S_TRIPLE || SST_IDG(SST_E3G(sp)) != S_NULL ||
2246 list->next != ITEM_END) {
2247 INT val[2];
2248 error(75, 3, gbl.lineno, "'constant'", CNULL);
2249 SST_DTYPEP(stktop, DT_NCHAR);
2250 val[0] = getstring(" ", 1);
2251 val[1] = 0;
2252 SST_IDP(stktop, S_CONST);
2253 SST_CVALP(stktop, getcon(val, DT_NCHAR));
2254 SST_ASTP(stktop, mk_cnst(SST_CVALG(stktop)));
2255 SST_SHAPEP(stktop, 0);
2256 break;
2257 }
2258 ch_substring(stktop, SST_E1G(sp), SST_E2G(sp));
2259 break;
2260 }
2261 if (list && list != ITEM_END && (DTY(dtype) == TY_CHAR)) {
2262 SST *sp;
2263 sp = list->t.stkp;
2264 if (SST_IDG(sp) != S_TRIPLE || SST_IDG(SST_E3G(sp)) != S_NULL ||
2265 list->next != ITEM_END) {
2266 error(75, 3, gbl.lineno, "'constant'", CNULL);
2267 SST_DTYPEP(stktop, DT_CHAR);
2268 SST_CVALP(stktop, getstring(" ", 1));
2269 SST_ASTP(stktop, mk_cnst(SST_CVALG(stktop)));
2270 SST_SHAPEP(stktop, 0);
2271 break;
2272 }
2273 ch_substring(stktop, SST_E1G(sp), SST_E2G(sp));
2274 break;
2275 }
2276 error(75, 3, gbl.lineno, "'constant'", CNULL);
2277 break;
2278 default:
2279 /* So far, we get here if SST_ID is S_EXPR. This means that an
2280 * expression has an argument list as in rs(1)(2). Give syntax error.
2281 * If a compiler created symbol (ie. a char function) look up real name.
2282 */
2283 sptr = getbase((int)SST_ASTG(stktop));
2284 if (CCSYMG(sptr))
2285 sptr = SST_ERRSYMG(stktop);
2286 if (STYPEG(sptr) == ST_ARRAY)
2287 return (ref_array(stktop, list));
2288 error(75, 3, gbl.lineno, SYMNAME(sptr), CNULL);
2289 break;
2290 }
2291 return (1);
2292 }
2293
2294 /**
2295 \brief Resolve forward references: try to find the declaration symbol
2296 and replace the reference symbol with it.
2297
2298 F95 allows forward references to pure functions from within
2299 specification expressions. A symbol will be created at the
2300 reference which must be fixed later after the function declaration
2301 has been seen. Possible forward references are marked FWDREF in
2302 mkvarref() above.
2303 */
2304 void
resolve_fwd_refs()2305 resolve_fwd_refs()
2306 {
2307 int ref, mod, decl, hashlk;
2308
2309 for (ref = stb.firstusym; ref < stb.stg_avail; ref++) {
2310 if (STYPEG(ref) == ST_PROC && FWDREFG(ref)) {
2311
2312 /* Find the module that contains the reference. */
2313 for (mod = SCOPEG(ref); mod; mod = SCOPEG(mod))
2314 if (STYPEG(mod) == ST_MODULE)
2315 break;
2316 if (mod == 0)
2317 continue; /* Not in a module. */
2318
2319 /* Look for the matching declaration. */
2320 for (decl = first_hash(ref); decl; decl = HASHLKG(decl)) {
2321 if (NMPTRG(decl) != NMPTRG(ref))
2322 continue;
2323 if (STYPEG(decl) == ST_PROC && ENCLFUNCG(decl) == mod) {
2324 hashlk = HASHLKG(ref);
2325 *(stb.stg_base + ref) = *(stb.stg_base + decl);
2326 HASHLKP(ref, hashlk);
2327 break;
2328 }
2329 }
2330 }
2331 }
2332 }
2333
2334 /* returns 1 if array dtype has one too many subscripts and the first
2335 subscript in the list is a S_TRIPLE. Otherwise, returns 0;
2336 */
2337 static int
is_substring(ITEM * list,int dtype)2338 is_substring(ITEM *list, int dtype)
2339 {
2340 int numdim;
2341 ITEM *tmplist;
2342 int i;
2343
2344 if (!list || list == ITEM_END)
2345 return 0;
2346
2347 if (DTY(dtype) != TY_ARRAY)
2348 return 0;
2349
2350 if (SST_IDG(list->t.stkp) != S_TRIPLE)
2351 return 0;
2352
2353 numdim = AD_NUMDIM(AD_DPTR(dtype));
2354
2355 tmplist = list;
2356 i = 0;
2357 while (tmplist != ITEM_END) {
2358 i++;
2359 tmplist = tmplist->next;
2360 }
2361 if (i == numdim + 1)
2362 return 1;
2363
2364 return 0;
2365 }
2366
2367 /** \brief Check if a stack entry represents a constant or an expression
2368 evaluated to a constant.
2369 */
2370 LOGICAL
is_sst_const(SST * stk)2371 is_sst_const(SST *stk)
2372 {
2373 switch (SST_IDG(stk)) {
2374 case S_CONST:
2375 return TRUE;
2376 case S_EXPR:
2377 if (A_ALIASG(SST_ASTG(stk)))
2378 return TRUE;
2379 break;
2380 default:
2381 break;
2382 }
2383 return FALSE;
2384 }
2385
2386 /** \brief Get the SST_CVAL-like value for a semantic stack entry already
2387 determined
2388 to be a constant (i.e., is_sst_const() is true).
2389
2390 SST_CVAL-like means just the the sst's CVAL field. If the stack has been
2391 evaluated (is an S_EXPR), need to get CVAL from the ast.
2392 */
2393 INT
get_sst_cval(SST * stkp)2394 get_sst_cval(SST *stkp)
2395 {
2396 int ast;
2397 int sptr;
2398
2399 if (SST_IDG(stkp) == S_CONST)
2400 return SST_CVALG(stkp);
2401 ast = SST_ASTG(stkp);
2402 #if DEBUG
2403 assert(SST_IDG(stkp) == S_EXPR && A_ALIASG(ast),
2404 "get_sst_cval, expected S_EXPR with ALIAS", ast, 4);
2405 #endif
2406 ast = A_ALIASG(ast);
2407 sptr = A_SPTRG(ast);
2408 switch (DTY(A_DTYPEG(ast))) {
2409 case TY_WORD:
2410 case TY_INT:
2411 case TY_LOG:
2412 case TY_REAL:
2413 case TY_SINT:
2414 case TY_BINT:
2415 case TY_SLOG:
2416 case TY_BLOG:
2417 /* coordinate with ast.c:mk_cval1() */
2418 return CONVAL2G(sptr);
2419 default:
2420 break;
2421 }
2422 return sptr;
2423 }
2424
2425 /** \brief Check if a stack entry is a legal variable reference.
2426
2427 This routine is used when it's known that a variable reference is required
2428 and a check is necessary before calling routines like like mkvarref and
2429 mklvalue.
2430 */
2431 LOGICAL
is_varref(SST * stk)2432 is_varref(SST *stk)
2433 {
2434 switch (SST_IDG(stk)) {
2435 case S_IDENT:
2436 case S_LVALUE:
2437 return TRUE;
2438 default:
2439 break;
2440 }
2441 return FALSE;
2442 }
2443
2444 /** \brief Access the address of the object (sym).
2445 */
2446 int
ref_object(int sptr)2447 ref_object(int sptr)
2448 {
2449 /* Check the current scope for a default clause */
2450 if (sem.parallel || sem.task || sem.target || sem.teams
2451 || sem.orph
2452 )
2453 sptr = sem_check_scope(sptr, sptr);
2454 if (SCG(sptr) == SC_BASED)
2455 ref_based_object(sptr);
2456
2457 return sptr;
2458 }
2459
2460 LOGICAL
ast_isparam(int ast)2461 ast_isparam(int ast)
2462 {
2463 int sptr;
2464 INT val;
2465 int lop, rop;
2466 INT lv, rv;
2467 int count;
2468 int sign, ndim;
2469 int i, asd;
2470 int argt;
2471 LOGICAL is_const = TRUE;
2472
2473 if (ast == 0)
2474 return FALSE;
2475 switch (A_TYPEG(ast) /* opc */) {
2476 case A_ID:
2477 if (A_ALIASG(ast)) {
2478 ast = A_ALIASG(ast);
2479 return TRUE;
2480 }
2481 if (PARAMG(A_SPTRG(ast)))
2482 return TRUE;
2483 return FALSE;
2484
2485 case A_CNST:
2486 return TRUE;
2487
2488 case A_UNOP:
2489 val = ast_isparam((int)A_LOPG(ast));
2490 return val;
2491
2492 case A_BINOP:
2493 if (ast_isparam((int)A_LOPG(ast)) == FALSE)
2494 return FALSE;
2495 return ast_isparam((int)A_ROPG(ast));
2496
2497 case A_PAREN:
2498 case A_CONV:
2499 return ast_isparam((int)A_LOPG(ast));
2500
2501 case A_MEM:
2502 if (A_MEM == A_TYPEG(A_PARENTG(ast))) /* don't evaluate at this point */
2503 return FALSE;
2504 if (ALLOCATTRG(A_SPTRG(A_MEMG(ast))) || POINTERG(A_SPTRG(A_MEMG(ast))))
2505 return FALSE;
2506 return ast_isparam(A_PARENTG(ast));
2507
2508 case A_SUBSCR:
2509 if (ast_isparam(A_LOPG(ast)) == FALSE)
2510 return FALSE;
2511 asd = A_ASDG(ast);
2512 ndim = ASD_NDIM(asd);
2513 for (i = 0; i < ndim; ++i) {
2514 int ss;
2515 ss = ASD_SUBS(asd, i);
2516 if (ast_isparam(ss) == FALSE)
2517 return FALSE;
2518 }
2519 return TRUE;
2520 case A_TRIPLE:
2521 if (ast_isparam(A_LBDG(ast)) == FALSE)
2522 return FALSE;
2523 if (ast_isparam(A_UPBDG(ast)) == FALSE)
2524 return FALSE;
2525 if (A_STRIDEG(ast))
2526 return (ast_isparam(A_STRIDEG(ast)));
2527 return TRUE;
2528
2529 /* don't do A_INTR for now except for
2530 maxval, maxloc, minval, minloc */
2531 case A_INTR:
2532 switch (A_OPTYPEG(ast)) {
2533 case I_MAXVAL:
2534 case I_MAXLOC:
2535 case I_MINVAL:
2536 case I_MINLOC:
2537 argt = A_ARGSG(ast);
2538 for (i = 0; i < A_ARGCNTG(ast); ++i) {
2539 int argast = ARGT_ARG(argt, i);
2540 if (argast && !ast_isparam(argast))
2541 return FALSE;
2542 }
2543 return TRUE;
2544
2545 default:
2546 return FALSE;
2547 }
2548 default:
2549 return FALSE;
2550 break;
2551 }
2552 return FALSE;
2553 }
2554
2555 /** \brief Checks whether a symbol is used in a select type or associate
2556 * construct as a selector.
2557 *
2558 * \param sptr is the symbol we are checking.
2559 *
2560 * \return true if symbol is a selector in an associate/select type
2561 * construct; else false.
2562 */
2563 static bool
is_selector(SPTR sptr)2564 is_selector(SPTR sptr)
2565 {
2566
2567 int i;
2568 ITEM *itemp;
2569 int doif = sem.doif_depth;
2570
2571 for(i=doif; i > 0; --i) {
2572 if (DI_ID(i) == DI_ASSOC) {
2573 for (itemp = DI_ASSOCIATIONS(doif); itemp != NULL;
2574 itemp = itemp->next) {
2575 if (itemp->t.sptr == sptr) {
2576 return true;
2577 }
2578 }
2579 } else if (DI_ID(i) == DI_SELECT_TYPE &&
2580 strcmp(SYMNAME(sptr), SYMNAME(DI_SELECTOR(i))) == 0) {
2581 return true;
2582 }
2583 }
2584 return false;
2585 }
2586
2587 static int
ref_array(SST * stktop,ITEM * list)2588 ref_array(SST *stktop, ITEM *list)
2589 {
2590 int sptr, dtype;
2591 int count;
2592 ITEM *ip1;
2593 SST *sp;
2594 int numdim, isvec;
2595 int nummissing;
2596 ADSC *ad;
2597 int subs[MAXDIMS], ast;
2598 int triple[3]; /* asts for triple notation */
2599 int tmp;
2600 ast = SST_ASTG(stktop);
2601 if (SST_IDG(stktop) == S_LVALUE) {
2602 /* pointer to an ILM */
2603 dtype = SST_DTYPEG(stktop);
2604 sptr = SST_LSYMG(stktop);
2605 } else {
2606 /* symbol table entry */
2607 sptr = SST_SYMG(stktop);
2608 dtype = DTYPEG(sptr);
2609 sptr = ref_object(sptr);
2610 if (SST_IDG(stktop) != S_DERIVED)
2611 SST_LSYMP(stktop, sptr);
2612 if (STYPEG(sptr) == ST_ENTRY || STYPEG(sptr) == ST_PROC)
2613 sptr = ref_entry(sptr);
2614 ast = mk_id(sptr);
2615 }
2616 ad = AD_DPTR(dtype);
2617 numdim = AD_NUMDIM(ad);
2618
2619 /*
2620 * we must make two passes through the subscript list to
2621 * determine if it is vector or element
2622 */
2623 isvec = FALSE;
2624 count = 0;
2625 for (ip1 = list; ip1 != ITEM_END; ip1 = ip1->next) {
2626 count++;
2627 /* will be marked as illegal */
2628 if (SST_IDG(ip1->t.stkp) == S_KEYWORD)
2629 continue;
2630 if (SST_IDG(ip1->t.stkp) == S_LABEL)
2631 continue;
2632 if (SST_IDG(ip1->t.stkp) == S_TRIPLE) {
2633 isvec = TRUE;
2634 continue;
2635 }
2636 if (DTY(SST_DTYPEG(ip1->t.stkp)) == TY_ARRAY) {
2637 isvec = TRUE;
2638 continue;
2639 }
2640 }
2641
2642 /* for NULL triples in derived type references, we have to be
2643 sure to grab array bounds from the correct place.
2644 We assert that any missing subscripts apply to the inner
2645 component array (whose subscripts come first.) Subscripts
2646 in subs[] array will get shifted over later */
2647 nummissing = 0;
2648 if (SST_IDG(stktop) == S_DERIVED) {
2649 if (count < numdim)
2650 nummissing = numdim - count;
2651 }
2652
2653 if (!isvec) {
2654 count = 0;
2655 for (ip1 = list; ip1 != ITEM_END; ip1 = ip1->next) {
2656 count++;
2657 if (count == numdim && ip1->next != ITEM_END) {
2658 error(78, 3, gbl.lineno, SYMNAME(sptr), CNULL);
2659 ip1->next = ITEM_END; /* Truncate # of subscripts */
2660 }
2661 /* process each subscript: */
2662 sp = ip1->t.stkp;
2663 if (SST_IDG(sp) == S_KEYWORD) {
2664 /* <ident> = <expr> illegal */
2665 errsev(79);
2666 subs[count - 1] = astb.bnd.one;
2667 } else if (SST_IDG(sp) == S_LABEL) {
2668 error(155, 3, gbl.lineno, "Illegal use of alternate return specifier",
2669 CNULL);
2670 subs[count - 1] = astb.bnd.one;
2671 } else {
2672 /* single subscript */
2673 chksubscr(sp, sptr);
2674 subs[count - 1] = SST_ASTG(sp);
2675 }
2676 }
2677 /* generate scalar load */
2678 dtype = DTY(dtype + 1);
2679 } else {
2680 /* A vector slice reference */
2681 if (!TY_ISVEC(DTYG(dtype))) {
2682 error83(DTYG(dtype));
2683 sem.dinit_error = TRUE;
2684 return (0);
2685 }
2686 count = 0;
2687 for (ip1 = list; ip1 != ITEM_END; ip1 = ip1->next) {
2688 count++;
2689 if (count == numdim && ip1->next != ITEM_END) {
2690 error(78, 3, gbl.lineno, SYMNAME(sptr), CNULL);
2691 sem.dinit_error = TRUE;
2692 ip1->next = ITEM_END;
2693 }
2694 /* process each subscript: */
2695 triple[0] = triple[1] = triple[2] = 0;
2696 sp = ip1->t.stkp;
2697 if (SST_IDG(sp) == S_KEYWORD) {
2698 /* <ident> = <expression> is illegal */
2699 errsev(79);
2700 subs[count - 1] = astb.bnd.one;
2701 } else if (SST_IDG(sp) == S_LABEL) {
2702 error(155, 3, gbl.lineno, "Illegal use of alternate return specifier",
2703 CNULL);
2704 subs[count - 1] = astb.bnd.one;
2705 } else if (SST_IDG(sp) == S_TRIPLE) {
2706 sp = SST_E1G(sp);
2707 /* triplet subscript */
2708 if (SST_IDG(sp) == S_NULL) {
2709 triple[0] = tmp =
2710 check_member(ast, lbound_of(dtype, (count - 1) + nummissing));
2711 again:
2712 switch (A_TYPEG(tmp)) {
2713 case A_ID:
2714 case A_CNST:
2715 case A_BINOP: /*ptr reshape*/
2716 tmp = A_SPTRG(tmp);
2717 break;
2718 case A_SUBSCR:
2719 tmp = A_LOPG(tmp);
2720 goto again;
2721 default:
2722 if (A_ALIASG(tmp))
2723 tmp = A_SPTRG(A_ALIASG(tmp));
2724 break;
2725 }
2726 } else {
2727 chksubscr(sp, sptr);
2728 triple[0] = SST_ASTG(sp);
2729 }
2730 sp = SST_E2G(ip1->t.stkp);
2731 if (SST_IDG(sp) == S_NULL) {
2732 if (!SST_DIMFLAGG(stktop) &&
2733 AD_UPBD(ad, (count - 1) + nummissing) == 0) {
2734 /* '*' specified */
2735 error(84, 3, gbl.lineno, SYMNAME(sptr),
2736 "- extent of assumed size array is unknown");
2737 } else {
2738 triple[1] = tmp =
2739 check_member(ast, AD_UPAST(ad, (count - 1) + nummissing));
2740
2741 switch (A_TYPEG(tmp)) {
2742 case A_ID:
2743 case A_CNST:
2744 case A_BINOP: /*ptr reshape*/
2745 tmp = A_SPTRG(tmp);
2746 break;
2747 default:
2748 if (A_ALIASG(tmp))
2749 tmp = A_SPTRG(A_ALIASG(tmp));
2750 break;
2751 }
2752 }
2753 } else {
2754 chksubscr(sp, sptr);
2755 triple[1] = SST_ASTG(sp);
2756 }
2757
2758 sp = SST_E3G(ip1->t.stkp);
2759 if (SST_IDG(sp) != S_NULL) {
2760 chksubscr(sp, sptr);
2761 triple[2] = SST_ASTG(sp);
2762 if (triple[2] == astb.bnd.zero)
2763 error(155, 3, gbl.lineno, "Illegal zero stride",
2764 "in array subscript triplet");
2765 }
2766 subs[count - 1] = mk_triple(triple[0], triple[1], triple[2]);
2767 A_MASKP(subs[count - 1], SST_DIMFLAGG(stktop));
2768 } else {
2769 /* single subscript */
2770 chksubscr(sp, sptr);
2771 subs[count - 1] = SST_ASTG(sp);
2772 }
2773 }
2774
2775 if (!DT_ISVEC(DTY(dtype + 1))) {
2776 interr("mkvarref: non-vec type", dtype, 3);
2777 }
2778 }
2779
2780 if (count != numdim) {
2781 if (SST_IDG(stktop) == S_DERIVED && count < numdim) {
2782 /* a member reference of a subscripted derived type -
2783 * insert the remaining subscripts as triples derived from the
2784 * bounds of the beginning dimensions.
2785 */
2786 int i, j;
2787 /* shift subscripts over */
2788 j = numdim - 1;
2789 for (i = count - 1; i >= 0; i--)
2790 subs[j--] = subs[i];
2791 i = 0;
2792 while (count < numdim) {
2793 subs[i] = mk_triple(AD_LWAST(ad, i), AD_UPAST(ad, i), 0);
2794 count++;
2795 i++;
2796 }
2797 dtype = DTYPEG(sptr);
2798 } else if (!ALIGNG(sptr) && !DISTG(sptr)) {
2799 /* 'overindexed' subscript reference
2800 * T3D/T3E or C90 Cray targets, scalar reference of unmapped
2801 * array.
2802 */
2803 while (count < numdim) {
2804 if (AD_LWAST(ad, count) == 0)
2805 subs[count] = astb.bnd.one;
2806 else
2807 subs[count] = AD_LWAST(ad, count);
2808 count++;
2809 }
2810 if (flg.standard)
2811 ERR170("The number of subscripts is less than the rank of",
2812 SYMNAME(sptr));
2813 else
2814 error(155, 2, gbl.lineno,
2815 "The number of subscripts is less than the rank of",
2816 SYMNAME(sptr));
2817 } else {
2818 error(78, 3, gbl.lineno, SYMNAME(sptr), CNULL);
2819 while (count < numdim)
2820 subs[count++] = astb.bnd.one;
2821 }
2822 }
2823
2824 SST_IDP(stktop, S_LVALUE);
2825 /* can't overwrite list item in w4 until list is processed ????*/
2826 /*SST_SHAPEP(stktop, A_SHAPEG(ast));*/
2827 SST_LSYMP(stktop, sptr);
2828 ast = mk_subscr(ast, subs, numdim, dtype);
2829 dtype = A_DTYPEG(ast); /* derived types may change dtype */
2830 SST_DTYPEP(stktop, dtype);
2831 SST_ASTP(stktop, ast);
2832 SST_SHAPEP(stktop, A_SHAPEG(ast));
2833 if (sem.dinit_data) {
2834 constant_lvalue(stktop);
2835 }
2836 /* evaluate to constant here if it is a dimension and all is param */
2837 if (!isvec && numdim == 1 &&
2838 (sem.dinit_data || sem.in_dim || INSIDE_STRUCT)) {
2839 if (DT_ISINT(A_DTYPEG(ast)) && ast_isparam(ast)) {
2840 INT conval;
2841 ACL *acl = construct_acl_from_ast(ast, A_DTYPEG(ast), 0);
2842
2843 acl = eval_init_expr(acl);
2844 conval = cngcon(acl->conval, acl->dtype, A_DTYPEG(ast));
2845 ast = mk_cval1(conval, (int)A_DTYPEG(ast));
2846 SST_IDP(stktop, S_CONST);
2847 SST_LSYMP(stktop, 0);
2848 SST_ASTP(stktop, ast);
2849 SST_ACLP(stktop, 0);
2850 if (DT_ISWORD(A_DTYPEG(ast)))
2851 SST_SYMP(stktop, CONVAL2G(A_SPTRG(ast)));
2852 else
2853 SST_SYMP(stktop, A_SPTRG(ast));
2854 }
2855 }
2856 if (!isvec && CLASSG(sptr) && !MONOMORPHICG(sptr) &&
2857 !is_selector(sptr) && !is_unl_poly(sptr) && !sem.in_array_const) {
2858 /* Provide polymorphic address for the polymorphic subscripted reference.
2859 *
2860 * Note the following expressions are handled separately:
2861 *
2862 * 1. selectors that are a part of a select type or associate construct.
2863 * 2. unlimited polymorphic objects.
2864 * 3. expressions inside an array constructor.
2865 *
2866 */
2867 int std = add_stmt(mk_stmt(A_CONTINUE, 0));
2868 int astnew = gen_poly_element_arg(ast, sptr, std);
2869 A_ORIG_EXPRP(astnew, ast);
2870 SST_ASTP(stktop, astnew);
2871 }
2872 return 1;
2873 }
2874
2875 /*---------------------------------------------------------------------*/
2876
2877 /** \brief Check that substring specifier is correct, write SUBS (substring)
2878 ILM and return pointer to it.
2879 */
2880 int
chksubstr(SST * stktop,ITEM * item)2881 chksubstr(SST *stktop, ITEM *item)
2882 {
2883 SST *sp;
2884 int sptr;
2885 int cvlen;
2886 int ast, lb_ast, ub_ast;
2887 int odtype, dtype;
2888 INT t;
2889 int ityp; /* integer type for substring positions */
2890
2891 ityp = stb.user.dt_int;
2892 if (astb.bnd.dtype == DT_INT8)
2893 ityp = DT_INT8;
2894 SST_CVLENP(stktop, 0);
2895 lb_ast = ub_ast = 0;
2896 odtype = SST_DTYPEG(stktop);
2897 dtype = DDTG(odtype);
2898 if (SST_IDG(stktop) == S_LVALUE) {
2899 /* Probably substringing an array reference e.g. ca(1)(1:2) */
2900 sptr = SST_LSYMG(stktop);
2901 } else if (SST_IDG(stktop) == S_DERIVED) {
2902 sptr = SST_SYMG(stktop);
2903 dtype = DDTG(DTYPEG(sptr));
2904 } else {
2905 sptr = SST_SYMG(stktop);
2906 SST_LSYMP(stktop, sptr);
2907 SST_IDP(stktop, S_LVALUE);
2908 sptr = ref_object(sptr);
2909 }
2910 ast = SST_ASTG(stktop);
2911
2912 if (item == ITEM_END) {
2913 /* Neither upper nor lower bound given, default both */
2914 goto no_upbound;
2915 }
2916
2917 /* Validate that we process only a subscript triplet, of which, only the
2918 * form e1:e2 is valid for substring references.
2919 */
2920 if (SST_IDG(item->t.stkp) != S_TRIPLE) {
2921 error(82, 3, gbl.lineno, SYMNAME(sptr), CNULL);
2922 return 1;
2923 }
2924
2925 /* Validate lower bound and generate ast's for it */
2926 sp = SST_E1G(item->t.stkp);
2927 if (SST_IDG(sp) == S_NULL) {
2928 /* No lower bound, default to 1 */
2929 } else {
2930 if (!DT_ISINT(SST_DTYPEG(sp)))
2931 chk_scalartyp(sp, ityp, TRUE);
2932 else {
2933 if (DTY(SST_DTYPEG(sp)) == TY_INT8)
2934 ityp = DT_INT8;
2935 if (SST_IDG(sp) == S_CONST) {
2936 t = SST_CVALG(sp);
2937 if (DTY(SST_DTYPEG(sp)) == TY_INT8)
2938 t = cngcon(t, DT_INT8, ityp);
2939 if (t < 1) {
2940 error(82, 3, gbl.lineno, SYMNAME(sptr), CNULL);
2941 SST_DTYPEP(sp, ityp);
2942 SST_CVALP(sp, 1);
2943 }
2944 }
2945 chktyp(sp, ityp, FALSE); /* just to mkexpr() & set dtype */
2946 }
2947 lb_ast = SST_ASTG(sp);
2948 }
2949
2950 /* Validate upper bound and generate ast's for it. If user didn't
2951 * specify an upper bound use the variable's character length.
2952 */
2953 sp = SST_E2G(item->t.stkp);
2954
2955 cvlen = 0;
2956 if (SST_IDG(sp) == S_NULL) { /* upper bound not specified */
2957 no_upbound:
2958 if (dtype == DT_ASSCHAR || dtype == DT_ASSNCHAR || dtype == DT_DEFERCHAR ||
2959 dtype == DT_DEFERNCHAR) {
2960 /* Don't really know if character length assumption works */
2961 if (STYPEG(sptr) == ST_ENTRY)
2962 sptr = ref_entry(sptr);
2963 } else if (ADJLENG(sptr))
2964 ub_ast = size_ast(sptr, dtype);
2965 else {
2966 cvlen = string_length(dtype);
2967 if (cvlen < 0)
2968 interr("chksubstr: bad cvlen", cvlen, 3);
2969 }
2970 } else { /* upper bound specified */
2971 /* no need to check value of upper bound since F90 allows the lower
2972 * bound to exceed the upper bound.
2973 */
2974 if (DTY(SST_DTYPEG(sp)) == TY_INT8)
2975 ityp = DT_INT8;
2976 chk_scalartyp(sp, ityp, TRUE);
2977 ub_ast = SST_ASTG(sp);
2978 }
2979
2980 /* Make sure user didn't specify a 3rd expression i.e. e1:e2:e3, or
2981 * more than one argument.
2982 */
2983 if (item != ITEM_END &&
2984 (SST_IDG(SST_E3G(item->t.stkp)) != S_NULL || item->next != ITEM_END))
2985 error(82, 3, gbl.lineno, SYMNAME(sptr), CNULL);
2986
2987 if (lb_ast == ub_ast && (lb_ast == 0 || !A_CALLFGG(lb_ast))) {
2988 cvlen = 1;
2989 dtype = get_type(2, (int)DTY(dtype), mk_cval(cvlen, DT_INT4));
2990 } else if (A_TYPEG(lb_ast) == A_CNST && A_TYPEG(ub_ast) == A_CNST) {
2991 cvlen = CONVAL2G(A_SPTRG(ub_ast)) - CONVAL2G(A_SPTRG(lb_ast)) + 1;
2992 if (cvlen < 0)
2993 cvlen = 0;
2994 dtype = get_type(2, (int)DTY(dtype), mk_cval(cvlen, DT_INT4));
2995 } else if (ub_ast) {
2996 cvlen = ub_ast;
2997 if (lb_ast) {
2998 lb_ast = mk_convert(lb_ast, ityp); /* lb may have narrow type */
2999 cvlen = mk_binop(OP_SUB, cvlen, lb_ast, ityp);
3000 cvlen = mk_binop(OP_ADD, cvlen, astb.i1, ityp);
3001 }
3002 if (ityp == DT_INT8)
3003 cvlen = mk_convert(cvlen, DT_INT4);
3004 if (!A_ALIASG(cvlen))
3005 cvlen = ast_intr(I_MAX, DT_INT4, 2, cvlen, mk_cval(0, DT_INT4));
3006 dtype = get_type(2, (int)DTY(dtype), cvlen);
3007 SST_CVLENP(stktop, cvlen);
3008 } else if (cvlen && A_TYPEG(lb_ast) == A_CNST) {
3009 cvlen = cvlen - CONVAL2G(A_SPTRG(lb_ast)) + 1;
3010 if (cvlen < 0)
3011 cvlen = 0;
3012 dtype = get_type(2, (int)DTY(dtype), mk_cval(cvlen, DT_INT4));
3013 } else {
3014 cvlen = 0;
3015 if (DTY(dtype) == TY_CHAR) {
3016 dtype = DT_ASSCHAR;
3017 } else if (DTY(dtype) == TY_NCHAR) {
3018 dtype = DT_ASSNCHAR;
3019 } else {
3020 interr("chksubstr: bad character type", dtype, 3);
3021 }
3022 }
3023 /* should this be an array type? */
3024 if (DTY(odtype) == TY_ARRAY) {
3025 /* make a new array type, same bounds as parent type */
3026 dtype = get_type(3, TY_ARRAY, dtype);
3027 DTY(dtype + 2) = DTY(odtype + 2);
3028 }
3029 ast = mk_substr(ast, lb_ast, ub_ast, dtype);
3030 SST_ASTP(stktop, ast);
3031 if (SST_IDG(stktop) != S_DERIVED) {
3032 SST_SHAPEP(stktop, A_SHAPEG(ast));
3033 SST_DTYPEP(stktop, dtype);
3034 }
3035 return 1;
3036 }
3037
3038 /** \brief Substring of a character constant.
3039 */
3040 void
ch_substring(SST * stktop,SST * lb_sp,SST * ub_sp)3041 ch_substring(SST *stktop, SST *lb_sp, SST *ub_sp)
3042 {
3043 int cnst_sptr; /* symbol table pointer of character constant */
3044 int lb_ast;
3045 int ub_ast;
3046 int dtype;
3047 int cvlen;
3048 char *cp;
3049 int new_var;
3050 int ast;
3051 INT val[2];
3052
3053 dtype = SST_DTYPEG(stktop);
3054 cnst_sptr = SST_CVALG(stktop);
3055 if (SST_IDG(lb_sp) != S_NULL) {
3056 if (!DT_ISINT(SST_DTYPEG(lb_sp)))
3057 (void)chk_scalartyp(lb_sp, DT_INT, TRUE);
3058 }
3059 if (SST_IDG(ub_sp) != S_NULL) {
3060 if (!DT_ISINT(SST_DTYPEG(ub_sp)))
3061 (void)chk_scalartyp(ub_sp, DT_INT, TRUE);
3062 }
3063 if (SST_IDG(stktop) == S_CONST &&
3064 (SST_IDG(lb_sp) == S_NULL || SST_IDG(lb_sp) == S_CONST) &&
3065 (SST_IDG(ub_sp) == S_NULL || SST_IDG(ub_sp) == S_CONST)) {
3066 cvlen = string_length(dtype);
3067 if (SST_IDG(lb_sp) == S_NULL)
3068 lb_ast = 1;
3069 else {
3070 lb_ast = CONVAL2G(A_SPTRG(SST_ASTG(lb_sp)));
3071 if (lb_ast < 1) {
3072 errsev(82);
3073 lb_ast = 1;
3074 }
3075 }
3076 if (SST_IDG(ub_sp) == S_NULL)
3077 ub_ast = cvlen;
3078 else {
3079 ub_ast = CONVAL2G(A_SPTRG(SST_ASTG(ub_sp)));
3080 if (ub_ast > cvlen) {
3081 errsev(82);
3082 ub_ast = cvlen;
3083 }
3084 }
3085 cvlen = ub_ast - lb_ast + 1;
3086 if (cvlen < 1) {
3087 char *str = "";
3088 cnst_sptr = getstring(str, strlen(str));
3089 if (DTY(dtype) == TY_NCHAR) {
3090 dtype = get_type(2, TY_NCHAR, mk_cval(strlen(str), DT_INT4));
3091 val[0] = cnst_sptr;
3092 val[1] = 0;
3093 cnst_sptr = getcon(val, dtype);
3094 }
3095 SST_DTYPEP(stktop, DTYPEG(cnst_sptr));
3096 SST_CVALP(stktop, cnst_sptr);
3097 SST_ASTP(stktop, mk_cnst(cnst_sptr));
3098 return;
3099 }
3100 if (cvlen != string_length(dtype)) {
3101 if (DTY(dtype) == TY_NCHAR) {
3102 int char_cnst;
3103 int blen; /* length in bytes of new kanji constant */
3104 char *p;
3105
3106 char_cnst = CONVAL1G(cnst_sptr);
3107 p = stb.n_base + CONVAL1G(char_cnst);
3108 /*
3109 * get char position of lower bnd and char length of resulting
3110 * string.
3111 */
3112 lb_ast = kanji_len((unsigned char *)p, lb_ast - 1);
3113 blen = kanji_len((unsigned char *)p + lb_ast, cvlen);
3114 cp = getitem(0, blen);
3115 BCOPY(cp, p + lb_ast, char, blen);
3116 char_cnst = getstring(cp, blen);
3117 dtype = get_type(2, TY_NCHAR, mk_cval(cvlen, DT_INT4));
3118 val[0] = char_cnst;
3119 val[1] = 0;
3120 SST_DTYPEP(stktop, dtype);
3121 SST_ASTP(stktop, mk_cnst(getcon(val, dtype)));
3122 return;
3123 }
3124 cp = getitem(0, cvlen);
3125 BCOPY(cp, stb.n_base + CONVAL1G(cnst_sptr) + lb_ast - 1, char, cvlen);
3126 dtype = get_type(2, TY_CHAR, mk_cval(cvlen, DT_INT4));
3127 SST_DTYPEP(stktop, dtype);
3128 SST_CVALP(stktop, getstring(cp, cvlen));
3129 SST_ASTP(stktop, mk_cnst(SST_CVALG(stktop)));
3130 }
3131 return;
3132 }
3133 if (SST_IDG(lb_sp) != S_NULL) {
3134 (void)chktyp(lb_sp, DT_INT, FALSE); /* just to mkexpr() & set dtype */
3135 lb_ast = SST_ASTG(lb_sp);
3136 } else
3137 lb_ast = 0;
3138 if (SST_IDG(ub_sp) != S_NULL) {
3139 (void)chktyp(ub_sp, DT_INT, FALSE); /* just to mkexpr() & set dtype */
3140 ub_ast = SST_ASTG(ub_sp);
3141 } else
3142 ub_ast = 0;
3143 new_var = getcctmp('t', cnst_sptr, ST_UNKNOWN, dtype);
3144 if (STYPEG(new_var) == ST_UNKNOWN) {
3145 STYPEP(new_var, ST_VAR);
3146 DINITP(new_var, 1);
3147 sym_is_refd(new_var);
3148 dinit_put(DINIT_LOC, new_var);
3149 dinit_put(DINIT_STR, (INT)cnst_sptr);
3150 dinit_put(DINIT_END, (INT)0);
3151 }
3152 ast = mk_id(new_var);
3153 ast = mk_substr(ast, lb_ast, ub_ast, dtype);
3154 SST_IDP(stktop, S_EXPR);
3155 SST_ASTP(stktop, ast);
3156 }
3157
3158 /** \brief Repair a bad term in an expression.
3159
3160 Done by using the constant (sptr) passed to this routine. An xCON ILM is
3161 generated referencing this constant.
3162 */
3163 int
fix_term(SST * stktop,int sptr)3164 fix_term(SST *stktop, int sptr)
3165 {
3166 SST_IDP(stktop, S_EXPR);
3167 SST_DTYPEP(stktop, DTYPEG(sptr));
3168 switch (DTY(DTYPEG(sptr))) {
3169 case TY_INT:
3170 break;
3171 case TY_REAL:
3172 break;
3173 case TY_DBLE:
3174 break;
3175 case TY_INT8:
3176 break;
3177 default:
3178 interr("fix_term: Unexpected dtype:", DTYPEG(sptr), 0);
3179 break;
3180 }
3181
3182 return 1;
3183 }
3184
3185 /** \brief Called when array of derived type = scalar derived type, but the
3186 scalar derived type has an array component.
3187 */
3188 int
assign_array_w_forall(int dest_ast,int src_ast,int dtype,int ndim)3189 assign_array_w_forall(int dest_ast, int src_ast, int dtype, int ndim)
3190 {
3191 int i;
3192 ADSC *ad;
3193 int subs[MAXDIMS];
3194 int ast, ast2;
3195 int list;
3196 int forallast;
3197 int sptr;
3198
3199 /* generate code
3200 forall(i's) dest(:'s,i's) = src(:'s)
3201 where there are ndim :'s representing the component array
3202 and the i's represent the shape of the dest ary
3203 of derived type
3204
3205 we already have
3206 dest(*) = src(*);
3207 */
3208
3209 /* first ndim are o.k. */
3210 for (i = 0; i < ndim; i++) {
3211 subs[i] = ASD_SUBS(A_ASDG(dest_ast), i);
3212 }
3213 if (DTY(dtype) != TY_ARRAY)
3214 interr("assign_array_w_forall(), bad dtype", dtype, 3);
3215 ad = AD_DPTR(dtype);
3216 if (AD_NUMDIM(ad) <= ndim)
3217 interr("assign_array_w_forall(), bad dtype dim", dtype, 3);
3218 start_astli();
3219 /* i retains its value from prior loop */
3220 for (; i < AD_NUMDIM(ad); i++) {
3221 /* get temp var for forall index var */
3222 sptr = get_temp(astb.bnd.dtype);
3223 ast2 = mk_id(sptr);
3224 /* use subscript for forall index var */
3225 list = add_astli();
3226 ASTLI_SPTR(list) = sptr;
3227 ASTLI_TRIPLE(list) = ASD_SUBS(A_ASDG(dest_ast), i);
3228 /* and use forall index var for subscript */
3229 subs[i] = ast2;
3230 }
3231 forallast = mk_stmt(A_FORALL, 0);
3232 A_LISTP(forallast, ASTLI_HEAD);
3233
3234 /* change dest subscript to subs which uses forall vars */
3235 dest_ast = mk_subscr(A_LOPG(dest_ast), subs, AD_NUMDIM(ad), dtype);
3236
3237 /* add assign and make forall point to it ?? */
3238 ast = mk_assn_stmt(dest_ast, src_ast, dtype);
3239 A_IFSTMTP(forallast, ast);
3240
3241 return forallast;
3242 }
3243
3244 /** \brief Give error message for reference like a(:)%b(:)
3245 */
3246 void
check_derived_type_array_section(int ast)3247 check_derived_type_array_section(int ast)
3248 {
3249 int mem, parent, subscr;
3250 for (mem = ast; mem;) {
3251 switch (A_TYPEG(mem)) {
3252 case A_MEM:
3253 parent = A_PARENTG(mem);
3254 /* if this is an array member, and the parent has nontrivial shape,
3255 * give an error message */
3256 if (A_SHAPEG(parent)) {
3257 int sptr;
3258 sptr = A_SPTRG(A_MEMG(mem));
3259 if (DTY(DTYPEG(sptr)) == TY_ARRAY) {
3260 error(455, 3, gbl.lineno, SYMNAME(memsym_of_ast(mem)), "");
3261 }
3262 }
3263 mem = parent;
3264 break;
3265 case A_SUBSCR:
3266 subscr = mem;
3267 parent = mem = A_LOPG(subscr);
3268 if (A_TYPEG(mem) == A_MEM) {
3269 parent = A_PARENTG(mem);
3270 if (A_SHAPEG(parent)) {
3271 /* if any subscripts are triplets or have shape, give error */
3272 int asd, i, ndim, ss;
3273 asd = A_ASDG(subscr);
3274 ndim = ASD_NDIM(asd);
3275 for (i = 0; i < ndim; ++i) {
3276 ss = ASD_SUBS(asd, i);
3277 if (A_SHAPEG(ss) || A_TYPEG(ss) == A_TRIPLE) {
3278 error(455, 3, gbl.lineno, SYMNAME(memsym_of_ast(mem)), "");
3279 break;
3280 }
3281 }
3282 }
3283 }
3284 mem = parent;
3285 default:
3286 return;
3287 }
3288 }
3289 } /* check_derived_type_array_section */
3290
3291 /** \brief Assign stktop to newtop.
3292 */
3293 int
assign(SST * newtop,SST * stktop)3294 assign(SST *newtop, SST *stktop)
3295 {
3296 int dtype;
3297 int shape;
3298 int stype;
3299 int ast;
3300
3301 if (mklvalue(newtop, 1) == 0)
3302 /* Avoid assignment ILM's if lvalue is illegal */
3303 return 0;
3304 dtype = SST_DTYPEG(newtop);
3305 shape = SST_SHAPEG(newtop);
3306
3307 if (shape != 0 && SST_DTYPEG(stktop) == DT_HOLL)
3308 errsev(100);
3309
3310 /* If the left and right sides of the assign. stmt. have unequal data
3311 * types or if equal, they are records then change the type of the right
3312 * side to the type of the left side.
3313 */
3314 if (SST_IDG(stktop) == S_STFUNC)
3315 chktyp(stktop, dtype, FALSE);
3316
3317 if (SST_IDG(stktop) == S_EXPR && SST_ASTG(stktop) && SST_ASTG(newtop) &&
3318 (A_TYPEG(SST_ASTG(stktop)) == A_FUNC) &&
3319 is_iso_cptr(A_DTYPEG(SST_ASTG(stktop))) &&
3320 is_iso_cptr(A_DTYPEG(SST_ASTG(newtop)))) {
3321
3322 } else if (DTYG(dtype) == TY_STRUCT || DTYG(dtype) == TY_DERIVED) {
3323 SPTR sptr;
3324 if (SST_IDG(newtop) == S_LVALUE || SST_IDG(newtop) == S_EXPR) {
3325 sptr = SST_LSYMG(newtop);
3326 } else {
3327 sptr = SST_SYMG(newtop);
3328 }
3329 cngtyp2(stktop, dtype, (CLASSG(sptr) && ALLOCATTRG(sptr)));
3330 } else if (DTYG(dtype) != DTYG(SST_DTYPEG(stktop))) {
3331 if (DTY(dtype) == TY_ARRAY && DTY(SST_DTYPEG(stktop)) != TY_ARRAY)
3332 /*
3333 * array = scalar and the element type is not the same as the
3334 * type of the scalar; first convert the scalar.
3335 */
3336 cngtyp(stktop, DTY(dtype + 1));
3337 else {
3338 cngtyp(stktop, dtype);
3339 }
3340 }
3341
3342 mkexpr1(stktop);
3343 cngshape(stktop, newtop);
3344
3345 if (DTY(dtype) == TY_ARRAY && !DT_ISVEC(DTY(dtype + 1)))
3346 error83(DTYG(dtype));
3347
3348 check_derived_type_array_section(SST_ASTG(newtop));
3349
3350 {
3351 int lhs;
3352 int rhs;
3353 int call;
3354
3355 lhs = SST_ASTG(newtop);
3356 rhs = SST_ASTG(stktop);
3357 call = STD_AST(sem.arrfn.call_std);
3358 if (gbl.maxsev < 3 && sem.arrfn.try && DTY(dtype) == TY_ARRAY &&
3359 rhs == sem.arrfn.return_value && subst_lhs_arrfn(lhs, rhs, call)) {
3360 /*
3361 * The RHS of the assignment is a function call for which
3362 * the result temp can be replaced by the lhs.
3363 */
3364 int argt;
3365 int arr_tmp;
3366
3367 arr_tmp = A_SPTRG(rhs);
3368 argt = A_ARGSG(call);
3369 ARGT_ARG(argt, 0) = lhs;
3370 if (ALLOCG(arr_tmp)) {
3371 /*
3372 * if the temp was allocated, delete its allocation
3373 * and remove the temp from the dealloc list. Note
3374 * that if the temp is not found in the dealloc list,
3375 * then the allocate is left.
3376 */
3377 ITEM *p, *t;
3378
3379 p = NULL;
3380 for (t = sem.p_dealloc; t != NULL; t = t->next) {
3381 if (t->ast == rhs) {
3382 ast_to_comment(STD_AST(sem.arrfn.alloc_std));
3383 if (p == NULL)
3384 sem.p_dealloc = t->next;
3385 else
3386 p->next = t->next;
3387 break;
3388 }
3389 p = t;
3390 }
3391 for (t = sem.p_dealloc_delete; t != NULL; t = t->next) {
3392 if (t->ast == rhs) {
3393 delete_stmt(t->t.ilm);
3394 }
3395 }
3396 }
3397 sem.arrfn.try
3398 = 0;
3399 return 0;
3400 }
3401 ast = mk_assn_stmt(lhs, rhs, dtype);
3402
3403 if (DTY(dtype) == TY_ARRAY) {
3404 direct_loop_enter();
3405 direct_loop_end(gbl.lineno, gbl.lineno);
3406 }
3407 }
3408
3409 return ast;
3410 }
3411
3412 /*
3413 * Can the result temp by substituted with the LHS?
3414 * The LHS cannot:
3415 * - have the POINTER attribute
3416 * - have adjustable length if character
3417 * - have the allocatable attribute if the 2003 allocatable semantics are
3418 * enabled
3419 * - have different length than the function result
3420 * - appear as an argument to the function
3421 * The LHS must be 'whole'; for hpf, the LHS must also be an ident.
3422 * The RHS (function result) cannot have the POINTER attribute (POINTER
3423 * functions can be seen in assign() because of the work for
3424 * p => func() (i.e., assign_pointer())
3425 */
3426 static LOGICAL
subst_lhs_arrfn(int lhs,int rhs,int call)3427 subst_lhs_arrfn(int lhs, int rhs, int call)
3428 {
3429 int sym;
3430 int arr_tmp;
3431 int dtype, eldt;
3432 int func_sptr;
3433
3434 if (XBIT(47, 0x800000))
3435 return FALSE;
3436 if (DI_IN_NEST(sem.doif_depth, DI_WHERE)) {
3437 /* WHERE processing must see the assignment! */
3438 return FALSE;
3439 }
3440 func_sptr = sem.arrfn.sptr;
3441 if (!PUREG(func_sptr)) {
3442 /*
3443 * f1565 6-
3444 * substituting the result of an array-valued function to the array
3445 * on the lhs is an unsafe optimization since the function could
3446 * define the array. This optimization was added for polyhedron-
3447 * channel (f12457), and fixing 15656 means that the optimization
3448 * will no longer occur in channel ...
3449 * In addition to the constraints above, need:
3450 * o calling a contained function from the host
3451 * o calling a function from a contained function and the lhs is
3452 * not local
3453 * o calling a function and the lhs is 'global'
3454 * We can do better if:
3455 * o for internal procedures, we somehow record what variables
3456 * (host-associated & globals) are possibly defined =>
3457 * IDEAS: enhance how we process internal procedures so that
3458 * we can collect information; use IPA
3459 * o for external functions, what global symbols are possibly
3460 * defined => use IPA
3461 */
3462 sym = sym_of_ast(lhs);
3463 if (gbl.internal > 1 && !INTERNALG(sym))
3464 return FALSE;
3465 if (INTERNALG(func_sptr) && gbl.internal <= 1 &&
3466 (GSCOPEG(sym) || XBIT(7, 0x200000))) {
3467 return FALSE;
3468 }
3469 if ((SCG(sym) == SC_CMBLK) || (SCG(sym) == SC_EXTERN))
3470 return FALSE;
3471 }
3472 sym = memsym_of_ast(lhs);
3473 if (POINTERG(sym) || ADJLENG(sym) || (ALLOCATTRG(sym) && XBIT(54, 1)))
3474 return FALSE;
3475 arr_tmp = A_SPTRG(rhs);
3476 if (POINTERG(arr_tmp))
3477 return FALSE;
3478 dtype = DTYPEG(sym);
3479 eldt = DTY(DTYPEG(arr_tmp) + 1);
3480 if (DTY(eldt) == TY_CHAR || DTY(eldt) == TY_NCHAR) {
3481 int d1;
3482 /* warning - use DDTG for the lhs, since the member itself doesn't
3483 * need to be an array.
3484 */
3485 if (ADJLENG(arr_tmp))
3486 return FALSE;
3487 d1 = DDTG(dtype);
3488 if (DTY(eldt + 1) != DTY(d1 + 1))
3489 return FALSE;
3490 }
3491 if (A_TYPEG(lhs) == A_ID)
3492 return not_in_arrfn(lhs, call);
3493 if (A_TYPEG(lhs) == A_MEM) {
3494 /*
3495 * If the LHS is a member, then the member must be an array in
3496 * order for it to be 'whole'.
3497 */
3498 if (DTY(dtype) == TY_ARRAY)
3499 return not_in_arrfn(A_PARENTG(lhs), call);
3500 return FALSE;
3501 }
3502 if (A_TYPEG(lhs) == A_SUBSCR && A_SHAPEG(lhs) && DTY(dtype) == TY_ARRAY) {
3503 /*
3504 * If subscripted, the LHS is 'whole' if its triples are just ':'.
3505 */
3506 ADSC *ad;
3507 int shd, nd, ii;
3508 int asd, sub;
3509
3510 ad = AD_DPTR(dtype);
3511 shd = A_SHAPEG(lhs);
3512 nd = SHD_NDIM(shd);
3513 if (nd > AD_NUMDIM(ad))
3514 return FALSE;
3515 asd = A_ASDG(lhs);
3516 for (ii = 0; ii < nd; ++ii) {
3517 sub = ASD_SUBS(asd, ii);
3518 if (A_TYPEG(sub) != A_TRIPLE)
3519 return FALSE;
3520 if (A_STRIDEG(sub) && A_STRIDEG(sub) != astb.bnd.one)
3521 return FALSE;
3522 if (A_LBDG(sub) != AD_LWAST(ad, ii))
3523 return FALSE;
3524 if (A_UPBDG(sub) != AD_UPAST(ad, ii))
3525 return FALSE;
3526 }
3527 return not_in_arrfn(A_LOPG(lhs), call);
3528 }
3529
3530 return FALSE;
3531 }
3532
3533 /*
3534 * Can the result temp by substituted with the LHS?
3535 * The LHS must have POINTER attribute.
3536 * the LHS must not appear as an argument to the function
3537 * the LHS must be 'whole'
3538 * the LHS must not be adjustable length, if character
3539 * the LHS must match in datatype and rank to the function
3540 */
3541 static LOGICAL
subst_lhs_pointer(int lhs,int rhs,int call)3542 subst_lhs_pointer(int lhs, int rhs, int call)
3543 {
3544 int sym, tmp, symdtype, symddtype, tmpdtype, tmpddtype;
3545 if (XBIT(47, 0x800000))
3546 return FALSE;
3547 sym = memsym_of_ast(lhs);
3548 if (!POINTERG(sym) || ADJLENG(sym))
3549 return FALSE;
3550 symdtype = DTYPEG(sym);
3551 tmp = A_SPTRG(rhs);
3552 tmpdtype = DTYPEG(tmp);
3553 if (DTY(tmpdtype) != DTY(symdtype))
3554 return FALSE;
3555
3556 symddtype = DDTG(symdtype);
3557 tmpddtype = DDTG(tmpdtype);
3558 if (DTY(symddtype) != DTY(tmpddtype))
3559 return FALSE;
3560
3561 if (DTY(tmpddtype) == TY_CHAR || DTY(tmpddtype) == TY_NCHAR) {
3562 /* warning - use DDTG for the lhs, since the member itself doesn't
3563 * need to be an array. */
3564 if (ADJLENG(tmp)) /* return temp is adjustable length */
3565 return FALSE;
3566 if (DTY(symddtype + 1) != DTY(tmpddtype + 1)) /* not same char length */
3567 return FALSE;
3568 }
3569 if (A_TYPEG(lhs) == A_ID)
3570 return not_in_arrfn(lhs, call);
3571 if (A_TYPEG(lhs) == A_MEM)
3572 return not_in_arrfn(A_PARENTG(lhs), call);
3573
3574 return FALSE;
3575 } /* subst_lhs_pointer */
3576
3577 static LOGICAL
not_in_arrfn(int memref,int call)3578 not_in_arrfn(int memref, int call)
3579 {
3580 int i;
3581 int nargs;
3582 int argt;
3583 int arg;
3584
3585 nargs = A_ARGCNTG(call);
3586 argt = A_ARGSG(call);
3587 for (i = 1; i < nargs; i++) {
3588 arg = ARGT_ARG(argt, i);
3589 if (contains_ast(arg, memref))
3590 return FALSE;
3591 }
3592 return TRUE;
3593 }
3594
3595 static void
update_proc_ptr_dtype_from_interface(int func_sptr)3596 update_proc_ptr_dtype_from_interface(int func_sptr)
3597 {
3598 if (is_procedure_ptr(func_sptr)) {
3599 int func_dtype = DTYPEG(func_sptr);
3600 int paramct, dpdsc, iface_sptr;
3601 proc_arginfo(func_sptr, ¶mct, &dpdsc, &iface_sptr);
3602 if (iface_sptr > NOSYM) {
3603 if (STYPEG(iface_sptr) != 0 && STYPEG(iface_sptr) != ST_PROC) {
3604 int found_iface_sptr =
3605 findByNameStypeScope(SYMNAME(iface_sptr), ST_PROC, 0);
3606 if (found_iface_sptr > NOSYM && STYPEG(found_iface_sptr) == ST_PROC) {
3607 iface_sptr = found_iface_sptr;
3608 proc_arginfo(iface_sptr, ¶mct, &dpdsc, NULL);
3609 }
3610 }
3611 }
3612 if (iface_sptr > NOSYM && STYPEG(iface_sptr) == ST_PROC) {
3613 int dtproc = DTY(DTYPEG(func_sptr) + 1);
3614 CHECK(DTY(dtproc) == TY_PROC);
3615 DTY(dtproc + 1) = DTYPEG(iface_sptr);
3616 DTY(dtproc + 2) = iface_sptr;
3617 DTY(dtproc + 3) = paramct;
3618 DTY(dtproc + 4) = dpdsc;
3619 }
3620 }
3621 }
3622
3623 /*
3624 * pointer assignment - assign stktop to newtop.
3625 */
3626 static LOGICAL
valid_assign_pointer_types(SST * newtop,SST * stktop)3627 valid_assign_pointer_types(SST *newtop, SST *stktop)
3628 {
3629 LOGICAL is_proc_ptr = FALSE;
3630 int dest = SST_ASTG(newtop);
3631 int source = SST_ASTG(stktop);
3632 DTYPE d1, d2, dtype;
3633
3634 d1 = DDTG(SST_DTYPEG(newtop)); /* Check for procedure ptr */
3635 if (!is_procedure_ptr_dtype(d1) && rank_of_ast(dest) != rank_of_ast(source)) {
3636 if (A_TYPEG(dest) != A_SUBSCR) {
3637 error(155, 3, gbl.lineno, "Illegal POINTER assignment -",
3638 "rank mismatch");
3639 return FALSE;
3640 }
3641 if (rank_of_ast(source) != 1 && !bnds_remap_list(dest)) {
3642 error(155, 3, gbl.lineno, "Illegal POINTER assignment -",
3643 "rank of pointer target must be 1 or equal to rank of pointer "
3644 "object");
3645 return FALSE;
3646 }
3647 }
3648 if (rank_of_ast(source) != 1 && bnds_remap_list(dest) &&
3649 !simply_contiguous(source)) {
3650 error(155, 3, gbl.lineno, "Illegal POINTER assignment -",
3651 "pointer target must be simply contiguous");
3652 return FALSE;
3653 }
3654 dtype = SST_DTYPEG(newtop);
3655 d1 = DDTG(dtype);
3656 d2 = DDTG(SST_DTYPEG(stktop));
3657 is_proc_ptr = is_procedure_ptr_dtype(d1);
3658 if (is_proc_ptr) {
3659 update_proc_ptr_dtype_from_interface(get_ast_sptr(SST_ASTG(newtop)));
3660 d1 = proc_ptr_result_dtype(d1);
3661 if (is_procedure_ptr_dtype(d2)) {
3662 d2 = proc_ptr_result_dtype(d2);
3663 } else {
3664 int rhs_sptr = get_ast_sptr(SST_ASTG(stktop));
3665 if (rhs_sptr > NOSYM) {
3666 int dpdsc = 0, iface_sptr;
3667 proc_arginfo(rhs_sptr, NULL, &dpdsc, &iface_sptr);
3668 if (iface_sptr <= NOSYM)
3669 iface_sptr = rhs_sptr;
3670 if (dpdsc > 0) {
3671 d2 = DTYPEG(iface_sptr);
3672 } else if (iface_sptr > NOSYM && STYPEG(iface_sptr) == ST_PROC &&
3673 SCG(iface_sptr) == SC_EXTERN) {
3674 /* Assume this is a procedure declared with the external
3675 * statement and therefore, does not have an interface. Fortran spec
3676 * allows assignment of external procedures to procedure pointers.
3677 */
3678 d2 = DT_NONE;
3679 }
3680 }
3681 }
3682 }
3683
3684 switch (DTY(d1)) {
3685 case TY_CHAR:
3686 case TY_NCHAR:
3687 if (DTY(d1) != DTY(d2)) {
3688 error(155, 3, gbl.lineno, "Illegal POINTER assignment -",
3689 "type mismatch");
3690 return FALSE;
3691 }
3692 if (d1 == DT_ASSCHAR || d2 == DT_DEFERCHAR)
3693 break;
3694 if (d1 == DT_ASSNCHAR || d2 == DT_DEFERNCHAR)
3695 break;
3696 if (DTY(d1 + 1) && DTY(d2 + 1) && A_ALIASG(DTY(d1 + 1)) &&
3697 A_ALIASG(DTY(d2 + 1)) && DTY(d1 + 1) != DTY(d2 + 1)) {
3698 error(155, 3, gbl.lineno, "Illegal POINTER assignment -",
3699 "type mismatch");
3700 return FALSE;
3701 }
3702 break;
3703 default:
3704 if (!eq_dtype2(d1, d2, TRUE)) { /* TRUE for polymorphic ptrs */
3705 if (UNLPOLYG(DTY(d1 + 3))) /* true for CLASS(*) ptrs */
3706 return TRUE;
3707 if (is_proc_ptr && d2 == DT_NONE)
3708 return TRUE;
3709 error(155, 3, gbl.lineno, "Illegal POINTER assignment -",
3710 "type mismatch");
3711 return FALSE;
3712 }
3713 }
3714
3715 if (DTY(dtype) == TY_ARRAY && !DT_ISVEC(array_element_dtype(dtype))) {
3716 error83(DTYG(dtype));
3717 return FALSE;
3718 }
3719
3720 return TRUE;
3721 }
3722
3723 static int
assign_intrinsic_to_pointer(SST * newtop,SST * stktop)3724 assign_intrinsic_to_pointer(SST *newtop, SST *stktop)
3725 {
3726 int dtype;
3727 int shape;
3728 int ast;
3729 int dest, source;
3730 int pvar;
3731
3732 dest = SST_ASTG(newtop);
3733 source = SST_ASTG(stktop);
3734
3735 if (PDNUMG(A_SPTRG(A_LOPG(source))) != PD_null) {
3736 error(155, 3, gbl.lineno, "Illegal POINTER assignment", CNULL);
3737 if (INSIDE_STRUCT) {
3738 sem.dinit_error = TRUE;
3739 }
3740 return 0;
3741 }
3742
3743 pvar = find_pointer_variable_assign(dest, SST_DIMFLAGG(newtop));
3744 if (pvar == 0) {
3745 error(155, 3, gbl.lineno, "Illegal POINTER assignment -",
3746 "non-POINTER object");
3747 return 0;
3748 }
3749 if (!POINTERG(pvar)) {
3750 error(72, 3, gbl.lineno, SYMNAME(pvar), "- must be a POINTER variable");
3751 return 0;
3752 }
3753
3754 set_assn(sym_of_ast(dest));
3755
3756 if (DTY(A_DTYPEG(source)) == TY_WORD) {
3757 A_DTYPEP(source, A_DTYPEG(dest));
3758 A_SHAPEP(source, A_SHAPEG(dest));
3759 } else if (!valid_assign_pointer_types(newtop, stktop)) {
3760 if (INSIDE_STRUCT) {
3761 sem.dinit_error = TRUE;
3762 }
3763 return 0;
3764 }
3765
3766 return add_ptr_assign(dest, source, 0);
3767 }
3768
3769 int
assign_pointer(SST * newtop,SST * stktop)3770 assign_pointer(SST *newtop, SST *stktop)
3771 {
3772 int dtype;
3773 int shape;
3774 int ast;
3775 int dest, source, call;
3776 int pvar;
3777 int d1, d2;
3778
3779 ast = 0;
3780
3781 if (mklvalue(newtop, 1) == 0)
3782 /* Avoid assignment ILM's if lvalue is illegal */
3783 return 0;
3784
3785 if (A_TYPEG(SST_ASTG(stktop)) == A_INTR) {
3786 set_assn(sym_of_ast(A_LOPG(SST_ASTG(stktop))));
3787 return assign_intrinsic_to_pointer(newtop, stktop);
3788 }
3789
3790 if (SST_IDG(stktop) == S_IDENT) {
3791 int sptr = SST_SYMG(stktop), sp2;
3792 switch (STYPEG(sptr)) {
3793 case ST_GENERIC:
3794 if (!select_gsame(sptr))
3795 break;
3796 /* fall thru */
3797 case ST_PD:
3798 case ST_INTRIN:
3799 sp2 = intrinsic_as_arg(sptr);
3800 if (sp2 == 0)
3801 break;
3802 TARGETP(sp2, 1);
3803 SST_IDP(stktop, S_EXPR);
3804 SST_ASTP(stktop, mk_id(sp2));
3805 SST_DTYPEP(stktop, DTYPEG(sp2));
3806 SST_SHAPEP(stktop, 0);
3807 break;
3808 default:;
3809 }
3810 }
3811
3812 dtype = SST_DTYPEG(newtop);
3813 shape = SST_SHAPEG(newtop);
3814
3815 mkexpr2(stktop);
3816
3817 /* both sides of the assignment must be of the same type, type parameters
3818 * and rank.
3819 */
3820 dest = SST_ASTG(newtop);
3821 source = SST_ASTG(stktop);
3822
3823 pvar = find_pointer_variable_assign(dest, SST_DIMFLAGG(newtop));
3824 if (pvar == 0) {
3825 error(155, 3, gbl.lineno, "Illegal POINTER assignment -",
3826 "non-POINTER object");
3827 return 0;
3828 }
3829 if (!POINTERG(pvar)) {
3830 error(72, 3, gbl.lineno, SYMNAME(pvar), "- must be a POINTER variable");
3831 return 0;
3832 }
3833
3834 if (is_procedure_ptr(pvar)) {
3835 int iface=0;
3836 proc_arginfo(pvar, NULL, NULL, &iface);
3837 if (ELEMENTALG(iface) && !IS_INTRINSIC(STYPEG(iface)) && !CCSYMG(iface)) {
3838 error(1010, ERR_Severe, gbl.lineno, SYMNAME(pvar), CNULL);
3839 }
3840 }
3841
3842 if (chk_pointer_intent(pvar, dest))
3843 return 0;
3844
3845 if (chk_pointer_target(pvar, source))
3846 return 0;
3847
3848 if (!valid_assign_pointer_types(newtop, stktop))
3849 return 0;
3850
3851 call = STD_AST(sem.arrfn.call_std);
3852 if (gbl.maxsev < 3 && sem.arrfn.try && source == sem.arrfn.return_value &&
3853 subst_lhs_pointer(dest, source, call)) {
3854 /*
3855 * The RHS of the assignment is a function call for which
3856 * the result temp can be replaced by the lhs.
3857 */
3858 int argt;
3859 int arr_tmp;
3860
3861 arr_tmp = A_SPTRG(source);
3862 argt = A_ARGSG(call);
3863 ARGT_ARG(argt, 0) = dest;
3864 sem.arrfn.try
3865 = 0;
3866 return 0;
3867 }
3868
3869 return add_ptr_assign(dest, source, 0);
3870 }
3871
3872 /** \brief Generates a call to a poly_element_addr runtime routine that
3873 * computes the address of a polymorphic array element.
3874 *
3875 * This is required when our passed object argument of a type bound
3876 * procedure call is an array element.
3877 *
3878 * \param ast is the ast of the passed object argument (an A_SUBSCR ast).
3879 * \param sptr is the symbol table pointer of the passed object argument.
3880 * \param std is the current statement descriptor.
3881 *
3882 * \return an ast that represents the pointer that holds the address of the
3883 * polymorphic array element.
3884 */
3885 int
gen_poly_element_arg(int ast,SPTR sptr,int std)3886 gen_poly_element_arg(int ast, SPTR sptr, int std)
3887 {
3888
3889 SPTR func, tmp, ptr, sdsc, ptr_sdsc;
3890 int astnew, args;
3891 int asd, numdim, i, ss;
3892 int tmp_ast, ptr_ast, sdsc_ast, ptr_sdsc_ast;
3893 DTYPE dtype;
3894 FtnRtlEnum rtlRtn;
3895
3896 dtype = DTYPEG(sptr);
3897
3898 assert(DTY(dtype) == TY_ARRAY, "gen_poly_element_arg: Expected array dtype",
3899 dtype, 4);
3900
3901 dtype = DTY(dtype+1);
3902
3903 asd = A_ASDG(ast);
3904 numdim = ASD_NDIM(asd);
3905 args = mk_argt(3+numdim);
3906
3907 for (i = 0; i < numdim; ++i) {
3908 ss = ASD_SUBS(asd, i);
3909 ARGT_ARG(args, 3+i) = ss;
3910 }
3911
3912 ARGT_ARG(args, 0) = A_LOPG(ast);
3913 if (SCG(sptr) == SC_DUMMY && (needs_descriptor(sptr) || CLASSG(sptr))) {
3914 fix_class_args(gbl.currsub);
3915 sdsc = get_type_descr_arg(gbl.currsub, sptr);
3916 } else {
3917 sdsc = 0;
3918 }
3919 if (sdsc <= NOSYM) {
3920 do {
3921 if (STYPEG(sptr) == ST_MEMBER) {
3922 sdsc = get_member_descriptor(sptr);
3923 } else {
3924 sdsc = SDSCG(sptr);
3925 }
3926 if (sdsc > NOSYM) {
3927 break;
3928 }
3929 get_static_descriptor(sptr);
3930 assert(SDSCG(sptr) > NOSYM, "gen_poly_element_arg: get_static_descriptor"
3931 " failed", sptr, 4); /* sanity check */
3932 } while(true);
3933 }
3934
3935 sdsc_ast = mk_id(sdsc);
3936 sdsc_ast = check_member(ast, sdsc_ast);
3937
3938 ptr = getccsym_sc('d', sem.dtemps++, ST_VAR, SC_LOCAL);
3939 DTYPEP(ptr, dtype);
3940 POINTERP(ptr, 1);
3941 CLASSP(ptr, CLASSG(sptr));
3942 ADDRTKNP(ptr, 1);
3943 set_descriptor_rank(1);
3944 get_static_descriptor(ptr);
3945 set_descriptor_rank(0);
3946 ptr_sdsc = SDSCG(ptr);
3947 ptr_sdsc_ast = mk_id(ptr_sdsc);
3948
3949 if (DTY(dtype) == TY_DERIVED) {
3950 astnew = mk_set_type_call(ptr_sdsc_ast, sdsc_ast, 0);
3951 } else {
3952 int type_code = dtype_to_arg(DTY(dtype));
3953 type_code = mk_cval1(type_code, DT_INT);
3954 type_code = mk_unop(OP_VAL, type_code, DT_INT);
3955 astnew = mk_set_type_call(ptr_sdsc_ast, type_code, 1);
3956 }
3957
3958 std = add_stmt_before(astnew, std);
3959
3960 ARGT_ARG(args, 1) = sdsc_ast;
3961
3962 switch(numdim) {
3963 case 1:
3964 rtlRtn = RTE_poly_element_addr1;
3965 break;
3966 case 2:
3967 rtlRtn = RTE_poly_element_addr2;
3968 break;
3969 case 3:
3970 rtlRtn = RTE_poly_element_addr3;
3971 break;
3972 default:
3973 rtlRtn = RTE_poly_element_addr;
3974 }
3975
3976 func = mk_id(sym_mkfunc_nodesc(mkRteRtnNm(rtlRtn), DT_NONE));
3977
3978 tmp = getccsym_sc('d', sem.dtemps++, ST_VAR, SC_LOCAL);
3979 DTYPEP(tmp, dtype);
3980 POINTERP(tmp, 1);
3981 tmp_ast = mk_id(tmp);
3982 A_DTYPEP(tmp_ast, dtype);
3983 A_PTRREFP(tmp_ast, 1);
3984 ARGT_ARG(args, 2) = tmp_ast;
3985
3986 astnew = mk_func_node(A_CALL, func, 3+numdim, args);
3987
3988 std = add_stmt_after(astnew, std);
3989
3990 ptr_ast = mk_id(ptr);
3991 astnew = add_ptr_assign(ptr_ast, tmp_ast, std);
3992 add_stmt_after(astnew, std);
3993 return ptr_ast;
3994 }
3995
3996 int
add_ptr_assign(int dest,int src,int std)3997 add_ptr_assign(int dest, int src, int std)
3998 {
3999 int func;
4000 int ast;
4001 int dtype, tag;
4002 int dtype2, tag2, dtype3;
4003 SPTR dest_sptr, src_sptr, sdsc;
4004 int newargt, astnew;
4005
4006 /* Check if the dest is scalar, if so assign len to descriptor
4007 * For array, it was done in runtime.
4008 * Also, check if it is assigned to NULL, then don't assign len
4009 */
4010
4011 dtype = A_DTYPEG(dest);
4012 dtype2 = A_DTYPEG(src);
4013
4014 if (DTY(dtype) == TY_DERIVED) {
4015 tag = DTY(dtype + 3);
4016 } else if (DTY(dtype) == TY_ARRAY) {
4017 dtype3 = DTY(dtype + 1);
4018 if (DTY(dtype3) == TY_DERIVED) {
4019 tag = DTY(dtype3 + 3);
4020 } else {
4021 tag = 0;
4022 }
4023 } else {
4024 tag = 0;
4025 }
4026
4027 if (DTY(dtype2) == TY_DERIVED) {
4028 tag2 = DTY(dtype2 + 3);
4029 } else if (DTY(dtype2) == TY_ARRAY) {
4030 dtype3 = DTY(dtype2 + 1);
4031 if (DTY(dtype3) == TY_DERIVED) {
4032 tag2 = DTY(dtype3 + 3);
4033 } else {
4034 tag2 = 0;
4035 }
4036 } else {
4037 tag2 = 0;
4038 }
4039
4040 if (tag && tag2 && has_type_parameter(dtype2) && has_type_parameter(dtype) &&
4041 !BASETYPEG(tag) && BASETYPEG(tag2)) {
4042 /* The parameterized derived type (PDT) for the destination
4043 * pointer is currently set to the default/base type. Now that it's
4044 * being used, we need to instantiate it with the source type.
4045 */
4046 if (DTY(dtype2) == TY_ARRAY) {
4047 dtype2 = DTY(dtype2 + 1);
4048 }
4049 dtype3 = create_parameterized_dt(dtype2, 1);
4050 if (DTY(dtype) == TY_ARRAY) {
4051 dtype = dup_array_dtype(dtype);
4052 DTY(dtype + 1) = dtype3;
4053 } else {
4054 dtype = dtype3;
4055 }
4056 A_DTYPEP(dest, dtype);
4057 DTYPEP(memsym_of_ast(dest), dtype);
4058 }
4059
4060 if ((dtype == DT_DEFERCHAR || dtype == DT_DEFERNCHAR ||
4061 (UNLPOLYG(tag) && DTY(A_DTYPEG(src)) == TY_CHAR)) &&
4062 !is_dtype_unlimited_polymorphic(A_DTYPEG(src))) {
4063 int dest_len_ast = get_len_of_deferchar_ast(dest);
4064 int src_len_ast, cvlen;
4065 if (A_TYPEG(src) == A_INTR && A_OPTYPEG(src) == I_NULL)
4066 src_len_ast = mk_cval(0, astb.bnd.dtype);
4067 else
4068 src_len_ast = string_expr_length(src);
4069 cvlen = mk_assn_stmt(dest_len_ast, src_len_ast, astb.bnd.dtype);
4070 if (std)
4071 add_stmt_before(cvlen, std);
4072 else
4073 add_stmt(cvlen);
4074 }
4075
4076 if (ast_is_sym(src)) {
4077 src_sptr = memsym_of_ast(src);
4078 } else {
4079 src_sptr = 0;
4080 }
4081
4082 dest_sptr = memsym_of_ast(dest);
4083
4084 if (DTY(dtype) == TY_PTR) {
4085
4086 if (STYPEG(src_sptr) == ST_PROC) {
4087 int iface=0, iface2=0, dpdsc=0, dpdsc2=0;
4088 proc_arginfo(src_sptr, NULL, &dpdsc, &iface);
4089 proc_arginfo(dest_sptr, NULL, &dpdsc2, &iface2);
4090 if (iface > NOSYM && iface2 > NOSYM && dpdsc != 0 && dpdsc2 != 0 &&
4091 !cmp_interfaces_strict(iface2, iface,
4092 (IGNORE_ARG_NAMES|RELAX_STYPE_CHK))) {
4093 /* issue an error if src_sptr is not declared with an external
4094 * statement and its interface does not match dest_sptr's interface.
4095 */
4096 error(1008, ERR_Severe, gbl.lineno, SYMNAME(dest_sptr), CNULL);
4097 }
4098 }
4099 if (STYPEG(src_sptr) == ST_PROC && INTERNALG(src_sptr)) {
4100 sdsc = SDSCG(dest_sptr);
4101 if (sdsc == 0)
4102 get_static_descriptor(dest_sptr);
4103 if (STYPEG(dest_sptr) == ST_MEMBER)
4104 sdsc = get_member_descriptor(dest_sptr);
4105 if (sdsc <= NOSYM)
4106 sdsc = SDSCG(dest_sptr);
4107 /* Note: closure pointer register argument to RTE_asn_closure is added
4108 * in exp_rte.c.
4109 */
4110 newargt = mk_argt(1);
4111 ARGT_ARG(newargt, 0) = STYPEG(sdsc) != ST_MEMBER ? mk_id(sdsc) :
4112 check_member(dest, mk_id(sdsc));
4113 func = mk_id(sym_mkfunc_nodesc(mkRteRtnNm(RTE_asn_closure), DT_NONE));
4114 /* Setting the recursive flag on the host subprogram forces the contains
4115 * subprograms to use the closure pointer register and not a direct
4116 * uplevel memory reference (which does not work with pointers
4117 * to internal procedures).
4118 */
4119 RECURP(gbl.currsub, 1);
4120 astnew = mk_func_node(A_CALL, func, 1, newargt);
4121 if (std)
4122 add_stmt_before(astnew, std);
4123 else
4124 add_stmt(astnew);
4125 }
4126 }
4127 func = intast_sym[I_PTR2_ASSIGN];
4128 ast = begin_call(A_ICALL, func, 2);
4129 A_OPTYPEP(ast, I_PTR2_ASSIGN);
4130 add_arg(dest);
4131 add_arg(src);
4132 if (XBIT(54, 0x40) && ast_is_sym(dest) && CONTIGATTRG(memsym_of_ast(dest))) {
4133 /* Add contiguity pointer check. We add the check after the pointer
4134 * assignment so we will get the correct section descriptor for dest.
4135 */
4136 if (std) {
4137 std = add_stmt_before(ast, std);
4138 } else {
4139 std = add_stmt(ast);
4140 }
4141 ast = mk_stmt(A_CONTINUE, 0);
4142 std = add_stmt_after(ast, std);
4143 gen_contig_check(dest, dest, 0, gbl.lineno, false, std);
4144 ast = mk_stmt(A_CONTINUE, 0); /* return a continue statement */
4145 }
4146 return ast;
4147 }
4148
4149 /** \brief Generate contiguity check test inline (experimental)
4150 *
4151 * Called by gen_contig_check() below to generate the contiguity check inline.
4152 * This is an experimental test since it looks at the descriptor flags,
4153 * data type, and src_sptr if src_sptr is an optional dummy argument. The
4154 * endif asts are generated in gen_contig_check().
4155 *
4156 * \param src is the source/pointer target ast.
4157 * \param src_sptr is the source/pointer target sptr.
4158 * \param sdsc is the source/pointer target's descriptor
4159 * \param std is the optional statement descriptor for adding the check (0
4160 * if not applicable).
4161 *
4162 * \return the statement descriptor (std) of the generated code.
4163 */
4164 static int
inline_contig_check(int src,SPTR src_sptr,SPTR sdsc,int std)4165 inline_contig_check(int src, SPTR src_sptr, SPTR sdsc, int std)
4166 {
4167 int flagsast = get_header_member_with_parent(src, sdsc, DESC_HDR_FLAGS);
4168 int lenast = get_header_member_with_parent(src, sdsc, DESC_HDR_BYTE_LEN);
4169 int sizeast = size_ast(src_sptr, DDTG(DTYPEG(src_sptr)));
4170 int cmp, astnew, seqast, newargt;
4171
4172 /* Step 1: Add insertion point in AST */
4173 astnew = mk_stmt(A_CONTINUE, 0);
4174 if (std)
4175 std = add_stmt_before(astnew, std);
4176 else
4177 std = add_stmt(astnew);
4178
4179 /* Step 2: If src_sptr is an optional argument, then generate an
4180 * argument "present" check. Also generate this check if XBIT(54, 0x200)
4181 * is set which says to ignore null pointer targets.
4182 */
4183 if (XBIT(54, 0x200) || (SCG(src_sptr) == SC_DUMMY && OPTARGG(src_sptr))) {
4184 int present = ast_intr(I_PRESENT, stb.user.dt_log, 1, src);
4185 astnew = mk_stmt(A_IFTHEN, 0);
4186 A_IFEXPRP(astnew, present);
4187 std = add_stmt_after(astnew, std);
4188 }
4189
4190 /* Step 3: Check descriptor flag to see if it includes
4191 * __SEQUENTIAL_SECTION.
4192 */
4193 seqast = mk_isz_cval(__SEQUENTIAL_SECTION, DT_INT);
4194 flagsast = ast_intr(I_AND, astb.bnd.dtype, 2, flagsast, seqast);
4195 cmp = mk_binop(OP_EQ, flagsast, astb.i0, DT_INT);
4196 astnew = mk_stmt(A_IFTHEN, 0);
4197 A_IFEXPRP(astnew, cmp);
4198 std = add_stmt_after(astnew, std);
4199
4200 /* Step 4: Check element size to see if it matches descriptor
4201 * element size (i.e., check for a noncontiguous array subobject like
4202 * p => dt(:)%m where dt has more than one component).
4203 */
4204 cmp = mk_binop(OP_EQ, lenast, sizeast, DT_INT);
4205 astnew = mk_stmt(A_IFTHEN, 0);
4206 A_IFEXPRP(astnew, cmp);
4207 std = add_stmt_after(astnew, std);
4208
4209 return std;
4210 }
4211
4212 /** \brief Generate a contiguous pointer check on a pointer assignment
4213 * when applicable.
4214 *
4215 * \param dest is the destination pointer.
4216 * \param src is the pointer target.
4217 * \param sdsc is an optional descriptor argument to pass to the check
4218 * function (0 to use src's descriptor).
4219 * \param srcLine is the line number associated with the check.
4220 * \param cs is true when we are generating the check at a call-site.
4221 * \param std is the optional statement descriptor for adding the check (0
4222 * if not applicable).
4223 */
4224 void
gen_contig_check(int dest,int src,SPTR sdsc,int srcLine,bool cs,int std)4225 gen_contig_check(int dest, int src, SPTR sdsc, int srcLine, bool cs, int std)
4226 {
4227 int newargt, astnew;
4228 SPTR src_sptr, dest_sptr, func;
4229 bool isFuncCall, inlineContigCheck, ignoreNullTargets;
4230 int argFlags;
4231
4232 if (ast_is_sym(src)) {
4233 src_sptr = memsym_of_ast(src);
4234 } else {
4235 interr("gen_contig_check: invalid src ast", src, 3);
4236 src_sptr = 0;
4237 }
4238
4239 if (ast_is_sym(dest)) {
4240 dest_sptr = memsym_of_ast(dest);
4241 } else {
4242 interr("gen_contig_check: invalid dest ast", dest, 3);
4243 dest_sptr = 0;
4244 }
4245 isFuncCall = (RESULTG(dest_sptr) && FVALG(gbl.currsub) != dest_sptr);
4246 /* If XBIT(54, 0x200) is set, we ignore null pointer targets. If
4247 * we have an optional argument, then we need to igore it if it's
4248 * null (i.e., not present).
4249 */
4250 ignoreNullTargets = (XBIT(54, 0x200) || (SCG(dest_sptr) == SC_DUMMY &&
4251 OPTARGG(dest_sptr)));
4252 if (CONTIGATTRG(dest_sptr) || (CONTIGATTRG(src_sptr) && isFuncCall)) {
4253 int lineno, ptrnam, srcfil;
4254 if (sdsc <= NOSYM)
4255 sdsc = SDSCG(src_sptr);
4256 if (sdsc <= NOSYM)
4257 get_static_descriptor(src_sptr);
4258 if (STYPEG(src_sptr) == ST_MEMBER)
4259 sdsc = get_member_descriptor(src_sptr);
4260 if (sdsc <= NOSYM)
4261 sdsc = SDSCG(src_sptr);
4262 lineno = mk_cval1(srcLine, DT_INT);
4263 lineno = mk_unop(OP_VAL, lineno, DT_INT);
4264 ptrnam = !isFuncCall ? getstring(SYMNAME(dest_sptr),
4265 strlen(SYMNAME(dest_sptr))+1) :
4266 getstring(SYMNAME(src_sptr), strlen(SYMNAME(src_sptr))+1);
4267 srcfil = getstring(gbl.curr_file, strlen(gbl.curr_file)+1);
4268 /* Check to see if we should inline the contiguity check. We do not
4269 * currently inline it if the user is also generating checks at the
4270 * call-site. Currently the inlining routine uses an argument structure
4271 * that may conflict with the call-site (but not when we're generating
4272 * checks for pointer assignments or arguments inside a callee).
4273 * We could possibly support inlining at the call-site by deferring the
4274 * check after we generate the call-site code. However, this may be
4275 * a lot of work for something that probably will not be used too often.
4276 * Generating checks for pointer assignments and for arguments inside a
4277 * callee are typically sufficient. The only time one needs to check
4278 * the call-site is when the called routine is inside a library that was
4279 * not compiled with contiguity checking.
4280 */
4281 inlineContigCheck = (XBIT(54, 0x100) && !cs);
4282 if (inlineContigCheck) {
4283 std = inline_contig_check(src, src_sptr, sdsc, std);
4284 }
4285 newargt = mk_argt(6);
4286 ARGT_ARG(newargt, 0) = A_TYPEG(src) == A_SUBSCR ? A_LOPG(src) : src;
4287 ARGT_ARG(newargt, 1) = STYPEG(sdsc) != ST_MEMBER ? mk_id(sdsc) :
4288 check_member(src, mk_id(sdsc));
4289 ARGT_ARG(newargt, 2) = lineno;
4290 ARGT_ARG(newargt, 3) = mk_id(ptrnam);
4291 ARGT_ARG(newargt, 4) = mk_id(srcfil);
4292 /* We can pass some flags about src here. For now, the flag is 1 if
4293 * dest_sptr is an optional argument or if we do not want to flag null
4294 * pointer targets. That way, we do not indicate a contiguity error
4295 * if the argument is not present or if the pointer target is null.
4296 */
4297 argFlags = mk_cval1( ignoreNullTargets ? 1 : 0, DT_INT);
4298 argFlags = mk_unop(OP_VAL, argFlags, DT_INT);
4299 ARGT_ARG(newargt, 5) = argFlags;
4300
4301 func = mk_id(sym_mkfunc_nodesc(inlineContigCheck ?
4302 mkRteRtnNm(RTE_contigerror) :
4303 mkRteRtnNm(RTE_contigchk), DT_NONE));
4304 astnew = mk_func_node(A_CALL, func, 6, newargt);
4305 if (inlineContigCheck) {
4306 /* generate endifs for inline contiguity checks */
4307 std = add_stmt_after(astnew, std);
4308 std = add_stmt_after(mk_stmt(A_ENDIF,0), std);
4309 if (ignoreNullTargets) {
4310 std = add_stmt_after(mk_stmt(A_ENDIF,0), std);
4311 }
4312 add_stmt_after(mk_stmt(A_ENDIF,0), std);
4313 } else if (std) {
4314 add_stmt_before(astnew, std);
4315 } else {
4316 add_stmt(astnew);
4317 }
4318 }
4319 }
4320
4321 int
mk_component_ast(int leaf,int parent,int src_ast)4322 mk_component_ast(int leaf, int parent, int src_ast)
4323 {
4324 int new_src_ast;
4325 int new_src_dt;
4326 int i, i2;
4327 int dt, nsubs, ndim, add, subs[MAXDIMS];
4328 ADSC *ad;
4329
4330 new_src_ast = mk_id(leaf);
4331 new_src_dt = DTYPEG(leaf);
4332 dt = DDTG(new_src_dt);
4333 nsubs = 0;
4334 if (A_TYPEG(src_ast) == A_SUBSCR) {
4335 ad = AD_DPTR(DTYPEG(parent));
4336 nsubs = AD_NUMDIM(ad);
4337 }
4338
4339 /* now check to see if we have to add subscripts because the
4340 component itself was originally an array. (Now the component
4341 will still be an array, but may have more dimensions.) */
4342 i2 = 0;
4343 ndim = 0;
4344 if (DTY(new_src_dt) == TY_ARRAY) {
4345 ad = AD_DPTR(new_src_dt);
4346 ndim = AD_NUMDIM(ad);
4347 if (nsubs != ndim) {
4348 /* we have to add subscripts. */
4349 add = ndim - nsubs;
4350 if (add <= 0)
4351 interr("mk_component_ast: derived type assign src", leaf, 3);
4352 else
4353 dt = new_src_dt; /* want array of ... */
4354 for (; i2 < add; i2++) {
4355 subs[i2] = mk_triple(AD_LWAST(ad, i2), AD_UPAST(ad, i2), 0);
4356 }
4357 }
4358 }
4359 if (nsubs) {
4360 add = i2 + nsubs;
4361 i = 0;
4362 for (; i2 < add; i2++) {
4363 subs[i2] = ASD_SUBS(A_ASDG(src_ast), i++);
4364 }
4365 }
4366 if (ndim) {
4367 new_src_ast = mk_subscr(new_src_ast, subs, ndim, dt);
4368 A_DTYPEP(new_src_ast, dt);
4369 }
4370
4371 return new_src_ast;
4372 }
4373
4374 /* Similar to ast.c:find_pointer_variable(), but it also looks for a
4375 * special case where we're performing pointer reshaping (e.g.
4376 * ptr(1:n) => x or ptr(1:) => x). Therefore, this function only gets
4377 * called by assign_pointer() and assign_intrinsic_to_pointer().
4378 */
4379 static int
find_pointer_variable_assign(int ast,int dimFlag)4380 find_pointer_variable_assign(int ast, int dimFlag)
4381 {
4382 if (A_TYPEG(ast) == A_SUBSCR) { /* ptr reshape */
4383 int shd, nd, asd, i, sub, ubast, lbast, ast2;
4384 int bounds_spec_list, bounds_remapping_list;
4385 shd = A_SHAPEG(ast);
4386 nd = SHD_NDIM(shd);
4387 asd = A_ASDG(ast);
4388 ast2 = A_LOPG(ast);
4389 if (A_TYPEG(ast2) == A_MEM)
4390 ast2 = A_MEMG(ast2);
4391 for (bounds_spec_list = bounds_remapping_list = i = 0; i < nd; ++i) {
4392 sub = ASD_SUBS(asd, i);
4393 ubast = A_UPBDG(sub);
4394 lbast = A_LBDG(sub);
4395 if (A_STRIDEG(sub)) {
4396 error(155, 3, gbl.lineno, "Illegal POINTER assignment -",
4397 "stride specification not allowed in destination pointer "
4398 "section");
4399 return 0; /* p(l:u:s) => ... not valid for specified stride */
4400 }
4401 if (dimFlag & (0x2 << (i * 3))) {
4402 /* p(l:) => or p(:) =>
4403 * need to discard compiler inserted expr for upperbound.
4404 */
4405 A_UPBDP(sub, 0);
4406 ubast = 0;
4407 }
4408 if (dimFlag & (0x1 << (i * 3))) {
4409 /* p(:u) => or p(:) =>
4410 * need to discard compiler inserted expr for lowerbound.
4411 */
4412 A_LBDP(sub, 0);
4413 lbast = 0;
4414 }
4415 if (!lbast) {
4416 error(155, 3, gbl.lineno, "Illegal POINTER assignment -",
4417 "illegal implied lowerbound in destination pointer "
4418 "section");
4419 return 0; /*p(:) => or p(:u) => not valid for implied lowerbound */
4420 }
4421 if (ubast) {
4422 if (bounds_spec_list) {
4423 /* cannot mix bounds-spec-list dimensions with
4424 * bounds-remapping-list dimensions (e.g., x(l:u,l:) is
4425 * not valid). See 7.4.2 Pointer Assignment in F2003 spec.
4426 */
4427 error(155, 3, gbl.lineno, "Illegal POINTER assignment -",
4428 "inconsistent dimension specification in "
4429 "destination pointer section");
4430
4431 return 0;
4432 }
4433 bounds_remapping_list = 1;
4434 } else {
4435 if (bounds_remapping_list) {
4436 /* cannot mix bounds-spec-list dimensions with
4437 * bounds-remapping-list dimensions (e.g., x(l:u,l:) is
4438 * not valid) See 7.4.2 Pointer Assignment in F2003 spec.
4439 */
4440 error(155, 3, gbl.lineno, "Illegal POINTER assignment -",
4441 "inconsistent dimension specification in "
4442 "destination pointer section");
4443
4444 return 0;
4445 }
4446 bounds_spec_list = 1;
4447 }
4448 }
4449 ast = ast2;
4450 }
4451 return find_pointer_variable(ast);
4452 }
4453
4454 int
chk_pointer_intent(int pvar,int refast)4455 chk_pointer_intent(int pvar, int refast)
4456 {
4457 if (STYPEG(pvar) == ST_MEMBER) {
4458 if (refast) {
4459 int ss;
4460 ss = getbase(refast);
4461 if (SCG(ss) == SC_DUMMY && !POINTERG(ss) && !ALLOCATTRG(ss) &&
4462 INTENTG(ss) == INTENT_IN) {
4463 error(155, 3, gbl.lineno,
4464 "Derived type argument cannot be INTENT(IN) --", SYMNAME(ss));
4465 return 1;
4466 }
4467 }
4468 } else if (SCG(pvar) == SC_DUMMY && INTENTG(pvar) == INTENT_IN) {
4469 error(155, 3, gbl.lineno, "POINTER argument cannot be INTENT(IN) --",
4470 SYMNAME(pvar));
4471 return 1;
4472 }
4473 return 0;
4474 }
4475
4476 int
any_pointer_source(int ast)4477 any_pointer_source(int ast)
4478 {
4479 again:
4480 switch (A_TYPEG(ast)) {
4481 case A_ID:
4482 if (POINTERG(A_SPTRG(ast)))
4483 return 1;
4484 break;
4485 case A_FUNC:
4486 case A_SUBSCR:
4487 case A_SUBSTR:
4488 ast = A_LOPG(ast);
4489 goto again;
4490 case A_MEM:
4491 if (POINTERG(A_SPTRG(A_MEMG(ast))))
4492 return 1;
4493 ast = A_PARENTG(ast);
4494 goto again;
4495 default:
4496 break;
4497 }
4498 return 0;
4499 }
4500
4501 int
chk_pointer_target(int pvar,int source)4502 chk_pointer_target(int pvar, int source)
4503 {
4504 int targetbase;
4505 int target;
4506
4507 find_pointer_target(source, &targetbase, &target);
4508 if (target == 0 || targetbase == 0) {
4509 error(155, 3, gbl.lineno, "Illegal target of a POINTER assignment", CNULL);
4510 return 1;
4511 }
4512 if (STYPEG(target) == ST_PROC) {
4513 if (is_procedure_ptr(pvar)) {
4514 ADDRTKNP(target, 1);
4515 return 0;
4516 }
4517 error(155, 3, gbl.lineno, "Illegal target of a POINTER assignment", CNULL);
4518 return 1;
4519 }
4520 if (!TARGETG(targetbase) && !POINTERG(target) &&
4521 !any_pointer_source(source)) {
4522 error(84, 3, gbl.lineno, SYMNAME(target),
4523 "- must have the TARGET or POINTER attribute");
4524 return 1;
4525 }
4526 if (TARGETG(targetbase)) {
4527 ADDRTKNP(targetbase, 1);
4528 #ifdef PTRRHSG
4529 PTRRHSP(targetbase, 1);
4530 #endif
4531 if (F77OUTPUT && XBIT(49, 0x8000) && DT_ISCMPLX(DDTG(DTYPEG(target))))
4532 error(155, 2, gbl.lineno, "Complex TARGET may not be properly aligned -",
4533 SYMNAME(target));
4534 if (is_protected(targetbase)) {
4535 err_protected(targetbase, "be a pointer target");
4536 }
4537 }
4538 return 0;
4539 }
4540
4541 LOGICAL
is_protected(int sptr)4542 is_protected(int sptr)
4543 {
4544 if (PROTECTEDG(sptr) && ENCLFUNCG(sptr) != sem.mod_sym)
4545 return TRUE;
4546 return FALSE;
4547 }
4548
4549 void
err_protected(int sptr,char * context)4550 err_protected(int sptr, char *context)
4551 {
4552 char bf[128];
4553 sprintf(bf, "%s %s -",
4554 "A use-associated object with the PROTECTED attribute cannot",
4555 context);
4556 error(155, 3, gbl.lineno, bf, SYMNAME(sptr));
4557 }
4558
4559 void
set_assn(int sptr)4560 set_assn(int sptr)
4561 {
4562 ASSNP(sptr, 1);
4563 /* it's legal for inherited submodules to access protected variables
4564 defined parent modules, otherwise it's illegal */
4565 if (is_protected(sptr) && !is_used_by_submod(gbl.currsub, sptr)) {
4566 err_protected(sptr, "be assigned");
4567 }
4568 }
4569
4570 static void
cast_to_typeless(SST * op,int typ)4571 cast_to_typeless(SST *op, int typ)
4572 {
4573 int conv_ast;
4574
4575 (void)casttyp(op, typ);
4576
4577 if (typ != TY_WORD && typ != TY_DWORD)
4578 return;
4579
4580 if (SST_ASTG(op)) {
4581 conv_ast = mk_convert(SST_ASTG(op), typ);
4582 if (conv_ast != SST_ASTG(op)) {
4583 SST_ASTP(op, conv_ast);
4584 }
4585 }
4586 }
4587
4588 /** \brief Make two operands conform in a binary operation. The sequence of
4589 events is crucial to correct interpretation of expression.
4590 */
4591 void
chkopnds(SST * lop,SST * operator,SST * rop)4592 chkopnds(SST *lop, SST *operator, SST *rop)
4593 {
4594 int dltype, drtype; /* data type */
4595 int opc, opl;
4596
4597 #define ARITH(o) \
4598 (o == OP_ADD || o == OP_SUB || o == OP_MUL || o == OP_DIV || o == OP_XTOI)
4599 #define OK_LTYP(t) \
4600 ((t) == TY_WORD || (t) == TY_DWORD || (t) == TY_BINT || (t) == TY_SINT || \
4601 (t) == TY_INT || (t) == TY_CHAR || (t) == TY_NCHAR)
4602
4603 /* define OP_ macros not defined in ast.h which will represent the bit-wise
4604 * variants of OP_LOR, OP_LAND, OP_EQV, OP_XOR, respectively.
4605 */
4606 #define OP_OR -1
4607 #define OP_AND -2
4608 #define OP_EQV -3
4609 #define OP_XOR -4
4610
4611 opc = SST_OPTYPEG(operator);
4612
4613 /*
4614 * Rules for logical expressions: non-decimal constants assume
4615 * the data type of integer. If at least one operand is
4616 * an integer the other operand becomes an integer and operation
4617 * is bitwise. Handle logicals first since left operand is already
4618 * checked by semant and right must be checked here.
4619 */
4620 if (opc == OP_LOG) {
4621 int ty_lop, ty_rop;
4622
4623 opl = (int)SST_OPCG(operator);
4624 chklog(rop);
4625 ty_lop = TY_OF(lop);
4626 ty_rop = TY_OF(rop);
4627 if (flg.standard) {
4628 if (!TY_ISLOG(ty_lop) || !TY_ISLOG(ty_rop))
4629 errwarn(95);
4630 }
4631 if (OK_LTYP(ty_lop) || OK_LTYP(ty_rop)) {
4632 /* if one operand an integer make other operand
4633 * and operator an integer.
4634 */
4635 cngtyp(lop, DT_INT);
4636 cngtyp(rop, DT_INT);
4637 if (opl == OP_LAND || opl == OP_LOR)
4638 opl = (opl == OP_LAND) ? OP_AND : OP_OR;
4639 else
4640 opl = (opl == OP_LEQV) ? OP_EQV : OP_XOR;
4641 }
4642 SST_OPCP(operator, opl);
4643 goto shape;
4644 } else {
4645 if (flg.standard) {
4646 if (TY_ISLOG(TY_OF(lop)) || TY_ISLOG(TY_OF(rop)))
4647 errwarn(95);
4648 }
4649 }
4650 /* catch use of structures and convert to other opnd's type or integer */
4651 if (((TY_OF(lop) == TY_STRUCT) && (TY_OF(rop) == TY_STRUCT)) ||
4652 ((TY_OF(lop) == TY_DERIVED) && (TY_OF(rop) == TY_DERIVED))) {
4653 cngtyp(lop, DT_INT);
4654 cngtyp(rop, DT_INT);
4655 }
4656 if ((TY_OF(lop) == TY_STRUCT) || (TY_OF(lop) == TY_DERIVED))
4657 cngtyp(lop, (int)PT_OF(rop));
4658 if ((TY_OF(rop) == TY_STRUCT) || (TY_OF(rop) == TY_DERIVED))
4659 cngtyp(rop, (int)PT_OF(lop));
4660
4661 /*
4662 * Look for special case of 'double op complex' which should result
4663 * in both operands coverted to doublecomplex.
4664 */
4665 if ((TY_OF(lop) == TY_DBLE && TY_OF(rop) == TY_CMPLX) ||
4666 (TY_OF(lop) == TY_CMPLX && TY_OF(rop) == TY_DBLE)) {
4667 cngtyp(rop, DT_CMPLX16);
4668 cngtyp(lop, DT_CMPLX16);
4669 }
4670
4671 if (opc == OP_CMP) {
4672 /* Rules for relational expressions: nondecimal constants result
4673 * in a typeless comparison. Size of the larger operand is used.
4674 * (per the VMS implementation)
4675 *
4676 * first catch illegal relational expressions i.e. mixture of
4677 * char and numeric
4678 */
4679 if ((TY_OF(lop) == TY_CHAR || TY_OF(lop) == TY_NCHAR) &&
4680 (TY_OF(rop) != TY_CHAR && TY_OF(rop) != TY_NCHAR)) {
4681 errsev(124);
4682 SST_IDP(lop, S_CONST);
4683 SST_DTYPEP(lop, DT_INT);
4684 SST_CVALP(lop, 0);
4685 }
4686 if ((TY_OF(rop) == TY_CHAR || TY_OF(rop) == TY_NCHAR) &&
4687 (TY_OF(lop) != TY_CHAR && TY_OF(lop) != TY_NCHAR)) {
4688 errsev(124);
4689 SST_IDP(rop, S_CONST);
4690 SST_DTYPEP(rop, DT_INT);
4691 SST_CVALP(rop, 0);
4692 }
4693
4694 /* Catch certain relational operations to avoid type conversion unless
4695 * the other operand is integer or logical. For integer/logical,
4696 * cast the 'word' value to the respective integer/logical type.
4697 */
4698 if (TY_OF(lop) == TY_DWORD) {
4699 if (!TY_ISINT(TY_OF(rop)) && !TY_ISLOG(TY_OF(rop))) {
4700 /* typeless compare */
4701 (void)cast_to_typeless(rop, DT_DWORD);
4702 goto shape;
4703 }
4704 }
4705 if (TY_OF(rop) == TY_DWORD) {
4706 if (!TY_ISINT(TY_OF(lop)) && !TY_ISLOG(TY_OF(lop))) {
4707 /* typeless compare */
4708 (void)cast_to_typeless(lop, DT_DWORD);
4709 goto shape;
4710 }
4711 }
4712 if (TY_OF(lop) == TY_WORD) {
4713 /* here comparison must be at least 64-bits */
4714 if (TY_OF(rop) == TY_DBLE || TY_ISCMPLX(TY_OF(rop))) {
4715 (void)cast_to_typeless(rop, DT_DWORD);
4716 (void)casttyp(lop, DT_DWORD);
4717 goto shape;
4718 }
4719 if (!TY_ISINT(TY_OF(rop)) && !TY_ISLOG(TY_OF(rop))) {
4720 (void)cast_to_typeless(rop, DT_WORD);
4721 goto shape;
4722 }
4723 }
4724 if (TY_OF(rop) == TY_WORD) {
4725 /* here comparison must be at least 64-bits */
4726 if (TY_OF(lop) == TY_DBLE || TY_ISCMPLX(TY_OF(lop))) {
4727 (void)cast_to_typeless(lop, DT_DWORD);
4728 (void)casttyp(rop, DT_DWORD);
4729 goto shape;
4730 }
4731 if (!TY_ISINT(TY_OF(lop)) && !TY_ISLOG(TY_OF(lop))) {
4732 (void)cast_to_typeless(lop, DT_WORD);
4733 goto shape;
4734 }
4735 }
4736 }
4737 if (ARITH(opc) || opc == OP_CAT) {
4738 /* handle nondecimals in arithmetic operations and
4739 * character expressions
4740 */
4741 if ((SST_ISNONDECC(lop) &&
4742 (SST_ISNONDECC(rop) || TY_OF(rop) == TY_DWORD)) ||
4743 (TY_OF(lop) == TY_DWORD &&
4744 (SST_ISNONDECC(rop) || TY_OF(rop) == TY_DWORD))) {
4745 cngtyp(lop, DT_INT);
4746 cngtyp(rop, DT_INT);
4747 }
4748 if (TY_ISNUMERIC(TY_OF(rop)) &&
4749 (SST_ISNONDECC(lop) || (TY_OF(lop) == TY_DWORD)))
4750 cngtyp(lop, (int)PT_OF(rop));
4751
4752 if (TY_ISNUMERIC(TY_OF(lop)) &&
4753 (SST_ISNONDECC(rop) || (TY_OF(rop) == TY_DWORD)))
4754 cngtyp(rop, (int)PT_OF(lop));
4755 }
4756
4757 /* Change logical types to integer for
4758 * arithmetic and relational operations
4759 */
4760 if (TY_ISLOG(TY_OF(lop))) {
4761 if (SST_IDG(lop) != S_CONST)
4762 mkexpr1(lop);
4763 dltype = TYPE_OF(lop);
4764 dltype = DDTG(dltype);
4765 cngtyp(lop, DT_INT + (dltype - DT_LOG));
4766 }
4767
4768 if (TY_ISLOG(TY_OF(rop))) {
4769 if (SST_IDG(rop) != S_CONST)
4770 mkexpr1(rop);
4771 drtype = TYPE_OF(rop);
4772 drtype = DDTG(drtype);
4773 cngtyp(rop, DT_INT + (drtype - DT_LOG));
4774 }
4775
4776 if (opc == OP_XTOI) {
4777 /* Exponentiation breaks the normal rule. If exponent is integer,
4778 * don't change its type.
4779 */
4780 if (TY_ISINT(TY_OF(rop))) {
4781 if (TY_OF(rop) < TY_OF(lop)) {
4782 /* Check left operand */
4783 if (!TY_ISNUMERIC(TY_OF(lop)))
4784 cngtyp(lop, (int)PT_OF(rop));
4785 if (TY_OF(rop) != TY_INT8)
4786 cngtyp(rop, DT_INT);
4787 if (SST_IDG(lop) == S_CONST && SST_IDG(rop) == S_CONST)
4788 /* scalar constant ** int constant */
4789 return;
4790 mkexpr1(lop);
4791 mkexpr1(rop);
4792 if (DTY(SST_DTYPEG(lop)) == TY_ARRAY) {
4793 (void)chkshape(rop, lop, TRUE);
4794 return;
4795 }
4796 if (DTY(SST_DTYPEG(rop)) == TY_ARRAY) {
4797 (void)chkshape(lop, rop, TRUE);
4798 return;
4799 }
4800 /* scalar ** int scalar */
4801 return;
4802 }
4803 } else if (!XBIT(124, 0x40000) && SST_IDG(rop) == S_CONST) {
4804 int pw, is_int;
4805 INT conval;
4806 INT num[2];
4807 switch (TY_OF(rop)) {
4808 case TY_CMPLX:
4809 conval = SST_CVALG(rop);
4810 if (CONVAL2G(conval) != 0)
4811 break;
4812 conval = CONVAL1G(conval);
4813 goto ck_real_pw;
4814 case TY_REAL:
4815 conval = SST_CVALG(rop);
4816 ck_real_pw:
4817 is_int = xfisint(conval, &pw);
4818 if ((!flg.ieee || pw == 1 || pw == 2) && is_int) {
4819 if (TY_OF(lop) < TY_OF(rop))
4820 cngtyp(lop, (int)SST_DTYPEG(rop)); /* Normal rule */
4821 SST_CVALP(rop, pw);
4822 SST_DTYPEP(rop, DT_INT4);
4823 SST_ASTP(rop, mk_cval1(pw, DT_INT4));
4824 return;
4825 }
4826 break;
4827 case TY_DCMPLX:
4828 conval = SST_CVALG(rop);
4829 if (!is_dbl0(CONVAL2G(conval)))
4830 break;
4831 conval = CONVAL1G(conval);
4832 goto ck_dble_pw;
4833 case TY_DBLE:
4834 conval = SST_CVALG(rop);
4835 ck_dble_pw:
4836 num[0] = CONVAL1G(conval);
4837 num[1] = CONVAL2G(conval);
4838 is_int = xdisint(num, &pw);
4839 if ((!flg.ieee || pw == 1 || pw == 2) && is_int) {
4840 if (TY_OF(lop) < TY_OF(rop))
4841 cngtyp(lop, (int)SST_DTYPEG(rop)); /* Normal rule */
4842 SST_CVALP(rop, pw);
4843 SST_DTYPEP(rop, DT_INT4);
4844 SST_ASTP(rop, mk_cval1(pw, DT_INT4));
4845 return;
4846 }
4847 break;
4848 default:
4849 break;
4850 }
4851 }
4852 }
4853 /*
4854 * Perform type conversion of both operands to a common data type.
4855 * Remember that character and records are highest data types. For
4856 * non-character operations character data should be converted to down
4857 * rather than follow the normal rule. When records are used they should
4858 * always be converted down. This avoids propagation of errors.
4859 */
4860 if (TY_OF(lop) < TY_OF(rop)) {
4861 if (((TY_OF(rop) == TY_STRUCT) || (TY_OF(rop) == TY_DERIVED)) ||
4862 (opc != OP_CAT && (TY_OF(rop) == TY_CHAR || TY_OF(rop) == TY_NCHAR)))
4863 cngtyp(rop, (int)SST_DTYPEG(lop)); /* Break normal rule */
4864 else
4865 cngtyp(lop, (int)SST_DTYPEG(rop)); /* Normal rule */
4866 } else if (TY_OF(rop) < TY_OF(lop)) {
4867 if (((TY_OF(lop) == TY_STRUCT) || (TY_OF(lop) == TY_DERIVED)) ||
4868 (opc != OP_CAT && (TY_OF(lop) == TY_CHAR || TY_OF(lop) == TY_NCHAR)))
4869 cngtyp(lop, (int)SST_DTYPEG(rop)); /* Break normal rule */
4870 else
4871 cngtyp(rop, (int)SST_DTYPEG(lop)); /* Normal rule */
4872 } else if ((TY_OF(lop) == TY_STRUCT) || (TY_OF(lop) == TY_DERIVED)) {
4873 /* Both are == and structure. can't do binary operations with
4874 * structures.
4875 */
4876 cngtyp(lop, DT_INT);
4877 cngtyp(rop, DT_INT);
4878 } else if (TY_OF(lop) == TY_CHAR || TY_OF(lop) == TY_NCHAR) {
4879 /* Both are == and character;
4880 * char op char is only legal for concat and relational operators
4881 */
4882 if (opc != OP_CAT && opc != OP_CMP) {
4883 cngtyp(lop, DT_INT);
4884 cngtyp(rop, DT_INT);
4885 } else if (DTY(TYPE_OF(lop)) == TY_ARRAY && !TY_ISVEC(TY_CHAR))
4886 error83(TY_CHAR);
4887 }
4888 /*
4889 * Types of operands are the same now make sure shapes of both
4890 * operands agree.
4891 */
4892 shape:
4893 if (DTY(SST_DTYPEG(lop)) == TY_ARRAY && DTY(SST_DTYPEG(rop)) != TY_ARRAY)
4894 cngshape(rop, lop);
4895 else
4896 cngshape(lop, rop);
4897 }
4898
4899 /** \brief Perform a unary operation on logical rhs.
4900 */
4901 void
unop(SST * rslt,SST * operator,SST * rop)4902 unop(SST *rslt, SST *operator, SST *rop)
4903 {
4904 int rdtype; /* data type */
4905 int lbtype; /* basic data type (INT, LOG, etc) */
4906 int opc; /* operation code */
4907 int dltype, drtype; /* data type */
4908
4909 opc = SST_OPTYPEG(operator);
4910 if (opc != OP_ADD && opc != OP_SUB) {
4911 return;
4912 }
4913 if (!TY_ISLOG(TY_OF(rop))) {
4914 return;
4915 }
4916 if (SST_IDG(rop) == S_STFUNC)
4917 mkexpr1(rop);
4918 constant_lvalue(rop);
4919
4920 if (SST_IDG(rop) != S_CONST)
4921 mkexpr1(rop);
4922
4923 drtype = TYPE_OF(rop);
4924 drtype = DDTG(drtype);
4925 cngtyp(rop, DT_INT + (drtype - DT_LOG));
4926
4927 cngshape(rop, rop);
4928
4929 mkexpr1(rop);
4930 lbtype = TY_OF(rop);
4931 rdtype = TYPE_OF(rop);
4932 SST_IDP(rslt, S_EXPR);
4933 SST_DTYPEP(rslt, rdtype);
4934 }
4935
4936 /** \brief Perform a binary operation on rhs1 and rhs2. They both conform in
4937 data type and shape.
4938 */
4939 void
binop(SST * rslt,SST * lop,SST * operator,SST * rop)4940 binop(SST *rslt, SST *lop, SST *operator, SST *rop)
4941 {
4942 /* Values for left and right operands */
4943 int ldtype, rdtype; /* data type */
4944 int lbtype; /* basic data type (INT, LOG, etc) */
4945 int newtyp;
4946 int lsptr, rsptr; /* symbol table pointers */
4947 int klsptr, krsptr, krslt; /* symbol table pointers */
4948 int llen, rlen; /* character string lengths */
4949 int opc, opc1; /* operation code */
4950
4951 char *carea; /* temporary area for concatenation */
4952 int count, condition;
4953 INT term, conval;
4954 LOGICAL is_array;
4955 ADSC *ad, *ad1;
4956 int i, numdim;
4957 INT val1[2], val2[2], res[2], val[4];
4958 int c;
4959 int cvlen;
4960
4961 /*
4962 * Step 1: Catch statement functions and call mkexpr1 to process the
4963 * linked list (arguments) on the semantic stack.
4964 */
4965 if (SST_IDG(lop) == S_STFUNC)
4966 mkexpr1(lop);
4967 if (SST_IDG(rop) == S_STFUNC)
4968 mkexpr1(rop);
4969
4970 /*
4971 * Step 2: Catch some illegal cases early.
4972 */
4973 /* catch vector ops on hollerith constants before changing their type */
4974 if ((TYPE_OF(rop) == DT_HOLL && DTY(TYPE_OF(lop)) == TY_ARRAY) ||
4975 (TYPE_OF(lop) == DT_HOLL && DTY(TYPE_OF(rop)) == TY_ARRAY))
4976 errsev(100);
4977
4978 opc = SST_OPTYPEG(operator);
4979 constant_lvalue(lop);
4980 constant_lvalue(rop);
4981 /*
4982 * Step 3: Ensure that the data types and shapes of both operands agree.
4983 */
4984 chkopnds(lop, operator, rop);
4985
4986 /*
4987 * Step 4: Shortcut comparisons between typeless and different sized
4988 * operands. A 32-bit typeless is always less than a 64-bit
4989 * typeless.
4990 */
4991 if (opc == OP_CMP) {
4992 if ((TYPE_OF(lop) == TY_DWORD) && (TYPE_OF(rop) == TY_WORD)) {
4993 conval = 1;
4994 goto shortcut;
4995 }
4996 if ((TYPE_OF(rop) == TY_DWORD) && (TYPE_OF(lop) == TY_WORD)) {
4997 conval = -1;
4998 goto shortcut;
4999 }
5000 }
5001
5002 /*
5003 * Step 5: Optimize AND's and OR's in logical expressions by short
5004 * circuiting if both operands are logicals and one operand
5005 * is a logical constant .false. for an AND operation or a
5006 * .true. for an OR operation. For example l .or. c
5007 * would avoid the evaluation of l if the constant c were true
5008 * or would return the evaluation of l if the constant c were false.
5009 */
5010 if (opc == OP_LOG && TY_ISLOG(TY_OF(lop)) && TY_ISLOG(TY_OF(rop))) {
5011 if ((opc1 = SST_OPCG(operator)) == OP_LOR)
5012 condition = SCFTN_FALSE & 1;
5013 else if (opc1 == OP_LAND)
5014 condition = SCFTN_TRUE & 1;
5015 else
5016 goto step6;
5017 if (SST_IDG(lop) == S_CONST) {
5018 val1[1] = (DTY(TY_OF(lop)) == TY_LOG8) ? CONVAL2G(SST_CVALG(lop))
5019 : SST_CVALG(lop);
5020 if ((val1[1] & 1) == condition)
5021 *rslt = *rop;
5022 else
5023 *rslt = *lop;
5024 SST_ASTP(rop, 0); /* short circuit optimization occurred */
5025 return;
5026 } else if (SST_IDG(rop) == S_CONST) {
5027 val1[1] = (DTY(TY_OF(rop)) == TY_LOG8) ? CONVAL2G(SST_CVALG(rop))
5028 : SST_CVALG(rop);
5029 if ((val1[1] & 1) == condition)
5030 *rslt = *lop;
5031 else
5032 *rslt = *rop;
5033 SST_ASTP(rop, 0); /* short circuit optimization occurred */
5034 return;
5035 }
5036 }
5037
5038 /* assertion: We have two operands of equal data types, of equal shape,
5039 * and an operation to perform. If constants are involved,
5040 * non-decimal constants have assumed a different type.
5041 * Step 6: Possibly constant fold.
5042 */
5043 step6:
5044 if (SST_IDG(lop) == S_CONST && SST_IDG(rop) == S_CONST) {
5045 /* Perform constant folding based on operator */
5046 switch (opc) {
5047 case OP_LOG:
5048 opc1 = SST_OPCG(operator); /* real logical operator */
5049 if (DTY(TY_OF(lop)) == TY_LOG8) {
5050 val1[0] = CONVAL1G(SST_CVALG(lop));
5051 val1[1] = CONVAL2G(SST_CVALG(lop));
5052 } else {
5053 val1[1] = SST_CVALG(lop);
5054 if (val1[1] < 0)
5055 val1[0] = -1;
5056 else
5057 val1[0] = 0;
5058 }
5059 if (DTY(TY_OF(rop)) == TY_LOG8) {
5060 val2[0] = CONVAL1G(SST_CVALG(rop));
5061 val2[1] = CONVAL2G(SST_CVALG(rop));
5062 } else {
5063 val2[1] = SST_CVALG(rop);
5064 if (val2[1] < 0)
5065 val2[0] = -1;
5066 else
5067 val2[0] = 0;
5068 }
5069 if (opc1 == OP_LEQV || opc1 == OP_EQV) {
5070 conval = cmp64(val1, val2);
5071 SST_CVALP(rslt, clog_to_log((INT)(conval == 0)));
5072 } else if (opc1 == OP_LNEQV) {
5073 conval = cmp64(val1, val2);
5074 SST_CVALP(rslt, clog_to_log((INT)(conval != 0)));
5075 } else if (opc1 == OP_LOR) {
5076 or64(val1, val2, res);
5077 SST_CVALP(rslt, clog_to_log(res[0] | res[1]));
5078 } else if (opc1 == OP_LAND) {
5079 and64(val1, val2, res);
5080 SST_CVALP(rslt, clog_to_log(res[0] | res[1]));
5081 } else if (opc1 == OP_XOR) {
5082 xor64(val1, val2, res);
5083 SST_CVALP(rslt, clog_to_log(res[0] | res[1]));
5084 } else if (opc1 == OP_OR) {
5085 or64(val1, val2, res);
5086 SST_CVALP(rslt, clog_to_log(res[0] | res[1]));
5087 } else if (opc1 == OP_AND) {
5088 and64(val1, val2, res);
5089 SST_CVALP(rslt, clog_to_log(res[0] | res[1]));
5090 } else
5091 interr("binop: bad opcode in SST_OPC:", opc1, 0);
5092 SST_DTYPEP(rslt, DT_LOG);
5093 if (DTY(DT_LOG) == TY_LOG8) {
5094 res[1] = SST_CVALG(rslt);
5095 if (res[1] < 0)
5096 res[0] = -1 & 0xFFFFFFFF;
5097 else
5098 res[0] = 0;
5099 SST_CVALP(rslt, getcon(res, DT_LOG8));
5100 }
5101 break;
5102 case OP_XTOI:
5103 case OP_XTOX:
5104 if (TYPE_OF(rop) == DT_INT8) {
5105 conval = const_xtoi(SST_CVALG(lop), SST_CVALG(rop), TYPE_OF(lop));
5106 SST_CVALP(rslt, conval);
5107 } else if (DT_ISINT(TYPE_OF(rop))) {
5108 count = SST_CVALG(rop);
5109 if (TYPE_OF(rop) != DT_INT4)
5110 count = cngcon(count, (int)TYPE_OF(rop), DT_INT4);
5111 conval = _xtok(SST_CVALG(lop), count, TYPE_OF(lop));
5112 SST_CVALP(rslt, conval);
5113 } else {
5114 /* can't fold if exponent is not an integer constant */
5115 goto binop_exp;
5116 }
5117 break;
5118
5119 case OP_CAT:
5120 SST_CVLENP(rslt, 0);
5121 if (TY_OF(lop) != TY_OF(rop))
5122 goto error_cat;
5123 if (TY_OF(lop) != TY_CHAR && TY_OF(lop) != TY_NCHAR)
5124 goto error_cat;
5125 klsptr = lsptr = SST_SYMG(lop);
5126 krsptr = rsptr = SST_SYMG(rop);
5127 ldtype = DTYPEG(lsptr);
5128 rdtype = DTYPEG(rsptr);
5129 #if DEBUG
5130 assert(STYPEG(lsptr) == ST_CONST &&
5131 (DTY(ldtype) == TY_CHAR || DTY(ldtype) == TY_NCHAR),
5132 "binop:CAT1", lsptr, 2);
5133 assert(STYPEG(rsptr) == ST_CONST &&
5134 (DTY(rdtype) == TY_CHAR || DTY(rdtype) == TY_NCHAR),
5135 "binop:CAT2", rsptr, 2);
5136 #endif
5137 llen = string_length(ldtype);
5138 rlen = string_length(rdtype);
5139 carea = getitem(0, llen + rlen);
5140 if (TY_OF(lop) == TY_NCHAR) {
5141 klsptr = CONVAL1G(lsptr);
5142 krsptr = CONVAL1G(rsptr);
5143 }
5144 BCOPY(carea, stb.n_base + CONVAL1G(klsptr), char, llen);
5145 BCOPY(carea + llen, stb.n_base + CONVAL1G(krsptr), char, rlen);
5146 krslt = getstring(carea, llen + rlen);
5147 newtyp = get_type(2, TY_OF(lop), mk_cval(llen + rlen, DT_INT4));
5148 if (TY_OF(lop) == TY_NCHAR) {
5149 llen = kanji_len((unsigned char *)stb.n_base + CONVAL1G(klsptr), llen);
5150 rlen = kanji_len((unsigned char *)stb.n_base + CONVAL1G(krsptr), rlen);
5151 val[0] = krslt;
5152 val[1] = 0;
5153 val[2] = 0;
5154 val[3] = 0;
5155 krslt = getcon(val, newtyp);
5156 }
5157 SST_SYMP(rslt, krslt);
5158 SST_DTYPEP(rslt, newtyp);
5159 break;
5160
5161 error_cat:
5162 SST_CVLENP(rslt, 0);
5163 errsev(146);
5164 SST_SYMP(rslt, getstring(" ", 1));
5165 SST_DTYPEP(rslt, DT_CHAR);
5166 break;
5167
5168 case OP_ADD:
5169 case OP_SUB:
5170 case OP_MUL:
5171 case OP_DIV:
5172 SST_CVALP(rslt, const_fold(opc, SST_CVALG(lop), SST_CVALG(rop),
5173 (int)TYPE_OF(lop)));
5174 SST_DTYPEP(rslt, TYPE_OF(lop));
5175 break;
5176
5177 case OP_CMP:
5178 conval =
5179 const_fold(OP_CMP, SST_CVALG(lop), SST_CVALG(rop), (int)TYPE_OF(lop));
5180 shortcut:
5181 switch (SST_OPCG(operator)) {
5182 case OP_EQ:
5183 conval = (conval == 0);
5184 break;
5185 case OP_GE:
5186 conval = (conval >= 0);
5187 break;
5188 case OP_GT:
5189 conval = (conval > 0);
5190 break;
5191 case OP_LE:
5192 conval = (conval <= 0);
5193 break;
5194 case OP_LT:
5195 conval = (conval < 0);
5196 break;
5197 case OP_NE:
5198 conval = (conval != 0);
5199 break;
5200 }
5201 conval = conval ? SCFTN_TRUE : SCFTN_FALSE;
5202 if (DTY(stb.user.dt_log) == TY_LOG8) {
5203 res[1] = conval;
5204 if (res[1] < 0)
5205 res[0] = -1 & 0xFFFFFFFF;
5206 else
5207 res[0] = 0;
5208 SST_CVALP(rslt, getcon(res, DT_LOG8));
5209 } else
5210 SST_CVALP(rslt, conval);
5211 SST_DTYPEP(rslt, stb.user.dt_log);
5212 break;
5213
5214 default:
5215 interr("binop: bad opcode:", opc, 0);
5216 break;
5217 }
5218 return;
5219 }
5220
5221 /*
5222 * assertion: We have two operands that are not both constants
5223 * therefore constant folding is not possible.
5224 * step 7: Make an expression from operands and operator.
5225 */
5226 if (opc == OP_XTOI && SST_IDG(rop) == S_CONST && TYPE_OF(rop) == DT_INT &&
5227 SST_CVALG(rop) == 2) {
5228 /* optimize x raised to the power of 2 */
5229 mkexpr(lop);
5230 SST_IDP(rslt, S_EXPR);
5231 SST_DTYPEP(rslt, SST_DTYPEG(lop));
5232 } else if (opc == OP_LOG) {
5233 /* We have a logical expression */
5234 mkexpr(lop);
5235 mkexpr(rop);
5236 opc = SST_OPCG(operator);
5237 chklog(lop);
5238 chklog(rop);
5239
5240 if (DTY(TYPE_OF(lop)) == TY_ARRAY || DTY(TYPE_OF(rop)) == TY_ARRAY)
5241 ;
5242 else {
5243 /* Normal scalar logical expressions should be LOG*4 */
5244 mklogint4(lop);
5245 mklogint4(rop);
5246 }
5247 SST_IDP(rslt, S_EXPR);
5248 } else {
5249 binop_exp:
5250 if (opc == OP_CAT) {
5251 int rdt;
5252
5253 cvlen = 0;
5254 if (TY_OF(lop) == TY_CHAR) {
5255 if (TY_OF(rop) != TY_CHAR)
5256 goto error_cat;
5257 mkexpr1(lop);
5258 mkexpr1(rop);
5259 rdt = DT_ASSCHAR;
5260 }
5261 else if (TY_OF(lop) == TY_NCHAR) { /* kanji */
5262 if (TY_OF(rop) != TY_NCHAR)
5263 goto error_cat;
5264 mkexpr1(lop);
5265 mkexpr1(rop);
5266 rdt = DT_ASSNCHAR;
5267 }
5268 else
5269 goto error_cat;
5270 ldtype = TYPE_OF(lop);
5271 rdtype = TYPE_OF(rop);
5272 is_array = FALSE;
5273 if (DTY(ldtype) == TY_ARRAY) {
5274 is_array = TRUE;
5275 ldtype = DTY(ldtype + 1);
5276 }
5277 if (DTY(rdtype) == TY_ARRAY) {
5278 is_array = TRUE;
5279 rdtype = DTY(rdtype + 1);
5280 }
5281 if (ldtype != DT_ASSCHAR && ldtype != DT_DEFERCHAR &&
5282 ldtype != DT_ASSNCHAR && rdtype != DT_ASSNCHAR &&
5283 ldtype != DT_DEFERNCHAR && rdtype != DT_DEFERNCHAR &&
5284 rdtype != DT_ASSCHAR && rdtype != DT_DEFERCHAR) {
5285 llen = SST_CVLENG(lop);
5286 rlen = SST_CVLENG(rop);
5287 if (llen == 0 && !A_ALIASG(DTY(ldtype + 1)))
5288 goto cat_result;
5289 if (rlen == 0 && !A_ALIASG(DTY(rdtype + 1)))
5290 goto cat_result;
5291 if (llen) {
5292 if (rlen == 0)
5293 rlen = mk_cval(string_length(rdtype), DT_INT4);
5294 } else if (rlen) {
5295 llen = mk_cval(string_length(ldtype), DT_INT4);
5296 }
5297 if (llen) {
5298 cvlen = mk_binop(OP_ADD, llen, rlen, DT_INT4);
5299 rdt = get_type(2, (int)DTY(rdt), cvlen);
5300 } else {
5301 llen = string_length(ldtype);
5302 rlen = string_length(rdtype);
5303 rdt = get_type(2, (int)DTY(rdt), mk_cval(llen + rlen, DT_INT4));
5304 cvlen = DTY(rdt + 1);
5305 }
5306 }
5307 cat_result:
5308 if (is_array) {
5309 if (TY_OF(lop) == TY_CHAR) {
5310 if (DTY(TYPE_OF(lop)) == TY_ARRAY)
5311 ad1 = AD_DPTR(TYPE_OF(lop));
5312 else
5313 ad1 = AD_DPTR(TYPE_OF(rop));
5314 numdim = AD_NUMDIM(ad1);
5315 rdt = get_array_dtype(numdim, rdt);
5316 } else {
5317 rdt = get_type(3, TY_ARRAY, rdt);
5318 DTY(rdt + 2) = 0;
5319 }
5320 }
5321 SST_IDP(rslt, S_EXPR);
5322 SST_DTYPEP(rslt, rdt);
5323 SST_CVLENP(rslt, cvlen);
5324 } else {
5325 mkexpr1(lop);
5326 mkexpr1(rop);
5327 lbtype = TY_OF(lop);
5328 ldtype = TYPE_OF(lop);
5329
5330 if (opc == OP_CMP) {
5331 opc = SST_OPCG(operator);
5332 if (DTY(TYPE_OF(lop)) == TY_ARRAY || DTY(TYPE_OF(rop)) == TY_ARRAY)
5333 is_array = TRUE;
5334 else
5335 is_array = FALSE;
5336 if (TY_ISCMPLX(TY_OF(lop)) && (opc != OP_EQ && opc != OP_NE))
5337 errsev(96);
5338 if (is_array) {
5339 ldtype = get_type(3, TY_ARRAY, stb.user.dt_log);
5340 DTY(ldtype + 2) = 0;
5341 } else
5342 ldtype = stb.user.dt_log;
5343 }
5344
5345 SST_IDP(rslt, S_EXPR);
5346 SST_DTYPEP(rslt, ldtype);
5347 }
5348 }
5349 }
5350
5351 /* convert C's logical value to pgftn's logical (.true./.false.) */
5352 static INT
clog_to_log(INT clog)5353 clog_to_log(INT clog)
5354 {
5355 if (clog)
5356 return SCFTN_TRUE;
5357 return SCFTN_FALSE;
5358 }
5359
5360 /** \brief Return a new data type based on the rules of applying a length
5361 specifier to an existing base data type (i.e. LOGICAL*1) passed in as
5362 a TY_ value.
5363
5364 \a sptr points to the symbol table entry whose data type is being modified.
5365 This is for error messages. If no \a sptr then message is for type
5366 declaration verb.
5367
5368 Special case:
5369 > When sptr is 0, the data type adjustment is occurring at the time when
5370 > the length immediately follows a data type (i.e. when \<data type> is
5371 > being processed). When sptr is non-zero, this means that the length
5372 > follows the name of the symbol (\<data type> has already been processed)
5373 > (i.e. CHARACTER FOO*1); and a length of -1 implies that no length
5374 > was specified.
5375 >
5376 > So, when sptr is nonzero and len is -1, we do not attempt to adjust
5377 > the data type; if so, we will incorrectly adjust
5378 > <pre>
5379 > REAL*4 rv</pre>
5380 > when the "r8" option has been selected (-x 124 8).
5381 */
5382 int
mod_type(int dtype,int ty,int kind,int len,int propagated,int sptr)5383 mod_type(int dtype, int ty, int kind, int len, int propagated, int sptr)
5384 {
5385 /*
5386 * The dtype could be any static or dynamic dtype therefore use the
5387 * TY_type field for comparisons. For example, there is the static
5388 * entry for CHARACTER*1 and the dynamic entries for CHARACTER*number.
5389 */
5390 if (sptr && len == -1)
5391 return dtype;
5392 /*
5393 * the possible values of 'ty' are those which can be base types.
5394 */
5395 switch (ty) {
5396 case TY_BINT:
5397 if (kind != 0)
5398 error(32, 2, gbl.lineno, (sptr) ? SYMNAME(sptr) : "byte", CNULL);
5399 break;
5400 case TY_INT:
5401 case TY_INT8:
5402 if (kind == 0) {
5403 if (!flg.i4 && dtype == DT_INT)
5404 return (DT_SINT);
5405 return dtype;
5406 }
5407 if (kind == 1) {
5408 if (len == 1)
5409 return (DT_BINT);
5410 if (len == 2)
5411 return (DT_SINT);
5412 if (len == 4)
5413 return (DT_INT4);
5414 if (len == 8 && !XBIT(57, 0x2))
5415 return (DT_INT8);
5416 }
5417 error(31, 2, gbl.lineno, (sptr) ? SYMNAME(sptr) : "integer", CNULL);
5418 break;
5419 case TY_LOG:
5420 case TY_LOG8:
5421 if (kind == 0) {
5422 if (!flg.i4 && dtype == DT_LOG)
5423 return (DT_SLOG);
5424 return dtype;
5425 }
5426 if (kind == 1) {
5427 if (len == 1)
5428 return (DT_BLOG);
5429 if (len == 2)
5430 return (DT_SLOG);
5431 if (len == 4)
5432 return (DT_LOG4);
5433 if (len == 8 && !XBIT(57, 0x2))
5434 return (DT_LOG8);
5435 }
5436 error(31, 2, gbl.lineno, (sptr) ? SYMNAME(sptr) : "logical", CNULL);
5437 break;
5438 case TY_DBLE:
5439 if (sem.ogdtype == DT_REAL8 && kind != 0) {
5440 error(32, 2, gbl.lineno, (sptr) ? SYMNAME(sptr) : "doubleprecision",
5441 CNULL);
5442 break;
5443 }
5444 /* NB: no break here. */
5445 case TY_REAL:
5446 if (kind == 0)
5447 return dtype;
5448 if (kind == 1) {
5449 if (len == 16 && !XBIT(57, 0x4)) {
5450 if (XBIT(57, 0x10)) {
5451 if (!propagated)
5452 error(437, 2, gbl.lineno, "REAL*16", "REAL*8");
5453 return DT_REAL8;
5454 } else {
5455 return DT_QUAD;
5456 }
5457 }
5458 if (len == 8)
5459 return DT_REAL8;
5460 if (len == 4)
5461 return (DT_REAL4);
5462 }
5463 error(31, 2, gbl.lineno, (sptr) ? SYMNAME(sptr) :
5464 (ty == TY_HALF ? "real2" : "real"), CNULL);
5465 break;
5466 case TY_DCMPLX:
5467 if (sem.ogdtype == DT_CMPLX16 && kind != 0) {
5468 error(32, 2, gbl.lineno, (sptr) ? SYMNAME(sptr) : "doublecomplex", CNULL);
5469 break;
5470 }
5471 /* NB: no break here. */
5472 case TY_CMPLX:
5473 if (kind == 0)
5474 return dtype;
5475 if (kind == 1) {
5476 if (len == 32 && !XBIT(57, 0x8)) {
5477 if (XBIT(57, 0x10)) {
5478 if (!propagated)
5479 error(437, 2, gbl.lineno, "COMPLEX*32", "COMPLEX*16");
5480 return DT_CMPLX16;
5481 } else {
5482 return DT_QCMPLX;
5483 }
5484 }
5485 if (len == 16)
5486 return DT_CMPLX16;
5487 if (len == 8)
5488 return (DT_CMPLX8);
5489 }
5490 error(31, 2, gbl.lineno, (sptr) ? SYMNAME(sptr) : "complex", CNULL);
5491 break;
5492 case TY_CHAR:
5493 case TY_NCHAR:
5494 switch (kind) {
5495 case 3: /* zero-size character */
5496 return get_type(2, DTY(dtype), astb.i0);
5497 case 5: /* '*(:)' */
5498 if (DTY(dtype) == TY_CHAR)
5499 return DT_DEFERCHAR;
5500 else
5501 return DT_DEFERNCHAR;
5502 case 2: /* '*(*)' */
5503 if (DTY(dtype) == TY_CHAR)
5504 return DT_ASSCHAR;
5505 else
5506 return DT_ASSNCHAR;
5507 case 1: /* constant length */
5508 return get_type(2, DTY(dtype), mk_cval(len, DT_INT4));
5509 case 4: /* adjustable length */
5510 return get_type(2, DTY(dtype), len);
5511 case 0: /* no length */
5512 return get_type(2, DTY(dtype), astb.i1);
5513 }
5514 break;
5515 default:
5516 interr("mod_type/data type: bad data type:", dtype, 0);
5517 break;
5518 }
5519 return dtype;
5520 }
5521
5522 /** \brief Return the printable representation of a semantic stack entry
5523 */
5524 char *
prtsst(SST * stkptr)5525 prtsst(SST *stkptr)
5526 {
5527 static char symbuf[132];
5528 int val, dtype;
5529
5530 val = SST_SYMG(stkptr);
5531 dtype = SST_DTYPEG(stkptr);
5532 if (SST_IDG(stkptr) == S_CONST) {
5533 if (dtype == DT_QUAD || dtype == DT_REAL8 || DT_ISCMPLX(dtype)) {
5534 return (getprint(val));
5535 } else {
5536 if (DT_ISREAL(dtype)) {
5537 sprintf(symbuf, "%f", *(float *)&val);
5538 } else if (DT_ISLOG(dtype)) {
5539 if (val == SCFTN_TRUE)
5540 sprintf(symbuf, ".TRUE.");
5541 else
5542 sprintf(symbuf, ".FALSE.");
5543 } else if (DTYG(dtype) == TY_CHAR)
5544 sprintf(symbuf, "\"%s\"", stb.n_base + CONVAL1G(val));
5545 else
5546 sprintf(symbuf, "%d", val);
5547 }
5548 }
5549 return (symbuf);
5550 }
5551
5552 /** \brief Dereference an ast to determine the base, i.e. its symbol pointer.
5553 */
5554 int
getbase(int ast)5555 getbase(int ast)
5556 {
5557 switch (A_TYPEG(ast)) {
5558 case A_SUBSTR:
5559 case A_SUBSCR:
5560 return (getbase((int)A_LOPG(ast)));
5561
5562 case A_ID:
5563 return A_SPTRG(ast);
5564
5565 case A_MEM:
5566 return (getbase((int)A_PARENTG(ast)));
5567
5568 case A_FUNC:
5569 case A_CALL:
5570 return (getbase((int)A_LOPG(ast)));
5571
5572 default:
5573 return 0;
5574 }
5575 }
5576
5577 /*---------------------------------------------------------------------*
5578 * Handle DO statements *
5579 *---------------------------------------------------------------------*/
5580
5581 /** \brief Generate ILMs which computes the address of the index variable.
5582 Need to do it this way since the ILMs which were originally
5583 computed during the parse are not saved across the blocks
5584 */
5585 int
do_index_addr(int sptr)5586 do_index_addr(int sptr)
5587 {
5588 return ref_object(sptr);
5589 }
5590
5591 /** \brief Write out block DO AST from doinfo record. This function assumes
5592 that they init, limit, and step expressions have already been cast to
5593 the type of the do index variable.
5594 */
5595 int
do_begin(DOINFO * doinfo)5596 do_begin(DOINFO *doinfo)
5597 {
5598 int iv;
5599 int ast, dovar;
5600
5601 iv = doinfo->index_var;
5602 doinfo->prev_dovar = DOVARG(iv);
5603 DOCHK(iv);
5604 DOVARP(iv, 1);
5605 ast = mk_stmt(A_DO, 0 /* SST_ASTG(RHS(1)) BLOCKDO */);
5606 dovar = mk_id(iv);
5607 A_DOVARP(ast, dovar);
5608 A_M1P(ast, doinfo->init_expr);
5609 A_M2P(ast, doinfo->limit_expr);
5610 A_M3P(ast, doinfo->step_expr);
5611 A_LASTVALP(ast, 0);
5612
5613 return ast;
5614 }
5615
5616 /*
5617 * Compute the last value of a DO index variable.
5618 */
5619 static int tempify_ast(int);
5620
5621 void
do_lastval(DOINFO * doinfo)5622 do_lastval(DOINFO *doinfo)
5623 {
5624 int dtype, sptr;
5625 int e1, e2, e3;
5626 int ast, dest_ast;
5627
5628 /* for a simd loop, lastval_var is not used.
5629 * we need to calculate the last iteration in the
5630 * compiler.
5631 */
5632 doinfo->lastval_var = 0;
5633 if (!sem.expect_simd_do) {
5634 sptr = get_itemp(DT_INT);
5635 ast = astb.i0;
5636 ADDRTKNP(sptr, 1);
5637 doinfo->lastval_var = sptr;
5638 dest_ast = mk_id(sptr);
5639 ast = mk_assn_stmt(dest_ast, ast, A_DTYPEG(ast));
5640 (void)add_stmt(ast);
5641 return;
5642 }
5643
5644 dtype = DTYPEG(doinfo->index_var);
5645 /*
5646 * A do expression containing a function needs to be assigned to a temp
5647 * since we're creating multiple uses (here in and in the DO itself),
5648 * of a do expression.
5649 */
5650 e1 = doinfo->init_expr;
5651 if (A_CALLFGG(e1)) {
5652 e1 = tempify_ast(e1);
5653 e1 = doinfo->init_expr = A_DESTG(e1);
5654 }
5655 e2 = doinfo->limit_expr;
5656 if (A_CALLFGG(e2)) {
5657 e2 = tempify_ast(e2);
5658 e2 = doinfo->limit_expr = A_DESTG(e2);
5659 }
5660 e3 = doinfo->step_expr;
5661 if (A_CALLFGG(e3)) {
5662 e3 = tempify_ast(e3);
5663 e3 = doinfo->step_expr = A_DESTG(e3);
5664 }
5665
5666 /* lp_cnt = (e2 - e1 + e3) / e3 */
5667 ast = mk_binop(OP_SUB, e2, e1, dtype);
5668 ast = mk_binop(OP_ADD, ast, e3, dtype);
5669 ast = mk_binop(OP_DIV, ast, e3, dtype);
5670
5671 /* lastval = lp_cnt*e3 + e1 */
5672 ast = mk_binop(OP_MUL, ast, e3, dtype);
5673 ast = mk_binop(OP_ADD, ast, e1, dtype);
5674 doinfo->lastval_var = get_itemp(dtype);
5675 dest_ast = mk_id(doinfo->lastval_var);
5676 ast = mk_assn_stmt(dest_ast, ast, dtype);
5677 (void)add_stmt(ast);
5678 }
5679
5680 /*
5681 * allocate a temporary, assign it the value, and return the assignment
5682 * ast
5683 */
5684 static int
tempify_ast(int src)5685 tempify_ast(int src)
5686 {
5687 int argtyp;
5688 int tmpsym;
5689 int assn;
5690 int ast;
5691
5692 argtyp = A_DTYPEG(src);
5693 tmpsym = get_temp(argtyp);
5694 ast = mk_id(tmpsym);
5695 ast = mk_assn_stmt(ast, src, argtyp);
5696 (void)add_stmt(ast);
5697 return ast;
5698 }
5699
5700 static void
add_taskloopreg(DOINFO * doinfo)5701 add_taskloopreg(DOINFO *doinfo)
5702 {
5703 int ast, savesc;
5704 int lb, ub, st;
5705
5706 ast = mk_stmt(A_MP_TASKLOOPREG, 0);
5707 A_M1P(ast, doinfo->init_expr);
5708 A_M2P(ast, doinfo->limit_expr);
5709 A_M3P(ast, doinfo->step_expr);
5710 (void)add_stmt(ast);
5711 }
5712
5713 int
do_parbegin(DOINFO * doinfo)5714 do_parbegin(DOINFO *doinfo)
5715 {
5716 int iv, di_id;
5717 int ast, dovar;
5718
5719 iv = doinfo->index_var;
5720 if (!DT_ISINT(DTYPEG(iv))) {
5721 error(155, 3, gbl.lineno,
5722 "The index variable of a parallel DO must be integer -", SYMNAME(iv));
5723 return do_begin(doinfo);
5724 }
5725
5726 if (DI_ID(sem.doif_depth) == DI_TASKLOOP) {
5727 add_taskloopreg(doinfo);
5728 }
5729
5730 doinfo->prev_dovar = DOVARG(iv);
5731 DOCHK(iv);
5732 DOVARP(iv, 1);
5733
5734 ast = mk_stmt(A_MP_PDO, 0 /* SST_ASTG(RHS(1)) BLOCKDO */);
5735 dovar = mk_id(iv);
5736 A_DOVARP(ast, dovar);
5737 A_M1P(ast, doinfo->init_expr);
5738 A_M2P(ast, doinfo->limit_expr);
5739 A_M3P(ast, doinfo->step_expr);
5740 #ifdef OMP_OFFLOAD_LLVM
5741 if(DI_ID(sem.doif_depth) == DI_PARDO &&
5742 DI_ID(sem.doif_depth-1) == DI_TARGET) {
5743 int targetast = DI_BTARGET(1);
5744 int ast_looptc = mk_stmt(A_MP_TARGETLOOPTRIPCOUNT, 0);
5745 A_LOOPTRIPCOUNTP(targetast, ast_looptc);
5746 A_DOVARP(ast_looptc, dovar);
5747 A_M1P(ast_looptc, doinfo->init_expr);
5748 A_M2P(ast_looptc, doinfo->limit_expr);
5749 A_M3P(ast_looptc, doinfo->step_expr);
5750 }
5751 #endif
5752 if (DI_ID(sem.doif_depth) != DI_TASKLOOP) {
5753 A_CHUNKP(ast, DI_CHUNK(sem.doif_depth));
5754 A_DISTCHUNKP(ast, DI_DISTCHUNK(sem.doif_depth)); /* currently unused */
5755 A_SCHED_TYPEP(ast, DI_SCHED_TYPE(sem.doif_depth));
5756 A_ORDEREDP(ast, DI_IS_ORDERED(sem.doif_depth));
5757 } else {
5758 A_CHUNKP(ast, 0);
5759 A_DISTCHUNKP(ast, 0);
5760 A_SCHED_TYPEP(ast, 0);
5761 A_ORDEREDP(ast, 0);
5762 }
5763 if (doinfo->lastval_var) {
5764 int lv_ast = mk_id(doinfo->lastval_var);
5765 A_LASTVALP(ast, lv_ast);
5766 } else {
5767 A_LASTVALP(ast, 0);
5768 }
5769 A_ENDLABP(ast, 0);
5770
5771 /* set distribute loop flag */
5772 A_DISTRIBUTEP(ast, 0);
5773 A_DISTPARDOP(ast, 0);
5774
5775 if (DI_ID(sem.doif_depth) == DI_TASKLOOP) {
5776 A_TASKLOOPP(ast, 1);
5777 } else {
5778 A_TASKLOOPP(ast, 0);
5779 }
5780
5781 return ast;
5782 }
5783
5784 static struct {
5785 int upper;
5786 int lower;
5787 int tmplower; /* different if lower is lastprivate */
5788 int stride;
5789 // struct mp_for_init_info MPF;
5790 } distlp_info;
5791
5792 void
save_distloop_info(int lower,int upper,int stride)5793 save_distloop_info(int lower, int upper, int stride)
5794 {
5795 }
5796
5797 void
restore_distloop_info()5798 restore_distloop_info()
5799 {
5800 }
5801
5802 int
do_simdbegin(DOINFO * doinfo)5803 do_simdbegin(DOINFO *doinfo)
5804 {
5805 int iv, di_id;
5806 int ast, dovar;
5807
5808 iv = doinfo->index_var;
5809 if (!DT_ISINT(DTYPEG(iv))) {
5810 error(155, 3, gbl.lineno,
5811 "The index variable of a simd DO must be integer -", SYMNAME(iv));
5812 return do_begin(doinfo);
5813 }
5814 doinfo->prev_dovar = DOVARG(iv);
5815 DOCHK(iv);
5816 DOVARP(iv, 1);
5817 ast = mk_stmt(A_DO, 0 /* SST_ASTG(RHS(1)) BLOCKDO */);
5818 dovar = mk_id(iv);
5819 A_DOVARP(ast, dovar);
5820 A_M1P(ast, doinfo->init_expr);
5821 A_M2P(ast, doinfo->limit_expr);
5822 A_M3P(ast, doinfo->step_expr);
5823 if (doinfo->lastval_var) {
5824 A_LASTVALP(ast, mk_id(doinfo->lastval_var));
5825 } else {
5826 A_LASTVALP(ast, 0);
5827 }
5828 A_ENDLABP(ast, 0);
5829 A_DISTRIBUTEP(ast, 0);
5830 A_CHUNKP(ast, 0);
5831 A_DISTCHUNKP(ast, 0); /* currently unused */
5832 A_SCHED_TYPEP(ast, 0);
5833 A_ORDEREDP(ast, 0);
5834 A_DISTPARDOP(ast, 0);
5835 A_TASKLOOPP(ast, 0);
5836
5837 return ast;
5838 }
5839
5840 /*
5841 * collapse structure where various information is collected when the
5842 * omp collapse clause is present.
5843 */
5844 static struct {
5845 int itemp;
5846 int doif_depth; /* doif of the PARDO/PDO specifying COLLAPSE */
5847 int dtype; /* dtype of the new index, loop cnt & other temps */
5848 int index_var;
5849 int lp_cnt;
5850 int quo_var;
5851 int rem_var;
5852 int tmp_var;
5853 } coll_st;
5854
5855 static int get_collapse_temp(int, char *);
5856 static int collapse_expr(int, int, char *);
5857 static void collapse_index(DOINFO *);
5858
5859 /** \brief Begin processing loop collapse.
5860
5861 Example: the use of the collapse is for 3 loops.
5862 <pre>
5863 !$omp ... collapse(3)
5864 do i1 = in1, l1, s1
5865 do i2 = in2, l2, s2
5866 do i3 = in3, l3, s3
5867 ... SS ...
5868 </pre>
5869
5870 The 3 loops are collapsed into a single loop with a new index variable and
5871 loop count. The new loop defines the iteration space for which the other
5872 omp clauses are applied; the new loop will appear as:
5873 <pre>
5874 n1 = (l1 - in1 + s1)/s1
5875 n2 = (l2 - in2 + s2)/s2
5876 n3 = (l3 - in3 + s3)/s3
5877 nn = n1*n2*n3 !! the product of the loop counts
5878 !$omp ...
5879 do ii = 1, nn
5880 t = ii-1
5881 q = t / n3
5882 r = t - q*n3
5883 i3 = in3 + r*s3
5884
5885 t = q
5886 q = t / n2
5887 r = t - q*n2
5888 i2 = in2 + r*s2
5889
5890 t = q
5891 q = t / n1
5892 r = t - q*n1
5893 i2 = in1 + r*s1
5894
5895 ... SS ...
5896 </pre>
5897
5898 Basically, the original index variables are no longer iterated; their
5899 values are computed as a function of the new index variable and the
5900 corresponding loops' init, stride, and loop count.
5901
5902 Prefix of temps created for each loop:
5903 <pre>
5904 .Xa - lower bound
5905 .Xb - stride
5906 .Xc - loop count
5907 </pre>
5908 Collapsed loop:
5909 <pre>
5910 .Xd - loop count
5911 .id - index variable
5912 .Xe - quotient of id/loopcnt
5913 .Xf - remainder of id/loopcnt
5914 .Xg = temp var
5915 </pre>
5916 */
5917 int
collapse_begin(DOINFO * doinfo)5918 collapse_begin(DOINFO *doinfo)
5919 {
5920 int dtype;
5921 SST tsst;
5922 int ast;
5923 int count_var;
5924
5925 dtype = DTYPEG(doinfo->index_var);
5926 if (!DT_ISINT(dtype)) {
5927 error(155, 3, gbl.lineno,
5928 "The index variable of a parallel DO must be integer -",
5929 SYMNAME(doinfo->index_var));
5930 doinfo->collapse = sem.collapse = sem.collapse_depth = 0;
5931 ast = do_begin(doinfo);
5932 DI_DOINFO(sem.doif_depth) = 0; /* remove any chunk info */
5933 return ast;
5934 }
5935 coll_st.doif_depth = sem.doif_depth;
5936
5937 if (dtype != DT_INT8) /* change type if LOG, SINT, etc.*/
5938 dtype = DT_INT; /* see ensuing getccsym() call */
5939 /*
5940 * if the step expression is not a constant, a temporary variable
5941 * must be allocated to hold the value for the do-end.
5942 */
5943 doinfo->step_expr = collapse_expr(doinfo->step_expr, dtype, "Xb");
5944 /*
5945 * Same with the init expr.
5946 */
5947 doinfo->init_expr = collapse_expr(doinfo->init_expr, dtype, "Xa");
5948 /*
5949 * lp_cnt <-- (e2 - e1 + e3) / e3
5950 */
5951 ast = mk_binop(OP_SUB, doinfo->limit_expr, doinfo->init_expr, dtype);
5952 ast = mk_binop(OP_ADD, ast, doinfo->step_expr, dtype);
5953 ast = mk_binop(OP_DIV, ast, doinfo->step_expr, dtype);
5954 SST_IDP(&tsst, S_EXPR);
5955 SST_ASTP(&tsst, ast);
5956 SST_DTYPEP(&tsst, dtype);
5957 chktyp(&tsst, DT_INT8, FALSE);
5958
5959 count_var = get_collapse_temp(DT_INT8, "Xc");
5960 doinfo->count = mk_id(count_var);
5961
5962 /* add store of loop count */
5963 ast = SST_ASTG(&tsst);
5964 ast = mk_assn_stmt(doinfo->count, ast, DT_INT8);
5965 (void)add_stmt(ast);
5966
5967 coll_st.dtype = DT_INT8;
5968 coll_st.lp_cnt = get_collapse_temp(coll_st.dtype, "Xd");
5969 coll_st.index_var = get_collapse_temp(coll_st.dtype, "id");
5970 coll_st.quo_var = get_collapse_temp(coll_st.dtype, "Xe");
5971 coll_st.rem_var = get_collapse_temp(coll_st.dtype, "Xf");
5972 coll_st.tmp_var = get_collapse_temp(coll_st.dtype, "Xg");
5973 ENCLFUNCP(count_var, BLK_SYM(sem.scope_level));
5974 ENCLFUNCP(coll_st.lp_cnt, BLK_SYM(sem.scope_level));
5975 ENCLFUNCP(coll_st.index_var, BLK_SYM(sem.scope_level));
5976 ENCLFUNCP(coll_st.quo_var, BLK_SYM(sem.scope_level));
5977 ENCLFUNCP(coll_st.rem_var, BLK_SYM(sem.scope_level));
5978 ENCLFUNCP(coll_st.tmp_var, BLK_SYM(sem.scope_level));
5979 /*
5980 * initialize the new loop count as the loop count of the first loop.
5981 */
5982 SST_IDP(&tsst, S_IDENT);
5983 SST_SYMP(&tsst, count_var);
5984 SST_DTYPEP(&tsst, DT_INT8);
5985 chktyp(&tsst, coll_st.dtype, FALSE);
5986 mkexpr1(&tsst);
5987 ast = SST_ASTG(&tsst);
5988 ast = mk_assn_stmt(mk_id(coll_st.lp_cnt), ast, coll_st.dtype);
5989 (void)add_stmt(ast);
5990 coll_st.itemp++;
5991 sem.collapse_depth--;
5992
5993 return 0;
5994 }
5995
5996 /** \brief Process an ensuing loop which is being collapsed.
5997 */
5998 int
collapse_add(DOINFO * doinfo)5999 collapse_add(DOINFO *doinfo)
6000 {
6001 int dtype;
6002 SST tsst;
6003 int ast, dest_ast, std;
6004 int count_var;
6005
6006 dtype = DTYPEG(doinfo->index_var);
6007 if (DT_ISINT(dtype) && dtype != DT_INT8) /* change type if LOG, SINT, etc.*/
6008 dtype = DT_INT; /* see ensuing getccsym() call */
6009 /*
6010 * if the step expression is not a constant, a temporary variable
6011 * must be allocated to hold the value for the do-end.
6012 */
6013 doinfo->step_expr = collapse_expr(doinfo->step_expr, dtype, "Xb");
6014 /*
6015 * Same with the init expr.
6016 */
6017 doinfo->init_expr = collapse_expr(doinfo->init_expr, dtype, "Xa");
6018 /*
6019 * lp_cnt <-- (e2 - e1 + e3) / e3
6020 */
6021 ast = mk_binop(OP_SUB, doinfo->limit_expr, doinfo->init_expr, dtype);
6022 ast = mk_binop(OP_ADD, ast, doinfo->step_expr, dtype);
6023 ast = mk_binop(OP_DIV, ast, doinfo->step_expr, dtype);
6024 SST_IDP(&tsst, S_EXPR);
6025 SST_ASTP(&tsst, ast);
6026 SST_DTYPEP(&tsst, dtype);
6027
6028 chktyp(&tsst, DT_INT8, FALSE);
6029 ast = SST_ASTG(&tsst);
6030
6031 count_var = get_collapse_temp(DT_INT8, "Xc");
6032 ENCLFUNCP(count_var, BLK_SYM(sem.scope_level));
6033 doinfo->count = mk_id(count_var);
6034 coll_st.itemp++;
6035
6036 /* add store of loop count */
6037 ast = SST_ASTG(&tsst);
6038 ast = mk_assn_stmt(doinfo->count, ast, DT_INT8);
6039 (void)add_stmt(ast);
6040
6041 /*
6042 * update the new loop count by multiplying the loop count of the
6043 * current loop.
6044 */
6045 SST_IDP(&tsst, S_IDENT);
6046 SST_SYMP(&tsst, count_var);
6047 SST_DTYPEP(&tsst, DT_INT8);
6048 chktyp(&tsst, coll_st.dtype, FALSE);
6049 mkexpr1(&tsst);
6050 ast = SST_ASTG(&tsst);
6051 dest_ast = mk_id(coll_st.lp_cnt);
6052 ast = mk_binop(OP_MUL, dest_ast, ast, coll_st.dtype);
6053 ast = mk_assn_stmt(dest_ast, ast, coll_st.dtype);
6054 (void)add_stmt(ast);
6055
6056 if (doinfo->collapse == 1) {
6057 DOINFO *dinf;
6058 int t1, t2;
6059 int sv;
6060 int i;
6061 /*
6062 * The last loop to be collapsed is now processed. Create the new
6063 * new loop and pass to do_parbegin() which will apply the remaining
6064 * omp clauses.
6065 */
6066 dinf = get_doinfo(1);
6067 dinf->index_var = coll_st.index_var;
6068 dinf->prev_dovar = 0;
6069 if (coll_st.dtype != DT_INT8)
6070 dinf->init_expr = dinf->step_expr = astb.i1;
6071 else
6072 dinf->init_expr = dinf->step_expr = astb.k1;
6073 dinf->limit_expr = mk_id(coll_st.lp_cnt);
6074 do_lastval(dinf);
6075 sv = sem.doif_depth;
6076 /*
6077 * DI_DOINFO(coll_st.doif_depth) locates the DOINFO record for
6078 * the PARDO/PDO; DI_DOINFO(coll_st.doif_depth+1) is the DOINFO
6079 * for its corresponding DO.
6080 */
6081 sem.doif_depth = coll_st.doif_depth;
6082 if (DI_ID(sem.doif_depth) == DI_SIMD)
6083 ast = do_simdbegin(dinf);
6084 else
6085 ast = do_parbegin(dinf);
6086 std = add_stmt(ast);
6087 sem.doif_depth = sv;
6088 if (DI_ID(sv) == DI_DOCONCURRENT)
6089 STD_BLKSYM(std) = DI_CONC_BLOCK_SYM(sv);
6090 /*
6091 * Compute the values for index variables in the collapsed do loops in
6092 * the order from inner to outer.
6093 * DI_DOINFO(sem.doif_depth) locates the DOINFO record for loop
6094 * immediately enclosing the current loop.
6095 */
6096 collapse_index(doinfo); /* innermost first */
6097 for (i = sem.doif_depth; TRUE; i--) {
6098 DOINFO *dd;
6099 dd = DI_DOINFO(i);
6100 collapse_index(dd);
6101 if (dd->collapse == sem.collapse)
6102 break;
6103 }
6104
6105 DI_DOINFO(coll_st.doif_depth + 1) = dinf;
6106 }
6107 sem.collapse_depth--;
6108
6109 return 0;
6110 }
6111
6112 static int
get_collapse_temp(int dtype,char * pfx)6113 get_collapse_temp(int dtype, char *pfx)
6114 {
6115 int sptr;
6116 sptr = getccssym_sc(pfx, coll_st.itemp, ST_VAR, sem.sc);
6117 DTYPEP(sptr, dtype);
6118 return sptr;
6119 }
6120
6121 static int
collapse_expr(int ast,int dtype,char * pfx)6122 collapse_expr(int ast, int dtype, char *pfx)
6123 {
6124 int sptr, dest_ast;
6125 if (A_ALIASG(ast))
6126 return ast;
6127 sptr = getccssym_sc(pfx, coll_st.itemp, ST_VAR, sem.sc);
6128 DTYPEP(sptr, dtype);
6129 dest_ast = mk_id(sptr);
6130 ast = mk_assn_stmt(dest_ast, ast, dtype);
6131 (void)add_stmt(ast);
6132 return dest_ast;
6133 }
6134
6135 /*
6136 * Compute the values of the index variables of the collapsed DO loops.
6137 * The index variables will be computed in the order of inner to
6138 * outer.
6139 */
6140 static void
collapse_index(DOINFO * dd)6141 collapse_index(DOINFO *dd)
6142 {
6143 int dt_index;
6144 int q, r, cnt;
6145 int qpr, tmp;
6146 SST tsst;
6147
6148 dt_index = DTYPEG(dd->index_var);
6149 if (dd->collapse == 1) {
6150 /*
6151 * initialize for a new set of collapsed loops; compute
6152 * qpr <-- (id-1) / cnt
6153 */
6154 qpr = mk_id(coll_st.index_var);
6155 if (coll_st.dtype != DT_INT8)
6156 qpr = mk_binop(OP_SUB, qpr, astb.i1, coll_st.dtype);
6157 else
6158 qpr = mk_binop(OP_SUB, qpr, astb.k1, coll_st.dtype);
6159 qpr = mk_assn_stmt(mk_id(coll_st.tmp_var), qpr, coll_st.dtype);
6160 (void)add_stmt(qpr);
6161 }
6162 /*
6163 * Compute
6164 * q <-- qpr / cnt
6165 */
6166 qpr = mk_id(coll_st.tmp_var);
6167 SST_IDP(&tsst, S_IDENT);
6168 SST_SYMP(&tsst, A_SPTRG(dd->count));
6169 SST_DTYPEP(&tsst, dt_index);
6170 chktyp(&tsst, coll_st.dtype, FALSE);
6171 mkexpr1(&tsst);
6172 cnt = SST_ASTG(&tsst);
6173 tmp = mk_binop(OP_DIV, qpr, cnt, coll_st.dtype);
6174 q = mk_id(coll_st.quo_var);
6175 tmp = mk_assn_stmt(q, tmp, coll_st.dtype);
6176 (void)add_stmt(tmp);
6177 /*
6178 * Compute
6179 * r <-- qpr - q * cnt
6180 */
6181 tmp = mk_binop(OP_MUL, q, cnt, coll_st.dtype);
6182 tmp = mk_binop(OP_SUB, qpr, tmp, coll_st.dtype);
6183 r = mk_id(coll_st.rem_var);
6184 tmp = mk_assn_stmt(r, tmp, coll_st.dtype);
6185 (void)add_stmt(tmp);
6186 /*
6187 * Compute
6188 * i <-- init + r*step
6189 */
6190 SST_IDP(&tsst, S_IDENT);
6191 SST_SYMP(&tsst, coll_st.rem_var);
6192 SST_DTYPEP(&tsst, coll_st.dtype);
6193 chktyp(&tsst, dt_index, FALSE);
6194 mkexpr1(&tsst);
6195 r = SST_ASTG(&tsst);
6196 tmp = mk_binop(OP_MUL, r, dd->step_expr, dt_index);
6197 tmp = mk_binop(OP_ADD, tmp, dd->init_expr, dt_index);
6198 tmp = mk_assn_stmt(mk_id(dd->index_var), tmp, dt_index);
6199 (void)add_stmt(tmp);
6200 /*
6201 * Compute, iff not the last index variable
6202 * qpr <-- q
6203 */
6204 if (dd->collapse != sem.collapse) {
6205 tmp = mk_assn_stmt(qpr, q, coll_st.dtype);
6206 (void)add_stmt(tmp);
6207 }
6208 }
6209
6210 void
do_end(DOINFO * doinfo)6211 do_end(DOINFO *doinfo)
6212 {
6213 int ast, i, orig_doif, par_doif, std, symi, astlab;
6214 SPTR block_sptr, lab, sptr;
6215
6216 orig_doif = sem.doif_depth; // original loop index
6217
6218 // Close do concurrent mask.
6219 // Don't emit scn.currlab here. (Don't use add_stmt.)
6220 if (DI_ID(orig_doif) == DI_DOCONCURRENT && DI_CONC_MASK_STD(orig_doif))
6221 (void)add_stmt_after(mk_stmt(A_ENDIF, 0), STD_LAST);
6222
6223 // Loop body is done; emit loop cycle label.
6224 // Don't emit scn.currlab here. (Don't use add_stmt.)
6225 if (DI_CYCLE_LABEL(orig_doif)) {
6226 std = add_stmt_after(mk_stmt(A_CONTINUE, 0), STD_LAST);
6227 STD_LABEL(std) = DI_CYCLE_LABEL(orig_doif);
6228 DEFDP(DI_CYCLE_LABEL(orig_doif), 1);
6229 }
6230
6231 // Finish do concurrent inner loop processing and move to the outermost loop.
6232 if (DI_ID(orig_doif) == DI_DOCONCURRENT) {
6233 check_doconcurrent(orig_doif); // innermost loop has constraint check info
6234 std = add_stmt_after(mk_stmt(A_CONTINUE, 0), STD_LAST);
6235 STD_LINENO(std) = gbl.lineno;
6236 STD_LABEL(std) = lab = getlab();
6237 RFCNTI(lab);
6238 VOLP(lab, true);
6239 block_sptr = DI_CONC_BLOCK_SYM(orig_doif);
6240 ENDLINEP(block_sptr, gbl.lineno);
6241 ENDLABP(block_sptr, lab);
6242 for (i = DI_CONC_COUNT(orig_doif), symi = DI_CONC_SYMS(orig_doif); i;
6243 --i, symi = SYMI_NEXT(symi)) {
6244 sptr = SYMI_SPTR(symi);
6245 HIDDENP(sptr, 1); // do concurrent index construct var
6246 }
6247 for (++sptr; sptr < stb.stg_avail; ++sptr)
6248 switch (STYPEG(sptr)) {
6249 case ST_UNKNOWN:
6250 case ST_IDENT:
6251 case ST_VAR:
6252 case ST_ARRAY:
6253 if (SAVEG(sptr))
6254 break;
6255 if (!CCSYMG(sptr) && !HCCSYMG(sptr))
6256 DCLCHK(sptr);
6257 HIDDENP(sptr, 1); // do concurrent non-index construct var
6258 if (ENCLFUNCG(sptr) == 0)
6259 ENCLFUNCP(sptr, block_sptr);
6260 }
6261 for (; DI_CONC_COUNT(orig_doif) > 1; --orig_doif)
6262 if (!DI_DOINFO(orig_doif)->collapse) {
6263 std = add_stmt(mk_stmt(A_ENDDO, 0));
6264 STD_BLKSYM(std) = block_sptr;
6265 }
6266 doinfo = DI_DOINFO(orig_doif);
6267 sem.doif_depth = orig_doif;
6268 }
6269
6270 if (doinfo->index_var)
6271 /*
6272 * If there is an index variable, set its DOVAR flag to its 'state'
6273 * before entering the DO which is about to be popped.
6274 */
6275 DOVARP(doinfo->index_var, doinfo->prev_dovar);
6276
6277 par_doif = orig_doif - 1; // parallel loop index (if it exists)
6278
6279 switch (DI_ID(par_doif)) {
6280 case DI_PDO:
6281 (void)add_stmt(mk_stmt(A_MP_ENDPDO, 0));
6282 if (scn.currlab && scn.stmtyp != TK_ENDDO)
6283 (void)add_stmt(mk_stmt(A_MP_BARRIER, 0));
6284 end_parallel_clause(par_doif);
6285 sem.close_pdo = TRUE;
6286 par_pop_scope();
6287 sem.collapse = 0;
6288 break;
6289
6290 case DI_TASKLOOP:
6291 ast = mk_stmt(A_MP_ENDPDO, 0);
6292 A_TASKLOOPP(ast, 1);
6293 (void)add_stmt(ast);
6294 end_parallel_clause(par_doif);
6295 sem.close_pdo = TRUE;
6296 --sem.task;
6297 par_pop_scope();
6298 add_stmt(mk_stmt(A_MP_ETASKLOOPREG, 0));
6299 ast = mk_stmt(A_MP_ETASKLOOP, 0);
6300 A_LOPP(DI_BEGINP(par_doif), ast);
6301 A_LOPP(ast, DI_BEGINP(par_doif));
6302 add_stmt(ast);
6303 if (sem.task < 0)
6304 sem.task = 0;
6305 mp_create_escope();
6306 sem.collapse = 0;
6307 break;
6308
6309 case DI_DOACROSS:
6310 case DI_PARDO:
6311 /* For DOACROSS & PARALLEL DO, need to end the parallel section. */
6312 (void)add_stmt(mk_stmt(A_MP_ENDPDO, 0));
6313 end_parallel_clause(par_doif);
6314 sem.close_pdo = TRUE;
6315 --sem.parallel;
6316 par_pop_scope();
6317 ast = emit_epar();
6318 A_LOPP(DI_BPAR(par_doif), ast);
6319 A_LOPP(ast, DI_BPAR(par_doif));
6320 mp_create_escope();
6321 sem.collapse = 0;
6322 break;
6323
6324 case DI_TEAMSDIST:
6325 case DI_TARGTEAMSDIST:
6326 case DI_DISTRIBUTE:
6327 (void)add_stmt(mk_stmt(A_MP_ENDPDO, 0));
6328 end_parallel_clause(par_doif);
6329 sem.close_pdo = TRUE;
6330 par_pop_scope();
6331 ast = mk_stmt(A_MP_ENDDISTRIBUTE, 0);
6332 A_LOPP(DI_BDISTRIBUTE(par_doif), ast);
6333 A_LOPP(ast, DI_BDISTRIBUTE(par_doif));
6334 (void)add_stmt(ast);
6335 sem.collapse = 0;
6336 break;
6337
6338 case DI_TEAMSDISTPARDO:
6339 case DI_TARGTEAMSDISTPARDO:
6340 case DI_DISTPARDO:
6341 (void)add_stmt(mk_stmt(A_MP_ENDPDO, 0));
6342 end_parallel_clause(par_doif);
6343 sem.close_pdo = TRUE;
6344
6345 /* We create 2 scopes for distributed loop so that
6346 * lastprivate(dovar) is not the same as dovar for
6347 * distributed loop, therefore we need to double pop
6348 * one for do scope and another is for lastprivate
6349 * which is DISTPARDO scope.
6350 */
6351
6352 par_pop_scope();
6353 par_pop_scope();
6354 ast = mk_stmt(A_MP_ENDDISTRIBUTE, 0);
6355 A_LOPP(DI_BDISTRIBUTE(par_doif), ast);
6356 A_LOPP(ast, DI_BDISTRIBUTE(par_doif));
6357 (void)add_stmt(ast);
6358 sem.collapse = 0;
6359 break;
6360
6361 case DI_TARGPARDO:
6362 (void)add_stmt(mk_stmt(A_MP_ENDPDO, 0));
6363 end_parallel_clause(par_doif);
6364 sem.close_pdo = TRUE;
6365 --sem.parallel;
6366 par_pop_scope();
6367 ast = emit_epar();
6368 A_LOPP(DI_BPAR(par_doif), ast);
6369 A_LOPP(ast, DI_BPAR(par_doif));
6370 mp_create_escope();
6371 sem.collapse = 0;
6372 end_parallel_clause(orig_doif);
6373 sem.doif_depth--; /* leave_dir(DI_TARGPARDO, .. */
6374 par_doif--;
6375 sem.target--;
6376 par_pop_scope();
6377 ast = emit_etarget();
6378 mp_create_escope();
6379 A_LOPP(DI_BTARGET(par_doif), ast);
6380 A_LOPP(ast, DI_BTARGET(par_doif));
6381 sem.collapse = 0;
6382 break;
6383
6384 case DI_SIMD:
6385 /* Standalone simd construct and target simd too? */
6386 (void)add_stmt(mk_stmt(A_ENDDO, 0));
6387 end_parallel_clause(par_doif);
6388 sem.close_pdo = TRUE;
6389 par_pop_scope();
6390 sem.collapse = 0;
6391 break;
6392
6393 case DI_ACCDO:
6394 case DI_ACCLOOP:
6395 case DI_ACCREGDO:
6396 case DI_ACCREGLOOP:
6397 case DI_ACCKERNELSDO:
6398 case DI_ACCKERNELSLOOP:
6399 case DI_ACCPARALLELDO:
6400 case DI_ACCPARALLELLOOP:
6401 case DI_ACCSERIALLOOP:
6402 case DI_CUFKERNEL:
6403 (void)add_stmt(mk_stmt(A_ENDDO, 0));
6404 sem.close_pdo = TRUE;
6405 /* Pop the inserted new symbol for the induction var*/
6406 if (flg.smp && (SCG(doinfo->index_var) != SC_PRIVATE)) {
6407 if (DI_DO_POPINDEX(sem.doif_depth) > SPTR_NULL)
6408 pop_sym(DI_DO_POPINDEX(sem.doif_depth));
6409 }
6410 break;
6411
6412 default:
6413 // No parallel loop; process the original loop.
6414 if (doinfo->collapse > 0)
6415 // This is an intermediate loop in a collapsed loop nest.
6416 break;
6417
6418 switch (DI_ID(orig_doif)) {
6419 case DI_DO:
6420 (void)add_stmt(mk_stmt(A_ENDDO, 0));
6421 break;
6422 case DI_DOCONCURRENT:
6423 std = add_stmt(mk_stmt(A_ENDDO, 0));
6424 STD_BLKSYM(std) = block_sptr;
6425 break;
6426 case DI_DOWHILE:
6427 ast = mk_stmt(A_GOTO, 0);
6428 // Do not place mk_label inside A_L1P(ast, mk_label(...))
6429 // due to undefined behavior of C compiler for evaluation order
6430 // between the calculation of the address of the target of an
6431 // assignment and the computation of the value being assigned.
6432 astlab = mk_label(DI_TOP_LABEL(orig_doif));
6433 A_L1P(ast, astlab);
6434 RFCNTI(DI_TOP_LABEL(orig_doif));
6435 (void)add_stmt(ast);
6436 (void)add_stmt(mk_stmt(A_ENDIF, 0));
6437 break;
6438 }
6439 }
6440
6441 // Loop code is done; emit loop exit label.
6442 if (DI_EXIT_LABEL(orig_doif)) {
6443 std = add_stmt(mk_stmt(A_CONTINUE, 0));
6444 STD_LABEL(std) = DI_EXIT_LABEL(orig_doif);
6445 DEFDP(DI_EXIT_LABEL(orig_doif), 1);
6446 }
6447
6448 --sem.doif_depth;
6449 }
6450
6451 DOINFO *
get_doinfo(int area)6452 get_doinfo(int area)
6453 {
6454 DOINFO *doinfo;
6455 doinfo = (DOINFO *)getitem(area, sizeof(DOINFO));
6456 doinfo->collapse = 0;
6457 doinfo->distloop = 0;
6458 return doinfo;
6459 }
6460
6461 /**
6462 \param structd dtype record of parent structure
6463 \param base ast ptr of parent structure
6464 \param nmx index into "names" area of member
6465 \return ast or 0 if not found
6466 */
6467 int
mkmember(int structd,int base,int nmx)6468 mkmember(int structd, int base, int nmx)
6469 {
6470 int sptr; /* next member of structure to search */
6471 int dtype;
6472 int tmp;
6473 for (sptr = DTY(structd + 1); sptr > NOSYM; sptr = SYMLKG(sptr)) {
6474 dtype = DTYPEG(sptr);
6475 /*
6476 * special case: if member is a union, then we must look at
6477 * all maps which belong to the union; recall that each map is
6478 * just a struct.
6479 */
6480 if (DTY(dtype) == TY_UNION) {
6481 int ast;
6482 ast = mkunion(dtype, base, nmx);
6483 if (ast)
6484 return (ast);
6485 } else if (NMPTRG(sptr) == nmx) {
6486 int ast, member;
6487 if (flg.xref)
6488 xrefput(sptr, 'r');
6489 member = mk_id(sptr);
6490 ast = mk_member(base, mk_id(sptr), dtype);
6491 return ast;
6492 } else if (PARENTG(sptr)) { /* type extension */
6493 int ast = mkmember(DTYPEG(sptr), base, nmx);
6494 if (ast)
6495 return ast;
6496 }
6497 }
6498 return 0; /* not found */
6499 }
6500
6501 /**
6502 \param uniond dtype record of parent structure
6503 \param base ast ptr of parent structure
6504 \param nmx index into "names" area of member
6505 \return ast or 0 if not found
6506 */
6507 static int
mkunion(int uniond,int base,int nmx)6508 mkunion(int uniond, int base, int nmx)
6509 {
6510 int sptr; /* next member of structure to search */
6511 int dtype;
6512 int ast;
6513 /*
6514 * scan the MAPs (each "member" is a struct and represents
6515 * one map)
6516 */
6517 for (sptr = DTY(uniond + 1); sptr != NOSYM; sptr = SYMLKG(sptr)) {
6518 dtype = DTYPEG(sptr);
6519 #if DEBUG
6520 assert(DTY(dtype) == TY_STRUCT, "mkunion, dt not struct", sptr, 3);
6521 #endif
6522 /* look at all members of the map (a struct) */
6523 ast = mkmember(dtype, base, nmx);
6524 if (ast)
6525 return ast;
6526 }
6527 return 0; /* not found */
6528 }
6529
6530 /** \brief Given an ast which computes the address of the label variable or
6531 loads the label variable, create the variable of indicated dtype.
6532 */
6533 int
mklabelvar(SST * stkptr)6534 mklabelvar(SST *stkptr)
6535 {
6536 int ast;
6537 int sptr;
6538 int dtype;
6539
6540 mkexpr(stkptr);
6541 ast = SST_ASTG(stkptr);
6542 #if DEBUG
6543 if (A_TYPEG(ast) != A_ID) {
6544 interr("mklabelvar: ast not id", ast, 3);
6545 return 0;
6546 }
6547 #endif
6548 sptr = A_SPTRG(ast);
6549 /*
6550 * When targeting llvm, always create a temp variable of ptr-size
6551 * integer type.
6552 */
6553 if (XBIT(49, 0x100))
6554 dtype = DT_INT8;
6555 else
6556 dtype = DT_INT4;
6557 sptr = getcctmp_sc('l', sptr, ST_VAR, dtype, sem.sc);
6558 SST_DTYPEP(stkptr, DTYPEG(sptr));
6559 SST_ASTP(stkptr, mk_id(sptr));
6560 return sptr;
6561 }
6562
6563 LOGICAL
legal_labelvar(int dtype)6564 legal_labelvar(int dtype)
6565 {
6566 if (dtype == stb.user.dt_int)
6567 return TRUE;
6568 if (dtype == DT_INT4 || dtype == DT_INT8)
6569 return TRUE;
6570 return FALSE;
6571 }
6572
6573 static INT
_xtok(INT conval1,BIGINT64 count,int dtype)6574 _xtok(INT conval1, BIGINT64 count, int dtype)
6575 {
6576 INT conval;
6577 INT one;
6578 int isneg;
6579 IEEE128 qtemp, qresult, qnum1;
6580 IEEE128 qreal1, qrealrs, qimag1, qimagrs;
6581 IEEE128 qrealpv, qtemp1;
6582 DBLE dtemp, dresult, num1;
6583 DBLE dreal1, drealrs, dimag1, dimagrs;
6584 DBLE drealpv, dtemp1;
6585 SNGL temp, result;
6586 SNGL real1, realrs, imag1, imagrs;
6587 SNGL realpv, temp1;
6588 DBLINT64 inum1, ires;
6589 int overr;
6590 UINT uval, uoldval;
6591
6592 overr = 0;
6593 isneg = 0;
6594 if (count < 0) {
6595 isneg = 1;
6596 count = -count;
6597 }
6598 one = 1;
6599 if (dtype != DT_INT4)
6600 one = cngcon(one, DT_INT4, dtype);
6601 switch (DTY(dtype)) {
6602 case TY_WORD:
6603 case TY_DWORD:
6604 error(33, 3, gbl.lineno, " ", CNULL);
6605 return (0);
6606
6607 case TY_BINT:
6608 case TY_SINT:
6609 case TY_INT:
6610 uval = 1;
6611 {
6612 int do_neg;
6613 int sg;
6614 sg = 0;
6615 do_neg = 0;
6616 if (conval1 < 0) {
6617 do_neg = 1;
6618 conval1 = -conval1;
6619 }
6620 uoldval = conval1;
6621 while (count--) {
6622 sg ^= 1;
6623 uval = uval * conval1;
6624 if (!sem.which_pass && !overr && uval < uoldval) {
6625 /*
6626 * generally, warnings are inhibited during the 2nd parse
6627 */
6628 overr = 1;
6629 }
6630 uoldval = uval;
6631 }
6632 conval = *((INT *)&uval);
6633 if (do_neg) {
6634 conval1 = -conval1;
6635 if (sg)
6636 conval = -conval;
6637 } else if (conval & 0x80000000)
6638 overr = 1;
6639 if (overr) {
6640 error(155, 2, gbl.lineno, "Integer overflow occurred when evaluating",
6641 "**");
6642 }
6643 }
6644 break;
6645
6646 case TY_INT8:
6647 inum1[0] = CONVAL1G(conval1);
6648 inum1[1] = CONVAL2G(conval1);
6649 ires[0] = CONVAL1G(stb.k1);
6650 ires[1] = CONVAL2G(stb.k1);
6651 while (count--)
6652 mul64(inum1, ires, ires);
6653 conval = getcon(ires, DT_INT8);
6654 break;
6655
6656 case TY_REAL:
6657 conval = CONVAL2G(stb.flt1);
6658 while (count--)
6659 xfmul(conval1, conval, &conval);
6660 break;
6661
6662 case TY_DBLE:
6663 num1[0] = CONVAL1G(conval1);
6664 num1[1] = CONVAL2G(conval1);
6665 dresult[0] = CONVAL1G(stb.dbl1);
6666 dresult[1] = CONVAL2G(stb.dbl1);
6667 while (count--)
6668 xdmul(num1, dresult, dresult);
6669 conval = getcon(dresult, DT_REAL8);
6670 break;
6671
6672 case TY_CMPLX:
6673 real1 = CONVAL1G(conval1);
6674 imag1 = CONVAL2G(conval1);
6675 realrs = CONVAL1G(one);
6676 imagrs = CONVAL2G(one);
6677 while (count--) {
6678 /* (a + bi) * (c + di) ==> (ac-bd) + (ad+cb)i */
6679 realpv = realrs;
6680 xfmul(real1, realrs, &temp1);
6681 xfmul(imag1, imagrs, &temp);
6682 xfsub(temp1, temp, &realrs);
6683 xfmul(real1, imagrs, &temp1);
6684 xfmul(realpv, imag1, &temp);
6685 xfadd(temp1, temp, &imagrs);
6686 }
6687 num1[0] = realrs;
6688 num1[1] = imagrs;
6689 conval = getcon(num1, DT_CMPLX8);
6690 break;
6691
6692 case TY_DCMPLX:
6693 dreal1[0] = CONVAL1G(CONVAL1G(conval1));
6694 dreal1[1] = CONVAL2G(CONVAL1G(conval1));
6695 dimag1[0] = CONVAL1G(CONVAL2G(conval1));
6696 dimag1[1] = CONVAL2G(CONVAL2G(conval1));
6697 drealrs[0] = CONVAL1G(CONVAL1G(one));
6698 drealrs[1] = CONVAL2G(CONVAL1G(one));
6699 dimagrs[0] = CONVAL1G(CONVAL2G(one));
6700 dimagrs[1] = CONVAL2G(CONVAL2G(one));
6701 while (count--) {
6702 /* (a + bi) * (c + di) ==> (ac-bd) + (ad+cb)i */
6703 drealpv[0] = drealrs[0];
6704 drealpv[1] = drealrs[1];
6705 xdmul(dreal1, drealrs, dtemp1);
6706 xdmul(dimag1, dimagrs, dtemp);
6707 xdsub(dtemp1, dtemp, drealrs);
6708 xdmul(dreal1, dimagrs, dtemp1);
6709 xdmul(drealpv, dimag1, dtemp);
6710 xdadd(dtemp1, dtemp, dimagrs);
6711 }
6712 num1[0] = getcon(drealrs, DT_REAL8);
6713 num1[1] = getcon(dimagrs, DT_REAL8);
6714 conval = getcon(num1, DT_CMPLX16);
6715 break;
6716
6717 case TY_BLOG:
6718 case TY_SLOG:
6719 case TY_LOG:
6720 case TY_LOG8:
6721 case TY_NCHAR:
6722 case TY_CHAR:
6723 errsev(91);
6724 return 0;
6725 }
6726 if (isneg) {
6727 /* exponentiation to a negative power */
6728 conval = const_fold(OP_DIV, one, conval, dtype);
6729 }
6730
6731 return conval;
6732 }
6733
6734 static void
error83(int ty)6735 error83(int ty)
6736 {
6737 if (ty == TY_CHAR)
6738 UFCHAR;
6739 else
6740 errsev(83);
6741 }
6742
6743