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 Abstract syntax tree access module.
20
21 This module contains the routines used to initialize, update, access, and
22 dump the abstract syntax tree.
23
24 <pre>
25 q flags:
26 -q 4 256 dump asts
27 -q 4 512 include hash table of asts
28 </pre>
29 */
30
31 #include "gbldefs.h"
32 #include "global.h"
33 #include "error.h"
34 #include "symtab.h"
35 #include "symutl.h"
36 #include "dtypeutl.h"
37 #include "scan.h"
38 #include "machar.h"
39 #include "state.h"
40 #include "ast.h"
41 #include "pragma.h"
42 #include "rte.h"
43 #include "extern.h"
44 #include "rtlRtns.h"
45
46 static int reduce_iadd(int, INT);
47 static int reduce_i8add(int, int);
48 static int convert_cnst(int, int);
49 static SPTR sym_of_ast2(int);
50 static LOGICAL bounds_match(int, int, int);
51 static INT _fdiv(INT, INT);
52 static void _ddiv(INT *, INT *, INT *);
53 static int hex2char(INT *);
54 static int hex2nchar(INT *);
55 static void truncation_warning(int);
56 static void conversion_warning(void);
57
58 static int atemps; /* temp counter for bounds' temporaries */
59
60 #define MIN_INT64(n) \
61 (((n[0] & 0xffffffff) == 0x80000000) && ((n[1] & 0xffffffff) == 0))
62
63 /** \brief Initialize AST table for new user program unit.
64 */
65 void
ast_init(void)66 ast_init(void)
67 {
68 int i;
69
70 #if DEBUG
71 assert(sizeof(AST) / sizeof(int) == 19, "bad AST size",
72 sizeof(AST) / sizeof(int), 4);
73 #endif
74
75 /* allocate AST and auxiliary structures: */
76
77 if (astb.stg_size <= 0) {
78 STG_ALLOC(astb, 2000);
79 #if DEBUG
80 assert(astb.stg_base, "ast_init: no room for AST", astb.stg_size, 4);
81 #endif
82 } else {
83 STG_RESET(astb);
84 }
85 STG_NEXT(astb); /* reserve ast index 1 to terminate ast_traverse() */
86 BZERO(astb.hshtb, int, HSHSZ + 1);
87
88 if (astb.asd.stg_size <= 0) {
89 astb.asd.stg_size = 200;
90 NEW(astb.asd.stg_base, int, astb.asd.stg_size);
91 #if DEBUG
92 assert(astb.asd.stg_base, "ast_init: no room for ASD", astb.asd.stg_size, 4);
93 #endif
94 }
95 BZERO(astb.asd.hash, int, 7);
96 astb.asd.stg_base[0] = 0;
97 astb.asd.stg_avail = 1;
98
99 if (astb.shd.stg_size <= 0) {
100 astb.shd.stg_size = 200;
101 NEW(astb.shd.stg_base, SHD, astb.shd.stg_size);
102 #if DEBUG
103 assert(astb.shd.stg_base, "ast_init: no room for SHD", astb.shd.stg_size, 4);
104 #endif
105 } else
106 BZERO(astb.shd.hash, int, 7);
107 astb.shd.stg_base[0].lwb = 0;
108 astb.shd.stg_base[0].upb = 0;
109 astb.shd.stg_base[0].stride = 0;
110 astb.shd.stg_avail = 1;
111
112 if (astb.std.stg_size <= 0) {
113 STG_ALLOC(astb.std, 200);
114 #if DEBUG
115 assert(astb.std.stg_base, "ast_init: no room for STD", astb.std.stg_size, 4);
116 #endif
117 } else {
118 STG_RESET(astb.std);
119 }
120
121 STD_PREV(0) = STD_NEXT(0) = 0;
122 STD_FLAGS(0) = 0;
123 STD_LINENO(0) = 0;
124 STD_FINDEX(0) = 0;
125
126 if (astb.astli.stg_size <= 0) {
127 astb.astli.stg_size = 200;
128 NEW(astb.astli.stg_base, ASTLI, astb.astli.stg_size);
129 #if DEBUG
130 assert(astb.astli.stg_base, "ast_init: no room for ASTLI", astb.astli.stg_size, 4);
131 #endif
132 }
133 astb.astli.stg_avail = 1;
134 astb.astli.stg_base[0].h1 = 0;
135 astb.astli.stg_base[0].h2 = 0;
136 astb.astli.stg_base[0].flags = 0;
137 astb.astli.stg_base[0].next = 0;
138
139 if (astb.argt.stg_size <= 0) {
140 astb.argt.stg_size = 200;
141 NEW(astb.argt.stg_base, int, astb.argt.stg_size);
142 #if DEBUG
143 assert(astb.argt.stg_base, "ast_init: no room for ARGT", astb.argt.stg_size, 4);
144 #endif
145 }
146 astb.argt.stg_avail = 1;
147 astb.argt.stg_base[0] = 0;
148
149 if (astb.comstr.stg_size <= 0) {
150 astb.comstr.stg_size = 200;
151 NEW(astb.comstr.stg_base, char, astb.comstr.stg_size);
152 #if DEBUG
153 assert(astb.comstr.stg_base, "ast_init: no room for COMSTR", astb.comstr.stg_size,
154 4);
155 #endif
156 }
157 astb.comstr.stg_avail = 0;
158 astb.comstr.stg_base[0] = 0;
159
160 BZERO(astb.implicit, char, sizeof(astb.implicit));
161
162 BZERO(astb.stg_base + 0, AST, 2); /* initialize AST #0 and #1 */
163 /*
164 * WARNING --- any changes/additions to the predeclared ASTs
165 * need to be reflected in the interf/exterf module processing.
166 * The ASTs before astb.firstuast are not written to the .mod
167 * file and are used asis when encountered during the read processing.
168 * NOTE that the current value of firstuast is 12 !!!
169 */
170 astb.i0 = mk_cval((INT)0, DT_INT);
171 astb.i1 = mk_cval((INT)1, DT_INT);
172 /*
173 * ensure that unique asts represent (void *)0, (void *)1, and the
174 * character value indicating a non-present I/O character specifier.
175 * Use %val with ID asts of a few predeclared symbol table pointers.
176 * WARNING: need to ensure that the ID ASTs have the same data type
177 * as the %val ASTs.
178 */
179 #define MKU(a, s, d) \
180 { \
181 i = new_node(A_ID); \
182 A_SPTRP(i, s); \
183 A_DTYPEP(i, d); \
184 a = mk_unop(OP_VAL, i, d); \
185 }
186
187 MKU(astb.ptr0, 1, DT_INT);
188 MKU(astb.ptr1, 2, DT_INT);
189 MKU(astb.ptr0c, 3, DT_CHAR);
190
191 #undef MKU
192
193 /*
194 * astb.k0 & astb.k1 used to be created with astb.i0 & astb.i1, but
195 * that caused compatibility problems with older modfiles.
196 * the new predeclareds are added to the end of the predeclared
197 * area, so that numbering of the older predeclareds remains
198 * the same.
199 */
200 astb.k0 = mk_cval((INT)0, DT_INT8);
201 astb.k1 = mk_cval((INT)1, DT_INT8);
202
203 if (XBIT(68, 0x1)) {
204 astb.bnd.dtype = DT_INT8;
205 astb.bnd.zero = astb.k0;
206 astb.bnd.one = astb.k1;
207 } else {
208 astb.bnd.dtype = DT_INT;
209 astb.bnd.zero = astb.i0;
210 astb.bnd.one = astb.i1;
211 }
212
213 /* fix length of DT_CHAR, DT_NCHAR */
214 DTY(DT_CHAR + 1) = astb.bnd.one;
215 DTY(DT_NCHAR + 1) = astb.bnd.one;
216
217 atemps = 0;
218 astb.firstuast = astb.stg_avail;
219 #if DEBUG
220 assert(astb.firstuast == 12,
221 "ast_init(): # of predeclared ASTs has changed -- fix interf or IVSN",
222 astb.firstuast, 4);
223 #endif
224
225 /* integer array(1) data type record */
226 aux.dt_iarray = DT_IARRAY;
227
228 DTY(DT_IARRAY + 1) = stb.user.dt_int;
229 get_aux_arrdsc(DT_IARRAY, 1);
230 ADD_LWAST(DT_IARRAY, 0) = 0;
231 ADD_UPBD(DT_IARRAY, 0) = ADD_UPAST(DT_IARRAY, 0) =
232 ADD_EXTNTAST(DT_IARRAY, 0) = astb.bnd.one;
233
234 if (stb.user.dt_int == DT_INT) {
235 aux.dt_iarray_int = aux.dt_iarray;
236 } else {
237 aux.dt_iarray_int = get_array_dtype(1, DT_INT);
238 ADD_LWAST(aux.dt_iarray_int, 0) = 0;
239 ADD_UPBD(aux.dt_iarray_int, 0) = ADD_UPAST(aux.dt_iarray_int, 0) =
240 ADD_EXTNTAST(aux.dt_iarray_int, 0) = astb.bnd.one;
241 }
242 }
243
244 void
ast_fini(void)245 ast_fini(void)
246 {
247 if (astb.stg_base) {
248 STG_DELETE(astb);
249 }
250 if (astb.asd.stg_base) {
251 FREE(astb.asd.stg_base);
252 astb.asd.stg_avail = astb.asd.stg_size = 0;
253 }
254 if (astb.shd.stg_base) {
255 FREE(astb.shd.stg_base);
256 astb.shd.stg_avail = astb.shd.stg_size = 0;
257 }
258 if (astb.std.stg_base) {
259 STG_DELETE(astb.std);
260 }
261 if (astb.astli.stg_base) {
262 FREE(astb.astli.stg_base);
263 astb.astli.stg_avail = astb.astli.stg_size = 0;
264 }
265 if (astb.argt.stg_base) {
266 FREE(astb.argt.stg_base);
267 astb.argt.stg_avail = astb.argt.stg_size = 0;
268 }
269 if (astb.comstr.stg_base) {
270 FREE(astb.comstr.stg_base);
271 astb.comstr.stg_avail = astb.comstr.stg_size = 0;
272 }
273 } /* ast_fini */
274
275 int
new_node(int type)276 new_node(int type)
277 {
278 int nd;
279
280 nd = STG_NEXT(astb);
281 if (nd > MAXAST || astb.stg_base == NULL)
282 errfatal(7);
283 A_TYPEP(nd, type);
284 return nd;
285 }
286
287 #define ADD_NODE(nd, a, hashval) \
288 (nd) = new_node(a); \
289 A_HSHLKP((nd), astb.hshtb[hashval]); \
290 astb.hshtb[hashval] = (nd)
291
292 /* not used
293 #define HSH_0(a) hash_val(a, -1, -1, -1, -1)
294 #define HSH_1(a,o1) hash_val(a, o1, -1, -1, -1)
295 */
296 #define HSH_2(a, o1, o2) hash_val(a, o1, o2, -1, -1)
297 #define HSH_3(a, o1, o2, o3) hash_val(a, o1, o2, o3, -1)
298 #define HSH_4(a, o1, o2, o3, o4) hash_val(a, o1, o2, o3, o4)
299
300 static INT
hash_val(int a,int hw3,int hw4,int hw5,int hw6)301 hash_val(int a, int hw3, int hw4, int hw5, int hw6)
302 {
303 INT hashval;
304
305 hashval = a;
306 if (hw3 > 0)
307 hashval ^= hw3 >> 4;
308 if (hw4 > 0)
309 hashval ^= hw4 << 8;
310 if (hw5 > 0)
311 hashval ^= hw5 >> 8;
312 if (hw6 > 0)
313 hashval ^= hw6 << 16;
314 hashval &= 0x7fffffff;
315 hashval %= HSHSZ;
316 return hashval;
317 }
318
319 /* hash an ast with dtype & sptr (A_ID, A_CNST, A_LABEL) */
320 static int
hash_sym(int a,DTYPE dtype,int sptr)321 hash_sym(int a, DTYPE dtype, int sptr)
322 {
323 INT hashval;
324 int nd;
325
326 hashval = HSH_2(a, dtype, sptr);
327 for (nd = astb.hshtb[hashval]; nd != 0; nd = A_HSHLKG(nd)) {
328 if (a == A_TYPEG(nd) && dtype == A_DTYPEG(nd) && sptr == A_SPTRG(nd))
329 return nd;
330 }
331 ADD_NODE(nd, a, hashval);
332 if (dtype)
333 A_DTYPEP(nd, dtype);
334 A_SPTRP(nd, sptr);
335 return nd;
336 }
337
338 /* hash an A_UNOP ast */
339 static int
hash_unop(int a,DTYPE dtype,int lop,int optype)340 hash_unop(int a, DTYPE dtype, int lop, int optype)
341 {
342 INT hashval;
343 int nd;
344
345 hashval = HSH_3(a, dtype, lop, optype);
346 for (nd = astb.hshtb[hashval]; nd != 0; nd = A_HSHLKG(nd)) {
347 if (a == A_TYPEG(nd) && dtype == A_DTYPEG(nd) && lop == A_LOPG(nd) &&
348 optype == A_OPTYPEG(nd))
349 return nd;
350 }
351 ADD_NODE(nd, a, hashval);
352 A_DTYPEP(nd, dtype);
353 A_LOPP(nd, lop);
354 A_OPTYPEP(nd, optype);
355 return nd;
356 }
357
358 /* hash an A_BINOP op ast */
359 static int
hash_binop(int a,DTYPE dtype,int lop,int optype,int rop)360 hash_binop(int a, DTYPE dtype, int lop, int optype, int rop)
361 {
362 INT hashval;
363 int nd;
364
365 hashval = HSH_4(a, dtype, lop, optype, rop);
366 for (nd = astb.hshtb[hashval]; nd != 0; nd = A_HSHLKG(nd)) {
367 if (a == A_TYPEG(nd) && dtype == A_DTYPEG(nd) && lop == A_LOPG(nd) &&
368 optype == A_OPTYPEG(nd) && rop == A_ROPG(nd))
369 return nd;
370 }
371 ADD_NODE(nd, a, hashval);
372 A_DTYPEP(nd, dtype);
373 A_LOPP(nd, lop);
374 A_OPTYPEP(nd, optype);
375 A_ROPP(nd, rop);
376 return nd;
377 }
378
379 /* hash an A_PAREN ast */
380 static int
hash_paren(int a,DTYPE dtype,int lop)381 hash_paren(int a, DTYPE dtype, int lop)
382 {
383 INT hashval;
384 int nd;
385
386 hashval = HSH_2(a, dtype, lop);
387 for (nd = astb.hshtb[hashval]; nd != 0; nd = A_HSHLKG(nd)) {
388 if (a == A_TYPEG(nd) && dtype == A_DTYPEG(nd) && lop == A_LOPG(nd))
389 return nd;
390 }
391 ADD_NODE(nd, a, hashval);
392 A_DTYPEP(nd, dtype);
393 A_LOPP(nd, lop);
394 return nd;
395 }
396
397 /* hash an A_CONV ast */
398 static int
hash_conv(int a,DTYPE dtype,int lop,int shd)399 hash_conv(int a, DTYPE dtype, int lop, int shd)
400 {
401 INT hashval;
402 int nd;
403
404 hashval = HSH_3(a, dtype, lop, shd);
405 for (nd = astb.hshtb[hashval]; nd != 0; nd = A_HSHLKG(nd)) {
406 if (a == A_TYPEG(nd) && dtype == A_DTYPEG(nd) && lop == A_LOPG(nd) &&
407 (!shd || shd == A_SHAPEG(nd)))
408 return nd;
409 }
410 ADD_NODE(nd, a, hashval);
411 A_DTYPEP(nd, dtype);
412 A_LOPP(nd, lop);
413 return nd;
414 }
415
416 /* hash an A_SUBSCR ast */
417 static int
hash_subscr(int a,DTYPE dtype,int lop,int asd)418 hash_subscr(int a, DTYPE dtype, int lop, int asd)
419 {
420 INT hashval;
421 int nd;
422
423 hashval = HSH_3(a, dtype, lop, asd);
424 for (nd = astb.hshtb[hashval]; nd != 0; nd = A_HSHLKG(nd)) {
425 if (a == A_TYPEG(nd) && dtype == A_DTYPEG(nd) && lop == A_LOPG(nd) &&
426 asd == A_ASDG(nd))
427 return nd;
428 }
429 ADD_NODE(nd, a, hashval);
430 A_DTYPEP(nd, dtype);
431 A_LOPP(nd, lop);
432 A_ASDP(nd, asd);
433 return nd;
434 }
435
436 /* hash an A_MEM ast */
437 static int
hash_mem(int a,DTYPE dtype,int parent,int mem)438 hash_mem(int a, DTYPE dtype, int parent, int mem)
439 {
440 INT hashval;
441 int nd;
442
443 hashval = HSH_3(a, dtype, parent, mem);
444 for (nd = astb.hshtb[hashval]; nd != 0; nd = A_HSHLKG(nd)) {
445 if (a == A_TYPEG(nd) && dtype == A_DTYPEG(nd) && parent == A_PARENTG(nd) &&
446 mem == A_MEMG(nd))
447 return nd;
448 }
449 ADD_NODE(nd, a, hashval);
450 A_DTYPEP(nd, dtype);
451 A_PARENTP(nd, parent);
452 A_MEMP(nd, mem);
453 return nd;
454 }
455
456 /* hash an A_CMPLXC ast */
457 static int
hash_cmplxc(int a,DTYPE dtype,int lop,int rop)458 hash_cmplxc(int a, DTYPE dtype, int lop, int rop)
459 {
460 INT hashval;
461 int nd;
462
463 hashval = HSH_3(a, dtype, lop, rop);
464 for (nd = astb.hshtb[hashval]; nd != 0; nd = A_HSHLKG(nd)) {
465 if (a == A_TYPEG(nd) && dtype == A_DTYPEG(nd) && lop == A_LOPG(nd) &&
466 rop == A_ROPG(nd))
467 return nd;
468 }
469 ADD_NODE(nd, a, hashval);
470 A_DTYPEP(nd, dtype);
471 A_LOPP(nd, lop);
472 A_ROPP(nd, rop);
473 return nd;
474 }
475
476 /* hash an A_TRIPLE ast */
477 static int
hash_triple(int a,int lb,int ub,int stride)478 hash_triple(int a, int lb, int ub, int stride)
479 {
480 INT hashval;
481 int nd;
482
483 hashval = HSH_3(a, lb, ub, stride);
484 for (nd = astb.hshtb[hashval]; nd != 0; nd = A_HSHLKG(nd)) {
485 if (a == A_TYPEG(nd) && lb == A_LBDG(nd) && ub == A_UPBDG(nd) &&
486 stride == A_STRIDEG(nd))
487 return nd;
488 }
489 ADD_NODE(nd, a, hashval);
490 A_LBDP(nd, lb);
491 A_UPBDP(nd, ub);
492 A_STRIDEP(nd, stride);
493 return nd;
494 }
495
496 /* hash an A_SUBSTR ast */
497 static int
hash_substr(int a,DTYPE dtype,int lop,int left,int right)498 hash_substr(int a, DTYPE dtype, int lop, int left, int right)
499 {
500 INT hashval;
501 int nd;
502
503 hashval = HSH_4(a, dtype, lop, left, right);
504 for (nd = astb.hshtb[hashval]; nd != 0; nd = A_HSHLKG(nd)) {
505 if (a == A_TYPEG(nd) && dtype == A_DTYPEG(nd) && lop == A_LOPG(nd) &&
506 left == A_LEFTG(nd) && right == A_RIGHTG(nd))
507 return nd;
508 }
509 ADD_NODE(nd, a, hashval);
510 A_DTYPEP(nd, dtype);
511 A_LOPP(nd, lop);
512 A_LEFTP(nd, left);
513 A_RIGHTP(nd, right);
514 return nd;
515 }
516
517 int
mk_id(int id)518 mk_id(int id)
519 {
520 int ast = mk_id_noshape(id);
521 if (A_SHAPEG(ast) == 0)
522 A_SHAPEP(ast, mkshape(DTYPEG(id)));
523 return ast;
524 }
525
526 int
mk_id_noshape(int id)527 mk_id_noshape(int id)
528 {
529 if (id <= NOSYM || id >= stb.stg_avail) {
530 interr("mk_id: invalid symbol table index", id, ERR_Severe);
531 }
532 return hash_sym(A_ID, DTYPEG(id), id); /* defer shape to later */
533 }
534
535 int
mk_init(int left,DTYPE dtype)536 mk_init(int left, DTYPE dtype)
537 {
538 int ast;
539 ast = new_node(A_INIT);
540 A_DTYPEP(ast, dtype);
541 A_LEFTP(ast, left);
542 return ast;
543 } /* mk_init */
544
545 int
mk_atomic(int stmt_type,int left,int right,DTYPE dtype)546 mk_atomic(int stmt_type, int left, int right, DTYPE dtype)
547 {
548 int ast;
549 ast = new_node(stmt_type);
550 A_DTYPEP(ast, dtype);
551 A_LOPP(ast, left);
552 A_ROPP(ast, right);
553 return ast;
554 } /* mk_atomic */
555
556 /** \brief Make a constant AST given a constant symbol table pointer
557 */
558 int
mk_cnst(int cnst)559 mk_cnst(int cnst)
560 {
561 int ast;
562
563 ast = hash_sym(A_CNST, DTYPEG(cnst), cnst);
564 A_ALIASP(ast, ast);
565 if (A_SHAPEG(ast) == 0 && DTY(DTYPEG(cnst)) == TY_ARRAY)
566 A_SHAPEP(ast, mkshape((int)DTYPEG(cnst)));
567 return ast;
568 }
569
570 int
mk_cval(INT v,DTYPE dtype)571 mk_cval(INT v, DTYPE dtype)
572 {
573 /* DT_INT may be 4 or 8 bytes, DT_LOG may be 4 or 8 bytes. This
574 * function assumes that DT_INT and DT_LOG are always passed as a
575 * 32-bit value, converts them appropriately if necessary, and
576 * calls the 'real' mk_cval1.
577 */
578 DBLINT64 v1;
579
580 if (DTY(dtype) == TY_INT8) {
581 if (v < 0)
582 v1[0] = -1;
583 else
584 v1[0] = 0;
585 v1[1] = v;
586 return mk_cval1(getcon(v1, DT_INT8), DT_INT8);
587 }
588 if (DTY(dtype) == TY_LOG8) {
589 if (v < 0)
590 v1[0] = -1;
591 else
592 v1[0] = 0;
593 v1[1] = v;
594 return mk_cval1(getcon(v1, DT_LOG8), DT_LOG8);
595 }
596 return mk_cval1(v, dtype);
597 }
598
599 int
mk_isz_cval(ISZ_T v,DTYPE dtype)600 mk_isz_cval(ISZ_T v, DTYPE dtype)
601 {
602 if (dtype == DT_INT8) {
603 DBLINT64 num;
604
605 ISZ_2_INT64(v, num);
606 return mk_cval1(getcon(num, DT_INT8), DT_INT8);
607 }
608 return mk_cval(v, dtype);
609 }
610
611 int
mk_fake_iostat()612 mk_fake_iostat()
613 {
614 return mk_id(get_temp(astb.bnd.dtype));
615 }
616
617 /** \brief Make a constant AST given the actual (single word) value or
618 a constant symbol table pointer; determined by data type.
619 */
620 int
mk_cval1(INT v,DTYPE dtype)621 mk_cval1(INT v, DTYPE dtype)
622 {
623 int cnst;
624 static INT val[2];
625 int ast;
626
627 switch (DTY(dtype)) {
628 case TY_WORD:
629 case TY_INT:
630 case TY_LOG:
631 case TY_REAL:
632 case TY_SINT:
633 case TY_BINT:
634 case TY_SLOG:
635 case TY_BLOG:
636 if (v < 0)
637 val[0] = -1;
638 else
639 val[0] = 0;
640 val[1] = v;
641 cnst = getcon(val, dtype);
642 break;
643
644 case TY_INT8:
645 case TY_LOG8:
646 case TY_DBLE:
647 case TY_DWORD:
648 case TY_CMPLX:
649 case TY_DCMPLX:
650 case TY_NCHAR:
651 case TY_HOLL:
652 case TY_CHAR:
653 cnst = v;
654 break;
655
656 case TY_PTR:
657 interr("mk_cval1:ptr v", dtype, 3);
658 break;
659
660 default:
661 interr("mk_cval1:baddtype", dtype, 1);
662 }
663
664 ast = hash_sym(A_CNST, dtype, cnst);
665 A_ALIASP(ast, ast);
666
667 if (A_SHAPEG(ast) == 0 && DTY(dtype) == TY_ARRAY)
668 A_SHAPEP(ast, mkshape(dtype));
669 return ast;
670 }
671
672 /** \brief Create an alias of ast if it isn't a constant AST.
673 Its alias field will be set to the ast 'a_cnst'.
674 */
675 void
mk_alias(int ast,int a_cnst)676 mk_alias(int ast, int a_cnst)
677 {
678 if (A_TYPEG(ast) != A_CNST)
679 A_ALIASP(ast, a_cnst);
680 }
681
682 int
mk_label(int lab)683 mk_label(int lab)
684 {
685 return hash_sym(A_LABEL, 0, lab);
686 }
687
688 int
mk_binop(int optype,int lop,int rop,DTYPE dtype)689 mk_binop(int optype, int lop, int rop, DTYPE dtype)
690 {
691 int ast;
692 int tmp;
693 int ncons;
694 LOGICAL commutable;
695 INT v1, v2;
696 int c1, c2;
697 DBLINT64 inum1, inum2;
698
699 #if DEBUG
700 if (A_TYPEG(lop) == A_TRIPLE || A_TYPEG(rop) == A_TRIPLE) {
701 interr("mk_binop: trying to operate on a triplet", optype, 3);
702 }
703 #endif
704 switch (optype) {
705 case OP_ADD:
706 case OP_SUB:
707 case OP_MUL:
708 case OP_DIV:
709 if (DTY(dtype) == TY_INT8 || DTY(dtype) == TY_LOG8) {
710 lop = convert_int(lop, dtype);
711 rop = convert_int(rop, dtype);
712 }
713 break;
714 case OP_XTOI:
715 if (DTY(dtype) == TY_INT8 || DTY(dtype) == TY_LOG8) {
716 lop = convert_int(lop, dtype);
717 }
718 default:
719 break;
720 }
721 c1 = c2 = ncons = 0;
722 commutable = FALSE;
723 switch (optype) {
724 case OP_MUL:
725 case OP_ADD:
726 case OP_LEQV:
727 case OP_LNEQV:
728 case OP_LOR:
729 case OP_LAND:
730 commutable = TRUE;
731 /***** fall through *****/
732 default:
733 if (A_TYPEG(lop) == A_CNST) {
734 ncons = 1;
735 c1 = A_SPTRG(lop);
736 }
737 if (A_TYPEG(rop) == A_CNST) {
738 ncons |= 2;
739 c2 = A_SPTRG(rop);
740 }
741 if (commutable) {
742 if (ncons == 1) {
743 /*
744 * make the left constant the right operand; note that for OP_LOR and
745 * OP_LAND, 'folding' only examines the right operand.
746 */
747 tmp = lop;
748 lop = rop;
749 rop = tmp;
750 c2 = c1;
751 c1 = 0;
752 } else if (ncons == 0 && lop > rop) {
753 tmp = lop;
754 lop = rop;
755 rop = tmp;
756 }
757 }
758 break;
759 }
760
761 if (ncons != 0 && DT_ISINT(dtype))
762 switch (DTY(dtype)) {
763 case TY_INT8:
764 case TY_LOG8:
765 switch (optype) {
766 case OP_MUL:
767 if (c2 == stb.k1)
768 return lop;
769 if (!A_CALLFGG(lop) && c2 == stb.k0)
770 return mk_cnst(stb.k0);
771 if (ncons == 3) {
772 v1 = const_fold(OP_MUL, c1, c2, dtype);
773 return mk_cnst(v1);
774 }
775 break;
776 case OP_ADD:
777 if (c2 == stb.k0)
778 return lop;
779 if (ncons & 2) {
780 ast = reduce_i8add(lop, c2);
781 if (ast)
782 return ast;
783 inum1[0] = CONVAL1G(c2);
784 inum1[1] = CONVAL2G(c2);
785 inum2[0] = 0;
786 inum2[1] = 0;
787 if (MIN_INT64(inum1))
788 break;
789 if (cmp64(inum1, inum2) < 0) {
790 c2 = negate_const(c2, DT_INT8);
791 rop = mk_cnst(c2);
792 optype = OP_SUB;
793 }
794 }
795 break;
796 case OP_SUB:
797 if (ncons == 1) {
798 if (c1 == stb.k0)
799 return mk_unop(OP_SUB, rop, dtype);
800 break;
801 }
802 /* the second operand is a constant; the first operand may be a
803 * constant.
804 */
805 if (c2 == stb.k0)
806 return lop;
807 inum1[0] = CONVAL1G(c2);
808 inum1[1] = CONVAL2G(c2);
809 if (MIN_INT64(inum1))
810 break;
811 tmp = negate_const(c2, DT_INT8);
812 ast = reduce_i8add(lop, tmp);
813 if (ast)
814 return ast;
815 inum2[0] = 0;
816 inum2[1] = 0;
817 if (cmp64(inum1, inum2) < 0) {
818 c2 = negate_const(c2, DT_INT8);
819 rop = mk_cnst(c2);
820 optype = OP_ADD;
821 }
822 break;
823 case OP_DIV:
824 if (!A_CALLFGG(rop) && c1 == stb.k0)
825 return mk_cnst(stb.k0);
826 if (c2 == stb.k1)
827 return lop;
828 if (ncons == 3) {
829 v1 = const_fold(OP_DIV, c1, c2, dtype);
830 return mk_cnst(v1);
831 }
832 break;
833 case OP_XTOI:
834 if (c2 == stb.k1)
835 return lop;
836 if (!A_CALLFGG(lop) && c2 == stb.k0)
837 return mk_cnst(stb.k1);
838 if (!A_CALLFGG(rop)) {
839 if (c1 == stb.k0)
840 return mk_cnst(stb.k0);
841 if (c1 == stb.k1)
842 return mk_cnst(stb.k1);
843 }
844 break;
845 default:
846 break;
847 }
848 break;
849
850 default:
851 switch (optype) {
852 case OP_MUL:
853 if (rop == astb.i1)
854 return lop;
855 if (!A_CALLFGG(lop) && rop == astb.i0)
856 return astb.i0;
857 if (ncons == 3) {
858 v1 = CONVAL2G(A_SPTRG(lop));
859 v2 = CONVAL2G(A_SPTRG(rop));
860 ast = mk_cval(v1 * v2, DT_INT);
861 return ast;
862 }
863 break;
864 case OP_ADD:
865 v2 = CONVAL2G(A_SPTRG(rop));
866 if (v2 == 0)
867 return lop;
868 if (ncons & 2) {
869 ast = reduce_iadd(lop, v2);
870 if (ast)
871 return ast;
872 if (v2 == 0x80000000)
873 break;
874 if (v2 < 0) {
875 rop = mk_cval(-v2, DT_INT);
876 optype = OP_SUB;
877 }
878 }
879 break;
880 case OP_SUB:
881 if (ncons == 1) {
882 if (lop == astb.i0)
883 return mk_unop(OP_SUB, rop, DT_INT);
884 break;
885 }
886 /* the second operand is a constant; the first operand may be a
887 * constant.
888 */
889 v2 = CONVAL2G(A_SPTRG(rop));
890 if (v2 == 0)
891 return lop;
892 if (v2 == 0x80000000)
893 break;
894 ast = reduce_iadd(lop, -v2);
895 if (ast)
896 return ast;
897 if (v2 < 0) {
898 rop = mk_cval(-v2, DT_INT);
899 optype = OP_ADD;
900 }
901 break;
902 case OP_DIV:
903 if (!A_CALLFGG(rop) && lop == astb.i0)
904 return astb.i0;
905 if (rop == astb.i1)
906 return lop;
907 if (ncons == 3) {
908 v1 = CONVAL2G(A_SPTRG(lop));
909 v2 = CONVAL2G(A_SPTRG(rop));
910 if (v2 == 0)
911 break;
912 ast = mk_cval(v1 / v2, DT_INT);
913 return ast;
914 }
915 break;
916 case OP_XTOI:
917 if (rop == astb.i1)
918 return lop;
919 if (!A_CALLFGG(lop) && rop == astb.i0)
920 return astb.i1;
921 if (!A_CALLFGG(rop)) {
922 if (lop == astb.i0)
923 return astb.i0;
924 if (lop == astb.i1)
925 return astb.i1;
926 }
927 if (ncons == 3) {
928 INT v;
929 v1 = CONVAL2G(A_SPTRG(lop));
930 v2 = CONVAL2G(A_SPTRG(rop));
931 if (v2 < 0)
932 return astb.i0;
933 v = v1;
934 while (--v2 > 0)
935 v *= v1;
936 ast = mk_cval(v, DT_INT);
937 return ast;
938 }
939 break;
940 case OP_LAND:
941 v2 = CONVAL2G(A_SPTRG(rop));
942 if (v2 == 0)
943 return rop; /* something .and. .false. is .false */
944 return lop; /* something .and. .true. is something */
945 break;
946 case OP_LOR:
947 v2 = CONVAL2G(A_SPTRG(rop));
948 if (v2 != 0)
949 return rop; /* something .or. .true. is .true */
950 return lop; /* something .or. .false. is something */
951 break;
952 default:
953 break;
954 }
955 break;
956 }
957
958 if (DT_ISINT(dtype))
959 switch (optype) {
960 case OP_SUB:
961 if (A_CALLFGG(rop))
962 break;
963 if (lop == rop) {
964 switch (DTY(dtype)) {
965 case TY_INT8:
966 case TY_LOG8:
967 return mk_cnst(stb.k0);
968 default:
969 return astb.i0;
970 }
971 } else if (A_DTYPEG(lop) == A_DTYPEG(rop) && A_TYPEG(lop) == A_BINOP &&
972 A_OPTYPEG(lop) == OP_ADD) {
973 if (A_LOPG(lop) == rop) {
974 return A_ROPG(lop);
975 } else if (A_ROPG(lop) == rop) {
976 return A_LOPG(lop);
977 }
978 }
979 break;
980 case OP_DIV:
981 if (A_CALLFGG(rop))
982 break;
983 if (lop == rop)
984 switch (DTY(dtype)) {
985 case TY_INT8:
986 case TY_LOG8:
987 return mk_cnst(stb.k1);
988 default:
989 return astb.i1;
990 }
991 break;
992 default:
993 break;
994 }
995
996 ast = hash_binop(A_BINOP, dtype, lop, optype, rop);
997 A_CALLFGP(ast, A_CALLFGG(lop) | A_CALLFGG(rop));
998 A_SHAPEP(ast, A_SHAPEG(lop));
999 return ast;
1000 }
1001
1002 /* ast of left of '+' */
1003 /* value of constant */
1004 static int
reduce_iadd(int opnd,INT con)1005 reduce_iadd(int opnd, INT con)
1006 {
1007 int new;
1008 INT v1;
1009 int lop, rop;
1010 int tmp;
1011
1012 #if DEBUG
1013 assert(opnd, "reduce_iadd:opnd is 0", con, 3);
1014 #endif
1015
1016 switch (A_TYPEG(opnd)) {
1017 case A_CNST:
1018 v1 = CONVAL2G(A_SPTRG(opnd));
1019 new = mk_cval(v1 + con, DT_INT);
1020 return new;
1021
1022 case A_BINOP:
1023 switch (A_OPTYPEG(opnd)) {
1024 case OP_ADD:
1025 lop = A_LOPG(opnd);
1026 rop = A_ROPG(opnd);
1027 new = reduce_iadd(rop, con);
1028 if (new) {
1029 if (new == astb.i0)
1030 return lop;
1031 if (A_TYPEG(new) == A_CNST) {
1032 v1 = CONVAL2G(A_SPTRG(new));
1033 if (v1 < 0 && v1 != 0x80000000) {
1034 new = mk_cval(-v1, DT_INT);
1035 new = hash_binop(A_BINOP, DT_INT, lop, OP_SUB, new);
1036 A_CALLFGP(new, A_CALLFGG(lop));
1037 A_SHAPEP(new, 0);
1038 return new;
1039 }
1040 } else if (lop > new) {
1041 tmp = lop;
1042 lop = new;
1043 new = tmp;
1044 }
1045 new = hash_binop(A_BINOP, DT_INT, lop, OP_ADD, new);
1046 A_CALLFGP(new, A_CALLFGG(lop) | A_CALLFGG(new));
1047 A_SHAPEP(new, 0);
1048 return new;
1049 }
1050 new = reduce_iadd(lop, con);
1051 if (new) {
1052 if (A_TYPEG(new) != A_CNST && (A_TYPEG(rop) == A_CNST || rop > new)) {
1053 tmp = rop;
1054 rop = new;
1055 new = tmp;
1056 }
1057 new = hash_binop(A_BINOP, DT_INT, rop, OP_ADD, new);
1058 A_CALLFGP(new, A_CALLFGG(rop) | A_CALLFGG(new));
1059 A_SHAPEP(new, 0);
1060 return new;
1061 }
1062 break;
1063 case OP_SUB:
1064 lop = A_LOPG(opnd);
1065 rop = A_ROPG(opnd);
1066 new = reduce_iadd(lop, con);
1067 if (new) {
1068 if (A_TYPEG(new) == A_CNST && new == astb.i0) {
1069 new = mk_unop(OP_SUB, rop, DT_INT);
1070 return new;
1071 }
1072 new = hash_binop(A_BINOP, DT_INT, new, OP_SUB, rop);
1073 A_CALLFGP(new, A_CALLFGG(new) | A_CALLFGG(rop));
1074 A_SHAPEP(new, 0);
1075 return new;
1076 }
1077 if (con == 0x80000000)
1078 break;
1079 new = reduce_iadd(rop, -con);
1080 if (new) {
1081 if (new == astb.i0)
1082 return lop;
1083 if (A_TYPEG(new) == A_CNST) {
1084 v1 = CONVAL2G(A_SPTRG(new));
1085 if (v1 < 0 && v1 != 0x80000000) {
1086 new = mk_cval(-v1, DT_INT);
1087 new = hash_binop(A_BINOP, DT_INT, lop, OP_ADD, new);
1088 A_CALLFGP(new, A_CALLFGG(lop));
1089 A_SHAPEP(new, 0);
1090 return new;
1091 }
1092 }
1093 new = hash_binop(A_BINOP, DT_INT, lop, OP_SUB, new);
1094 A_CALLFGP(new, A_CALLFGG(lop) | A_CALLFGG(new));
1095 A_SHAPEP(new, 0);
1096 return new;
1097 }
1098 break;
1099 }
1100 break;
1101 default:
1102 break;
1103 }
1104
1105 return 0;
1106 }
1107
1108 /* ast of left of '+' */
1109 /* value of constant, a symbol table pointer */
1110 static int
reduce_i8add(int opnd,int con_st)1111 reduce_i8add(int opnd, int con_st)
1112 {
1113 int new;
1114 int c1;
1115 int lop, rop;
1116 int tmp;
1117 DBLINT64 inum1, inum2;
1118
1119 #if DEBUG
1120 assert(opnd, "reduce_i8add:opnd is 0", con_st, 3);
1121 #endif
1122
1123 switch (A_TYPEG(opnd)) {
1124 case A_CNST:
1125 c1 = const_fold(OP_ADD, A_SPTRG(opnd), con_st, DT_INT8);
1126 new = mk_cnst(c1);
1127 return new;
1128
1129 case A_BINOP:
1130 switch (A_OPTYPEG(opnd)) {
1131 case OP_ADD:
1132 lop = A_LOPG(opnd);
1133 rop = A_ROPG(opnd);
1134 new = reduce_i8add(rop, con_st);
1135 if (new) {
1136 if (A_TYPEG(new) == A_CNST) {
1137 c1 = A_SPTRG(new);
1138 if (c1 == stb.k0)
1139 return lop;
1140 inum1[0] = CONVAL1G(c1);
1141 inum1[1] = CONVAL2G(c1);
1142 inum2[0] = 0;
1143 inum2[1] = 0;
1144 if (!MIN_INT64(inum1) && cmp64(inum1, inum2) < 0) {
1145 new = negate_const(c1, DT_INT8);
1146 new = mk_cnst(new);
1147 new = hash_binop(A_BINOP, DT_INT8, lop, OP_SUB, new);
1148 A_CALLFGP(new, A_CALLFGG(lop));
1149 A_SHAPEP(new, 0);
1150 return new;
1151 }
1152 } else if (lop > new) {
1153 tmp = lop;
1154 lop = new;
1155 new = tmp;
1156 }
1157 new = hash_binop(A_BINOP, DT_INT8, lop, OP_ADD, new);
1158 A_CALLFGP(new, A_CALLFGG(lop) | A_CALLFGG(new));
1159 A_SHAPEP(new, 0);
1160 return new;
1161 }
1162 new = reduce_i8add(lop, con_st);
1163 if (new) {
1164 if (A_TYPEG(new) != A_CNST && (A_TYPEG(rop) == A_CNST || rop > new)) {
1165 tmp = rop;
1166 rop = new;
1167 new = tmp;
1168 }
1169 new = hash_binop(A_BINOP, DT_INT8, rop, OP_ADD, new);
1170 A_CALLFGP(new, A_CALLFGG(rop) | A_CALLFGG(new));
1171 A_SHAPEP(new, 0);
1172 return new;
1173 }
1174 break;
1175 case OP_SUB:
1176 lop = A_LOPG(opnd);
1177 rop = A_ROPG(opnd);
1178 new = reduce_i8add(lop, con_st);
1179 if (new) {
1180 if (A_TYPEG(new) == A_CNST && A_SPTRG(new) == stb.k0) {
1181 new = mk_unop(OP_SUB, rop, DT_INT8);
1182 return new;
1183 }
1184 new = hash_binop(A_BINOP, DT_INT8, new, OP_SUB, rop);
1185 A_CALLFGP(new, A_CALLFGG(new) | A_CALLFGG(rop));
1186 A_SHAPEP(new, 0);
1187 return new;
1188 }
1189 inum1[0] = CONVAL1G(con_st);
1190 inum1[1] = CONVAL2G(con_st);
1191 if (MIN_INT64(inum1))
1192 break;
1193 c1 = negate_const(con_st, DT_INT8);
1194 new = reduce_i8add(rop, c1);
1195 if (new) {
1196 if (A_TYPEG(new) == A_CNST) {
1197 c1 = A_SPTRG(new);
1198 if (c1 == stb.k0)
1199 return lop;
1200 inum1[0] = CONVAL1G(c1);
1201 inum1[1] = CONVAL2G(c1);
1202 inum2[0] = 0;
1203 inum2[1] = 0;
1204 if (!MIN_INT64(inum1) && cmp64(inum1, inum2) < 0) {
1205 c1 = negate_const(c1, DT_INT8);
1206 new = mk_cnst(c1);
1207 new = hash_binop(A_BINOP, DT_INT8, lop, OP_ADD, new);
1208 A_CALLFGP(new, A_CALLFGG(lop));
1209 A_SHAPEP(new, 0);
1210 return new;
1211 }
1212 }
1213 new = hash_binop(A_BINOP, DT_INT8, lop, OP_SUB, new);
1214 A_CALLFGP(new, A_CALLFGG(lop) | A_CALLFGG(new));
1215 A_SHAPEP(new, 0);
1216 return new;
1217 }
1218 break;
1219 }
1220 break;
1221 default:
1222 break;
1223 }
1224
1225 return 0;
1226 }
1227
1228 int
mk_unop(int optype,int lop,DTYPE dtype)1229 mk_unop(int optype, int lop, DTYPE dtype)
1230 {
1231 int ast;
1232 INT conval;
1233 int shape;
1234
1235 #if DEBUG
1236 if (A_TYPEG(lop) == A_TRIPLE) {
1237 interr("mk_unop: trying to operate on a triplet", optype, 3);
1238 }
1239 #endif
1240 switch (optype) {
1241 case OP_ADD:
1242 case OP_SUB:
1243 case OP_LNOT:
1244 if (DTY(dtype) == TY_INT8 || DTY(dtype) == TY_LOG8) {
1245 lop = convert_int(lop, dtype);
1246 }
1247 break;
1248 default:
1249 break;
1250 }
1251
1252 shape = A_SHAPEG(lop);
1253
1254 switch (optype) {
1255 case OP_ADD:
1256 return lop;
1257
1258 case OP_SUB:
1259 if (A_TYPEG(lop) == A_CNST) {
1260 switch (DTY(dtype)) {
1261 case TY_BINT:
1262 case TY_SINT:
1263 case TY_INT:
1264 case TY_BLOG:
1265 case TY_SLOG:
1266 case TY_LOG:
1267 conval = CONVAL2G(A_SPTRG(lop));
1268 ast = mk_cval(-conval, DT_INT);
1269 break;
1270
1271 case TY_REAL:
1272 conval = A_SPTRG(lop);
1273 if (NMPTRG(conval) != 0)
1274 goto noconstfold;
1275 conval = CONVAL2G(conval);
1276 conval = negate_const(conval, dtype);
1277 ast = mk_cval(conval, dtype);
1278 break;
1279
1280 case TY_DBLE:
1281 case TY_CMPLX:
1282 case TY_DCMPLX:
1283 case TY_INT8:
1284 case TY_LOG8:
1285 conval = A_SPTRG(lop);
1286 if (NMPTRG(conval) != 0)
1287 goto noconstfold;
1288 conval = negate_const(conval, dtype);
1289 ast = mk_cnst((int)conval);
1290 break;
1291
1292 default:
1293 interr("mk_unop-negate: bad dtype", dtype, 3);
1294 ast = astb.i0;
1295 break;
1296 }
1297 return ast;
1298 }
1299 break;
1300
1301 case OP_LOC:
1302 shape = 0;
1303 break;
1304
1305 default:
1306 break;
1307 }
1308
1309 noconstfold:
1310 ast = hash_unop(A_UNOP, dtype, lop, optype);
1311 A_CALLFGP(ast, A_CALLFGG(lop));
1312 A_SHAPEP(ast, shape);
1313 return ast;
1314 }
1315
1316 int
mk_cmplxc(int lop,int rop,DTYPE dtype)1317 mk_cmplxc(int lop, int rop, DTYPE dtype)
1318 {
1319 int ast;
1320
1321 ast = hash_cmplxc(A_CMPLXC, dtype, lop, rop);
1322 if (A_SHAPEG(ast) == 0 && DTY(dtype) == TY_ARRAY)
1323 A_SHAPEP(ast, mkshape(dtype));
1324 return ast;
1325 }
1326
1327 int
mk_paren(int lop,DTYPE dtype)1328 mk_paren(int lop, DTYPE dtype)
1329 {
1330 int ast;
1331 ast = hash_paren(A_PAREN, dtype, lop);
1332 A_CALLFGP(ast, A_CALLFGG(lop));
1333 A_SHAPEP(ast, A_SHAPEG(lop));
1334
1335 return ast;
1336 }
1337
1338 int
mk_convert(int lop,DTYPE dtype)1339 mk_convert(int lop, DTYPE dtype)
1340 {
1341 int ast;
1342
1343 if (A_TYPEG(lop) == A_CNST) {
1344 ast = convert_cnst(lop, dtype);
1345 if (ast != lop)
1346 return ast;
1347 }
1348 /* don't convert 'lop' */
1349 if (A_TYPEG(lop) == A_TRIPLE)
1350 return lop;
1351 ast = hash_conv(A_CONV, dtype, lop, 0);
1352 if (DTY(dtype) == TY_ARRAY && A_SHAPEG(ast) == 0) {
1353 if (A_SHAPEG(lop))
1354 A_SHAPEP(ast, A_SHAPEG(lop));
1355 else
1356 A_SHAPEP(ast, mkshape(dtype));
1357 }
1358 /* copy the ALIAS field for conversion between integer types */
1359 if (DT_ISINT(dtype) && DT_ISINT(A_DTYPEG(lop))) {
1360 A_ALIASP(ast, A_ALIASG(lop));
1361 }
1362 A_CALLFGP(ast, A_CALLFGG(lop));
1363 return ast;
1364 }
1365
1366 /* Generate a convert of ast to dtype if it isn't the right type already. */
1367 int
convert_int(int ast,DTYPE dtype)1368 convert_int(int ast, DTYPE dtype)
1369 {
1370 if (A_DTYPEG(ast) == dtype)
1371 return ast;
1372 return mk_convert(ast, dtype);
1373 }
1374
1375 static int
convert_cnst(int cnst,int newtyp)1376 convert_cnst(int cnst, int newtyp)
1377 {
1378 INT oldval;
1379 int oldtyp;
1380 int to, from;
1381 int sptr;
1382 INT num[4], result;
1383 INT num1[8];
1384 INT num2[4];
1385 UINT unum[4];
1386 int q0;
1387
1388 oldtyp = A_DTYPEG(cnst);
1389 if (newtyp == oldtyp)
1390 return cnst;
1391 to = DTY(newtyp);
1392 from = DTY(oldtyp);
1393
1394 if (!TY_ISSCALAR(to) || !TY_ISSCALAR(from))
1395 return cnst;
1396
1397 sptr = A_SPTRG(cnst);
1398
1399 /* switch statement falls thru to call_mk_cval1 */
1400 switch (to) {
1401 default:
1402 /* TY_CHAR & TY_NCHAR: the lengths are not always precise */
1403 return cnst;
1404 case TY_WORD:
1405 result = CONVAL2G(sptr);
1406 break;
1407 case TY_DWORD:
1408 if (size_of(from) >= size_of(to)) {
1409 num[0] = CONVAL1G(sptr);
1410 num[1] = CONVAL2G(sptr);
1411 } else {
1412 num[1] = CONVAL2G(sptr);
1413 num[0] = (TY_ISINT(from) && num[1] < 0) ? -1 : 0;
1414 }
1415 result = getcon(num, newtyp);
1416 break;
1417 case TY_BLOG:
1418 case TY_BINT:
1419 switch (from) {
1420 case TY_WORD:
1421 case TY_DWORD:
1422 if (to == TY_BLOG)
1423 return cnst; /* don't convert typeless for now */
1424 case TY_BLOG:
1425 case TY_SLOG:
1426 case TY_LOG:
1427 case TY_LOG8:
1428 case TY_BINT:
1429 case TY_SINT:
1430 case TY_INT:
1431 case TY_INT8:
1432 oldval = CONVAL2G(sptr);
1433 result = sign_extend(oldval, 8);
1434 break;
1435 default:
1436 goto other_int_cases;
1437 }
1438 break;
1439 case TY_SLOG:
1440 case TY_SINT:
1441 switch (from) {
1442 case TY_WORD:
1443 case TY_DWORD:
1444 if (to == TY_SLOG)
1445 return cnst; /* don't convert typeless for now */
1446 case TY_BINT:
1447 case TY_SINT:
1448 case TY_INT:
1449 case TY_INT8:
1450 case TY_BLOG:
1451 case TY_SLOG:
1452 case TY_LOG:
1453 case TY_LOG8:
1454 oldval = CONVAL2G(sptr);
1455 result = sign_extend(oldval, 16);
1456 break;
1457 default:
1458 goto other_int_cases;
1459 }
1460 break;
1461 case TY_LOG:
1462 case TY_INT:
1463 switch (from) {
1464 case TY_WORD:
1465 case TY_DWORD:
1466 if (to == TY_LOG)
1467 return cnst; /* don't convert typeless for now */
1468 case TY_BINT:
1469 case TY_SINT:
1470 case TY_INT:
1471 case TY_BLOG:
1472 case TY_SLOG:
1473 case TY_LOG:
1474 result = CONVAL2G(sptr);
1475 break;
1476 case TY_INT8:
1477 case TY_LOG8:
1478 result = sign_extend(CONVAL2G(sptr), 32);
1479 break;
1480 default:
1481 goto other_int_cases;
1482 }
1483 break;
1484 other_int_cases:
1485 switch (from) {
1486 case TY_CMPLX:
1487 oldval = CONVAL1G(sptr);
1488 xfix(oldval, &result);
1489 break;
1490 case TY_REAL:
1491 oldval = CONVAL2G(sptr);
1492 xfix(oldval, &result);
1493 break;
1494 case TY_DCMPLX:
1495 sptr = CONVAL1G(sptr);
1496 case TY_DBLE:
1497 num[0] = CONVAL1G(sptr);
1498 num[1] = CONVAL2G(sptr);
1499 xdfix(num, &result);
1500 break;
1501 default: /* TY_HOLL, TY_CHAR, TY_NCHAR */
1502 return cnst;
1503 }
1504 break;
1505
1506 case TY_LOG8:
1507 case TY_INT8:
1508 if (from == TY_DWORD || from == TY_INT8 || from == TY_LOG8) {
1509 if (to == TY_LOG8)
1510 return cnst; /* don't convert typeless for now */
1511 num[0] = CONVAL1G(sptr);
1512 num[1] = CONVAL2G(sptr);
1513 } else if (from == TY_WORD) {
1514 if (to == TY_LOG8)
1515 return cnst; /* don't convert typeless for now */
1516 num[0] = 0;
1517 unum[1] = CONVAL2G(sptr);
1518 num[1] = unum[1];
1519 } else if (TY_ISINT(from)) {
1520 oldval = CONVAL2G(sptr);
1521 if (oldval < 0) {
1522 num[0] = -1;
1523 num[1] = oldval;
1524 } else {
1525 num[0] = 0;
1526 num[1] = oldval;
1527 }
1528 } else {
1529 switch (from) {
1530 case TY_CMPLX:
1531 oldval = CONVAL1G(sptr);
1532 xfix64(oldval, num);
1533 break;
1534 case TY_REAL:
1535 oldval = CONVAL2G(sptr);
1536 xfix64(oldval, num);
1537 break;
1538 case TY_DCMPLX:
1539 sptr = CONVAL1G(sptr);
1540 case TY_DBLE:
1541 num1[0] = CONVAL1G(sptr);
1542 num1[1] = CONVAL2G(sptr);
1543 xdfix64(num1, num);
1544 break;
1545 default: /* TY_HOLL, TY_CHAR, TY_NCHAR */
1546 return cnst;
1547 }
1548 }
1549 result = getcon(num, newtyp);
1550 break;
1551
1552 case TY_REAL:
1553 if (from == TY_WORD || from == TY_DWORD)
1554 return cnst; /* don't convert typeless for now */
1555 /* result = CONVAL2G(sptr); */
1556 else if (from == TY_INT8 || from == TY_LOG8) {
1557 num[0] = CONVAL1G(sptr);
1558 num[1] = CONVAL2G(sptr);
1559 xflt64(num, &result);
1560 } else if (TY_ISINT(from)) {
1561 oldval = CONVAL2G(sptr);
1562 xffloat(oldval, &result);
1563 } else {
1564 switch (from) {
1565 case TY_CMPLX:
1566 result = CONVAL1G(sptr);
1567 break;
1568 case TY_DCMPLX:
1569 sptr = CONVAL1G(sptr);
1570 case TY_DBLE:
1571 num[0] = CONVAL1G(sptr);
1572 num[1] = CONVAL2G(sptr);
1573 xsngl(num, &result);
1574 break;
1575 default: /* TY_HOLL, TY_CHAR, TY_NCHAR */
1576 return cnst;
1577 }
1578 }
1579 break;
1580
1581 case TY_DBLE:
1582 if (from == TY_WORD) {
1583 return cnst; /* don't convert typeless for now */
1584 /*
1585 num[0] = 0;
1586 num[1] = CONVAL2G(sptr);
1587 */
1588 } else if (from == TY_DWORD) {
1589 return cnst; /* don't convert typeless for now */
1590 /*
1591 num[0] = CONVAL1G(sptr);
1592 num[1] = CONVAL2G(sptr);
1593 */
1594 } else if (from == TY_INT8 || from == TY_LOG8) {
1595 num1[0] = CONVAL1G(sptr);
1596 num1[1] = CONVAL2G(sptr);
1597 xdflt64(num1, num);
1598 } else if (TY_ISINT(from))
1599 xdfloat(CONVAL2G(sptr), num);
1600 else {
1601 /* if a special 'named' constant, don't evaluate */
1602 if ((XBIT(49, 0x400000) || XBIT(51, 0x40)) && NMPTRG(sptr))
1603 return cnst;
1604 switch (from) {
1605 case TY_DCMPLX:
1606 result = CONVAL1G(sptr);
1607 goto call_mk_cval1;
1608 case TY_CMPLX:
1609 oldval = CONVAL1G(sptr);
1610 xdble(oldval, num);
1611 break;
1612 case TY_REAL:
1613 oldval = CONVAL2G(sptr);
1614 xdble(oldval, num);
1615 break;
1616 default: /* TY_HOLL, TY_CHAR, TY_NCHAR */
1617 return cnst;
1618 }
1619 }
1620 result = getcon(num, DT_REAL8);
1621 break;
1622
1623 case TY_CMPLX:
1624 /* num[0] = real part
1625 * num[1] = imaginary part
1626 */
1627 num[1] = 0;
1628 if (from == TY_WORD) {
1629 /* a la VMS */
1630 return cnst; /* don't convert typeless for now */
1631 /*
1632 num[0] = 0;
1633 num[1] = CONVAL2G(sptr);
1634 */
1635 } else if (from == TY_DWORD) {
1636 /* a la VMS */
1637 return cnst; /* don't convert typeless for now */
1638 /*
1639 num[0] = CONVAL1G(sptr);
1640 num[1] = CONVAL2G(sptr);
1641 */
1642 } else if (from == TY_INT8 || from == TY_LOG8) {
1643 num1[0] = CONVAL1G(sptr);
1644 num1[1] = CONVAL2G(sptr);
1645 xflt64(num1, &num[0]);
1646 } else if (TY_ISINT(from))
1647 xffloat(CONVAL2G(sptr), &num[0]);
1648 else {
1649 switch (from) {
1650 case TY_REAL:
1651 num[0] = CONVAL2G(sptr);
1652 break;
1653 case TY_DBLE:
1654 num1[0] = CONVAL1G(sptr);
1655 num1[1] = CONVAL2G(sptr);
1656 xsngl(num1, &num[0]);
1657 break;
1658 case TY_DCMPLX:
1659 num1[0] = CONVAL1G(CONVAL1G(sptr));
1660 num1[1] = CONVAL2G(CONVAL1G(sptr));
1661 xsngl(num1, &num[0]);
1662 num1[0] = CONVAL1G(CONVAL2G(sptr));
1663 num1[1] = CONVAL2G(CONVAL2G(sptr));
1664 xsngl(num1, &num[1]);
1665 break;
1666 default: /* TY_HOLL, TY_CHAR, TY_NCHAR */
1667 return cnst;
1668 }
1669 }
1670 result = getcon(num, DT_CMPLX8);
1671 break;
1672
1673 case TY_DCMPLX:
1674 if (from == TY_WORD) {
1675 return cnst; /* don't convert typeless for now */
1676 /*
1677 num[0] = 0;
1678 num[1] = CONVAL2G(sptr);
1679 num[0] = getcon(num, DT_REAL8);
1680 num[1] = stb.dbl0;
1681 */
1682 } else if (from == TY_DWORD) {
1683 return cnst; /* don't convert typeless for now */
1684 /*
1685 num[0] = CONVAL1G(sptr);
1686 num[1] = CONVAL2G(sptr);
1687 num[0] = getcon(num, DT_REAL8);
1688 num[1] = stb.dbl0;
1689 */
1690 } else if (from == TY_INT8 || from == TY_LOG8) {
1691 num1[0] = CONVAL1G(sptr);
1692 num1[1] = CONVAL2G(sptr);
1693 xdflt64(num1, num);
1694 num[0] = getcon(num, DT_REAL8);
1695 num[1] = stb.dbl0;
1696 } else if (TY_ISINT(from)) {
1697 xdfloat(CONVAL2G(sptr), num);
1698 num[0] = getcon(num, DT_REAL8);
1699 num[1] = stb.dbl0;
1700 } else {
1701 switch (from) {
1702 case TY_REAL:
1703 xdble(CONVAL2G(sptr), num);
1704 num[0] = getcon(num, DT_REAL8);
1705 num[1] = stb.dbl0;
1706 break;
1707 case TY_DBLE:
1708 num[0] = sptr;
1709 num[1] = stb.dbl0;
1710 break;
1711 case TY_CMPLX:
1712 xdble(CONVAL1G(sptr), num1);
1713 num[0] = getcon(num1, DT_REAL8);
1714 xdble(CONVAL2G(sptr), num1);
1715 num[1] = getcon(num1, DT_REAL8);
1716 break;
1717 default: /* TY_HOLL, TY_CHAR, TY_NCHAR */
1718 return cnst;
1719 }
1720 }
1721 result = getcon(num, DT_CMPLX16);
1722 break;
1723
1724 }
1725
1726 call_mk_cval1:
1727 cnst = mk_cval1(result, newtyp);
1728 return cnst;
1729 }
1730
1731 int
mk_promote_scalar(int lop,DTYPE dtype,int shd)1732 mk_promote_scalar(int lop, DTYPE dtype, int shd)
1733 {
1734 int ast = hash_conv(A_CONV, dtype, lop, shd);
1735 A_CALLFGP(ast, A_CALLFGG(lop));
1736 A_SHAPEP(ast, shd);
1737 return ast;
1738 }
1739
1740 int
mk_subscr(int arr,int * subs,int numdim,DTYPE dtype)1741 mk_subscr(int arr, int *subs, int numdim, DTYPE dtype)
1742 {
1743 int asd = mk_asd(subs, numdim);
1744 return mk_subscr_copy(arr, asd, dtype);
1745 }
1746
1747 int
mk_subscr_copy(int arr,int asd,DTYPE dtype)1748 mk_subscr_copy(int arr, int asd, DTYPE dtype)
1749 {
1750 int i;
1751 int ast;
1752 int callfg;
1753 int shape;
1754 int numdim = ASD_NDIM(asd);
1755
1756 assert(arr >= 0 && arr < astb.stg_avail, "mk_subscr_copy: invalid array ast", arr,
1757 ERR_Fatal);
1758 assert(asd >= 0 && asd < astb.asd.stg_avail, "mk_subscr_copy: invalid asd index",
1759 asd, ERR_Fatal);
1760 assert(dtype >= 0 && dtype < stb.dt.stg_avail,
1761 "mk_subscr_copy: invalid dtype index", dtype, ERR_Fatal);
1762
1763 callfg = 0;
1764 for (i = 0; i < numdim; i++) {
1765 callfg |= A_CALLFGG(ASD_SUBS(asd, i));
1766 }
1767
1768 shape = 0;
1769 if (A_TYPEG(arr) == A_MEM) {
1770 int shape_parent = A_SHAPEG(A_PARENTG(arr));
1771 int shape_mem = A_SHAPEG(A_MEMG(arr));
1772 if (shape_parent && shape_mem) {
1773 /* we are subscripting the member, need to use parent's shape */
1774 dtype = dtype_with_shape(dtype, shape_parent);
1775 shape = shape_parent;
1776 }
1777 }
1778
1779 if (shape == 0) { /* not already chosen */
1780 /* see if there should be a shape */
1781 int shape_rank = 0;
1782 int arr_shape = A_SHAPEG(arr); /* shape of array */
1783 for (i = 0; i < numdim; ++i) {
1784 int sub = ASD_SUBS(asd, i);
1785 if (A_TYPEG(sub) == A_TRIPLE || A_SHAPEG(sub))
1786 ++shape_rank;
1787 }
1788 if (shape_rank > 0) {
1789 add_shape_rank(shape_rank);
1790 for (i = 0; i < numdim; ++i) {
1791 int sub = ASD_SUBS(asd, i);
1792 if (A_TYPEG(sub) == A_TRIPLE) {
1793 int lwb = A_LBDG(sub);
1794 int upb = A_UPBDG(sub);
1795 int stride = A_STRIDEG(sub);
1796 if (lwb == 0)
1797 lwb = astb.bnd.one;
1798 if (upb == 0 && arr_shape)
1799 upb = SHD_UPB(arr_shape, i);
1800 if (stride == 0)
1801 stride = astb.bnd.one;
1802 add_shape_spec(lwb, upb, stride);
1803 } else {
1804 int shp = A_SHAPEG(sub);
1805 if (shp != 0) {
1806 /* vector subscript */
1807 add_shape_spec(SHD_LWB(shp, 0), SHD_UPB(shp, 0),
1808 SHD_STRIDE(shp, 0));
1809 }
1810 }
1811 }
1812 shape = mk_shape();
1813 }
1814 }
1815 if (shape == 0) {
1816 dtype = DDTG(dtype);
1817 }
1818 /* In the following case: a%b(i), where a and b are both arrays,
1819 * the input dtype is the type of b(i). It needs to be changed
1820 * to array of b(i). Also, the shape needs to be fixed.
1821 */
1822 ast = hash_subscr(A_SUBSCR, dtype, arr, asd);
1823 A_CALLFGP(ast, callfg | A_CALLFGG(arr));
1824 A_SHAPEP(ast, shape);
1825 if (DT_ISSCALAR(dtype)) {
1826 int al = complex_alias(ast);
1827 if (A_TYPEG(al) == A_INIT)
1828 A_ALIASP(ast, A_LEFTG(al));
1829 }
1830 return ast;
1831 } /* mk_subscr_copy */
1832
1833 /* Find or create an ASD with these subscripts */
1834 int
mk_asd(int * subs,int numdim)1835 mk_asd(int *subs, int numdim)
1836 {
1837 int i;
1838 int asd;
1839 assert(numdim > 0 && numdim <= MAXSUBS, "mk_subscr: bad numdim", numdim,
1840 ERR_Fatal);
1841 /* search the existing ASDs with the same number of dimensions */
1842 for (asd = astb.asd.hash[numdim - 1]; asd != 0; asd = ASD_NEXT(asd)) {
1843 for (i = 0; i < numdim; i++) {
1844 if (subs[i] != ASD_SUBS(asd, i))
1845 goto next_asd;
1846 }
1847 return asd;
1848 next_asd:;
1849 }
1850
1851 /* allocate a new ASD; note that the type ASD allows for one subscript. */
1852 asd = astb.asd.stg_avail;
1853 astb.asd.stg_avail += sizeof(ASD) / sizeof(int) + numdim - 1;
1854 NEED(astb.asd.stg_avail, astb.asd.stg_base, int, astb.asd.stg_size, astb.asd.stg_avail + 240);
1855 ASD_NDIM(asd) = numdim;
1856 ASD_NEXT(asd) = astb.asd.hash[numdim - 1];
1857 astb.asd.hash[numdim - 1] = asd;
1858 for (i = 0; i < numdim; i++) {
1859 int sub = subs[i];
1860 assert(sub > 0, "mk_asd() bad subscript ast at dim", i + 1, ERR_Severe);
1861 ASD_SUBS(asd, i) = sub;
1862 }
1863 return asd;
1864 }
1865
1866 /**
1867 \param lb ast of lower bound
1868 \param ub ast of upper bound
1869 \param stride ast of stride
1870 Any of these asts can be 0
1871 */
1872 int
mk_triple(int lb,int ub,int stride)1873 mk_triple(int lb, int ub, int stride)
1874 {
1875 int ast;
1876 ast = hash_triple(A_TRIPLE, lb, ub, stride);
1877 A_CALLFGP(ast, (lb ? A_CALLFGG(lb) : 0) | (ub ? A_CALLFGG(ub) : 0) |
1878 (stride ? A_CALLFGG(stride) : 0));
1879 return ast;
1880 }
1881
1882 /**
1883 \param chr ast of character item being substring'd
1884 \param left position of leftmost character
1885 \param right position of rightmost character
1886 \param dtype dtype
1887 */
1888 int
mk_substr(int chr,int left,int right,DTYPE dtype)1889 mk_substr(int chr, int left, int right, DTYPE dtype)
1890 {
1891 int ast;
1892
1893 ast = hash_substr(A_SUBSTR, dtype, chr, left, right);
1894 A_SHAPEP(ast, A_SHAPEG(chr));
1895 A_CALLFGP(ast, A_CALLFGG(chr) | (left ? A_CALLFGG(left) : 0) |
1896 (right ? A_CALLFGG(right) : 0));
1897 return ast;
1898 }
1899
1900 /** \brief For an AST tree with members and subscripts,
1901 if the base variable has the PARAMG bit set and all the subscripts
1902 are known constants, we can perhaps find the value the AST and set
1903 the A_ALIAS flag.
1904 */
1905 int
complex_alias(int ast)1906 complex_alias(int ast)
1907 {
1908 int a, alias, sptr, asd, ndim, i, j, elem_offset, dtype;
1909 switch (A_TYPEG(ast)) {
1910 case A_SUBSCR:
1911 alias = complex_alias(A_LOPG(ast));
1912 if (alias == 0)
1913 return 0;
1914 dtype = A_DTYPEG(A_LOPG(ast));
1915 if (DTY(dtype) != TY_ARRAY)
1916 return 0;
1917 /* check the subscripts */
1918 asd = A_ASDG(ast);
1919 ndim = ASD_NDIM(asd);
1920 a = alias;
1921 alias = A_LEFTG(alias);
1922 if (alias == 0)
1923 return 0;
1924 if (A_TYPEG(alias) != A_INIT) {
1925 /*
1926 * presumably, this init is just a scalar promoted to an array.
1927 */
1928 return a;
1929 }
1930 elem_offset = 0;
1931 for (i = 0; i < ndim; ++i) {
1932 int ss, ssptr, ssval, lwbd, lwbdsptr, lwbdval, mplyr, mplyrsptr, mplyrval;
1933 ss = ASD_SUBS(asd, i);
1934 ss = A_ALIASG(ss);
1935 if (ss == 0)
1936 return 0;
1937 ssptr = A_SPTRG(ss);
1938 ssval = CONVAL2G(ssptr);
1939 /* lower bound of this dimension? */
1940 lwbd = ADD_LWAST(dtype, i);
1941 lwbd = A_ALIASG(lwbd);
1942 if (lwbd == 0)
1943 return 0;
1944 lwbdsptr = A_SPTRG(lwbd);
1945 lwbdval = CONVAL2G(lwbdsptr);
1946 mplyr = ADD_MLPYR(dtype, i);
1947 mplyr = A_ALIASG(mplyr);
1948 if (mplyr == 0)
1949 return 0;
1950 mplyrsptr = A_SPTRG(mplyr);
1951 mplyrval = CONVAL2G(mplyrsptr);
1952
1953 elem_offset += (ssval - lwbdval) * mplyrval;
1954 }
1955 /* find this element of the named constant array */
1956 for (j = 0; j < elem_offset; ++j) {
1957 alias = A_RIGHTG(alias);
1958 if (alias == 0)
1959 return 0;
1960 }
1961 return alias;
1962 break;
1963 case A_MEM:
1964 alias = complex_alias(A_PARENTG(ast));
1965 if (alias == 0)
1966 return 0;
1967 /* find this member in the alias list */
1968 sptr = A_SPTRG(A_MEMG(ast));
1969 for (a = A_LEFTG(alias); a; a = A_RIGHTG(a)) {
1970 if (A_SPTRG(a) == sptr)
1971 return a;
1972 }
1973 return 0;
1974 break;
1975 case A_ID:
1976 /* is the symbol really a PARAMETER symbolic constant? */
1977 sptr = A_SPTRG(ast);
1978 if (!PARAMG(sptr))
1979 return 0;
1980 return PARAMVALG(sptr);
1981 default:
1982 return 0;
1983 }
1984 } /* complex_alias */
1985
1986 int
mk_member(int parent,int mem,DTYPE dtype)1987 mk_member(int parent, int mem, DTYPE dtype)
1988 {
1989 int ast;
1990 int shape_parent, shape_mem;
1991
1992 shape_parent = A_SHAPEG(parent);
1993 shape_mem = A_SHAPEG(mem);
1994 /* If both parent and member have a shape, there is really no
1995 * correct dtype for A_MEM. mk_subscr will have to check.
1996 */
1997 /* dtype is dtype of member */
1998 if (shape_mem) {
1999 int memsptr;
2000 /* if this member is a pointer, then we must modify the shape
2001 * descriptors to use the static descriptor which is in the
2002 * dtype */
2003 memsptr = A_SPTRG(mem);
2004 if ((POINTERG(memsptr) || ALLOCATTRG(memsptr)) && SDSCG(memsptr) &&
2005 STYPEG(SDSCG(memsptr)) == ST_MEMBER) {
2006 shape_mem = mk_mem_ptr_shape(parent, mem, A_DTYPEG(mem));
2007 }
2008 dtype = dtype_with_shape(dtype, shape_mem);
2009 } else if (shape_parent) {
2010 dtype = dtype_with_shape(DDTG(dtype), shape_parent);
2011 }
2012 ast = hash_mem(A_MEM, dtype, parent, mem);
2013 if (DTY(dtype) == TY_ARRAY) {
2014 if (shape_mem) {
2015 A_SHAPEP(ast, shape_mem);
2016 } else if (shape_parent) {
2017 A_SHAPEP(ast, shape_parent);
2018 } else {
2019 A_SHAPEP(ast, mkshape(dtype));
2020 }
2021 }
2022 A_CALLFGP(ast, A_CALLFGG(parent));
2023 if (DT_ISSCALAR(dtype)) {
2024 int al;
2025 al = complex_alias(ast);
2026 if (A_TYPEG(al) == A_INIT)
2027 A_ALIASP(ast, A_LEFTG(al));
2028 }
2029 return ast;
2030 }
2031
2032 /*---------------------------------------------------------------------*/
2033
2034 /** \brief Make shape ilm(s) from an array descriptor. Return the pointer to
2035 the
2036 the shape descriptor (SHD).
2037 */
2038 int
mkshape(DTYPE dtype)2039 mkshape(DTYPE dtype)
2040 {
2041 int numdim, i;
2042 int lwb, upb, stride;
2043
2044 if (DTY(dtype) != TY_ARRAY)
2045 return 0;
2046 numdim = ADD_NUMDIM(dtype);
2047 if (numdim > 7 || numdim < 1) {
2048 interr("mkshape: bad numdim", numdim, 3);
2049 numdim = 1;
2050 add_shape_rank(numdim);
2051 add_shape_spec(astb.bnd.one, astb.bnd.one, astb.bnd.one);
2052 return mk_shape();
2053 }
2054
2055 add_shape_rank(numdim);
2056 for (i = 0; i < numdim; ++i) {
2057 lwb = lbound_of(dtype, i);
2058 upb = ADD_UPAST(dtype, i);
2059 stride = astb.bnd.one;
2060 add_shape_spec(lwb, upb, stride);
2061 }
2062 return mk_shape();
2063 }
2064
2065 /** \brief Make shape ast(s) for an array reference off of a pointer in a
2066 derived type. Return the shape descriptor (SHD). Main difference
2067 is that the descriptor references need to be derived type
2068 components.
2069 */
2070 int
mk_mem_ptr_shape(int parent,int mem,DTYPE dtype)2071 mk_mem_ptr_shape(int parent, int mem, DTYPE dtype)
2072 {
2073 int numdim, i;
2074 int lwb, upb, extnt, stride;
2075 int newlwb, newupb, newextnt;
2076 int sdsc;
2077 int subs[1];
2078 int lwbds[MAXRANK];
2079 int upbds[MAXRANK];
2080 int asd;
2081
2082 if (DTY(dtype) != TY_ARRAY)
2083 return 0;
2084 numdim = ADD_NUMDIM(dtype);
2085 if (numdim > 7 || numdim < 1) {
2086 interr("mkshape: bad numdim", numdim, 3);
2087 numdim = 1;
2088 add_shape_rank(numdim);
2089 add_shape_spec(astb.bnd.one, astb.bnd.one, astb.bnd.one);
2090 return mk_shape();
2091 }
2092
2093 sdsc = SDSCG(A_SPTRG(mem));
2094 for (i = 0; i < numdim; ++i) {
2095 lwb = lbound_of(dtype, i);
2096 upb = ADD_UPAST(dtype, i);
2097 extnt = ADD_EXTNTAST(dtype, i);
2098 stride = astb.bnd.one;
2099 /* lwb, upb and extnt should look like x$sd(..) -- need to modify
2100 * them to be parent%x$sd(..)
2101 */
2102 assert(sdsc != 0, "mk_mem_ptr_shape: no static desc for pointer", mem, 4);
2103 assert(A_TYPEG(lwb) == A_SUBSCR, "mk_mem_ptr_shape: lwb not subs", lwb, 4);
2104 assert(memsym_of_ast(lwb) == sdsc, "mk_mem_ptr_shape: lwb not sdsc", lwb,
2105 4);
2106 assert(A_TYPEG(extnt) == A_SUBSCR, "mk_mem_ptr_shape: extnt not subs",
2107 extnt, 4);
2108 assert(memsym_of_ast(extnt) == sdsc, "mk_mem_ptr_shape: extnt not sdsc",
2109 extnt, 4);
2110
2111 asd = A_ASDG(lwb);
2112 assert(ASD_NDIM(asd) == 1, "mk_mem_ptr_shape: lwb too many dims", lwb, 4);
2113 newlwb = mk_id(sdsc);
2114 newlwb = mk_member(parent, newlwb, A_DTYPEG(newlwb));
2115 subs[0] = ASD_SUBS(asd, 0);
2116 newlwb = mk_subscr(newlwb, subs, 1, astb.bnd.dtype);
2117
2118 newupb = mk_id(sdsc);
2119 newupb = mk_member(parent, newupb, A_DTYPEG(newupb));
2120 asd = A_ASDG(extnt);
2121 assert(ASD_NDIM(asd) == 1, "mk_mem_ptr_shape: extnt too many dims", extnt,
2122 4);
2123 subs[0] = ASD_SUBS(asd, 0);
2124 newupb = mk_subscr(newupb, subs, 1, astb.bnd.dtype);
2125 newupb = mk_binop(OP_SUB, newupb, mk_isz_cval(1, A_DTYPEG(extnt)),
2126 A_DTYPEG(extnt));
2127 newupb = mk_binop(OP_ADD, newlwb, newupb, A_DTYPEG(extnt));
2128
2129 lwbds[i] = newlwb;
2130 upbds[i] = newupb;
2131 }
2132 stride = astb.bnd.one;
2133 add_shape_rank(numdim);
2134 for (i = 0; i < numdim; ++i)
2135 add_shape_spec(lwbds[i], upbds[i], stride);
2136 return mk_shape();
2137 }
2138
2139 /*
2140 * define static structure used to represent the template for creating
2141 * a shape descriptor. A shape descriptor is called by the following calls:
2142 *
2143 * add_shape_rank(ndim) -- begin by defining the shape's rank
2144 *
2145 * foreach dimension
2146 * add_shape_spec(lwb, upb, stride) -- ASTs of lower and upper bounds and
2147 * stride for dimension
2148 * mk_shape() -- create shape descriptor in dynamic memory area
2149 * and return its pointer.
2150 *
2151 * reduc_shape() -- create shape descriptor derived from an existing
2152 * shape descriptor excluding a given dimension.
2153 *
2154 */
2155 static struct {
2156 short ndim; /* number of dimensions (rank) */
2157 short next; /* next dimension to be filled in */
2158 struct {
2159 int lwb;
2160 int upb;
2161 int stride;
2162 } spec[MAXRANK]; /* maximum number of dimensions */
2163 } _shd;
2164
2165 int
mk_shape(void)2166 mk_shape(void)
2167 {
2168 int ndim;
2169 int shape;
2170 int i;
2171
2172 ndim = _shd.ndim;
2173 #if DEBUG
2174 assert(ndim && ndim == _shd.next, "mk_shape:inconsistent ndim,next",
2175 _shd.ndim, 4);
2176 #endif
2177
2178 /* search the existing SHDs with the same number of dimensions
2179 */
2180 for (shape = astb.shd.hash[ndim - 1]; shape; shape = SHD_NEXT(shape)) {
2181 for (i = 0; i < ndim; i++)
2182 if (SHD_LWB(shape, i) != _shd.spec[i].lwb ||
2183 SHD_UPB(shape, i) != _shd.spec[i].upb ||
2184 SHD_STRIDE(shape, i) != _shd.spec[i].stride)
2185 goto next_shape;
2186 goto found; /* return matching shape */
2187 next_shape:;
2188 }
2189 /*
2190 * allocate a new SHD; note that the type SHD allows for one
2191 * subscript.
2192 */
2193 shape = astb.shd.stg_avail;
2194 i = ndim + 1; /* WATCH declaration of SHD */
2195 astb.shd.stg_avail += i;
2196 NEED(astb.shd.stg_avail, astb.shd.stg_base, SHD, astb.shd.stg_size, astb.shd.stg_avail + 240);
2197 SHD_NDIM(shape) = ndim;
2198 SHD_NEXT(shape) = astb.shd.hash[ndim - 1];
2199 SHD_FILL(shape) = 0; /* avoid bogus UMR reports */
2200 astb.shd.hash[ndim - 1] = shape;
2201 for (i = 0; i < ndim; i++) {
2202 SHD_LWB(shape, i) = _shd.spec[i].lwb;
2203 SHD_UPB(shape, i) = _shd.spec[i].upb;
2204 SHD_STRIDE(shape, i) = _shd.spec[i].stride;
2205 }
2206
2207 found:
2208 return shape;
2209 }
2210
2211 /** \brief Make an ast tree that computes the offset of the derived type or
2212 array element reference 'ast' from the start of the variable being
2213 referenced.
2214 */
2215 int
mk_offset(int astx,int resdtype)2216 mk_offset(int astx, int resdtype)
2217 {
2218 int sptr, sptrdtype, offsetx, numdim, asd, i, sub, offx, ssoffx;
2219 switch (A_TYPEG(astx)) {
2220 case A_ID:
2221 return mk_isz_cval(0, resdtype);
2222 case A_SUBSTR:
2223 sptr = memsym_of_ast(astx);
2224 offsetx = mk_offset(A_PARENTG(astx), resdtype);
2225 offx = mk_binop(OP_SUB, A_LEFTG(astx), stb.i1, resdtype);
2226 offsetx = mk_binop(OP_ADD, offsetx, offx, resdtype);
2227 return offsetx;
2228 case A_SUBSCR:
2229 sptr = memsym_of_ast(astx);
2230 sub = A_ASDG(astx);
2231 sptrdtype = DTYPEG(sptr);
2232 asd = A_ASDG(astx);
2233 numdim = ADD_NUMDIM(sptrdtype);
2234 if (ASD_NDIM(asd) != numdim)
2235 interr("mk_offset: dimensions don't match", numdim, 3);
2236 offsetx = mk_offset(A_PARENTG(astx), resdtype);
2237 offx = 0;
2238 for (i = 0; i < numdim; ++i) {
2239 int ss = ASD_SUBS(sub, i);
2240 if (A_TYPEG(ss) == A_TRIPLE)
2241 ss = A_LBDG(ss);
2242 ssoffx = mk_binop(OP_SUB, ss, ADD_LWAST(sptrdtype, i), resdtype);
2243 ssoffx = mk_binop(OP_MUL, ssoffx, ADD_MLPYR(sptrdtype, i), resdtype);
2244 if (!offx) {
2245 offx = ssoffx;
2246 } else {
2247 offx = mk_binop(OP_ADD, offx, ssoffx, resdtype);
2248 }
2249 }
2250 offx = mk_binop(OP_MUL, offx, size_ast(sptr, DTY(sptrdtype + 1)), resdtype);
2251 offsetx = mk_binop(OP_ADD, offsetx, offx, resdtype);
2252 return offsetx;
2253 case A_MEM:
2254 sptr = A_SPTRG(A_MEMG(astx));
2255 offsetx = mk_offset(A_PARENTG(astx), resdtype);
2256 offsetx = mk_binop(OP_ADD, offsetx, mk_isz_cval(ADDRESSG(sptr), resdtype),
2257 resdtype);
2258 return offsetx;
2259 default:
2260 interr("mk_offset: unexpected ast", astx, 3);
2261 return mk_isz_cval(0, resdtype);
2262 }
2263 } /* mk_offset */
2264
2265 /** \brief Duplicate a shape descriptor excluding a given dimension.
2266 \param o_shape old shape
2267 \param astdim ast of dimension to be excluded
2268 \param after std after which code is produced to create the
2269 bounds descriptor (if dim is not a constant)
2270 */
2271 int
reduc_shape(int o_shape,int astdim,int after)2272 reduc_shape(int o_shape, int astdim, int after)
2273 {
2274 int ndim;
2275 int o_ndim;
2276 int dim;
2277 int shape;
2278 int i;
2279
2280 o_ndim = SHD_NDIM(o_shape);
2281 ndim = o_ndim - 1;
2282
2283 if (A_ALIASG(astdim) == 0) {
2284 /* for non-constant dim, just create a dummy shape descriptor
2285 * of the correct rank for the intrinsic. Each item in the descriptor
2286 * will reference a CCSYM symbol and will not appear in the output.
2287 */
2288 int sptr, a;
2289
2290 if (ndim <= 0)
2291 return 0;
2292
2293 sptr = getccsym('.', 0, ST_VAR);
2294 a = mk_id(sptr);
2295 DTYPEP(sptr, astb.bnd.dtype);
2296 add_shape_rank(ndim);
2297 for (i = 0; i < ndim; i++)
2298 add_shape_spec(a, a, a);
2299 } else {
2300 /* dim is a constant */
2301
2302 dim = get_int_cval(A_SPTRG(A_ALIASG(astdim)));
2303 if (dim < 1 || dim > o_ndim) {
2304 error(423, 3, gbl.lineno, NULL, NULL);
2305 dim = 1;
2306 }
2307 if (ndim <= 0)
2308 return 0;
2309
2310 add_shape_rank(ndim);
2311 for (i = 0; i < o_ndim; i++)
2312 if (i != dim - 1)
2313 add_shape_spec((int)SHD_LWB(o_shape, i), (int)SHD_UPB(o_shape, i),
2314 (int)SHD_STRIDE(o_shape, i));
2315 }
2316 shape = mk_shape();
2317 return shape;
2318 }
2319
2320 /** \brief Duplicate a shape descriptor increasing its rank at the given
2321 dimension.
2322 \param o_shape old shape
2323 \param astdim ast of dimension to add
2324 \param ub ast of upper bound of dim at astdim
2325 \param after std after which code is produced to create the
2326 bounds descriptor (if dim is not a constant)
2327 */
2328 int
increase_shape(int o_shape,int astdim,int ub,int after)2329 increase_shape(int o_shape, int astdim, int ub, int after)
2330 {
2331 int ndim;
2332 int o_ndim;
2333 int dim;
2334 int shape;
2335 int i;
2336
2337 if (o_shape == 0) {
2338 /* scalar: create a rank 1 array */
2339 add_shape_rank(1);
2340 add_shape_spec(astb.bnd.one, ub, astb.bnd.one);
2341 } else {
2342 o_ndim = SHD_NDIM(o_shape);
2343 ndim = o_ndim + 1;
2344
2345 if (A_ALIASG(astdim) == 0) {
2346 /* for non-constant dim, just create a dummy shape descriptor
2347 * of the correct rank for the intrinsic. Each item in the
2348 * descriptor will reference a CCSYM symbol and will not appear in
2349 * the output.
2350 */
2351 int sptr, a;
2352
2353 sptr = getccsym('.', 0, ST_VAR);
2354 a = mk_id(sptr);
2355 DTYPEP(sptr, astb.bnd.dtype);
2356 add_shape_rank(ndim);
2357 for (i = 0; i < ndim; i++)
2358 add_shape_spec(a, a, a);
2359 } else {
2360 /* dim is a constant */
2361
2362 dim = get_int_cval(A_SPTRG(A_ALIASG(astdim)));
2363 if (dim < 1 || dim > ndim) {
2364 error(423, 3, gbl.lineno, NULL, NULL);
2365 dim = 1;
2366 }
2367 add_shape_rank(ndim);
2368 for (i = 0; i < o_ndim; i++) {
2369 if (i == dim - 1)
2370 add_shape_spec(astb.bnd.one, ub, astb.bnd.one);
2371 add_shape_spec((int)SHD_LWB(o_shape, i), (int)SHD_UPB(o_shape, i),
2372 (int)SHD_STRIDE(o_shape, i));
2373 }
2374 if (o_ndim == dim - 1)
2375 add_shape_spec(astb.bnd.one, ub, astb.bnd.one);
2376 }
2377 }
2378 shape = mk_shape();
2379 return shape;
2380 }
2381
2382 void
add_shape_rank(int ndim)2383 add_shape_rank(int ndim)
2384 {
2385 _shd.ndim = ndim;
2386 _shd.next = 0;
2387 }
2388
2389 void
add_shape_spec(int lwb,int upb,int stride)2390 add_shape_spec(int lwb, int upb, int stride)
2391 {
2392 int i;
2393
2394 i = _shd.next;
2395 #if DEBUG
2396 assert(i < _shd.ndim, "add_shape_spec:exceed rank", i, 4);
2397 #endif
2398 _shd.spec[i].lwb = lwb;
2399 _shd.spec[i].upb = upb;
2400 _shd.spec[i].stride = stride;
2401 _shd.next++;
2402 }
2403
2404 /** \brief Check conformance of shape descriptors
2405 \return true if the data types for two shapes are conformable
2406 (have the same shape). Shape is defined to be the rank and
2407 the extents of each dimension.
2408 */
2409 LOGICAL
conform_shape(int shape1,int shape2)2410 conform_shape(int shape1, int shape2)
2411 {
2412 int ndim;
2413 int i;
2414 ISZ_T lb1, lb2; /* lower bounds if constants */
2415 ISZ_T ub1, ub2; /* upper bounds if constants */
2416 ISZ_T st1, st2; /* strides if constants */
2417
2418 if (shape1 == shape2)
2419 return TRUE;
2420 ndim = SHD_NDIM(shape1);
2421 if (ndim != SHD_NDIM(shape2))
2422 return FALSE;
2423
2424 for (i = 0; i < ndim; i++) {
2425 if ((lb1 = A_ALIASG(SHD_LWB(shape1, i))) == 0)
2426 continue; /* not a constant => skip this dimension */
2427 lb1 = get_isz_cval(A_SPTRG(lb1));
2428
2429 if ((ub1 = A_ALIASG(SHD_UPB(shape1, i))) == 0)
2430 continue; /* not a constant => skip this dimension */
2431 ub1 = get_isz_cval(A_SPTRG(ub1));
2432
2433 if ((st1 = A_ALIASG(SHD_STRIDE(shape1, i))) == 0)
2434 continue; /* not a constant => skip this dimension */
2435 st1 = get_isz_cval(A_SPTRG(st1));
2436
2437 if ((lb2 = A_ALIASG(SHD_LWB(shape2, i))) == 0)
2438 continue; /* not a constant => skip this dimension */
2439 lb2 = get_isz_cval(A_SPTRG(lb2));
2440
2441 if ((ub2 = A_ALIASG(SHD_UPB(shape2, i))) == 0)
2442 continue; /* not a constant => skip this dimension */
2443 ub2 = get_isz_cval(A_SPTRG(ub2));
2444
2445 if ((st2 = A_ALIASG(SHD_STRIDE(shape2, i))) == 0)
2446 continue; /* not a constant => skip this dimension */
2447 st2 = get_isz_cval(A_SPTRG(st2));
2448
2449 /* lower and upper bounds and stride are constants in this dimension*/
2450
2451 if (!st1 || !st2 || (ub1 - lb1 + st1) / st1 != (ub2 - lb2 + st2) / st2)
2452 return FALSE;
2453 }
2454
2455 return TRUE;
2456 }
2457
2458 /** \brief Create an ast representing the extent of a dimension.
2459 \param shape shape descriptor
2460 \param dim which dimension (0 based)
2461 */
2462 int
extent_of_shape(int shape,int dim)2463 extent_of_shape(int shape, int dim)
2464 {
2465 int a;
2466 int lb = SHD_LWB(shape, dim);
2467 int ub = SHD_UPB(shape, dim);
2468 int stride = SHD_STRIDE(shape, dim);
2469
2470 a = mk_binop(OP_SUB, ub, lb, astb.bnd.dtype);
2471 a = mk_binop(OP_ADD, a, stride, astb.bnd.dtype);
2472 a = mk_binop(OP_DIV, a, stride, astb.bnd.dtype);
2473
2474 if (A_ALIASG(a)) {
2475 int cv;
2476 cv = A_SPTRG(A_ALIASG(a)); /* constant ST entry */
2477 if (DTY(DT_INT) != TY_INT8 && !XBIT(68, 0x1)) {
2478 if (CONVAL2G(cv) < 0)
2479 /* zero-sized in the dimension */
2480 return astb.i0;
2481 } else {
2482 INT inum1[2], inum2[2];
2483
2484 inum1[0] = CONVAL1G(cv);
2485 inum1[1] = CONVAL2G(cv);
2486 inum2[0] = 0;
2487 inum2[1] = 0;
2488 if (cmp64(inum1, inum2) < 0)
2489 /* zero-sized in the dimension */
2490 return astb.bnd.zero;
2491 }
2492 } else {
2493 int mask = mk_binop(OP_GE, ub, lb, astb.bnd.dtype);
2494 a = mk_merge(a, astb.bnd.zero, mask, astb.bnd.dtype);
2495 }
2496
2497 return a;
2498 }
2499
2500 /** \brief Get the lower bound of a shape descriptor.
2501 \param shape shape descriptor
2502 \param dim which dimension (0 based)
2503 \return an ast if the lower bound is a constant; otherwise, return 0.
2504 */
2505 int
lbound_of_shape(int shape,int dim)2506 lbound_of_shape(int shape, int dim)
2507 {
2508 int lb = SHD_LWB(shape, dim);
2509 int ub = SHD_UPB(shape, dim);
2510
2511 if (A_ALIASG(lb) && A_ALIASG(ub)) {
2512 if (get_isz_cval(A_SPTRG(A_ALIASG(lb))) >
2513 get_isz_cval(A_SPTRG(A_ALIASG(ub))))
2514 /* zero-sized in the dimension */
2515 return astb.bnd.zero;
2516 return lb;
2517 }
2518 return 0;
2519 }
2520
2521 /** \brief Get the upper bound of a shape descriptor.
2522 \param shape shape descriptor
2523 \param dim which dimension (0 based)
2524 \return an ast if the upper bound is a constant; otherwise, return 0.
2525 */
2526 int
ubound_of_shape(int shape,int dim)2527 ubound_of_shape(int shape, int dim)
2528 {
2529 int lb = SHD_LWB(shape, dim);
2530 int ub = SHD_UPB(shape, dim);
2531
2532 if (A_ALIASG(lb) && A_ALIASG(ub)) {
2533 if (get_isz_cval(A_SPTRG(A_ALIASG(lb))) >
2534 get_isz_cval(A_SPTRG(A_ALIASG(ub))))
2535 /* zero-sized in the dimension */
2536 return astb.bnd.zero;
2537 return ub;
2538 }
2539 return 0;
2540 }
2541
2542 int
rank_of_ast(int ast)2543 rank_of_ast(int ast)
2544 {
2545 int shape;
2546
2547 shape = A_SHAPEG(ast);
2548 if (shape == 0)
2549 return 0;
2550 return SHD_NDIM(shape);
2551 }
2552
2553 /** \brief Return the ast which computes the zero-base offset for an array.
2554 */
2555 int
mk_zbase_expr(ADSC * ad)2556 mk_zbase_expr(ADSC *ad)
2557 {
2558 int i, numdim;
2559 int zbaseast = 0;
2560
2561 numdim = AD_NUMDIM(ad);
2562 for (i = 0; i < numdim; i++) {
2563 if (i == 0) {
2564 zbaseast = AD_LWAST(ad, i);
2565 } else {
2566 int a;
2567 a = mk_binop(OP_MUL, AD_LWAST(ad, i), AD_MLPYR(ad, i), astb.bnd.dtype);
2568 zbaseast = mk_binop(OP_ADD, zbaseast, a, astb.bnd.dtype);
2569 }
2570 }
2571 return zbaseast;
2572 }
2573
2574 /** \brief Return an ast that computes the multiplier from the multiplier,
2575 lower bound, and upper bound of the previous dimension.
2576 */
2577 int
mk_mlpyr_expr(int lb,int ub,int mlpyr)2578 mk_mlpyr_expr(int lb, int ub, int mlpyr)
2579 {
2580 int ast;
2581
2582 if (lb == astb.bnd.one)
2583 ast = ub;
2584 else {
2585 ast = mk_binop(OP_SUB, ub, lb, astb.bnd.dtype);
2586 ast = mk_binop(OP_ADD, ast, astb.bnd.one, astb.bnd.dtype);
2587 }
2588 ast = mk_binop(OP_MUL, mlpyr, ast, astb.bnd.dtype);
2589 return ast;
2590 }
2591
2592 /** \brief Return an ast that computes the extent (from the \a lb and \a ub).
2593 */
2594 int
mk_extent_expr(int lb,int ub)2595 mk_extent_expr(int lb, int ub)
2596 {
2597 INT extent_expr;
2598
2599 if (A_ALIASG(lb) && ub && A_ALIASG(ub)) {
2600 extent_expr = mk_isz_cval(
2601 ad_val_of(A_SPTRG(ub)) - ad_val_of(A_SPTRG(lb)) + 1, astb.bnd.dtype);
2602 } else if (!ub) {
2603 extent_expr = mk_binop(OP_ADD, lb, astb.bnd.one, astb.bnd.dtype);
2604 } else if (lb == astb.bnd.one) {
2605 extent_expr = ub;
2606 } else {
2607 extent_expr = mk_binop(OP_ADD, mk_binop(OP_SUB, ub, lb, astb.bnd.dtype),
2608 astb.bnd.one, astb.bnd.dtype);
2609 }
2610
2611 return extent_expr;
2612 }
2613
2614 /** \brief Return an ast to reference the extent.
2615 */
2616 int
mk_extent(int lb,int ub,int dim)2617 mk_extent(int lb, int ub, int dim)
2618 {
2619 INT extent;
2620
2621 if (lb && ub && A_ALIASG(lb) && A_ALIASG(ub)) {
2622 extent = mk_isz_cval(ad_val_of(A_SPTRG(ub)) - ad_val_of(A_SPTRG(lb)) + 1,
2623 astb.bnd.dtype);
2624 } else if (lb && A_TYPEG(lb) == A_SUBSCR) {
2625 int sptr = memsym_of_ast(lb);
2626 if (STYPEG(sptr) == ST_DESCRIPTOR || STYPEG(sptr) == ST_ARRDSC ||
2627 (STYPEG(sptr) == ST_MEMBER && DESCARRAYG(sptr))) {
2628 extent = get_extent(sptr, dim);
2629 } else {
2630 /*extent = mk_extent_expr(lb, ub);*/
2631 extent = mk_bnd_ast();
2632 }
2633 } else {
2634 if (lb == astb.bnd.one && ub) {
2635 extent = ub;
2636 } else {
2637 /* ub is probably an ID (for a temp var), allocate a temp for extent */
2638 extent = mk_bnd_ast();
2639 }
2640 }
2641 return extent;
2642 }
2643
2644 int
mk_shared_extent(int lb,int ub,int dim)2645 mk_shared_extent(int lb, int ub, int dim)
2646 {
2647 INT extent;
2648
2649 if (lb && ub && A_ALIASG(lb) && A_ALIASG(ub)) {
2650 extent = mk_isz_cval(ad_val_of(A_SPTRG(ub)) - ad_val_of(A_SPTRG(lb)) + 1,
2651 astb.bnd.dtype);
2652 } else if (lb && A_TYPEG(lb) == A_SUBSCR) {
2653 int sptr = memsym_of_ast(lb);
2654 if (STYPEG(sptr) == ST_DESCRIPTOR || STYPEG(sptr) == ST_ARRDSC ||
2655 (STYPEG(sptr) == ST_MEMBER && DESCARRAYG(sptr))) {
2656 extent = get_extent(sptr, dim);
2657 } else if (lb && ub) {
2658 extent = mk_extent_expr(lb, ub);
2659 extent = mk_shared_bnd_ast(extent);
2660 } else {
2661 extent = mk_bnd_ast();
2662 }
2663 } else {
2664 if (lb == astb.bnd.one && ub) {
2665 extent = ub;
2666 } else if (lb && ub) {
2667 /* ub is probably an ID (for a temp var), allocate a temp for extent */
2668 extent = mk_extent_expr(lb, ub);
2669 extent = mk_shared_bnd_ast(extent);
2670 } else {
2671 extent = mk_bnd_ast();
2672 }
2673 }
2674 return extent;
2675 }
2676
2677 /* \brief returns TRUE if type of ast is a symbol or an object that can be
2678 * passed to sym_of_ast() or memsym_of_ast() functions.
2679 *
2680 * \param ast is the AST to test.
2681 *
2682 * \returns TRUE if ast is suitable for sym_of_ast(), etc. Otherwise FALSE.
2683 */
2684 LOGICAL
ast_is_sym(int ast)2685 ast_is_sym(int ast)
2686 {
2687 return sym_of_ast2(ast) != 0;
2688 }
2689
2690 /** \brief Like memsym_of_ast(), but for a member, returns the sptr of its
2691 parent, not the member.
2692 */
2693 int
sym_of_ast(int ast)2694 sym_of_ast(int ast)
2695 {
2696 SPTR sptr = sym_of_ast2(ast);
2697 if (sptr == 0) {
2698 interr("sym_of_ast: unexpected ast", ast, 3);
2699 return stb.i0;
2700 }
2701 return sptr;
2702 }
2703
2704 /* Like sym_of_ast() but return 0 if ast does not have a sym. */
2705 static SPTR
sym_of_ast2(int ast)2706 sym_of_ast2(int ast)
2707 {
2708 int alias = A_ALIASG(ast);
2709 if (alias)
2710 return A_SPTRG(alias);
2711 switch (A_TYPEG(ast)) {
2712 case A_ID:
2713 case A_LABEL:
2714 case A_ENTRY:
2715 return A_SPTRG(ast);
2716 case A_SUBSCR:
2717 case A_SUBSTR:
2718 case A_CONV:
2719 case A_FUNC:
2720 case A_CALL:
2721 return sym_of_ast2(A_LOPG(ast));
2722 case A_MEM:
2723 return sym_of_ast2(A_PARENTG(ast));
2724 default:
2725 return 0;
2726 }
2727 }
2728
2729 /** \brief Like sym_of_ast(), except for members it will return second to last
2730 parent
2731 member.
2732
2733 For example, `pds%%data%%foo()` returns `data`, `pds%%data` returns
2734 `pds`.<br>
2735 This is used in computing the pass argument for a type-bound procedure
2736 expression.
2737 */
2738 int
pass_sym_of_ast(int ast)2739 pass_sym_of_ast(int ast)
2740 {
2741 int a;
2742
2743 if ((a = A_ALIASG(ast)))
2744 return A_SPTRG(a);
2745 while (1) {
2746 switch (A_TYPEG(ast)) {
2747 case A_ID:
2748 case A_LABEL:
2749 case A_ENTRY:
2750 return A_SPTRG(ast);
2751 case A_FUNC:
2752 case A_CALL:
2753 case A_SUBSCR:
2754 case A_SUBSTR:
2755 ast = A_LOPG(ast);
2756 if (A_TYPEG(ast) == A_MEM)
2757 ast = A_MEMG(ast);
2758 break;
2759 case A_MEM:
2760 ast = A_PARENTG(ast);
2761 if (A_TYPEG(ast) == A_MEM)
2762 return A_SPTRG(A_MEMG(ast));
2763 break;
2764 default:
2765 interr("pass_sym_of_ast: unexpected ast", ast, 3);
2766 return stb.i0;
2767 }
2768 }
2769 }
2770
2771 /** \brief Like sym_of_ast(), but for a member, returns the sptr of the
2772 member itself, not its parent */
2773 int
memsym_of_ast(int ast)2774 memsym_of_ast(int ast)
2775 {
2776 int a;
2777
2778 if ((a = A_ALIASG(ast)))
2779 return A_SPTRG(a);
2780 while (1) {
2781 switch (A_TYPEG(ast)) {
2782 case A_ID:
2783 case A_LABEL:
2784 case A_ENTRY:
2785 return A_SPTRG(ast);
2786 case A_SUBSCR:
2787 case A_SUBSTR:
2788 case A_CONV:
2789 ast = A_LOPG(ast);
2790 break;
2791 case A_MEM:
2792 ast = A_MEMG(ast);
2793 break;
2794 case A_FUNC:
2795 case A_CALL:
2796 ast = A_LOPG(ast);
2797 break;
2798 default:
2799 interr("memsym_of_ast:unexp.ast", ast, 3);
2800 return stb.i0;
2801 }
2802 }
2803 }
2804
2805 /** \brief Replace sptr of ast, if member, replace the sptr of the member */
2806 void
put_memsym_of_ast(int ast,int sptr)2807 put_memsym_of_ast(int ast, int sptr)
2808 {
2809 int a;
2810
2811 if ((a = A_ALIASG(ast))) {
2812 A_SPTRP(a, sptr);
2813 return;
2814 }
2815 while (1) {
2816 switch (A_TYPEG(ast)) {
2817 case A_ID:
2818 case A_LABEL:
2819 case A_ENTRY:
2820 A_SPTRP(ast, sptr);
2821 return;
2822 case A_SUBSCR:
2823 case A_SUBSTR:
2824 ast = A_LOPG(ast);
2825 break;
2826 case A_MEM:
2827 ast = A_MEMG(ast);
2828 break;
2829 default:
2830 interr("put_memsym_of_ast:unexp.ast", ast, 3);
2831 return;
2832 }
2833 }
2834 }
2835
2836 /** \brief Generate a replacement AST with a new sptr for certain AST types.
2837 *
2838 * This routine duplicates an AST and replaces its symbol table pointer with
2839 * the caller specified symbol table pointer. This routine is typically used
2840 * for replacing a generic type bound procedure with its resolved specific
2841 * type bound procedure. This routine currently works for A_ID and A_MEM AST
2842 * types.
2843 *
2844 * \param ast is the original AST that we want to duplicate.
2845 * \param sptr is the new symbol table pointer for the new AST.
2846 *
2847 * \return the (new) replacement AST.
2848 */
2849 int
replace_memsym_of_ast(int ast,SPTR sptr)2850 replace_memsym_of_ast(int ast, SPTR sptr)
2851 {
2852 switch (A_TYPEG(ast)) {
2853 case A_ID:
2854 return mk_id(sptr);
2855 case A_MEM:
2856 if (A_TYPEG(A_MEMG(ast)) == A_ID) {
2857 return mk_member(A_PARENTG(ast), mk_id(sptr), A_DTYPEG(ast));
2858 }
2859 /* else fall through to error */
2860 default:
2861 interr("replace_memsym_of_ast: unexpected ast", ast, 3);
2862 }
2863 return 0;
2864 }
2865
2866 /** \brief Like memsym_of_ast(), but for looking for the sptr of a procedure
2867 * reference
2868 */
2869 int
procsym_of_ast(int ast)2870 procsym_of_ast(int ast)
2871 {
2872 int a;
2873
2874 while (1) {
2875 switch (A_TYPEG(ast)) {
2876 case A_ID:
2877 return A_SPTRG(ast);
2878 case A_SUBSCR:
2879 ast = A_LOPG(ast);
2880 break;
2881 case A_MEM:
2882 ast = A_MEMG(ast);
2883 break;
2884 default:
2885 interr("procym_of_ast:unexp.ast", ast, 3);
2886 return stb.i0;
2887 }
2888 }
2889 }
2890
2891 LOGICAL
pure_func_call(int func_ast)2892 pure_func_call(int func_ast)
2893 {
2894 int entry;
2895 int iface;
2896 entry = procsym_of_ast(A_LOPG(func_ast));
2897 proc_arginfo(entry, NULL, NULL, &iface);
2898 if (iface && PUREG(iface))
2899 return TRUE;
2900 return FALSE;
2901 }
2902
2903 LOGICAL
elemental_func_call(int func_ast)2904 elemental_func_call(int func_ast)
2905 {
2906 int entry;
2907 int iface;
2908 entry = procsym_of_ast(A_LOPG(func_ast));
2909 proc_arginfo(entry, NULL, NULL, &iface);
2910 if (iface && ELEMENTALG(iface))
2911 return TRUE;
2912 return FALSE;
2913 }
2914
2915 /** \brief Return sptr of an A_SUBSCR */
2916 int
sptr_of_subscript(int ast)2917 sptr_of_subscript(int ast)
2918 {
2919 int sptr;
2920
2921 assert(A_TYPEG(ast) == A_SUBSCR, "sptr_of_subscript: not a subscript", ast,
2922 4);
2923 ast = A_LOPG(ast);
2924 sptr = 0;
2925 if (A_TYPEG(ast) == A_ID)
2926 sptr = A_SPTRG(ast);
2927 else if (A_TYPEG(ast) == A_MEM)
2928 sptr = A_SPTRG(A_MEMG(ast));
2929 else if (A_TYPEG(ast) == A_SUBSCR)
2930 sptr = sptr_of_subscript(ast);
2931 else if (A_TYPEG(ast) == A_CONV)
2932 sptr = memsym_of_ast(ast);
2933 else
2934 assert(0, "sptr_of_subscript: unknown type", ast, 4);
2935 return sptr;
2936 } /* sptr_of_subscript */
2937
2938 /** \brief Return the leftmost array symbol.
2939
2940 + for `a%%b(i)%%c%%d(j)%%e`, it will return `b`
2941 + for `a(i)%%d(j)`, it will return `a`
2942 + for `a(i)%%d`, it will return `a`
2943 + for `a%%b%%c%%d(i)`, it will return `d`
2944 + for scalar `a%%b`, it will return `a`
2945 */
2946 int
left_array_symbol(int ast)2947 left_array_symbol(int ast)
2948 {
2949 int a, asym = 0;
2950
2951 a = A_ALIASG(ast);
2952 if (a)
2953 return A_SPTRG(a);
2954 while (1) {
2955 int sptr;
2956 switch (A_TYPEG(ast)) {
2957 case A_ID:
2958 sptr = A_SPTRG(ast);
2959 if (DTY(DTYPEG(sptr)) == TY_ARRAY)
2960 return sptr;
2961 /* FALLTHROUGH */
2962 case A_LABEL:
2963 case A_ENTRY:
2964 if (asym)
2965 return asym;
2966 return A_SPTRG(ast);
2967 case A_SUBSTR:
2968 ast = A_LOPG(ast);
2969 break;
2970 case A_MEM:
2971 sptr = A_SPTRG(A_MEMG(ast));
2972 if (DTY(DTYPEG(sptr)) == TY_ARRAY)
2973 asym = sptr;
2974 ast = A_PARENTG(ast);
2975 break;
2976 case A_SUBSCR:
2977 ast = A_LOPG(ast);
2978 if (A_TYPEG(ast) == A_MEM) {
2979 asym = A_SPTRG(A_MEMG(ast));
2980 ast = A_PARENTG(ast);
2981 } else if (A_TYPEG(ast) == A_ID) {
2982 asym = A_SPTRG(ast);
2983 return asym;
2984 }
2985 break;
2986 default:
2987 interr("left_array_of_ast:unexpected ast type", ast, 3);
2988 break;
2989 }
2990 }
2991 }
2992
2993 /** \brief Return the AST of the leftmost A_SUBSCR:
2994
2995 + For `a%%b(i)%%c%%d(j)%%e`, it will return the AST of `a%%b(i)`
2996 + For `a(i)%%d(j)`, it will return the AST of `a(i)`
2997 + For `a(i)%%d`, it will return the AST of `a(i)`
2998 + For `a%%b%%c%%d(i)`, it will return `a%%b%%c%%d(i)`
2999 + For scalar `a%%b`, it will return `a`
3000 */
3001 int
left_subscript_ast(int ast)3002 left_subscript_ast(int ast)
3003 {
3004 int aleft = 0;
3005 while (1) {
3006 int sptr;
3007 switch (A_TYPEG(ast)) {
3008 case A_ID:
3009 sptr = A_SPTRG(ast);
3010 if (DTY(DTYPEG(sptr)) == TY_ARRAY) {
3011 interr("left_subscript_ast: found unsubscripted array ID", ast, 3);
3012 }
3013 case A_LABEL:
3014 case A_ENTRY:
3015 if (aleft)
3016 return aleft;
3017 interr("left_subscript_ast: no subscripts", ast, 3);
3018 return ast;
3019 case A_SUBSTR:
3020 ast = A_LOPG(ast);
3021 break;
3022 case A_MEM:
3023 sptr = A_SPTRG(A_MEMG(ast));
3024 if (DTY(DTYPEG(sptr)) == TY_ARRAY) {
3025 interr("left_subscript_ast: found unsubscripted array MEM", ast, 3);
3026 }
3027 ast = A_PARENTG(ast);
3028 break;
3029 case A_SUBSCR:
3030 aleft = ast;
3031 ast = A_LOPG(ast);
3032 /* skip over the 'parent' of a subscript, since its
3033 * symbol will be an array, and we want to save the A_SUBSCR,
3034 not the A_ID or A_MEM */
3035 if (A_TYPEG(ast) == A_MEM) {
3036 ast = A_PARENTG(ast);
3037 } else if (A_TYPEG(ast) == A_ID) {
3038 return aleft;
3039 }
3040 break;
3041 default:
3042 interr("left_subscript_ast:unexpected ast type", ast, 3);
3043 return aleft;
3044 }
3045 }
3046 }
3047
3048 /** \brief This routine is similar to left_subscript_ast except it
3049 returns the leftmost non-scalar subscript.
3050
3051 For `a(1)%%b(i)` return `b(i)`
3052 */
3053 int
left_nonscalar_subscript_ast(int ast)3054 left_nonscalar_subscript_ast(int ast)
3055 {
3056 int aleft = 0;
3057 int i, sub, ndim;
3058 while (1) {
3059 int sptr;
3060 switch (A_TYPEG(ast)) {
3061 case A_ID:
3062 sptr = A_SPTRG(ast);
3063 if (DTY(DTYPEG(sptr)) == TY_ARRAY) {
3064 interr("left_nonscalar_subscript_ast:"
3065 " found unsubscripted array ID",
3066 ast, 3);
3067 }
3068 case A_LABEL:
3069 case A_ENTRY:
3070 if (aleft)
3071 return aleft;
3072 interr("left_nonscalar_subscript_ast: no subscripts", ast, 3);
3073 return ast;
3074 case A_SUBSTR:
3075 ast = A_LOPG(ast);
3076 break;
3077 case A_MEM:
3078 sptr = A_SPTRG(A_MEMG(ast));
3079 if (DTY(DTYPEG(sptr)) == TY_ARRAY) {
3080 interr("left_nonscalr_subscript_ast:"
3081 " found unsubscripted array MEM",
3082 ast, 3);
3083 }
3084 ast = A_PARENTG(ast);
3085 break;
3086 case A_SUBSCR:
3087 /* check subscripts -- make sure they're not all constant */
3088 sub = A_ASDG(ast);
3089 ndim = ASD_NDIM(sub);
3090 for (i = 0; i < ndim; ++i) {
3091 if (A_TYPEG(ASD_SUBS(sub, i)) != A_CNST) {
3092 aleft = ast;
3093 break;
3094 }
3095 }
3096 ast = A_LOPG(ast);
3097 /* skip over the 'parent' of a subscript, since its
3098 * symbol will be an array, and we want to save the A_SUBSCR,
3099 not the A_ID or A_MEM */
3100 if (A_TYPEG(ast) == A_MEM) {
3101 ast = A_PARENTG(ast);
3102 } else if (A_TYPEG(ast) == A_ID) {
3103 return aleft;
3104 }
3105 break;
3106 default:
3107 interr("left_nonscalar_subscript_ast:unexpected ast type", ast, 3);
3108 return aleft;
3109 }
3110 }
3111 }
3112
3113 /** \brief Return the AST of the leftmost A_SUBSCR or A_ID that is distributed
3114 or aligned.
3115
3116 For `a%%b(i)%%c%%d(j)%%e`, it will return the AST of
3117 `%%e`, `d(j)`, `%%c`, `b(i)`, or `a`, depending on which is distributed.
3118 */
3119 int
dist_ast(int ast)3120 dist_ast(int ast)
3121 {
3122 int nextast, sptr, aleft;
3123 for (; ast; ast = nextast) {
3124 nextast = sptr = 0;
3125 switch (A_TYPEG(ast)) {
3126 case A_ID:
3127 sptr = A_SPTRG(ast);
3128 break;
3129 case A_SUBSTR:
3130 nextast = A_LOPG(ast);
3131 break;
3132 case A_MEM:
3133 sptr = A_SPTRG(A_MEMG(ast));
3134 nextast = A_PARENTG(ast);
3135 break;
3136 case A_SUBSCR:
3137 aleft = A_LOPG(ast);
3138 /* skip over the 'parent' of a subscript, since its
3139 * symbol will be an array, and we want to save the A_SUBSCR,
3140 not the A_ID or A_MEM */
3141 if (A_TYPEG(aleft) == A_MEM) {
3142 sptr = A_SPTRG(A_MEMG(aleft));
3143 nextast = A_PARENTG(aleft);
3144 } else if (A_TYPEG(aleft) == A_ID) {
3145 sptr = A_SPTRG(aleft);
3146 } else {
3147 interr("dist_ast: found naked subscript", ast, 3);
3148 return 0;
3149 }
3150 break;
3151 default:
3152 interr("dist_ast:unexpected ast type", ast, 3);
3153 }
3154 if (sptr) {
3155 switch (STYPEG(sptr)) {
3156 case ST_VAR:
3157 case ST_ARRAY:
3158 case ST_MEMBER:
3159 if (DISTG(sptr) || ALIGNG(sptr))
3160 return ast;
3161 default:;
3162 }
3163 }
3164 }
3165 return 0;
3166 } /* dist_ast */
3167
3168 static LOGICAL
stride1_triple(int triple)3169 stride1_triple(int triple)
3170 {
3171 #if DEBUG
3172 assert(A_TYPEG(triple) == A_TRIPLE, "stride1_triple: not A_TRIPLE", triple,
3173 4);
3174 #endif
3175 if (A_STRIDEG(triple) && A_STRIDEG(triple) != astb.i1 &&
3176 A_STRIDEG(triple) != astb.bnd.one)
3177 return FALSE;
3178 return TRUE;
3179 }
3180
3181 /* contiguous_array_section is a simple 3 state state machine (the 3rd state,
3182 * FALSE, is implicit).
3183 * |inputs
3184 *state |DIM_WHOLE| DIM_TRIPLE | DIM_ELMNT
3185 *---------------------|--------------------------------------------------
3186 *START | START | TRIPLE_SNGL_ELEM_SEEN|
3187 *TRIPLE_SNGL_ELEM_SEEN| FALSE | FALSE | TRIPLE_SNGL_ELEM_SEEN
3188 */
3189 static LOGICAL
contiguous_array_section(int subscr_ast)3190 contiguous_array_section(int subscr_ast)
3191 {
3192 enum { START, TRIPLE_SNGL_ELEM_SEEN } state;
3193 enum {
3194 DIM_WHOLE, /* ":" */
3195 DIM_TRIPLE, /* "lb:ub:", no stride allowed */
3196 DIM_ELMNT, /* "indx" */
3197 DONT_CARE,
3198 } tkn;
3199
3200 int asd;
3201 int ndims, dim;
3202 int sptr;
3203 int ast;
3204
3205 asd = A_ASDG(subscr_ast);
3206 ndims = ASD_NDIM(asd);
3207
3208 state = START;
3209 for (dim = 0; dim < ndims; dim++) {
3210 ast = ASD_SUBS(asd, dim);
3211 switch (A_TYPEG(ast)) {
3212 case A_ID:
3213 case A_MEM:
3214 case A_SUBSCR:
3215 case A_FUNC:
3216 if (A_SHAPEG(ast))
3217 return FALSE;
3218 /* FALL THRU */
3219 case A_CNST:
3220 case A_BINOP:
3221 case A_UNOP:
3222 tkn = DIM_ELMNT;
3223 break;
3224 case A_TRIPLE:
3225 if (is_whole_dim(subscr_ast, dim))
3226 tkn = DIM_WHOLE;
3227 else if (stride1_triple(ast))
3228 tkn = DIM_TRIPLE;
3229 else
3230 return FALSE;
3231 break;
3232 case A_CONV:
3233 tkn = DONT_CARE;
3234 break;
3235 default:
3236 interr("contiguous_array_section: unexpected dimension type", 0, 3);
3237 }
3238
3239 switch (state) {
3240 case START:
3241 if (tkn == DIM_TRIPLE || tkn == DIM_ELMNT)
3242 state = TRIPLE_SNGL_ELEM_SEEN;
3243 break;
3244 case TRIPLE_SNGL_ELEM_SEEN:
3245 if (tkn != DIM_ELMNT)
3246 return FALSE;
3247 break;
3248 }
3249 }
3250 return TRUE;
3251 }
3252
3253 /** \brief Determine if array \a arr_ast covers all extent at dim i
3254
3255 For example, on `a(1,:)` return true for second dim.
3256 */
3257 LOGICAL
is_whole_dim(int arr_ast,int i)3258 is_whole_dim(int arr_ast, int i)
3259 {
3260 ADSC *ad;
3261 int asd;
3262 int sptr;
3263 int st, sub;
3264 int descr;
3265 int lb;
3266 int up;
3267 int ad_lwast;
3268 int ad_upast;
3269
3270 assert(A_TYPEG(arr_ast) == A_SUBSCR, "is_whole_dim: must be SUBSCR", 2,
3271 arr_ast);
3272 asd = A_ASDG(arr_ast);
3273 sptr = memsym_of_ast(arr_ast);
3274 ad = AD_DPTR(DTYPEG(sptr));
3275 sub = ASD_SUBS(asd, i);
3276 if (A_TYPEG(sub) != A_TRIPLE)
3277 return FALSE;
3278
3279 descr = SDSCG(sptr);
3280 lb = A_LBDG(sub);
3281 up = A_UPBDG(sub);
3282 ad_lwast = check_member(arr_ast, AD_LWAST(ad, i));
3283 ad_upast = check_member(arr_ast, AD_UPAST(ad, i));
3284 if (ASSUMSHPG(sptr) && ad_lwast != lb && lb != astb.i1 &&
3285 lb != astb.bnd.one) {
3286 return FALSE;
3287 } else if (STYPEG(sptr) == ST_MEMBER && (ad_lwast != lb || ad_upast != up)) {
3288 /* a member whole dim looks like
3289 * lb = <descr>[i].lb
3290 * up = <descr>[i].up - <descr>[i].lb + 1
3291 * look for these patterns (does the following look for enough
3292 * of these patterns?)
3293 */
3294 if (A_TYPEG(lb) != A_SUBSCR || memsym_of_ast(lb) != descr) {
3295 return FALSE;
3296 }
3297 if (A_TYPEG(up) == A_BINOP) {
3298 if (A_TYPEG(A_LOPG(up)) != A_SUBSCR ||
3299 memsym_of_ast(A_LOPG(up)) != descr) {
3300 return FALSE;
3301 }
3302 if (A_TYPEG(A_ROPG(up)) != A_BINOP ||
3303 A_TYPEG(A_LOPG(A_ROPG(up))) != A_SUBSCR ||
3304 memsym_of_ast(A_LOPG(A_ROPG(up))) != descr) {
3305 return FALSE;
3306 }
3307 } else {
3308 return FALSE;
3309 }
3310 } else if (ad_lwast != lb || ad_upast != up) {
3311 return FALSE;
3312 }
3313
3314 st = A_STRIDEG(sub);
3315 if (st != 0 && st != astb.i1 && st != astb.bnd.one)
3316 return FALSE;
3317 return TRUE;
3318 }
3319
3320 LOGICAL
is_whole_array(int arr_ast)3321 is_whole_array(int arr_ast)
3322 {
3323 int shape, lop, sptr, ndim, i, dtype;
3324
3325 assert(A_TYPEG(arr_ast) == A_SUBSCR, "is_whole_array: must be SUBSCR",
3326 arr_ast, 2);
3327 if (A_TYPEG(arr_ast) == A_SUBSCR) {
3328 lop = A_LOPG(arr_ast);
3329 } else {
3330 lop = arr_ast;
3331 }
3332 switch (A_TYPEG(lop)) {
3333 case A_ID:
3334 sptr = A_SPTRG(lop);
3335 lop = 0;
3336 break;
3337 case A_MEM:
3338 sptr = A_SPTRG(A_MEMG(lop));
3339 lop = A_PARENTG(lop);
3340 break;
3341 default:
3342 interr("is_whole_array: subscript error", arr_ast, 4);
3343 }
3344
3345 shape = A_SHAPEG(arr_ast);
3346 if (shape == 0)
3347 return FALSE;
3348 ndim = SHD_NDIM(shape);
3349 if (ndim != rank_of_sym(sptr))
3350 return FALSE;
3351 dtype = DTYPEG(sptr);
3352 for (i = 0; i < ndim; ++i) {
3353 int stride;
3354 stride = SHD_STRIDE(shape, i);
3355 if (stride != 0 && stride != astb.i1)
3356 return FALSE;
3357 /* some array expressions of the form a(:) will have ADD_LWBD==0
3358 * but ADD_LWAST wiil be set */
3359 if (ADD_LWBD(dtype, i) != 0) {
3360 if (!bounds_match(ADD_LWBD(dtype, i), SHD_LWB(shape, i), lop))
3361 return FALSE;
3362 } else if (!bounds_match(ADD_LWAST(dtype, i), SHD_LWB(shape, i), lop)) {
3363 return FALSE;
3364 }
3365 if (!bounds_match(ADD_UPBD(dtype, i), SHD_UPB(shape, i), lop))
3366 return FALSE;
3367 }
3368 return TRUE;
3369 } /* is_whole_array */
3370
3371 /* for normal array, lwdtype will be expression or section descriptor.
3372 * for derived type member, lwdtype will be LW$SD(29) or some such,
3373 * while lwshape will be X%LW$SD(29) or some such. Make sure
3374 * the X% matches the parent, while the LW$SD(29) matches also
3375 */
3376 static LOGICAL
bounds_match(int lwdtype,int lwshape,int parent)3377 bounds_match(int lwdtype, int lwshape, int parent)
3378 {
3379 if (lwdtype == lwshape)
3380 return TRUE;
3381 if (A_TYPEG(lwdtype) == A_SUBSCR && A_TYPEG(lwshape) == A_SUBSCR) {
3382 /* see if these are section descriptor references */
3383 int adtype, ashape;
3384 adtype = A_LOPG(lwdtype);
3385 ashape = A_LOPG(lwshape);
3386 if (A_TYPEG(adtype) == A_ID && A_TYPEG(ashape) == A_MEM) {
3387 int asddtype, asdshape, ssdtype, ssshape;
3388 if (A_PARENTG(ashape) != parent)
3389 return FALSE;
3390 if (A_SPTRG(adtype) != A_SPTRG(A_MEMG(ashape)))
3391 return FALSE;
3392 asddtype = A_ASDG(lwdtype);
3393 asdshape = A_ASDG(lwshape);
3394 if (ASD_NDIM(asddtype) != 1 || ASD_NDIM(asdshape) != 1)
3395 return FALSE;
3396 if (ASD_SUBS(asddtype, 0) != ASD_SUBS(asdshape, 0))
3397 return FALSE;
3398 /* yes, shape is X%P$SD(n) and dtype is P$SD(n) */
3399 return TRUE;
3400 }
3401 }
3402 return FALSE;
3403 } /* bounds_match */
3404
3405 LOGICAL
simply_contiguous(int arr_ast)3406 simply_contiguous(int arr_ast)
3407 {
3408 int sptr;
3409
3410 switch (A_TYPEG(arr_ast)) {
3411 case A_ID:
3412 sptr = sym_of_ast(arr_ast);
3413 if (POINTERG(sptr) || ASSUMSHPG(sptr))
3414 return CONTIGATTRG(sptr);
3415 return TRUE;
3416 case A_FUNC:
3417 sptr = sym_of_ast(arr_ast);
3418 return !POINTERG(sptr);
3419 case A_SUBSTR:
3420 return FALSE;
3421 case A_MEM:
3422 sptr = sym_of_ast(arr_ast);
3423 if (!DT_ISCMPLX(STYPEG(sptr))) {
3424 sptr = memsym_of_ast(arr_ast);
3425 if (POINTERG(sptr) || ASSUMSHPG(sptr))
3426 return CONTIGATTRG(sptr);
3427 }
3428 break;
3429 case A_SUBSCR:
3430 return contiguous_array_section(arr_ast);
3431 }
3432
3433 return FALSE;
3434 }
3435
3436 LOGICAL
bnds_remap_list(int subscr_ast)3437 bnds_remap_list(int subscr_ast)
3438 {
3439 int asd;
3440 int ndims, dim;
3441 int sptr;
3442 int ast;
3443
3444 if (A_TYPEG(subscr_ast) != A_SUBSCR) {
3445 return FALSE;
3446 }
3447
3448 asd = A_ASDG(subscr_ast);
3449 ndims = ASD_NDIM(asd);
3450 for (dim = 0; dim < ndims; dim++) {
3451 ast = ASD_SUBS(asd, dim);
3452 if (A_TYPEG(ast) == A_TRIPLE) {
3453 if (A_UPBDG(ast)) {
3454 return TRUE;
3455 }
3456 }
3457 }
3458 return FALSE;
3459 }
3460
3461 /** \brief In \a original replace \a subtree with \a replacement.
3462 \param original `a%%b(i)%%c%%d(j)%%e`
3463 \param subtree `a%%b(i)`
3464 \param replacement `a%%b(1:2)`
3465 \return New ast: `a%%b(1:2)%%c%%d(j)%%e`
3466 */
3467 int
replace_ast_subtree(int original,int subtree,int replacement)3468 replace_ast_subtree(int original, int subtree, int replacement)
3469 {
3470 int p, ast, subs[MAXRANK], nsubs, i, asd, dtype;
3471 /* only A_ID, A_SUBSCR, A_SUBSTR, A_MEM allowed */
3472 if (subtree == replacement) /* in a%b(1)%j replace a%b(1) by a%b(1) */
3473 return original;
3474 if (subtree == original) /* in a%b(1) replace a%b(1) by a%b(i:j) */
3475 return replacement;
3476 switch (A_TYPEG(original)) {
3477 case A_SUBSTR:
3478 p = replace_ast_subtree(A_LOPG(original), subtree, replacement);
3479 ast =
3480 mk_substr(p, A_LEFTG(original), A_RIGHTG(original), A_DTYPEG(original));
3481 return ast;
3482 case A_SUBSCR:
3483 p = replace_ast_subtree(A_LOPG(original), subtree, replacement);
3484 asd = A_ASDG(original);
3485 nsubs = ASD_NDIM(asd);
3486 for (i = 0; i < nsubs; ++i)
3487 subs[i] = ASD_SUBS(asd, i);
3488 ast = mk_subscr(p, subs, nsubs, A_DTYPEG(original));
3489 return ast;
3490 case A_MEM:
3491 p = replace_ast_subtree(A_PARENTG(original), subtree, replacement);
3492 dtype = A_DTYPEG(original);
3493 if (A_SHAPEG(A_PARENTG(original)) && !A_SHAPEG(p))
3494 /*
3495 * the parent has shape, not the member, so the type of the new member
3496 * tree needs to be scalar.
3497 */
3498 dtype = DDTG(dtype);
3499 ast = mk_member(p, A_MEMG(original), dtype);
3500 return ast;
3501 case A_ID:
3502 /* should not get here, the replacement should have
3503 * replaced the original by now */
3504 interr("replace_ast_subtree: unexpected ID ast", original, 3);
3505 default:
3506 interr("replace_ast_subtree: unexpected ast type", original, 3);
3507 }
3508 return replacement;
3509 } /* replace_ast_subtree */
3510
3511 /** \brief Given an ast, return an ast with the element size */
3512 int
elem_size_of_ast(int ast)3513 elem_size_of_ast(int ast)
3514 {
3515 DTYPE dtype;
3516 int bytes;
3517 int i;
3518 int is_arr = 0;
3519
3520 dtype = A_DTYPEG(ast);
3521
3522 if (DTY(dtype) == TY_ARRAY) {
3523 is_arr = 1;
3524 dtype = DTY(dtype + 1);
3525 }
3526
3527 if (DTY(dtype) == TY_CHAR) {
3528 if (dtype != DT_ASSCHAR && dtype != DT_DEFERCHAR)
3529 bytes = mk_isz_cval(size_of(dtype), astb.bnd.dtype);
3530 else {
3531 if (!is_arr)
3532 i = sym_mkfunc_nodesc(mkRteRtnNm(RTE_lena), astb.bnd.dtype);
3533 else
3534 i = sym_mkfunc_nodesc_expst(mkRteRtnNm(RTE_lena), astb.bnd.dtype);
3535 bytes = begin_call(A_FUNC, i, 1);
3536 add_arg(ast);
3537 }
3538 }
3539 else if (DTY(dtype) == TY_NCHAR) {
3540 if (dtype != DT_ASSNCHAR && dtype != DT_DEFERNCHAR)
3541 bytes = mk_isz_cval(size_of(dtype), astb.bnd.dtype);
3542 else {
3543 if (!is_arr)
3544 i = sym_mkfunc_nodesc(mkRteRtnNm(RTE_nlena), astb.bnd.dtype);
3545 else
3546 i = sym_mkfunc_nodesc_expst(mkRteRtnNm(RTE_nlena), astb.bnd.dtype);
3547 bytes = begin_call(A_FUNC, i, 1);
3548 add_arg(ast);
3549 }
3550 }
3551 else {
3552 bytes = mk_isz_cval(size_of(dtype), astb.bnd.dtype);
3553 }
3554
3555 return bytes;
3556 }
3557
3558 int
size_of_ast(int ast)3559 size_of_ast(int ast)
3560 {
3561 int shape;
3562 int ndim;
3563 int i;
3564 int sz;
3565 int tmp;
3566
3567 shape = A_SHAPEG(ast);
3568 if (shape == 0)
3569 return astb.bnd.one;
3570 ndim = SHD_NDIM(shape);
3571 sz = astb.bnd.one;
3572 for (i = 0; i < ndim; i++) {
3573 int t;
3574 tmp = mk_binop(OP_SUB, check_member(ast, (int)SHD_UPB(shape, i)),
3575 check_member(ast, (int)SHD_LWB(shape, i)), astb.bnd.dtype);
3576 t = check_member(ast, (int)SHD_STRIDE(shape, i));
3577 tmp = mk_binop(OP_ADD, tmp, t, astb.bnd.dtype);
3578 tmp = mk_binop(OP_DIV, tmp, t, astb.bnd.dtype);
3579 sz = mk_binop(OP_MUL, sz, tmp, astb.bnd.dtype);
3580 }
3581 return sz;
3582 }
3583
3584 int
mk_bnd_ast(void)3585 mk_bnd_ast(void)
3586 {
3587 int bnd;
3588
3589 if (XBIT(68, 0x1))
3590 bnd = getcctmp('b', atemps++, ST_VAR, DT_INT8);
3591 else
3592 bnd = getcctmp('b', atemps++, ST_VAR, DT_INT4);
3593 SCP(bnd, SC_LOCAL);
3594 CCSYMP(bnd, 1);
3595 return mk_id(bnd);
3596 }
3597
3598 /** \brief Create a shared bounds temporary.
3599 \param ast the AST of the bounds expression which will be stored in the temp
3600
3601 The same temp will be used for multiple uses of an expression.
3602 */
3603 int
mk_shared_bnd_ast(int ast)3604 mk_shared_bnd_ast(int ast)
3605 {
3606 int bnd;
3607 if (XBIT(68, 0x1))
3608 bnd = getcctmp('e', ast, ST_VAR, DT_INT8);
3609 else
3610 bnd = getcctmp('e', ast, ST_VAR, DT_INT4);
3611 SCP(bnd, SC_LOCAL);
3612 CCSYMP(bnd, 1);
3613 /*ADDRTKNP(bnd, 1); should be unnecssary since optutil.c considers
3614 * scalar temps (HCCSYM is set) as 'implicitly live'.
3615 */
3616 return mk_id(bnd);
3617 }
3618
3619 int
mk_stmt(int stmt_type,DTYPE dtype)3620 mk_stmt(int stmt_type, DTYPE dtype)
3621 {
3622 int ast;
3623
3624 ast = new_node(stmt_type);
3625 if (dtype)
3626 A_DTYPEP(ast, dtype);
3627 return ast;
3628 }
3629
3630 int
mk_std(int ast)3631 mk_std(int ast)
3632 {
3633 int std;
3634
3635 std = STG_NEXT(astb.std);
3636 if (std > MAXAST || astb.std.stg_base == NULL)
3637 errfatal(7);
3638 STD_AST(std) = ast; /* link std to ast */
3639 A_STDP(ast, std); /* link ast to std */
3640 return std;
3641 }
3642
3643 int
add_stmt(int ast)3644 add_stmt(int ast)
3645 {
3646 int std;
3647
3648 std = mk_std(ast);
3649
3650 insert_stmt_before(std, 0);
3651 if (gbl.in_include) {
3652 STD_LINENO(std) = gbl.lineno;
3653 STD_FINDEX(std) = gbl.findex;
3654 STD_ORIG(std) = 1;
3655 } else {
3656 STD_LINENO(std) = gbl.lineno;
3657 STD_FINDEX(std) = gbl.findex;
3658 }
3659 if (scn.currlab && !DEFDG(scn.currlab)) {
3660 STD_LABEL(std) = scn.currlab;
3661 DEFDP(scn.currlab, 1);
3662 } else
3663 STD_LABEL(std) = 0;
3664
3665 return std;
3666 }
3667
3668 static void
set_par(int std)3669 set_par(int std)
3670 {
3671 int bef, aft;
3672 bef = STD_PREV(std);
3673 aft = STD_NEXT(std);
3674 if (bef && aft) {
3675 if (STD_PAR(bef) && STD_PAR(aft))
3676 STD_PAR(std) = 1;
3677 if (STD_TASK(bef) && STD_TASK(aft))
3678 STD_TASK(std) = 1;
3679 }
3680 }
3681
3682 int
add_stmt_after(int ast,int stmt)3683 add_stmt_after(int ast, int stmt)
3684 {
3685 int std;
3686
3687 assert(ast, "add_stmt_after: sees ast of 0", ast, 2);
3688
3689 std = mk_std(ast);
3690 insert_stmt_after(std, stmt);
3691 if (flg.smp) {
3692 set_par(std);
3693 }
3694
3695 return std;
3696 }
3697
3698 int
add_stmt_before(int ast,int stmt)3699 add_stmt_before(int ast, int stmt)
3700 {
3701 int std;
3702
3703 assert(ast, "add_stmt_before: sees ast of 0", ast, 2);
3704
3705 std = mk_std(ast);
3706
3707 insert_stmt_before(std, stmt);
3708 if (flg.smp) {
3709 set_par(std);
3710 }
3711
3712 return std;
3713 }
3714
3715 /* Insert std into STD list after stdafter; copy lineno and findex from stdafter
3716 * to std. */
3717 void
insert_stmt_after(int std,int stdafter)3718 insert_stmt_after(int std, int stdafter)
3719 {
3720 STD_PREV(std) = stdafter;
3721 STD_NEXT(std) = STD_NEXT(stdafter);
3722 STD_PREV(STD_NEXT(stdafter)) = std;
3723 STD_NEXT(stdafter) = std;
3724 STD_LINENO(std) = STD_LINENO(stdafter);
3725 STD_FINDEX(std) = STD_FINDEX(stdafter);
3726 }
3727
3728 /* Insert std into STD list before stdbefore; copy lineno and findex from
3729 * stdbefore
3730 * to std. */
3731 void
insert_stmt_before(int std,int stdbefore)3732 insert_stmt_before(int std, int stdbefore)
3733 {
3734 STD_NEXT(std) = stdbefore;
3735 STD_PREV(std) = STD_PREV(stdbefore);
3736 STD_NEXT(STD_PREV(stdbefore)) = std;
3737 STD_PREV(stdbefore) = std;
3738 STD_LINENO(std) = STD_LINENO(stdbefore);
3739 STD_FINDEX(std) = STD_FINDEX(stdbefore);
3740 }
3741
3742 /* Remove std from the STD list. */
3743 void
remove_stmt(int std)3744 remove_stmt(int std)
3745 {
3746 int prev = STD_PREV(std);
3747 int next = STD_NEXT(std);
3748 #if DEBUG
3749 if (STD_NEXT(prev) != std || STD_PREV(next) != std) {
3750 interr("remove_stmt: corrupt STD or deleting statement twice", std,
3751 ERR_Severe);
3752 return;
3753 }
3754 #endif
3755 STD_NEXT(prev) = next;
3756 STD_PREV(next) = prev;
3757 /* clear the pointers so we don't delete the statement twice */
3758 STD_NEXT(std) = 0;
3759 STD_PREV(std) = 0;
3760 }
3761
3762 /* Move std(s) before stdbefore */
3763 void
move_range_before(int sstd,int estd,int stdbefore)3764 move_range_before(int sstd, int estd, int stdbefore)
3765 {
3766 if (!(sstd && estd && stdbefore))
3767 return;
3768
3769 STD_NEXT(STD_PREV(sstd)) = STD_NEXT(estd);
3770 STD_PREV(STD_NEXT(estd)) = STD_PREV(sstd);
3771
3772 if (sstd == estd) {
3773 insert_stmt_before(sstd, stdbefore);
3774 } else {
3775 STD_NEXT(STD_PREV(stdbefore)) = sstd;
3776 STD_PREV(sstd) = STD_PREV(stdbefore);
3777 STD_PREV(stdbefore) = estd;
3778 STD_NEXT(estd) = stdbefore;
3779 }
3780 }
3781
3782 /* Move std(s) after stdafter */
3783 void
move_range_after(int sstd,int estd,int stdafter)3784 move_range_after(int sstd, int estd, int stdafter)
3785 {
3786 if (!(sstd && estd && stdafter))
3787 return;
3788
3789 STD_NEXT(STD_PREV(sstd)) = STD_NEXT(estd);
3790 STD_PREV(STD_NEXT(estd)) = STD_PREV(sstd);
3791
3792 if (sstd == estd) {
3793 insert_stmt_after(sstd, stdafter);
3794 } else {
3795 STD_PREV(STD_NEXT(stdafter)) = estd;
3796 STD_NEXT(estd) = STD_NEXT(stdafter);
3797 STD_NEXT(stdafter) = sstd;
3798 STD_PREV(sstd) = stdafter;
3799 }
3800 }
3801
3802 /* Move all STDs starting with std to before stdbefore */
3803 void
move_stmts_before(int std,int stdbefore)3804 move_stmts_before(int std, int stdbefore)
3805 {
3806 int stdnext;
3807 for (; std != 0; std = stdnext) {
3808 stdnext = STD_NEXT(std);
3809 remove_stmt(std);
3810 insert_stmt_before(std, stdbefore);
3811 if (flg.smp) {
3812 set_par(std);
3813 }
3814 }
3815 }
3816
3817 /* Move all STDs starting with std to after stdafter */
3818 void
move_stmts_after(int std,int stdafter)3819 move_stmts_after(int std, int stdafter)
3820 {
3821 int stdnext;
3822 for (; std != 0; std = stdnext) {
3823 stdnext = STD_NEXT(std);
3824 remove_stmt(std);
3825 insert_stmt_after(std, stdafter);
3826 if (flg.smp) {
3827 set_par(std);
3828 }
3829 }
3830 }
3831
3832 void
ast_to_comment(int ast)3833 ast_to_comment(int ast)
3834 {
3835 int std = A_STDG(ast);
3836 int par = STD_PAR(std);
3837 int accel = STD_ACCEL(std);
3838 int newast = mk_stmt(A_COMMENT, 0);
3839
3840 A_LOPP(newast, ast);
3841 STD_AST(std) = newast;
3842 A_STDP(newast, std);
3843 STD_FLAGS(std) = 0;
3844 STD_PAR(std) = par;
3845 STD_ACCEL(std) = accel;
3846 }
3847
3848 int
mk_comstr(char * str)3849 mk_comstr(char *str)
3850 {
3851 int newast;
3852 INT indx;
3853
3854 newast = mk_stmt(A_COMSTR, 0);
3855 indx = astb.comstr.stg_avail;
3856 A_COMPTRP(newast, indx);
3857 astb.comstr.stg_avail += strlen(str) + 1;
3858 NEED(astb.comstr.stg_avail, astb.comstr.stg_base, char, astb.comstr.stg_size,
3859 astb.comstr.stg_avail + 200);
3860 strcpy(COMSTR(newast), str);
3861 astb.comstr.stg_base[indx] = '!';
3862
3863 return newast;
3864 }
3865
3866 /** \brief Create an ARGT
3867 \param cnt number of arguments in the ARGT
3868 */
3869 int
mk_argt(int cnt)3870 mk_argt(int cnt)
3871 {
3872 int argt;
3873
3874 if (cnt == 0)
3875 return 0;
3876 argt = astb.argt.stg_avail;
3877 astb.argt.stg_avail += cnt + 1;
3878 NEED(astb.argt.stg_avail, astb.argt.stg_base, int, astb.argt.stg_size, astb.argt.stg_avail + 200);
3879 if (argt > MAX_NMPTR || astb.argt.stg_base == NULL)
3880 errfatal(7);
3881 ARGT_CNT(argt) = cnt;
3882
3883 return argt;
3884 }
3885
3886 /**
3887 \param cnt Number of arguments in the ARGT
3888 */
3889 void
unmk_argt(int cnt)3890 unmk_argt(int cnt)
3891 {
3892 if (cnt == 0)
3893 return;
3894 astb.argt.stg_avail -= cnt + 1;
3895 } /* unmk_argt */
3896
3897 /* AST List (ASTLI) Management */
3898
3899 static int tail_astli; /* tail of ast list */
3900
3901 /** \brief Initalize for a new ast list.
3902
3903 The head of the list is stored in ast.astli.base[0].next
3904 and is accessed via the macro ASTLI_HEAD.
3905
3906 Call add_astli() to add items to the end of the list.
3907 */
3908 void
start_astli(void)3909 start_astli(void)
3910 {
3911 tail_astli = 0; /* no elements in the list */
3912 ASTLI_HEAD = 0;
3913 }
3914
3915 /** \brief Create and return an AST list item, adding it to the end of the
3916 current list.
3917 */
3918 int
add_astli(void)3919 add_astli(void)
3920 {
3921 int astli;
3922
3923 astli = astb.astli.stg_avail++;
3924 NEED(astb.astli.stg_avail, astb.astli.stg_base, ASTLI, astb.astli.stg_size,
3925 astb.astli.stg_size + 200);
3926 if (astli > MAX_NMPTR || astb.astli.stg_base == NULL)
3927 errfatal(7);
3928 ASTLI_NEXT(tail_astli) = astli;
3929 ASTLI_NEXT(astli) = 0;
3930 tail_astli = astli;
3931 ASTLI_FLAGS(astli) = 0;
3932
3933 return astli;
3934 }
3935
3936 static void
reset_astli(void)3937 reset_astli(void)
3938 {
3939 if (ASTLI_HEAD) {
3940 astb.astli.stg_avail = ASTLI_HEAD;
3941 ASTLI_HEAD = 0;
3942 }
3943 } /* reset_astli */
3944
3945 /**
3946 \param firstc first character in range
3947 \param lastc last character in range
3948 \param dtype implicit dtype pointer: 0 => NONE
3949 */
3950 void
ast_implicit(int firstc,int lastc,DTYPE dtype)3951 ast_implicit(int firstc, int lastc, DTYPE dtype)
3952 {
3953 int i, j;
3954
3955 if (dtype == 0)
3956 astb.implicit[54] = 1;
3957 else if (DTY(dtype) != TY_DERIVED) {
3958 i = IMPL_INDEX(firstc);
3959 j = IMPL_INDEX(lastc);
3960 for (; i <= j; i++)
3961 astb.implicit[i] = dtype;
3962 }
3963 }
3964
3965 /*-----------------------------------------------------------------------*/
3966
3967 static struct {
3968 int argt;
3969 int ast;
3970 int arg_num;
3971 int ast_type;
3972 int arg_count;
3973 } curr_call = {0, 0, 0, 0, 0};
3974
3975 /**
3976 \param ast_type A_FUNC, A_CALL, or A_INTR
3977 \param func sptr of function to invoke
3978 \param count number of arguments
3979 */
3980 int
begin_call(int ast_type,int func,int count)3981 begin_call(int ast_type, int func, int count)
3982 {
3983 int lop;
3984 /* make sure the previous call completed */
3985 if (curr_call.arg_num < curr_call.arg_count)
3986 interr("begin_call called before the previous procedure call completed",
3987 curr_call.arg_num, 3);
3988 curr_call.arg_count = count;
3989 curr_call.argt = mk_argt(count); /* mk_argt stuffs away count */
3990 curr_call.ast_type = ast_type;
3991 curr_call.ast = new_node(ast_type);
3992 lop = mk_id(func);
3993 A_LOPP(curr_call.ast, lop);
3994 A_ARGCNTP(curr_call.ast, count);
3995 A_ARGSP(curr_call.ast, curr_call.argt);
3996 if (ast_type == A_FUNC)
3997 A_CALLFGP(curr_call.ast, 1);
3998
3999 curr_call.arg_num = 0;
4000
4001 return curr_call.ast;
4002 }
4003
4004 /** \brief Add an argument
4005 \param arg AST of argument to add.
4006 */
4007 void
add_arg(int arg)4008 add_arg(int arg)
4009 {
4010 if (curr_call.arg_num >= curr_call.arg_count)
4011 interr("add_arg called with too many arguments, or one begin_call mixed in "
4012 "with another",
4013 curr_call.arg_num, ERR_Severe);
4014 ARGT_ARG(curr_call.argt, curr_call.arg_num) = arg;
4015 curr_call.arg_num++;
4016 if (A_CALLFGG(arg))
4017 A_CALLFGP(curr_call.ast, 1);
4018 }
4019
4020 /** \brief For an elemental intrinsic or function AST created by begin_call()
4021 and
4022 one or more calls to add_arg, fill in the result dtype and shape of the AST.
4023 \param dtype scalar dtype of the function/intrinsic
4024 \param promote if TRUE, promote the dtype to an array & create a shape
4025 descriptor
4026 */
4027 void
finish_args(DTYPE dtype,LOGICAL promote)4028 finish_args(DTYPE dtype, LOGICAL promote)
4029 {
4030 int shape;
4031
4032 shape = 0;
4033 if (promote) {
4034 dtype = get_array_dtype(1, dtype);
4035 shape = A_SHAPEG(ARGT_ARG(curr_call.argt, 0));
4036 }
4037 A_DTYPEP(curr_call.ast, dtype);
4038 A_SHAPEP(curr_call.ast, shape);
4039 }
4040
4041 int
mk_func_node(int ast_type,int func_ast,int paramct,int argt)4042 mk_func_node(int ast_type, int func_ast, int paramct, int argt)
4043 {
4044 int ast;
4045
4046 ast = new_node(ast_type);
4047 A_LOPP(ast, func_ast);
4048 A_ARGCNTP(ast, paramct);
4049 A_ARGSP(ast, argt);
4050 if (ast_type == A_INTR || ast_type == A_ICALL) {
4051 int i;
4052 for (i = 0; i < paramct; i++)
4053 if (ARGT_ARG(argt, i) && A_CALLFGG(ARGT_ARG(argt, i))) {
4054 A_CALLFGP(ast, 1);
4055 break;
4056 }
4057 } else
4058 A_CALLFGP(ast, 1);
4059
4060 return ast;
4061 }
4062
4063 int
mk_assn_stmt(int dest,int source,DTYPE dtype)4064 mk_assn_stmt(int dest, int source, DTYPE dtype)
4065 {
4066 int ast;
4067 ast = mk_stmt(A_ASN, dtype);
4068 A_DESTP(ast, dest);
4069 A_SRCP(ast, source);
4070 return ast;
4071 }
4072
4073 static int astMatch; /* AST # for matching */
4074
4075 /* This is the callback function for contains_ast(). */
4076 static LOGICAL
_contains_ast(int astTarg,LOGICAL * pflag)4077 _contains_ast(int astTarg, LOGICAL *pflag)
4078 {
4079 if (astMatch == astTarg) {
4080 *pflag = TRUE;
4081 return TRUE;
4082 }
4083 return FALSE;
4084 }
4085
4086 /** \brief Return TRUE if astSrc occurs somewhere within astTarg.
4087
4088 WARNING: This routine may not produce correct results for non-leaf
4089 AST's -- correctness depends on hashing capabilities.
4090 */
4091 LOGICAL
contains_ast(int astTarg,int astSrc)4092 contains_ast(int astTarg, int astSrc)
4093 {
4094 LOGICAL result = FALSE;
4095
4096 if (!astTarg)
4097 return FALSE;
4098
4099 astMatch = astSrc;
4100 ast_visit(1, 1);
4101 ast_traverse(astTarg, _contains_ast, NULL, &result);
4102 ast_unvisit();
4103 return result;
4104 }
4105
4106 /* general ast rewrite functions: uses a list to keep track of the ast nodes
4107 * which have been visited; if a node is visited, the node's REPL field
4108 * is the ast which replaces the node.
4109 */
4110
4111 static int visit_list = 0;
4112 static ast_visit_fn _visited;
4113
4114 int rewrite_opfields = 0;
4115
4116 #if DEBUG
4117 static LOGICAL ast_visit_state = FALSE;
4118 #endif
4119 static LOGICAL ast_check_visited = TRUE;
4120
4121 /** \brief Add an AST to the visit list.
4122
4123 An ast is added to the visit list during ast_rewrite() and ast_traverse().
4124 */
4125 void
ast_visit(int old,int new)4126 ast_visit(int old, int new)
4127 {
4128 #if DEBUG
4129 if (old == 0)
4130 interr("ast_visit sees ast of 0", 0, 2);
4131 if (old == 1 && new == 1) {
4132 if (ast_visit_state == TRUE && ast_check_visited) {
4133 interr("ast_visit without ast_unvisit", 0, 1);
4134 }
4135 ast_visit_state = TRUE;
4136 } else if (ast_visit_state == FALSE && ast_check_visited) {
4137 interr("ast_visit without ast_visit(1,1)", 0, 1);
4138 }
4139 #endif
4140 if (A_VISITG(old) == 0) { /* allow multiple replacements */
4141 A_VISITP(old, visit_list);
4142 visit_list = old;
4143 }
4144 }
4145
4146 /** \brief The \a old AST is to be replaced by the \a new AST.
4147
4148 Set its REPL field and add to the visit list. The caller of ast_rewrite()
4149 will have called ast_replace() one or more times to 'initialize' the
4150 rewriting process.
4151 */
4152 void
ast_replace(int old,int new)4153 ast_replace(int old, int new)
4154 {
4155 #if DEBUG
4156 if (old == 0)
4157 interr("ast_replace sees ast of 0", 0, 2);
4158 if (ast_visit_state == FALSE) {
4159 interr("ast_replace without ast_visit(1,1)", 0, 1);
4160 }
4161 #endif
4162 A_REPLP(old, new);
4163 ast_visit(old, new);
4164 }
4165
4166 /** \brief Traverse the visit list to clean up the nodes in the list.
4167
4168 The caller must call ast_unvisit(). ast_unvisit() also clears the REPL
4169 field.
4170 */
4171 void
ast_unvisit(void)4172 ast_unvisit(void)
4173 {
4174 int next;
4175
4176 #if DEBUG
4177 if (ast_visit_state == FALSE && ast_check_visited) {
4178 interr("ast_unvisit without ast_visit(1,1)", 0, 1);
4179 }
4180 ast_visit_state = FALSE;
4181 #endif
4182 for (; visit_list; visit_list = next) {
4183 next = A_VISITG(visit_list);
4184 A_REPLP(visit_list, 0);
4185 A_VISITP(visit_list, 0);
4186 }
4187 _visited = NULL;
4188 rewrite_opfields = 0;
4189 }
4190
4191 void
ast_unvisit_norepl(void)4192 ast_unvisit_norepl(void)
4193 {
4194 int next;
4195
4196 #if DEBUG
4197 if (ast_visit_state == FALSE) {
4198 interr("ast_unvisit_repl without ast_visit(1,1)", 0, 1);
4199 }
4200 ast_visit_state = FALSE;
4201 #endif
4202 for (; visit_list; visit_list = next) {
4203 next = A_VISITG(visit_list);
4204 A_VISITP(visit_list, 0);
4205 }
4206 _visited = NULL;
4207 rewrite_opfields = 0;
4208 }
4209
4210 /** \brief Visit the nodes on the 'visit_list' again, call \a proc on each one.
4211 */
4212 void
ast_revisit(ast_visit_fn proc,int * extra_arg)4213 ast_revisit(ast_visit_fn proc, int *extra_arg)
4214 {
4215 if (visit_list) {
4216 int v;
4217 v = visit_list;
4218 (*proc)(v, extra_arg);
4219 for (v = A_VISITG(v); v && v != visit_list; v = A_VISITG(v))
4220 (*proc)(v, extra_arg);
4221 }
4222 } /* ast_revisit */
4223
4224 int
ast_rewrite(int ast)4225 ast_rewrite(int ast)
4226 {
4227 int atype;
4228 int astnew;
4229 int l;
4230 int parent, mem, left, right, lop, rop, l1, l2, l3, sub, lbd, upbd, stride,
4231 dest, src, ifexpr, ifstmt, dolab, dovar, m1, m2, m3, itriple, otriple,
4232 otriple1, dim, bvect, ddesc, sdesc, mdesc, vsub, chunk, npar, start,
4233 align, m4, stblk, lastvar, endlab, finalexpr, priorityexpr;
4234 DTYPE dtype;
4235 int devsrc;
4236 int asd;
4237 int numdim;
4238 int subs[MAXRANK];
4239 int argt;
4240 int argcnt;
4241 int argtnew;
4242 int anew;
4243 int i;
4244 LOGICAL changes;
4245 int astli, astlinew;
4246 int rank, rank1;
4247 int shape, procbind;
4248
4249 if (ast == 0)
4250 return 0; /* watch for a 'null' argument */
4251 if (A_REPLG(ast))
4252 return A_REPLG(ast);
4253 shape = A_SHAPEG(ast);
4254 astnew = ast; /* default */
4255 changes = FALSE;
4256 switch (atype = A_TYPEG(ast)) {
4257 case A_CMPLXC:
4258 case A_CNST:
4259 case A_ID:
4260 case A_LABEL:
4261 /* nothing changes */
4262 break;
4263 case A_MEM:
4264 parent = ast_rewrite((int)A_PARENTG(ast));
4265 mem = A_MEMG(ast);
4266 if (A_REPLG(mem)) {
4267 if (A_TYPEG(A_REPLG(mem)) == A_ID) {
4268 mem = A_REPLG(mem);
4269 }
4270 }
4271 if (parent != A_PARENTG(ast) || mem != A_MEMG(ast)) {
4272 astnew = mk_member(parent, mem, A_DTYPEG(ast));
4273 }
4274 break;
4275 case A_SUBSTR:
4276 dtype = A_DTYPEG(ast);
4277 lop = ast_rewrite((int)A_LOPG(ast));
4278 left = ast_rewrite((int)A_LEFTG(ast));
4279 right = ast_rewrite((int)A_RIGHTG(ast));
4280 if (left != A_LEFTG(ast) || right != A_RIGHTG(ast) || lop != A_LOPG(ast)) {
4281 astnew = mk_substr(lop, left, right, dtype);
4282 }
4283 break;
4284 case A_BINOP:
4285 dtype = A_DTYPEG(ast);
4286 lop = ast_rewrite((int)A_LOPG(ast));
4287 rop = ast_rewrite((int)A_ROPG(ast));
4288 if (lop != A_LOPG(ast) || rop != A_ROPG(ast)) {
4289 rank = (shape ? SHD_NDIM(shape) : 0);
4290 shape = A_SHAPEG(lop);
4291 rank1 = (shape ? SHD_NDIM(shape) : 0);
4292 if (rank != rank1) {
4293 if (rank == 0)
4294 rank = rank1;
4295 dtype = get_array_dtype(rank, DDTG(A_DTYPEG(lop)));
4296 }
4297 astnew = mk_binop((int)A_OPTYPEG(ast), lop, rop, dtype);
4298 }
4299 break;
4300 case A_UNOP:
4301 dtype = A_DTYPEG(ast);
4302 lop = ast_rewrite((int)A_LOPG(ast));
4303 if (lop != A_LOPG(ast)) {
4304 rank = (shape ? SHD_NDIM(shape) : 0);
4305 shape = A_SHAPEG(lop);
4306 rank1 = (shape ? SHD_NDIM(shape) : 0);
4307 if (rank != rank1) {
4308 if (rank == 0)
4309 rank = rank1;
4310 dtype = get_array_dtype(rank, DDTG(A_DTYPEG(lop)));
4311 }
4312 astnew = mk_unop((int)A_OPTYPEG(ast), lop, dtype);
4313 }
4314 break;
4315 case A_PAREN:
4316 dtype = A_DTYPEG(ast);
4317 lop = ast_rewrite((int)A_LOPG(ast));
4318 if (lop != A_LOPG(ast)) {
4319 rank = (shape ? SHD_NDIM(shape) : 0);
4320 shape = A_SHAPEG(lop);
4321 rank1 = (shape ? SHD_NDIM(shape) : 0);
4322 if (rank != rank1) {
4323 if (rank == 0)
4324 rank = rank1;
4325 dtype = get_array_dtype(rank, DDTG(A_DTYPEG(lop)));
4326 }
4327 astnew = mk_paren(lop, dtype);
4328 }
4329 break;
4330 case A_CONV:
4331 dtype = A_DTYPEG(ast);
4332 lop = ast_rewrite((int)A_LOPG(ast));
4333 if (lop != A_LOPG(ast)) {
4334 rank = (shape ? SHD_NDIM(shape) : 0);
4335 shape = A_SHAPEG(lop);
4336 rank1 = (shape ? SHD_NDIM(shape) : 0);
4337 if (rank != rank1) {
4338 if (rank == 0)
4339 rank = rank1;
4340 dtype = get_array_dtype(rank, DDTG(A_DTYPEG(ast)));
4341 }
4342 astnew = mk_convert(lop, dtype);
4343 }
4344 break;
4345 case A_SUBSCR:
4346 dtype = A_DTYPEG(ast);
4347 lop = ast_rewrite((int)A_LOPG(ast));
4348 if (lop != A_LOPG(ast))
4349 changes = TRUE;
4350 asd = A_ASDG(ast);
4351 numdim = ASD_NDIM(asd);
4352 assert(numdim > 0 && numdim <= 7, "ast_rewrite: bad numdim", ast, 4);
4353 for (i = 0; i < numdim; ++i) {
4354 sub = ast_rewrite((int)ASD_SUBS(asd, i));
4355 if (sub != ASD_SUBS(asd, i))
4356 changes = TRUE;
4357 subs[i] = sub;
4358 }
4359 if (changes) {
4360 astnew = mk_subscr(lop, subs, numdim, dtype);
4361 }
4362 break;
4363 case A_INIT:
4364 dtype = A_DTYPEG(ast);
4365 left = ast_rewrite((int)A_LEFTG(ast));
4366 right = ast_rewrite((int)A_RIGHTG(ast));
4367 if (left != A_LEFTG(ast) || right != A_RIGHTG(ast)) {
4368 astnew = mk_init(left, dtype);
4369 A_RIGHTP(astnew, right);
4370 A_SPTRP(astnew, A_SPTRG(ast));
4371 }
4372 break;
4373 case A_TRIPLE:
4374 lbd = ast_rewrite((int)A_LBDG(ast));
4375 upbd = ast_rewrite((int)A_UPBDG(ast));
4376 stride = ast_rewrite((int)A_STRIDEG(ast));
4377 if (lbd != A_LBDG(ast) || upbd != A_UPBDG(ast) ||
4378 stride != A_STRIDEG(ast)) {
4379 astnew = mk_triple(lbd, upbd, stride);
4380 }
4381 break;
4382 case A_FUNC:
4383 lop = ast_rewrite(A_LOPG(ast));
4384 if (lop != A_LOPG(ast))
4385 changes = TRUE;
4386 argt = A_ARGSG(ast);
4387 argcnt = A_ARGCNTG(ast);
4388 argtnew = mk_argt(argcnt);
4389 for (i = 0; i < argcnt; i++) {
4390 anew = ast_rewrite(ARGT_ARG(argt, i));
4391 ARGT_ARG(argtnew, i) = anew;
4392 if (ARGT_ARG(argtnew, i) != ARGT_ARG(argt, i))
4393 changes = TRUE;
4394 }
4395 if (!changes) {
4396 unmk_argt(argcnt);
4397 } else {
4398 astnew = mk_func_node((int)A_TYPEG(ast), lop, argcnt, argtnew);
4399 A_SHAPEP(astnew, A_SHAPEG(ast));
4400 A_DTYPEP(astnew, A_DTYPEG(ast));
4401 }
4402 break;
4403 case A_INTR:
4404 lop = ast_rewrite((int)A_LOPG(ast));
4405 if (lop != A_LOPG(ast))
4406 changes = TRUE;
4407 argt = A_ARGSG(ast);
4408 argcnt = A_ARGCNTG(ast);
4409 argtnew = mk_argt(argcnt);
4410 for (i = 0; i < argcnt; i++) {
4411 anew = ast_rewrite(ARGT_ARG(argt, i));
4412 ARGT_ARG(argtnew, i) = anew;
4413 if (ARGT_ARG(argtnew, i) != ARGT_ARG(argt, i))
4414 changes = TRUE;
4415 }
4416 if (!changes) {
4417 unmk_argt(argcnt);
4418 } else {
4419 astnew = mk_func_node((int)A_TYPEG(ast), lop, argcnt, argtnew);
4420 A_OPTYPEP(astnew, A_OPTYPEG(ast));
4421 A_SHAPEP(astnew, A_SHAPEG(ast));
4422 A_DTYPEP(astnew, A_DTYPEG(ast));
4423 }
4424 switch (A_OPTYPEG(astnew)) {
4425 /* optimize a few intrinsics */
4426 case I_SIZE:
4427 /* is dim present and a constant ? */
4428 if (ARGT_ARG(argtnew, 1) && (i = A_ALIASG(ARGT_ARG(argtnew, 1)))) {
4429 int lwb, upb, stride;
4430 i = CONVAL2G(A_SPTRG(i)) - 1;
4431 shape = A_SHAPEG(ARGT_ARG(argtnew, 0));
4432 lwb = SHD_LWB(shape, i);
4433 upb = SHD_UPB(shape, i);
4434 stride = SHD_STRIDE(shape, i);
4435 if (stride == 0)
4436 stride = astb.bnd.one;
4437 if (lwb && A_ALIASG(lwb) && upb && A_ALIASG(upb) &&
4438 A_ALIASG(stride)) { /* stride is always nonzero here */
4439 astnew = upb;
4440 if (lwb != stride) {
4441 astnew = mk_binop(OP_SUB, astnew, lwb, astb.bnd.dtype);
4442 astnew = mk_binop(OP_ADD, astnew, stride, astb.bnd.dtype);
4443 }
4444 if (stride != astb.bnd.one) {
4445 astnew = mk_binop(OP_DIV, astnew, stride, astb.bnd.dtype);
4446 }
4447 }
4448 }
4449 break;
4450 case I_LBOUND:
4451 /* is dim a constant ? */
4452 if ((i = A_ALIASG(ARGT_ARG(argtnew, 1)))) {
4453 shape = A_SHAPEG(ARGT_ARG(argtnew, 0));
4454 i = CONVAL2G(A_SPTRG(i)) - 1;
4455 l = lbound_of_shape(shape, i);
4456 if (l)
4457 astnew = l;
4458 }
4459 break;
4460 case I_UBOUND:
4461 /* is dim a constant ? */
4462 if ((i = A_ALIASG(ARGT_ARG(argtnew, 1)))) {
4463 shape = A_SHAPEG(ARGT_ARG(argtnew, 0));
4464 i = CONVAL2G(A_SPTRG(i)) - 1;
4465 l = ubound_of_shape(shape, i);
4466 if (l)
4467 astnew = l;
4468 }
4469 break;
4470 default:
4471 break;
4472 }
4473 break;
4474 case A_ICALL:
4475 case A_CALL:
4476 lop = ast_rewrite((int)A_LOPG(ast));
4477 if (lop != A_LOPG(ast))
4478 changes = TRUE;
4479 argt = A_ARGSG(ast);
4480 argcnt = A_ARGCNTG(ast);
4481 argtnew = mk_argt(argcnt);
4482 for (i = 0; i < argcnt; i++) {
4483 anew = ast_rewrite(ARGT_ARG(argt, i));
4484 ARGT_ARG(argtnew, i) = anew;
4485 if (ARGT_ARG(argtnew, i) != ARGT_ARG(argt, i))
4486 changes = TRUE;
4487 }
4488 if (!changes) {
4489 unmk_argt(argcnt);
4490 } else {
4491 astnew = mk_func_node((int)A_TYPEG(ast), lop, argcnt, argtnew);
4492 A_OPTYPEP(astnew, A_OPTYPEG(ast));
4493 A_SHAPEP(astnew, A_SHAPEG(ast));
4494 if (atype == A_ICALL)
4495 A_DTYPEP(astnew, A_DTYPEG(ast));
4496 if (atype == A_CALL)
4497 A_INVOKING_DESCP(astnew, A_INVOKING_DESCG(ast));
4498 }
4499 break;
4500 case A_ASN:
4501 dtype = A_DTYPEG(ast);
4502 dest = ast_rewrite(A_DESTG(ast));
4503 src = ast_rewrite(A_SRCG(ast));
4504 if (dest != A_DESTG(ast) || src != A_SRCG(ast)) {
4505 shape = A_SHAPEG(A_DESTG(ast));
4506 rank = (shape ? SHD_NDIM(shape) : 0);
4507 shape = A_SHAPEG(dest);
4508 rank1 = (shape ? SHD_NDIM(shape) : 0);
4509 if (rank != rank1) {
4510 if (rank == 0)
4511 rank = rank1;
4512 dtype = get_array_dtype(rank, DDTG(A_DTYPEG(dest)));
4513 }
4514 astnew = mk_assn_stmt(dest, src, dtype);
4515 }
4516 break;
4517 case A_IF:
4518 ifexpr = ast_rewrite(A_IFEXPRG(ast));
4519 ifstmt = ast_rewrite(A_IFSTMTG(ast));
4520 if (ifexpr != A_IFEXPRG(ast) || ifstmt != A_IFSTMTG(ast)) {
4521 astnew = mk_stmt(A_IF, 0);
4522 A_IFEXPRP(astnew, ifexpr);
4523 A_IFSTMTP(astnew, ifstmt);
4524 }
4525 break;
4526 case A_IFTHEN:
4527 case A_ELSEIF:
4528 ifexpr = ast_rewrite(A_IFEXPRG(ast));
4529 if (ifexpr != A_IFEXPRG(ast)) {
4530 astnew = mk_stmt(A_TYPEG(ast), 0);
4531 A_IFEXPRP(astnew, ifexpr);
4532 }
4533 break;
4534 case A_AIF:
4535 ifexpr = ast_rewrite(A_IFEXPRG(ast));
4536 l1 = ast_rewrite(A_L1G(ast));
4537 l2 = ast_rewrite(A_L2G(ast));
4538 l3 = ast_rewrite(A_L3G(ast));
4539 if (ifexpr != A_IFEXPRG(ast) || l1 != A_L1G(ast) || l2 != A_L2G(ast) ||
4540 l3 != A_L3G(ast)) {
4541 astnew = mk_stmt(A_AIF, 0);
4542 A_IFEXPRP(astnew, ifexpr);
4543 A_L1P(astnew, l1);
4544 A_L2P(astnew, l2);
4545 A_L3P(astnew, l3);
4546 }
4547 break;
4548 case A_GOTO:
4549 l1 = ast_rewrite(A_L1G(ast));
4550 if (l1 != A_L1G(ast)) {
4551 astnew = mk_stmt(A_GOTO, 0);
4552 A_L1P(astnew, l1);
4553 }
4554 break;
4555 case A_CGOTO:
4556 case A_AGOTO:
4557 start_astli();
4558 lop = ast_rewrite(A_LOPG(ast));
4559 if (lop != A_LOPG(ast))
4560 changes = TRUE;
4561 for (astli = A_LISTG(ast); astli; astli = ASTLI_NEXT(astli)) {
4562 astlinew = add_astli();
4563 ASTLI_AST(astlinew) = ast_rewrite(ASTLI_AST(astli));
4564 if (ASTLI_AST(astlinew) != ASTLI_AST(astli))
4565 changes = TRUE;
4566 }
4567 if (!changes) {
4568 reset_astli();
4569 } else {
4570 astnew = mk_stmt(A_TYPEG(ast), 0);
4571 A_LISTP(astnew, ASTLI_HEAD);
4572 A_LOPP(astnew, lop);
4573 }
4574 break;
4575 case A_ASNGOTO:
4576 #if DEBUG
4577 assert(A_TYPEG(A_SRCG(ast)) == A_LABEL,
4578 "_ast_trav, src A_ASNGOTO not label", A_SRCG(ast), 3);
4579 #endif
4580 if (FMTPTG(A_SPTRG(A_SRCG(ast)))) {
4581 src = A_SRCG(ast);
4582 dest = ast_rewrite(A_DESTG(ast));
4583 } else {
4584 src = ast_rewrite(A_SRCG(ast));
4585 dest = ast_rewrite(A_DESTG(ast));
4586 }
4587 if (src != A_SRCG(ast) || dest != A_DESTG(ast)) {
4588 astnew = mk_stmt(A_ASNGOTO, 0);
4589 A_SRCP(astnew, src);
4590 A_DESTP(astnew, dest);
4591 }
4592 break;
4593 case A_DO:
4594 dolab = ast_rewrite(A_DOLABG(ast));
4595 dovar = ast_rewrite(A_DOVARG(ast));
4596 m1 = ast_rewrite(A_M1G(ast));
4597 m2 = ast_rewrite(A_M2G(ast));
4598 m3 = ast_rewrite(A_M3G(ast));
4599 m4 = ast_rewrite(A_M4G(ast));
4600 if (dolab != A_DOLABG(ast) || dovar != A_DOVARG(ast) || m1 != A_M1G(ast) ||
4601 m2 != A_M2G(ast) || m3 != A_M3G(ast) || m4 != A_M4G(ast)) {
4602 astnew = mk_stmt(A_DO, 0);
4603 A_DOLABP(astnew, dolab);
4604 A_DOVARP(astnew, dovar);
4605 A_M1P(astnew, m1);
4606 A_M2P(astnew, m2);
4607 A_M3P(astnew, m3);
4608 A_M4P(astnew, m4);
4609 }
4610 break;
4611 case A_DOWHILE:
4612 dolab = ast_rewrite(A_DOLABG(ast));
4613 ifexpr = ast_rewrite(A_IFEXPRG(ast));
4614 if (dolab != A_DOLABG(ast) || ifexpr != A_IFEXPRG(ast)) {
4615 astnew = mk_stmt(A_DOWHILE, 0);
4616 A_DOLABP(astnew, dolab);
4617 A_IFEXPRP(astnew, ifexpr);
4618 }
4619 break;
4620 case A_STOP:
4621 case A_PAUSE:
4622 case A_RETURN:
4623 lop = ast_rewrite(A_LOPG(ast));
4624 if (lop != A_LOPG(ast)) {
4625 astnew = mk_stmt(A_TYPEG(ast), 0);
4626 A_LOPP(astnew, lop);
4627 }
4628 break;
4629 case A_ALLOC:
4630 lop = ast_rewrite(A_LOPG(ast));
4631 src = ast_rewrite(A_SRCG(ast));
4632 dest = ast_rewrite(A_DESTG(ast));
4633 m3 = ast_rewrite(A_M3G(ast));
4634 start = ast_rewrite(A_STARTG(ast));
4635 dtype = A_DTYPEG(ast);
4636 devsrc = ast_rewrite(A_DEVSRCG(ast));
4637 align = ast_rewrite(A_ALIGNG(ast));
4638 if (lop != A_LOPG(ast) || src != A_SRCG(ast) || dest != A_DESTG(ast) ||
4639 m3 != A_M3G(ast) || start != A_STARTG(ast) ||
4640 devsrc != A_DEVSRCG(ast) || align != A_ALIGNG(ast)) {
4641 astnew = mk_stmt(A_ALLOC, 0);
4642 A_TKNP(astnew, A_TKNG(ast));
4643 A_DALLOCMEMP(astnew, A_DALLOCMEMG(ast));
4644 A_FIRSTALLOCP(astnew, A_FIRSTALLOCG(ast));
4645 A_LOPP(astnew, lop);
4646 A_SRCP(astnew, src);
4647 A_DESTP(astnew, dest);
4648 A_M3P(astnew, m3);
4649 A_STARTP(astnew, start);
4650 A_DTYPEP(astnew, dtype);
4651 A_DEVSRCP(astnew, devsrc);
4652 A_ALIGNP(astnew, align);
4653 }
4654 break;
4655 case A_WHERE:
4656 ifexpr = ast_rewrite(A_IFEXPRG(ast));
4657 ifstmt = ast_rewrite(A_IFSTMTG(ast));
4658 if (ifexpr != A_IFEXPRG(ast) || ifstmt != A_IFSTMTG(ast)) {
4659 astnew = mk_stmt(A_WHERE, 0);
4660 A_IFEXPRP(astnew, ifexpr);
4661 A_IFSTMTP(astnew, ifstmt);
4662 }
4663 break;
4664 case A_FORALL:
4665 ifexpr = ast_rewrite(A_IFEXPRG(ast));
4666 ifstmt = ast_rewrite(A_IFSTMTG(ast));
4667 if (ifexpr != A_IFEXPRG(ast) || ifstmt != A_IFSTMTG(ast))
4668 changes = TRUE;
4669 start_astli();
4670 for (astli = A_LISTG(ast); astli; astli = ASTLI_NEXT(astli)) {
4671 int s;
4672 astlinew = add_astli();
4673 ASTLI_TRIPLE(astlinew) = ast_rewrite(ASTLI_TRIPLE(astli));
4674 s = ast_rewrite(mk_id((int)ASTLI_SPTR(astli)));
4675 ASTLI_SPTR(astlinew) = A_SPTRG(s);
4676 if (ASTLI_TRIPLE(astlinew) != ASTLI_TRIPLE(astli) ||
4677 ASTLI_SPTR(astlinew) != ASTLI_SPTR(astli))
4678 changes = TRUE;
4679 }
4680 if (!changes) {
4681 reset_astli();
4682 } else {
4683 astnew = mk_stmt(A_FORALL, 0);
4684 A_LISTP(astnew, ASTLI_HEAD);
4685 A_IFEXPRP(astnew, ifexpr);
4686 A_IFSTMTP(astnew, ifstmt);
4687 }
4688 break;
4689 case A_REDIM:
4690 src = ast_rewrite(A_SRCG(ast));
4691 if (src != A_SRCG(ast)) {
4692 astnew = mk_stmt(A_REDIM, 0);
4693 A_SRCP(astnew, src);
4694 }
4695 break;
4696 case A_ENTRY:
4697 case A_COMMENT:
4698 case A_COMSTR:
4699 case A_ELSE:
4700 case A_ENDIF:
4701 case A_ELSEFORALL:
4702 case A_ELSEWHERE:
4703 case A_ENDWHERE:
4704 case A_ENDFORALL:
4705 case A_ENDDO:
4706 case A_CONTINUE:
4707 case A_END:
4708 break;
4709 case A_REALIGN:
4710 lop = ast_rewrite(A_LOPG(ast));
4711 if (lop != A_LOPG(ast)) {
4712 astnew = mk_stmt(A_REALIGN, (int)A_DTYPEG(ast));
4713 A_LOPP(astnew, lop);
4714 }
4715 break;
4716 case A_REDISTRIBUTE:
4717 lop = ast_rewrite(A_LOPG(ast));
4718 if (lop != A_LOPG(ast)) {
4719 astnew = mk_stmt(A_REDISTRIBUTE, (int)A_DTYPEG(ast));
4720 A_LOPP(astnew, lop);
4721 }
4722 break;
4723 case A_HLOCALIZEBNDS:
4724 lop = ast_rewrite(A_LOPG(ast));
4725 itriple = ast_rewrite(A_ITRIPLEG(ast));
4726 otriple = ast_rewrite(A_OTRIPLEG(ast));
4727 dim = ast_rewrite(A_DIMG(ast));
4728 if (lop != A_LOPG(ast) || itriple != A_ITRIPLEG(ast) ||
4729 otriple != A_OTRIPLEG(ast) || dim != A_DIMG(ast)) {
4730 astnew = mk_stmt(A_HLOCALIZEBNDS, 0);
4731 A_LOPP(astnew, lop);
4732 A_ITRIPLEP(astnew, itriple);
4733 A_OTRIPLEP(astnew, otriple);
4734 A_DIMP(astnew, dim);
4735 }
4736 break;
4737 case A_HALLOBNDS:
4738 lop = ast_rewrite(A_LOPG(ast));
4739 if (lop != A_LOPG(ast)) {
4740 astnew = mk_stmt(A_HALLOBNDS, 0);
4741 A_LOPP(astnew, lop);
4742 }
4743 break;
4744 case A_HCYCLICLP:
4745 lop = ast_rewrite(A_LOPG(ast));
4746 itriple = ast_rewrite(A_ITRIPLEG(ast));
4747 otriple = ast_rewrite(A_OTRIPLEG(ast));
4748 otriple1 = ast_rewrite(A_OTRIPLE1G(ast));
4749 dim = ast_rewrite(A_DIMG(ast));
4750 if (lop != A_LOPG(ast) || itriple != A_ITRIPLEG(ast) ||
4751 otriple != A_OTRIPLEG(ast) || otriple1 != A_OTRIPLE1G(ast) ||
4752 dim != A_DIMG(ast)) {
4753 astnew = mk_stmt(A_HCYCLICLP, 0);
4754 A_LOPP(astnew, lop);
4755 A_ITRIPLEP(astnew, itriple);
4756 A_OTRIPLEP(astnew, otriple);
4757 A_OTRIPLE1P(astnew, otriple1);
4758 A_DIMP(astnew, dim);
4759 }
4760 break;
4761 case A_HOFFSET:
4762 dest = ast_rewrite(A_DESTG(ast));
4763 lop = ast_rewrite(A_LOPG(ast));
4764 rop = ast_rewrite(A_ROPG(ast));
4765 if (dest != A_DESTG(ast) || lop != A_LOPG(ast) || rop != A_ROPG(ast)) {
4766 astnew = mk_stmt(A_HOFFSET, 0);
4767 A_DESTP(astnew, dest);
4768 A_LOPP(astnew, lop);
4769 A_ROPP(astnew, rop);
4770 }
4771 break;
4772 case A_HSECT:
4773 lop = ast_rewrite(A_LOPG(ast));
4774 bvect = ast_rewrite(A_BVECTG(ast));
4775 if (lop != A_LOPG(ast) || bvect != A_BVECTG(ast)) {
4776 astnew = new_node(atype);
4777 A_DTYPEP(astnew, DT_INT);
4778 A_LOPP(astnew, lop);
4779 A_BVECTP(astnew, bvect);
4780 }
4781 break;
4782 case A_HCOPYSECT:
4783 dest = ast_rewrite(A_DESTG(ast));
4784 src = ast_rewrite(A_SRCG(ast));
4785 ddesc = ast_rewrite(A_DDESCG(ast));
4786 sdesc = ast_rewrite(A_SDESCG(ast));
4787 if (dest != A_DESTG(ast) || src != A_SRCG(ast) || ddesc != A_DDESCG(ast) ||
4788 sdesc != A_SDESCG(ast)) {
4789 astnew = new_node(atype);
4790 A_DTYPEP(astnew, DT_INT);
4791 A_DESTP(astnew, dest);
4792 A_SRCP(astnew, src);
4793 A_DDESCP(astnew, ddesc);
4794 A_SDESCP(astnew, sdesc);
4795 }
4796 break;
4797 case A_HPERMUTESECT:
4798 dest = ast_rewrite(A_DESTG(ast));
4799 src = ast_rewrite(A_SRCG(ast));
4800 ddesc = ast_rewrite(A_DDESCG(ast));
4801 sdesc = ast_rewrite(A_SDESCG(ast));
4802 bvect = ast_rewrite(A_BVECTG(ast));
4803 if (dest != A_DESTG(ast) || src != A_SRCG(ast) || ddesc != A_DDESCG(ast) ||
4804 sdesc != A_SDESCG(ast) || bvect != A_BVECTG(ast)) {
4805 astnew = new_node(atype);
4806 A_DTYPEP(astnew, DT_INT);
4807 A_DESTP(astnew, dest);
4808 A_SRCP(astnew, src);
4809 A_DDESCP(astnew, ddesc);
4810 A_SDESCP(astnew, sdesc);
4811 A_BVECTP(astnew, bvect);
4812 }
4813 break;
4814 case A_HOVLPSHIFT:
4815 src = ast_rewrite(A_SRCG(ast));
4816 sdesc = ast_rewrite(A_SDESCG(ast));
4817 if (src != A_SRCG(ast) || sdesc != A_SDESCG(ast)) {
4818 astnew = new_node(atype);
4819 A_DTYPEP(astnew, DT_INT);
4820 A_SRCP(astnew, src);
4821 A_SDESCP(astnew, sdesc);
4822 }
4823 break;
4824 case A_HGETSCLR:
4825 dest = ast_rewrite(A_DESTG(ast));
4826 src = ast_rewrite(A_SRCG(ast));
4827 lop = ast_rewrite(A_LOPG(ast));
4828 if (dest != A_DESTG(ast) || src != A_SRCG(ast)) {
4829 astnew = mk_stmt(atype, 0);
4830 A_DESTP(astnew, dest);
4831 A_SRCP(astnew, src);
4832 A_LOPP(astnew, lop);
4833 }
4834 break;
4835 case A_HGATHER:
4836 case A_HSCATTER:
4837 vsub = ast_rewrite(A_VSUBG(ast));
4838 dest = ast_rewrite(A_DESTG(ast));
4839 src = ast_rewrite(A_SRCG(ast));
4840 ddesc = ast_rewrite(A_DDESCG(ast));
4841 sdesc = ast_rewrite(A_SDESCG(ast));
4842 mdesc = ast_rewrite(A_MDESCG(ast));
4843 bvect = ast_rewrite(A_BVECTG(ast));
4844
4845 if (vsub != A_VSUBG(ast) || dest != A_DESTG(ast) || src != A_SRCG(ast) ||
4846 ddesc != A_DDESCG(ast) || sdesc != A_SDESCG(ast) ||
4847 mdesc != A_MDESCG(ast) || bvect != A_BVECTG(ast)) {
4848 astnew = new_node(atype);
4849 A_DTYPEP(astnew, DT_INT);
4850 A_VSUBP(astnew, vsub);
4851 A_DESTP(astnew, dest);
4852 A_SRCP(astnew, src);
4853 A_DDESCP(astnew, ddesc);
4854 A_SDESCP(astnew, sdesc);
4855 A_MDESCP(astnew, mdesc);
4856 A_BVECTP(astnew, bvect);
4857 }
4858 break;
4859 case A_HCSTART:
4860 lop = ast_rewrite(A_LOPG(ast));
4861 dest = ast_rewrite(A_DESTG(ast));
4862 src = ast_rewrite(A_SRCG(ast));
4863 if (lop != A_LOPG(ast) || dest != A_DESTG(ast) || src != A_SRCG(ast)) {
4864 astnew = new_node(atype);
4865 A_DTYPEP(astnew, DT_INT);
4866 A_LOPP(astnew, lop);
4867 A_DESTP(astnew, dest);
4868 A_SRCP(astnew, src);
4869 }
4870 break;
4871 case A_HCFINISH:
4872 case A_HCFREE:
4873 lop = ast_rewrite(A_LOPG(ast));
4874 if (lop != A_LOPG(ast)) {
4875 astnew = mk_stmt(atype, 0);
4876 A_LOPP(astnew, lop);
4877 }
4878 break;
4879 case A_HOWNERPROC:
4880 dtype = A_DTYPEG(ast);
4881 lop = ast_rewrite(A_LOPG(ast));
4882 dim = ast_rewrite(A_DIMG(ast));
4883 m1 = ast_rewrite(A_M1G(ast));
4884 m2 = ast_rewrite(A_M2G(ast));
4885 if (lop != A_LOPG(ast) || dim != A_DIMG(ast) || m1 != A_M1G(ast) ||
4886 m2 != A_M2G(ast)) {
4887 astnew = new_node(atype);
4888 A_DTYPEP(astnew, dtype);
4889 A_LOPP(astnew, lop);
4890 A_DIMP(astnew, dim);
4891 A_M1P(astnew, m1);
4892 A_M2P(astnew, m2);
4893 }
4894 break;
4895 case A_HLOCALOFFSET:
4896 dtype = A_DTYPEG(ast);
4897 lop = ast_rewrite(A_LOPG(ast));
4898 if (lop != A_LOPG(ast)) {
4899 astnew = new_node(atype);
4900 A_DTYPEP(astnew, dtype);
4901 A_LOPP(astnew, lop);
4902 }
4903 break;
4904 case A_CRITICAL:
4905 case A_ENDCRITICAL:
4906 break;
4907 case A_MASTER:
4908 break;
4909 case A_ENDMASTER:
4910 lop = A_LOPG(ast); /* its master */
4911 argcnt = A_ARGCNTG(ast);
4912 if (argcnt) {
4913 /* copy present */
4914 argt = A_ARGSG(ast);
4915 argtnew = mk_argt(argcnt);
4916 for (i = 0; i < argcnt; i++) {
4917 anew = ast_rewrite(ARGT_ARG(argt, i));
4918 ARGT_ARG(argtnew, i) = anew;
4919 if (ARGT_ARG(argtnew, i) != ARGT_ARG(argt, i))
4920 changes = TRUE;
4921 }
4922 if (!changes) {
4923 unmk_argt(argcnt);
4924 } else {
4925 astnew = mk_stmt(atype, 0);
4926 A_ARGSP(astnew, argtnew);
4927 A_ARGCNTP(astnew, argcnt);
4928 A_LOPP(astnew, lop);
4929 A_LOPP(lop, astnew); /* update reverse link */
4930 }
4931 }
4932 break;
4933 case A_ATOMIC:
4934 case A_ATOMICCAPTURE:
4935 case A_ATOMICREAD:
4936 case A_ATOMICWRITE:
4937 case A_ENDATOMIC:
4938 case A_BARRIER:
4939 case A_NOBARRIER:
4940 break;
4941 case A_MP_PARALLEL:
4942 ifexpr = ast_rewrite(A_IFPARG(ast));
4943 npar = ast_rewrite(A_NPARG(ast));
4944 endlab = ast_rewrite(A_ENDLABG(ast));
4945 procbind = ast_rewrite(A_PROCBINDG(ast));
4946 if (ifexpr != A_IFPARG(ast) || npar != A_NPARG(ast) ||
4947 endlab != A_ENDLABG(ast)) {
4948 astnew = mk_stmt(A_MP_PARALLEL, 0);
4949 A_IFPARP(astnew, ifexpr);
4950 A_NPARP(astnew, npar);
4951 A_LOPP(astnew,
4952 A_LOPG(ast)); /* A_MP_PARALLEL points to A_MP_ENDPARALLEL */
4953 A_LOPP(A_LOPG(ast), astnew); /* and back */
4954 A_ENDLABP(A_ENDLABG(ast), astnew); /* and back */
4955 A_PROCBINDP(A_ENDLABG(ast), astnew); /* and back */
4956 }
4957 break;
4958 case A_MP_TEAMS:
4959 ifexpr = ast_rewrite(A_NTEAMSG(ast));
4960 npar = ast_rewrite(A_THRLIMITG(ast));
4961 if (ifexpr != A_NTEAMSG(ast) || npar != A_THRLIMITG(ast)) {
4962 astnew = mk_stmt(A_MP_TEAMS, 0);
4963 A_NTEAMSP(astnew, ifexpr);
4964 A_THRLIMITP(astnew, npar);
4965 A_LOPP(astnew, A_LOPG(ast)); /* A_MP_TEAMS points to A_MP_ENDTEAMS */
4966 A_LOPP(A_LOPG(ast), astnew); /* and back */
4967 }
4968 break;
4969 case A_MP_TASK:
4970 ifexpr = ast_rewrite(A_IFPARG(ast));
4971 endlab = ast_rewrite(A_ENDLABG(ast));
4972 priorityexpr = ast_rewrite(A_PRIORITYG(ast));
4973 finalexpr = ast_rewrite(A_FINALPARG(ast));
4974 if (ifexpr != A_IFPARG(ast) || endlab != A_ENDLABG(ast) ||
4975 finalexpr != A_FINALPARG(ast) || priorityexpr != A_PRIORITYG(ast)) {
4976 astnew = mk_stmt(A_MP_TASK, 0);
4977 A_IFPARP(astnew, ifexpr);
4978 A_FINALPARP(astnew, finalexpr);
4979 A_ENDLABP(astnew, endlab);
4980 A_LOPP(astnew, A_LOPG(ast)); /* A_MP_TASK points to A_MP_ENDTASK */
4981 A_LOPP(A_LOPG(ast), astnew); /* and back */
4982 }
4983 break;
4984 case A_MP_TASKLOOP:
4985 ifexpr = ast_rewrite(A_IFPARG(ast));
4986 finalexpr = ast_rewrite(A_FINALPARG(ast));
4987 priorityexpr = ast_rewrite(A_PRIORITYG(ast));
4988 if (ifexpr != A_IFPARG(ast) || finalexpr != A_FINALPARG(ast) ||
4989 priorityexpr != A_PRIORITYG(ast)) {
4990 astnew = mk_stmt(A_MP_TASKLOOP, 0);
4991 A_IFPARP(astnew, ifexpr);
4992 A_FINALPARP(astnew, finalexpr);
4993 A_PRIORITYP(astnew, priorityexpr);
4994 A_LOPP(astnew, A_LOPG(ast)); /* A_MP_TASKLOOP points to A_MP_ETASKLOOP */
4995 A_LOPP(A_LOPG(ast), astnew); /* and back */
4996 }
4997 break;
4998 case A_MP_TARGET:
4999 case A_MP_TARGETDATA:
5000 ifexpr = ast_rewrite(A_IFPARG(ast));
5001 if (ifexpr != A_IFPARG(ast)) {
5002 astnew = mk_stmt(atype, 0);
5003 A_IFPARP(astnew, ifexpr);
5004 A_LOPP(astnew,
5005 A_LOPG(ast)); /* A_MP_TARGETxx points to A_MP_ENDTARGETxx */
5006 A_LOPP(A_LOPG(ast), astnew); /* and back */
5007 }
5008 break;
5009 case A_MP_TARGETUPDATE:
5010 case A_MP_TARGETENTERDATA:
5011 case A_MP_TARGETEXITDATA:
5012 ifexpr = ast_rewrite(A_IFPARG(ast));
5013 if (ifexpr != A_IFPARG(ast)) {
5014 astnew = mk_stmt(atype, 0);
5015 A_IFPARP(astnew, ifexpr);
5016 }
5017 break;
5018
5019 case A_MP_ENDTARGET:
5020 case A_MP_ENDTARGETDATA:
5021 case A_MP_ENDTEAMS:
5022 case A_MP_DISTRIBUTE:
5023 case A_MP_ENDDISTRIBUTE:
5024 case A_MP_TASKGROUP:
5025 case A_MP_ETASKGROUP:
5026 case A_MP_ETASKDUP:
5027 case A_MP_ENDPARALLEL:
5028 case A_MP_CRITICAL:
5029 case A_MP_ENDCRITICAL:
5030 case A_MP_ATOMIC:
5031 case A_MP_ENDATOMIC:
5032 case A_MP_MASTER:
5033 case A_MP_ENDMASTER:
5034 case A_MP_SINGLE:
5035 case A_MP_ENDSINGLE:
5036 case A_MP_BARRIER:
5037 case A_MP_TASKWAIT:
5038 case A_MP_TASKYIELD:
5039 case A_MP_BCOPYIN:
5040 case A_MP_ECOPYIN:
5041 case A_MP_BCOPYPRIVATE:
5042 case A_MP_ECOPYPRIVATE:
5043 case A_MP_EMPSCOPE:
5044 case A_MP_FLUSH:
5045 case A_MP_TASKREG:
5046 case A_MP_TASKDUP:
5047 case A_MP_ETASKLOOPREG:
5048 case A_MP_ATOMICREAD:
5049 case A_MP_ATOMICUPDATE:
5050 case A_MP_ATOMICCAPTURE:
5051 case A_MP_MAP:
5052 case A_MP_EMAP:
5053 case A_MP_TARGETLOOPTRIPCOUNT:
5054 case A_MP_EREDUCTION:
5055 case A_MP_BREDUCTION:
5056 case A_MP_REDUCTIONITEM:
5057 break;
5058 case A_MP_ATOMICWRITE:
5059 rop = ast_rewrite(A_ROPG(ast));
5060 if (rop != A_ROPG(ast)) {
5061 astnew = mk_stmt(atype, 0);
5062 A_LOPP(astnew, A_LOPG(ast));
5063 A_ROPP(astnew, rop);
5064 A_MEM_ORDERP(astnew, A_MEM_ORDERG(ast));
5065 }
5066 break;
5067 case A_MP_CANCELLATIONPOINT:
5068 rop = ast_rewrite(A_ENDLABG(ast));
5069 if (rop != A_ENDLABG(ast)) {
5070 astnew = mk_stmt(atype, 0);
5071 A_ENDLABP(astnew, rop);
5072 A_CANCELKINDP(astnew, A_CANCELKINDG(ast));
5073 }
5074 break;
5075 case A_MP_CANCEL:
5076 rop = ast_rewrite(A_ENDLABG(ast));
5077 lop = ast_rewrite(A_IFPARG(ast));
5078 if (rop != A_ENDLABG(ast) || rop != A_IFPARG(ast)) {
5079 astnew = mk_stmt(atype, 0);
5080 A_ENDLABP(astnew, rop);
5081 A_CANCELKINDP(astnew, A_CANCELKINDG(ast));
5082 }
5083 break;
5084 case A_MP_TASKFIRSTPRIV:
5085 rop = ast_rewrite(A_ROPG(ast));
5086 lop = ast_rewrite(A_LOPG(ast));
5087 if (rop != A_ROPG(ast) || lop != A_LOPG(ast)) {
5088 astnew = mk_stmt(atype, 0);
5089 A_SPTRP(astnew, A_SPTRG(ast));
5090 A_ROPP(astnew, rop);
5091 A_LOPP(astnew, lop);
5092 }
5093 break;
5094
5095 case A_MP_BMPSCOPE:
5096 stblk = ast_rewrite(A_STBLKG(ast));
5097 if (stblk != A_STBLKG(ast)) {
5098 astnew = mk_stmt(A_MP_BMPSCOPE, 0);
5099 A_STBLKP(astnew, stblk);
5100 }
5101 break;
5102 case A_MP_PRE_TLS_COPY:
5103 case A_MP_COPYIN:
5104 case A_MP_COPYPRIVATE:
5105 rop = ast_rewrite(A_ROPG(ast));
5106 if (rop != A_ROPG(ast)) {
5107 astnew = mk_stmt(atype, 0);
5108 A_SPTRP(astnew, A_SPTRG(ast));
5109 A_ROPP(astnew, rop);
5110 }
5111 break;
5112 case A_MP_TASKLOOPREG:
5113 m1 = ast_rewrite(A_M1G(ast));
5114 m2 = ast_rewrite(A_M2G(ast));
5115 m3 = ast_rewrite(A_M3G(ast));
5116 if (m1 != A_M1G(ast) || m2 != A_M2G(ast) || m3 != A_M3G(ast)) {
5117 astnew = mk_stmt(A_MP_TASKLOOPREG, 0);
5118 A_M1P(astnew, m1);
5119 A_M2P(astnew, m2);
5120 A_M3P(astnew, m3);
5121 }
5122 break;
5123 case A_MP_PDO:
5124 dolab = ast_rewrite(A_DOLABG(ast));
5125 dovar = ast_rewrite(A_DOVARG(ast));
5126 lastvar = ast_rewrite(A_LASTVALG(ast));
5127
5128 /* don't rewrite bounds if this is distribute parallel do
5129 * unless we combine the distribute and parallel do in
5130 * a single loop.
5131 */
5132 if (A_DISTPARDOG(ast)) {
5133 m1 = A_M1G(ast);
5134 m2 = A_M2G(ast);
5135 m3 = A_M3G(ast);
5136 } else {
5137 m1 = ast_rewrite(A_M1G(ast));
5138 m2 = ast_rewrite(A_M2G(ast));
5139 m3 = ast_rewrite(A_M3G(ast));
5140 }
5141 chunk = ast_rewrite(A_CHUNKG(ast));
5142 if (dolab != A_DOLABG(ast) || dovar != A_DOVARG(ast) || m1 != A_M1G(ast) ||
5143 lastvar != A_LASTVALG(ast) || m2 != A_M2G(ast) || m3 != A_M3G(ast) ||
5144 chunk != A_CHUNKG(ast)) {
5145 astnew = mk_stmt(A_MP_PDO, 0);
5146 A_DOLABP(astnew, dolab);
5147 A_DOVARP(astnew, dovar);
5148 A_LASTVALP(astnew, lastvar);
5149 A_M1P(astnew, m1);
5150 A_M2P(astnew, m2);
5151 A_M3P(astnew, m3);
5152 A_CHUNKP(astnew, chunk);
5153 A_SCHED_TYPEP(astnew, A_SCHED_TYPEG(ast));
5154 A_ORDEREDP(astnew, A_ORDEREDG(ast));
5155 A_DISTRIBUTEP(astnew, A_DISTRIBUTEG(ast));
5156 A_DISTPARDOP(astnew, A_DISTPARDOG(ast));
5157 A_TASKLOOPP(astnew, A_TASKLOOPG(ast));
5158 }
5159 break;
5160 case A_MP_ENDPDO:
5161 case A_MP_ENDSECTIONS:
5162 case A_MP_SECTION:
5163 case A_MP_LSECTION:
5164 case A_MP_WORKSHARE:
5165 case A_MP_ENDWORKSHARE:
5166 case A_MP_BPDO:
5167 case A_MP_EPDO:
5168 case A_MP_BORDERED:
5169 case A_MP_EORDERED:
5170 case A_MP_ENDTASK:
5171 case A_MP_ETASKLOOP:
5172 break;
5173 case A_PREFETCH:
5174 lop = ast_rewrite(A_LOPG(ast));
5175 if (lop != A_LOPG(ast)) {
5176 astnew = new_node(atype);
5177 A_LOPP(astnew, lop);
5178 A_OPTYPEP(astnew, A_OPTYPEG(ast));
5179 }
5180 break;
5181 case A_PRAGMA:
5182 lop = ast_rewrite(A_LOPG(ast));
5183 rop = ast_rewrite(A_ROPG(ast));
5184 if (lop != A_LOPG(ast) || rop != A_ROPG(ast)) {
5185 astnew = new_node(atype);
5186 A_LOPP(astnew, lop);
5187 A_ROPP(astnew, rop);
5188 A_PRAGMATYPEP(astnew, A_PRAGMATYPEG(ast));
5189 A_PRAGMASCOPEP(astnew, A_PRAGMASCOPEG(ast));
5190 }
5191 break;
5192 default:
5193 interr("ast_rewrite: unexpected ast", ast, 2);
5194 return ast;
5195 }
5196
5197 ast_replace(ast, astnew);
5198 if (astnew != ast) {
5199 if (rewrite_opfields & 0x1)
5200 A_OPT1P(astnew, A_OPT1G(ast));
5201 if (rewrite_opfields & 0x2)
5202 A_OPT2P(astnew, A_OPT2G(ast));
5203 }
5204 return astnew;
5205 }
5206
5207 /** \brief Only called by the semantic analyzer; if it needs to be used by all
5208 phases,
5209 many ASTs need to be added as cases.
5210 */
5211 void
ast_clear_repl(int ast)5212 ast_clear_repl(int ast)
5213 {
5214 int asd;
5215 int numdim;
5216 int arg;
5217 int argt;
5218 int argcnt;
5219 int i;
5220
5221 if (ast == 0)
5222 return; /* watch for a 'null' argument */
5223 if (A_REPLG(ast) == 0)
5224 return;
5225 switch (A_TYPEG(ast)) {
5226 case A_CMPLXC:
5227 case A_CNST:
5228 case A_ID:
5229 case A_LABEL:
5230 break;
5231 case A_MEM:
5232 ast_clear_repl((int)A_PARENTG(ast));
5233 break;
5234 case A_SUBSTR:
5235 ast_clear_repl((int)A_LOPG(ast));
5236 ast_clear_repl((int)A_LEFTG(ast));
5237 ast_clear_repl((int)A_RIGHTG(ast));
5238 break;
5239 case A_BINOP:
5240 ast_clear_repl((int)A_LOPG(ast));
5241 ast_clear_repl((int)A_ROPG(ast));
5242 break;
5243 case A_UNOP:
5244 ast_clear_repl((int)A_LOPG(ast));
5245 break;
5246 case A_PAREN:
5247 ast_clear_repl((int)A_LOPG(ast));
5248 break;
5249 case A_CONV:
5250 ast_clear_repl((int)A_LOPG(ast));
5251 break;
5252 case A_SUBSCR:
5253 ast_clear_repl((int)A_LOPG(ast));
5254 asd = A_ASDG(ast);
5255 numdim = ASD_NDIM(asd);
5256 assert(numdim > 0 && numdim <= 7, "ast_clear_repl: bad numdim", ast, 4);
5257 for (i = 0; i < numdim; ++i)
5258 ast_clear_repl((int)ASD_SUBS(asd, i));
5259 break;
5260 case A_TRIPLE:
5261 ast_clear_repl((int)A_LBDG(ast));
5262 ast_clear_repl((int)A_UPBDG(ast));
5263 ast_clear_repl((int)A_STRIDEG(ast));
5264 break;
5265 case A_FUNC:
5266 ast_clear_repl((int)A_LOPG(ast));
5267 argt = A_ARGSG(ast);
5268 argcnt = A_ARGCNTG(ast);
5269 for (i = 0; i < argcnt; i++) {
5270 arg = ARGT_ARG(argt, i);
5271 (void)ast_clear_repl(arg);
5272 }
5273 break;
5274 case A_INTR:
5275 case A_ICALL:
5276 ast_clear_repl((int)A_LOPG(ast));
5277 argt = A_ARGSG(ast);
5278 argcnt = A_ARGCNTG(ast);
5279 for (i = 0; i < argcnt; i++) {
5280 arg = ARGT_ARG(argt, i);
5281 (void)ast_clear_repl(arg);
5282 }
5283 break;
5284 case A_REALIGN:
5285 case A_REDISTRIBUTE:
5286 ast_clear_repl((int)A_LOPG(ast));
5287 break;
5288 default:
5289 interr("ast_clear_repl: unexpected ast", ast, 2);
5290 }
5291
5292 A_REPLP(ast, 0);
5293 }
5294
5295 static ast_preorder_fn _preorder;
5296 static ast_visit_fn _postorder;
5297 static void _ast_trav(int ast, int *extra_arg);
5298
5299 /** \brief General ast traversal function: uses a list to keep track of the
5300 ast nodes which have been visited; if a node is visited, the node's
5301 REPL field is non-zero.
5302 \param ast the ast to traverse
5303 \param preorder called before visiting children; return TRUE to prevent
5304 visiting ast's operands
5305 \param postorder called after visiting children
5306 \param extra_arg passed to preorder and postorder
5307
5308 \a preorder and \a postorder can be NULL. If they are not, they are called
5309 with two arguments, an ast and a pointer. The pointer argument 'extra_arg'
5310 (possibly NULL) may be used by the caller to pass value(s) to visit
5311 routines, used by the visit routines to return values, or both.
5312
5313 Visited asts are linked together using 'visit_list'; the caller must call
5314 ast_unvisit() to cleanup up the VISIT and REPL fields of the asts. To begin
5315 the traverse, ast #1 must be marked visited by the caller; e.g.,
5316 <pre>
5317 ast_visit(1, 1);
5318 </pre>
5319 */
5320 void
ast_traverse(int ast,ast_preorder_fn preorder,ast_visit_fn postorder,int * extra_arg)5321 ast_traverse(int ast, ast_preorder_fn preorder, ast_visit_fn postorder,
5322 int *extra_arg)
5323 {
5324 ast_preorder_fn save_preorder = _preorder;
5325 ast_visit_fn save_postorder = _postorder;
5326 LOGICAL save_ast_check_visited = ast_check_visited;
5327 ast_check_visited = TRUE;
5328 _preorder = preorder;
5329 _postorder = postorder;
5330 _ast_trav(ast, extra_arg);
5331 _preorder = save_preorder;
5332 _postorder = save_postorder;
5333 ast_check_visited = save_ast_check_visited;
5334 }
5335
5336 /** \brief Recursively visit the ast operands of \a ast; useful if the caller
5337 needs check the 'result' (via extra_arg) of the visit function.
5338
5339 See ast_traverse() for details about params.
5340
5341 For the case where it's necessary to perform certain actions/checks when
5342 an ast has already been visited, ast_estab_visited(visit) may be called
5343 prior to ast_traverse() to establish such a function. ast_unvisit()
5344 removes this function.
5345 */
5346 void
ast_traverse_all(int ast,ast_preorder_fn preorder,ast_visit_fn postorder,int * extra_arg)5347 ast_traverse_all(int ast, ast_preorder_fn preorder, ast_visit_fn postorder,
5348 int *extra_arg)
5349 {
5350 ast_preorder_fn save_preorder = _preorder;
5351 ast_visit_fn save_postorder = _postorder;
5352 LOGICAL save_ast_check_visited = ast_check_visited;
5353 ast_check_visited = FALSE;
5354 _preorder = preorder;
5355 _postorder = postorder;
5356 _ast_trav(ast, extra_arg);
5357 _preorder = save_preorder;
5358 _postorder = save_postorder;
5359 ast_check_visited = save_ast_check_visited;
5360 }
5361
5362 /** \brief While in an ast_traverse recursion, continue on another subtree */
5363 void
ast_traverse_more(int ast,int * extra_arg)5364 ast_traverse_more(int ast, int *extra_arg)
5365 {
5366 _ast_trav(ast, extra_arg);
5367 } /* ast_traverse_more */
5368
5369 static void
_ast_trav(int ast,int * extra_arg)5370 _ast_trav(int ast, int *extra_arg)
5371 {
5372 if (ast_check_visited) {
5373 if (A_VISITG(ast)) {
5374 if (_visited != NULL)
5375 (*_visited)(ast, extra_arg);
5376 return;
5377 }
5378 ast_visit(ast, 1);
5379 }
5380
5381 if (_preorder != NULL) {
5382 if ((*_preorder)(ast, extra_arg))
5383 return;
5384 }
5385
5386 ast_trav_recurse(ast, extra_arg);
5387
5388 if (_postorder != NULL)
5389 (*_postorder)(ast, extra_arg);
5390 }
5391
5392 void
ast_trav_recurse(int ast,int * extra_arg)5393 ast_trav_recurse(int ast, int *extra_arg)
5394 {
5395 int atype;
5396 int i, asd;
5397 int astli;
5398 int argt;
5399 int cnt;
5400
5401 switch (atype = A_TYPEG(ast)) {
5402 case A_NULL:
5403 case A_ID:
5404 case A_CNST:
5405 case A_LABEL:
5406 break;
5407 case A_BINOP:
5408 _ast_trav((int)A_LOPG(ast), extra_arg);
5409 _ast_trav((int)A_ROPG(ast), extra_arg);
5410 break;
5411 case A_UNOP:
5412 _ast_trav((int)A_LOPG(ast), extra_arg);
5413 break;
5414 case A_CMPLXC:
5415 _ast_trav((int)A_LOPG(ast), extra_arg);
5416 _ast_trav((int)A_ROPG(ast), extra_arg);
5417 break;
5418 case A_CONV:
5419 _ast_trav((int)A_LOPG(ast), extra_arg);
5420 break;
5421 case A_PAREN:
5422 _ast_trav((int)A_LOPG(ast), extra_arg);
5423 break;
5424 case A_MEM:
5425 _ast_trav((int)A_PARENTG(ast), extra_arg);
5426 _ast_trav((int)A_MEMG(ast), extra_arg);
5427 break;
5428 case A_SUBSCR:
5429 asd = A_ASDG(ast);
5430 _ast_trav((int)A_LOPG(ast), extra_arg);
5431 for (i = 0; i < (int)ASD_NDIM(asd); i++)
5432 _ast_trav((int)ASD_SUBS(asd, i), extra_arg);
5433 break;
5434 case A_SUBSTR:
5435 _ast_trav((int)A_LOPG(ast), extra_arg);
5436 if (A_LEFTG(ast))
5437 _ast_trav((int)A_LEFTG(ast), extra_arg);
5438 if (A_RIGHTG(ast))
5439 _ast_trav((int)A_RIGHTG(ast), extra_arg);
5440 break;
5441 case A_INIT:
5442 if (A_LEFTG(ast))
5443 _ast_trav((int)A_LEFTG(ast), extra_arg);
5444 if (A_RIGHTG(ast))
5445 _ast_trav((int)A_RIGHTG(ast), extra_arg);
5446 break;
5447 case A_TRIPLE:
5448 /* [lb]:[ub][:stride] */
5449 if (A_LBDG(ast))
5450 _ast_trav((int)A_LBDG(ast), extra_arg);
5451 if (A_UPBDG(ast))
5452 _ast_trav((int)A_UPBDG(ast), extra_arg);
5453 if (A_STRIDEG(ast))
5454 _ast_trav((int)A_STRIDEG(ast), extra_arg);
5455 break;
5456 case A_INTR:
5457 case A_CALL:
5458 case A_ICALL:
5459 case A_FUNC:
5460 _ast_trav((int)A_LOPG(ast), extra_arg);
5461 cnt = A_ARGCNTG(ast);
5462 argt = A_ARGSG(ast);
5463 for (i = 0; i < cnt; i++)
5464 /* watch for optional args */
5465 if (ARGT_ARG(argt, i) != 0)
5466 _ast_trav((int)ARGT_ARG(argt, i), extra_arg);
5467 break;
5468 case A_ASN:
5469 _ast_trav((int)A_DESTG(ast), extra_arg);
5470 _ast_trav((int)A_SRCG(ast), extra_arg);
5471 break;
5472 case A_IF:
5473 _ast_trav((int)A_IFEXPRG(ast), extra_arg);
5474 _ast_trav((int)A_IFSTMTG(ast), extra_arg);
5475 break;
5476 case A_IFTHEN:
5477 _ast_trav((int)A_IFEXPRG(ast), extra_arg);
5478 break;
5479 case A_ELSE:
5480 break;
5481 case A_ELSEIF:
5482 _ast_trav((int)A_IFEXPRG(ast), extra_arg);
5483 break;
5484 case A_AIF:
5485 _ast_trav((int)A_IFEXPRG(ast), extra_arg);
5486 _ast_trav((int)A_L1G(ast), extra_arg);
5487 _ast_trav((int)A_L2G(ast), extra_arg);
5488 _ast_trav((int)A_L3G(ast), extra_arg);
5489 break;
5490 case A_GOTO:
5491 _ast_trav((int)A_L1G(ast), extra_arg);
5492 break;
5493 case A_CGOTO:
5494 for (astli = A_LISTG(ast); astli; astli = ASTLI_NEXT(astli))
5495 _ast_trav((int)ASTLI_AST(astli), extra_arg);
5496 _ast_trav((int)A_LOPG(ast), extra_arg);
5497 break;
5498 case A_AGOTO:
5499 _ast_trav((int)A_LOPG(ast), extra_arg);
5500 for (astli = A_LISTG(ast); astli; astli = ASTLI_NEXT(astli))
5501 _ast_trav((int)ASTLI_AST(astli), extra_arg);
5502 break;
5503 case A_ASNGOTO:
5504 #if DEBUG
5505 assert(A_TYPEG(A_SRCG(ast)) == A_LABEL,
5506 "_ast_trav, src A_ASNGOTO not label", A_SRCG(ast), 3);
5507 #endif
5508 if ((i = FMTPTG(A_SPTRG(A_SRCG(ast)))))
5509 _ast_trav((int)A_DESTG(ast), extra_arg);
5510 else {
5511 _ast_trav((int)A_SRCG(ast), extra_arg);
5512 _ast_trav((int)A_DESTG(ast), extra_arg);
5513 }
5514 break;
5515 case A_DO:
5516 if (A_DOLABG(ast))
5517 _ast_trav((int)A_DOLABG(ast), extra_arg);
5518 _ast_trav((int)A_DOVARG(ast), extra_arg);
5519 _ast_trav((int)A_M1G(ast), extra_arg);
5520 _ast_trav((int)A_M2G(ast), extra_arg);
5521 if (A_M3G(ast))
5522 _ast_trav((int)A_M3G(ast), extra_arg);
5523 if (A_M4G(ast))
5524 _ast_trav((int)A_M4G(ast), extra_arg);
5525 break;
5526 case A_DOWHILE:
5527 if (A_DOLABG(ast))
5528 _ast_trav((int)A_DOLABG(ast), extra_arg);
5529 _ast_trav((int)A_IFEXPRG(ast), extra_arg);
5530 break;
5531 case A_STOP:
5532 case A_PAUSE:
5533 if (A_LOPG(ast))
5534 _ast_trav((int)A_LOPG(ast), extra_arg);
5535 break;
5536 case A_RETURN:
5537 if (A_LOPG(ast))
5538 _ast_trav((int)A_LOPG(ast), extra_arg);
5539 break;
5540 case A_ALLOC:
5541 if (A_LOPG(ast))
5542 _ast_trav((int)A_LOPG(ast), extra_arg);
5543 if (A_DESTG(ast))
5544 _ast_trav((int)A_DESTG(ast), extra_arg);
5545 if (A_M3G(ast))
5546 _ast_trav((int)A_M3G(ast), extra_arg);
5547 if (A_STARTG(ast))
5548 _ast_trav((int)A_STARTG(ast), extra_arg);
5549 if (A_DEVSRCG(ast))
5550 _ast_trav((int)A_DEVSRCG(ast), extra_arg);
5551 if (A_ALIGNG(ast))
5552 _ast_trav((int)A_ALIGNG(ast), extra_arg);
5553 _ast_trav((int)A_SRCG(ast), extra_arg);
5554 break;
5555 case A_WHERE:
5556 _ast_trav((int)A_IFEXPRG(ast), extra_arg);
5557 if (A_IFSTMTG(ast))
5558 _ast_trav((int)A_IFSTMTG(ast), extra_arg);
5559 break;
5560 case A_ELSEFORALL:
5561 case A_ELSEWHERE:
5562 break;
5563 case A_FORALL:
5564 for (astli = A_LISTG(ast); astli; astli = ASTLI_NEXT(astli))
5565 _ast_trav((int)ASTLI_TRIPLE(astli), extra_arg);
5566 if (A_IFEXPRG(ast))
5567 _ast_trav((int)A_IFEXPRG(ast), extra_arg);
5568 if (A_IFSTMTG(ast))
5569 _ast_trav((int)A_IFSTMTG(ast), extra_arg);
5570 break;
5571 case A_REDIM:
5572 _ast_trav((int)A_SRCG(ast), extra_arg);
5573 break;
5574 case A_ENTRY:
5575 case A_COMMENT:
5576 case A_COMSTR:
5577 case A_ENDIF:
5578 case A_ENDWHERE:
5579 case A_ENDFORALL:
5580 case A_ENDDO:
5581 case A_CONTINUE:
5582 case A_END:
5583 break;
5584 case A_REALIGN:
5585 case A_REDISTRIBUTE:
5586 _ast_trav((int)A_LOPG(ast), extra_arg);
5587 break;
5588 case A_HLOCALIZEBNDS:
5589 if (A_LOPG(ast))
5590 _ast_trav((int)A_LOPG(ast), extra_arg);
5591 if (A_ITRIPLEG(ast))
5592 _ast_trav((int)A_ITRIPLEG(ast), extra_arg);
5593 if (A_OTRIPLEG(ast))
5594 _ast_trav((int)A_OTRIPLEG(ast), extra_arg);
5595 if (A_DIMG(ast))
5596 _ast_trav((int)A_DIMG(ast), extra_arg);
5597 break;
5598 case A_HALLOBNDS:
5599 if (A_LOPG(ast))
5600 _ast_trav((int)A_LOPG(ast), extra_arg);
5601 break;
5602 case A_HCYCLICLP:
5603 if (A_LOPG(ast))
5604 _ast_trav((int)A_LOPG(ast), extra_arg);
5605 if (A_ITRIPLEG(ast))
5606 _ast_trav((int)A_ITRIPLEG(ast), extra_arg);
5607 if (A_OTRIPLEG(ast))
5608 _ast_trav((int)A_OTRIPLEG(ast), extra_arg);
5609 if (A_OTRIPLE1G(ast))
5610 _ast_trav((int)A_OTRIPLE1G(ast), extra_arg);
5611 if (A_DIMG(ast))
5612 _ast_trav((int)A_DIMG(ast), extra_arg);
5613 break;
5614 case A_HOFFSET:
5615 _ast_trav((int)A_DESTG(ast), extra_arg);
5616 _ast_trav((int)A_LOPG(ast), extra_arg);
5617 _ast_trav((int)A_ROPG(ast), extra_arg);
5618 break;
5619 case A_HSECT:
5620 if (A_LOPG(ast))
5621 _ast_trav((int)A_LOPG(ast), extra_arg);
5622 if (A_BVECTG(ast))
5623 _ast_trav((int)A_BVECTG(ast), extra_arg);
5624 break;
5625 case A_HCOPYSECT:
5626 if (A_DESTG(ast))
5627 _ast_trav((int)A_DESTG(ast), extra_arg);
5628 if (A_SRCG(ast))
5629 _ast_trav((int)A_SRCG(ast), extra_arg);
5630 if (A_DDESCG(ast))
5631 _ast_trav((int)A_DDESCG(ast), extra_arg);
5632 if (A_SDESCG(ast))
5633 _ast_trav((int)A_SDESCG(ast), extra_arg);
5634 break;
5635 case A_HPERMUTESECT:
5636 if (A_DESTG(ast))
5637 _ast_trav((int)A_DESTG(ast), extra_arg);
5638 if (A_SRCG(ast))
5639 _ast_trav((int)A_SRCG(ast), extra_arg);
5640 if (A_DDESCG(ast))
5641 _ast_trav((int)A_DDESCG(ast), extra_arg);
5642 if (A_SDESCG(ast))
5643 _ast_trav((int)A_SDESCG(ast), extra_arg);
5644 if (A_BVECTG(ast))
5645 _ast_trav((int)A_BVECTG(ast), extra_arg);
5646 break;
5647 case A_HOVLPSHIFT:
5648 if (A_SRCG(ast))
5649 _ast_trav((int)A_SRCG(ast), extra_arg);
5650 if (A_SDESCG(ast))
5651 _ast_trav((int)A_SDESCG(ast), extra_arg);
5652 break;
5653 case A_HGETSCLR:
5654 if (A_DESTG(ast))
5655 _ast_trav((int)A_DESTG(ast), extra_arg);
5656 if (A_SRCG(ast))
5657 _ast_trav((int)A_SRCG(ast), extra_arg);
5658 if (A_LOPG(ast))
5659 _ast_trav((int)A_LOPG(ast), extra_arg);
5660 break;
5661 case A_HGATHER:
5662 case A_HSCATTER:
5663 if (A_VSUBG(ast))
5664 _ast_trav((int)A_VSUBG(ast), extra_arg);
5665 if (A_DESTG(ast))
5666 _ast_trav((int)A_DESTG(ast), extra_arg);
5667 if (A_SRCG(ast))
5668 _ast_trav((int)A_SRCG(ast), extra_arg);
5669 if (A_DDESCG(ast))
5670 _ast_trav((int)A_DDESCG(ast), extra_arg);
5671 if (A_SDESCG(ast))
5672 _ast_trav((int)A_SDESCG(ast), extra_arg);
5673 if (A_MDESCG(ast))
5674 _ast_trav((int)A_MDESCG(ast), extra_arg);
5675 if (A_BVECTG(ast))
5676 _ast_trav((int)A_BVECTG(ast), extra_arg);
5677 break;
5678 case A_HCSTART:
5679 if (A_LOPG(ast))
5680 _ast_trav((int)A_LOPG(ast), extra_arg);
5681 if (A_DESTG(ast))
5682 _ast_trav((int)A_DESTG(ast), extra_arg);
5683 if (A_SRCG(ast))
5684 _ast_trav((int)A_SRCG(ast), extra_arg);
5685 break;
5686 case A_HCFINISH:
5687 case A_HCFREE:
5688 if (A_LOPG(ast))
5689 _ast_trav((int)A_LOPG(ast), extra_arg);
5690 break;
5691 case A_HOWNERPROC:
5692 if (A_LOPG(ast))
5693 _ast_trav((int)A_LOPG(ast), extra_arg);
5694 if (A_DIMG(ast))
5695 _ast_trav((int)A_DIMG(ast), extra_arg);
5696 if (A_M1G(ast))
5697 _ast_trav((int)A_M1G(ast), extra_arg);
5698 if (A_M2G(ast))
5699 _ast_trav((int)A_M2G(ast), extra_arg);
5700 break;
5701 case A_MASTER:
5702 #if DEBUG
5703 assert(A_LOPG(ast), "_ast_trav, A_MASTER LOP field not set", ast, 2);
5704 #endif
5705 /*_ast_trav((int)A_LOPG(ast), extra_arg);*/
5706 break;
5707 case A_ENDMASTER:
5708 #if DEBUG
5709 assert(A_LOPG(ast), "_ast_trav, A_ENDMASTER LOP field not set", ast, 2);
5710 #endif
5711 /*_ast_trav((int)A_LOPG(ast), extra_arg);*/
5712 cnt = A_ARGCNTG(ast);
5713 argt = A_ARGSG(ast);
5714 for (i = 0; i < cnt; i++)
5715 _ast_trav((int)ARGT_ARG(argt, i), extra_arg);
5716 break;
5717 case A_CRITICAL:
5718 case A_ENDCRITICAL:
5719 #if DEBUG
5720 assert(A_LOPG(ast), "_ast_trav, A_[END]CRITICAL LOP field not set", ast, 2);
5721 #endif
5722 /*_ast_trav((int)A_LOPG(ast), extra_arg);*/
5723 break;
5724 case A_ATOMIC:
5725 case A_ATOMICCAPTURE:
5726 case A_ATOMICREAD:
5727 case A_ATOMICWRITE:
5728 case A_ENDATOMIC:
5729 case A_BARRIER:
5730 case A_NOBARRIER:
5731 break;
5732 case A_MP_PARALLEL:
5733 #if DEBUG
5734 assert(A_LOPG(ast), "_ast_trav, A_MP_PARALLEL LOP field not set", ast, 2);
5735 #endif
5736 if (A_IFPARG(ast))
5737 _ast_trav((int)A_IFPARG(ast), extra_arg);
5738 if (A_NPARG(ast))
5739 _ast_trav((int)A_NPARG(ast), extra_arg);
5740 if (A_ENDLABG(ast))
5741 _ast_trav((int)A_ENDLABG(ast), extra_arg);
5742 if (A_PROCBINDG(ast))
5743 _ast_trav((int)A_PROCBINDG(ast), extra_arg);
5744 /*_ast_trav((int)A_LOPG(ast), extra_arg);*/
5745 break;
5746 case A_MP_ENDPARALLEL:
5747 #if DEBUG
5748 assert(A_LOPG(ast), "_ast_trav, A_MP_ENDPARALLEL LOP field not set", ast,
5749 2);
5750 #endif
5751 /*_ast_trav((int)A_LOPG(ast), extra_arg);*/
5752 break;
5753 case A_MP_TEAMS:
5754 #if DEBUG
5755 assert(A_LOPG(ast), "_ast_trav, A_MP_TEAMS LOP field not set", ast, 2);
5756 #endif
5757 if (A_NTEAMSG(ast))
5758 _ast_trav((int)A_NTEAMSG(ast), extra_arg);
5759 if (A_THRLIMITG(ast))
5760 _ast_trav((int)A_THRLIMITG(ast), extra_arg);
5761 /*_ast_trav((int)A_LOPG(ast), extra_arg);*/
5762 break;
5763 case A_MP_TARGET:
5764 #if DEBUG
5765 assert(A_LOPG(ast), "_ast_trav, A_MP_TARGET LOP field not set", ast, 2);
5766 #endif
5767 if (A_IFPARG(ast))
5768 _ast_trav((int)A_IFPARG(ast), extra_arg);
5769 break;
5770 case A_MP_ENDTARGET:
5771 #if DEBUG
5772 assert(A_LOPG(ast), "_ast_trav, A_MP_ENDTARGET LOP field not set", ast, 2);
5773 #endif
5774 /*_ast_trav((int)A_LOPG(ast), extra_arg);*/
5775 break;
5776 case A_MP_TARGETDATA:
5777 #if DEBUG
5778 assert(A_LOPG(ast), "_ast_trav, A_MP_TARGETDATA LOP field not set", ast, 2);
5779 #endif
5780 if (A_IFPARG(ast))
5781 _ast_trav((int)A_IFPARG(ast), extra_arg);
5782 break;
5783 case A_MP_ENDTARGETDATA:
5784 #if DEBUG
5785 assert(A_LOPG(ast), "_ast_trav, A_MP_ENDTARGETDATA LOP field not set", ast,
5786 2);
5787 #endif
5788 /*_ast_trav((int)A_LOPG(ast), extra_arg);*/
5789 break;
5790
5791 case A_MP_TARGETUPDATE:
5792 case A_MP_TARGETENTERDATA:
5793 case A_MP_TARGETEXITDATA:
5794 if (A_IFPARG(ast))
5795 _ast_trav((int)A_IFPARG(ast), extra_arg);
5796 break;
5797
5798 case A_MP_TASK:
5799 #if DEBUG
5800 assert(A_LOPG(ast), "_ast_trav, A_MP_TASK LOP field not set", ast, 2);
5801 #endif
5802 if (A_IFPARG(ast))
5803 _ast_trav((int)A_IFPARG(ast), extra_arg);
5804 if (A_ENDLABG(ast))
5805 _ast_trav((int)A_ENDLABG(ast), extra_arg);
5806 /*_ast_trav((int)A_LOPG(ast), extra_arg);*/
5807 break;
5808 case A_MP_ENDTASK:
5809 #if DEBUG
5810 assert(A_LOPG(ast), "_ast_trav, A_MP_ENDTASK LOP field not set", ast, 2);
5811 #endif
5812 /*_ast_trav((int)A_LOPG(ast), extra_arg);*/
5813 break;
5814 case A_MP_TASKLOOP:
5815 #if DEBUG
5816 assert(A_LOPG(ast), "_ast_trav, A_MP_TASKLOOP LOP field not set", ast, 2);
5817 #endif
5818 if (A_IFPARG(ast))
5819 _ast_trav((int)A_IFPARG(ast), extra_arg);
5820 if (A_FINALPARG(ast))
5821 _ast_trav((int)A_FINALPARG(ast), extra_arg);
5822 if (A_PRIORITYG(ast))
5823 _ast_trav((int)A_PRIORITYG(ast), extra_arg);
5824 /*_ast_trav((int)A_LOPG(ast), extra_arg);*/
5825 break;
5826 case A_MP_ETASKLOOP:
5827 #if DEBUG
5828 assert(A_LOPG(ast), "_ast_trav, A_MP_ETASKLOOP LOP field not set", ast, 2);
5829 #endif
5830 /*_ast_trav((int)A_LOPG(ast), extra_arg);*/
5831 break;
5832 case A_MP_CRITICAL:
5833 case A_MP_ENDCRITICAL:
5834 #if DEBUG
5835 assert(A_LOPG(ast), "_ast_trav, A_MP_[END]CRITICAL LOP field not set", ast,
5836 2);
5837 #endif
5838 /*_ast_trav((int)A_LOPG(ast), extra_arg);*/
5839 break;
5840 case A_MP_ATOMIC:
5841 case A_MP_ENDATOMIC:
5842 break;
5843 case A_MP_CANCEL:
5844 if (A_IFPARG(ast))
5845 _ast_trav((int)A_IFPARG(ast), extra_arg);
5846 #if DEBUG
5847 assert(A_ENDLABG(ast), "_ast_trav, A_MP_CANCEL ENDLAB field not set", ast,
5848 2);
5849 #endif
5850 if (A_ENDLABG(ast))
5851 _ast_trav((int)A_ENDLABG(ast), extra_arg);
5852 break;
5853 case A_MP_CANCELLATIONPOINT:
5854 #if DEBUG
5855 assert(A_ENDLABG(ast),
5856 "_ast_trav, A_MP_CANCELLATIONPOINT ENDLAB field not set", ast, 2);
5857 #endif
5858 if (A_ENDLABG(ast))
5859 _ast_trav((int)A_ENDLABG(ast), extra_arg);
5860 break;
5861 case A_MP_MASTER:
5862 case A_MP_ENDMASTER:
5863 #if DEBUG
5864 assert(A_LOPG(ast), "_ast_trav, A_MP_[END]MASTER LOP field not set", ast,
5865 2);
5866 #endif
5867 /*_ast_trav((int)A_LOPG(ast), extra_arg);*/
5868 break;
5869 case A_MP_SINGLE:
5870 case A_MP_ENDSINGLE:
5871 #if DEBUG
5872 assert(A_LOPG(ast), "_ast_trav, A_MP_[END]SINGLE LOP field not set", ast,
5873 2);
5874 #endif
5875 /*_ast_trav((int)A_LOPG(ast), extra_arg);*/
5876 break;
5877 case A_MP_TASKFIRSTPRIV:
5878 #if DEBUG
5879 assert(A_LOPG(ast), "_ast_trav, A_MP_TASKFIRSTPRIV LOP field not set", ast,
5880 2);
5881 assert(A_ROPG(ast), "_ast_trav, A_MP_TASKFIRSTPRIV ROP field not set", ast,
5882 2);
5883 #endif
5884 if (A_LOPG(ast))
5885 _ast_trav((int)A_LOPG(ast), extra_arg);
5886 if (A_ROPG(ast))
5887 _ast_trav((int)A_ROPG(ast), extra_arg);
5888 break;
5889 case A_MP_ENDTEAMS:
5890 case A_MP_DISTRIBUTE:
5891 case A_MP_ENDDISTRIBUTE:
5892 case A_MP_TASKGROUP:
5893 case A_MP_ETASKGROUP:
5894 case A_MP_BARRIER:
5895 case A_MP_ETASKDUP:
5896 case A_MP_TASKWAIT:
5897 case A_MP_TASKYIELD:
5898 case A_MP_SECTION:
5899 case A_MP_LSECTION:
5900 case A_MP_ENDPDO:
5901 case A_MP_PRE_TLS_COPY:
5902 case A_MP_BCOPYIN:
5903 case A_MP_COPYIN:
5904 case A_MP_ECOPYIN:
5905 case A_MP_BCOPYPRIVATE:
5906 case A_MP_COPYPRIVATE:
5907 case A_MP_ECOPYPRIVATE:
5908 case A_MP_EMPSCOPE:
5909 case A_MP_FLUSH:
5910 case A_MP_TASKREG:
5911 case A_MP_TASKDUP:
5912 case A_MP_ETASKLOOPREG:
5913 case A_MP_MAP:
5914 case A_MP_EMAP:
5915 case A_MP_TARGETLOOPTRIPCOUNT:
5916 case A_MP_EREDUCTION:
5917 case A_MP_BREDUCTION:
5918 case A_MP_REDUCTIONITEM:
5919 break;
5920 case A_MP_BMPSCOPE:
5921 #if DEBUG
5922 assert(A_STBLKG(ast), "_ast_trav, A_MP_BMPSCOPE STBLK field not set", ast,
5923 2);
5924 #endif
5925 if (A_STBLKG(ast))
5926 _ast_trav((int)A_STBLKG(ast), extra_arg);
5927 break;
5928 case A_MP_TASKLOOPREG:
5929 if (A_M1G(ast))
5930 _ast_trav((int)A_M1G(ast), extra_arg);
5931 if (A_M2G(ast))
5932 _ast_trav((int)A_M2G(ast), extra_arg);
5933 if (A_M3G(ast))
5934 _ast_trav((int)A_M3G(ast), extra_arg);
5935 break;
5936 case A_MP_PDO:
5937 if (A_DOLABG(ast))
5938 _ast_trav((int)A_DOLABG(ast), extra_arg);
5939 _ast_trav((int)A_DOVARG(ast), extra_arg);
5940 if (A_LASTVALG(ast))
5941 _ast_trav((int)A_LASTVALG(ast), extra_arg);
5942 _ast_trav((int)A_M1G(ast), extra_arg);
5943 _ast_trav((int)A_M2G(ast), extra_arg);
5944 if (A_M3G(ast))
5945 _ast_trav((int)A_M3G(ast), extra_arg);
5946 if (A_CHUNKG(ast))
5947 _ast_trav((int)A_CHUNKG(ast), extra_arg);
5948 if (A_ENDLABG(ast))
5949 _ast_trav((int)A_ENDLABG(ast), extra_arg);
5950 break;
5951 case A_MP_SECTIONS:
5952 if (A_ENDLABG(ast))
5953 _ast_trav((int)A_ENDLABG(ast), extra_arg);
5954 break;
5955 case A_MP_ATOMICREAD:
5956 if (A_SRCG(ast))
5957 _ast_trav((int)A_SRCG(ast), extra_arg);
5958 break;
5959 case A_MP_ATOMICWRITE:
5960 case A_MP_ATOMICUPDATE:
5961 case A_MP_ATOMICCAPTURE:
5962 if (A_LOPG(ast))
5963 _ast_trav((int)A_LOPG(ast), extra_arg);
5964 if (A_ROPG(ast))
5965 _ast_trav((int)A_ROPG(ast), extra_arg);
5966 break;
5967 case A_MP_ENDSECTIONS:
5968 case A_MP_WORKSHARE:
5969 case A_MP_ENDWORKSHARE:
5970 case A_MP_BPDO:
5971 case A_MP_EPDO:
5972 case A_MP_BORDERED:
5973 case A_MP_EORDERED:
5974 break;
5975 case A_PREFETCH:
5976 #if DEBUG
5977 assert(A_LOPG(ast), "_ast_trav, A_PREFETCH LOP field not set", ast, 2);
5978 #endif
5979 _ast_trav((int)A_LOPG(ast), extra_arg);
5980 break;
5981 case A_PRAGMA:
5982 if (A_LOPG(ast))
5983 _ast_trav((int)A_LOPG(ast), extra_arg);
5984 if (A_ROPG(ast))
5985 _ast_trav((int)A_ROPG(ast), extra_arg);
5986 break;
5987 default:
5988 interr("ast_trav_recurse:bad astype", atype, 3);
5989 }
5990 }
5991
5992 static int indent = 0;
5993
5994 /* routine must be externally visible */
5995 void
_dump_shape(int shd,FILE * file)5996 _dump_shape(int shd, FILE *file)
5997 {
5998 int l, nd, ii;
5999
6000 if (file == NULL)
6001 file = stderr;
6002 for (l = 0; l < indent; ++l)
6003 fprintf(file, " ");
6004 fprintf(file, " shape:%5d\n", shd);
6005 nd = SHD_NDIM(shd);
6006 for (ii = 0; ii < nd; ++ii) {
6007 for (l = 0; l < indent; ++l)
6008 fprintf(file, " ");
6009 fprintf(file, " [%d]. lwb: %5d upb: %5d stride: %5d\n", ii,
6010 SHD_LWB(shd, ii), SHD_UPB(shd, ii), SHD_STRIDE(shd, ii));
6011 }
6012 }
6013
6014 /* routine must be externally visible */
6015 void
dump_shape(int shd)6016 dump_shape(int shd)
6017 {
6018 _dump_shape(shd, gbl.dbgfil);
6019 }
6020
6021 /* routine must be externally visible */
6022 void
_dump_one_ast(int i,FILE * file)6023 _dump_one_ast(int i, FILE *file)
6024 {
6025 int asd, j, k;
6026 char typeb[512];
6027 int l, sptr;
6028
6029 if (i <= 0 || i > astb.stg_avail)
6030 return;
6031 if (file == NULL)
6032 file = stderr;
6033 for (l = 0; l < indent; ++l)
6034 fprintf(file, " ");
6035 fprintf(file, "%-10s hshlk/std:%5d", astb.atypes[A_TYPEG(i)],
6036 (int)A_HSHLKG(i));
6037 switch (A_TYPEG(i)) {
6038 default:
6039 break;
6040 case A_ID:
6041 case A_CNST:
6042 case A_BINOP:
6043 case A_UNOP:
6044 case A_CMPLXC:
6045 case A_CONV:
6046 case A_PAREN:
6047 case A_MEM:
6048 case A_SUBSCR:
6049 case A_SUBSTR:
6050 case A_FUNC:
6051 case A_INTR:
6052 case A_INIT:
6053 case A_ASN:
6054 getdtype(A_DTYPEG(i), typeb);
6055 fprintf(file, " type:%s", typeb);
6056 break;
6057 }
6058 switch (A_TYPEG(i)) {
6059 default:
6060 break;
6061 case A_ID:
6062 case A_BINOP:
6063 case A_UNOP:
6064 case A_CMPLXC:
6065 case A_CONV:
6066 case A_PAREN:
6067 case A_SUBSTR:
6068 case A_FUNC:
6069 case A_INTR:
6070 fprintf(file, " alias:%5d callfg:%d", (int)A_ALIASG(i),
6071 (int)A_CALLFGG(i));
6072 break;
6073 }
6074 if (A_VISITG(i))
6075 fprintf(file, " visit=%d", A_VISITG(i));
6076 fprintf(file, " opt=(%d,%d)\n", (int)A_OPT1G(i), (int)A_OPT2G(i));
6077 for (l = 0; l < indent; ++l)
6078 fprintf(file, " ");
6079 fprintf(file, "aptr:%5d", i);
6080 switch (A_TYPEG(i)) {
6081 case A_NULL:
6082 fprintf(file, " <null_ast>");
6083 break;
6084 case A_ID:
6085 case A_LABEL:
6086 case A_ENTRY:
6087 fprintf(file, " sptr:%5d (%s)", (int)A_SPTRG(i), SYMNAME(A_SPTRG(i)));
6088 break;
6089 case A_CNST:
6090 #if DEBUG
6091 assert(i == A_ALIASG(i), "dump_one_ast, alias of cnst not self", i, 3);
6092 #endif
6093 fprintf(file, " sptr:%5d (%s)", (int)A_SPTRG(i),
6094 getprint((int)A_SPTRG(i)));
6095 break;
6096 case A_BINOP:
6097 fprintf(file, " lop :%5d rop:%5d optype:%d", (int)A_LOPG(i),
6098 (int)A_ROPG(i), (int)A_OPTYPEG(i));
6099 break;
6100 case A_UNOP:
6101 fprintf(file, " lop :%5d optype:%d", (int)A_LOPG(i), (int)A_OPTYPEG(i));
6102 if (i == astb.ptr0)
6103 fprintf(file, " ptr0");
6104 else if (i == astb.ptr1)
6105 fprintf(file, " ptr1");
6106 else if (i == astb.ptr0c)
6107 fprintf(file, " ptr0c");
6108 break;
6109 case A_CMPLXC:
6110 fprintf(file, " lop :%5d rop:%5d", (int)A_LOPG(i), (int)A_ROPG(i));
6111 break;
6112 case A_CONV:
6113 fprintf(file, " opnd:%5d", (int)A_LOPG(i));
6114 break;
6115 case A_PAREN:
6116 fprintf(file, " opnd:%5d", (int)A_LOPG(i));
6117 break;
6118 case A_MEM:
6119 fprintf(file, " parent:%5d mem:%5d", (int)A_PARENTG(i), (int)A_MEMG(i));
6120 if (A_ALIASG(i)) {
6121 fprintf(file, " alias:%5d", (int)A_ALIASG(i));
6122 }
6123 break;
6124 case A_SUBSCR:
6125 asd = A_ASDG(i);
6126 fprintf(file, " opnd:%5d asd:%5d", (int)A_LOPG(i), asd);
6127 if (A_ALIASG(i)) {
6128 fprintf(file, " alias:%5d", (int)A_ALIASG(i));
6129 }
6130 for (j = 0; j < (int)ASD_NDIM(asd); j++) {
6131 fprintf(file, "\n");
6132 for (l = 0; l < indent; ++l)
6133 fprintf(file, " ");
6134 fprintf(file, " [%d]:%5d", j + 1, (int)ASD_SUBS(asd, j));
6135 }
6136 break;
6137 case A_SUBSTR:
6138 fprintf(file, " opnd:%5d left:%5d right:%5d", (int)A_LOPG(i),
6139 (int)A_LEFTG(i), (int)A_RIGHTG(i));
6140 break;
6141 case A_TRIPLE:
6142 fprintf(file, " lb:%5d, ub:%5d, stride:%5d", (int)A_LBDG(i),
6143 (int)A_UPBDG(i), (int)A_STRIDEG(i));
6144 break;
6145 case A_FUNC:
6146 case A_INTR:
6147 case A_CALL:
6148 case A_ICALL:
6149 j = A_ARGCNTG(i);
6150 fprintf(file, " lop:%5d argcnt:%5d args:%5d", (int)A_LOPG(i), j,
6151 (int)A_ARGSG(i));
6152 if (A_TYPEG(i) == A_INTR || A_TYPEG(i) == A_ICALL || A_TYPEG(i) == A_INIT)
6153 fprintf(file, " optype:%5d", (int)A_OPTYPEG(i));
6154 k = 0;
6155 while (j--) {
6156 fprintf(file, "\n");
6157 for (l = 0; l < indent; ++l)
6158 fprintf(file, " ");
6159 fprintf(file, " (%5d):%5d", k, (int)ARGT_ARG(A_ARGSG(i), k));
6160 k++;
6161 }
6162 break;
6163 case A_ASN:
6164 case A_ASNGOTO:
6165 fprintf(file, " dest:%5d src:%5d", (int)A_DESTG(i), (int)A_SRCG(i));
6166 break;
6167 case A_IF:
6168 fprintf(file, " ifexpr:%5d ifstmt:%5d", (int)A_IFEXPRG(i),
6169 (int)A_IFSTMTG(i));
6170 break;
6171 case A_IFTHEN:
6172 fprintf(file, " ifexpr:%5d", (int)A_IFEXPRG(i));
6173 break;
6174 case A_ELSE:
6175 break;
6176 case A_ELSEIF:
6177 fprintf(file, " ifexpr:%5d", (int)A_IFEXPRG(i));
6178 break;
6179 case A_ENDIF:
6180 break;
6181 case A_AIF:
6182 fprintf(file, " ifexpr:%5d,", (int)A_IFEXPRG(i));
6183 fprintf(file, " l1:%5d, l2:%5d, l3:%5d", (int)A_L1G(i), (int)A_L2G(i),
6184 (int)A_L3G(i));
6185 break;
6186 case A_GOTO:
6187 fprintf(file, " l1:%5d", A_L1G(i));
6188 break;
6189 case A_CGOTO:
6190 case A_AGOTO:
6191 fprintf(file, " lop:%5d list:%5d", A_LOPG(i), j = A_LISTG(i));
6192 dump_astli(j);
6193 break;
6194 case A_DO:
6195 fprintf(file, " lab:%5d", (int)A_DOLABG(i));
6196 fprintf(file, " var:%5d", (int)A_DOVARG(i));
6197 fprintf(file, " m1:%5d", (int)A_M1G(i));
6198 fprintf(file, " m2:%5d", (int)A_M2G(i));
6199 fprintf(file, " m3:%5d", (int)A_M3G(i));
6200 fprintf(file, " m4:%5d", (int)A_M4G(i));
6201 break;
6202 case A_DOWHILE:
6203 fprintf(file, " lab:%5d", (int)A_DOLABG(i));
6204 fprintf(file, " ifexpr:%5d", (int)A_IFEXPRG(i));
6205 break;
6206 case A_ENDDO:
6207 case A_CONTINUE:
6208 case A_END:
6209 break;
6210 case A_STOP:
6211 case A_PAUSE:
6212 case A_RETURN:
6213 fprintf(file, " lop:%5d", (int)A_LOPG(i));
6214 break;
6215 case A_ALLOC:
6216 fprintf(file,
6217 " tkn:%5d lop:%5d src:%5d dest:%5d m3:%5d"
6218 "start:%5d dallocmem: %d firstalloc: %d devsrc: %d align: %d",
6219 (int)A_TKNG(i), (int)A_LOPG(i), A_SRCG(i), A_DESTG(i), A_M3G(i),
6220 A_STARTG(i), A_DALLOCMEMG(i), A_FIRSTALLOCG(i), A_DEVSRCG(i),
6221 A_ALIGNG(i));
6222 break;
6223 case A_WHERE:
6224 fprintf(file, " ifstmt:%5d ifexpr:%5d", (int)A_IFSTMTG(i),
6225 (int)A_IFEXPRG(i));
6226 break;
6227 case A_FORALL:
6228 fprintf(file, " ifstmt:%5d ifexpr:%5d src:%5d list:%5d",
6229 (int)A_IFSTMTG(i), (int)A_IFEXPRG(i), A_SRCG(i),
6230 j = (int)A_LISTG(i));
6231 dump_astli(j);
6232 break;
6233 case A_ELSEWHERE:
6234 case A_ENDWHERE:
6235 case A_ENDFORALL:
6236 case A_ELSEFORALL:
6237 break;
6238 case A_REDIM:
6239 fprintf(file, " src:%5d", (int)A_SRCG(i));
6240 break;
6241 case A_COMMENT:
6242 fprintf(file, " lop:%5d", (int)A_LOPG(i));
6243 break;
6244 case A_INIT:
6245 fprintf(file, " left:%5d right:%5d sptr:%5d (%s)", (int)A_LEFTG(i),
6246 (int)A_RIGHTG(i), (int)A_SPTRG(i), getprint((int)A_SPTRG(i)));
6247 break;
6248 case A_COMSTR:
6249 fprintf(file, " comment:%s", COMSTR(i));
6250 break;
6251 case A_HALLOBNDS:
6252 fprintf(file, " lop:%5d", A_LOPG(i));
6253 break;
6254 case A_HCYCLICLP:
6255 fprintf(file, " lop:%5d", A_LOPG(i));
6256 fprintf(file, " itriple:%5d", A_ITRIPLEG(i));
6257 fprintf(file, " otriple:%5d", A_OTRIPLEG(i));
6258 fprintf(file, " otriple1:%5d", A_OTRIPLE1G(i));
6259 fprintf(file, " dim:%5d", A_DIMG(i));
6260 break;
6261 case A_HOFFSET:
6262 fprintf(file, " dest:%5d", A_DESTG(i));
6263 fprintf(file, " lop:%5d", A_LOPG(i));
6264 fprintf(file, " rop:%5d", A_ROPG(i));
6265 break;
6266 case A_HSECT:
6267 fprintf(file, " lop:%5d", A_LOPG(i));
6268 fprintf(file, " bvect:%5d", A_BVECTG(i));
6269 break;
6270 case A_HCOPYSECT:
6271 fprintf(file, " dest:%5d", A_DESTG(i));
6272 fprintf(file, " src:%5d", A_SRCG(i));
6273 fprintf(file, " ddesc:%5d", A_DDESCG(i));
6274 fprintf(file, " sdesc:%5d", A_SDESCG(i));
6275 break;
6276 case A_HPERMUTESECT:
6277 fprintf(file, " dest:%5d", A_DESTG(i));
6278 fprintf(file, " src:%5d", A_SRCG(i));
6279 fprintf(file, " ddesc:%5d", A_DDESCG(i));
6280 fprintf(file, " sdesc:%5d", A_SDESCG(i));
6281 fprintf(file, " bvect:%5d", A_BVECTG(i));
6282 break;
6283 case A_HOVLPSHIFT:
6284 fprintf(file, " src:%5d", A_SRCG(i));
6285 fprintf(file, " sdesc:%5d", A_SDESCG(i));
6286 break;
6287 case A_HGETSCLR:
6288 fprintf(file, " dest:%5d", A_DESTG(i));
6289 fprintf(file, " src:%5d\n", A_SRCG(i));
6290 if (A_LOPG(i)) {
6291 fprintf(file, " lop:%5d\n", A_LOPG(i));
6292 }
6293 break;
6294 case A_HGATHER:
6295 case A_HSCATTER:
6296 fprintf(file, " vsub:%5d", A_VSUBG(i));
6297 fprintf(file, " dest:%5d", A_DESTG(i));
6298 fprintf(file, " src:%5d\n", A_SRCG(i));
6299 fprintf(file, " ddesc:%5d", A_DDESCG(i));
6300 fprintf(file, " sdesc:%5d", A_SDESCG(i));
6301 fprintf(file, " mdesc:%5d", A_MDESCG(i));
6302 fprintf(file, " bvect:%5d", A_BVECTG(i));
6303 break;
6304 case A_HCSTART:
6305 fprintf(file, " lop:%5d", A_LOPG(i));
6306 fprintf(file, " dest:%5d", A_DESTG(i));
6307 fprintf(file, " src:%5d\n", A_SRCG(i));
6308 break;
6309 case A_HCFINISH:
6310 case A_HCFREE:
6311 fprintf(file, " lop:%5d", A_LOPG(i));
6312 break;
6313 case A_MASTER:
6314 fprintf(file, " lop:%5d", A_LOPG(i));
6315 break;
6316 case A_ENDMASTER:
6317 fprintf(file, " lop:%5d", A_LOPG(i));
6318 j = A_ARGCNTG(i);
6319 fprintf(file, " argcnt:%5d", j);
6320 fprintf(file, " args:%5d\n", A_ARGSG(i));
6321 k = 0;
6322 while (j-- > 0) {
6323 fprintf(file, "\n");
6324 for (l = 0; l < indent; ++l)
6325 fprintf(file, " ");
6326 fprintf(file, " (%5d):%5d", k, (int)ARGT_ARG(A_ARGSG(i), k));
6327 k++;
6328 }
6329 break;
6330 case A_CRITICAL:
6331 case A_ENDCRITICAL:
6332 case A_ATOMIC:
6333 case A_ATOMICCAPTURE:
6334 case A_ATOMICREAD:
6335 case A_ATOMICWRITE:
6336 fprintf(file, " lop:%5d", A_LOPG(i));
6337 break;
6338 case A_ENDATOMIC:
6339 case A_BARRIER:
6340 case A_NOBARRIER:
6341 break;
6342 case A_MP_BMPSCOPE:
6343 fprintf(file, " stblk:%5d", A_STBLKG(i));
6344 break;
6345 case A_MP_EMPSCOPE:
6346 break;
6347 case A_MP_PARALLEL:
6348 fprintf(file, " lop:%5d", A_LOPG(i));
6349 fprintf(file, " ifpar:%5d", A_IFPARG(i));
6350 fprintf(file, " npar:%5d", A_NPARG(i));
6351 fprintf(file, " endlab:%5d", A_ENDLABG(i));
6352 fprintf(file, " procbind:%5d", A_PROCBINDG(i));
6353 break;
6354 case A_MP_ATOMICREAD:
6355 fprintf(file, " rhs/expr:%5d", A_SRCG(i));
6356 break;
6357 case A_MP_ATOMICWRITE:
6358 case A_MP_ATOMICUPDATE:
6359 case A_MP_ATOMICCAPTURE:
6360 fprintf(file, " lhs:%5d", A_LOPG(i));
6361 fprintf(file, " rhs/expr:%5d", A_ROPG(i));
6362 break;
6363 case A_MP_TEAMS:
6364 fprintf(file, " lop:%5d", A_LOPG(i));
6365 fprintf(file, " nteams:%5d", A_NTEAMSG(i));
6366 fprintf(file, " thrlimit:%5d", A_THRLIMITG(i));
6367 break;
6368 case A_MP_TASKFIRSTPRIV:
6369 fprintf(file, " lop:%5d", A_LOPG(i));
6370 fprintf(file, " rop:%5d", A_ROPG(i));
6371 break;
6372 case A_MP_TASK:
6373 fprintf(file, " lop:%5d", A_LOPG(i));
6374 fprintf(file, " ifpar:%5d", A_IFPARG(i));
6375 fprintf(file, " final:%5d", A_FINALPARG(i));
6376 if (A_UNTIEDG(i))
6377 fprintf(file, " untied");
6378 if (A_EXEIMMG(i))
6379 fprintf(file, " exeimm");
6380 if (A_MERGEABLEG(i))
6381 fprintf(file, " mergeable");
6382 if (A_ENDLABG(i))
6383 fprintf(file, " endlab:%5d", A_ENDLABG(i));
6384 break;
6385 case A_MP_TASKLOOP:
6386 fprintf(file, " lop:%5d", A_LOPG(i));
6387 fprintf(file, " ifpar:%5d", A_IFPARG(i));
6388 fprintf(file, " final:%5d", A_FINALPARG(i));
6389 fprintf(file, " priority:%5d", A_PRIORITYG(i));
6390 if (A_UNTIEDG(i))
6391 fprintf(file, " untied");
6392 if (A_EXEIMMG(i))
6393 fprintf(file, " exeimm");
6394 if (A_MERGEABLEG(i))
6395 fprintf(file, " mergeable");
6396 if (A_NOGROUPG(i))
6397 fprintf(file, " nogroup");
6398 if (A_GRAINSIZEG(i))
6399 fprintf(file, " grainsize");
6400 if (A_NUM_TASKSG(i))
6401 fprintf(file, " num_tasks");
6402 break;
6403 case A_MP_TARGET:
6404 fprintf(file, " iftarget:%5d", A_IFPARG(i));
6405 break;
6406 case A_MP_TARGETUPDATE:
6407 fprintf(file, " iftargetupdate:%5d", A_IFPARG(i));
6408 break;
6409 case A_MP_TARGETEXITDATA:
6410 fprintf(file, " iftargetexitdata:%5d", A_IFPARG(i));
6411 break;
6412 case A_MP_TARGETENTERDATA:
6413 fprintf(file, " iftargetenterdata:%5d", A_IFPARG(i));
6414 break;
6415 case A_MP_TARGETDATA:
6416 fprintf(file, " iftargetdata:%5d", A_IFPARG(i));
6417 break;
6418
6419 case A_MP_ENDPARALLEL:
6420 case A_MP_CRITICAL:
6421 case A_MP_ENDCRITICAL:
6422 case A_MP_ATOMIC:
6423 case A_MP_ENDATOMIC:
6424 case A_MP_MASTER:
6425 case A_MP_ENDMASTER:
6426 case A_MP_SINGLE:
6427 case A_MP_ENDSINGLE:
6428 case A_MP_ENDSECTIONS:
6429 case A_MP_SECTIONS:
6430 fprintf(file, " endlab:%5d", (int)A_ENDLABG(i));
6431 break;
6432 case A_MP_ENDTASK:
6433 fprintf(file, " lop:%5d", A_LOPG(i));
6434 break;
6435 case A_MP_CANCEL:
6436 fprintf(file, " ifcancel:%5d", A_IFPARG(i));
6437 fprintf(file, " cancelkind:%5d", A_CANCELKINDG(i));
6438 fprintf(file, " endlab:%5d", (int)A_ENDLABG(i));
6439 break;
6440 case A_MP_CANCELLATIONPOINT:
6441 fprintf(file, " cancelkind:%5d", A_CANCELKINDG(i));
6442 fprintf(file, " endlab:%5d", (int)A_ENDLABG(i));
6443 break;
6444 case A_MP_PDO:
6445 fprintf(file, " lab:%5d", (int)A_DOLABG(i));
6446 fprintf(file, " var:%5d", (int)A_DOVARG(i));
6447 fprintf(file, " lastvar:%5d", (int)A_LASTVALG(i));
6448 fprintf(file, " m1:%5d", (int)A_M1G(i));
6449 fprintf(file, " m2:%5d", (int)A_M2G(i));
6450 fprintf(file, " m3:%5d\n", (int)A_M3G(i));
6451 fprintf(file, " chunk:%5d", (int)A_CHUNKG(i));
6452 fprintf(file, " sched_type:%5d", (int)A_SCHED_TYPEG(i));
6453 if (A_ORDEREDG(i))
6454 fprintf(file, " ordered");
6455 if (A_DISTPARDOG(i))
6456 fprintf(file, " distpardo");
6457 if (A_DISTRIBUTEG(i))
6458 fprintf(file, " distribute");
6459 if (A_TASKLOOPG(i))
6460 fprintf(file, " taskloop");
6461 if (A_ENDLABG(i))
6462 fprintf(file, " endlab:%5d", (int)A_ENDLABG(i));
6463 break;
6464 case A_MP_TASKLOOPREG:
6465 fprintf(file, " m1:%5d", (int)A_M1G(i));
6466 fprintf(file, " m2:%5d", (int)A_M2G(i));
6467 fprintf(file, " m3:%5d\n", (int)A_M3G(i));
6468 break;
6469 case A_MP_ETASKLOOPREG:
6470 case A_MP_TASKREG:
6471 case A_MP_TASKDUP:
6472 case A_MP_ENDTARGETDATA:
6473 case A_MP_ENDTARGET:
6474 case A_MP_ENDTEAMS:
6475 case A_MP_DISTRIBUTE:
6476 case A_MP_ENDDISTRIBUTE:
6477 case A_MP_TASKGROUP:
6478 case A_MP_ETASKGROUP:
6479 case A_MP_BARRIER:
6480 case A_MP_ETASKDUP:
6481 case A_MP_TASKWAIT:
6482 case A_MP_TASKYIELD:
6483 case A_MP_ENDPDO:
6484 case A_MP_SECTION:
6485 case A_MP_LSECTION:
6486 case A_MP_BCOPYIN:
6487 case A_MP_ECOPYIN:
6488 case A_MP_BCOPYPRIVATE:
6489 case A_MP_ECOPYPRIVATE:
6490 case A_MP_WORKSHARE:
6491 case A_MP_ENDWORKSHARE:
6492 case A_MP_BPDO:
6493 case A_MP_EPDO:
6494 case A_MP_BORDERED:
6495 case A_MP_EORDERED:
6496 case A_MP_FLUSH:
6497 break;
6498 case A_MP_PRE_TLS_COPY:
6499 case A_MP_COPYIN:
6500 case A_MP_COPYPRIVATE:
6501 fprintf(file, " sptr:%5d (%s)", (int)A_SPTRG(i),
6502 getprint((int)A_SPTRG(i)));
6503 fprintf(file, " size:%5d", (int)A_ROPG(i));
6504 break;
6505 case A_PREFETCH:
6506 fprintf(file, " lop:%5d optype:%d", A_LOPG(i), A_OPTYPEG(i));
6507 break;
6508 case A_PRAGMA:
6509 fprintf(file, " lop:%5d rop:%5d type:%d scope:%d", A_LOPG(i), A_ROPG(i),
6510 A_PRAGMATYPEG(i), A_PRAGMASCOPEG(i));
6511 if (A_PRAGMATYPEG(i) == PR_ACCTILE) {
6512 j = A_ARGCNTG(i);
6513 fprintf(file, " argcnt:%5d args:%5d", (int)A_LOPG(i), j);
6514 k = 0;
6515 while (j--) {
6516 fprintf(file, "\n");
6517 for (l = 0; l < indent; ++l)
6518 fprintf(file, " ");
6519 fprintf(file, " (%5d):%5d", k, (int)ARGT_ARG(A_ARGSG(i), k));
6520 k++;
6521 }
6522 }
6523 break;
6524 default:
6525 fprintf(file, "NO DUMP AVL");
6526 break;
6527 }
6528 fprintf(file, "\n");
6529 if ((A_TYPEG(i) == A_ASN || A_ISEXPR(A_TYPEG(i))) && A_SHAPEG(i)) {
6530 dump_shape(A_SHAPEG(i));
6531 }
6532 }
6533
6534 /* routine must be externally visible */
6535 void
dump_one_ast(int i)6536 dump_one_ast(int i)
6537 {
6538 _dump_one_ast(i, gbl.dbgfil);
6539 }
6540
6541 /* routine must be externally visible */
6542 void
dump_ast_tree(int i)6543 dump_ast_tree(int i)
6544 {
6545 int j, k;
6546 int asd;
6547
6548 if (i <= 0 || i > astb.stg_avail)
6549 return;
6550 fprintf(gbl.dbgfil, "\n");
6551 dump_one_ast(i);
6552 switch (A_TYPEG(i)) {
6553 case A_NULL:
6554 case A_ID:
6555 case A_LABEL:
6556 case A_ENTRY:
6557 case A_CNST:
6558 case A_CMPLXC:
6559 case A_GOTO:
6560 case A_CGOTO:
6561 case A_AGOTO:
6562 break;
6563 case A_BINOP:
6564 indent += 3;
6565 dump_ast_tree(A_LOPG(i));
6566 dump_ast_tree(A_ROPG(i));
6567 indent -= 3;
6568 break;
6569 case A_MEM:
6570 indent += 3;
6571 dump_ast_tree(A_MEMG(i));
6572 dump_ast_tree(A_PARENTG(i));
6573 indent -= 3;
6574 break;
6575 case A_CONV:
6576 case A_UNOP:
6577 case A_PAREN:
6578 indent += 3;
6579 dump_ast_tree(A_LOPG(i));
6580 indent -= 3;
6581 break;
6582 case A_SUBSCR:
6583 asd = A_ASDG(i);
6584 indent += 3;
6585 dump_ast_tree(A_LOPG(i));
6586 indent += 1;
6587 for (j = 0; j < (int)ASD_NDIM(asd); j++) {
6588 dump_ast_tree(ASD_SUBS(asd, j));
6589 }
6590 indent -= 4;
6591 break;
6592 case A_SUBSTR:
6593 indent += 3;
6594 dump_ast_tree(A_LEFTG(i));
6595 dump_ast_tree(A_RIGHTG(i));
6596 dump_ast_tree(A_LOPG(i));
6597 indent -= 3;
6598 break;
6599 case A_INIT:
6600 indent += 3;
6601 dump_ast_tree(A_LEFTG(i));
6602 indent -= 3;
6603 dump_ast_tree(A_RIGHTG(i));
6604 break;
6605 case A_TRIPLE:
6606 indent += 3;
6607 dump_ast_tree(A_LBDG(i));
6608 dump_ast_tree(A_UPBDG(i));
6609 dump_ast_tree(A_STRIDEG(i));
6610 indent -= 3;
6611 break;
6612 case A_FUNC:
6613 case A_INTR:
6614 case A_CALL:
6615 case A_ICALL:
6616 indent += 1;
6617 dump_ast_tree(A_LOPG(i));
6618 j = A_ARGCNTG(i);
6619 indent += 2;
6620 k = 0;
6621 while (j--) {
6622 dump_ast_tree(ARGT_ARG(A_ARGSG(i), k));
6623 k++;
6624 }
6625 indent -= 3;
6626 break;
6627 case A_ASN:
6628 case A_ASNGOTO:
6629 indent += 3;
6630 dump_ast_tree(A_DESTG(i));
6631 dump_ast_tree(A_SRCG(i));
6632 indent -= 3;
6633 break;
6634 case A_IF:
6635 indent += 3;
6636 dump_ast_tree(A_IFEXPRG(i));
6637 dump_ast_tree(A_IFSTMTG(i));
6638 indent -= 3;
6639 break;
6640 case A_IFTHEN:
6641 indent += 3;
6642 dump_ast_tree(A_IFEXPRG(i));
6643 indent -= 3;
6644 break;
6645 case A_ELSE:
6646 break;
6647 case A_ELSEIF:
6648 indent += 3;
6649 dump_ast_tree(A_IFEXPRG(i));
6650 indent -= 3;
6651 break;
6652 case A_ENDIF:
6653 break;
6654 case A_AIF:
6655 indent += 3;
6656 dump_ast_tree(A_IFEXPRG(i));
6657 indent -= 3;
6658 break;
6659 case A_DO:
6660 indent += 3;
6661 dump_ast_tree(A_M1G(i));
6662 dump_ast_tree(A_M2G(i));
6663 dump_ast_tree(A_M3G(i));
6664 dump_ast_tree(A_M4G(i));
6665 indent -= 3;
6666 break;
6667 case A_DOWHILE:
6668 indent += 3;
6669 dump_ast_tree(A_IFEXPRG(i));
6670 indent -= 3;
6671 break;
6672 case A_ENDDO:
6673 case A_CONTINUE:
6674 case A_END:
6675 break;
6676 case A_STOP:
6677 case A_PAUSE:
6678 case A_RETURN:
6679 indent += 3;
6680 dump_ast_tree(A_LOPG(i));
6681 indent -= 3;
6682 break;
6683 case A_ALLOC:
6684 break;
6685 case A_WHERE:
6686 indent += 3;
6687 dump_ast_tree(A_IFEXPRG(i));
6688 dump_ast_tree(A_IFSTMTG(i));
6689 indent -= 3;
6690 break;
6691 case A_FORALL:
6692 break;
6693 case A_ELSEWHERE:
6694 case A_ENDWHERE:
6695 case A_ENDFORALL:
6696 case A_ELSEFORALL:
6697 break;
6698 case A_REDIM:
6699 break;
6700 case A_COMMENT:
6701 case A_COMSTR:
6702 break;
6703 case A_REALIGN:
6704 case A_REDISTRIBUTE:
6705 break;
6706 case A_HLOCALIZEBNDS:
6707 break;
6708 case A_HALLOBNDS:
6709 break;
6710 case A_HCYCLICLP:
6711 break;
6712 case A_HOFFSET:
6713 break;
6714 case A_HSECT:
6715 break;
6716 case A_HCOPYSECT:
6717 break;
6718 case A_HPERMUTESECT:
6719 break;
6720 case A_HOVLPSHIFT:
6721 break;
6722 case A_HGETSCLR:
6723 indent += 3;
6724 dump_ast_tree(A_DESTG(i));
6725 dump_ast_tree(A_SRCG(i));
6726 if (A_LOPG(i)) {
6727 dump_ast_tree(A_LOPG(i));
6728 }
6729 indent -= 3;
6730 break;
6731 case A_HGATHER:
6732 case A_HSCATTER:
6733 break;
6734 case A_HCSTART:
6735 break;
6736 case A_HCFINISH:
6737 case A_HCFREE:
6738 break;
6739 case A_MASTER:
6740 break;
6741 case A_ENDMASTER:
6742 j = A_ARGCNTG(i);
6743 indent += 3;
6744 k = 0;
6745 while (j-- > 0) {
6746 dump_ast_tree(ARGT_ARG(A_ARGSG(i), k));
6747 k++;
6748 }
6749 indent -= 3;
6750 break;
6751 case A_ATOMIC:
6752 case A_ATOMICCAPTURE:
6753 case A_ATOMICREAD:
6754 case A_ATOMICWRITE:
6755 case A_PREFETCH:
6756 indent += 3;
6757 dump_ast_tree(A_LOPG(i));
6758 indent -= 3;
6759 break;
6760 case A_PRAGMA:
6761 indent += 3;
6762 dump_ast_tree(A_LOPG(i));
6763 dump_ast_tree(A_ROPG(i));
6764 if (A_PRAGMATYPEG(i) == PR_ACCTILE) {
6765 j = A_ARGCNTG(i);
6766 k = 0;
6767 while (j-- > 0) {
6768 int a = ARGT_ARG(A_ARGSG(i), k);
6769 dump_ast_tree(a);
6770 k++;
6771 }
6772 }
6773 indent -= 3;
6774 break;
6775 indent -= 3;
6776 break;
6777 case A_CRITICAL:
6778 case A_ENDCRITICAL:
6779 case A_ENDATOMIC:
6780 case A_BARRIER:
6781 case A_NOBARRIER:
6782 break;
6783 case A_MP_PARALLEL:
6784 indent += 3;
6785 dump_ast_tree(A_IFPARG(i));
6786 dump_ast_tree(A_NPARG(i));
6787 dump_ast_tree(A_ENDLABG(i));
6788 dump_ast_tree(A_PROCBINDG(i));
6789 indent -= 3;
6790 break;
6791 case A_MP_TEAMS:
6792 indent += 3;
6793 dump_ast_tree(A_NTEAMSG(i));
6794 dump_ast_tree(A_THRLIMITG(i));
6795 indent -= 3;
6796 break;
6797 case A_MP_BMPSCOPE:
6798 indent += 3;
6799 dump_ast_tree(A_STBLKG(i));
6800 indent -= 3;
6801 break;
6802 case A_MP_TASK:
6803 case A_MP_TASKLOOP:
6804 indent += 3;
6805 dump_ast_tree(A_IFPARG(i));
6806 dump_ast_tree(A_FINALPARG(i));
6807 dump_ast_tree(A_PRIORITYG(i));
6808 indent -= 3;
6809 break;
6810 case A_MP_TASKFIRSTPRIV:
6811 indent += 3;
6812 dump_ast_tree(A_LOPG(i));
6813 dump_ast_tree(A_ROPG(i));
6814 indent -= 3;
6815 break;
6816 case A_MP_TARGET:
6817 case A_MP_TARGETDATA:
6818 indent += 3;
6819 dump_ast_tree(A_IFPARG(i));
6820 dump_ast_tree(A_LOPG(i));
6821 indent -= 3;
6822 break;
6823 case A_MP_TARGETENTERDATA:
6824 case A_MP_TARGETEXITDATA:
6825 case A_MP_TARGETUPDATE:
6826 indent += 3;
6827 dump_ast_tree(A_IFPARG(i));
6828 indent -= 3;
6829 break;
6830
6831 case A_MP_ENDTARGET:
6832 case A_MP_ENDTARGETDATA:
6833 case A_MP_ENDTEAMS:
6834 case A_MP_DISTRIBUTE:
6835 case A_MP_ENDDISTRIBUTE:
6836 case A_MP_TASKGROUP:
6837 case A_MP_ETASKGROUP:
6838 case A_MP_ENDPARALLEL:
6839 case A_MP_CRITICAL:
6840 case A_MP_ENDCRITICAL:
6841 case A_MP_ATOMIC:
6842 case A_MP_ENDATOMIC:
6843 case A_MP_MASTER:
6844 case A_MP_ENDMASTER:
6845 case A_MP_SINGLE:
6846 case A_MP_ENDSINGLE:
6847 case A_MP_BARRIER:
6848 case A_MP_ETASKDUP:
6849 case A_MP_TASKWAIT:
6850 case A_MP_TASKYIELD:
6851 case A_MP_ENDTASK:
6852 case A_MP_EMPSCOPE:
6853 case A_MP_ETASKLOOPREG:
6854 case A_MP_TASKDUP:
6855 break;
6856 case A_MP_TASKREG:
6857 indent += 3;
6858 dump_ast_tree(A_ENDLABG(i));
6859 indent -= 3;
6860 break;
6861 case A_MP_CANCEL:
6862 indent += 3;
6863 dump_ast_tree(A_IFPARG(i));
6864 dump_ast_tree(A_ENDLABG(i));
6865 indent -= 3;
6866 break;
6867 case A_MP_SECTIONS:
6868 case A_MP_CANCELLATIONPOINT:
6869 indent += 3;
6870 dump_ast_tree(A_ENDLABG(i));
6871 indent -= 3;
6872 break;
6873 case A_MP_PDO:
6874 indent += 3;
6875 dump_ast_tree(A_M1G(i));
6876 dump_ast_tree(A_M2G(i));
6877 dump_ast_tree(A_M3G(i));
6878 dump_ast_tree(A_CHUNKG(i));
6879 indent -= 3;
6880 break;
6881 case A_MP_TASKLOOPREG:
6882 indent += 3;
6883 dump_ast_tree(A_M1G(i));
6884 dump_ast_tree(A_M2G(i));
6885 dump_ast_tree(A_M3G(i));
6886 indent -= 3;
6887 break;
6888 case A_MP_ATOMICREAD:
6889 dump_ast_tree(A_SRCG(i));
6890 indent -= 3;
6891 break;
6892 case A_MP_ATOMICWRITE:
6893 case A_MP_ATOMICUPDATE:
6894 case A_MP_ATOMICCAPTURE:
6895 dump_ast_tree(A_LOPG(i));
6896 dump_ast_tree(A_ROPG(i));
6897 indent -= 3;
6898 break;
6899 case A_MP_ENDPDO:
6900 case A_MP_ENDSECTIONS:
6901 case A_MP_SECTION:
6902 case A_MP_LSECTION:
6903 case A_MP_WORKSHARE:
6904 case A_MP_ENDWORKSHARE:
6905 case A_MP_BPDO:
6906 case A_MP_EPDO:
6907 case A_MP_BORDERED:
6908 case A_MP_EORDERED:
6909 case A_MP_PRE_TLS_COPY:
6910 case A_MP_BCOPYIN:
6911 case A_MP_COPYIN:
6912 case A_MP_ECOPYIN:
6913 case A_MP_BCOPYPRIVATE:
6914 case A_MP_COPYPRIVATE:
6915 case A_MP_ECOPYPRIVATE:
6916 case A_MP_FLUSH:
6917 break;
6918 default:
6919 fprintf(gbl.dbgfil, "NO DUMP AVL");
6920 break;
6921 }
6922 }
6923
6924 /* routine must be externally visible */
6925 void
dump_ast(void)6926 dump_ast(void)
6927 {
6928 int i;
6929
6930 fprintf(gbl.dbgfil, "AST Table\n");
6931 for (i = 1; i < astb.stg_avail; i++) {
6932 fprintf(gbl.dbgfil, "\n");
6933 _dump_one_ast(i, gbl.dbgfil);
6934 }
6935
6936 fprintf(gbl.dbgfil, "\n");
6937 if (DBGBIT(4, 512)) {
6938 fprintf(gbl.dbgfil, "HashIndex First\n");
6939 for (i = 0; i <= HSHSZ; i++)
6940 if (astb.hshtb[i])
6941 fprintf(gbl.dbgfil, " %5d %5d\n", i, (int)astb.hshtb[i]);
6942 }
6943 }
6944
6945 /* routine must be externally visible */
6946 void
dump_astli(int astli)6947 dump_astli(int astli)
6948 {
6949 while (astli) {
6950 fprintf(gbl.dbgfil, "\n%5d. h1:%-5d h2:%-5d flags:%04x", astli,
6951 (int)ASTLI_SPTR(astli), (int)ASTLI_TRIPLE(astli),
6952 (int)ASTLI_FLAGS(astli));
6953 astli = ASTLI_NEXT(astli);
6954 }
6955 }
6956
6957 /* routine must be externally visible */
6958 void
_dump_std(int std,FILE * fil)6959 _dump_std(int std, FILE *fil)
6960 {
6961 int ast;
6962 if (fil == NULL)
6963 fil = stderr;
6964 ast = STD_AST(std);
6965 fprintf(fil, "std:%5d. lineno:%-5d label:%-5d(%s) ast:%-5d", std,
6966 STD_LINENO(std), STD_LABEL(std),
6967 STD_LABEL(std) ? SYMNAME(STD_LABEL(std)) : "", ast);
6968 #undef _PFG
6969 #define _PFG(cond, str) \
6970 if (cond) \
6971 fprintf(fil, " %s", str)
6972 _PFG(A_CALLFGG(ast), "callfg");
6973 _PFG(STD_EX(std), "ex");
6974 _PFG(STD_ST(std), "st");
6975 _PFG(STD_BR(std), "br");
6976 _PFG(STD_DELETE(std), "delete");
6977 _PFG(STD_IGNORE(std), "ignore");
6978 _PFG(STD_SPLIT(std), "split");
6979 _PFG(STD_MINFO(std), "info");
6980 _PFG(STD_LOCAL(std), "local");
6981 _PFG(STD_PURE(std), "pure");
6982 _PFG(STD_PAR(std), "par");
6983 _PFG(STD_CS(std), "cs");
6984 _PFG(STD_PARSECT(std), "parsect");
6985 _PFG(STD_TASK(std), "task");
6986 fprintf(fil, "\n");
6987 if (STD_LABEL(std))
6988 fprintf(fil, "%s:\n", SYMNAME(STD_LABEL(std)));
6989 dbg_print_ast(ast, fil);
6990 }
6991
6992 /* routine must be externally visible */
6993 void
dump_std(void)6994 dump_std(void)
6995 {
6996 int std;
6997 for (std = STD_NEXT(0); std; std = STD_NEXT(std)) {
6998 _dump_std(std, gbl.dbgfil);
6999 }
7000 }
7001
7002 /* routine must be externally visible */
7003 void
dump_stg_stat(char * where)7004 dump_stg_stat(char *where)
7005 {
7006 FILE *fil;
7007 if (gbl.dbgfil == NULL)
7008 fil = stderr;
7009 else
7010 fil = gbl.dbgfil;
7011 fprintf(fil, " Storage Allocation %s\n", where);
7012 fprintf(fil, " AST :%8d\n", astb.stg_avail);
7013 fprintf(fil, " ASD :%8d\n", astb.asd.stg_avail);
7014 fprintf(fil, " STD :%8d\n", astb.std.stg_avail);
7015 fprintf(fil, " ASTLI :%8d\n", astb.astli.stg_avail);
7016 fprintf(fil, " ARGT :%8d\n", astb.argt.stg_avail);
7017 fprintf(fil, " SHD :%8d\n", astb.shd.stg_avail);
7018 fprintf(fil, " SYM :%8d\n", stb.stg_avail);
7019 fprintf(fil, " DT :%8d\n", stb.dt.stg_avail);
7020 }
7021
7022 #include <stdarg.h>
7023
7024 static int _huge(DTYPE);
7025
7026 int
ast_intr(int i_intr,DTYPE dtype,int cnt,...)7027 ast_intr(int i_intr, DTYPE dtype, int cnt, ...)
7028
7029 {
7030 int ast;
7031 int sptr, sptre;
7032 va_list vargs;
7033 int opnd;
7034
7035 va_start(vargs, cnt);
7036
7037 sptr = intast_sym[i_intr];
7038 if (STYPEG(sptr) == ST_PD) {
7039 /* allow only those predeclareds which are passed thru as intrinsics */
7040 if (i_intr == I_HUGE) {
7041 va_end(vargs);
7042 return _huge(dtype);
7043 }
7044 ast = begin_call(A_INTR, sptr, cnt);
7045 while (cnt--) {
7046 opnd = va_arg(vargs, int);
7047 (void)add_arg(opnd);
7048 }
7049 A_OPTYPEP(ast, i_intr);
7050 } else {
7051 sptre = sptr;
7052 if (STYPEG(sptr) == ST_GENERIC) {
7053 switch (DTY(dtype)) {
7054 case TY_SLOG:
7055 case TY_SINT:
7056 if ((sptr = GSINTG(sptr)))
7057 break;
7058 case TY_WORD:
7059 case TY_DWORD:
7060 case TY_BLOG:
7061 case TY_BINT:
7062 case TY_LOG:
7063 case TY_INT:
7064 sptr = GINTG(sptr);
7065 break;
7066 case TY_LOG8:
7067 case TY_INT8:
7068 sptr = GINT8G(sptr);
7069 break;
7070 case TY_REAL:
7071 sptr = GREALG(sptr);
7072 break;
7073 case TY_DBLE:
7074 sptr = GDBLEG(sptr);
7075 break;
7076 case TY_CMPLX:
7077 sptr = GCMPLXG(sptr);
7078 break;
7079 case TY_DCMPLX:
7080 sptr = GDCMPLXG(sptr);
7081 break;
7082 default:
7083 sptr = 0;
7084 break;
7085 }
7086 assert(sptr != 0, "ast_intr: unknown generic", 0, 3);
7087 }
7088 if (STYPEG(sptre) == ST_INTRIN || STYPEG(sptre) == ST_GENERIC) {
7089 ast = begin_call(A_INTR, sptre, cnt);
7090 while (cnt--) {
7091 opnd = va_arg(vargs, int);
7092 (void)add_arg(opnd);
7093 }
7094 A_OPTYPEP(ast, INTASTG(sptr));
7095 } else if (i_intr == I_INT) {
7096 opnd = va_arg(vargs, int);
7097 sptre = sym_mkfunc_nodesc(mkRteRtnNm(RTE_int), DT_INT);
7098 ast = begin_call(A_FUNC, sptre, 2);
7099 (void)add_arg(opnd);
7100 (void)add_arg(mk_cval((INT)ty_to_lib[DTYG(A_TYPEG(opnd))], DT_INT));
7101 } else if (i_intr == I_REAL) {
7102 opnd = va_arg(vargs, int);
7103 sptre = sym_mkfunc_nodesc(mkRteRtnNm(RTE_real), DT_REAL4);
7104 ast = begin_call(A_FUNC, sptre, 2);
7105 (void)add_arg(opnd);
7106 (void)add_arg(mk_cval((INT)ty_to_lib[DTYG(A_TYPEG(opnd))], DT_INT));
7107 } else if (i_intr == I_DBLE) {
7108 opnd = va_arg(vargs, int);
7109 sptre = sym_mkfunc_nodesc(mkRteRtnNm(RTE_dble), DT_DBLE);
7110 ast = begin_call(A_FUNC, sptre, 2);
7111 (void)add_arg(opnd);
7112 (void)add_arg(mk_cval((INT)ty_to_lib[DTYG(A_TYPEG(opnd))], DT_INT));
7113 } else {
7114 assert(FALSE, "ast_intr: unknown predefined", i_intr, ERR_Fatal);
7115 }
7116 }
7117 A_DTYPEP(ast, dtype);
7118 A_SHAPEP(ast, 0);
7119
7120 va_end(vargs);
7121 return ast;
7122 }
7123
7124 static int
_huge(DTYPE dtype)7125 _huge(DTYPE dtype)
7126 {
7127 INT val[4];
7128 int tmp, ast, sptr;
7129 char *sname;
7130
7131 switch (DTYG(dtype)) {
7132 case TY_BINT:
7133 val[0] = 0x7f;
7134 sname = "huge(1_1)";
7135 goto const_int_val;
7136 case TY_SINT:
7137 val[0] = 0x7fff;
7138 sname = "huge(1_2)";
7139 goto const_int_val;
7140 case TY_INT:
7141 val[0] = 0x7fffffff;
7142 sname = "huge(1_4)";
7143 goto const_int_val;
7144 case TY_INT8:
7145 val[0] = 0x7fffffff;
7146 val[1] = 0xffffffff;
7147 sname = "huge(1_8)";
7148 goto const_int8_val;
7149 case TY_REAL:
7150 /* 3.402823466E+38 */
7151 val[0] = 0x7f7fffff;
7152 sname = "huge(1.0_4)";
7153 goto const_real_val;
7154 case TY_DBLE:
7155 sname = "huge(1.0_8)";
7156 if (XBIT(49, 0x40000)) { /* C90 */
7157 #define C90_HUGE "0.136343516952426e+2466" /* 0577757777777777777776 */
7158 atoxd(C90_HUGE, &val[0], strlen(C90_HUGE));
7159 } else {
7160 /* 1.79769313486231571E+308 */
7161 val[0] = 0x7fefffff;
7162 val[1] = 0xffffffff;
7163 }
7164 goto const_dble_val;
7165 default:
7166 return 0; /* caller must check */
7167 }
7168
7169 const_int_val:
7170 ast = mk_cval1(val[0], DT_INT4);
7171 return ast;
7172
7173 const_int8_val:
7174 tmp = getcon(val, DT_INT8);
7175 ast = mk_cval1(tmp, DT_INT8);
7176 return ast;
7177
7178 const_real_val:
7179 ast = mk_cval1(val[0], DT_REAL4);
7180 sptr = A_SPTRG(ast);
7181 /* just added? */
7182 if (NMPTRG(sptr) == 0 && (XBIT(49, 0x400000) || XBIT(51, 0x40)))
7183 NMPTRP(sptr, putsname(sname, strlen(sname)));
7184 return ast;
7185
7186 const_dble_val:
7187 tmp = getcon(val, DT_REAL8);
7188 ast = mk_cnst(tmp);
7189 sptr = A_SPTRG(ast);
7190 /* just added? */
7191 if (NMPTRG(sptr) == 0 && (XBIT(49, 0x400000) || XBIT(51, 0x40)))
7192 NMPTRP(sptr, putsname(sname, strlen(sname)));
7193 return ast;
7194
7195 }
7196
7197 /* utility function to ensure that an expression has type dt_needed.
7198 * If expression needs to be converted, the 'int' intrinsic is used.
7199 */
7200 static int
mk_int(int expr,DTYPE dt_needed)7201 mk_int(int expr, DTYPE dt_needed)
7202 {
7203 DTYPE dt;
7204 int inp;
7205
7206 inp = expr;
7207 if (A_TYPEG(inp) == A_CONV)
7208 inp = A_LOPG(inp);
7209 dt = DDTG(A_DTYPEG(inp));
7210 if (dt != dt_needed) {
7211 if (A_TYPEG(inp) == A_CNST) {
7212 int new;
7213 new = convert_cnst(inp, dt_needed);
7214 if (new != inp)
7215 return new;
7216 }
7217 expr = ast_intr(I_INT, dt_needed, 1, inp);
7218 }
7219 return expr;
7220 }
7221
7222 /** \brief Utility function to ensure that an expression has type DT_INT
7223 (default integer).
7224 */
7225 int
mk_default_int(int expr)7226 mk_default_int(int expr)
7227 {
7228 return mk_int(expr, DT_INT);
7229 }
7230
7231 /** \brief Utility function to ensure that an expression has a type suitable for
7232 array bounds, DT_INT8 for -Mlarge_arrays, DT_INT otherwise.
7233 */
7234 int
mk_bnd_int(int expr)7235 mk_bnd_int(int expr)
7236 {
7237 return mk_int(expr, astb.bnd.dtype);
7238 }
7239
7240 int
mk_smallest_val(DTYPE dtype)7241 mk_smallest_val(DTYPE dtype)
7242 {
7243 INT val[4];
7244 int tmp;
7245
7246 switch (DTYG(dtype)) {
7247 case TY_BINT:
7248 val[0] = ~0x7f;
7249 if (XBIT(51, 0x1))
7250 val[0] |= 0x01;
7251 break;
7252 case TY_SINT:
7253 val[0] = ~0x7fff;
7254 if (XBIT(51, 0x2))
7255 val[0] |= 0x0001;
7256 break;
7257 case TY_INT:
7258 val[0] = ~0x7fffffff;
7259 if (XBIT(51, 0x4))
7260 val[0] |= 0x00000001;
7261 break;
7262 case TY_INT8:
7263 if (XBIT(49, 0x1040000)) {
7264 /* T3D/T3E or C90 Cray targets - workaround for cray compiler:
7265 * -9223372036854775808_8 (-huge()-1) is considered to be out of
7266 * range; just return -huge().
7267 */
7268 tmp = _huge(DT_INT8);
7269 tmp = mk_unop(OP_SUB, tmp, dtype);
7270 return tmp;
7271 }
7272 val[0] = ~0x7fffffff;
7273 val[1] = 0;
7274 if (XBIT(51, 0x8))
7275 val[1] |= 0x00000001;
7276 tmp = getcon(val, DT_INT8);
7277 return (mk_cval1(tmp, DT_INT8));
7278 case TY_REAL:
7279 case TY_DBLE:
7280 tmp = _huge(dtype);
7281 tmp = mk_unop(OP_SUB, tmp, dtype);
7282 return tmp;
7283 default:
7284 return 0; /* caller must check */
7285 }
7286 /* const_int_val */
7287 return (mk_cval1(val[0], DT_INT4));
7288 }
7289
7290 int
mk_largest_val(DTYPE dtype)7291 mk_largest_val(DTYPE dtype)
7292 {
7293 return ast_intr(I_HUGE, dtype, 0);
7294 }
7295
7296 int
mk_merge(int tsource,int fsource,int mask,DTYPE resdt)7297 mk_merge(int tsource, int fsource, int mask, DTYPE resdt)
7298 {
7299 int func;
7300 int newargt, newast;
7301 newargt = mk_argt(3);
7302 ARGT_ARG(newargt, 0) = tsource;
7303 ARGT_ARG(newargt, 1) = fsource;
7304 ARGT_ARG(newargt, 2) = mask;
7305 if (resdt == DT_INT8) {
7306 func = sym_mkfunc_nodesc(mkRteRtnNm(RTE_mergei8), DT_INT8);
7307 } else {
7308 func = sym_mkfunc_nodesc(mkRteRtnNm(RTE_mergei), DT_INT);
7309 }
7310 newast = mk_func_node(A_INTR, mk_id(func), 3, newargt);
7311 A_OPTYPEP(newast, I_MERGE);
7312 A_DTYPEP(newast, resdt);
7313 return newast;
7314 }
7315
rw_ast_state(RW_ROUTINE,RW_FILE)7316 void rw_ast_state(RW_ROUTINE, RW_FILE)
7317 {
7318 int nw;
7319
7320 RW_FD(astb.hshtb, astb.hshtb, 1);
7321 RW_SCALAR(astb.stg_avail);
7322 RW_SCALAR(astb.stg_cleared);
7323 RW_SCALAR(astb.stg_dtsize);
7324 RW_FD(astb.stg_base, AST, astb.stg_avail);
7325
7326 RW_FD(astb.asd.hash, astb.asd.hash, 1);
7327 RW_SCALAR(astb.asd.stg_avail);
7328 RW_SCALAR(astb.asd.stg_cleared);
7329 RW_SCALAR(astb.asd.stg_dtsize);
7330 RW_FD(astb.asd.stg_base, int, astb.asd.stg_avail);
7331
7332 RW_FD(astb.shd.hash, astb.shd.hash, 1);
7333 RW_SCALAR(astb.shd.stg_avail);
7334 RW_SCALAR(astb.shd.stg_cleared);
7335 RW_SCALAR(astb.shd.stg_dtsize);
7336 RW_FD(astb.shd.stg_base, SHD, astb.shd.stg_avail);
7337
7338 RW_SCALAR(astb.astli.stg_avail);
7339 RW_SCALAR(astb.astli.stg_cleared);
7340 RW_SCALAR(astb.astli.stg_dtsize);
7341 RW_FD(astb.astli.stg_base, ASTLI, astb.astli.stg_avail);
7342
7343 RW_SCALAR(astb.argt.stg_avail);
7344 RW_SCALAR(astb.argt.stg_cleared);
7345 RW_SCALAR(astb.argt.stg_dtsize);
7346 RW_FD(astb.argt.stg_base, int, astb.argt.stg_avail);
7347
7348 RW_SCALAR(astb.comstr.stg_avail);
7349 RW_SCALAR(astb.comstr.stg_cleared);
7350 RW_SCALAR(astb.comstr.stg_dtsize);
7351 RW_FD(astb.comstr.stg_base, char, astb.comstr.stg_avail);
7352
7353 }
7354
7355 /*
7356 * remove std from link list of stds
7357 * On the other hand, if it is the ENTSTD of any entry, change to A_CONTINUE
7358 */
7359 void
delete_stmt(int std)7360 delete_stmt(int std)
7361 {
7362 int entry;
7363 int prev, next;
7364 for (entry = gbl.entries; entry > NOSYM; entry = SYMLKG(entry)) {
7365 if (ENTSTDG(entry) == std) {
7366 /* change to A_CONTINUE instead */
7367 if (A_TYPEG(STD_AST(std)) != A_CONTINUE) {
7368 STD_AST(std) = mk_stmt(A_CONTINUE, 0);
7369 }
7370 return;
7371 }
7372 }
7373 if (STD_PTASGN(std)) {
7374 STD_AST(std) = mk_stmt(A_CONTINUE, 0);
7375 return;
7376 }
7377
7378 remove_stmt(std);
7379 STD_DELETE(std) = 1;
7380 STD_LINENO(std) = -1;
7381 STD_FINDEX(std) = 1;
7382 }
7383
7384 int
add_nullify_ast(int sptrast)7385 add_nullify_ast(int sptrast)
7386 {
7387 int sptr;
7388 int ast;
7389
7390 sptr = intast_sym[I_NULLIFY];
7391 ast = begin_call(A_ICALL, sptr, 1);
7392 A_OPTYPEP(ast, I_NULLIFY);
7393 add_arg(sptrast);
7394 return ast;
7395 }
7396
7397 /** \brief Looks for an assumed shape expression in an AST.
7398 \param ast is the AST expression that we're examining.
7399 */
7400 int
has_assumshp_expr(int ast)7401 has_assumshp_expr(int ast)
7402 {
7403 int sptr, rslt, i;
7404 switch (A_TYPEG(ast)) {
7405 case A_CONV:
7406 return has_assumshp_expr(A_LOPG(ast));
7407 case A_INTR:
7408 switch (A_OPTYPEG(ast)) {
7409 case I_INT1:
7410 case I_INT2:
7411 case I_INT4:
7412 case I_INT8:
7413 case I_INT:
7414 i = A_ARGSG(ast);
7415 return has_assumshp_expr(ARGT_ARG(i, 0));
7416 }
7417 break;
7418 case A_CNST:
7419 return 0;
7420 case A_ID:
7421 case A_LABEL:
7422 case A_ENTRY:
7423 sptr = A_SPTRG(ast);
7424 if (DTY(DTYPEG(sptr)) != TY_ARRAY)
7425 return 0;
7426 return ASSUMSHPG(sptr);
7427 case A_SUBSCR:
7428 case A_SUBSTR:
7429 return has_assumshp_expr(A_LOPG(ast));
7430 case A_MEM:
7431 rslt = has_assumshp_expr(A_MEMG(ast));
7432 if (!rslt) {
7433 ast = A_PARENTG(ast);
7434 rslt = has_assumshp_expr(ast);
7435 }
7436 return rslt;
7437 case A_UNOP:
7438 return has_assumshp_expr(A_LOPG(ast));
7439 case A_BINOP:
7440 rslt = has_assumshp_expr(A_LOPG(ast));
7441 if (!rslt)
7442 rslt = has_assumshp_expr(A_ROPG(ast));
7443 return rslt;
7444 default:
7445 interr("has_assumshp_expr: unexpected ast type", A_TYPEG(ast), 3);
7446 }
7447 return 0;
7448 }
7449
7450 /** \brief Looks for an adjustable array expression in an AST.
7451 \param ast is the AST expression that we're examining.
7452 */
7453 int
has_adjustable_expr(int ast)7454 has_adjustable_expr(int ast)
7455 {
7456 int sptr, rslt, i;
7457 switch (A_TYPEG(ast)) {
7458 case A_CONV:
7459 return has_adjustable_expr(A_LOPG(ast));
7460 case A_INTR:
7461 switch (A_OPTYPEG(ast)) {
7462 case I_INT1:
7463 case I_INT2:
7464 case I_INT4:
7465 case I_INT8:
7466 case I_INT:
7467 i = A_ARGSG(ast);
7468 return has_adjustable_expr(ARGT_ARG(i, 0));
7469 }
7470 break;
7471 case A_CNST:
7472 return 0;
7473 case A_ID:
7474 case A_LABEL:
7475 case A_ENTRY:
7476 sptr = A_SPTRG(ast);
7477 if (DTY(DTYPEG(sptr)) != TY_ARRAY)
7478 return 0;
7479 return ADJARRG(sptr);
7480 case A_SUBSCR:
7481 case A_SUBSTR:
7482 return has_adjustable_expr(A_LOPG(ast));
7483 case A_MEM:
7484 rslt = has_adjustable_expr(A_MEMG(ast));
7485 if (!rslt) {
7486 ast = A_PARENTG(ast);
7487 rslt = has_adjustable_expr(ast);
7488 }
7489 return rslt;
7490 case A_UNOP:
7491 return has_adjustable_expr(A_LOPG(ast));
7492 case A_BINOP:
7493 rslt = has_adjustable_expr(A_LOPG(ast));
7494 if (!rslt)
7495 rslt = has_adjustable_expr(A_ROPG(ast));
7496 return rslt;
7497 default:
7498 interr("has_adjustable_expr: unexpected ast type", A_TYPEG(ast), 3);
7499 }
7500 return 0;
7501 }
7502
7503 /** \brief Looks for a pointer expression in an AST.
7504 \param ast is the AST expression that we're examining.
7505 */
7506 int
has_pointer_expr(int ast)7507 has_pointer_expr(int ast)
7508 {
7509 int sptr, rslt, i;
7510 switch (A_TYPEG(ast)) {
7511 case A_CONV:
7512 return has_pointer_expr(A_LOPG(ast));
7513 case A_INTR:
7514 switch (A_OPTYPEG(ast)) {
7515 case I_INT1:
7516 case I_INT2:
7517 case I_INT4:
7518 case I_INT8:
7519 case I_INT:
7520 i = A_ARGSG(ast);
7521 return has_pointer_expr(ARGT_ARG(i, 0));
7522 }
7523 break;
7524 case A_CNST:
7525 return 0;
7526 case A_ID:
7527 case A_LABEL:
7528 case A_ENTRY:
7529 sptr = A_SPTRG(ast);
7530 return POINTERG(sptr);
7531 case A_SUBSCR:
7532 case A_SUBSTR:
7533 return has_pointer_expr(A_LOPG(ast));
7534 case A_MEM:
7535 rslt = has_pointer_expr(A_MEMG(ast));
7536 if (!rslt) {
7537 ast = A_PARENTG(ast);
7538 rslt = has_pointer_expr(ast);
7539 }
7540 return rslt;
7541 case A_UNOP:
7542 return has_pointer_expr(A_LOPG(ast));
7543 case A_BINOP:
7544 rslt = has_pointer_expr(A_LOPG(ast));
7545 if (!rslt)
7546 rslt = has_pointer_expr(A_ROPG(ast));
7547 return rslt;
7548 default:
7549 interr("has_pointer_expr: unexpected ast type", A_TYPEG(ast), 3);
7550 }
7551 return 0;
7552 }
7553
7554 /** \brief Looks for an allocatable expression in an AST.
7555 \param ast is the AST expression that we're examining.
7556 */
7557 int
has_allocatable_expr(int ast)7558 has_allocatable_expr(int ast)
7559 {
7560 int sptr, rslt, i;
7561 switch (A_TYPEG(ast)) {
7562 case A_CONV:
7563 return has_allocatable_expr(A_LOPG(ast));
7564 case A_INTR:
7565 switch (A_OPTYPEG(ast)) {
7566 case I_INT1:
7567 case I_INT2:
7568 case I_INT4:
7569 case I_INT8:
7570 case I_INT:
7571 i = A_ARGSG(ast);
7572 return has_allocatable_expr(ARGT_ARG(i, 0));
7573 }
7574 break;
7575 case A_CNST:
7576 return 0;
7577 case A_ID:
7578 case A_LABEL:
7579 case A_ENTRY:
7580 sptr = A_SPTRG(ast);
7581 return ALLOCATTRG(sptr);
7582 case A_SUBSCR:
7583 case A_SUBSTR:
7584 return has_allocatable_expr(A_LOPG(ast));
7585 case A_MEM:
7586 rslt = has_allocatable_expr(A_MEMG(ast));
7587 if (!rslt) {
7588 ast = A_PARENTG(ast);
7589 rslt = has_allocatable_expr(ast);
7590 }
7591 return rslt;
7592 case A_UNOP:
7593 return has_allocatable_expr(A_LOPG(ast));
7594 case A_BINOP:
7595 rslt = has_allocatable_expr(A_LOPG(ast));
7596 if (!rslt)
7597 rslt = has_allocatable_expr(A_ROPG(ast));
7598 return rslt;
7599 default:
7600 interr("has_allocatable_expr: unexpected ast type", A_TYPEG(ast), 3);
7601 }
7602 return 0;
7603 }
7604
7605 /** \brief Check if the derived type tag is the iso_c_binding: c_ptr or
7606 c_funptr.
7607 These types are compatible with pointers.
7608 \return true if this AST is an intrinsic call to c_loc or c_funcloc
7609 */
7610 int
is_iso_cloc(int ast)7611 is_iso_cloc(int ast)
7612 {
7613 return is_iso_c_loc(ast) || is_iso_c_funloc(ast);
7614 }
7615
7616 /** \brief Check if this AST is an intrinsic call to c_loc. */
7617 int
is_iso_c_loc(int ast)7618 is_iso_c_loc(int ast)
7619 {
7620 return A_TYPEG(ast) == A_INTR && A_OPTYPEG(ast) == I_C_LOC;
7621 }
7622
7623 /** \brief Check if this AST is an intrinsic call to c_funloc. */
7624 int
is_iso_c_funloc(int ast)7625 is_iso_c_funloc(int ast)
7626 {
7627 return A_TYPEG(ast) == A_INTR && A_OPTYPEG(ast) == I_C_FUNLOC;
7628 }
7629
7630 /** \brief Find the symbol table entry of pointer variable from an ast
7631 representing a pointer object.
7632 */
7633 int
find_pointer_variable(int ast)7634 find_pointer_variable(int ast)
7635 {
7636 switch (A_TYPEG(ast)) {
7637 case A_ID:
7638 return (A_SPTRG(ast));
7639 case A_MEM:
7640 ast = A_MEMG(ast);
7641 if (A_TYPEG(ast) == A_ID)
7642 return (A_SPTRG(ast));
7643 default:
7644 break;
7645 }
7646 return 0;
7647 }
7648
7649 /** \brief Find the symbol table entry of the target from an ast representing
7650 the target in a pointer assignment.
7651 */
7652 void
find_pointer_target(int ast,int * pbase,int * psym)7653 find_pointer_target(int ast, int *pbase, int *psym)
7654 {
7655 int base, sym;
7656
7657 sym = base = 0;
7658 again:
7659 switch (A_TYPEG(ast)) {
7660 case A_ID:
7661 base = A_SPTRG(ast);
7662 break;
7663 case A_FUNC:
7664 case A_SUBSCR:
7665 case A_SUBSTR:
7666 ast = A_LOPG(ast);
7667 goto again;
7668 case A_MEM:
7669 if (sym == 0)
7670 sym = A_SPTRG(A_MEMG(ast));
7671 ast = A_PARENTG(ast);
7672 goto again;
7673 default:
7674 break;
7675 }
7676 if (STYPEG(base) == ST_ENTRY && FVALG(base)) {
7677 base = FVALG(base);
7678 }
7679 if (sym == 0)
7680 sym = base;
7681 *pbase = base;
7682 *psym = sym;
7683 }
7684
7685 /** \brief Convert a hollerith constant to a numeric value.
7686 \param cp character pointer to hollerith character string
7687 \param num result of conversion of hollerith to numeric
7688 \param bc byte count of destination area i.e. *1, *2, *4, *8 or *16
7689 */
7690 void
holtonum(char * cp,INT * num,int bc)7691 holtonum(char *cp, INT *num, int bc)
7692 {
7693 unsigned char *p, buf[18];
7694 int sc, i;
7695 int lc;
7696
7697 /*
7698 * There are 4 32-bit parcels. Index 'i' starts at the parcel to begin
7699 * filling and moves upward. For example, for a 8 byte quantity 'i' would
7700 * start at 2 and end at 3 thus the last two words of 'num' array contain
7701 * the 64-bit number.
7702 */
7703 num[0] = num[1] = num[2] = num[3] = 0;
7704 sprintf((char *)buf, "%-17.17s", cp); /* Need 1 xtra char to detect trunc */
7705 p = buf;
7706 /* Select the initial parcel based on size of destination area */
7707 i = 3;
7708 if (bc > 4)
7709 i = 2;
7710 if (bc > 8)
7711 i = 0;
7712 if (flg.endian) {
7713 /*
7714 * The big endian byte order simply shifts each new character left 8
7715 * bits FEWER than the previous shifted character producing the order
7716 * ABCDEF...
7717 */
7718 while (i <= 3) {
7719 sc = (bc < 4) ? bc : 4; /* Initial shift count */
7720 while (sc--)
7721 num[i] |= *p++ << (sc * 8);
7722 i++;
7723 }
7724 } else {
7725 /*
7726 * The little endian byte order simply shifts each new character left 8
7727 * bits MORE than the previous shifted character producing the order
7728 * ...FEDCBA
7729 */
7730 while (i <= 3) {
7731 sc = (bc < 4) ? bc : 4; /* Initial shift count */
7732 lc = sc - 1;
7733 while (sc--)
7734 num[i] |= *p++ << ((lc - sc) * 8);
7735 i++;
7736 }
7737 }
7738
7739 if (*p != '\0' && *p != ' ')
7740 errwarn(24);
7741 }
7742
7743 INT
negate_const(INT conval,DTYPE dtype)7744 negate_const(INT conval, DTYPE dtype)
7745 {
7746 SNGL result, realrs, imagrs;
7747 DBLE dresult, drealrs, dimagrs;
7748 IEEE128 qresult, qrealrs, qimagrs;
7749 static INT num[4], numz[4];
7750
7751 switch (DTY(dtype)) {
7752 case TY_BINT:
7753 case TY_SINT:
7754 case TY_INT:
7755 case TY_BLOG:
7756 case TY_SLOG:
7757 case TY_LOG:
7758 return (-conval);
7759
7760 case TY_INT8:
7761 case TY_LOG8:
7762 return const_fold(OP_SUB, (INT)stb.k0, conval, dtype);
7763
7764 case TY_REAL:
7765 xfneg(conval, &result);
7766 return (result);
7767
7768 case TY_DBLE:
7769 num[0] = CONVAL1G(conval);
7770 num[1] = CONVAL2G(conval);
7771 xdneg(num, dresult);
7772 return getcon(dresult, DT_REAL8);
7773
7774 case TY_CMPLX:
7775 xfneg(CONVAL1G(conval), &realrs);
7776 xfneg(CONVAL2G(conval), &imagrs);
7777 num[0] = realrs;
7778 num[1] = imagrs;
7779 return getcon(num, DT_CMPLX8);
7780
7781 case TY_DCMPLX:
7782 dresult[0] = CONVAL1G(CONVAL1G(conval));
7783 dresult[1] = CONVAL2G(CONVAL1G(conval));
7784 xdneg(dresult, drealrs);
7785 dresult[0] = CONVAL1G(CONVAL2G(conval));
7786 dresult[1] = CONVAL2G(CONVAL2G(conval));
7787 xdneg(dresult, dimagrs);
7788 num[0] = getcon(drealrs, DT_REAL8);
7789 num[1] = getcon(dimagrs, DT_REAL8);
7790 return getcon(num, DT_CMPLX16);
7791
7792 default:
7793 interr("negate_const: bad dtype", dtype, 3);
7794 return (0);
7795 }
7796 }
7797
7798 INT
const_fold(int opr,INT conval1,INT conval2,DTYPE dtype)7799 const_fold(int opr, INT conval1, INT conval2, DTYPE dtype)
7800 {
7801 IEEE128 qtemp, qresult, qnum1, qnum2;
7802 IEEE128 qreal1, qreal2, qrealrs, qimag1, qimag2, qimagrs;
7803 IEEE128 qtemp1, qtemp2;
7804 DBLE dtemp, dresult, num1, num2;
7805 DBLE dreal1, dreal2, drealrs, dimag1, dimag2, dimagrs;
7806 DBLE dtemp1, dtemp2;
7807 SNGL temp, result;
7808 SNGL real1, real2, realrs, imag1, imag2, imagrs;
7809 SNGL temp1, temp2;
7810 UINT val1, val2;
7811 DBLINT64 inum1, inum2, ires;
7812 int cvlen1, cvlen2, urs, q0;
7813 char *p, *q;
7814
7815 switch (DTY(dtype)) {
7816 case TY_WORD:
7817 if (opr != OP_CMP) {
7818 error(33, 3, gbl.lineno, " ", CNULL);
7819 return (0);
7820 }
7821 return (xucmp((UINT)conval1, (UINT)conval2));
7822
7823 case TY_DWORD:
7824 /* only comparisons in 64-bits allowed */
7825 if (opr != OP_CMP) {
7826 error(33, 3, gbl.lineno, " ", CNULL);
7827 return (0);
7828 }
7829 val1 = (UINT)CONVAL1G(conval1);
7830 val2 = (UINT)CONVAL2G(conval2);
7831 urs = xucmp(val1, val2);
7832 if (urs == 0) {
7833 /* 1st words are equal, compare 2nd words */
7834 return (xucmp((UINT)CONVAL1G(conval1), (UINT)CONVAL2G(conval2)));
7835 }
7836 return (urs);
7837 case TY_BINT:
7838 case TY_SINT:
7839 case TY_INT:
7840 switch (opr) {
7841 case OP_ADD:
7842 return conval1 + conval2;
7843 case OP_CMP:
7844 /*
7845 * the following doesn't work 'cause it could exceed the
7846 * range of an int:
7847 * return (conval1 - conval2);
7848 */
7849 if (conval1 < conval2)
7850 return (INT)-1;
7851 if (conval1 > conval2)
7852 return (INT)1;
7853 return (INT)0;
7854 case OP_SUB:
7855 return conval1 - conval2;
7856 case OP_MUL:
7857 return conval1 * conval2;
7858 case OP_DIV:
7859 if (conval2 == 0) {
7860 errsev(98);
7861 conval2 = 1;
7862 }
7863 return conval1 / conval2;
7864 case OP_XTOI:
7865 /*
7866 * we get here if we're tring to init a x**k in an array constructor
7867 * where x is the constant and k is the iterator; the actual evaluatioh
7868 * will occur in the backend
7869 */
7870 return 0;
7871 }
7872 break;
7873
7874 case TY_INT8:
7875 inum1[0] = CONVAL1G(conval1);
7876 inum1[1] = CONVAL2G(conval1);
7877 inum2[0] = CONVAL1G(conval2);
7878 inum2[1] = CONVAL2G(conval2);
7879 switch (opr) {
7880 case OP_ADD:
7881 add64(inum1, inum2, ires);
7882 break;
7883 case OP_CMP:
7884 /*
7885 * the following doesn't work 'cause it could exceed the
7886 * range of an int:
7887 * return (conval1 - conval2);
7888 */
7889 return cmp64(inum1, inum2);
7890 case OP_SUB:
7891 sub64(inum1, inum2, ires);
7892 break;
7893 case OP_MUL:
7894 mul64(inum1, inum2, ires);
7895 break;
7896 case OP_DIV:
7897 if (inum2[0] == 0 && inum2[1] == 0) {
7898 errsev(98);
7899 inum2[1] = 1;
7900 }
7901 div64(inum1, inum2, ires);
7902 break;
7903 case OP_XTOI:
7904 /*
7905 * we get here if we're tring to init a x**k in an array constructor
7906 * where x is the constant and k is the iterator; the actual evaluatioh
7907 * will occur in the backend
7908 */
7909 ires[0] = ires[1] = 0;
7910 break;
7911 }
7912 return getcon(ires, DT_INT8);
7913
7914 case TY_REAL:
7915 switch (opr) {
7916 case OP_ADD:
7917 xfadd(conval1, conval2, &result);
7918 return result;
7919 case OP_SUB:
7920 xfsub(conval1, conval2, &result);
7921 return result;
7922 case OP_MUL:
7923 xfmul(conval1, conval2, &result);
7924 return result;
7925 case OP_DIV:
7926 result = _fdiv(conval1, conval2);
7927 return result;
7928 case OP_CMP:
7929 return xfcmp(conval1, conval2);
7930 case OP_XTOI:
7931 case OP_XTOX:
7932 xfpow(conval1, conval2, &result);
7933 return result;
7934 }
7935 break;
7936
7937 case TY_DBLE:
7938 num1[0] = CONVAL1G(conval1);
7939 num1[1] = CONVAL2G(conval1);
7940 num2[0] = CONVAL1G(conval2);
7941 num2[1] = CONVAL2G(conval2);
7942 switch (opr) {
7943 case OP_ADD:
7944 xdadd(num1, num2, dresult);
7945 break;
7946 case OP_SUB:
7947 xdsub(num1, num2, dresult);
7948 break;
7949 case OP_MUL:
7950 xdmul(num1, num2, dresult);
7951 break;
7952 case OP_DIV:
7953 _ddiv(num1, num2, dresult);
7954 break;
7955 case OP_CMP:
7956 return xdcmp(num1, num2);
7957 case OP_XTOI:
7958 case OP_XTOX:
7959 xdpow(num1, num2, dresult);
7960 break;
7961 default:
7962 goto err_exit;
7963 }
7964 return getcon(dresult, DT_REAL8);
7965
7966 case TY_CMPLX:
7967 real1 = CONVAL1G(conval1);
7968 imag1 = CONVAL2G(conval1);
7969 real2 = CONVAL1G(conval2);
7970 imag2 = CONVAL2G(conval2);
7971 switch (opr) {
7972 case OP_ADD:
7973 xfadd(real1, real2, &realrs);
7974 xfadd(imag1, imag2, &imagrs);
7975 break;
7976 case OP_SUB:
7977 xfsub(real1, real2, &realrs);
7978 xfsub(imag1, imag2, &imagrs);
7979 break;
7980 case OP_MUL:
7981 /* (a + bi) * (c + di) ==> (ac-bd) + (ad+cb)i */
7982 xfmul(real1, real2, &temp1);
7983 xfmul(imag1, imag2, &temp);
7984 xfsub(temp1, temp, &realrs);
7985 xfmul(real1, imag2, &temp1);
7986 xfmul(real2, imag1, &temp);
7987 xfadd(temp1, temp, &imagrs);
7988 break;
7989 case OP_DIV:
7990 /*
7991 * realrs = real2;
7992 * if (realrs < 0)
7993 * realrs = -realrs;
7994 * imagrs = imag2;
7995 * if (imagrs < 0)
7996 * imagrs = -imagrs;
7997 */
7998 if (xfcmp(real2, CONVAL2G(stb.flt0)) < 0)
7999 xfsub(CONVAL2G(stb.flt0), real2, &realrs);
8000 else
8001 realrs = real2;
8002
8003 if (xfcmp(imag2, CONVAL2G(stb.flt0)) < 0)
8004 xfsub(CONVAL2G(stb.flt0), imag2, &imagrs);
8005 else
8006 imagrs = imag2;
8007
8008 /* avoid overflow */
8009
8010 if (xfcmp(realrs, imagrs) <= 0) {
8011 /*
8012 * if (realrs <= imagrs) {
8013 * temp = real2 / imag2;
8014 * temp1 = 1.0f / (imag2 * (1 + temp * temp));
8015 * realrs = (real1 * temp + imag1) * temp1;
8016 * imagrs = (imag1 * temp - real1) * temp1;
8017 * }
8018 */
8019 temp = _fdiv(real2, imag2);
8020
8021 xfmul(temp, temp, &temp1);
8022 xfadd(CONVAL2G(stb.flt1), temp1, &temp1);
8023 xfmul(imag2, temp1, &temp1);
8024 temp1 = _fdiv(CONVAL2G(stb.flt1), temp1);
8025
8026 xfmul(real1, temp, &realrs);
8027 xfadd(realrs, imag1, &realrs);
8028 xfmul(realrs, temp1, &realrs);
8029
8030 xfmul(imag1, temp, &imagrs);
8031 xfsub(imagrs, real1, &imagrs);
8032 xfmul(imagrs, temp1, &imagrs);
8033 } else {
8034 /*
8035 * else {
8036 * temp = imag2 / real2;
8037 * temp1 = 1.0f / (real2 * (1 + temp * temp));
8038 * realrs = (real1 + imag1 * temp) * temp1;
8039 * imagrs = (imag1 - real1 * temp) * temp1;
8040 * }
8041 */
8042 temp = _fdiv(imag2, real2);
8043
8044 xfmul(temp, temp, &temp1);
8045 xfadd(CONVAL2G(stb.flt1), temp1, &temp1);
8046 xfmul(real2, temp1, &temp1);
8047 temp1 = _fdiv(CONVAL2G(stb.flt1), temp1);
8048
8049 xfmul(imag1, temp, &realrs);
8050 xfadd(real1, realrs, &realrs);
8051 xfmul(realrs, temp1, &realrs);
8052
8053 xfmul(real1, temp, &imagrs);
8054 xfsub(imag1, imagrs, &imagrs);
8055 xfmul(imagrs, temp1, &imagrs);
8056 }
8057 break;
8058 case OP_CMP:
8059 /*
8060 * for complex, only EQ and NE comparisons are allowed, so return
8061 * 0 if the two constants are the same, else 1:
8062 */
8063 return (conval1 != conval2);
8064 default:
8065 goto err_exit;
8066 }
8067 num1[0] = realrs;
8068 num1[1] = imagrs;
8069 return getcon(num1, DT_CMPLX8);
8070
8071 case TY_DCMPLX:
8072 dreal1[0] = CONVAL1G(CONVAL1G(conval1));
8073 dreal1[1] = CONVAL2G(CONVAL1G(conval1));
8074 dimag1[0] = CONVAL1G(CONVAL2G(conval1));
8075 dimag1[1] = CONVAL2G(CONVAL2G(conval1));
8076 dreal2[0] = CONVAL1G(CONVAL1G(conval2));
8077 dreal2[1] = CONVAL2G(CONVAL1G(conval2));
8078 dimag2[0] = CONVAL1G(CONVAL2G(conval2));
8079 dimag2[1] = CONVAL2G(CONVAL2G(conval2));
8080 switch (opr) {
8081 case OP_ADD:
8082 xdadd(dreal1, dreal2, drealrs);
8083 xdadd(dimag1, dimag2, dimagrs);
8084 break;
8085 case OP_SUB:
8086 xdsub(dreal1, dreal2, drealrs);
8087 xdsub(dimag1, dimag2, dimagrs);
8088 break;
8089 case OP_MUL:
8090 /* (a + bi) * (c + di) ==> (ac-bd) + (ad+cb)i */
8091 xdmul(dreal1, dreal2, dtemp1);
8092 xdmul(dimag1, dimag2, dtemp);
8093 xdsub(dtemp1, dtemp, drealrs);
8094 xdmul(dreal1, dimag2, dtemp1);
8095 xdmul(dreal2, dimag1, dtemp);
8096 xdadd(dtemp1, dtemp, dimagrs);
8097 break;
8098 case OP_DIV:
8099 dtemp2[0] = CONVAL1G(stb.dbl0);
8100 dtemp2[1] = CONVAL2G(stb.dbl0);
8101 /* drealrs = dreal2;
8102 * if (drealrs < 0)
8103 * drealrs = -drealrs;
8104 * dimagrs = dimag2;
8105 * if (dimagrs < 0)
8106 * dimagrs = -dimagrs;
8107 */
8108 if (xdcmp(dreal2, dtemp2) < 0)
8109 xdsub(dtemp2, dreal2, drealrs);
8110 else {
8111 drealrs[0] = dreal2[0];
8112 drealrs[1] = dreal2[1];
8113 }
8114 if (xdcmp(dimag2, dtemp2) < 0)
8115 xdsub(dtemp2, dimag2, dimagrs);
8116 else {
8117 dimagrs[0] = dimag2[0];
8118 dimagrs[1] = dimag2[1];
8119 }
8120
8121 /* avoid overflow */
8122
8123 dtemp2[0] = CONVAL1G(stb.dbl1);
8124 dtemp2[1] = CONVAL2G(stb.dbl1);
8125 if (xdcmp(drealrs, dimagrs) <= 0) {
8126 /* if (drealrs <= dimagrs) {
8127 * dtemp = dreal2 / dimag2;
8128 * dtemp1 = 1.0 / (dimag2 * (1 + dtemp * dtemp));
8129 * drealrs = (dreal1 * dtemp + dimag1) * dtemp1;
8130 * dimagrs = (dimag1 * dtemp - dreal1) * dtemp1;
8131 * }
8132 */
8133 _ddiv(dreal2, dimag2, dtemp);
8134
8135 xdmul(dtemp, dtemp, dtemp1);
8136 xdadd(dtemp2, dtemp1, dtemp1);
8137 xdmul(dimag2, dtemp1, dtemp1);
8138 _ddiv(dtemp2, dtemp1, dtemp1);
8139
8140 xdmul(dreal1, dtemp, drealrs);
8141 xdadd(drealrs, dimag1, drealrs);
8142 xdmul(drealrs, dtemp1, drealrs);
8143
8144 xdmul(dimag1, dtemp, dimagrs);
8145 xdsub(dimagrs, dreal1, dimagrs);
8146 xdmul(dimagrs, dtemp1, dimagrs);
8147 } else {
8148 /* else {
8149 * dtemp = dimag2 / dreal2;
8150 * dtemp1 = 1.0 / (dreal2 * (1 + dtemp * dtemp));
8151 * drealrs = (dreal1 + dimag1 * dtemp) * dtemp1;
8152 * dimagrs = (dimag1 - dreal1 * dtemp) * dtemp1;
8153 * }
8154 */
8155 _ddiv(dimag2, dreal2, dtemp);
8156
8157 xdmul(dtemp, dtemp, dtemp1);
8158 xdadd(dtemp2, dtemp1, dtemp1);
8159 xdmul(dreal2, dtemp1, dtemp1);
8160 _ddiv(dtemp2, dtemp1, dtemp1);
8161
8162 xdmul(dimag1, dtemp, drealrs);
8163 xdadd(dreal1, drealrs, drealrs);
8164 xdmul(drealrs, dtemp1, drealrs);
8165
8166 xdmul(dreal1, dtemp, dimagrs);
8167 xdsub(dimag1, dimagrs, dimagrs);
8168 xdmul(dimagrs, dtemp1, dimagrs);
8169 }
8170 break;
8171 case OP_CMP:
8172 /*
8173 * for complex, only EQ and NE comparisons are allowed, so return
8174 * 0 if the two constants are the same, else 1:
8175 */
8176 return (conval1 != conval2);
8177 default:
8178 goto err_exit;
8179 }
8180 num1[0] = getcon(drealrs, DT_REAL8);
8181 num1[1] = getcon(dimagrs, DT_REAL8);
8182 return getcon(num1, DT_CMPLX16);
8183
8184 case TY_BLOG:
8185 case TY_SLOG:
8186 case TY_LOG:
8187 case TY_LOG8:
8188 if (opr != OP_CMP) {
8189 errsev(91);
8190 return 0;
8191 }
8192 /*
8193 * opr is assumed to be OP_CMP, only EQ and NE comparisons are
8194 * allowed so just return 0 if eq, else 1:
8195 */
8196 return (conval1 != conval2);
8197
8198 case TY_NCHAR:
8199 if (opr != OP_CMP) {
8200 errsev(91);
8201 return 0;
8202 }
8203 #define KANJI_BLANK 0xA1A1
8204 {
8205 int bytes, val1, val2;
8206 /* following if condition prevent seg fault from following example;
8207 * logical,parameter ::b=char(32,kind=2).eq.char(45,kind=2)
8208 */
8209 if (CONVAL1G(conval1) > stb.stg_avail ||
8210 CONVAL1G(conval2) > stb.stg_avail) {
8211 errsev(91);
8212 return 0;
8213 }
8214 cvlen1 = string_length(DTYPEG(CONVAL1G(conval1)));
8215 cvlen2 = string_length(DTYPEG(CONVAL1G(conval2)));
8216 p = stb.n_base + CONVAL1G(CONVAL1G(conval1));
8217 q = stb.n_base + CONVAL1G(CONVAL1G(conval2));
8218
8219 while (cvlen1 > 0 && cvlen2 > 0) {
8220 val1 = kanji_char((unsigned char *)p, cvlen1, &bytes);
8221 p += bytes, cvlen1 -= bytes;
8222 val2 = kanji_char((unsigned char *)q, cvlen2, &bytes);
8223 q += bytes, cvlen2 -= bytes;
8224 if (val1 != val2)
8225 return (val1 - val2);
8226 }
8227
8228 while (cvlen1 > 0) {
8229 val1 = kanji_char((unsigned char *)p, cvlen1, &bytes);
8230 p += bytes, cvlen1 -= bytes;
8231 if (val1 != KANJI_BLANK)
8232 return (val1 - KANJI_BLANK);
8233 }
8234
8235 while (cvlen2 > 0) {
8236 val2 = kanji_char((unsigned char *)q, cvlen2, &bytes);
8237 q += bytes, cvlen2 -= bytes;
8238 if (val2 != KANJI_BLANK)
8239 return (KANJI_BLANK - val2);
8240 }
8241 }
8242 return 0;
8243
8244 case TY_CHAR:
8245 if (opr != OP_CMP) {
8246 errsev(91);
8247 return 0;
8248 }
8249 /* opr is OP_CMP, return -1, 0, or 1: */
8250 cvlen1 = string_length(DTYPEG(conval1));
8251 cvlen2 = string_length(DTYPEG(conval2));
8252 if (cvlen1 == 0 || cvlen2 == 0) {
8253 return cvlen1 - cvlen2;
8254 }
8255 /* change the shorter string to be of same length as the longer: */
8256 if (cvlen1 < cvlen2) {
8257 conval1 = cngcon(conval1, (int)DTYPEG(conval1), (int)DTYPEG(conval2));
8258 cvlen1 = cvlen2;
8259 } else
8260 conval2 = cngcon(conval2, (int)DTYPEG(conval2), (int)DTYPEG(conval1));
8261
8262 p = stb.n_base + CONVAL1G(conval1);
8263 q = stb.n_base + CONVAL1G(conval2);
8264 do {
8265 if (*p != *q)
8266 return (*p - *q);
8267 ++p;
8268 ++q;
8269 } while (--cvlen1);
8270 return 0;
8271 }
8272
8273 err_exit:
8274 interr("const_fold: bad args", dtype, 3);
8275 return (0);
8276 }
8277
8278 /** \brief Convert constant from oldtyp to newtyp.
8279 \return constant value for 32-bit constants, or symbol table pointer
8280
8281 Issue error messages only for impossible conversions.<br>
8282 Can only be used for scalar constants.
8283
8284 Remember: Non-decimal constants are octal, hexadecimal, or hollerith
8285 constants which are represented by DT_WORD, DT_DWORD and DT_HOLL.
8286 Non-decimal constants 'assume' data types rather than go thru a conversion.
8287 Hollerith constants have a data type of DT_HOLL in the semantic stack;
8288 the CONVAL1 field locates a constant of data type DT_CHAR and the
8289 CONVAL2 field indicates the kind of Hollerith ('h', 'l', or 'r').
8290
8291 Hollerith constants are always treated as scalars while octal or
8292 hexadecimal constants can be promoted to vectors.
8293 */
8294 INT
cngcon(INT oldval,int oldtyp,int newtyp)8295 cngcon(INT oldval, int oldtyp, int newtyp)
8296 {
8297 int to, from;
8298 char *cp, buf[20];
8299 int newcvlen, oldcvlen, msk, blnk;
8300 INT num[4], result;
8301 INT num1[8];
8302 INT num2[4];
8303 INT swap;
8304 UINT unum[4];
8305 int q0;
8306
8307 #define MASKH32(sptr) (CONVAL1G(sptr) & 0xFFFFFFFF)
8308 if (is_empty_typedef(newtyp) && oldtyp == DT_INT4) {
8309 /* Special case for empty typedef */
8310 newtyp = DT_INT4;
8311 }
8312 if (newtyp == oldtyp)
8313 return oldval;
8314 to = DTY(newtyp);
8315 from = DTY(oldtyp);
8316
8317 if ((!TY_ISSCALAR(to) && to != TY_NUMERIC) || !TY_ISSCALAR(from))
8318 goto type_conv_error;
8319
8320 if (F77OUTPUT) {
8321 if (TY_ISLOG(to) && (!TY_ISLOG(from)))
8322 /* "Illegal type conversion $" */
8323 error(432, 2, gbl.lineno, "to logical", CNULL);
8324 if (TY_ISLOG(from) && (!TY_ISLOG(to)))
8325 error(432, 2, gbl.lineno, "from logical", CNULL);
8326 }
8327
8328 switch (to) {
8329 case TY_WORD:
8330 break;
8331
8332 case TY_BLOG:
8333 case TY_BINT:
8334 /* decimal integer constants are 32-bits, BUT, PARAMETER
8335 may be TY_SLOG, TY_SINT, TY_BLOG, or TY_BINT.
8336 */
8337 switch (from) {
8338 case TY_WORD:
8339 if (oldval & 0xFFFFFF00)
8340 errwarn(15);
8341 return (sign_extend(oldval, 8));
8342 case TY_DWORD:
8343 result = CONVAL2G(oldval);
8344 if (CONVAL1G(oldval))
8345 errwarn(15);
8346 return (sign_extend(result, 8));
8347 case TY_INT8:
8348 case TY_LOG8:
8349 result = CONVAL2G(oldval);
8350 if ((((result & 0xFFFFFF80) != 0xFFFFFF80) && (result & 0xFFFFFF00)) ||
8351 (MASKH32(oldval) != 0 && MASKH32(oldval) != 0xFFFFFFFF))
8352 truncation_warning(result & 0xFF);
8353 return (sign_extend(result, 8));
8354 case TY_BINT:
8355 case TY_SINT:
8356 case TY_INT:
8357 case TY_BLOG:
8358 case TY_SLOG:
8359 case TY_LOG:
8360 if (((oldval & 0xFFFFFF80) != 0xFFFFFF80) && (oldval & 0xFFFFFF00))
8361 truncation_warning(oldval & 0xFF);
8362 return (sign_extend(oldval, 8));
8363 default:
8364 break;
8365 }
8366 goto other_int_cases;
8367 case TY_SLOG:
8368 case TY_SINT:
8369 switch (from) {
8370 case TY_WORD:
8371 if (oldval & 0xFFFF0000)
8372 errwarn(15);
8373 return (sign_extend(oldval, 16));
8374 case TY_DWORD:
8375 result = CONVAL2G(oldval);
8376 if (CONVAL1G(oldval))
8377 errwarn(15);
8378 return (sign_extend(result, 16));
8379 case TY_INT8:
8380 case TY_LOG8:
8381 result = CONVAL2G(oldval);
8382 if ((((result & 0xFFFF8000) != 0xFFFF8000) && (result & 0xFFFF0000)) ||
8383 (MASKH32(oldval) != 0 && MASKH32(oldval) != 0xFFFFFFFF))
8384 truncation_warning(result & 0xFFFF);
8385 return (sign_extend(result, 16));
8386 case TY_BINT:
8387 case TY_SINT:
8388 case TY_INT:
8389 case TY_BLOG:
8390 case TY_SLOG:
8391 case TY_LOG:
8392 if (((oldval & 0xFFFF8000) != 0xFFFF8000) && (oldval & 0xFFFF0000))
8393 truncation_warning(oldval & 0xFFFF);
8394 return (sign_extend(oldval, 16));
8395 default:
8396 break;
8397 }
8398 goto other_int_cases;
8399 case TY_LOG:
8400 case TY_INT:
8401 if (from == TY_DWORD) {
8402 result = CONVAL2G(oldval);
8403 if (CONVAL1G(oldval))
8404 errwarn(15);
8405 return (result);
8406 }
8407 if (from == TY_INT8) {
8408 result = CONVAL2G(oldval);
8409 if (MASKH32(oldval) != 0 && (MASKH32(oldval) != 0xFFFFFFFF))
8410 truncation_warning(CONVAL1G(oldval));
8411 return sign_extend(result, 32);
8412 }
8413 if (from == TY_LOG8) {
8414 result = CONVAL2G(oldval);
8415 return sign_extend(result, 32);
8416 }
8417 if (TY_ISLOG(to) && TY_ISLOG(from))
8418 /* -standard removes _TY_ISINT from logical types, so explicitly
8419 * check for logicals.
8420 */
8421 return oldval;
8422 if (from == TY_WORD || TY_ISINT(from))
8423 return oldval;
8424 other_int_cases:
8425 switch (from) {
8426 case TY_CMPLX:
8427 oldval = CONVAL1G(oldval);
8428 case TY_REAL:
8429 xfix(oldval, &result);
8430 return result;
8431 case TY_DCMPLX:
8432 oldval = CONVAL1G(oldval);
8433 case TY_DBLE:
8434 num[0] = CONVAL1G(oldval);
8435 num[1] = CONVAL2G(oldval);
8436 xdfix(num, &result);
8437 return result;
8438 case TY_HOLL:
8439 cp = stb.n_base + CONVAL1G(CONVAL1G(oldval));
8440 goto char_to_int;
8441 case TY_CHAR:
8442 if (flg.standard)
8443 conversion_warning();
8444 cp = stb.n_base + CONVAL1G(oldval);
8445 char_to_int:
8446 oldcvlen = 4;
8447 if (to == TY_BLOG || to == TY_BINT)
8448 oldcvlen = 1;
8449 if (to == TY_SLOG || to == TY_SINT)
8450 oldcvlen = 2;
8451 if (to == TY_LOG8 || to == TY_INT8)
8452 oldcvlen = 8;
8453 holtonum(cp, num, oldcvlen);
8454 return num[3];
8455 default: /* TY_NCHAR comes here */
8456 break;
8457 }
8458 break;
8459
8460 case TY_LOG8:
8461 case TY_INT8:
8462 if (from == TY_DWORD || from == TY_INT8 || from == TY_LOG8) {
8463 num[0] = CONVAL1G(oldval);
8464 num[1] = CONVAL2G(oldval);
8465 return getcon(num, newtyp);
8466 } else if (from == TY_WORD) {
8467 unum[0] = 0;
8468 unum[1] = oldval;
8469 return getcon((INT *)unum, newtyp);
8470 } else if (TY_ISINT(from) || (TY_ISLOG(to) && TY_ISLOG(from))) {
8471 if (oldval < 0) {
8472 num[0] = -1;
8473 num[1] = oldval;
8474 } else {
8475 num[0] = 0;
8476 num[1] = oldval;
8477 }
8478 return getcon(num, newtyp);
8479 } else {
8480 switch (from) {
8481 case TY_CMPLX:
8482 oldval = CONVAL1G(oldval);
8483 case TY_REAL:
8484 xfix64(oldval, num);
8485 return getcon(num, newtyp);
8486 case TY_DCMPLX:
8487 oldval = CONVAL1G(oldval);
8488 case TY_DBLE:
8489 num1[0] = CONVAL1G(oldval);
8490 num1[1] = CONVAL2G(oldval);
8491 xdfix64(num1, num);
8492 return getcon(num, newtyp);
8493 case TY_HOLL:
8494 cp = stb.n_base + CONVAL1G(CONVAL1G(oldval));
8495 goto char_to_int8;
8496 case TY_CHAR:
8497 if (flg.standard)
8498 conversion_warning();
8499 cp = stb.n_base + CONVAL1G(oldval);
8500 char_to_int8:
8501 holtonum(cp, num, 8);
8502 if (flg.endian == 0) {
8503 /* for little endian, need to swap words in each double word
8504 * quantity. Order of bytes in a word is okay, but not the
8505 * order of words.
8506 */
8507 swap = num[2];
8508 num[2] = num[3];
8509 num[3] = swap;
8510 }
8511 return getcon(&num[2], newtyp);
8512 default: /* TY_NCHAR comes here */
8513 break;
8514 }
8515 }
8516 break;
8517
8518 case TY_REAL:
8519 if (from == TY_WORD)
8520 return oldval;
8521 else if (from == TY_DWORD) {
8522 result = CONVAL2G(oldval);
8523 if (CONVAL1G(oldval))
8524 errwarn(15);
8525 return result;
8526 } else if (from == TY_INT8 || from == TY_LOG8) {
8527 num[0] = CONVAL1G(oldval);
8528 num[1] = CONVAL2G(oldval);
8529 xflt64(num, &result);
8530 return result;
8531 } else if (TY_ISINT(from)) {
8532 xffloat(oldval, &result);
8533 return result;
8534 } else {
8535 switch (from) {
8536 case TY_CMPLX:
8537 return CONVAL1G(oldval);
8538 case TY_DCMPLX:
8539 oldval = CONVAL1G(oldval);
8540 case TY_DBLE:
8541 num[0] = CONVAL1G(oldval);
8542 num[1] = CONVAL2G(oldval);
8543 xsngl(num, &result);
8544 return result;
8545 case TY_HOLL:
8546 cp = stb.n_base + CONVAL1G(CONVAL1G(oldval));
8547 goto char_to_real;
8548 case TY_CHAR:
8549 if (flg.standard)
8550 conversion_warning();
8551 cp = stb.n_base + CONVAL1G(oldval);
8552 char_to_real:
8553 holtonum(cp, num, 4);
8554 return num[3];
8555 default:
8556 break;
8557 }
8558 }
8559 break;
8560
8561 case TY_DBLE:
8562 if (from == TY_WORD) {
8563 num[0] = 0;
8564 num[1] = oldval;
8565 } else if (from == TY_DWORD) {
8566 num[0] = CONVAL1G(oldval);
8567 num[1] = CONVAL2G(oldval);
8568 } else if (from == TY_INT8 || from == TY_LOG8) {
8569 num1[0] = CONVAL1G(oldval);
8570 num1[1] = CONVAL2G(oldval);
8571 xdflt64(num1, num);
8572 } else if (TY_ISINT(from))
8573 xdfloat(oldval, num);
8574 else {
8575 switch (from) {
8576 case TY_DCMPLX:
8577 return CONVAL1G(oldval);
8578 case TY_CMPLX:
8579 oldval = CONVAL1G(oldval);
8580 case TY_REAL:
8581 xdble(oldval, num);
8582 break;
8583 case TY_HOLL:
8584 cp = stb.n_base + CONVAL1G(CONVAL1G(oldval));
8585 goto char_to_dble;
8586 case TY_CHAR:
8587 if (flg.standard)
8588 conversion_warning();
8589 cp = stb.n_base + CONVAL1G(oldval);
8590 char_to_dble:
8591 holtonum(cp, num, 8);
8592 if (flg.endian == 0) {
8593 /* for little endian, need to swap words in each double word
8594 * quantity. Order of bytes in a word is okay, but not the
8595 * order of words.
8596 */
8597 swap = num[2];
8598 num[2] = num[3];
8599 num[3] = swap;
8600 }
8601 return getcon(&num[2], DT_REAL8);
8602 default:
8603 errsev(91);
8604 return (stb.dbl0);
8605 }
8606 }
8607 return getcon(num, DT_REAL8);
8608
8609 case TY_CMPLX:
8610 /* num[0] = real part
8611 * num[1] = imaginary part
8612 */
8613 num[1] = 0;
8614 if (from == TY_WORD) {
8615 /* a la VMS */
8616 num[0] = 0;
8617 num[1] = oldval;
8618 } else if (from == TY_DWORD) {
8619 /* a la VMS */
8620 num[0] = CONVAL1G(oldval);
8621 num[1] = CONVAL2G(oldval);
8622 } else if (from == TY_INT8 || from == TY_LOG8) {
8623 num1[0] = CONVAL1G(oldval);
8624 num1[1] = CONVAL2G(oldval);
8625 xflt64(num1, &num[0]);
8626 } else if (TY_ISINT(from))
8627 xffloat(oldval, &num[0]);
8628 else {
8629 switch (from) {
8630 case TY_REAL:
8631 num[0] = oldval;
8632 break;
8633 case TY_DBLE:
8634 num1[0] = CONVAL1G(oldval);
8635 num1[1] = CONVAL2G(oldval);
8636 xsngl(num1, &num[0]);
8637 break;
8638 case TY_DCMPLX:
8639 num1[0] = CONVAL1G(CONVAL1G(oldval));
8640 num1[1] = CONVAL2G(CONVAL1G(oldval));
8641 xsngl(num1, &num[0]);
8642 num1[0] = CONVAL1G(CONVAL2G(oldval));
8643 num1[1] = CONVAL2G(CONVAL2G(oldval));
8644 xsngl(num1, &num[1]);
8645 break;
8646 case TY_HOLL:
8647 cp = stb.n_base + CONVAL1G(CONVAL1G(oldval));
8648 goto char_to_cmplx;
8649 case TY_CHAR:
8650 if (flg.standard)
8651 conversion_warning();
8652 cp = stb.n_base + CONVAL1G(oldval);
8653 char_to_cmplx:
8654 holtonum(cp, num, 8);
8655 return getcon(&num[2], DT_CMPLX8);
8656 default:
8657 num[0] = 0;
8658 num[1] = 0;
8659 errsev(91);
8660 }
8661 }
8662 return getcon(num, DT_CMPLX8);
8663
8664 case TY_DCMPLX:
8665 if (from == TY_WORD) {
8666 num[0] = 0;
8667 num[1] = oldval;
8668 num[0] = getcon(num, DT_REAL8);
8669 num[1] = stb.dbl0;
8670 } else if (from == TY_DWORD) {
8671 num[0] = CONVAL1G(oldval);
8672 num[1] = CONVAL2G(oldval);
8673 num[0] = getcon(num, DT_REAL8);
8674 num[1] = stb.dbl0;
8675 } else if (from == TY_INT8 || from == TY_LOG8) {
8676 num1[0] = CONVAL1G(oldval);
8677 num1[1] = CONVAL2G(oldval);
8678 xdflt64(num1, num);
8679 num[0] = getcon(num, DT_REAL8);
8680 num[1] = stb.dbl0;
8681 } else if (TY_ISINT(from)) {
8682 xdfloat(oldval, num);
8683 num[0] = getcon(num, DT_REAL8);
8684 num[1] = stb.dbl0;
8685 } else {
8686 switch (from) {
8687 case TY_REAL:
8688 xdble(oldval, num);
8689 num[0] = getcon(num, DT_REAL8);
8690 num[1] = stb.dbl0;
8691 break;
8692 case TY_DBLE:
8693 num[0] = oldval;
8694 num[1] = stb.dbl0;
8695 break;
8696 case TY_CMPLX:
8697 xdble(CONVAL1G(oldval), num1);
8698 num[0] = getcon(num1, DT_REAL8);
8699 xdble(CONVAL2G(oldval), num1);
8700 num[1] = getcon(num1, DT_REAL8);
8701 break;
8702 case TY_HOLL:
8703 cp = stb.n_base + CONVAL1G(CONVAL1G(oldval));
8704 goto char_to_dcmplx;
8705 case TY_CHAR:
8706 if (flg.standard)
8707 conversion_warning();
8708 cp = stb.n_base + CONVAL1G(oldval);
8709 char_to_dcmplx:
8710 holtonum(cp, num1, 16);
8711 if (flg.endian == 0) {
8712 /* for little endian, need to swap words in each double word
8713 * quantity. Order of bytes in a word is okay, but not the
8714 * order of words.
8715 */
8716 swap = num1[0];
8717 num1[0] = num1[1];
8718 num1[1] = swap;
8719 swap = num1[2];
8720 num1[2] = num1[3];
8721 num1[3] = swap;
8722 }
8723 num[0] = getcon(&num1[0], DT_REAL8);
8724 num[1] = getcon(&num1[2], DT_REAL8);
8725 break;
8726 default:
8727 num[0] = 0;
8728 num[1] = 0;
8729 errsev(91);
8730 }
8731 }
8732 return getcon(num, DT_CMPLX16);
8733
8734 case TY_NCHAR:
8735 if (from == TY_WORD) {
8736 num[0] = 0;
8737 num[1] = oldval;
8738 oldval = hex2nchar(num);
8739 cp = stb.n_base + CONVAL1G(oldval);
8740 oldcvlen = kanji_len((unsigned char *)cp, string_length(DTYPEG(oldval)));
8741 oldtyp = get_type(2, TY_NCHAR, mk_cval(oldcvlen, DT_INT4));
8742 if (newtyp == oldtyp)
8743 return oldval;
8744 } else if (from == TY_DWORD) {
8745 num[0] = CONVAL1G(oldval);
8746 num[1] = CONVAL2G(oldval);
8747 oldval = hex2nchar(num);
8748 cp = stb.n_base + CONVAL1G(oldval);
8749 oldcvlen = kanji_len((unsigned char *)cp, string_length(DTYPEG(oldval)));
8750 oldtyp = get_type(2, TY_NCHAR, mk_cval(oldcvlen, DT_INT4));
8751 if (newtyp == oldtyp)
8752 return oldval;
8753 } else if (from != TY_NCHAR) {
8754 errsev(146);
8755 return getstring(" ", 1);
8756 }
8757 goto char_shared;
8758
8759 case TY_CHAR:
8760 if (from == TY_WORD) {
8761 num[0] = 0;
8762 num[1] = oldval;
8763 oldval = hex2char(num);
8764 /* old value is now in character form; must changed oldtyp
8765 * and must check if lengths just happen to be equal.
8766 */
8767 oldtyp = DTYPEG(oldval);
8768 if (newtyp == oldtyp)
8769 return oldval;
8770 } else if (from == TY_DWORD) {
8771 num[0] = CONVAL1G(oldval);
8772 num[1] = CONVAL2G(oldval);
8773 oldval = hex2char(num);
8774 /* old value is now in character form; must changed oldtyp
8775 * and must check if lengths just happen to be equal.
8776 */
8777 oldtyp = DTYPEG(oldval);
8778 if (newtyp == oldtyp)
8779 return oldval;
8780 } else if (from != TY_CHAR && from != TY_HOLL) {
8781 errsev(146);
8782 return getstring(" ", 1);
8783 }
8784
8785 char_shared:
8786 if (newtyp == DT_ASSCHAR || newtyp == DT_DEFERCHAR)
8787 return oldval;
8788 if (newtyp == DT_ASSNCHAR || newtyp == DT_DEFERNCHAR)
8789 return oldval;
8790 newcvlen = string_length(newtyp);
8791 if (from == TY_HOLL) {
8792 oldval = CONVAL1G(oldval); /* locate Hollerith's char constant */
8793 oldtyp = DTYPEG(oldval);
8794 }
8795 oldcvlen = string_length(oldtyp);
8796
8797 if (oldcvlen > newcvlen) {
8798 /* truncate character string: */
8799 errinfo(122);
8800 if (from == TY_NCHAR) {
8801 /* oldval is kanji string, CONVAL1G(oldval) is char string */
8802 cp = local_sname(stb.n_base + CONVAL1G(CONVAL1G(oldval)));
8803 } else
8804 cp = local_sname(stb.n_base + CONVAL1G(oldval));
8805 if (from == TY_NCHAR ||
8806 (to == TY_NCHAR && (from == TY_WORD || from == TY_DWORD)))
8807 /* compute actual num bytes used to represent newcvlen chars:*/
8808 newcvlen = kanji_prefix((unsigned char *)cp, newcvlen,
8809 DTY(DTYPEG(oldval) + 1));
8810 result = getstring(cp, newcvlen);
8811 if (to == TY_NCHAR) {
8812 num[0] = result;
8813 num[1] = 0;
8814 num[2] = 0;
8815 num[3] = 0;
8816 result = getcon(num, newtyp);
8817 }
8818 return result;
8819 }
8820
8821 /* oldcvlen < newcvlen - pad with blanks. This works for regular
8822 and kanji strings. Note (from == oldcvlen) unless type is TY_NCHAR
8823 and there are one or more Kanji(2 byte) characters in the string. */
8824
8825 newcvlen -= oldcvlen; /* number of pad blanks */
8826 blnk = ' ';
8827 if (from == TY_NCHAR) /* double for NCHAR */
8828 newcvlen *= 2, blnk = 0xA1;
8829 from =
8830 string_length(DTYPEG(oldval)); /* number bytes in char string const */
8831 cp = getitem(0, from + newcvlen);
8832 BCOPY(cp, stb.n_base + CONVAL1G(oldval), char, (INT)from);
8833 if (newcvlen > 0) {
8834 do {
8835 cp[from++] = blnk;
8836 } while (--newcvlen > 0);
8837 }
8838 result = getstring(cp, from);
8839 if (to == TY_NCHAR) {
8840 num[0] = result;
8841 num[1] = 0;
8842 num[2] = 0;
8843 num[3] = 0;
8844 result = getcon(num, newtyp);
8845 }
8846 return result;
8847
8848 case TY_NUMERIC:
8849 if (!TY_ISNUMERIC(from))
8850 goto type_conv_error;
8851 return oldval;
8852
8853 default:
8854 break;
8855 }
8856
8857 type_conv_error:
8858 errsev(91);
8859 return 0;
8860 }
8861
8862 static void
truncation_warning(int c)8863 truncation_warning(int c)
8864 {
8865 char buf[20];
8866 sprintf(buf, "%d", c);
8867 error(W_0128_Integer_constant_truncated_to_fit_data_type_OP1, ERR_Warning,
8868 gbl.lineno, buf, 0);
8869 }
8870
8871 static void
conversion_warning(void)8872 conversion_warning(void)
8873 {
8874 error(W_0170_PGI_Fortran_extension_OP1_OP2, ERR_Warning, gbl.lineno,
8875 "conversion of CHARACTER constant to numeric", 0);
8876 }
8877
8878 static INT
_fdiv(INT dividend,INT divisor)8879 _fdiv(INT dividend, INT divisor)
8880 {
8881 INT quotient;
8882 INT temp;
8883
8884 #ifdef TM_FRCP
8885 if (!flg.ieee) {
8886 xfrcp(divisor, &temp);
8887 xfmul(dividend, temp, "ient);
8888 } else
8889 xfdiv(dividend, divisor, "ient);
8890 #else
8891 xfdiv(dividend, divisor, "ient);
8892 #endif
8893 return quotient;
8894 }
8895
8896 static void
_ddiv(INT * dividend,INT * divisor,INT * quotient)8897 _ddiv(INT *dividend, INT *divisor, INT *quotient)
8898 {
8899 INT temp[2];
8900
8901 #ifdef TM_DRCP
8902 if (!flg.ieee) {
8903 xdrcp(divisor, temp);
8904 xdmul(dividend, temp, quotient);
8905 } else
8906 xddiv(dividend, divisor, quotient);
8907 #else
8908 xddiv(dividend, divisor, quotient);
8909 #endif
8910 }
8911
8912 /** \brief Convert doubleword hex/octal value to a character.
8913 \param hexval two-element array of [0] msw, [1] lsw
8914 \return the symbol table entry of the character constant
8915
8916
8917 The conversion is performed by copying an 8-bit value (2 hex digits) to a
8918 character position which is endian-dependent. The endian-dependency is
8919 handled as if the hex value is "equivalenced" with a character value of the
8920 same length. The length of the character constant returned is determined
8921 by the magnitude of the hex values (leading 0's are not converted). Note
8922 that this conversion returns the same character value in context of an
8923 assignment or data initialization.
8924
8925 We may be incompatible with other implementations with respect to data
8926 initialization:
8927 1. if the value is smaller than the char item being initialized, the
8928 conversion process results in appending blanks; other systems may
8929 pad with 'nulls'
8930 2. if the value is larger, truncation of the least significant characters
8931 ("rightmost") occurs; other systems truncate the most significant
8932 characters ("leftmost").
8933 */
8934 static int
hex2char(INT * hexval)8935 hex2char(INT *hexval)
8936 {
8937 UINT val;
8938 int i;
8939 int len;
8940 char *p;
8941 char buf[8];
8942
8943 len = 0;
8944 if (flg.endian) {
8945 /* big endian: rightmost 2 hex digits are in last byte position */
8946 p = buf + 7;
8947 i = -1;
8948 } else {
8949 /* little endian: rightmost 2 hex digits are in first byte position */
8950 p = buf;
8951 i = 1;
8952 }
8953 val = hexval[1];
8954 while (val) {
8955 *p = val & 0xff;
8956 p += i;
8957 len++;
8958 val >>= 8;
8959 }
8960 val = hexval[0];
8961 while (val) {
8962 *p = val & 0xff;
8963 p += i;
8964 len++;
8965 val >>= 8;
8966 }
8967
8968 if (len == 0) {
8969 len = 1;
8970 *p = '\0';
8971 } else if (flg.endian)
8972 p++;
8973 else
8974 p = buf;
8975
8976 return getstring(p, len);
8977 }
8978
8979 /*
8980 * convert doubleword hex/octal value to an ncharacter. Function return value
8981 * is the symbol table entry of the character constant. The conversion is
8982 * performed by copying an 8-bit value (2 hex digits) to a character position
8983 * which is endian-dependent. The endian-dependency is handled as if
8984 * the hex value is "equivalenced" with a ncharacter value of the same length.
8985 * The length of the ncharacter constant returned is determined by the magnitude
8986 * of the hex values (leading 0's are not converted). Note that this conversion
8987 * returns the same ncharacter value in context of an assignment or data
8988 * initialization. We may be incompatible with other implementations
8989 * with respect to data initialization:
8990 * 1. if the value is smaller than the nchar item being initialized, the
8991 * conversion process results in appending blanks; other systems may
8992 * pad with 'nulls'
8993 * 2. if the value is larger, truncation of the least significant characters
8994 * ("rightmost") occurs; other systems truncate the most significant
8995 * characters ("leftmost").
8996 *
8997 * hexval[0] is msw, hexval[1] is lsw
8998 */
8999 static int
hex2nchar(INT * hexval)9000 hex2nchar(INT *hexval)
9001 {
9002 UINT val;
9003 int i;
9004 int len;
9005 unsigned short *p;
9006 unsigned short buf[4];
9007
9008 len = 0;
9009 if (flg.endian) {
9010 /* big endian: rightmost 2 hex digits are in last byte position */
9011 p = buf + 3;
9012 i = -1;
9013 } else {
9014 /* little endian: rightmost 2 hex digits are in first byte position */
9015 p = buf;
9016 i = 1;
9017 }
9018 val = hexval[1];
9019 while (val) {
9020 *p = val & 0xffff;
9021 p += i;
9022 len += 2;
9023 val >>= 16;
9024 }
9025 val = hexval[0];
9026 while (val) {
9027 *p = val & 0xffff;
9028 p += i;
9029 len += 2;
9030 val >>= 16;
9031 }
9032 if (len == 0) {
9033 len = 1;
9034 *p = '\0';
9035 } else if (flg.endian)
9036 p++;
9037 else
9038 p = buf;
9039
9040 return getstring((char *)p, len);
9041 }
9042
9043 int
resolve_ast_alias(int ast)9044 resolve_ast_alias(int ast)
9045 {
9046 int alias;
9047 while (ast && (alias = A_ALIASG(ast)) > 0 &&
9048 alias != ast /* prevent looping on bogus A_CNST self-aliases */) {
9049 ast = alias;
9050 }
9051 return ast;
9052 }
9053
9054 LOGICAL
is_array_ast(int ast)9055 is_array_ast(int ast)
9056 {
9057 if ((ast = resolve_ast_alias(ast))) {
9058 if (is_array_dtype(get_ast_dtype(ast)))
9059 return TRUE;
9060 switch (A_TYPEG(ast)) {
9061 case A_ID:
9062 return is_array_sptr(A_SPTRG(ast));
9063 case A_SUBSTR:
9064 return is_array_ast(A_LOPG(ast));
9065 case A_MEM:
9066 return is_array_ast(A_MEMG(ast)) || is_array_ast(A_PARENTG(ast));
9067 case A_SUBSCR: {
9068 int asd = A_ASDG(ast);
9069 int dims = ASD_NDIM(asd);
9070 int j;
9071 for (j = 0; j < dims; ++j) {
9072 if (is_array_ast(ASD_SUBS(asd, j)))
9073 return TRUE;
9074 }
9075 }
9076 return is_array_ast(A_LOPG(ast));
9077 case A_TRIPLE:
9078 return TRUE;
9079 }
9080 }
9081 return FALSE;
9082 }
9083
9084 LOGICAL
has_vector_subscript_ast(int ast)9085 has_vector_subscript_ast(int ast)
9086 {
9087 if ((ast = resolve_ast_alias(ast))) {
9088 switch (A_TYPEG(ast)) {
9089 case A_PAREN:
9090 case A_CONV:
9091 case A_SUBSTR:
9092 return has_vector_subscript_ast(A_LOPG(ast));
9093 case A_MEM:
9094 return has_vector_subscript_ast(A_PARENTG(ast));
9095 case A_SUBSCR: {
9096 int asd = A_ASDG(ast);
9097 int dims = ASD_NDIM(asd);
9098 int j;
9099 for (j = 0; j < dims; ++j) {
9100 int subs_ast = ASD_SUBS(asd, j);
9101 if (A_TYPEG(subs_ast) != A_TRIPLE && is_array_ast(subs_ast))
9102 return TRUE;
9103 }
9104 }
9105 return has_vector_subscript_ast(A_LOPG(ast));
9106 }
9107 }
9108 return FALSE;
9109 }
9110
9111 LOGICAL
is_data_ast(int ast)9112 is_data_ast(int ast)
9113 {
9114 if ((ast = resolve_ast_alias(ast))) {
9115 switch (A_TYPEG(ast)) {
9116 case A_ID:
9117 return !is_procedure_ptr(A_SPTRG(ast));
9118 case A_LABEL:
9119 case A_ENTRY:
9120 return FALSE;
9121 case A_CNST:
9122 case A_CMPLXC:
9123 case A_CONV:
9124 case A_UNOP:
9125 case A_BINOP:
9126 case A_PAREN:
9127 return TRUE;
9128 case A_FUNC: {
9129 DTYPE dtype = A_DTYPEG(ast);
9130 return dtype <= 0 || DTY(dtype) == TY_PROC;
9131 }
9132 case A_MEM:
9133 return is_data_ast(A_MEMG(ast));
9134 case A_SUBSTR:
9135 case A_SUBSCR:
9136 return TRUE;
9137 }
9138 }
9139 return FALSE;
9140 }
9141
9142 LOGICAL
is_variable_ast(int ast)9143 is_variable_ast(int ast)
9144 {
9145 if ((ast = resolve_ast_alias(ast))) {
9146 switch (A_TYPEG(ast)) {
9147 case A_ID:
9148 return !is_procedure_ptr(A_SPTRG(ast));
9149 case A_MEM:
9150 return is_variable_ast(A_MEMG(ast)) && is_variable_ast(A_PARENTG(ast));
9151 case A_SUBSTR:
9152 case A_SUBSCR:
9153 return is_variable_ast(A_LOPG(ast));
9154 }
9155 }
9156 return FALSE;
9157 }
9158
9159 int
get_ast_asd(int ast)9160 get_ast_asd(int ast)
9161 {
9162 if ((ast = resolve_ast_alias(ast)) && A_TYPEG(ast) == A_SUBSCR)
9163 return A_ASDG(ast);
9164 return 0;
9165 }
9166
9167 DTYPE
get_ast_dtype(int ast)9168 get_ast_dtype(int ast)
9169 {
9170 if ((ast = resolve_ast_alias(ast))) {
9171 switch (A_TYPEG(ast)) {
9172 case A_ID:
9173 case A_CNST:
9174 case A_LABEL:
9175 case A_BINOP:
9176 case A_UNOP:
9177 case A_CMPLXC:
9178 case A_CONV:
9179 case A_PAREN:
9180 case A_MEM:
9181 case A_SUBSCR:
9182 case A_SUBSTR:
9183 case A_FUNC:
9184 case A_INTR:
9185 case A_INIT:
9186 case A_ASN:
9187 case A_ICALL:
9188 /* Only these AST types interpret A_DTYPEG's overloaded field
9189 * as containing a data type table index.
9190 */
9191 return A_DTYPEG(ast);
9192 }
9193 }
9194 return DT_NONE;
9195 }
9196
9197 int
get_ast_rank(int ast)9198 get_ast_rank(int ast)
9199 {
9200 if ((ast = resolve_ast_alias(ast))) {
9201 int shd;
9202 DTYPE dtype;
9203
9204 /* These tests of those representations are arranged
9205 * here in descending order of credibility. When multiple
9206 * representations are present, We don't check their consistency
9207 * because there are indeed cases where they'll differ.
9208 */
9209 if ((shd = A_SHAPEG(ast)))
9210 return SHD_NDIM(shd); /* AST has explicit shape description */
9211 if (is_array_dtype(dtype = get_ast_dtype(ast)))
9212 return ADD_NUMDIM(dtype); /* Data type of AST is an array */
9213 }
9214 return 0;
9215 }
9216
9217 /* This utility finds the most relevant symbol table reference in an AST,
9218 * preferring member symbols to their parents. It's like memsym_of_ast()
9219 * but it fails gracefully and returns 0 when presented with an AST
9220 * that does not contain a symbol.
9221 */
9222 int
get_ast_sptr(int ast)9223 get_ast_sptr(int ast)
9224 {
9225 int sptr = 0;
9226 if ((ast = resolve_ast_alias(ast))) {
9227 switch (A_TYPEG(ast)) {
9228 case A_ID:
9229 case A_LABEL:
9230 case A_ENTRY:
9231 sptr = A_SPTRG(ast);
9232 break;
9233 case A_SUBSCR:
9234 case A_SUBSTR:
9235 case A_CONV:
9236 case A_FUNC:
9237 sptr = get_ast_sptr(A_LOPG(ast));
9238 break;
9239 case A_MEM:
9240 sptr = get_ast_sptr(A_MEMG(ast));
9241 if (sptr <= NOSYM)
9242 sptr = get_ast_sptr(A_PARENTG(ast));
9243 break;
9244 }
9245 }
9246 return sptr;
9247 }
9248
9249 /* Create a duplicate of an AST with a new data type. */
9250 int
rewrite_ast_with_new_dtype(int ast,DTYPE dtype)9251 rewrite_ast_with_new_dtype(int ast, DTYPE dtype)
9252 {
9253 if (A_DTYPEG(ast) != dtype) {
9254 switch (A_TYPEG(ast)) {
9255 case A_ID:
9256 case A_CNST:
9257 case A_LABEL: {
9258 int sptr = A_SPTRG(ast);
9259 int orig_sptr_dtype = DTYPEG(sptr);
9260 DTYPEP(sptr, dtype);
9261 ast = mk_id(sptr);
9262 DTYPEP(sptr, orig_sptr_dtype);
9263 return ast;
9264 }
9265 case A_MEM:
9266 return mk_member(A_PARENTG(ast), A_MEMG(ast), dtype);
9267 case A_SUBSCR: {
9268 int j, rank = get_ast_rank(ast), asd = A_ASDG(ast), subs[MAXRANK];
9269 for (j = 0; j < rank; ++j) {
9270 subs[j] = ASD_SUBS(asd, j);
9271 }
9272 return mk_subscr(A_LOPG(ast), subs, rank, dtype);
9273 }
9274 case A_ALLOC: /* and possibly others */
9275 /* not hashed, so it's okay to substitute dtype in situ */
9276 A_DTYPEP(ast, dtype);
9277 break;
9278 default:
9279 interr("rewrite_ast_with_new_dtype: can't replace dtype in A_TYPE",
9280 A_TYPEG(ast), 3);
9281 }
9282 }
9283 return ast;
9284 }
9285
9286 /*
9287 * Create a duplicated AST
9288 */
9289 int
mk_duplicate_ast(int ast)9290 mk_duplicate_ast(int ast)
9291 {
9292 int newast;
9293
9294 /*switch (A_TYPEG(ast)) {
9295 case A_PRAGMA:
9296 newast = mk_stmt(A_PRAGMA, 0);
9297 astb.stg_base[newast] = astb.stg_base[ast];
9298 break;
9299 default:
9300 interr("mk_duplicate_ast: A_TYPE is not supported yet",
9301 A_TYPEG(ast), ERR_Informational);
9302 }*/
9303 newast = mk_stmt(A_TYPEG(ast), 0);
9304 astb.stg_base[newast] = astb.stg_base[ast];
9305
9306 return newast;
9307 }
9308
9309 /* Get the most credible shape (rank and extents) of an AST from the various
9310 * sources of information that exist. Returns the rank, which is also
9311 * the number of leading entries that have been filled in extent_asts[].
9312 */
9313 int
get_ast_extents(int extent_asts[],int from_ast,DTYPE arr_dtype)9314 get_ast_extents(int extent_asts[], int from_ast, DTYPE arr_dtype)
9315 {
9316 int rank = get_ast_rank(from_ast);
9317
9318 if (rank > 0) {
9319 int shape = A_SHAPEG(from_ast);
9320 int asd = A_TYPEG(from_ast) == A_SUBSCR ? A_ASDG(from_ast) : 0;
9321 int dim;
9322
9323 for (dim = 0; dim < rank; ++dim) {
9324 int lb = 0, ub = 0, stride = 0, extent;
9325 if (shape) {
9326 lb = SHD_LWB(shape, dim);
9327 ub = SHD_UPB(shape, dim);
9328 stride = SHD_STRIDE(shape, dim);
9329 }
9330 if (!ub && asd) {
9331 int subscript = ASD_SUBS(asd, dim);
9332 if (A_TYPEG(subscript) == A_TRIPLE) {
9333 lb = A_LBDG(subscript);
9334 ub = A_UPBDG(subscript);
9335 stride = A_STRIDEG(subscript);
9336 } else {
9337 int subscr_shape = A_SHAPEG(subscript);
9338 if (subscr_shape > 0)
9339 ub = extent_of_shape(subscr_shape, 0);
9340 }
9341 }
9342 if (!ub && is_array_dtype(arr_dtype))
9343 ub = ADD_UPAST(arr_dtype, dim);
9344 if (!ub)
9345 ub = astb.bnd.one;
9346 if (!lb && is_array_dtype(arr_dtype))
9347 lb = ADD_LWAST(arr_dtype, dim);
9348 if (!lb)
9349 lb = astb.bnd.one;
9350 if (!stride)
9351 stride = astb.bnd.one;
9352
9353 extent = ub;
9354 if (lb != stride) {
9355 extent = mk_binop(OP_SUB, extent, lb, astb.bnd.dtype);
9356 extent = mk_binop(OP_ADD, extent, stride, astb.bnd.dtype);
9357 }
9358 if (stride != astb.bnd.one)
9359 extent = mk_binop(OP_DIV, extent, stride, astb.bnd.dtype);
9360 extent_asts[dim] = extent;
9361 }
9362 }
9363 return rank;
9364 }
9365
9366 /* Get the rank and lower/upper bounds on each dimension from an AST
9367 * and/or an array dtype, if possible. When lower and upper bounds
9368 * cannot all be discerned, or when strides appear, then set the lower
9369 * bounds all to 1 and use extents as the upper bounds.
9370 */
9371 int
get_ast_bounds(int lower_bound_asts[],int upper_bound_asts[],int from_ast,DTYPE arr_dtype)9372 get_ast_bounds(int lower_bound_asts[], int upper_bound_asts[], int from_ast,
9373 DTYPE arr_dtype)
9374 {
9375 int rank = get_ast_rank(from_ast);
9376
9377 if (rank > 0) {
9378 int shape = A_SHAPEG(from_ast);
9379 int asd = A_TYPEG(from_ast) == A_SUBSCR ? A_ASDG(from_ast) : 0;
9380 int dim = 0;
9381
9382 for (dim = 0; dim < rank; ++dim) {
9383 int lb = 0, ub = 0;
9384 if (asd) {
9385 int subscript = ASD_SUBS(asd, dim);
9386 if (subscript > 0) {
9387 if (A_TYPEG(subscript) == A_TRIPLE ||
9388 A_SHAPEG(subscript) > 0 /* vector-valued subscript */) {
9389 break;
9390 }
9391 }
9392 }
9393 if (shape) {
9394 int stride = SHD_STRIDE(shape, dim);
9395 if (stride > 0 && stride != astb.bnd.one) {
9396 break;
9397 }
9398 lb = SHD_LWB(shape, dim);
9399 ub = SHD_UPB(shape, dim);
9400 }
9401 if (is_array_dtype(arr_dtype)) {
9402 if (!ub) {
9403 ub = ADD_UPAST(arr_dtype, dim);
9404 }
9405 if (!lb) {
9406 lb = ADD_LWAST(arr_dtype, dim);
9407 }
9408 }
9409
9410 if (lb > 0 && ub > 0) {
9411 lower_bound_asts[dim] = lb;
9412 upper_bound_asts[dim] = ub;
9413 } else {
9414 break;
9415 }
9416 }
9417
9418 if (dim < rank) {
9419 /* Could not get good lower and upper bounds on all dimensions,
9420 * or there's a subscript triplet or vector-valued subscript.
9421 * Set the lower bounds all to 1, then try to extract extents
9422 * for use as the upper bounds.
9423 */
9424 for (dim = 0; dim < rank; ++dim) {
9425 lower_bound_asts[dim] = astb.bnd.one;
9426 }
9427 return get_ast_extents(upper_bound_asts, from_ast, arr_dtype);
9428 }
9429 }
9430 return rank;
9431 }
9432
9433 int
add_extent_subscripts(int to_ast,int rank,const int extent_asts[],DTYPE elt_dtype)9434 add_extent_subscripts(int to_ast, int rank, const int extent_asts[],
9435 DTYPE elt_dtype)
9436 {
9437 if (rank > 0) {
9438 int j, triple_asts[MAXRANK];
9439 for (j = 0; j < rank; ++j) {
9440 triple_asts[j] = mk_triple(astb.bnd.one, extent_asts[j], 0);
9441 }
9442 to_ast = mk_subscr(to_ast, triple_asts, rank, elt_dtype);
9443 }
9444 return to_ast;
9445 }
9446
9447 int
add_bounds_subscripts(int to_ast,int rank,const int lower_bound_asts[],const int upper_bound_asts[],DTYPE elt_dtype)9448 add_bounds_subscripts(int to_ast, int rank, const int lower_bound_asts[],
9449 const int upper_bound_asts[], DTYPE elt_dtype)
9450 {
9451 if (rank > 0) {
9452 int j, triple_asts[MAXRANK];
9453 for (j = 0; j < rank; ++j) {
9454 triple_asts[j] = mk_triple(lower_bound_asts[j], upper_bound_asts[j], 0);
9455 }
9456 to_ast = mk_subscr(to_ast, triple_asts, rank, elt_dtype);
9457 }
9458 return to_ast;
9459 }
9460
9461 /* Add subscript triples to an array-valued AST that span a shape
9462 * taken from another AST.
9463 */
9464 int
add_shapely_subscripts(int to_ast,int from_ast,DTYPE arr_dtype,DTYPE elt_dtype)9465 add_shapely_subscripts(int to_ast, int from_ast, DTYPE arr_dtype,
9466 DTYPE elt_dtype)
9467 {
9468 int extent_asts[MAXRANK];
9469 int rank = get_ast_extents(extent_asts, from_ast, arr_dtype);
9470 return add_extent_subscripts(to_ast, rank, extent_asts, elt_dtype);
9471 }
9472