1 /*
2 * Copyright (c) 1994-2019, NVIDIA CORPORATION. All rights reserved.
3 *
4 * Licensed under the Apache License, Version 2.0 (the "License");
5 * you may not use this file except in compliance with the License.
6 * You may obtain a copy of the License at
7 *
8 * http://www.apache.org/licenses/LICENSE-2.0
9 *
10 * Unless required by applicable law or agreed to in writing, software
11 * distributed under the License is distributed on an "AS IS" BASIS,
12 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13 * See the License for the specific language governing permissions and
14 * limitations under the License.
15 *
16 */
17
18 /** \file
19 \brief Fortran symbol utilities.
20 */
21
22 #include "gbldefs.h"
23 #include "global.h"
24 #include "error.h"
25 #include "symtab.h"
26 #include "symfun.h"
27 #include "symutl.h"
28 #include "dtypeutl.h"
29 #include "soc.h"
30 #include "ast.h"
31 #include "gramtk.h"
32 #include "comm.h"
33 #include "extern.h"
34 #include "hpfutl.h"
35 #include "rte.h"
36 #include "semant.h"
37
38 #define CONTIGUOUS_ARR(sptr) (ALLOCG(sptr) || CONTIGATTRG(sptr))
39 static int find_alloc_size(int ast, int foralllist, int *allocss,
40 int *allocdtype, int *allocdim);
41 static int do_check_member_id(int astmem, int astid);
42
43 SYMUTL symutl;
44
45 static int symutl_sc = SC_LOCAL; /* should symutl.sc be used instead?? */
46
47 void
set_symutl_sc(int sc)48 set_symutl_sc(int sc)
49 {
50 symutl_sc = sc;
51 symutl.sc = sc;
52 }
53
54 int
get_next_sym(char * basename,char * purpose)55 get_next_sym(char *basename, char *purpose)
56 {
57 int sptr;
58 char *p;
59
60 p = mangle_name(basename, purpose);
61 sptr = getsymbol(p);
62 HCCSYMP(sptr, 1);
63 HIDDENP(sptr, 1); /* can't see this, if in the parser */
64 SCOPEP(sptr, stb.curr_scope);
65 if (gbl.internal > 1)
66 INTERNALP(sptr, 1);
67 return sptr;
68 }
69
70 int
get_next_sym_dt(char * basename,char * purpose,int encldtype)71 get_next_sym_dt(char *basename, char *purpose, int encldtype)
72 {
73 int sptr;
74 char *p;
75
76 p = mangle_name_dt(basename, purpose, encldtype);
77 sptr = getsymbol(p);
78 HCCSYMP(sptr, 1);
79 HIDDENP(sptr, 1); /* can't see this, if in the parser */
80 SCOPEP(sptr, stb.curr_scope);
81 if (gbl.internal > 1)
82 INTERNALP(sptr, 1);
83 return sptr;
84 }
85
86 /* rename to get_ast_of_deferlen? */
87 int
get_len_of_deferchar_ast(int ast)88 get_len_of_deferchar_ast(int ast)
89 {
90 int sdsc, sdsc_ast;
91 int sdscofmem_ast;
92 int first;
93 int subs[1];
94
95 /* Need to add a check for subscript type */
96 first = first_element(ast);
97 if (A_TYPEG(first) == A_SUBSCR) {
98 first = A_LOPG(first);
99 }
100 if (A_TYPEG(first) != A_MEM) {
101 sdsc = SDSCG(A_SPTRG(first));
102 assert(sdsc != 0, "Deferred-length character symbol must have descriptor",
103 A_SPTRG(ast), 0);
104 return get_byte_len(sdsc);
105 }
106
107 /* this can be done partly by calling check_member() */
108 sdsc = SDSCG(A_SPTRG(A_MEMG(first)));
109 sdsc_ast = mk_id(sdsc);
110 sdscofmem_ast = mk_member(A_PARENTG(first), sdsc_ast, A_DTYPEG(sdsc_ast));
111
112 subs[0] = mk_isz_cval(get_byte_len_indx(), astb.bnd.dtype);
113 return mk_subscr(sdscofmem_ast, subs, 1, astb.bnd.dtype);
114 }
115
116 /** \brief Get the sptr of a specific name & SYMTYPE in the hash list
117 \param stype the SYMTYPE
118 \param first where to start the search (also establishes the name )
119 */
120 SPTR
get_symtype(SYMTYPE stype,SPTR first)121 get_symtype(SYMTYPE stype, SPTR first)
122 {
123 SPTR sptr;
124 for (sptr = first; sptr > NOSYM; sptr = HASHLKG(sptr)) {
125 if (NMPTRG(sptr) != NMPTRG(first))
126 continue;
127 if (STYPEG(sptr) == stype)
128 return sptr;
129 }
130 return 0;
131 }
132
133 int
sym_get_scalar(char * basename,char * purpose,int dtype)134 sym_get_scalar(char *basename, char *purpose, int dtype)
135 {
136 int sptr;
137
138 sptr = get_next_sym(basename, purpose);
139 DTYPEP(sptr, dtype);
140 STYPEP(sptr, ST_VAR);
141 DCLDP(sptr, 1);
142 SCP(sptr, symutl.sc);
143 NODESCP(sptr, 1);
144 SCOPEP(sptr, stb.curr_scope);
145 return sptr;
146 }
147
148 int
sym_get_ptr(int base)149 sym_get_ptr(int base)
150 {
151 int sptr;
152 char *basename;
153
154 basename = SYMNAME(base);
155 if (STYPEG(base) == ST_MEMBER) {
156 sptr = get_next_sym_dt(basename, "p", ENCLDTYPEG(base));
157 } else {
158 sptr = get_next_sym(basename, "p");
159 }
160 DTYPEP(sptr, DT_PTR);
161 STYPEP(sptr, ST_VAR);
162 SCP(sptr, symutl_sc);
163 NODESCP(sptr, 1);
164 PTRVP(sptr, 1);
165 return sptr;
166 }
167
168 int
sym_get_ptr_name(char * basename)169 sym_get_ptr_name(char *basename)
170 {
171 int sptr;
172
173 sptr = get_next_sym(basename, "p");
174 DTYPEP(sptr, DT_PTR);
175 STYPEP(sptr, ST_VAR);
176 SCP(sptr, symutl_sc);
177 NODESCP(sptr, 1);
178 PTRVP(sptr, 1);
179 return sptr;
180 }
181
182 int
sym_get_offset(int base)183 sym_get_offset(int base)
184 {
185 int sptr;
186 char *basename;
187
188 basename = SYMNAME(base);
189 if (STYPEG(base) == ST_MEMBER) {
190 sptr = get_next_sym_dt(basename, "o", ENCLDTYPEG(base));
191 } else {
192 sptr = get_next_sym(basename, "o");
193 }
194 DTYPEP(sptr, DT_PTR);
195 STYPEP(sptr, ST_VAR);
196 SCP(sptr, symutl_sc);
197 NODESCP(sptr, 1);
198 return sptr;
199 }
200
201 /** \brief Make a temporary array, not deferred shape. Bounds need to be
202 filled in later.
203 */
204 int
sym_get_array(char * basename,char * purpose,int dtype,int ndim)205 sym_get_array(char *basename, char *purpose, int dtype, int ndim)
206 {
207 int sptr;
208 ADSC *ad;
209 int i;
210
211 sptr = get_next_sym(basename, purpose);
212 dtype = get_array_dtype(ndim, dtype);
213 ALLOCP(sptr, 1);
214 ad = AD_DPTR(dtype);
215 AD_NOBOUNDS(ad) = 1;
216 for (i = 0; i < ndim; ++i) {
217 AD_LWAST(ad, i) = AD_UPAST(ad, i) = 0;
218 AD_LWBD(ad, i) = AD_UPBD(ad, i) = 0;
219 AD_EXTNTAST(ad, i) = 0;
220 }
221 DTYPEP(sptr, dtype);
222 STYPEP(sptr, ST_ARRAY);
223 DCLDP(sptr, 1);
224 SCP(sptr, symutl_sc);
225 return sptr;
226 }
227
228 /** \brief Create a function ST item given a name */
229 int
sym_mkfunc(char * nmptr,int dtype)230 sym_mkfunc(char *nmptr, int dtype)
231 {
232 register int sptr;
233
234 sptr = getsymbol(nmptr);
235 STYPEP(sptr, ST_PROC);
236 DTYPEP(sptr, dtype);
237 if (dtype != DT_NONE) {
238 DCLDP(sptr, 1);
239 FUNCP(sptr, 1);
240 if (XBIT(57, 0x2000))
241 TYPDP(sptr, 1);
242 }
243 SCP(sptr, SC_EXTERN);
244 SCOPEP(sptr, 0);
245 HCCSYMP(sptr, 1);
246 /*NODESCP(sptr,1);*/
247 return sptr;
248 }
249
250 /** \brief Create a function ST item given a name; set its NODESC flag */
251 int
sym_mkfunc_nodesc(char * nmptr,int dtype)252 sym_mkfunc_nodesc(char *nmptr, int dtype)
253 {
254 register int sptr;
255
256 sptr = sym_mkfunc(nmptr, dtype);
257 NODESCP(sptr, 1);
258 PUREP(sptr, 1);
259 return sptr;
260 }
261
262 /** \brief Create a function ST item given a name; set its NODESC and EXPST
263 flag.
264
265 Could replace EXPST with a new flag. If the flag is set
266 we still need transform_call() to fix arguments which are
267 array sections.
268 */
269 int
sym_mkfunc_nodesc_expst(char * nmptr,int dtype)270 sym_mkfunc_nodesc_expst(char *nmptr, int dtype)
271 {
272 register int sptr;
273
274 sptr = sym_mkfunc_nodesc(nmptr, dtype);
275 EXPSTP(sptr, 1);
276 return sptr;
277 }
278
279 /** \brief Create a function ST item given a name; set its NODESC and NOCOMM
280 * flag */
281 int
sym_mkfunc_nodesc_nocomm(char * nmptr,int dtype)282 sym_mkfunc_nodesc_nocomm(char *nmptr, int dtype)
283 {
284 register int sptr;
285
286 sptr = sym_mkfunc(nmptr, dtype);
287 NODESCP(sptr, 1);
288 NOCOMMP(sptr, 1);
289 PUREP(sptr, 1);
290 return sptr;
291 }
292
293 int
sym_mknproc(void)294 sym_mknproc(void)
295 {
296 STYPEP(gbl.sym_nproc, ST_VAR);
297 return gbl.sym_nproc;
298 }
299
300 /* This create descriptor and section descriptor
301 for each user defined array */
302
303 void
trans_mkdescr(int sptr)304 trans_mkdescr(int sptr)
305 {
306 int descr;
307 int sec;
308 char *p;
309
310 if (DESCRG(sptr) != 0)
311 return;
312 /* save the basename in case it is a SYMNAME (might be realloc'd) */
313 p = sym_strsave(SYMNAME(sptr));
314 descr = get_next_sym(p, "arrdsc");
315 STYPEP(descr, ST_ARRDSC);
316 /*
317 * 2nd try for f15624 - use the storage class field of the arrdsc so
318 * that the SC_PRIVATE of arrdsc is propagated to the actual descriptor.
319 */
320 SCP(descr, symutl_sc);
321 ARRAYP(descr, sptr);
322 ALNDP(descr, 0);
323 SECDP(descr, 0);
324 SECDSCP(descr, 0);
325 DESCRP(sptr, descr);
326 NODESCP(sptr, 0);
327 if (XBIT(57, 0x10000) && SCG(sptr) == SC_DUMMY && NEWDSCG(sptr)) {
328 SECDSCP(descr, NEWDSCG(sptr));
329 }
330 FREE(p);
331 }
332
333 /** \brief Create a section descriptor */
334 int
sym_get_sec(char * basename,int is_dummy)335 sym_get_sec(char *basename, int is_dummy)
336 {
337 int sec, sec_ptr;
338 int i;
339 ADSC *ad;
340 int dtype;
341 char *p;
342
343 /* save the basename in case it is a SYMNAME (might be realloc'd) */
344 p = sym_strsave(basename);
345 sec = get_next_sym(p, "s");
346 if (!is_dummy)
347 sec_ptr = get_next_sym(p, "sp");
348 FREE(p);
349
350 /* make sec be array(1) */
351 STYPEP(sec, ST_ARRAY);
352 dtype = aux.dt_iarray_int;
353 ad = AD_DPTR(dtype);
354 AD_LWAST(ad, 0) = 0;
355 AD_UPBD(ad, 0) = AD_UPAST(ad, 0) = mk_isz_cval(1, astb.bnd.dtype);
356 AD_EXTNTAST(ad, 0) = mk_isz_cval(1, astb.bnd.dtype);
357 DTYPEP(sec, dtype);
358 DCLDP(sec, 1);
359
360 /* array section for dummy doesn't have a pointer */
361 if (!is_dummy) {
362 SCP(sec, SC_BASED);
363 /* make the pointer point to sec */
364 STYPEP(sec_ptr, ST_VAR);
365 DTYPEP(sec_ptr, DT_PTR);
366 SCP(sec_ptr, symutl_sc);
367 MIDNUMP(sec, sec_ptr);
368 } else
369 SCP(sec, SC_DUMMY);
370
371 NODESCP(sec, 1);
372 return sec;
373 }
374
375 /** \brief Create a channel pointer (cp) */
376 int
sym_get_cp(void)377 sym_get_cp(void)
378 {
379 int cp_ptr;
380
381 /* save the basename in case it is a SYMNAME (might be realloc'd) */
382 cp_ptr = trans_getbound(0, 11);
383
384 /* make the pointer point to cp */
385 STYPEP(cp_ptr, ST_VAR);
386 DTYPEP(cp_ptr, DT_ADDR);
387 SCP(cp_ptr, SC_LOCAL);
388 DCLDP(cp_ptr, 1);
389 return cp_ptr;
390 }
391
392 /** \brief Create a channel pointer (xfer) */
393 int
sym_get_xfer(void)394 sym_get_xfer(void)
395 {
396 int xfer_ptr;
397
398 xfer_ptr = trans_getbound(0, 12);
399 STYPEP(xfer_ptr, ST_VAR);
400 DTYPEP(xfer_ptr, DT_ADDR);
401 SCP(xfer_ptr, SC_LOCAL);
402 DCLDP(xfer_ptr, 1);
403 return xfer_ptr;
404 }
405
406 /** \brief Create a section descriptor for a dummy argument */
407 int
sym_get_arg_sec(int sptr)408 sym_get_arg_sec(int sptr)
409 {
410 int sec;
411 int i;
412 ADSC *ad;
413 int dtype;
414 char *p;
415 char *basename;
416 int descr;
417 int sdsc;
418
419 if (XBIT(57, 0x10000)) {
420 sdsc = sym_get_sdescr(sptr, -1);
421 /* sym_get_sdescr will return existing descriptor but we don't want that if
422 * this is
423 * an interface. It is possible that the current routine has same name
424 * descriptor
425 * due to use associate.
426 */
427 if (SCOPEG(sptr)) {
428 int scope = SCOPEG(sptr);
429 if (STYPEG(scope) == ST_ALIAS)
430 scope = SYMLKG(scope);
431 if (SCG(scope) == SC_EXTERN && STYPEG(scope) == ST_PROC) {
432 sdsc = get_next_sym(SYMNAME(sptr), "sd");
433 }
434 }
435 SCP(sdsc, SC_DUMMY);
436 HCCSYMP(sdsc, 1);
437 return sdsc;
438 }
439
440 basename = SYMNAME(sptr);
441 /* save the basename in case it is a SYMNAME (might be realloc'd) */
442 p = sym_strsave(basename);
443 sec = get_next_sym(p, "s0");
444 FREE(p);
445
446 dtype = DDTG(DTYPEG(sptr));
447
448 if ((STYPEG(sptr) != ST_ARRAY || DTY(dtype) == TY_CHAR ||
449 DTY(dtype) == TY_NCHAR) &&
450 !POINTERG(sptr)) {
451 /* make sec be integer scalar */
452 DTYPEP(sec, DT_INT);
453 STYPEP(sec, ST_VAR);
454 } else {
455 /* make sec be array(1) */
456 STYPEP(sec, ST_ARRAY);
457 dtype = aux.dt_iarray_int;
458 ad = AD_DPTR(dtype);
459 AD_LWAST(ad, 0) = 0;
460 AD_UPBD(ad, 0) = AD_UPAST(ad, 0) = mk_isz_cval(1, astb.bnd.dtype);
461 AD_EXTNTAST(ad, 0) = mk_isz_cval(1, astb.bnd.dtype);
462 DTYPEP(sec, dtype);
463 }
464
465 DCLDP(sec, 1);
466 SCP(sec, SC_DUMMY);
467 HCCSYMP(sec, 1);
468
469 NODESCP(sec, 1);
470 return sec;
471 }
472
473 /** \brief Get a symbol for the base address of the formal argument */
474 int
sym_get_formal(int basevar)475 sym_get_formal(int basevar)
476 {
477 int formal;
478 int i;
479 int dtype;
480 char *p;
481 char *basename;
482
483 basename = SYMNAME(basevar);
484 formal = get_next_sym(basename, "bs");
485
486 dtype = DTYPEG(basevar);
487 if (DTY(dtype) != TY_ARRAY) {
488 /* declare as pointer to the datatype */
489 STYPEP(formal, ST_VAR);
490 DTYPEP(formal, dtype);
491 /*POINTERP( formal, 1 );*/
492 } else {
493 /* make sec be array(1) */
494 STYPEP(formal, ST_ARRAY);
495 dtype = DDTG(dtype);
496 dtype = get_array_dtype(1, dtype);
497 ADD_LWBD(dtype, 0) = 0;
498 ADD_LWAST(dtype, 0) = ADD_NUMELM(dtype) = ADD_UPBD(dtype, 0) =
499 ADD_UPAST(dtype, 0) = ADD_EXTNTAST(dtype, 0) =
500 mk_isz_cval(1, astb.bnd.dtype);
501 DTYPEP(formal, dtype);
502 }
503 DCLDP(formal, 1);
504 SCP(formal, SC_DUMMY);
505 HCCSYMP(formal, 1);
506 OPTARGP(formal, OPTARGG(basevar));
507 INTENTP(formal, INTENTG(basevar));
508 return formal;
509 }
510
511 /*-------------------------------------------------------------------------*/
512
513 /** \brief Return TRUE if the ast (triplet or shape stride)
514 has a constant value, and return its constant value
515 */
516 int
constant_stride(int a,int * value)517 constant_stride(int a, int *value)
518 {
519 int sptr;
520 /* ast of zero is treated as constant one */
521 if (a == 0) {
522 *value = 1;
523 return TRUE;
524 }
525 if (A_TYPEG(a) != A_CNST)
526 return FALSE;
527 sptr = A_SPTRG(a);
528 if (!DT_ISINT(DTYPEG(sptr)))
529 return FALSE;
530 if ((CONVAL1G(sptr) == 0 && CONVAL2G(sptr) >= 0) ||
531 (CONVAL1G(sptr) == -1 && CONVAL2G(sptr) < 0)) {
532 *value = CONVAL2G(sptr);
533 return TRUE;
534 }
535 return FALSE;
536 } /* constant_stride */
537
538 /* Temporary allocation */
539 /* subscripts (triples) for temp */
540 int
mk_forall_sptr(int forall_ast,int subscr_ast,int * subscr,int elem_dty)541 mk_forall_sptr(int forall_ast, int subscr_ast, int *subscr, int elem_dty)
542 {
543 int astli;
544 int submap[MAXSUBS], arr_sptr, memberast;
545 int i, ndims, lwbnd[MAXSUBS], upbnd[MAXSUBS];
546 int sptr, sdtype;
547 int single[] = {0, 0, 0, 0, 0, 0, 0};
548
549 assert(A_TYPEG(forall_ast) == A_FORALL, "mk_forall_sptr: ast not forall",
550 forall_ast, 4);
551 /* get the forall index list */
552 astli = A_LISTG(forall_ast);
553
554 ndims = 0;
555 do {
556 if (A_TYPEG(subscr_ast) == A_MEM) {
557 subscr_ast = A_PARENTG(subscr_ast);
558 } else if (A_TYPEG(subscr_ast) == A_SUBSCR) {
559 int lop, dtype;
560 int asd, n, i;
561 for (i = 0; i < ndims; ++i)
562 submap[i] = -1;
563 memberast = 0;
564 lop = A_LOPG(subscr_ast);
565 if (A_TYPEG(lop) == A_MEM) {
566 memberast = lop;
567 arr_sptr = A_SPTRG(A_MEMG(memberast));
568 } else if (A_TYPEG(lop) == A_ID) {
569 arr_sptr = A_SPTRG(lop);
570 } else {
571 interr("mk_forall_sptr: subscript has no member/id", subscr_ast, 3);
572 }
573 dtype = DTYPEG(arr_sptr);
574 /* determine how many dimensions are needed, and which ones they are */
575 asd = A_ASDG(subscr_ast);
576 n = ASD_NDIM(asd);
577 for (i = 0; i < n; ++i) {
578 /* need to include the dimension if it is vector as well */
579 int k, ast, allocss, allocdtype, allocdim, c, stride, lw, up;
580 allocss = 0;
581 allocdtype = 0;
582 allocdim = 0;
583 ast = ASD_SUBS(asd, i);
584 if (ASUMSZG(arr_sptr) || XBIT(58, 0x20000)) {
585 if (A_TYPEG(ast) == A_TRIPLE) {
586 assert(ndims < MAXDIMS, "temporary has too many dimensions",
587 ndims, 4);
588 lw = check_member(memberast, A_LBDG(ast));
589 up = check_member(memberast, A_UPBDG(ast));
590 c = constant_stride(A_STRIDEG(ast), &stride);
591 if (flg.opt >= 2 && !XBIT(2, 0x400000)) {
592 lwbnd[ndims] = astb.i1;
593 stride = A_STRIDEG(ast);
594 if (stride == 0)
595 stride = astb.i1;
596 upbnd[ndims] = mk_binop(
597 OP_DIV,
598 mk_binop(OP_ADD, mk_binop(OP_SUB, up, lw, stb.user.dt_int),
599 stride, stb.user.dt_int),
600 stride, stb.user.dt_int);
601 subscr[ndims] = mk_triple(lwbnd[ndims], upbnd[ndims], 0);
602 } else if (c && stride == 1) {
603 lwbnd[ndims] = lw;
604 upbnd[ndims] = up;
605 subscr[ndims] = mk_triple(lw, up, 0);
606 } else if (c && stride == -1) {
607 lwbnd[ndims] = up;
608 upbnd[ndims] = lw;
609 subscr[ndims] = mk_triple(lw, up, 0);
610 } else if (XBIT(58, 0x20000)) {
611 lwbnd[ndims] = astb.i1;
612 stride = A_STRIDEG(ast);
613 if (stride == 0)
614 stride = astb.i1;
615 upbnd[ndims] = mk_binop(
616 OP_DIV,
617 mk_binop(OP_ADD, mk_binop(OP_SUB, up, lw, stb.user.dt_int),
618 stride, stb.user.dt_int),
619 stride, stb.user.dt_int);
620 subscr[ndims] = mk_triple(lwbnd[ndims], upbnd[ndims], 0);
621 } else {
622 lwbnd[ndims] = lw;
623 upbnd[ndims] = up;
624 subscr[ndims] = mk_triple(lw, up, 0);
625 }
626 submap[ndims] = i;
627 ++ndims;
628 } else if (A_SHAPEG(ast)) {
629 int shd;
630 assert(ndims < MAXDIMS, "temporary has too many dimensions",
631 ndims, 4);
632 shd = A_SHAPEG(ast);
633 lw = check_member(memberast, SHD_LWB(shd, i));
634 up = check_member(memberast, SHD_UPB(shd, i));
635 c = constant_stride(SHD_STRIDE(shd, i), &stride);
636 if (c && stride == 1) {
637 lwbnd[ndims] = lw;
638 upbnd[ndims] = up;
639 subscr[ndims] = mk_triple(lw, up, 0);
640 } else if (c && stride == -1) {
641 lwbnd[ndims] = up;
642 upbnd[ndims] = lw;
643 subscr[ndims] = mk_triple(lw, up, A_STRIDEG(ast));
644 } else if (XBIT(58, 0x20000)) {
645 lwbnd[ndims] = astb.bnd.one;
646 stride = SHD_STRIDE(shd, i);
647 if (stride == 0)
648 stride = astb.bnd.one;
649 upbnd[ndims] = mk_binop(
650 OP_DIV,
651 mk_binop(OP_ADD, mk_binop(OP_SUB, up, lw, astb.bnd.dtype),
652 stride, astb.bnd.dtype),
653 stride, astb.bnd.dtype);
654 subscr[ndims] = mk_triple(lwbnd[ndims], upbnd[ndims], 0);
655 } else {
656 lwbnd[ndims] = lw;
657 upbnd[ndims] = up;
658 subscr[ndims] = mk_triple(lw, up, 0);
659 }
660 submap[ndims] = i;
661 ++ndims;
662 } else if ((k = search_forall_var(ast, astli)) != 0) {
663 assert(ndims < MAXDIMS, "temporary has too many dimensions",
664 ndims, 4);
665 /* make sure the bounds don't have other forall indices */
666 lw = A_LBDG(ASTLI_TRIPLE(k));
667 up = A_UPBDG(ASTLI_TRIPLE(k));
668 if (search_forall_var(lw, astli) || search_forall_var(up, astli)) {
669 /* can't use forall indices, they are triangular.
670 * use the bounds of the host array */
671 lwbnd[ndims] = check_member(memberast, ADD_LWAST(dtype, i));
672 upbnd[ndims] = check_member(memberast, ADD_UPAST(dtype, i));
673 subscr[ndims] = mk_triple(lwbnd[ndims], upbnd[ndims], 0);
674 } else if (other_forall_var(ast, astli, k)) {
675 lwbnd[ndims] = check_member(memberast, ADD_LWAST(dtype, i));
676 upbnd[ndims] = check_member(memberast, ADD_UPAST(dtype, i));
677 subscr[ndims] = mk_triple(lwbnd[ndims], upbnd[ndims], 0);
678 } else {
679 c = constant_stride(A_STRIDEG(ASTLI_TRIPLE(k)), &stride);
680 if (flg.opt >= 2 && !XBIT(2, 0x400000)) {
681 lwbnd[ndims] = astb.i1;
682 stride = A_STRIDEG(ASTLI_TRIPLE(k));
683 if (stride == 0)
684 stride = astb.i1;
685 upbnd[ndims] = mk_binop(
686 OP_DIV,
687 mk_binop(OP_ADD, mk_binop(OP_SUB, up, lw, stb.user.dt_int),
688 stride, stb.user.dt_int),
689 stride, stb.user.dt_int);
690 subscr[ndims] = mk_triple(lwbnd[ndims], upbnd[ndims], 0);
691 } else if (c && stride == 1) {
692 lwbnd[ndims] = lw;
693 upbnd[ndims] = up;
694 subscr[ndims] = mk_triple(lw, up, 0);
695 } else if (c && stride == -1) {
696 lwbnd[ndims] = up;
697 upbnd[ndims] = lw;
698 subscr[ndims] = mk_triple(up, lw, 0);
699 } else if (XBIT(58, 0x20000)) {
700 lwbnd[ndims] = astb.i1;
701 stride = A_STRIDEG(ASTLI_TRIPLE(k));
702 if (stride == 0)
703 stride = astb.i1;
704 upbnd[ndims] = mk_binop(
705 OP_DIV,
706 mk_binop(OP_ADD, mk_binop(OP_SUB, up, lw, stb.user.dt_int),
707 stride, stb.user.dt_int),
708 stride, stb.user.dt_int);
709 subscr[ndims] = mk_triple(lwbnd[ndims], upbnd[ndims], 0);
710 } else {
711 lwbnd[ndims] = lw;
712 upbnd[ndims] = up;
713 subscr[ndims] = mk_triple(lw, up, 0);
714 }
715 }
716 submap[ndims] = i;
717 ++ndims;
718 }
719 } else if (A_TYPEG(ast) == A_TRIPLE) {
720 /* include this dimension */
721 /* build a triplet for the allocate statement off of the
722 * dimensions for the array */
723 assert(ndims < MAXDIMS, "temporary has too many dimensions",
724 ndims, 4);
725 lwbnd[ndims] = check_member(memberast, ADD_LWAST(dtype, i));
726 upbnd[ndims] = check_member(memberast, ADD_UPAST(dtype, i));
727 subscr[ndims] = mk_triple(lwbnd[ndims], upbnd[ndims], 0);
728 submap[ndims] = i;
729 ++ndims;
730 } else if (find_alloc_size(ast, astli, &allocss, &allocdtype,
731 &allocdim)) {
732 /* make this dimension the same size as dimension
733 * allocdim of datatype allocdtype for which the subscript
734 * is at allocss */
735 assert(ndims < MAXDIMS, "temporary has too many dimensions",
736 ndims, 4);
737 if (allocdtype == 0) {
738 allocdtype = dtype;
739 allocdim = i;
740 allocss = memberast;
741 }
742 lwbnd[ndims] = check_member(allocss, ADD_LWAST(allocdtype, allocdim));
743 upbnd[ndims] = check_member(allocss, ADD_UPAST(allocdtype, allocdim));
744 subscr[ndims] = mk_triple(lwbnd[ndims], upbnd[ndims], 0);
745 submap[ndims] = i;
746 ++ndims;
747 } else if (A_SHAPEG(ast) || search_forall_var(ast, astli)) {
748 /* include this dimension */
749 /* build a triplet for the allocate statement off of the
750 * dimensions for the array */
751 assert(ndims < MAXDIMS, "temporary has too many dimensions",
752 ndims, 4);
753 lwbnd[ndims] = check_member(memberast, ADD_LWAST(dtype, i));
754 upbnd[ndims] = check_member(memberast, ADD_UPAST(dtype, i));
755 subscr[ndims] = mk_triple(lwbnd[ndims], upbnd[ndims], 0);
756 submap[ndims] = i;
757 ++ndims;
758 }
759 }
760 subscr_ast = A_LOPG(subscr_ast);
761 } else {
762 interr("mk_forall_sptr: not member or subscript", subscr_ast, 3);
763 }
764 } while (A_TYPEG(subscr_ast) != A_ID);
765
766 /* get the temporary */
767 assert(ndims > 0, "mk_forall_sptr: not enough dimensions", ndims, 4);
768 sptr = sym_get_array(SYMNAME(arr_sptr), "f", elem_dty, ndims);
769 /* set the bounds to the correct bounds from the array */
770 sdtype = DTYPEG(sptr);
771 if (flg.opt >= 2 && !XBIT(2, 0x400000)) {
772 for (i = 0; i < ndims; ++i) {
773 ADD_LWBD(sdtype, i) = ADD_LWAST(sdtype, i) = astb.bnd.one;
774 ADD_UPBD(sdtype, i) = ADD_UPAST(sdtype, i) =
775 mk_binop(OP_ADD, mk_binop(OP_SUB, upbnd[i], lwbnd[i], astb.bnd.dtype),
776 astb.bnd.one, astb.bnd.dtype);
777 ADD_EXTNTAST(sdtype, i) =
778 mk_extent(ADD_LWAST(sdtype, i), ADD_UPAST(sdtype, i), i);
779 }
780 } else {
781 for (i = 0; i < ndims; ++i) {
782 ADD_LWBD(sdtype, i) = ADD_LWAST(sdtype, i) = lwbnd[i];
783 ADD_UPBD(sdtype, i) = ADD_UPAST(sdtype, i) = upbnd[i];
784 ADD_EXTNTAST(sdtype, i) =
785 mk_extent(ADD_LWAST(sdtype, i), ADD_UPAST(sdtype, i), i);
786 }
787 }
788
789 /* make the descriptors for the temporary */
790 trans_mkdescr(sptr);
791
792 /* mark as compiler created */
793 HCCSYMP(sptr, 1);
794
795 return sptr;
796 }
797
798 /* get the subscript forall sptr, reuse temporary */
799 /* subscripts (triples) for temp */
800 int
get_forall_subscr(int forall_ast,int subscr_ast,int * subscr,int elem_dty)801 get_forall_subscr(int forall_ast, int subscr_ast, int *subscr, int elem_dty)
802 {
803 int astli;
804 int submap[MAXSUBS], arr_sptr, memberast;
805 int i, ndims, lwbnd[MAXSUBS], upbnd[MAXSUBS];
806 int sptr, sdtype;
807 int single[] = {0, 0, 0, 0, 0, 0, 0};
808
809 assert(A_TYPEG(forall_ast) == A_FORALL, "get_forall_subscr: ast not forall",
810 forall_ast, 4);
811 /* get the forall index list */
812 astli = A_LISTG(forall_ast);
813
814 ndims = 0;
815 do {
816 if (A_TYPEG(subscr_ast) == A_MEM) {
817 subscr_ast = A_PARENTG(subscr_ast);
818 } else if (A_TYPEG(subscr_ast) == A_SUBSCR) {
819 int lop, dtype;
820 int asd, n, i;
821 for (i = 0; i < ndims; ++i)
822 submap[i] = -1;
823 memberast = 0;
824 lop = A_LOPG(subscr_ast);
825 if (A_TYPEG(lop) == A_MEM) {
826 memberast = lop;
827 arr_sptr = A_SPTRG(A_MEMG(memberast));
828 } else if (A_TYPEG(lop) == A_ID) {
829 arr_sptr = A_SPTRG(lop);
830 } else {
831 interr("get_forall_subscr: subscript has no member/id", subscr_ast, 3);
832 }
833 dtype = DTYPEG(arr_sptr);
834 /* determine how many dimensions are needed, and which ones they are */
835 asd = A_ASDG(subscr_ast);
836 n = ASD_NDIM(asd);
837 for (i = 0; i < n; ++i) {
838 /* need to include the dimension if it is vector as well */
839 int k, ast, allocss, allocdtype, allocdim, c, stride, lw, up;
840 allocss = 0;
841 allocdtype = 0;
842 allocdim = 0;
843 ast = ASD_SUBS(asd, i);
844 if (ASUMSZG(arr_sptr) || XBIT(58, 0x20000)) {
845 if (A_TYPEG(ast) == A_TRIPLE) {
846 assert(ndims < MAXDIMS, "temporary has too many dimensions",
847 ndims, 4);
848 lw = check_member(memberast, A_LBDG(ast));
849 up = check_member(memberast, A_UPBDG(ast));
850 c = constant_stride(A_STRIDEG(ast), &stride);
851 if (flg.opt >= 2 && !XBIT(2, 0x400000)) {
852 lwbnd[ndims] = astb.i1;
853 stride = A_STRIDEG(ast);
854 if (stride == 0)
855 stride = astb.i1;
856 upbnd[ndims] = mk_binop(
857 OP_DIV,
858 mk_binop(OP_ADD, mk_binop(OP_SUB, up, lw, stb.user.dt_int),
859 stride, stb.user.dt_int),
860 stride, stb.user.dt_int);
861 subscr[ndims] = mk_triple(lwbnd[ndims], upbnd[ndims], 0);
862 } else if (c && stride == 1) {
863 lwbnd[ndims] = lw;
864 upbnd[ndims] = up;
865 subscr[ndims] = mk_triple(lw, up, 0);
866 } else if (c && stride == -1) {
867 lwbnd[ndims] = up;
868 upbnd[ndims] = lw;
869 subscr[ndims] = mk_triple(lw, up, 0);
870 } else if (XBIT(58, 0x20000)) {
871 lwbnd[ndims] = astb.i1;
872 stride = A_STRIDEG(ast);
873 if (stride == 0)
874 stride = astb.i1;
875 upbnd[ndims] = mk_binop(
876 OP_DIV,
877 mk_binop(OP_ADD, mk_binop(OP_SUB, up, lw, stb.user.dt_int),
878 stride, stb.user.dt_int),
879 stride, stb.user.dt_int);
880 subscr[ndims] = mk_triple(lwbnd[ndims], upbnd[ndims], 0);
881 } else {
882 lwbnd[ndims] = lw;
883 upbnd[ndims] = up;
884 subscr[ndims] = mk_triple(lw, up, 0);
885 }
886 submap[ndims] = i;
887 ++ndims;
888 } else if (A_SHAPEG(ast)) {
889 int shd;
890 assert(ndims < MAXDIMS, "temporary has too many dimensions",
891 ndims, 4);
892 shd = A_SHAPEG(ast);
893 lw = check_member(memberast, SHD_LWB(shd, i));
894 up = check_member(memberast, SHD_UPB(shd, i));
895 c = constant_stride(SHD_STRIDE(shd, i), &stride);
896 if (c && stride == 1) {
897 lwbnd[ndims] = lw;
898 upbnd[ndims] = up;
899 subscr[ndims] = mk_triple(lw, up, 0);
900 } else if (c && stride == -1) {
901 lwbnd[ndims] = up;
902 upbnd[ndims] = lw;
903 subscr[ndims] = mk_triple(lw, up, A_STRIDEG(ast));
904 } else if (XBIT(58, 0x20000)) {
905 lwbnd[ndims] = astb.bnd.one;
906 stride = SHD_STRIDE(shd, i);
907 if (stride == 0)
908 stride = astb.bnd.one;
909 upbnd[ndims] = mk_binop(
910 OP_DIV,
911 mk_binop(OP_ADD, mk_binop(OP_SUB, up, lw, astb.bnd.dtype),
912 stride, astb.bnd.dtype),
913 stride, astb.bnd.dtype);
914 subscr[ndims] = mk_triple(lwbnd[ndims], upbnd[ndims], 0);
915 } else {
916 lwbnd[ndims] = lw;
917 upbnd[ndims] = up;
918 subscr[ndims] = mk_triple(lw, up, 0);
919 }
920 submap[ndims] = i;
921 ++ndims;
922 } else if ((k = search_forall_var(ast, astli)) != 0) {
923 assert(ndims < MAXDIMS, "temporary has too many dimensions",
924 ndims, 4);
925 /* make sure the bounds don't have other forall indices */
926 lw = A_LBDG(ASTLI_TRIPLE(k));
927 up = A_UPBDG(ASTLI_TRIPLE(k));
928 if (search_forall_var(lw, astli) || search_forall_var(up, astli)) {
929 /* can't use forall indices, they are triangular.
930 * use the bounds of the host array */
931 lwbnd[ndims] = check_member(memberast, ADD_LWAST(dtype, i));
932 upbnd[ndims] = check_member(memberast, ADD_UPAST(dtype, i));
933 subscr[ndims] = mk_triple(lwbnd[ndims], upbnd[ndims], 0);
934 } else if (other_forall_var(ast, astli, k)) {
935 lwbnd[ndims] = check_member(memberast, ADD_LWAST(dtype, i));
936 upbnd[ndims] = check_member(memberast, ADD_UPAST(dtype, i));
937 subscr[ndims] = mk_triple(lwbnd[ndims], upbnd[ndims], 0);
938 } else {
939 c = constant_stride(A_STRIDEG(ASTLI_TRIPLE(k)), &stride);
940 if (flg.opt >= 2 && !XBIT(2, 0x400000)) {
941 lwbnd[ndims] = astb.i1;
942 stride = A_STRIDEG(ASTLI_TRIPLE(k));
943 if (stride == 0)
944 stride = astb.i1;
945 upbnd[ndims] = mk_binop(
946 OP_DIV,
947 mk_binop(OP_ADD, mk_binop(OP_SUB, up, lw, stb.user.dt_int),
948 stride, stb.user.dt_int),
949 stride, stb.user.dt_int);
950 subscr[ndims] = mk_triple(lwbnd[ndims], upbnd[ndims], 0);
951 } else if (c && stride == 1) {
952 lwbnd[ndims] = lw;
953 upbnd[ndims] = up;
954 subscr[ndims] = mk_triple(lw, up, 0);
955 } else if (c && stride == -1) {
956 lwbnd[ndims] = up;
957 upbnd[ndims] = lw;
958 subscr[ndims] = mk_triple(up, lw, 0);
959 } else if (XBIT(58, 0x20000)) {
960 lwbnd[ndims] = astb.i1;
961 stride = A_STRIDEG(ASTLI_TRIPLE(k));
962 if (stride == 0)
963 stride = astb.i1;
964 upbnd[ndims] = mk_binop(
965 OP_DIV,
966 mk_binop(OP_ADD, mk_binop(OP_SUB, up, lw, stb.user.dt_int),
967 stride, stb.user.dt_int),
968 stride, stb.user.dt_int);
969 subscr[ndims] = mk_triple(lwbnd[ndims], upbnd[ndims], 0);
970 } else {
971 lwbnd[ndims] = lw;
972 upbnd[ndims] = up;
973 subscr[ndims] = mk_triple(lw, up, 0);
974 }
975 }
976 submap[ndims] = i;
977 ++ndims;
978 }
979 } else if (A_TYPEG(ast) == A_TRIPLE) {
980 /* include this dimension */
981 /* build a triplet for the allocate statement off of the
982 * dimensions for the array */
983 assert(ndims < MAXDIMS, "temporary has >MAXDIMS dimensions",
984 ndims, 4);
985 lwbnd[ndims] = check_member(memberast, ADD_LWAST(dtype, i));
986 upbnd[ndims] = check_member(memberast, ADD_UPAST(dtype, i));
987 subscr[ndims] = mk_triple(lwbnd[ndims], upbnd[ndims], 0);
988 submap[ndims] = i;
989 ++ndims;
990 } else if (find_alloc_size(ast, astli, &allocss, &allocdtype,
991 &allocdim)) {
992 /* make this dimension the same size as dimension
993 * allocdim of datatype allocdtype for which the subscript
994 * is at allocss */
995 assert(ndims < MAXDIMS, "temporary has >MAXDIMS dimensions",
996 ndims, 4);
997 if (allocdtype == 0) {
998 allocdtype = dtype;
999 allocdim = i;
1000 allocss = memberast;
1001 }
1002 lwbnd[ndims] = check_member(allocss, ADD_LWAST(allocdtype, allocdim));
1003 upbnd[ndims] = check_member(allocss, ADD_UPAST(allocdtype, allocdim));
1004 subscr[ndims] = mk_triple(lwbnd[ndims], upbnd[ndims], 0);
1005 submap[ndims] = i;
1006 ++ndims;
1007 } else if (A_SHAPEG(ast) || search_forall_var(ast, astli)) {
1008 /* include this dimension */
1009 /* build a triplet for the allocate statement off of the
1010 * dimensions for the array */
1011 assert(ndims < MAXDIMS, "temporary has >MAXDIMS dimensions",
1012 ndims, 4);
1013 lwbnd[ndims] = check_member(memberast, ADD_LWAST(dtype, i));
1014 upbnd[ndims] = check_member(memberast, ADD_UPAST(dtype, i));
1015 subscr[ndims] = mk_triple(lwbnd[ndims], upbnd[ndims], 0);
1016 submap[ndims] = i;
1017 ++ndims;
1018 }
1019 }
1020 subscr_ast = A_LOPG(subscr_ast);
1021 } else {
1022 interr("get_forall_subscr: not member or subscript", subscr_ast, 3);
1023 }
1024 } while (A_TYPEG(subscr_ast) != A_ID);
1025
1026 return sptr;
1027 }
1028
1029 /** \brief Allocate a temporary to hold an array. Create the symbol pointer,
1030 add the allocate and deallocate statements, and return the array.
1031 \param forall_ast ast for forall
1032 \param subscr_ast ast for subscript expression
1033 \param alloc_stmt statement before which to allocate temp
1034 \param dealloc_stmt statement after which to deallocate temp
1035 \param dty datatype, or zero
1036 \param ast_dty ast with data type of element required
1037 \return symbol table pointer for array
1038
1039 The dimensions and mapping for the array are determined from the
1040 subscr_ast and the forall_ast. The subscr_ast has dimensions which
1041 are indexed by forall variables, and dimensions that are not. Those
1042 that are not are excluded from the temp. The caller can use the
1043 same index expressions to index this temp, as are used in the subscr_ast.
1044
1045 The dimensions included in the temp are taken from the array referenced
1046 by the subscr ast. Alignments for those dimensions are also taken from
1047 this array.
1048
1049 The allocate for the temporary is placed before alloc_stmt, and
1050 the deallocate is placed after dealloc_stmt. The name of the temporary
1051 is derived from the name of the array in the subscr_ast.
1052 */
1053 int
get_temp_forall(int forall_ast,int subscr_ast,int alloc_stmt,int dealloc_stmt,int dty,int ast_dty)1054 get_temp_forall(int forall_ast, int subscr_ast, int alloc_stmt,
1055 int dealloc_stmt, int dty, int ast_dty)
1056 {
1057 int sptr;
1058 int subscr[MAXSUBS];
1059 int par;
1060 int save_sc;
1061 int astd, dstd;
1062
1063 par = STD_PAR(alloc_stmt) || STD_TASK(alloc_stmt);
1064 if (par) {
1065 save_sc = symutl.sc;
1066 set_descriptor_sc(SC_PRIVATE);
1067 }
1068 if (dty) {
1069 sptr = mk_forall_sptr(forall_ast, subscr_ast, subscr, dty);
1070 } else {
1071 sptr = mk_forall_sptr(forall_ast, subscr_ast, subscr,
1072 DDTG(A_DTYPEG(ast_dty)));
1073 if (ast_dty > 0 &&
1074 sptr > NOSYM &&
1075 A_TYPEG(ast_dty) == A_SUBSCR &&
1076 is_dtype_runtime_length_char(A_DTYPEG(ast_dty)) &&
1077 SDSCG(sptr) <= NOSYM) {
1078 int length_ast = string_expr_length(ast_dty);
1079 if (length_ast > 0) {
1080 int descr_length_ast;
1081 get_static_descriptor(sptr);
1082 descr_length_ast = symbol_descriptor_length_ast(sptr, 0);
1083 if (descr_length_ast > 0) {
1084 add_stmt_before(mk_assn_stmt(descr_length_ast, length_ast,
1085 astb.bnd.dtype), alloc_stmt);
1086 }
1087 }
1088 }
1089 }
1090 if (par) {
1091 set_descriptor_sc(save_sc);
1092 }
1093 astd = mk_mem_allocate(mk_id(sptr), subscr, alloc_stmt, ast_dty);
1094 dstd = mk_mem_deallocate(mk_id(sptr), dealloc_stmt);
1095 if (STD_ACCEL(alloc_stmt))
1096 STD_RESCOPE(astd) = 1;
1097 if (STD_ACCEL(dealloc_stmt))
1098 STD_RESCOPE(dstd) = 1;
1099 return sptr;
1100 }
1101
1102 /** \brief This is almost identical to get_temp_forall() except that it has
1103 one more parameter, \p rhs.
1104 \param forall_ast ast for forall
1105 \param lhs ast for LHS
1106 \param rhs ast for RHS
1107 \param alloc_stmt statement before which to allocate temp
1108 \param dealloc_stmt statement after which to deallocate temp
1109 \param ast_dty ast with data type of element required
1110 \return symbol table pointer for array
1111
1112 For copy_section, we would like to decide the rank of temp
1113 according to rhs and distribution will be according to lhs.
1114 This case arise since we let copy_section to do also multicasting
1115 For example a(i,j) = b(2*i,3) kind of cases.
1116 tmp will be 1 dimensional and that will be distribute according
1117 to the fist dim of a.
1118 */
1119 int
get_temp_copy_section(int forall_ast,int lhs,int rhs,int alloc_stmt,int dealloc_stmt,int ast_dty)1120 get_temp_copy_section(int forall_ast, int lhs, int rhs, int alloc_stmt,
1121 int dealloc_stmt, int ast_dty)
1122 {
1123 int sptr, dty, subscr[MAXSUBS];
1124 dty = DDTG(A_DTYPEG(ast_dty));
1125 sptr = mk_forall_sptr_copy_section(forall_ast, lhs, rhs, subscr, dty);
1126 mk_mem_allocate(mk_id(sptr), subscr, alloc_stmt, ast_dty);
1127 mk_mem_deallocate(mk_id(sptr), dealloc_stmt);
1128 return sptr;
1129 }
1130
1131 /**
1132 \param forall_ast ast for forall
1133 \param lhs ast for LHS
1134 \param rhs ast for RHS
1135 \param alloc_stmt statement before which to allocate temp
1136 \param dealloc_stmt statement after which to deallocate temp
1137 \param ast_dty ast with data type of element required
1138 */
1139 int
get_temp_pure(int forall_ast,int lhs,int rhs,int alloc_stmt,int dealloc_stmt,int ast_dty)1140 get_temp_pure(int forall_ast, int lhs, int rhs, int alloc_stmt,
1141 int dealloc_stmt, int ast_dty)
1142 {
1143 int sptr, dty, subscr[MAXSUBS];
1144 dty = DDTG(A_DTYPEG(ast_dty));
1145 sptr = mk_forall_sptr_pure(forall_ast, lhs, rhs, subscr, dty);
1146 mk_mem_allocate(mk_id(sptr), subscr, alloc_stmt, ast_dty);
1147 mk_mem_deallocate(mk_id(sptr), dealloc_stmt);
1148 return sptr;
1149 }
1150
1151 /** \brief Get a temp sptr1 which will be as big as sptr
1152 it will be replicated and allocated
1153 \param sptr sptr to replicate
1154 \param alloc_stmt statement before which to allocate temp
1155 \param dealloc_stmt statement after which to deallocate temp
1156 \param astmem - tbw.
1157 */
1158 int
get_temp_pure_replicated(int sptr,int alloc_stmt,int dealloc_stmt,int astmem)1159 get_temp_pure_replicated(int sptr, int alloc_stmt, int dealloc_stmt, int astmem)
1160 {
1161 int sptr1;
1162 int subscr[MAXSUBS];
1163 int ptr;
1164 int hashlk;
1165 int i, ndim;
1166 ADSC *ad, *ad1;
1167
1168 ndim = rank_of_sym(sptr);
1169 sptr1 = sym_get_array(SYMNAME(sptr), "pure$repl", DDTG(DTYPEG(sptr)), ndim);
1170 ad = AD_DPTR(DTYPEG(sptr));
1171 ad1 = AD_DPTR(DTYPEG(sptr1));
1172 for (i = 0; i < ndim; i++) {
1173 AD_LWAST(ad1, i) = check_member(astmem, AD_LWAST(ad, i));
1174 AD_UPAST(ad1, i) = check_member(astmem, AD_UPAST(ad, i));
1175 AD_LWBD(ad1, i) = check_member(astmem, AD_LWBD(ad, i));
1176 AD_UPBD(ad1, i) = check_member(astmem, AD_UPBD(ad, i));
1177 AD_EXTNTAST(ad1, i) = check_member(astmem, AD_EXTNTAST(ad, i));
1178 subscr[i] = mk_triple(AD_LWAST(ad1, i), AD_UPAST(ad1, i), 0);
1179 }
1180
1181 /* make the descriptors for the temporary */
1182 trans_mkdescr(sptr1);
1183
1184 mk_mem_allocate(mk_id(sptr1), subscr, alloc_stmt, astmem);
1185 mk_mem_deallocate(mk_id(sptr1), dealloc_stmt);
1186 return sptr1;
1187 }
1188
1189 /**
1190 \param arr_ast ast for arr_ast
1191 \param alloc_stmt statement before which to allocate temp
1192 \param dealloc_stmt statement after which to deallocate temp
1193 \param dty ast with data type of element required
1194 */
1195 int
get_temp_remapping(int arr_ast,int alloc_stmt,int dealloc_stmt,int dty)1196 get_temp_remapping(int arr_ast, int alloc_stmt, int dealloc_stmt, int dty)
1197 {
1198 int sptr;
1199 int subscr[MAXSUBS];
1200
1201 sptr = mk_shape_sptr(A_SHAPEG(arr_ast), subscr, dty);
1202 mk_mem_allocate(mk_id(sptr), subscr, alloc_stmt, arr_ast);
1203 mk_mem_deallocate(mk_id(sptr), dealloc_stmt);
1204 return sptr;
1205 }
1206
1207 static LOGICAL
chk_temp_bnds(int lhs,int arr_sptr,int * subscr,int ndim)1208 chk_temp_bnds(int lhs, int arr_sptr, int *subscr, int ndim)
1209 {
1210 ADSC *tad;
1211 int sptr;
1212 int i;
1213
1214 if (A_TYPEG(lhs) != A_ID)
1215 return FALSE;
1216 sptr = A_SPTRG(lhs);
1217 tad = AD_DPTR(DTYPEG(sptr));
1218 /* runtime can't handle dest==src */
1219 if (arr_sptr == sptr)
1220 return FALSE;
1221 if (ndim != AD_NUMDIM(tad))
1222 return FALSE;
1223 for (i = 0; i < ndim; ++i) {
1224 if (AD_LWAST(tad, i) != A_LBDG(subscr[i]))
1225 return FALSE;
1226 if (AD_UPAST(tad, i) != A_UPBDG(subscr[i]))
1227 return FALSE;
1228 }
1229 return TRUE;
1230 }
1231
1232 /*
1233 * Make a symbol pointer from an array or subscripted array, assuming
1234 * that that symbol will be assigned the array
1235 */
1236 int
mk_assign_sptr(int arr_ast,char * purpose,int * subscr,int elem_dty,int * retval)1237 mk_assign_sptr(int arr_ast, char *purpose, int *subscr, int elem_dty,
1238 int *retval)
1239 {
1240 return chk_assign_sptr(arr_ast, purpose, subscr, elem_dty, 0, retval);
1241 }
1242
1243 /*
1244 * Find the sptr of the dummy at position 'pos' for subprogram ent
1245 */
1246 int
find_dummy(int entry,int pos)1247 find_dummy(int entry, int pos)
1248 {
1249 int dscptr;
1250
1251 proc_arginfo(entry, NULL, &dscptr, NULL);
1252 if (!dscptr)
1253 return 0;
1254 return aux.dpdsc_base[dscptr + pos];
1255 }
1256
1257 /*
1258 * return the symbol pointer to the array symbol,
1259 * and in *returnast, return the pointer to the A_SUBSCR
1260 * (or A_MEM or A_ID, if an unsubscripted array reference)
1261 */
1262 int
find_array(int ast,int * returnast)1263 find_array(int ast, int *returnast)
1264 {
1265 int sptr;
1266
1267 if (A_TYPEG(ast) == A_SUBSCR) {
1268 int lop;
1269 lop = A_LOPG(ast);
1270 if (A_TYPEG(lop) == A_ID) {
1271 if (returnast)
1272 *returnast = ast;
1273 sptr = A_SPTRG(lop);
1274 } else if (A_TYPEG(lop) == A_MEM) {
1275 /* child or parent? */
1276 int parent = A_PARENTG(lop);
1277 if ((A_SHAPEG(ast) != 0 && A_SHAPEG(ast) == A_SHAPEG(parent)) ||
1278 A_SHAPEG(lop) == 0) {
1279 return find_array(parent, returnast);
1280 }
1281 if (returnast)
1282 *returnast = ast;
1283 sptr = A_SPTRG(A_MEMG(lop));
1284 } else {
1285 interr("find_array: subscript parent is not id or member", ast, 3);
1286 }
1287 } else if (A_TYPEG(ast) == A_MEM) {
1288 int parent = A_PARENTG(ast);
1289 assert(A_SHAPEG(ast) != 0, "find_array: member ast has no shape", ast, 4);
1290
1291 if (A_SHAPEG(ast) == A_SHAPEG(parent)) {
1292 return find_array(parent, returnast);
1293 }
1294 if (returnast)
1295 *returnast = ast;
1296 sptr = A_SPTRG(A_MEMG(ast));
1297 } else if (A_TYPEG(ast) == A_ID) {
1298 assert(A_SHAPEG(ast) != 0, "find_array: ast has no shape", ast, 4);
1299 if (returnast)
1300 *returnast = ast;
1301 sptr = A_SPTRG(ast);
1302 } else {
1303 interr("find_array: not subscript or id or member", ast, 3);
1304 }
1305 assert(DTY(DTYPEG(sptr)) == TY_ARRAY, "find_array: symbol is not ARRAY", sptr,
1306 4);
1307 return sptr;
1308 }
1309
1310 /* ast is ast to search */
1311 static LOGICAL
found_forall_var(int ast)1312 found_forall_var(int ast)
1313 {
1314 int argt, n, i;
1315 int asd;
1316 int j;
1317
1318 switch (A_TYPEG(ast)) {
1319 case A_BINOP:
1320 if (found_forall_var(A_LOPG(ast)))
1321 return TRUE;
1322 return found_forall_var(A_ROPG(ast));
1323 case A_CONV:
1324 case A_UNOP:
1325 case A_PAREN:
1326 return found_forall_var(A_LOPG(ast));
1327 case A_CMPLXC:
1328 case A_CNST:
1329 return FALSE;
1330 case A_INTR:
1331 case A_FUNC:
1332 argt = A_ARGSG(ast);
1333 n = A_ARGCNTG(ast);
1334 for (i = 0; i < n; ++i) {
1335 if (found_forall_var(ARGT_ARG(argt, i)))
1336 return TRUE;
1337 }
1338 return FALSE;
1339 case A_TRIPLE:
1340 if (found_forall_var(A_LBDG(ast)))
1341 return TRUE;
1342 if (found_forall_var(A_UPBDG(ast)))
1343 return TRUE;
1344 if (A_STRIDEG(ast) && found_forall_var(A_STRIDEG(ast)))
1345 return TRUE;
1346 return FALSE;
1347 case A_MEM:
1348 return found_forall_var(A_PARENTG(ast));
1349 case A_SUBSCR:
1350 asd = A_ASDG(ast);
1351 n = ASD_NDIM(asd);
1352 for (i = 0; i < n; ++i) {
1353 if (found_forall_var(ASD_SUBS(asd, i)))
1354 return TRUE;
1355 }
1356 return found_forall_var(A_LOPG(ast));
1357 case A_ID:
1358 if (FORALLNDXG(A_SPTRG(ast)))
1359 return TRUE;
1360 return FALSE;
1361 default:
1362 interr("found_forall_index: bad opc", ast, 3);
1363 return FALSE;
1364 }
1365 }
1366
1367 static void
fixup_allocd_tmp_bounds(int * subscr,int * newsubscr,int ndim)1368 fixup_allocd_tmp_bounds(int *subscr, int *newsubscr, int ndim)
1369 {
1370 int i;
1371 int c_subscr;
1372
1373 /*
1374 * As per the Fortran spec, ALLOCATE allocates an array of size
1375 * zero when lb>ub. If the variable being allocated is a compiler
1376 * generated temp to hold the result of an expression that has a
1377 * negative stride, then the lb>ub. Reset the ub, lb, and stride
1378 * for this case (tpr3551)
1379 *
1380 * Update -- resetting the ub, lb, and stride has the effect of
1381 * computing the exact size needed for the temp. However, the
1382 * subscripts for the temp are not normalized with respect to
1383 * the actual size -- the original strided subscripts are used
1384 * and therefore, array bounds violations will occur. The computed
1385 * size just needs the direction of the stride (1 or -1) factored in;
1386 * the direction just needs to be computed as sign(1,stride).
1387 */
1388
1389 for (i = 0; i < ndim; ++i) {
1390 c_subscr = subscr[i];
1391 if (A_TYPEG(c_subscr) == A_TRIPLE && A_STRIDEG(c_subscr) != astb.bnd.one &&
1392 A_STRIDEG(c_subscr) != 0) {
1393 int ub;
1394 int stride;
1395
1396 stride = A_STRIDEG(c_subscr);
1397 if (A_ALIASG(stride)) {
1398 ISZ_T v;
1399 v = get_isz_cval(A_SPTRG((A_ALIASG(stride))));
1400 stride = astb.bnd.one;
1401 if (v < 0)
1402 stride = mk_isz_cval(-1, astb.bnd.dtype);
1403
1404 } else {
1405 int isign;
1406 isign = I_ISIGN;
1407 if (astb.bnd.dtype == DT_INT8) {
1408 isign = I_KISIGN;
1409 }
1410 stride = ast_intr(isign, astb.bnd.dtype, 2, astb.bnd.one, stride);
1411 }
1412 ub = mk_binop(OP_DIV,
1413 mk_binop(OP_ADD, mk_binop(OP_SUB, A_UPBDG(c_subscr),
1414 A_LBDG(c_subscr), astb.bnd.dtype),
1415 stride, astb.bnd.dtype),
1416 stride, astb.bnd.dtype);
1417 newsubscr[i] = mk_triple(astb.bnd.one, ub, 0);
1418 } else {
1419 newsubscr[i] = subscr[i];
1420 }
1421 }
1422 }
1423
1424 void
fixup_srcalloc_bounds(int * subscr,int * newsubscr,int ndim)1425 fixup_srcalloc_bounds(int *subscr, int *newsubscr, int ndim)
1426 {
1427 int i;
1428 int c_subscr;
1429 for (i = 0; i < ndim; ++i) {
1430 c_subscr = subscr[i];
1431 if (A_TYPEG(c_subscr) == A_TRIPLE) {
1432 int ub;
1433 int stride;
1434
1435 stride = A_STRIDEG(c_subscr);
1436 if (stride == 0)
1437 stride = astb.bnd.one;
1438
1439 if (A_ALIASG(stride)) {
1440 ISZ_T v;
1441 v = get_isz_cval(A_SPTRG((A_ALIASG(stride))));
1442 if (v < 0)
1443 stride = mk_isz_cval(-1, astb.bnd.dtype);
1444 }
1445 ub = mk_binop(OP_DIV,
1446 mk_binop(OP_ADD, mk_binop(OP_SUB, A_UPBDG(c_subscr),
1447 A_LBDG(c_subscr), astb.bnd.dtype),
1448 stride, astb.bnd.dtype),
1449 stride, astb.bnd.dtype);
1450
1451 newsubscr[i] = mk_triple(astb.bnd.one, ub, 0);
1452 } else {
1453 newsubscr[i] = subscr[i];
1454 }
1455 }
1456 }
1457
1458 /* This routine is just like old routine above.
1459 * However, it does not try to create temporary
1460 * based on in indirection, because that is wrong.
1461 * because distribution becomes wrong.
1462 * You can not align temporary with one dimension
1463 * aligned with a template the other dimension aligned with another
1464 * template.
1465 */
1466
1467 int
chk_assign_sptr(int arr_ast,char * purpose,int * subscr,int elem_dty,int lhs,int * retval)1468 chk_assign_sptr(int arr_ast, char *purpose, int *subscr, int elem_dty, int lhs,
1469 int *retval)
1470 {
1471 int arr_sptr;
1472 int ast;
1473 int submap[MAXSUBS];
1474 int newsubs[MAXSUBS];
1475 int i, n, j, n1, k;
1476 int asd, asd1;
1477 int astli;
1478 int sptr, ssast;
1479 ADSC *ad, *ad1;
1480 int dtype;
1481 ADSC *tad;
1482 int list;
1483 int lb, ub;
1484 int lb1, ub1, st1;
1485 int vsubsptr[MAXSUBS], vsubmap[MAXSUBS];
1486 int extent;
1487
1488 /* find the array */
1489 arr_sptr = find_array(arr_ast, &ssast);
1490 if (ASUMSZG(arr_sptr)) {
1491 sptr = mk_shape_sptr(A_SHAPEG(ssast), subscr, elem_dty);
1492 *retval = mk_id(sptr);
1493 return sptr;
1494 }
1495
1496 dtype = DTYPEG(arr_sptr);
1497 ad = AD_DPTR(dtype);
1498
1499 /* determine how many dimensions are needed, and which ones they are */
1500 if (A_TYPEG(ssast) == A_SUBSCR) {
1501 asd = A_ASDG(ssast);
1502 n = ASD_NDIM(asd);
1503 } else {
1504 asd = 0;
1505 n = AD_NUMDIM(ad);
1506 }
1507
1508 j = 0;
1509 assert(n <= MAXDIMS, "chk_assign_sptr: too many dimensions", n, 4);
1510 for (i = 0; i < n; ++i) {
1511 lb = AD_LWAST(ad, i);
1512 if (lb == 0)
1513 lb = mk_isz_cval(1, astb.bnd.dtype);
1514 lb = check_member(ssast, lb);
1515 ub = AD_UPAST(ad, i);
1516 ub = check_member(ssast, ub);
1517 vsubsptr[j] = 0;
1518 /* If this is a pointer member, we need to use the shape */
1519 if (A_TYPEG(ssast) == A_ID && STYPEG(arr_sptr) == ST_MEMBER &&
1520 POINTERG(arr_sptr)) {
1521 int shape;
1522 shape = A_SHAPEG(ssast);
1523 subscr[j] = mk_triple(SHD_LWB(shape, i), SHD_UPB(shape, i), 0);
1524 submap[j] = i;
1525 if (asd)
1526 ast = ASD_SUBS(asd, i);
1527 else
1528 ast = subscr[j];
1529 newsubs[j] = ast;
1530 ++j;
1531 } else if (asd) {
1532 ast = ASD_SUBS(asd, i);
1533 /* if it is from where-block
1534 * include each dimension */
1535 if (!XBIT(58, 0x20000) && !strcmp(purpose, "ww")) {
1536 subscr[j] = mk_triple(lb, ub, 0);
1537 newsubs[j] = ast;
1538 submap[j] = i;
1539 ++j;
1540 continue;
1541 }
1542 if (A_TYPEG(ast) == A_TRIPLE) {
1543 /* include this one */
1544 if (XBIT(58, 0x20000)) {
1545 subscr[j] = mk_triple(A_LBDG(ast), A_UPBDG(ast), A_STRIDEG(ast));
1546 newsubs[j] = ast;
1547 submap[j] = i;
1548 ++j;
1549 } else {
1550 /* would like to allocate to full size for hpf
1551 * so all processors get a chunk, even if ignored */
1552 subscr[j] = mk_triple(lb, ub, 0);
1553 newsubs[j] = ast;
1554 submap[j] = i;
1555 ++j;
1556 }
1557 } else if (A_SHAPEG(ast)) {
1558 /* vector subscript */
1559 /* (ub-lb+s)/st = extent */
1560 extent = extent_of_shape(A_SHAPEG(ast), 0);
1561 lb1 = lb;
1562 st1 = astb.i1;
1563 ub1 = opt_binop(OP_SUB, extent, st1, astb.bnd.dtype);
1564 ub1 = opt_binop(OP_ADD, ub1, lb1, astb.bnd.dtype);
1565 newsubs[j] = mk_triple(lb1, ub1, 0);
1566 subscr[j] = newsubs[j];
1567 submap[j] = i;
1568 ++j;
1569 } else if (found_forall_var(ast)) {
1570 /* a forall index appears in the subscript */
1571 /* allocate to full size instead of trying to
1572 * decipher the max/min size of the expression */
1573 subscr[j] = mk_triple(lb, ub, 0);
1574 newsubs[j] = ast;
1575 submap[j] = i;
1576 ++j;
1577 }
1578 /* else don't include scalar dims */
1579 } else {
1580 subscr[j] = mk_triple(lb, ub, 0);
1581 submap[j] = i;
1582 newsubs[j] = subscr[j];
1583 ++j;
1584 }
1585 }
1586
1587 assert(j > 0, "chk_assign_sptr: not enough dimensions", j, 4);
1588
1589 if (lhs && chk_temp_bnds(lhs, arr_sptr, subscr, j)) {
1590 *retval = lhs;
1591 return 0;
1592 }
1593
1594 /* get the temporary */
1595 sptr = sym_get_array(SYMNAME(arr_sptr), purpose, elem_dty, j);
1596 /* set the bounds to the correct bounds from the array */
1597 ad = AD_DPTR(dtype);
1598 tad = AD_DPTR(DTYPEG(sptr));
1599 fixup_allocd_tmp_bounds(newsubs, newsubs, j);
1600 for (i = 0; i < j; ++i) {
1601 if (A_TYPEG(newsubs[i]) == A_TRIPLE) {
1602 AD_LWBD(tad, i) = AD_LWAST(tad, i) = A_LBDG(newsubs[i]);
1603 AD_UPBD(tad, i) = AD_UPAST(tad, i) = A_UPBDG(newsubs[i]);
1604 AD_EXTNTAST(tad, i) = mk_extent(AD_LWAST(tad, i), AD_UPAST(tad, i), i);
1605 } else {
1606 /* assuming A_TYPE is A_CNST or A_ID */
1607 AD_LWBD(tad, i) = AD_LWAST(tad, i) = AD_UPBD(tad, i) = AD_UPAST(tad, i) =
1608 newsubs[i];
1609 AD_EXTNTAST(tad, i) = astb.bnd.one;
1610 }
1611 }
1612
1613 /* make the descriptors for the temporary */
1614 trans_mkdescr(sptr);
1615 #ifdef NOEXTENTG
1616 if ((!HCCSYMG(arr_sptr) && CONTIGUOUS_ARR(arr_sptr)) ||
1617 (HCCSYMG(arr_sptr) && SCG(arr_sptr) == SC_LOCAL &&
1618 CONTIGUOUS_ARR(arr_sptr) && NOEXTENTG(arr_sptr))) {
1619 NOEXTENTP(sptr, 1);
1620 }
1621 #endif
1622 /* mark as compiler created */
1623 HCCSYMP(sptr, 1);
1624
1625 /* make the subscript expression */
1626 *retval = mk_subscr(mk_id(sptr), newsubs, j, DTYPEG(sptr));
1627 return sptr;
1628 }
1629
1630 /*
1631 * Make a symbol pointer from an array or subscripted array, assuming
1632 * that that symbol will be assigned the array
1633 */
1634 int
mk_shape_sptr(int shape,int * subscr,int elem_dty)1635 mk_shape_sptr(int shape, int *subscr, int elem_dty)
1636 {
1637 int i, n, size, notshort;
1638 int sptr;
1639 int dtype;
1640 ADSC *tad;
1641 int ub;
1642
1643 /* determine how many dimensions are needed, and which ones they are */
1644 n = SHD_NDIM(shape);
1645 assert(n <= MAXDIMS, "mk_assign_sptr: too many dimensions", n, 4);
1646 for (i = 0; i < n; ++i) {
1647 /* (ub - lb + stride) / stride */
1648 assert(SHD_LWB(shape, i), "mk_assign_sptr: lower bound missing", 0, 4);
1649 assert(SHD_UPB(shape, i), "mk_assign_sptr: upper bound missing", 0, 4);
1650 if (SHD_STRIDE(shape, i) == astb.i1)
1651 ub = mk_binop(OP_ADD, mk_binop(OP_SUB, SHD_UPB(shape, i),
1652 SHD_LWB(shape, i), astb.bnd.dtype),
1653 astb.bnd.one, astb.bnd.dtype);
1654 else
1655 ub = mk_binop(
1656 OP_DIV, mk_binop(OP_ADD, mk_binop(OP_SUB, SHD_UPB(shape, i),
1657 SHD_LWB(shape, i), astb.bnd.dtype),
1658 SHD_STRIDE(shape, i), astb.bnd.dtype),
1659 SHD_STRIDE(shape, i), astb.bnd.dtype);
1660 subscr[i] = mk_triple(astb.bnd.one, ub, 0);
1661 }
1662 /* get the temporary */
1663 sptr = sym_get_array("tmp", "r", elem_dty, n);
1664 /* set the bounds to the correct bounds from the array */
1665 tad = AD_DPTR(DTYPEG(sptr));
1666 AD_MLPYR(tad, 0) = astb.bnd.one;
1667 notshort = 0;
1668 size = 1;
1669 for (i = 0; i < n; ++i) {
1670 AD_LWBD(tad, i) = AD_LWAST(tad, i) = A_LBDG(subscr[i]);
1671 AD_UPBD(tad, i) = AD_UPAST(tad, i) = A_UPBDG(subscr[i]);
1672 AD_EXTNTAST(tad, i) = mk_extent(AD_LWAST(tad, i), AD_UPAST(tad, i), i);
1673 AD_MLPYR(tad, i + 1) =
1674 mk_binop(OP_MUL, AD_MLPYR(tad, i), AD_UPBD(tad, i), astb.bnd.dtype);
1675 }
1676
1677 /* make the descriptors for the temporary */
1678 trans_mkdescr(sptr);
1679 check_small_allocatable(sptr);
1680
1681 /* mark as compiler created */
1682 HCCSYMP(sptr, 1);
1683
1684 return sptr;
1685 }
1686
1687 /*
1688 * If this is a temporary allocatable array,
1689 * see if it is small enough that we should just leave it on the stack.
1690 */
1691 void
check_small_allocatable(int sptr)1692 check_small_allocatable(int sptr)
1693 {
1694 int i, n, ex, small;
1695 int eldt;
1696 ISZ_T size;
1697 ADSC *ad;
1698 if (!XBIT(2, 0x1000))
1699 return;
1700 eldt = DTY(DTYPEG(sptr) + 1);
1701 if (DTY(eldt) == TY_CHAR
1702 || DTY(eldt) == TY_NCHAR
1703 ) {
1704 if (eldt == DT_ASSCHAR || eldt == DT_DEFERCHAR
1705 || eldt == DT_ASSNCHAR || eldt == DT_DEFERNCHAR
1706 )
1707 return;
1708 if (!A_ALIASG(DTY(eldt + 1)))
1709 return;
1710 }
1711 ad = AD_DPTR(DTYPEG(sptr));
1712 n = AD_NUMDIM(ad);
1713 small = 1;
1714 size = 1;
1715 for (i = 0; i < n; ++i) {
1716 ex = AD_EXTNTAST(ad, i);
1717 if (!A_ALIASG(ex)) {
1718 return;
1719 }
1720 ex = A_ALIASG(ex);
1721 size *= ad_val_of(A_SPTRG(ex));
1722 if (size > 20) {
1723 return;
1724 }
1725 }
1726 /* still small enough */
1727 ALLOCP(sptr, 0);
1728 if (MIDNUMG(sptr)) {
1729 SCP(sptr, SCG(MIDNUMG(sptr)));
1730 MIDNUMP(sptr, 0);
1731 }
1732 } /* check_small_allocatable */
1733
1734 /* if non-constant DIM
1735 * This routine is to handle non-constant dimension for reduction and spread.
1736 * Idea is to create temporary with right dimension, and
1737 * rely on pghpf_reduce_descriptor and pghpf_spread_descriptor
1738 * for tempoary bounds and alignment. Mark temp as if DYNAMIC since
1739 * compiler does not know the alignment of temporary.
1740 * This routine is alo try to use lhs
1741 */
1742
1743 static int
handle_non_cnst_dim(int arr_ast,char * purpose,int * subscr,int elem_dty,int dim,int lhs,int * retval,int ndim)1744 handle_non_cnst_dim(int arr_ast, char *purpose, int *subscr, int elem_dty,
1745 int dim, int lhs, int *retval, int ndim)
1746 {
1747 int arr_sptr;
1748 int ast;
1749 int submap[MAXSUBS];
1750 int newsubs[MAXSUBS];
1751 int i, k;
1752 int asd;
1753 int astli;
1754 int sptr;
1755 int dtype;
1756 int list;
1757 int desc;
1758 int lb, ub, ssast;
1759 int tmpl;
1760 int align, align1;
1761 int lhs_sptr;
1762
1763 /* find the array */
1764 arr_sptr = find_array(arr_ast, &ssast);
1765 dtype = DTYPEG(arr_sptr);
1766
1767 /* constant DIM */
1768 assert(dim != 0, "handle_non_cnst_dim: no dim", 0, 4);
1769 assert(!A_ALIASG(dim), "handle_non_cnst_dim: dim must be non-constant", 0, 4);
1770
1771 sptr = sym_get_array(SYMNAME(arr_sptr), purpose, elem_dty, ndim);
1772 desc = sym_get_sdescr(sptr, ndim);
1773 /* make the descriptors for the temporary */
1774 trans_mkdescr(sptr);
1775 NODESCP(sptr, 1);
1776 SECDSCP(DESCRG(sptr), desc);
1777 /* mark as compiler created */
1778 HCCSYMP(sptr, 1);
1779 for (i = 0; i < ndim; ++i) {
1780 int a;
1781 lb = get_global_lower(desc, i);
1782 a = get_extent(desc, i);
1783 a = mk_binop(OP_SUB, a, mk_cval(1, A_DTYPEG(a)), A_DTYPEG(a));
1784 ub = mk_binop(OP_ADD, lb, a, A_DTYPEG(lb));
1785 subscr[i] = newsubs[i] = mk_triple(lb, ub, 0);
1786 }
1787
1788 /* *retval = mk_id(sptr);*/
1789 *retval = mk_subscr(mk_id(sptr), newsubs, ndim, DTYPEG(sptr));
1790 return sptr;
1791 }
1792
1793 /*
1794 * Make a symbol pointer from an array or subscripted array, assuming
1795 * that that symbol will be used as the result of a reduction expression
1796 * that reduces the array. One dimension is squeezed out.
1797 */
1798 int
chk_reduc_sptr(int arr_ast,char * purpose,int * subscr,int elem_dty,int dim,int lhs,int * retval)1799 chk_reduc_sptr(int arr_ast, char *purpose, int *subscr, int elem_dty, int dim,
1800 int lhs, int *retval)
1801 {
1802 int arr_sptr;
1803 int ast;
1804 int submap[MAXSUBS];
1805 int newsubs[MAXSUBS];
1806 int i, n, j, k;
1807 int asd;
1808 int astli;
1809 int sptr, ssast;
1810 ADSC *ad;
1811 int dtype;
1812 ADSC *tad;
1813 int list;
1814 int single[] = {0, 0, 0, 0, 0, 0, 0};
1815
1816 /* find the array */
1817 arr_sptr = find_array(arr_ast, &ssast);
1818 dtype = DTYPEG(arr_sptr);
1819 ad = AD_DPTR(dtype);
1820
1821 /* determine how many dimensions are needed, and which ones they are */
1822 if (A_TYPEG(ssast) == A_SUBSCR) {
1823 asd = A_ASDG(ssast);
1824 n = ASD_NDIM(asd);
1825 } else {
1826 asd = 0;
1827 n = AD_NUMDIM(ad);
1828 }
1829
1830 /* constant DIM */
1831 assert(dim != 0, "chk_reduc_sptr: dim must be constant", 0, 4);
1832 /* if non-constant DIM */
1833 if (!A_ALIASG(dim))
1834 return handle_non_cnst_dim(ssast, purpose, subscr, elem_dty, dim, lhs,
1835 retval, n - 1);
1836
1837 dim = get_int_cval(A_SPTRG(A_ALIASG(dim)));
1838
1839 j = 0; /* dimension counter in temp */
1840 k = 0; /* vector dimensions in array */
1841 assert(n <= MAXDIMS, "chk_reduc_sptr: too many dimensions", n, 4);
1842 for (i = 0; i < n; ++i) {
1843 if (asd) {
1844 ast = ASD_SUBS(asd, i);
1845 if (A_TYPEG(ast) == A_TRIPLE) {
1846 k++;
1847 if (k == dim)
1848 continue;
1849 if (ASUMSZG(arr_sptr))
1850 subscr[j] = mk_triple(A_LBDG(ast), A_UPBDG(ast), 0);
1851 else
1852 subscr[j] = mk_triple(check_member(arr_ast, AD_LWAST(ad, i)),
1853 check_member(arr_ast, AD_UPAST(ad, i)), 0);
1854 submap[j] = i;
1855 newsubs[j] = ast;
1856 ++j;
1857 }
1858 } else {
1859 k++;
1860 if (k == dim)
1861 continue;
1862 subscr[j] = mk_triple(check_member(arr_ast, AD_LWAST(ad, i)),
1863 check_member(arr_ast, AD_UPAST(ad, i)), 0);
1864 submap[j] = i;
1865 newsubs[j] = subscr[j];
1866 ++j;
1867 }
1868 }
1869 /* get the temporary */
1870 assert(k > 1, "chk_reduc_sptr: not enough dimensions", 0, 4);
1871 assert(j == k - 1, "chk_reduc_sptr: dim out of range", 0, 4);
1872
1873 if (lhs && chk_temp_bnds(lhs, arr_sptr, subscr, j)) {
1874 *retval = lhs;
1875 return 0;
1876 }
1877
1878 sptr = sym_get_array(SYMNAME(arr_sptr), purpose, elem_dty, j);
1879 /* set the bounds to the correct bounds from the array */
1880 ad = AD_DPTR(dtype);
1881 tad = AD_DPTR(DTYPEG(sptr));
1882 if (!ASUMSZG(arr_sptr)) {
1883 for (i = 0; i < j; ++i) {
1884 AD_LWBD(tad, i) = AD_LWAST(tad, i) =
1885 check_member(arr_ast, AD_LWAST(ad, submap[i]));
1886 AD_UPBD(tad, i) = AD_UPAST(tad, i) =
1887 check_member(arr_ast, AD_UPAST(ad, submap[i]));
1888 AD_EXTNTAST(tad, i) = mk_extent(AD_LWAST(tad, i), AD_UPAST(tad, i), i);
1889 }
1890 } else {
1891 for (i = 0; i < j; ++i) {
1892 AD_LWBD(tad, i) = AD_LWAST(tad, i) = A_LBDG(subscr[i]);
1893 AD_UPBD(tad, i) = AD_UPAST(tad, i) = A_UPBDG(subscr[i]);
1894 AD_EXTNTAST(tad, i) = mk_extent(AD_LWAST(tad, i), AD_UPAST(tad, i), i);
1895 }
1896 }
1897
1898 /* make the descriptors for the temporary */
1899 trans_mkdescr(sptr);
1900 check_small_allocatable(sptr);
1901
1902 /* mark as compiler created */
1903 HCCSYMP(sptr, 1);
1904
1905 *retval = mk_subscr(mk_id(sptr), newsubs, j, DTYPEG(sptr));
1906
1907 return sptr;
1908 }
1909
1910 static void
mk_temp_based(int sptr)1911 mk_temp_based(int sptr)
1912 {
1913 int tempbase;
1914 /* create a pointer variable */
1915 tempbase = get_next_sym(SYMNAME(sptr), "cp");
1916
1917 /* make the pointer point to sptr */
1918 STYPEP(tempbase, ST_VAR);
1919 DTYPEP(tempbase, DT_PTR);
1920 SCP(tempbase, symutl_sc);
1921
1922 MIDNUMP(sptr, tempbase);
1923 SCP(sptr, SC_BASED);
1924 }
1925
1926 /*
1927 * Make a symbol pointer from an array or subscripted array, assuming
1928 * that that symbol will be used as the result of a spread expression
1929 * that adds a dimension to the array. One dimension is added.
1930 */
1931 int
mk_spread_sptr(int arr_ast,char * purpose,int * subscr,int elem_dty,int dim,int ncopies,int lhs,int * retval)1932 mk_spread_sptr(int arr_ast, char *purpose, int *subscr, int elem_dty, int dim,
1933 int ncopies, int lhs, int *retval)
1934 {
1935 int arr_sptr;
1936 int ast, shape;
1937 int submap[MAXSUBS];
1938 int newsubs[MAXSUBS];
1939 int i, n, j;
1940 int asd;
1941 int astli;
1942 int sptr, ssast;
1943 ADSC *ad = NULL;
1944 int dtype;
1945 ADSC *tad = NULL;
1946 int list;
1947 int ttype = 0;
1948 int single[] = {0, 0, 0, 0, 0, 0, 0};
1949
1950 /* if it has a scalar spread(3, dim, ncopies) */
1951 if (A_TYPEG(arr_ast) != A_SUBSCR && A_SHAPEG(arr_ast) == 0) { /*scalar */
1952 sptr = sym_get_array("spread", purpose, elem_dty, 1);
1953 /* set the bounds to the correct bounds from the array */
1954 tad = AD_DPTR(DTYPEG(sptr));
1955 AD_LWBD(tad, 0) = AD_LWAST(tad, 0) = mk_isz_cval(1, astb.bnd.dtype);
1956 AD_NUMELM(tad) = AD_UPBD(tad, 0) = AD_UPAST(tad, 0) = ncopies;
1957 AD_EXTNTAST(tad, 0) = mk_extent(AD_LWAST(tad, 0), AD_UPAST(tad, 0), 0);
1958 if (elem_dty == DT_ASSCHAR || elem_dty == DT_DEFERCHAR
1959 || elem_dty == DT_ASSNCHAR || elem_dty == DT_DEFERNCHAR
1960 ) {
1961 /* make the temporary a based symbol; mk_mem_allocate() will compute
1962 * the length
1963 */
1964 mk_temp_based(sptr);
1965 }
1966 /* make the descriptors for the temporary */
1967 trans_mkdescr(sptr);
1968 check_small_allocatable(sptr);
1969 /* mark as compiler created */
1970 HCCSYMP(sptr, 1);
1971 subscr[0] = mk_triple(mk_isz_cval(1, astb.bnd.dtype), ncopies, 0);
1972 newsubs[0] = subscr[0];
1973 *retval = mk_subscr(mk_id(sptr), newsubs, 1, DTYPEG(sptr));
1974 return sptr;
1975 }
1976
1977 switch (A_TYPEG(arr_ast)) {
1978 case A_SUBSCR:
1979 asd = A_ASDG(arr_ast);
1980 n = ASD_NDIM(asd);
1981 for (j = 0; j < n; j++) {
1982 int sb;
1983 sb = ASD_SUBS(asd, j);
1984 if (A_TYPEG(sb) != A_TRIPLE && A_SHAPEG(sb)) {
1985 /* has index vector */
1986 goto no_arr_sptr;
1987 }
1988 }
1989 /* fall-thru */
1990 case A_ID:
1991 case A_MEM:
1992 arr_sptr = find_array(arr_ast, &ssast);
1993 ttype = dtype = DTYPEG(arr_sptr);
1994 ad = AD_DPTR(dtype);
1995 shape = 0;
1996
1997 /* determine how many dimensions are needed, and which ones they are */
1998 if (A_TYPEG(ssast) == A_SUBSCR) {
1999 asd = A_ASDG(ssast);
2000 n = ASD_NDIM(asd);
2001 } else {
2002 asd = 0;
2003 n = AD_NUMDIM(ad);
2004 }
2005 break;
2006 default:
2007 no_arr_sptr:
2008 arr_sptr = 0;
2009 dtype = A_DTYPEG(arr_ast);
2010 ad = NULL;
2011 asd = 0;
2012 shape = A_SHAPEG(arr_ast);
2013 n = SHD_NDIM(shape);
2014 break;
2015 }
2016
2017 /* constant DIM */
2018 assert(dim != 0, "chk_reduc_sptr: dim must be constant", 0, 4);
2019 /* if non-constant DIM */
2020 if (!A_ALIASG(dim))
2021 return handle_non_cnst_dim(ssast, purpose, subscr, elem_dty, dim, lhs,
2022 retval, n + 1);
2023
2024 dim = get_int_cval(A_SPTRG(A_ALIASG(dim)));
2025
2026 j = 0;
2027 assert(n <= MAXDIMS, "chk_spread_sptr: too many dimensions", n, 4);
2028 for (i = 0; i < n; ++i) {
2029 if (asd) {
2030 ast = ASD_SUBS(asd, i);
2031 if (A_TYPEG(ast) == A_TRIPLE) {
2032 if (j == dim - 1) {
2033 /* add before this dimension */
2034 subscr[j] = mk_triple(mk_isz_cval(1, astb.bnd.dtype), ncopies, 0);
2035 submap[j] = -1;
2036 newsubs[j] = subscr[j];
2037 ++j;
2038 }
2039 /* include this one */
2040 if (ASUMSZG(arr_sptr))
2041 subscr[j] = mk_triple(A_LBDG(ast), A_UPBDG(ast), 0);
2042 else
2043 subscr[j] = mk_triple(check_member(ssast, AD_LWAST(ad, i)),
2044 check_member(ssast, AD_UPAST(ad, i)), 0);
2045 submap[j] = i;
2046 newsubs[j] = ast;
2047 ++j;
2048 }
2049 } else {
2050 if (j == dim - 1) {
2051 /* add before this dimension */
2052 subscr[j] = mk_triple(mk_isz_cval(1, astb.bnd.dtype), ncopies, 0);
2053 submap[j] = -1;
2054 newsubs[j] = subscr[j];
2055 ++j;
2056 }
2057 if (ad) {
2058 subscr[j] = mk_triple(check_member(ssast, AD_LWAST(ad, i)),
2059 check_member(ssast, AD_UPAST(ad, i)), 0);
2060 } else if (shape) {
2061 subscr[j] = mk_triple(SHD_LWB(shape, i), SHD_UPB(shape, i), 0);
2062 } else {
2063 interr("spread with no shape", ast, 3);
2064 }
2065 submap[j] = i;
2066 newsubs[j] = subscr[j];
2067 ++j;
2068 }
2069 }
2070 if (j == dim - 1) {
2071 /* add after last dimension */
2072 subscr[j] = mk_triple(mk_cval(1, DT_INT), ncopies, 0);
2073 submap[j] = -1;
2074 newsubs[j] = subscr[j];
2075 ++j;
2076 }
2077
2078 /* get the temporary */
2079 assert(j > 0, "chk_spread_sptr: not enough dimensions", 0, 4);
2080
2081 if (arr_sptr) {
2082 sptr = sym_get_array(SYMNAME(arr_sptr), purpose, elem_dty, j);
2083 } else {
2084 sptr = sym_get_array("sprd", purpose, elem_dty, j);
2085 }
2086 /* set the bounds to the correct bounds from the array */
2087 tad = AD_DPTR(DTYPEG(sptr));
2088 if (ad) {
2089 if (ttype) {
2090 ad = AD_DPTR(ttype);
2091 }
2092 for (i = 0; i < j; ++i) {
2093 if (ASUMSZG(arr_sptr)) {
2094 AD_LWBD(tad, i) = AD_LWAST(tad, i) = A_LBDG(subscr[i]);
2095 AD_UPBD(tad, i) = AD_UPAST(tad, i) = A_UPBDG(subscr[i]);
2096 AD_EXTNTAST(tad, i) = mk_extent(AD_LWAST(tad, i), AD_UPAST(tad, i), i);
2097 } else if (submap[i] != -1) {
2098 AD_LWBD(tad, i) = AD_LWAST(tad, i) =
2099 check_member(ssast, AD_LWAST(ad, submap[i]));
2100 AD_UPBD(tad, i) = AD_UPAST(tad, i) =
2101 check_member(ssast, AD_UPAST(ad, submap[i]));
2102 AD_EXTNTAST(tad, i) = check_member(ssast, AD_EXTNTAST(ad, submap[i]));
2103 } else {
2104 AD_LWBD(tad, i) = AD_LWAST(tad, i) = mk_isz_cval(1, astb.bnd.dtype);
2105 AD_UPBD(tad, i) = AD_UPAST(tad, i) = ncopies;
2106 AD_EXTNTAST(tad, i) = mk_extent(AD_LWAST(tad, i), AD_UPAST(tad, i), i);
2107 }
2108 }
2109 } else {
2110 for (i = 0; i < j; ++i) {
2111 if (submap[i] != -1) {
2112 AD_LWBD(tad, i) = AD_LWAST(tad, i) = SHD_LWB(shape, submap[i]);
2113 AD_UPBD(tad, i) = AD_UPAST(tad, i) = SHD_UPB(shape, submap[i]);
2114 AD_EXTNTAST(tad, i) = mk_extent_expr(SHD_LWB(shape, submap[i]),
2115 SHD_UPB(shape, submap[i]));
2116 } else {
2117 AD_LWBD(tad, i) = AD_LWAST(tad, i) = mk_isz_cval(1, astb.bnd.dtype);
2118 AD_UPBD(tad, i) = AD_UPAST(tad, i) = ncopies;
2119 AD_EXTNTAST(tad, i) =
2120 mk_extent_expr(AD_LWAST(tad, i), AD_UPAST(tad, i));
2121 }
2122 }
2123 }
2124 if (elem_dty == DT_ASSCHAR || elem_dty == DT_DEFERCHAR
2125 || dtype == DT_ASSNCHAR || elem_dty == DT_DEFERNCHAR
2126 ) {
2127 /* make the temporary a based symbol; mk_mem_allocate() will compute
2128 * the length
2129 */
2130 mk_temp_based(sptr);
2131 }
2132
2133 /* make the descriptors for the temporary */
2134 trans_mkdescr(sptr);
2135 check_small_allocatable(sptr);
2136
2137 /* mark as compiler created */
2138 HCCSYMP(sptr, 1);
2139
2140 *retval = mk_subscr(mk_id(sptr), newsubs, j, DTYPEG(sptr));
2141 return sptr;
2142 }
2143
2144 /*
2145 * Make sptr for matmul
2146 */
2147 int
mk_matmul_sptr(int arg1,int arg2,char * purpose,int * subscr,int elem_dty,int * retval)2148 mk_matmul_sptr(int arg1, int arg2, char *purpose, int *subscr, int elem_dty,
2149 int *retval)
2150 {
2151 int arr_sptr1, arr_sptr2;
2152 int ast;
2153 int submap1[MAXSUBS], submap2[MAXSUBS];
2154 int subscr1[MAXSUBS], subscr2[MAXSUBS];
2155 int newsubs1[MAXSUBS], newsubs2[MAXSUBS];
2156 int newsubs[MAXSUBS];
2157 int rank1, rank2, rank;
2158 int i, n, j;
2159 int flag;
2160 int asd;
2161 int astli;
2162 int sptr, ssast1, ssast2;
2163 ADSC *ad1, *ad2;
2164 int dtype;
2165 ADSC *tad;
2166 int list;
2167
2168 arr_sptr1 = find_array(arg1, &ssast1);
2169 dtype = DTYPEG(arr_sptr1);
2170 ad1 = AD_DPTR(dtype);
2171
2172 /* find the first vector dimension of the first arg */
2173 if (A_TYPEG(ssast1) == A_SUBSCR) {
2174 asd = A_ASDG(ssast1);
2175 n = ASD_NDIM(asd);
2176 } else {
2177 asd = 0;
2178 n = AD_NUMDIM(ad1);
2179 }
2180 assert(n <= MAXDIMS, "mk_matmul_sptr: too many dimensions", n, 4);
2181 j = 0;
2182 for (i = 0; i < n; ++i) {
2183 if (asd) {
2184 ast = ASD_SUBS(asd, i);
2185 if (A_TYPEG(ast) == A_TRIPLE) {
2186 int lb, ub;
2187 if (ASUMSZG(arr_sptr1)) {
2188 lb = A_LBDG(ast);
2189 ub = A_UPBDG(ast);
2190 } else {
2191 lb = check_member(ssast1, AD_LWAST(ad1, i));
2192 ub = check_member(ssast1, AD_UPAST(ad1, i));
2193 }
2194 subscr1[j] = mk_triple(lb, ub, 0);
2195 submap1[j] = i;
2196 newsubs1[j] = ast;
2197 ++j;
2198 }
2199 } else {
2200 int lb, ub;
2201 lb = check_member(ssast1, AD_LWAST(ad1, i));
2202 ub = check_member(ssast1, AD_UPAST(ad1, i));
2203 subscr1[j] = mk_triple(lb, ub, 0);
2204 submap1[j] = i;
2205 newsubs1[j] = subscr1[j];
2206 ++j;
2207 }
2208 }
2209 rank1 = j;
2210
2211 arr_sptr2 = find_array(arg2, &ssast2);
2212 dtype = DTYPEG(arr_sptr2);
2213 ad2 = AD_DPTR(dtype);
2214
2215 /* find the second vector dimension of the second arg */
2216 if (A_TYPEG(ssast2) == A_SUBSCR) {
2217 asd = A_ASDG(ssast2);
2218 n = ASD_NDIM(asd);
2219 } else {
2220 asd = 0;
2221 n = AD_NUMDIM(ad2);
2222 }
2223 assert(n <= MAXDIMS, "mk_matmul_sptr: too many dimensions", n, 4);
2224 j = 0;
2225 for (i = 0; i < n; ++i) {
2226 if (asd) {
2227 ast = ASD_SUBS(asd, i);
2228 if (A_TYPEG(ast) == A_TRIPLE) {
2229 int lb, ub;
2230 if (ASUMSZG(arr_sptr2)) {
2231 lb = A_LBDG(ast);
2232 ub = A_UPBDG(ast);
2233 } else {
2234 lb = check_member(ssast2, AD_LWAST(ad2, i));
2235 ub = check_member(ssast2, AD_UPAST(ad2, i));
2236 }
2237 subscr2[j] = mk_triple(lb, ub, 0);
2238 submap2[j] = i;
2239 newsubs2[j] = ast;
2240 ++j;
2241 }
2242 } else {
2243 int lb, ub;
2244 lb = check_member(ssast2, AD_LWAST(ad2, i));
2245 ub = check_member(ssast2, AD_UPAST(ad2, i));
2246 subscr2[j] = mk_triple(lb, ub, 0);
2247 submap2[j] = i;
2248 newsubs2[j] = subscr2[j];
2249 ++j;
2250 }
2251 }
2252 rank2 = j;
2253
2254 if (rank1 == 1) {
2255 /* dimension is second dimension of second array */
2256 assert(rank2 == 2, "mk_matmul_sptr: rank mismatch (1,2)", 0, 4);
2257 rank = 1;
2258 subscr[0] = subscr2[1];
2259 newsubs[0] = newsubs2[1];
2260 /* get the temporary */
2261 sptr = sym_get_array(SYMNAME(arr_sptr1), purpose, elem_dty, rank);
2262 dtype = DTYPEG(arr_sptr2);
2263 ad2 = AD_DPTR(dtype);
2264 /* set the bounds to the correct bounds from the arrays */
2265 tad = AD_DPTR(DTYPEG(sptr));
2266 if (ASUMSZG(arr_sptr2)) {
2267 AD_LWBD(tad, 0) = AD_LWAST(tad, 0) = A_LBDG(subscr[0]);
2268 AD_UPBD(tad, 0) = AD_UPAST(tad, 0) = A_UPBDG(subscr[0]);
2269 AD_EXTNTAST(tad, 0) = mk_extent(AD_LWAST(tad, 0), AD_UPAST(tad, 0), i);
2270 } else {
2271 AD_LWBD(tad, 0) = AD_LWAST(tad, 0) =
2272 check_member(ssast2, AD_LWAST(ad2, submap2[1]));
2273 AD_UPBD(tad, 0) = AD_UPAST(tad, 0) =
2274 check_member(ssast2, AD_UPAST(ad2, submap2[1]));
2275 AD_EXTNTAST(tad, 0) = check_member(ssast2, AD_EXTNTAST(ad2, submap2[1]));
2276 }
2277 } else if (rank2 == 1) {
2278 /* dimension is first dimension of first array */
2279 assert(rank1 == 2, "mk_matmul_sptr: rank mismatch (2,1)", 0, 4);
2280 rank = 1;
2281 subscr[0] = subscr1[0];
2282 newsubs[0] = newsubs1[0];
2283 /* get the temporary */
2284 sptr = sym_get_array(SYMNAME(arr_sptr1), purpose, elem_dty, rank);
2285 dtype = DTYPEG(arr_sptr1);
2286 ad1 = AD_DPTR(dtype);
2287 /* set the bounds to the correct bounds from the arrays */
2288 tad = AD_DPTR(DTYPEG(sptr));
2289 if (ASUMSZG(arr_sptr1)) {
2290 AD_LWBD(tad, 0) = AD_LWAST(tad, 0) = A_LBDG(subscr[0]);
2291 AD_UPBD(tad, 0) = AD_UPAST(tad, 0) = A_UPBDG(subscr[0]);
2292 AD_EXTNTAST(tad, 0) = mk_extent(AD_LWAST(tad, 0), AD_UPAST(tad, 0), i);
2293 } else {
2294 AD_LWBD(tad, 0) = AD_LWAST(tad, 0) =
2295 check_member(ssast1, AD_LWAST(ad1, submap1[0]));
2296 AD_UPBD(tad, 0) = AD_UPAST(tad, 0) =
2297 check_member(ssast1, AD_UPAST(ad1, submap1[0]));
2298 AD_EXTNTAST(tad, 0) = check_member(ssast1, AD_EXTNTAST(ad1, submap1[0]));
2299 }
2300 } else {
2301 /* dimension is 1st of 1st and 2nd of 2nd */
2302 assert(rank1 == 2 && rank2 == 2, "mk_matmul_sptr: rank mismatch (2,2)", 0,
2303 4);
2304 rank = 2;
2305 subscr[0] = subscr1[0];
2306 newsubs[0] = newsubs1[0];
2307 subscr[1] = subscr2[1];
2308 newsubs[1] = newsubs2[1];
2309 /* get the temporary */
2310 sptr = sym_get_array(SYMNAME(arr_sptr1), purpose, elem_dty, rank);
2311 dtype = DTYPEG(arr_sptr1);
2312 ad1 = AD_DPTR(dtype);
2313 dtype = DTYPEG(arr_sptr2);
2314 ad2 = AD_DPTR(dtype);
2315 /* set the bounds to the correct bounds from the arrays */
2316 tad = AD_DPTR(DTYPEG(sptr));
2317 if (ASUMSZG(arr_sptr1)) {
2318 AD_LWBD(tad, 0) = AD_LWAST(tad, 0) = A_LBDG(subscr[0]);
2319 AD_UPBD(tad, 0) = AD_UPAST(tad, 0) = A_UPBDG(subscr[0]);
2320 AD_EXTNTAST(tad, 0) = mk_extent(AD_LWAST(tad, 0), AD_UPAST(tad, 0), 0);
2321 } else {
2322 AD_LWBD(tad, 0) = AD_LWAST(tad, 0) =
2323 check_member(ssast1, AD_LWAST(ad1, submap1[0]));
2324 AD_UPBD(tad, 0) = AD_UPAST(tad, 0) =
2325 check_member(ssast1, AD_UPAST(ad1, submap1[0]));
2326 AD_EXTNTAST(tad, 0) = check_member(ssast1, AD_EXTNTAST(ad1, submap1[0]));
2327 }
2328 if (ASUMSZG(arr_sptr2)) {
2329 AD_LWBD(tad, 1) = AD_LWAST(tad, 1) = A_LBDG(subscr[1]);
2330 AD_UPBD(tad, 1) = AD_UPAST(tad, 1) = A_UPBDG(subscr[1]);
2331 AD_EXTNTAST(tad, 1) = mk_extent(AD_LWAST(tad, 1), AD_UPAST(tad, 1), 1);
2332 } else {
2333 AD_LWBD(tad, 1) = AD_LWAST(tad, 1) =
2334 check_member(ssast2, AD_LWAST(ad2, submap2[1]));
2335 AD_UPBD(tad, 1) = AD_UPAST(tad, 1) =
2336 check_member(ssast2, AD_UPAST(ad2, submap2[1]));
2337 AD_EXTNTAST(tad, 1) = check_member(ssast2, AD_EXTNTAST(ad2, submap2[1]));
2338 }
2339 }
2340
2341 /* make the descriptors for the temporary */
2342 trans_mkdescr(sptr);
2343 check_small_allocatable(sptr);
2344 #ifdef NOEXTENTG
2345 if (ALLOCG(sptr)) {
2346 if ((!HCCSYMG(arr_sptr1) && CONTIGUOUS_ARR(arr_sptr1)) ||
2347 (HCCSYMG(arr_sptr1) && SCG(arr_sptr1) == SC_LOCAL &&
2348 CONTIGUOUS_ARR(arr_sptr1) && NOEXTENTG(arr_sptr1))) {
2349 NOEXTENTP(sptr, 1);
2350 }
2351 }
2352 #endif
2353 /* mark as compiler created */
2354 HCCSYMP(sptr, 1);
2355
2356 *retval = mk_subscr(mk_id(sptr), newsubs, rank, DTYPEG(sptr));
2357
2358 return sptr;
2359 }
2360
2361 /*
2362 * Make sptr for transpose
2363 */
2364 int
mk_transpose_sptr(int arr_ast,char * purpose,int * subscr,int elem_dty,int * retval)2365 mk_transpose_sptr(int arr_ast, char *purpose, int *subscr, int elem_dty,
2366 int *retval)
2367 {
2368 int arr_sptr;
2369 int ast;
2370 int submap[MAXSUBS];
2371 int newsubs[MAXSUBS];
2372 int i, n, j;
2373 int asd;
2374 int astli;
2375 int sptr, ssast;
2376 ADSC *ad;
2377 int dtype;
2378 ADSC *tad;
2379 int list;
2380
2381 arr_sptr = find_array(arr_ast, &ssast);
2382 dtype = DTYPEG(arr_sptr);
2383 ad = AD_DPTR(dtype);
2384
2385 /* determine how many dimensions are needed, and which ones they are */
2386 if (A_TYPEG(ssast) == A_SUBSCR) {
2387 asd = A_ASDG(ssast);
2388 n = ASD_NDIM(asd);
2389 } else {
2390 asd = 0;
2391 n = AD_NUMDIM(ad);
2392 }
2393 j = 0;
2394 assert(n <= MAXDIMS, "mk_transpose_sptr: too many dimensions", n, 4);
2395 for (i = 0; i < n; ++i) {
2396 if (asd) {
2397 ast = ASD_SUBS(asd, i);
2398 if (A_TYPEG(ast) == A_TRIPLE) {
2399 /* include this one */
2400 if (ASUMSZG(arr_sptr))
2401 subscr[j] = mk_triple(A_LBDG(ast), A_UPBDG(ast), 0);
2402 else
2403 subscr[j] = mk_triple(check_member(ssast, AD_LWAST(ad, i)),
2404 check_member(ssast, AD_UPAST(ad, i)), 0);
2405 submap[j] = i;
2406 newsubs[j] = ast;
2407 ++j;
2408 }
2409 } else {
2410 subscr[j] = mk_triple(check_member(ssast, AD_LWAST(ad, i)),
2411 check_member(ssast, AD_UPAST(ad, i)), 0);
2412 submap[j] = i;
2413 newsubs[j] = subscr[j];
2414 ++j;
2415 }
2416 }
2417 /* get the temporary */
2418 assert(j == 2, "mk_transpose_sptr: not enough dimensions", 0, 4);
2419 sptr = sym_get_array(SYMNAME(arr_sptr), purpose, elem_dty, j);
2420 /* set the bounds to the correct bounds from the array */
2421 ad = AD_DPTR(dtype);
2422 tad = AD_DPTR(DTYPEG(sptr));
2423 if (ASUMSZG(arr_sptr)) {
2424 AD_LWBD(tad, 0) = AD_LWAST(tad, 0) = subscr[1];
2425 AD_UPBD(tad, 0) = AD_UPAST(tad, 0) = subscr[1];
2426 AD_EXTNTAST(tad, 0) = mk_extent(AD_LWAST(tad, 0), AD_UPAST(tad, 0), 0);
2427 AD_LWBD(tad, 1) = AD_LWAST(tad, 1) = subscr[0];
2428 AD_UPBD(tad, 1) = AD_UPAST(tad, 1) = subscr[0];
2429 AD_EXTNTAST(tad, 1) = mk_extent(AD_LWAST(tad, 1), AD_UPAST(tad, 1), 1);
2430 } else {
2431 AD_LWBD(tad, 0) = AD_LWAST(tad, 0) =
2432 check_member(arr_ast, AD_LWAST(ad, submap[1]));
2433 AD_UPBD(tad, 0) = AD_UPAST(tad, 0) =
2434 check_member(arr_ast, AD_UPAST(ad, submap[1]));
2435 AD_EXTNTAST(tad, 0) =
2436 check_member(arr_ast, mk_extent(AD_LWAST(tad, 0), AD_UPAST(tad, 0), 0));
2437 AD_LWBD(tad, 1) = AD_LWAST(tad, 1) =
2438 check_member(arr_ast, AD_LWAST(ad, submap[0]));
2439 AD_UPBD(tad, 1) = AD_UPAST(tad, 1) =
2440 check_member(arr_ast, AD_UPAST(ad, submap[0]));
2441 AD_EXTNTAST(tad, 1) =
2442 check_member(arr_ast, mk_extent(AD_LWAST(tad, 1), AD_UPAST(tad, 1), 1));
2443 }
2444
2445 i = newsubs[1];
2446 newsubs[1] = newsubs[0];
2447 newsubs[0] = i;
2448 i = subscr[1];
2449 subscr[1] = subscr[0];
2450 subscr[0] = i;
2451
2452 /* make the descriptors for the temporary */
2453 trans_mkdescr(sptr);
2454 check_small_allocatable(sptr);
2455
2456 /* mark as compiler created */
2457 HCCSYMP(sptr, 1);
2458
2459 *retval = mk_subscr(mk_id(sptr), newsubs, j, DTYPEG(sptr));
2460
2461 return sptr;
2462 }
2463
2464 int
mk_pack_sptr(int shape,int elem_dty)2465 mk_pack_sptr(int shape, int elem_dty)
2466 {
2467 int sptr;
2468 ADSC *tad;
2469
2470 assert(SHD_NDIM(shape) == 1, "mk_pack_sptr: not rank 1", 0, 4);
2471 sptr = sym_get_array("pack", "r", elem_dty, 1);
2472 tad = AD_DPTR(DTYPEG(sptr));
2473 AD_LWBD(tad, 0) = AD_LWAST(tad, 0) = SHD_LWB(shape, 0);
2474 AD_UPBD(tad, 0) = AD_UPAST(tad, 0) = SHD_UPB(shape, 0);
2475 AD_EXTNTAST(tad, 0) = mk_extent(AD_LWAST(tad, 0), AD_UPAST(tad, 0), 0);
2476 trans_mkdescr(sptr);
2477 check_small_allocatable(sptr);
2478 return sptr;
2479 }
2480
2481 /*
2482 * Replicated array to hold result of 'scalar' min/maxloc
2483 */
2484 int
mk_maxloc_sptr(int shape,int elem_dty)2485 mk_maxloc_sptr(int shape, int elem_dty)
2486 {
2487 int sptr;
2488 int dtype;
2489 ADSC *tad;
2490
2491 assert(SHD_NDIM(shape) == 1, "mk_maxloc_sptr: not rank 1", 0, 4);
2492 sptr = get_next_sym("mloc", "r");
2493 dtype = get_array_dtype(1, elem_dty);
2494 tad = AD_DPTR(dtype);
2495 AD_LWBD(tad, 0) = AD_LWAST(tad, 0) = SHD_LWB(shape, 0);
2496 AD_UPBD(tad, 0) = AD_UPAST(tad, 0) = SHD_UPB(shape, 0);
2497 AD_EXTNTAST(tad, 0) = mk_extent(AD_LWAST(tad, 0), AD_UPAST(tad, 0), 0);
2498 DTYPEP(sptr, dtype);
2499 STYPEP(sptr, ST_ARRAY);
2500 DCLDP(sptr, 1);
2501 SCP(sptr, symutl.sc);
2502
2503 /* make the descriptors for the temporary */
2504 trans_mkdescr(sptr);
2505
2506 return sptr;
2507 }
2508
2509 /* ast to search
2510 * list pointer of forall indices
2511 */
2512 int
search_forall_var(int ast,int list)2513 search_forall_var(int ast, int list)
2514 {
2515 int argt, n, i;
2516 int asd;
2517 int j;
2518
2519 switch (A_TYPEG(ast)) {
2520 case A_BINOP:
2521 if ((j = search_forall_var(A_LOPG(ast), list)) != 0)
2522 return j;
2523 return search_forall_var(A_ROPG(ast), list);
2524 case A_CONV:
2525 case A_UNOP:
2526 case A_PAREN:
2527 return search_forall_var(A_LOPG(ast), list);
2528 case A_CMPLXC:
2529 case A_CNST:
2530 break;
2531 case A_INTR:
2532 case A_FUNC:
2533 argt = A_ARGSG(ast);
2534 n = A_ARGCNTG(ast);
2535 for (i = 0; i < n; ++i) {
2536 if ((j = search_forall_var(ARGT_ARG(argt, i), list)) != 0)
2537 return j;
2538 }
2539 break;
2540 case A_TRIPLE:
2541 if ((j = search_forall_var(A_LBDG(ast), list)) != 0)
2542 return j;
2543 if ((j = search_forall_var(A_UPBDG(ast), list)) != 0)
2544 return j;
2545 if (A_STRIDEG(ast) && (j = search_forall_var(A_STRIDEG(ast), list)) != 0)
2546 return j;
2547 break;
2548 case A_MEM:
2549 return search_forall_var(A_PARENTG(ast), list);
2550 case A_SUBSCR:
2551 asd = A_ASDG(ast);
2552 n = ASD_NDIM(asd);
2553 for (i = 0; i < n; ++i)
2554 if ((j = search_forall_var(ASD_SUBS(asd, i), list)) != 0)
2555 return j;
2556 return search_forall_var(A_LOPG(ast), list);
2557 case A_ID:
2558 for (i = list; i != 0; i = ASTLI_NEXT(i)) {
2559 if (A_SPTRG(ast) == ASTLI_SPTR(i))
2560 return i;
2561 }
2562 break;
2563 default:
2564 interr("search_forall_var: bad opc", ast, 3);
2565 break;
2566 }
2567 return 0;
2568 }
2569
2570 int
other_forall_var(int ast,int list,int fnd)2571 other_forall_var(int ast, int list, int fnd)
2572 {
2573 /* ast to search
2574 * list pointer of forall indices
2575 * fnd - astli item of a forall index which appears in ast
2576 * f2731.
2577 */
2578 int argt, n, i;
2579 int asd;
2580 int j;
2581
2582 switch (A_TYPEG(ast)) {
2583 case A_BINOP:
2584 if ((j = other_forall_var(A_LOPG(ast), list, fnd)) != 0)
2585 return j;
2586 return other_forall_var(A_ROPG(ast), list, fnd);
2587 case A_CONV:
2588 case A_UNOP:
2589 case A_PAREN:
2590 return other_forall_var(A_LOPG(ast), list, fnd);
2591 case A_CMPLXC:
2592 case A_CNST:
2593 break;
2594 case A_INTR:
2595 case A_FUNC:
2596 argt = A_ARGSG(ast);
2597 n = A_ARGCNTG(ast);
2598 for (i = 0; i < n; ++i) {
2599 if ((j = other_forall_var(ARGT_ARG(argt, i), list, fnd)) != 0)
2600 return j;
2601 }
2602 break;
2603 case A_TRIPLE:
2604 if ((j = other_forall_var(A_LBDG(ast), list, fnd)) != 0)
2605 return j;
2606 if ((j = other_forall_var(A_UPBDG(ast), list, fnd)) != 0)
2607 return j;
2608 if (A_STRIDEG(ast) &&
2609 (j = other_forall_var(A_STRIDEG(ast), list, fnd)) != 0)
2610 return j;
2611 return 0;
2612 case A_MEM:
2613 return other_forall_var(A_PARENTG(ast), list, fnd);
2614 case A_SUBSCR:
2615 asd = A_ASDG(ast);
2616 n = ASD_NDIM(asd);
2617 for (i = 0; i < n; ++i)
2618 if ((j = other_forall_var(ASD_SUBS(asd, i), list, fnd)) != 0)
2619 return j;
2620 return other_forall_var(A_LOPG(ast), list, fnd);
2621 case A_ID:
2622 for (i = list; i != 0; i = ASTLI_NEXT(i)) {
2623 if (i == fnd)
2624 continue;
2625 if (A_SPTRG(ast) == ASTLI_SPTR(i))
2626 return i;
2627 }
2628 break;
2629 default:
2630 interr("other_forall_var: bad opc", ast, 3);
2631 }
2632 return 0;
2633 }
2634
2635 static int
find_alloc_size(int ast,int foralllist,int * ss,int * dtype,int * dim)2636 find_alloc_size(int ast, int foralllist, int *ss, int *dtype, int *dim)
2637 {
2638 int argt, n, i;
2639 int asd;
2640 int j;
2641
2642 if (ast <= 0)
2643 return 0;
2644 switch (A_TYPEG(ast)) {
2645 case A_BINOP:
2646 j = find_alloc_size(A_LOPG(ast), foralllist, ss, dtype, dim);
2647 if (j != 0)
2648 return j;
2649 return find_alloc_size(A_ROPG(ast), foralllist, ss, dtype, dim);
2650 case A_CONV:
2651 case A_UNOP:
2652 case A_PAREN:
2653 return find_alloc_size(A_LOPG(ast), foralllist, ss, dtype, dim);
2654 case A_CMPLXC:
2655 case A_CNST:
2656 return 0;
2657
2658 case A_INTR:
2659 case A_FUNC:
2660 argt = A_ARGSG(ast);
2661 n = A_ARGCNTG(ast);
2662 for (i = 0; i < n; ++i) {
2663 j = find_alloc_size(ARGT_ARG(argt, i), foralllist, ss, dtype, dim);
2664 if (j != 0)
2665 return j;
2666 }
2667 return 0;
2668
2669 case A_TRIPLE:
2670 j = find_alloc_size(A_LBDG(ast), foralllist, ss, dtype, dim);
2671 if (j != 0)
2672 return j;
2673 j = find_alloc_size(A_UPBDG(ast), foralllist, ss, dtype, dim);
2674 if (j != 0)
2675 return j;
2676 if (A_STRIDEG(ast)) {
2677 j = find_alloc_size(A_STRIDEG(ast), foralllist, ss, dtype, dim);
2678 if (j != 0)
2679 return j;
2680 }
2681 return 0;
2682 case A_MEM:
2683 return find_alloc_size(A_PARENTG(ast), foralllist, ss, dtype, dim);
2684 case A_SUBSCR:
2685 asd = A_ASDG(ast);
2686 n = ASD_NDIM(asd);
2687 for (i = 0; i < n; ++i) {
2688 j = find_alloc_size(ASD_SUBS(asd, i), foralllist, ss, dtype, dim);
2689 if (j != 0) {
2690 /* this subscript? another? */
2691 if (*ss == 0) {
2692 *ss = ast;
2693 *dim = i;
2694 *dtype = DTYPEG(memsym_of_ast(ast));
2695 }
2696 return j;
2697 }
2698 }
2699 return find_alloc_size(A_LOPG(ast), foralllist, ss, dtype, dim);
2700 case A_ID:
2701 for (i = foralllist; i != 0; i = ASTLI_NEXT(i)) {
2702 if (A_SPTRG(ast) == ASTLI_SPTR(i))
2703 return i;
2704 }
2705 return 0;
2706 default:
2707 interr("find_alloc_size: bad opc", ast, 3);
2708 return 0;
2709 }
2710 }
2711
2712 /* subscripts (triples) for temp */
2713 int
mk_forall_sptr_copy_section(int forall_ast,int lhs,int rhs,int * subscr,int elem_dty)2714 mk_forall_sptr_copy_section(int forall_ast, int lhs, int rhs, int *subscr,
2715 int elem_dty)
2716 {
2717 int arr_sptr, ssast;
2718 int ast;
2719 int submap[MAXSUBS];
2720 int i, n, j;
2721 int asd;
2722 int sptr;
2723 ADSC *ad;
2724 int dtype;
2725 ADSC *tad;
2726 int list;
2727 int asd1;
2728 int n1;
2729 int k;
2730 LOGICAL found;
2731 int astli, astli1;
2732 int nidx, nidx1;
2733 int align, axis;
2734 int single[] = {0, 0, 0, 0, 0, 0, 0};
2735
2736 /* find the array */
2737 assert(A_TYPEG(lhs) == A_SUBSCR,
2738 "mk_forall_sptr_copy_section: ast not subscript", lhs, 4);
2739 arr_sptr = find_array(lhs, &ssast);
2740 dtype = DTYPEG(arr_sptr);
2741 assert(DTY(dtype) == TY_ARRAY,
2742 "mk_forall_sptr_copy_section: subscr sym not ARRAY", arr_sptr, 4);
2743 ad = AD_DPTR(dtype);
2744
2745 /* get the forall index list */
2746 assert(A_TYPEG(forall_ast) == A_FORALL,
2747 "mk_forall_sptr_copy_section: ast not forall", forall_ast, 4);
2748 list = A_LISTG(forall_ast);
2749
2750 /* determine how many dimensions are needed, and which ones they are */
2751 asd = A_ASDG(lhs);
2752 n = ASD_NDIM(asd);
2753 asd1 = A_ASDG(rhs);
2754 n1 = ASD_NDIM(asd1);
2755
2756 j = 0;
2757 assert(n <= MAXDIMS && n1 <= MAXDIMS,
2758 "mk_forall_sptr_copy_section: too many dimensions", 0, 4);
2759 for (k = 0; k < n1; ++k) {
2760 astli1 = 0;
2761 nidx1 = 0;
2762 search_forall_idx(ASD_SUBS(asd1, k), list, &astli1, &nidx1);
2763 assert(nidx1 < 2, "mk_forall_sptr_copy_section: something is wrong", 2,
2764 rhs);
2765 if (nidx1 == 1 && astli1) {
2766 found = FALSE;
2767 for (i = 0; i < n; i++) {
2768 astli = 0;
2769 nidx = 0;
2770 search_forall_idx(ASD_SUBS(asd, i), list, &astli, &nidx);
2771 if (astli != 0) {
2772 assert(nidx == 1, "mk_forall_sptr_copy_section: something is wrong",
2773 2, lhs);
2774 if (astli == astli1) {
2775 found = TRUE;
2776 break;
2777 }
2778 }
2779 }
2780
2781 assert(found, "mk_forall_sptr_copy_section: something is wrong", 0, 4);
2782
2783 /* include this dimension */
2784 /* build a triplet for the allocate statement off of the
2785 * dimensions for a */
2786 if (ASUMSZG(arr_sptr)) {
2787 ast = ASD_SUBS(asd, i);
2788 if (A_TYPEG(ast) == A_TRIPLE)
2789 subscr[j] = mk_triple(A_LBDG(ast), A_UPBDG(ast), 0);
2790 else if (A_SHAPEG(ast)) {
2791 int shd;
2792 shd = A_SHAPEG(ast);
2793 subscr[j] = mk_triple(SHD_LWB(shd, i), SHD_UPB(shd, i), 0);
2794 } else
2795 subscr[j] = mk_triple(A_LBDG(ASTLI_TRIPLE(astli)),
2796 A_UPBDG(ASTLI_TRIPLE(astli)), 0);
2797 submap[j] = i;
2798 ++j;
2799 } else {
2800 subscr[j] = mk_triple(check_member(lhs, AD_LWAST(ad, i)),
2801 check_member(lhs, AD_UPAST(ad, i)), 0);
2802 submap[j] = i;
2803 ++j;
2804 }
2805 }
2806 }
2807 /* get the temporary */
2808 assert(j > 0, "mk_forall_sptr_copy_section: not enough dimensions", 0, 4);
2809 sptr = sym_get_array(SYMNAME(arr_sptr), "cs", elem_dty, j);
2810 /* set the bounds to the correct bounds from the array */
2811 ad = AD_DPTR(dtype); /* may have realloc'd */
2812 tad = AD_DPTR(DTYPEG(sptr));
2813 if (!ASUMSZG(arr_sptr)) {
2814 for (i = 0; i < j; ++i) {
2815 AD_LWBD(tad, i) = AD_LWAST(tad, i) =
2816 check_member(lhs, AD_LWAST(ad, submap[i]));
2817 AD_UPBD(tad, i) = AD_UPAST(tad, i) =
2818 check_member(lhs, AD_UPAST(ad, submap[i]));
2819 AD_EXTNTAST(tad, i) = mk_extent(AD_LWAST(tad, i), AD_UPAST(tad, i), i);
2820 }
2821 } else {
2822 for (i = 0; i < j; ++i) {
2823 AD_LWBD(tad, i) = AD_LWAST(tad, i) = A_LBDG(subscr[i]);
2824 AD_UPBD(tad, i) = AD_UPAST(tad, i) = A_UPBDG(subscr[i]);
2825 AD_EXTNTAST(tad, i) = mk_extent(AD_LWAST(tad, i), AD_UPAST(tad, i), i);
2826 }
2827 }
2828
2829 /* make the descriptors for the temporary */
2830 trans_mkdescr(sptr);
2831 check_small_allocatable(sptr);
2832
2833 /* mark as compiler created */
2834 HCCSYMP(sptr, 1);
2835
2836 return sptr;
2837 }
2838
2839 /* This is just like mk_forall_sptr_copy_section expect that
2840 * It also includes scalar dimension.
2841 */
2842 int
mk_forall_sptr_gatherx(int forall_ast,int lhs,int rhs,int * subscr,int elem_dty)2843 mk_forall_sptr_gatherx(int forall_ast, int lhs, int rhs, int *subscr,
2844 int elem_dty)
2845 {
2846 int arr_sptr;
2847 int ast, ssast;
2848 int submap[MAXSUBS];
2849 int i, n, j;
2850 int asd;
2851 int sptr;
2852 ADSC *ad;
2853 int dtype;
2854 ADSC *tad;
2855 int list;
2856 int asd1;
2857 int n1;
2858 int k;
2859 LOGICAL found;
2860 int astli, astli1;
2861 int nidx, nidx1;
2862 int single[] = {0, 0, 0, 0, 0, 0, 0};
2863
2864 /* find the array */
2865 assert(A_TYPEG(lhs) == A_SUBSCR, "mk_forall_sptr_gatherx: ast not subscript",
2866 lhs, 4);
2867 arr_sptr = find_array(lhs, &ssast);
2868 dtype = DTYPEG(arr_sptr);
2869 assert(DTY(dtype) == TY_ARRAY, "mk_forall_sptr_gatherx: subscr sym not ARRAY",
2870 arr_sptr, 4);
2871 ad = AD_DPTR(dtype);
2872
2873 /* get the forall index list */
2874 assert(A_TYPEG(forall_ast) == A_FORALL,
2875 "mk_foral_sptr_gatherx: ast not forall", forall_ast, 4);
2876 list = A_LISTG(forall_ast);
2877
2878 /* determine how many dimensions are needed, and which ones they are */
2879 asd = A_ASDG(lhs);
2880 n = ASD_NDIM(asd);
2881 asd1 = A_ASDG(rhs);
2882 n1 = ASD_NDIM(asd1);
2883
2884 j = 0;
2885 assert(n <= MAXDIMS && n1 <= MAXDIMS,
2886 "mk_forall_sptr_gatherx: too many dimensions", 0, 4);
2887 for (k = 0; k < n1; ++k) {
2888 astli1 = 0;
2889 nidx1 = 0;
2890 search_forall_idx(ASD_SUBS(asd1, k), list, &astli1, &nidx1);
2891 assert(nidx1 < 2, "mk_forall_sptr_gatherx: something is wrong", 2, rhs);
2892 if (nidx1 == 1 && astli1) {
2893 found = FALSE;
2894 for (i = 0; i < n; i++) {
2895 astli = 0;
2896 nidx = 0;
2897 search_forall_idx(ASD_SUBS(asd, i), list, &astli, &nidx);
2898 if (astli != 0) {
2899 assert(nidx == 1, "mk_forall_sptr_gatherx: something is wrong", 2,
2900 lhs);
2901 if (astli == astli1) {
2902 found = TRUE;
2903 break;
2904 }
2905 }
2906 }
2907
2908 assert(found, "mk_forall_sptr_gatherx: something is wrong", 0, 4);
2909
2910 /* include this dimension */
2911 /* build a triplet for the allocate statement off of the
2912 * dimensions for a */
2913 if (ASUMSZG(arr_sptr)) {
2914 ast = ASD_SUBS(asd, i);
2915 if (A_TYPEG(ast) == A_TRIPLE)
2916 subscr[j] = mk_triple(A_LBDG(ast), A_UPBDG(ast), 0);
2917 else if (A_SHAPEG(ast)) {
2918 int shd;
2919 shd = A_SHAPEG(ast);
2920 subscr[j] = mk_triple(SHD_LWB(shd, i), SHD_UPB(shd, i), 0);
2921 } else
2922 subscr[j] = mk_triple(A_LBDG(ASTLI_TRIPLE(astli)),
2923 A_UPBDG(ASTLI_TRIPLE(astli)), 0);
2924 submap[j] = i;
2925 ++j;
2926 } else {
2927 subscr[j] = mk_triple(check_member(ssast, AD_LWAST(ad, i)),
2928 check_member(ssast, AD_UPAST(ad, i)), 0);
2929 submap[j] = i;
2930 ++j;
2931 }
2932 } else if (nidx1 == 0 && astli1 == 0) {
2933 /* include scalar dimension too */
2934 subscr[j] = mk_triple(check_member(ssast, AD_LWAST(ad, k)),
2935 check_member(ssast, AD_UPAST(ad, k)), 0);
2936 submap[j] = k;
2937 ++j;
2938 }
2939 }
2940 /* get the temporary */
2941 assert(j > 0, "mk_forall_sptr_gatherx: not enough dimensions", 0, 4);
2942 sptr = sym_get_array(SYMNAME(arr_sptr), "g", elem_dty, j);
2943 /* set the bounds to the correct bounds from the array */
2944 ad = AD_DPTR(dtype); /* may have realloc'd */
2945 tad = AD_DPTR(DTYPEG(sptr));
2946 if (!ASUMSZG(arr_sptr)) {
2947 for (i = 0; i < j; ++i) {
2948 AD_LWBD(tad, i) = AD_LWAST(tad, i) =
2949 check_member(ssast, AD_LWAST(ad, submap[i]));
2950 AD_UPBD(tad, i) = AD_UPAST(tad, i) =
2951 check_member(ssast, AD_UPAST(ad, submap[i]));
2952 AD_EXTNTAST(tad, i) = check_member(ssast, AD_EXTNTAST(ad, submap[i]));
2953 }
2954 } else {
2955 for (i = 0; i < j; ++i) {
2956 AD_LWBD(tad, i) = AD_LWAST(tad, i) = A_LBDG(subscr[i]);
2957 AD_UPBD(tad, i) = AD_UPAST(tad, i) = A_UPBDG(subscr[i]);
2958 AD_EXTNTAST(tad, i) = mk_extent(AD_LWAST(tad, i), AD_UPAST(tad, i), i);
2959 }
2960 }
2961
2962 /* make the descriptors for the temporary */
2963 trans_mkdescr(sptr);
2964 check_small_allocatable(sptr);
2965
2966 /* mark as compiler created */
2967 HCCSYMP(sptr, 1);
2968
2969 return sptr;
2970 }
2971
2972 /* the size and shape of TMP will be based on both LHS and RHS.
2973 * There are two rules for TMP:
2974 * 1-) heading dimensions size and distribution from LHS
2975 * 2-) tailling dimensions size from shape of arg with no distribution
2976 */
2977 int
mk_forall_sptr_pure(int forall_ast,int lhs,int rhs,int * subscr,int elem_dty)2978 mk_forall_sptr_pure(int forall_ast, int lhs, int rhs, int *subscr, int elem_dty)
2979 {
2980 int submap[MAXSUBS];
2981 int i, j;
2982 int asd;
2983 int sptr;
2984 int lhs_sptr, rhs_sptr, lhsmem, rhsmem;
2985 int ndim;
2986 ADSC *ad;
2987 ADSC *tad;
2988 int list;
2989 int single[] = {0, 0, 0, 0, 0, 0, 0};
2990
2991 assert(A_TYPEG(lhs) == A_SUBSCR, "mk_forall_sptr_pure: ast not subscript",
2992 lhs, 4);
2993 assert(A_TYPEG(rhs) == A_SUBSCR, "mk_forall_sptr_pure: ast not subscript",
2994 rhs, 4);
2995 lhs_sptr = memsym_of_ast(lhs);
2996 lhsmem = A_LOPG(lhs);
2997 if (A_TYPEG(lhsmem) != A_MEM)
2998 lhsmem = 0;
2999 assert(DTY(DTYPEG(lhs_sptr)) == TY_ARRAY,
3000 "mk_forall_sptr_pure: subscr sym not ARRAY", lhs_sptr, 4);
3001 rhs_sptr = memsym_of_ast(rhs);
3002 rhsmem = A_LOPG(rhs);
3003 if (A_TYPEG(rhsmem) != A_MEM)
3004 rhsmem = 0;
3005 assert(DTY(DTYPEG(rhs_sptr)) == TY_ARRAY,
3006 "mk_forall_sptr_pure: subscr sym not ARRAY", rhs_sptr, 4);
3007
3008 /* get the forall index list */
3009 assert(A_TYPEG(forall_ast) == A_FORALL, "mk_forall_sptr_pure: ast not forall",
3010 forall_ast, 4);
3011 list = A_LISTG(forall_ast);
3012
3013 /* determine how many dimensions are needed, and which ones they are */
3014 asd = A_ASDG(lhs);
3015 ndim = ASD_NDIM(asd);
3016 ad = AD_DPTR(DTYPEG(lhs_sptr));
3017 j = 0;
3018 /* find size and distribution of heading dimension from lhs */
3019 for (i = 0; i < ndim; i++) {
3020 /* include this dimension */
3021 if (search_forall_var(ASD_SUBS(asd, i), list)) {
3022 subscr[j] = mk_triple(check_member(lhsmem, AD_LWAST(ad, i)),
3023 check_member(lhsmem, AD_UPAST(ad, i)), 0);
3024 submap[j] = i;
3025 ++j;
3026 }
3027 }
3028
3029 /* find tailling dimension from rhs with no distribution*/
3030 ad = AD_DPTR(DTYPEG(rhs_sptr));
3031 asd = A_ASDG(rhs);
3032 ndim = ASD_NDIM(asd);
3033 for (i = 0; i < ndim; i++) {
3034 if (A_TYPEG(ASD_SUBS(asd, i)) == A_TRIPLE || A_SHAPEG(ASD_SUBS(asd, i))) {
3035 /* include this dimension */
3036 subscr[j] = mk_triple(check_member(rhsmem, AD_LWAST(ad, i)),
3037 check_member(rhsmem, AD_UPAST(ad, i)), 0);
3038 submap[j] = -1;
3039 ++j;
3040 }
3041 }
3042
3043 /* get the temporary */
3044 assert(j > 0 && j <= MAXDIMS, "mk_forall_sptr_pure: not enough dimensions",
3045 j, 4);
3046 sptr = sym_get_array(SYMNAME(lhs_sptr), "pure", elem_dty, j);
3047 /* set the bounds to the correct bounds from the array */
3048 tad = AD_DPTR(DTYPEG(sptr));
3049 for (i = 0; i < j; ++i) {
3050 AD_LWBD(tad, i) = AD_LWAST(tad, i) = A_LBDG(subscr[i]);
3051 AD_UPBD(tad, i) = AD_UPAST(tad, i) = A_UPBDG(subscr[i]);
3052 AD_EXTNTAST(tad, i) = mk_extent(AD_LWAST(tad, i), AD_UPAST(tad, i), i);
3053 }
3054
3055 /* make the descriptors for the temporary */
3056 trans_mkdescr(sptr);
3057 check_small_allocatable(sptr);
3058
3059 /* mark as compiler created */
3060 HCCSYMP(sptr, 1);
3061
3062 return sptr;
3063 }
3064
3065 int
first_element(int ast)3066 first_element(int ast)
3067 {
3068 int i, n, subs[MAXSUBS], asd, ss, doit, lop, dtype, parent, sptr;
3069 switch (A_TYPEG(ast)) {
3070 case A_SUBSCR:
3071 /* if any subscript is a triplet, take the first one */
3072 asd = A_ASDG(ast);
3073 n = ASD_NDIM(asd);
3074 doit = 0;
3075 for (i = 0; i < n; ++i) {
3076 ss = ASD_SUBS(asd, i);
3077 if (A_TYPEG(ss) == A_TRIPLE) {
3078 subs[i] = A_LBDG(ss);
3079 doit = 1;
3080 } else {
3081 subs[i] = ss;
3082 }
3083 }
3084 lop = A_LOPG(ast);
3085 if (A_TYPEG(lop) == A_MEM) {
3086 parent = first_element(A_PARENTG(lop));
3087 if (parent != A_PARENTG(lop)) {
3088 doit = 1;
3089 lop = mk_member(parent, A_MEMG(lop), A_DTYPEG(lop));
3090 }
3091 }
3092 if (doit) {
3093 ast = mk_subscr(lop, subs, n, A_DTYPEG(ast));
3094 }
3095 break;
3096 case A_ID:
3097 sptr = A_SPTRG(ast);
3098 parent = 0;
3099 goto hit;
3100 case A_MEM:
3101 sptr = A_SPTRG(A_MEMG(ast));
3102 parent = first_element(A_PARENTG(ast));
3103 if (parent != A_PARENTG(ast)) {
3104 ast = mk_member(parent, A_MEMG(ast), A_DTYPEG(ast));
3105 }
3106 hit:
3107 dtype = DTYPEG(sptr);
3108 if (DTY(dtype) == TY_ARRAY) {
3109 n = ADD_NUMDIM(dtype);
3110 for (i = 0; i < n; ++i) {
3111 if (ADD_LWAST(dtype, i))
3112 subs[i] = check_member(ast, ADD_LWAST(dtype, i));
3113 else
3114 subs[i] = astb.bnd.one;
3115 }
3116 ast = mk_subscr(ast, subs, n, DTY(dtype + 1));
3117 }
3118 }
3119 return ast;
3120 } /* first_element */
3121
3122 int
mk_mem_allocate(int in_ast,int * subscr,int alloc_stmt,int ast_len_from)3123 mk_mem_allocate(int in_ast, int *subscr, int alloc_stmt, int ast_len_from)
3124 {
3125 int n, ast, shape, dtype, eldtype, sptr;
3126 int atp;
3127 int newstd = 0;
3128 int par;
3129 int task;
3130
3131 par = STD_PAR(alloc_stmt);
3132 task = STD_TASK(alloc_stmt);
3133 shape = A_SHAPEG(in_ast);
3134 assert(shape != 0, "mk_mem_allocate: no shape", in_ast, 4);
3135 n = SHD_NDIM(shape);
3136 if (A_TYPEG(in_ast) == A_ID) {
3137 sptr = A_SPTRG(in_ast);
3138 } else if (A_TYPEG(in_ast) == A_MEM) {
3139 sptr = A_SPTRG(A_MEMG(in_ast));
3140 } else {
3141 interr("mk_mem_allocate: not id/member", in_ast, 4);
3142 sptr = 0;
3143 }
3144 if (sptr && !ALLOCG(sptr) && !POINTERG(sptr) && !ADJARRG(sptr) &&
3145 !ADJLENG(sptr))
3146 return 0;
3147 dtype = A_DTYPEG(in_ast);
3148 eldtype = DDTG(dtype);
3149 if (ast_len_from && (eldtype == DT_ASSCHAR || eldtype == DT_ASSNCHAR ||
3150 eldtype == DT_DEFERCHAR || eldtype == DT_DEFERNCHAR) &&
3151 !ERLYSPECG(sptr)) {
3152 int cvsptr, cvast, cvlenast;
3153 int cvlen = CVLENG(sptr);
3154 if (eldtype == DT_ASSCHAR || eldtype == DT_ASSNCHAR) {
3155 if (cvlen == 0) {
3156 cvlen = sym_get_scalar(SYMNAME(sptr), "len", DT_INT);
3157 CVLENP(sptr, cvlen);
3158 if (SCG(sptr) == SC_DUMMY)
3159 CCSYMP(cvlen, 1);
3160 }
3161 ADJLENP(sptr, 1);
3162 cvlenast = mk_id(cvlen);
3163 } else {
3164 cvlenast = get_len_of_deferchar_ast(in_ast);
3165 }
3166 ast = mk_stmt(A_ASN, 0);
3167 A_DESTP(ast, cvlenast);
3168
3169 /* see if the source length can be resolved a little */
3170 cvsptr = 0;
3171 cvast = ast_len_from;
3172 if (A_TYPEG(cvast) == A_SUBSCR) {
3173 cvast = A_LOPG(cvast);
3174 }
3175 if (A_TYPEG(cvast) == A_ID) {
3176 cvsptr = A_SPTRG(cvast);
3177 } else if (A_TYPEG(cvast) == A_MEM) {
3178 cvsptr = A_SPTRG(A_MEMG(cvast));
3179 }
3180 if (cvsptr) {
3181 int cvdtype = DDTG(DTYPEG(cvsptr));
3182 if (cvdtype == DT_ASSCHAR || cvdtype == DT_ASSNCHAR) {
3183 if (CVLENG(cvsptr)) {
3184 atp = mk_id(CVLENG(cvsptr));
3185 A_SRCP(ast, atp);
3186 } else { /* formal argument */
3187 atp = size_ast(cvsptr, cvdtype);
3188 A_SRCP(ast, atp);
3189 }
3190 } else if (cvdtype == DT_DEFERCHAR || cvdtype == DT_DEFERNCHAR) {
3191 cvsptr = 0;
3192 } else if (DTY(cvdtype) == TY_CHAR || DTY(cvdtype) == TY_NCHAR) {
3193 A_SRCP(ast, DTY(cvdtype + 1));
3194 } else {
3195 cvsptr = 0;
3196 }
3197 }
3198
3199 if (cvsptr == 0) {
3200 ast_len_from = first_element(ast_len_from);
3201 atp = ast_intr(I_LEN, DT_INT, 1, ast_len_from);
3202 A_SRCP(ast, atp);
3203 }
3204 newstd = add_stmt_before(ast, alloc_stmt);
3205 STD_PAR(newstd) = par;
3206 STD_TASK(newstd) = task;
3207 } else if ((DTY(eldtype) == TY_CHAR || DTY(eldtype) == TY_NCHAR) &&
3208 (DTY(eldtype + 1) == 0 ||
3209 (DTY(eldtype + 1) > 0 && !A_ALIASG(DTY(eldtype + 1)))) &&
3210 !ERLYSPECG(sptr)) {
3211 /* nonconstant length */
3212 int rhs;
3213 int cvlen = CVLENG(sptr);
3214 if (cvlen == 0) {
3215 cvlen = sym_get_scalar(SYMNAME(sptr), "len", DT_INT);
3216 CVLENP(sptr, cvlen);
3217 if (SCG(sptr) == SC_DUMMY)
3218 CCSYMP(cvlen, 1);
3219 }
3220 ADJLENP(sptr, 1);
3221 ast = mk_stmt(A_ASN, 0);
3222 atp = mk_id(cvlen);
3223 A_DESTP(ast, atp);
3224 rhs = DTY(eldtype + 1);
3225 rhs = mk_convert(rhs, DTYPEG(cvlen));
3226 rhs = ast_intr(I_MAX, DTYPEG(cvlen), 2, rhs, mk_cval(0, DTYPEG(cvlen)));
3227 A_SRCP(ast, rhs);
3228 newstd = add_stmt_before(ast, alloc_stmt);
3229 STD_PAR(newstd) = par;
3230 STD_TASK(newstd) = task;
3231 }
3232 /* build and insert the allocate statement */
3233 ast = mk_stmt(A_ALLOC, 0);
3234 A_TKNP(ast, TK_ALLOCATE);
3235 A_LOPP(ast, 0);
3236 if (subscr != 0) {
3237 /*
3238 * As per the Fortran spec, ALLOCATE allocates an array of size
3239 * zero when lb>ub. If the variable being allocated is a compiler
3240 * generated temp to hold the result of an expression that has a
3241 * negative stride, then the lb>ub. Reset the ub, lb, and stride
3242 * for this case (tpr3551)
3243 *
3244 * Update -- resetting the ub, lb, and stride has the effect of
3245 * computing the exact size needed for the temp. However, the
3246 * subscripts for the temp are not normalized with respect to
3247 * the actual size -- the original strided subscripts are used
3248 * and therefore, array bounds violations will occur. The computed
3249 * size just needs the direction of the stride (1 or -1) factored in;
3250 * the direction just needs to be computed as sign(1,stride).
3251 */
3252 if (A_TYPEG(in_ast) == A_ID && (HCCSYMG(sptr) || CCSYMG(sptr))) {
3253 int newsubscr[MAXSUBS];
3254
3255 fixup_allocd_tmp_bounds(subscr, newsubscr, n);
3256
3257 atp = mk_subscr(in_ast, newsubscr, n, DDTG(A_DTYPEG(in_ast)));
3258 } else {
3259 atp = mk_subscr(in_ast, subscr, n, DDTG(A_DTYPEG(in_ast)));
3260 }
3261 A_SRCP(ast, atp);
3262 } else
3263 A_SRCP(ast, in_ast);
3264 newstd = add_stmt_before(ast, alloc_stmt);
3265 STD_PAR(newstd) = par;
3266 STD_TASK(newstd) = task;
3267 return newstd;
3268 }
3269
3270 /* see mk_mem_allocate -- should be always called */
3271 int
mk_mem_deallocate(int in_ast,int dealloc_stmt)3272 mk_mem_deallocate(int in_ast, int dealloc_stmt)
3273 {
3274 int ast, sptr;
3275 int par, task;
3276 int newstd = 0;
3277
3278 /* build and insert the deallocate statement */
3279 assert(A_SHAPEG(in_ast), "mk_mem_deallocate: var not array", in_ast, 4);
3280 sptr = memsym_of_ast(in_ast);
3281 if (sptr && !ALLOCG(sptr) && !POINTERG(sptr) && !ADJARRG(sptr) &&
3282 !ADJLENG(sptr))
3283 return 0;
3284 par = STD_PAR(dealloc_stmt);
3285 task = STD_TASK(dealloc_stmt);
3286 ast = mk_stmt(A_ALLOC, 0);
3287 A_TKNP(ast, TK_DEALLOCATE);
3288 A_LOPP(ast, 0);
3289 A_SRCP(ast, in_ast);
3290 newstd = add_stmt_after(ast, dealloc_stmt);
3291 STD_PAR(newstd) = par;
3292 STD_TASK(newstd) = task;
3293 return newstd;
3294 }
3295
3296 typedef struct {
3297 int count0;
3298 int count1;
3299 int count2;
3300 int count3;
3301 int count4;
3302 int count5;
3303 int count6;
3304 int count7;
3305 int count8;
3306 int count9;
3307 int count10;
3308 int count11;
3309 int count12;
3310 } BOUND;
3311
3312 static BOUND bound;
3313
3314 void
init_bnd(void)3315 init_bnd(void)
3316 {
3317 if (gbl.internal)
3318 return;
3319 bound.count0 = 0;
3320 bound.count1 = 0;
3321 bound.count2 = 0;
3322 bound.count3 = 0;
3323 bound.count4 = 0;
3324 bound.count5 = 0;
3325 bound.count6 = 0;
3326 bound.count7 = 0;
3327 bound.count8 = 0;
3328 bound.count9 = 0;
3329 bound.count10 = 0;
3330 bound.count11 = 0;
3331 bound.count12 = 0;
3332 }
3333
3334 int
getbnd(char * basename,char * purpose,int n,int dtype)3335 getbnd(char *basename, char *purpose, int n, int dtype)
3336 {
3337 int sptr;
3338
3339 #if DEBUG
3340 assert(n >= 0 && n <= 99999, "getbnd-n too large", n, 0);
3341 #endif
3342 if (n) {
3343 if (purpose)
3344 sptr = getsymf("%s%s%s%d", basename, "$$", purpose, n);
3345 else
3346 sptr = getsymf("%s%d", basename, n);
3347 } else {
3348 if (purpose)
3349 sptr = getsymf("%s%s%s", basename, "$$", purpose);
3350 else
3351 sptr = getsymbol(basename);
3352 }
3353
3354 if (gbl.internal > 1 && !INTERNALG(sptr))
3355 sptr = insert_sym(sptr);
3356 assert(STYPEG(sptr) == ST_UNKNOWN, "getbnd: name crash", sptr, 2);
3357 DTYPEP(sptr, dtype);
3358 STYPEP(sptr, ST_VAR);
3359 DCLDP(sptr, 1);
3360 SCP(sptr, SC_LOCAL);
3361 NODESCP(sptr, 1);
3362 HCCSYMP(sptr, 1);
3363 return sptr;
3364 }
3365
3366 int
trans_getbound(int sym,int type)3367 trans_getbound(int sym, int type)
3368 {
3369 int i;
3370 int sptr;
3371
3372 switch (type) {
3373 case 0:
3374 sptr = getbnd("i", "l", bound.count0, DT_INT);
3375 bound.count0++;
3376 return sptr;
3377 case 1:
3378 sptr = getbnd("i", "u", bound.count1, DT_INT);
3379 bound.count1++;
3380 return sptr;
3381 case 2:
3382 sptr = getbnd("i", "s", bound.count2, DT_INT);
3383 bound.count2++;
3384 return sptr;
3385 case 3:
3386 sptr = getbnd("c", "l", bound.count3, DT_INT);
3387 bound.count3++;
3388 return sptr;
3389 case 4:
3390 sptr = getbnd("c", "u", bound.count4, DT_INT);
3391 bound.count4++;
3392 return sptr;
3393 case 5:
3394 sptr = getbnd("c", "cs", bound.count5, DT_INT);
3395 bound.count5++;
3396 return sptr;
3397 case 6:
3398 sptr = getbnd("c", "lo", bound.count6, DT_INT);
3399 bound.count6++;
3400 return sptr;
3401 case 7:
3402 sptr = getbnd("c", "ls", bound.count7, DT_INT);
3403 bound.count7++;
3404 return sptr;
3405 case 8:
3406 sptr = getbnd("i", "c", bound.count8, DT_INT);
3407 bound.count8++;
3408 return sptr;
3409 case 9:
3410 sptr = getbnd("l", "b", bound.count9, DT_INT);
3411 bound.count9++;
3412 return sptr;
3413 case 10:
3414 sptr = getbnd("u", "b", bound.count10, DT_INT);
3415 bound.count10++;
3416 return sptr;
3417 case 11:
3418 sptr = getbnd("cp", "com", bound.count11, DT_INT);
3419 bound.count11++;
3420 return sptr;
3421 case 12:
3422 sptr = getbnd("xfer", "com", bound.count12, DT_INT);
3423 bound.count12++;
3424 return sptr;
3425 default:
3426 assert(TRUE, "trans_getbound: unknown type", 0, 4);
3427 sptr = getbnd("i", "l", bound.count0, DT_INT);
3428 bound.count0++;
3429 return sptr;
3430 }
3431 }
3432
3433 /* astmem is either zero, or an A_MEM */
3434 /* astid is an A_ID */
3435 /* if astmem is zero, return astid; otherwise, return an A_MEM with
3436 * the same parent as astmem, and with astid as member */
3437 int
check_member(int astmem,int astid)3438 check_member(int astmem, int astid)
3439 {
3440 if (astmem != 0 && A_TYPEG(astmem) == A_SUBSCR) {
3441 astmem = A_LOPG(astmem);
3442 }
3443 if (astmem == 0 || A_TYPEG(astmem) != A_MEM) {
3444 int sptr, stype;
3445 /* error check */
3446 /* astid may be A_ID or A_SUBSCR */
3447 if (A_TYPEG(astid) == A_ID) {
3448 sptr = A_SPTRG(astid);
3449 } else if (A_TYPEG(astid) == A_SUBSCR) {
3450 int lop;
3451 lop = A_LOPG(astid);
3452 if (A_TYPEG(lop) != A_ID)
3453 return astid;
3454 sptr = A_SPTRG(lop);
3455 } else {
3456 return astid;
3457 }
3458 stype = STYPEG(sptr);
3459 if (stype == ST_ARRDSC) {
3460 int secdsc;
3461 secdsc = SECDSCG(sptr);
3462 if (secdsc) {
3463 stype = STYPEG(secdsc);
3464 } else {
3465 stype = STYPEG(ARRAYG(sptr));
3466 }
3467 }
3468 if (stype == ST_MEMBER && !DESCARRAYG(sptr)) {
3469 interr("check_member: cannot match member with derived type", sptr, 3);
3470 }
3471 return astid;
3472 }
3473
3474 /* In the new array/pointer runtime descriptor, the extent may be an
3475 * expression of lower bound and upper bound. Handle this case.
3476 */
3477 if (A_TYPEG(astid) == A_BINOP) {
3478 /* get the values we need, in case astb.stg_base gets reallocated! */
3479 int lop = check_member(astmem, A_LOPG(astid));
3480 int rop = check_member(astmem, A_ROPG(astid));
3481 return mk_binop(A_OPTYPEG(astid), lop, rop, A_DTYPEG(astid));
3482 }
3483
3484 /* check that the ID is a ST_MEMBER of the same datatype */
3485 if (A_TYPEG(astid) == A_ID) {
3486 return do_check_member_id(astmem, astid);
3487 }
3488 if (A_TYPEG(astid) == A_SUBSCR) {
3489 int lop = A_LOPG(astid);
3490 if (A_TYPEG(lop) != A_ID) {
3491 return astid;
3492 } else {
3493 int subs[MAXSUBS];
3494 int i;
3495 int lop2 = do_check_member_id(astmem, lop);
3496 int asd = A_ASDG(astid);
3497 int n = ASD_NDIM(asd);
3498 for (i = 0; i < n; ++i) {
3499 subs[i] = ASD_SUBS(asd, i);
3500 }
3501 return mk_subscr(lop2, subs, n, A_DTYPEG(astid));
3502 }
3503 }
3504 return astid;
3505 } /* check_member */
3506
3507 static int
do_check_member_id(int astmem,int astid)3508 do_check_member_id(int astmem, int astid)
3509 {
3510 int sptr2, checksptr;
3511 int sptr = A_SPTRG(astid);
3512 SYMTYPE stype = STYPEG(sptr);
3513 assert(A_TYPEG(astid) == A_ID, "expecting A_TYPE == A_ID",
3514 A_TYPEG(astid), ERR_Fatal);
3515 if (XBIT(58, 0x10000) && stype == ST_ARRDSC) {
3516 checksptr = ARRAYG(sptr);
3517 if (checksptr && SDSCG(checksptr)) {
3518 checksptr = SDSCG(checksptr);
3519 stype = STYPEG(checksptr);
3520 } else if (checksptr) {
3521 /* see if the array is a member and needs a local
3522 * section descriptor */
3523 DTYPE dtype = DTYPEG(checksptr);
3524 if (ALIGNG(checksptr) || DISTG(checksptr) || POINTERG(checksptr) ||
3525 ADD_DEFER(dtype) || ADD_ADJARR(dtype) || ADD_NOBOUNDS(dtype)) {
3526 stype = STYPEG(checksptr);
3527 }
3528 }
3529 } else {
3530 checksptr = sptr;
3531 }
3532 if (stype != ST_MEMBER) {
3533 return astid;
3534 }
3535 sptr2 = A_SPTRG(A_MEMG(astmem));
3536 if (ENCLDTYPEG(checksptr) != ENCLDTYPEG(sptr2)) {
3537 interr("check_member: member arrived with wrong derived type", sptr, 3);
3538 }
3539 return mk_member(A_PARENTG(astmem), astid, A_DTYPEG(astid));
3540 }
3541
3542 /* get the first symbol with the same hash link */
3543 int
first_hash(int sptr)3544 first_hash(int sptr)
3545 {
3546 char *name;
3547 int len, hashval;
3548 name = SYMNAME(sptr);
3549 len = strlen(name);
3550 HASH_ID(hashval, name, len);
3551 if (hashval < 0)
3552 hashval = -hashval;
3553 return stb.hashtb[hashval];
3554 } /* first_hash */
3555
3556 LOGICAL
has_allocattr(int sptr)3557 has_allocattr(int sptr)
3558 {
3559 int dtype;
3560 if (ALLOCATTRG(sptr))
3561 return TRUE;
3562 dtype = DTYPEG(sptr);
3563 dtype = DDTG(dtype);
3564 if (DTY(dtype) == TY_DERIVED && ALLOCFLDG(DTY(dtype + 3)))
3565 return TRUE;
3566 return FALSE;
3567 }
3568
3569 /**
3570 * \brief utility function for visiting symbols of a specified name.
3571 *
3572 * This function is used to visit symbols of a specified name. The user of
3573 * this function should first initialize the search by calling the function
3574 * with task == 0.
3575 *
3576 * After initializing the search, the user can call this function with the
3577 * same sptr and a task == 1 or task == 2. The function
3578 * will return the sptr of the next unvisited symbol based on the criteria
3579 * specified in the task argument. Below summarizes the values for task:
3580 *
3581 * If task == 0, then this function will unset the VISIT flag for all symbols
3582 * with the same name as sptr.
3583 *
3584 * If task == 1, then return symbol must have the same symbol table type
3585 * as the sptr argument.
3586 *
3587 * If task == 2, then the returned symbol can have any symbol table type.
3588 *
3589 * Caveat: Do not use this function when another phase is using the
3590 * the VISIT field. For example, during the lower phase.
3591 *
3592 * \param sptr is the symbol table pointer of the name you wish to find.
3593 * \param task is the task the function will perform (see comments above).
3594 *
3595 * \return symbol table pointer of next unvisited symbol or 0 if no more
3596 * symbols have been found.
3597 */
3598 int
get_next_hash_link(int sptr,int task)3599 get_next_hash_link(int sptr, int task)
3600 {
3601 int hash, hptr, len;
3602 char *symname;
3603
3604 if (!sptr)
3605 return 0;
3606 symname = SYMNAME(sptr);
3607 len = strlen(symname);
3608 HASH_ID(hash, symname, len);
3609 if (task == 0) {
3610 /* init visit flag for all symbols with same name as sptr */
3611 for (hptr = stb.hashtb[hash]; hptr; hptr = HASHLKG(hptr)) {
3612 if (STYPEG(hptr) == STYPEG(sptr) && strcmp(symname, SYMNAME(hptr)) == 0) {
3613 VISITP(hptr, 0);
3614 }
3615 }
3616 } else if (task == 1) {
3617 VISITP(sptr, 1);
3618 for (hptr = stb.hashtb[hash]; hptr; hptr = HASHLKG(hptr)) {
3619 if (hptr != sptr && !VISITG(hptr) && STYPEG(hptr) == STYPEG(sptr) &&
3620 strcmp(symname, SYMNAME(hptr)) == 0) {
3621 return hptr;
3622 }
3623 }
3624 } else if (task == 2) {
3625 VISITP(sptr, 1);
3626 for (hptr = stb.hashtb[hash]; hptr; hptr = HASHLKG(hptr)) {
3627 if (hptr != sptr && !VISITG(hptr) &&
3628 strcmp(symname, SYMNAME(hptr)) == 0) {
3629 return hptr;
3630 }
3631 }
3632 }
3633 return 0;
3634 }
3635
3636 /** \brief utility function for finding a symbol in the symbol table that
3637 * has a specified name.
3638 *
3639 * Note: The first symbol that meets the criteria specified in the arguments
3640 * is returned. If you need to make multiple queries of the symbol table,
3641 * consider using the function get_next_hash_link() instead.
3642 *
3643 * \param symname is a C string that specifies the name of the symbol to find
3644 * \param stype specifies a particular symbol type to find or 0 will locate
3645 * any symbol type.
3646 * \param scope specifies the scope symbol table pointer to search for the
3647 * symbol. If scope is 0 then the symbol can appear in any scope.
3648 * If scope is -1, then the first symbol that's in scope is returned.
3649 *
3650 * \return symbol table pointer of the first symbol found that meets the
3651 * criteria mentioned above; else 0.
3652 */
3653 int
findByNameStypeScope(char * symname,int stype,int scope)3654 findByNameStypeScope(char *symname, int stype, int scope)
3655 {
3656 int hash, hptr, len;
3657 len = strlen(symname);
3658 HASH_ID(hash, symname, len);
3659 for (hptr = stb.hashtb[hash]; hptr; hptr = HASHLKG(hptr)) {
3660 if ((stype == 0 || STYPEG(hptr) == stype) &&
3661 strcmp(SYMNAME(hptr), symname) == 0) {
3662 if (scope == 0 || (scope == -1 && test_scope(hptr) > 0) ||
3663 scope == SCOPEG(hptr)) {
3664 return hptr;
3665 }
3666 }
3667 }
3668 return 0;
3669 }
3670
3671 LOGICAL
is_array_sptr(int sptr)3672 is_array_sptr(int sptr)
3673 {
3674 if (sptr > NOSYM) {
3675 switch (STYPEG(sptr)) {
3676 case ST_ARRAY:
3677 return TRUE;
3678 case ST_VAR:
3679 return is_array_dtype(DTYPEG(sptr));
3680 default:
3681 return FALSE;
3682 }
3683 }
3684 return FALSE;
3685 }
3686
3687 LOGICAL
is_unl_poly(int sptr)3688 is_unl_poly(int sptr)
3689 {
3690 return sptr > NOSYM &&
3691 CLASSG(sptr) &&
3692 is_dtype_unlimited_polymorphic(DTYPEG(sptr));
3693 }
3694
3695 bool
is_impure(int sptr)3696 is_impure(int sptr)
3697 {
3698 if ((STYPEG(sptr) == ST_INTRIN || STYPEG(sptr) == ST_PD) &&
3699 INKINDG(sptr) == IK_ELEMENTAL)
3700 return false;
3701 return IMPUREG(sptr) || (!PUREG(sptr) && !ELEMENTALG(sptr));
3702 }
3703
3704 LOGICAL
needs_descriptor(int sptr)3705 needs_descriptor(int sptr)
3706 {
3707 if (sptr > NOSYM) {
3708 if (IS_PROC_DUMMYG(sptr)) {
3709 return TRUE;
3710 }
3711 if (ST_ISVAR(STYPEG(sptr)) || STYPEG(sptr) == ST_IDENT) {
3712 DTYPE dtype = DTYPEG(sptr);
3713 return ASSUMSHPG(sptr) || POINTERG(sptr) || ALLOCATTRG(sptr) ||
3714 IS_PROC_DUMMYG(sptr) ||
3715 (is_array_dtype(dtype) && ADD_ASSUMSHP(dtype));
3716 }
3717 }
3718 /* N.B. Scalar CLASS polymorphic dummy arguments get type descriptors only,
3719 * not full descriptors, as a special case in add_class_arg_descr_arg().
3720 */
3721 return FALSE;
3722 }
3723
3724 /* \brief Returns true if a procedure dummy argument needs a procedure
3725 * descriptor.
3726 *
3727 * By default, we do not use a descriptor argument for dummy arguments
3728 * declared EXTERNAL since they could be non-Fortran procedures.
3729 * If the procedure dummy argument is an interface, not declared
3730 * EXTERNAL, or a part of an internal procedure, then we assume it is a Fortran
3731 * procedure and we will use a descriptor argument.
3732 *
3733 * XBIT(54, 0x20) overrides this restriction. That is, we will always use a
3734 * procedure descriptor when XBIT(54, 0x20) is enabled.
3735 *
3736 * \param symfunc is the procedure dummy argument we are testing.
3737 *
3738 * \return true if procedure dummy needs a descriptor; else false.
3739 */
3740 bool
proc_arg_needs_proc_desc(SPTR symfunc)3741 proc_arg_needs_proc_desc(SPTR symfunc)
3742 {
3743 return IS_PROC_DUMMYG(symfunc) && (XBIT(54, 0x20) ||
3744 IS_INTERFACEG(symfunc) || !TYPDG(symfunc) || INTERNALG(gbl.currsub));
3745 }
3746
3747 /* This function encloses an idiom that appears more than once in the
3748 * Fortran front-end to follow the symbol linkage convention
3749 * used to locate descriptor members in derived types.
3750 */
3751 SPTR
get_member_descriptor(int sptr)3752 get_member_descriptor(int sptr)
3753 {
3754 SPTR mem;
3755 assert(sptr > NOSYM && STYPEG(sptr) == ST_MEMBER,
3756 "get_member_descriptor: bad member", sptr, ERR_Severe);
3757 for (mem = SYMLKG(sptr); mem > NOSYM && HCCSYMG(mem); mem = SYMLKG(mem)) {
3758 if (DESCARRAYG(mem))
3759 return mem;
3760 }
3761 return NOSYM;
3762 }
3763
3764 int
find_member_descriptor(int sptr)3765 find_member_descriptor(int sptr)
3766 {
3767 if (sptr > NOSYM && STYPEG(sptr) == ST_MEMBER &&
3768 (CLASSG(sptr) || FINALIZEDG(sptr))) {
3769 int dsc_mem = get_member_descriptor(sptr);
3770 if (dsc_mem > NOSYM && DESCARRAYG(dsc_mem))
3771 return dsc_mem;
3772 }
3773 return 0;
3774 }
3775
3776 /* Ferret out a variable's descriptor from any of the places in which
3777 * the front-end might have hidden it. Represent it as an AST
3778 * if it exists.
3779 */
3780 int
find_descriptor_ast(int sptr,int ast)3781 find_descriptor_ast(int sptr, int ast)
3782 {
3783 int desc_ast, desc_sptr;
3784
3785 if (sptr <= NOSYM)
3786 return 0;
3787 if ((desc_ast = DSCASTG(sptr)))
3788 return desc_ast;
3789 if ((desc_sptr = find_member_descriptor(sptr)) > NOSYM ||
3790 (desc_sptr = SDSCG(sptr)) > NOSYM ||
3791 (desc_sptr = DESCRG(sptr)) > NOSYM) {
3792 if (STYPEG(desc_sptr) != ST_MEMBER || ast > 0) {
3793 desc_ast = mk_id(desc_sptr);
3794 if (STYPEG(desc_sptr) == ST_MEMBER)
3795 desc_ast = check_member(ast, desc_ast);
3796 DESCUSEDP(sptr, TRUE);
3797 return desc_ast;
3798 }
3799 }
3800 if (SCG(sptr) == SC_DUMMY && CLASSG(sptr)) {
3801 /* Identify a type descriptor argument */
3802 int scope_sptr = gbl.currsub;
3803 if (gbl.internal > 0)
3804 scope_sptr = resolve_sym_aliases(SCOPEG(sptr));
3805 desc_sptr = get_type_descr_arg(scope_sptr, sptr);
3806 if (desc_sptr > NOSYM) {
3807 DESCUSEDP(sptr, TRUE);
3808 return mk_id(desc_sptr);
3809 }
3810 }
3811 return 0;
3812 }
3813
3814 /* Scan a dummy argument list for a specific symbol's name (if valid) and
3815 * return its 1-based position if it's present in the list, else 0.
3816 * Done the hard way by comparing names, ignoring case.
3817 */
3818 int
find_dummy_position(int proc_sptr,int arg_sptr)3819 find_dummy_position(int proc_sptr, int arg_sptr)
3820 {
3821 if (proc_sptr > NOSYM && arg_sptr > NOSYM) {
3822 const char *name = SYMNAME(arg_sptr);
3823 int paramct, dpdsc, iface;
3824 proc_arginfo(proc_sptr, ¶mct, &dpdsc, &iface);
3825 if (dpdsc > 0) {
3826 int j, *argument = &aux.dpdsc_base[dpdsc];
3827 for (j = 0; j < paramct; ++j) {
3828 if (argument[j] > NOSYM && strcmp(SYMNAME(argument[j]), name) == 0)
3829 return 1 + j; /* 1-based list position */
3830 }
3831 }
3832 }
3833 return 0;
3834 }
3835
3836 /* Scan the whole symbol table(!) and return the maximum value of
3837 * the INVOBJ field for every valid binding of a t.b.p. for which
3838 * the argument is an implementation without NOPASS.
3839 */
3840 int
max_binding_invobj(int impl_sptr,int invobj)3841 max_binding_invobj(int impl_sptr, int invobj)
3842 {
3843 int sptr;
3844 for (sptr = 1; sptr < stb.stg_avail; ++sptr) {
3845 if (STYPEG(sptr) == ST_MEMBER && CLASSG(sptr) &&
3846 VTABLEG(sptr) == impl_sptr && !NOPASSG(sptr)) {
3847 int bind_sptr = BINDG(sptr);
3848 if (bind_sptr > NOSYM && INVOBJG(bind_sptr) > invobj)
3849 invobj = INVOBJG(bind_sptr);
3850 }
3851 }
3852 return invobj;
3853 }
3854
3855 static LOGICAL
test_tbp_or_final(int sptr)3856 test_tbp_or_final(int sptr)
3857 {
3858 /* Subtlety: For type-bound procedures, BIND and VTABLE are nonzero,
3859 * but might be set to NOSYM (1). The FINAL field's value is documented
3860 * as being the rank of the final procedure's argument plus one, but
3861 * it can also be -1 to represent a forward reference to a final subroutine.
3862 */
3863 return sptr > NOSYM && STYPEG(sptr) == ST_MEMBER && CCSYMG(sptr) &&
3864 CLASSG(sptr) && VTABLEG(sptr) != 0;
3865 }
3866
3867 LOGICAL
is_tbp(int sptr)3868 is_tbp(int sptr)
3869 {
3870 return test_tbp_or_final(sptr) && (BINDG(sptr) != 0 || IS_TBP(sptr));
3871 }
3872
3873 LOGICAL
is_final_procedure(int sptr)3874 is_final_procedure(int sptr)
3875 {
3876 return test_tbp_or_final(sptr) && FINALG(sptr) != 0;
3877 }
3878
3879 LOGICAL
is_tbp_or_final(int sptr)3880 is_tbp_or_final(int sptr)
3881 {
3882 return is_tbp(sptr) || is_final_procedure(sptr);
3883 }
3884
3885 /** \brief create a temporary variable that holds a temporary descriptor.
3886 *
3887 * \param dtype is the data type of the temporary variable.
3888 *
3889 * \returns the temporary variable.
3890 */
3891 int
get_tmp_descr(DTYPE dtype)3892 get_tmp_descr(DTYPE dtype)
3893 {
3894 int tmpv = getcctmp_sc('d', sem.dtemps++, ST_VAR, dtype, sem.sc);
3895 if (DTY(dtype) != TY_ARRAY && !SDSCG(tmpv)) {
3896 set_descriptor_rank(1); /* force a full (true) descriptor on a scalar */
3897 get_static_descriptor(tmpv);
3898 set_descriptor_rank(0);
3899 } else if (!SDSCG(tmpv)) {
3900 get_static_descriptor(tmpv);
3901 }
3902 return tmpv;
3903 }
3904
3905 /** \brief get a temporary procedure pointer to a specified procedure.
3906 *
3907 * \param sptr is the ST_PROC pointer target.
3908 *
3909 * \returns the procedure pointer.
3910 */
3911 SPTR
get_proc_ptr(SPTR sptr)3912 get_proc_ptr(SPTR sptr)
3913 {
3914 DTYPE dtype;
3915 SPTR tmpv;
3916 int sc;
3917
3918 if (!IS_PROC(STYPEG(sptr)))
3919 return NOSYM;
3920
3921 dtype = DTYPEG(sptr);
3922 tmpv = getcctmp_sc('d', sem.dtemps++, ST_VAR, dtype, sem.sc);
3923
3924 dtype = get_type(6, TY_PROC, dtype);
3925 DTY(dtype + 2) = sptr; /* interface */
3926 DTY(dtype + 3) = PARAMCTG(sptr); /* PARAMCT */
3927 DTY(dtype + 4) = DPDSCG(sptr); /* DPDSC */
3928 DTY(dtype + 5) = FVALG(sptr); /* FVAL */
3929
3930 dtype = get_type(2, TY_PTR, dtype);
3931
3932 POINTERP(tmpv, 1);
3933 DTYPEP(tmpv, dtype);
3934 sc = get_descriptor_sc();
3935 set_descriptor_sc(SC_LOCAL);
3936 get_static_descriptor(tmpv);
3937 set_descriptor_sc(sc);
3938 return tmpv;
3939 }
3940
3941
3942 /* Build an AST that references the byte length field in a descriptor,
3943 * if it exists and can be subscripted, else return 0.
3944 */
3945 int
get_descriptor_length_ast(int descriptor_ast)3946 get_descriptor_length_ast(int descriptor_ast)
3947 {
3948 if (descriptor_ast > 0 && is_array_dtype(A_DTYPEG(descriptor_ast))) {
3949 int subs = mk_isz_cval(get_byte_len_indx(), astb.bnd.dtype);
3950 return mk_subscr(descriptor_ast, &subs, 1, astb.bnd.dtype);
3951 }
3952 return 0;
3953 }
3954
3955 /* If a symbol has a descriptor that might need its byte length field
3956 * defined, return an AST to which the length should be stored, else 0.
3957 */
3958 int
symbol_descriptor_length_ast(SPTR sptr,int ast)3959 symbol_descriptor_length_ast(SPTR sptr, int ast)
3960 {
3961 int descr_ast = find_descriptor_ast(sptr, ast);
3962 if (descr_ast > 0) {
3963 DTYPE dtype = DTYPEG(sptr);
3964 if (DT_ISCHAR(dtype) ||
3965 is_unl_poly(sptr) ||
3966 is_array_dtype(dtype)) {
3967 return get_descriptor_length_ast(descr_ast);
3968 }
3969 }
3970 return 0;
3971 }
3972
3973 /* Build an AST to characterize the length of a value.
3974 * Pass values for arguments when they're known, or the
3975 * appropriate invalid value (NOSYM, DT_NONE, &c.) when not.
3976 */
3977 int
get_value_length_ast(DTYPE value_dtype,int value_ast,SPTR sptr,DTYPE sptr_dtype,int value_descr_ast)3978 get_value_length_ast(DTYPE value_dtype, int value_ast,
3979 SPTR sptr, DTYPE sptr_dtype,
3980 int value_descr_ast)
3981 {
3982 int ast;
3983 if (value_dtype > DT_NONE) {
3984 if (is_array_dtype(value_dtype))
3985 value_dtype = array_element_dtype(value_dtype);
3986 if (DT_ISCHAR(value_dtype)) {
3987 int len = string_length(value_dtype);
3988 if (len > 0) {
3989 return mk_isz_cval(len, astb.bnd.dtype);
3990 }
3991 if ((ast = DTY(value_dtype + 1)) > 0) {
3992 return ast;
3993 }
3994 if (value_ast > 0 &&
3995 (ast = string_expr_length(value_ast)) > 0) {
3996 return ast;
3997 }
3998 }
3999 }
4000 if (sptr > NOSYM && sptr_dtype > DT_NONE &&
4001 (ast = size_ast(sptr, sptr_dtype)) > 0)
4002 return ast;
4003 return get_descriptor_length_ast(value_descr_ast);
4004 }
4005
4006 void
add_auto_len(int sym,int Lbegin)4007 add_auto_len(int sym, int Lbegin)
4008 {
4009 int dtype, cvlen;
4010 int lhs, rhs, ast, std, astif, astthen, stdif;
4011
4012 dtype = DDTG(DTYPEG(sym));
4013 if (DTY(dtype) != TY_CHAR && DTY(dtype) != TY_NCHAR)
4014 return;
4015 cvlen = CVLENG(sym);
4016 #if DEBUG
4017 assert(
4018 (DDTG(DTYPEG(sym)) != DT_DEFERCHAR && DDTG(DTYPEG(sym)) != DT_DEFERNCHAR),
4019 "set_auto_len: arg is deferred-length character", sym, 4);
4020 #endif
4021 if (cvlen == 0) {
4022 cvlen = sym_get_scalar(SYMNAME(sym), "len", DT_INT);
4023 CVLENP(sym, cvlen);
4024 ADJLENP(sym, 1);
4025 if (SCG(sym) == SC_DUMMY)
4026 CCSYMP(cvlen, 1);
4027 }
4028 /* if ERLYSPEC set,the length assignment was done earlier done */
4029 if (!ERLYSPECG(CVLENG(sym))) {
4030 lhs = mk_id(cvlen);
4031 rhs = DTyCharLength(dtype);
4032
4033 rhs = mk_convert(rhs, DTYPEG(cvlen));
4034 rhs = ast_intr(I_MAX, DTYPEG(cvlen), 2, rhs, mk_cval(0, DTYPEG(cvlen)));
4035
4036 ast = mk_assn_stmt(lhs, rhs, DTYPEG(cvlen));
4037 std = add_stmt_before(ast, Lbegin);
4038 }
4039 } /* add_auto_len */
4040
4041