1 /*
2 * Copyright (c) 1994-2019, NVIDIA CORPORATION. All rights reserved.
3 *
4 * Licensed under the Apache License, Version 2.0 (the "License");
5 * you may not use this file except in compliance with the License.
6 * You may obtain a copy of the License at
7 *
8 * http://www.apache.org/licenses/LICENSE-2.0
9 *
10 * Unless required by applicable law or agreed to in writing, software
11 * distributed under the License is distributed on an "AS IS" BASIS,
12 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13 * See the License for the specific language governing permissions and
14 * limitations under the License.
15 *
16 */
17
18 /** \file
19 \brief Utility routines used by Fortran Semantic Analyzer.
20 */
21
22 #include "gbldefs.h"
23 #include "global.h"
24 #include "gramtk.h"
25 #include "error.h"
26 #include "symtab.h"
27 #include "symutl.h"
28 #include "dtypeutl.h"
29 #include "semant.h"
30 #include "semstk.h"
31 #include "machar.h"
32 #include "ast.h"
33 #include "dinit.h"
34 #include "interf.h"
35 #include "tokdf.h"
36 #include "scan.h"
37 #include "pd.h"
38 #include "rte.h"
39 #include "state.h"
40 #include "ccffinfo.h"
41 #include "rtlRtns.h"
42
43 /*
44 * before the END for the subprogram is generated, check how/where
45 * adjustable & assumed shape arrays were declared.
46 *
47 * An assumed shape array may be declared before its ENTRY, in which
48 * case its assumed shape attribute needs to be set.
49 *
50 * The entry's assumed size, adjustable, or assumed shape flags are set
51 * if there are corresponding array arguments.
52 */
53
54 static void to_assumed_shape(int);
55 static int compute_width_dtype(DTYPE in_dtype);
56 static void compute_size(bool add_flag, ACL *aclp, DTYPE dtype);
57 static void compute_size_ast(bool add_flag, ACL *aclp, DTYPE dtype);
58 static DTYPE compute_size_expr(bool add_flag, ACL *aclp, DTYPE dtype);
59 static void compute_size_ido(bool add_flag, ACL *aclp, DTYPE dtype);
60 static void compute_size_sconst(bool add_flag, ACL *aclp, DTYPE dtype);
61 static void add_etmp(int sptr);
62 static void add_auto_array(int);
63 static void add_auto_char(int);
64 static void add_autobj(int);
65 static void put_prefix(char *, int, FILE *);
66 static void _dmp_acl(ACL *, int, FILE *);
67 static ACL *clone_init_const(ACL *original, int temp);
68 static ACL *clone_init_const_list(ACL *original, int temp);
69 static ACL *eval_init_expr_item(ACL *cur_e);
70 static ACL *eval_do(ACL *ido);
71 static INT get_default_int_val(INT);
72 static int ast_rewrite_indices(int ast);
73 static INT get_const_from_ast(int ast);
74 static ACL *eval_array_constructor(ACL *);
75 static ISZ_T get_ival(DTYPE, INT);
76 static ACL *get_exttype_struct_constructor(ACL *, DTYPE, ACL **);
77 static ACL *get_struct_default_init(int sptr);
78 static void add_alloc_mem_initialize(int);
79 static int genPolyAsn(int dest, int src, int std, int parent);
80 static void save_dim_specs(SEM_DIM_SPECS *aa);
81 static void restore_dim_specs(SEM_DIM_SPECS *aa);
82 static void dinit_constructor(SPTR, ACL *);
83 static AC_INTRINSIC map_I_to_AC(int intrin);
84 static AC_INTRINSIC map_PD_to_AC(int pdnum);
85 static bool is_illegal_expr_in_init(SPTR, int ast, DTYPE);
86 static int init_intrin_type_desc(int ast, SPTR sptr, int std);
87
88 /*
89 * semant-created temporaries which are re-used across statements.
90 */
91
92 static int temps_ctr[3];
93 #define TEMPS_CTR(n) (temps_ctr[n]++)
94 #define TEMPS_STK(n) ((sem.doif_depth << 10) + temps_ctr[n]++)
95
96 void
chk_adjarr(void)97 chk_adjarr(void)
98 {
99 int entsym;
100 int *dscptr, cnt, arg;
101 LOGICAL is_first;
102 int stype;
103
104 if (gbl.rutype != RU_FUNC && gbl.rutype != RU_SUBR)
105 return;
106 if (gbl.currsub <= NOSYM)
107 return;
108 is_first = TRUE;
109 /* scan all entries. NOTE: gbl.entries not yet set */
110 for (entsym = gbl.currsub; entsym != NOSYM; entsym = SYMLKG(entsym)) {
111 ADDRESSP(entsym, 0);
112 dscptr = aux.dpdsc_base + DPDSCG(entsym);
113 for (cnt = PARAMCTG(entsym); cnt > 0; cnt--) {
114 arg = *dscptr++;
115 if (arg == 0)
116 continue;
117 stype = STYPEG(arg);
118 /*
119 * continue processing if
120 * ST_ARRAY | (ST_DERIVED && TY_ARRAY)
121 */
122 if (stype != ST_ARRAY)
123 continue;
124 if (ALLOCG(arg) && !ALLOCATTRG(arg)) {
125 to_assumed_shape(arg);
126 }
127 if (ASSUMSHPG(arg))
128 ASSUMSHPP(entsym, 1);
129 if (ASUMSZG(arg))
130 ASUMSZP(entsym, 1);
131 if (ADJARRG(arg) || RUNTIMEG(arg)) {
132 ADJARRP(entsym, 1); /* tell expand adj. arrays in entry */
133 if (!is_first || AFTENTG(arg))
134 AFTENTP(entsym, 1); /* tell expand adj. code generated */
135 }
136 }
137 /*
138 * repeat for any adjustable arrays which are pointers-based
139 * objects.
140 */
141 for (arg = gbl.p_adjarr; arg > NOSYM; arg = SYMLKG(arg)) {
142 if (SCG(arg) == SC_BASED && (ADJARRG(arg) || RUNTIMEG(arg))) {
143 ADJARRP(entsym, 1); /* tell expand adj. arrays in entry */
144 if (!is_first || AFTENTG(arg))
145 AFTENTP(entsym, 1); /* tell expand adj. code generated */
146 }
147 }
148 is_first = FALSE;
149 }
150 }
151
152 static void
to_assumed_shape(int arg)153 to_assumed_shape(int arg)
154 {
155 ADSC *ad;
156 int ndim;
157 int i;
158
159 AFTENTP(arg, 1);
160 ASSUMSHPP(arg, 1);
161 if (!XBIT(54, 2) && !XBIT(58, 0x400000))
162 SDSCS1P(arg, 1);
163 ALLOCP(arg, 0);
164 ad = AD_DPTR(DTYPEG(arg));
165 AD_ASSUMSHP(ad) = 1;
166 /* change the lower bound if one was not specifier. */
167 ndim = AD_NUMDIM(ad);
168 for (i = 0; i < ndim; i++)
169 if (AD_LWBD(ad, i) == AD_LWAST(ad, i) && !XBIT(54, 2) &&
170 !XBIT(58, 0x400000))
171 AD_LWBD(ad, i) = astb.bnd.one;
172 }
173
174 /** \brief Return TRUE if the expression at 'ast' is composed of constants
175 and the special symbol 'hpf_np$'. In this case, even though the
176 bound is not a literal constant, it is a runtime constant.
177 */
178 int
runtime_array(int ast)179 runtime_array(int ast)
180 {
181 int sym;
182 #if DEBUG
183 if (DBGBIT(3, 32))
184 fprintf(gbl.dbgfil, "runtime_array(ast=%d)\n", ast);
185 #endif
186 if (!ast)
187 return TRUE;
188 switch (A_TYPEG(ast)) {
189 case A_ID:
190 /* check for named parameter, or hpf_np$ */
191 sym = A_SPTRG(ast);
192 if (sym == gbl.sym_nproc) {
193 return TRUE;
194 }
195 if (STYPEG(sym) == ST_CONST || STYPEG(sym) == ST_PARAM) {
196 return TRUE;
197 }
198 break;
199 case A_CNST:
200 return TRUE;
201 case A_BINOP:
202 if (runtime_array(A_LOPG(ast)) && runtime_array(A_ROPG(ast))) {
203 return TRUE;
204 }
205 break;
206 case A_UNOP:
207 case A_PAREN:
208 if (runtime_array(A_LOPG(ast))) {
209 return TRUE;
210 }
211 break;
212 } /* switch */
213 #if DEBUG
214 if (DBGBIT(3, 32))
215 fprintf(gbl.dbgfil, "runtime_array(ast=%d): NO\n", ast);
216 #endif
217 return FALSE;
218 } /* runtime_array */
219
220 /* Checks to see if array bound ast is an expression that uses a type parameter.
221 * This function is mirrored in lowersym.c
222 */
223 static int
valid_kind_parm_expr(int ast)224 valid_kind_parm_expr(int ast)
225 {
226 int sptr, rslt, i;
227
228 if (!ast)
229 return 0;
230
231 switch (A_TYPEG(ast)) {
232 case A_INTR:
233 switch (A_OPTYPEG(ast)) {
234 case I_INT1:
235 case I_INT2:
236 case I_INT4:
237 case I_INT8:
238 case I_INT:
239 i = A_ARGSG(ast);
240 return valid_kind_parm_expr(ARGT_ARG(i, 0));
241 }
242 break;
243 case A_CNST:
244 return 1;
245 case A_MEM:
246 sptr = memsym_of_ast(ast);
247 if (KINDG(sptr))
248 return 1;
249 return 0;
250 case A_ID:
251 sptr = A_SPTRG(ast);
252 if (KINDG(sptr))
253 return 1;
254 return 0;
255 case A_CONV:
256 case A_UNOP:
257 return valid_kind_parm_expr(A_LOPG(ast));
258 case A_BINOP:
259 rslt = valid_kind_parm_expr(A_LOPG(ast));
260 if (!rslt)
261 return 0;
262 rslt = valid_kind_parm_expr(A_ROPG(ast));
263 if (!rslt)
264 return 0;
265 return 1;
266 }
267 return 0;
268 }
269
270 /*----------------------------------------------------------------------
271 * _mk_arrdsc:
272 * A dimension list has been parsed and all bounds information has been
273 * deposited into a few semant global data structures. From this
274 * information, create an array record along with the array's array
275 * descriptor, and return the pointer to the array data record.
276 * The contents of the array record are as follows:
277 *
278 * Deferred / assumed-shape arrays:
279 * --------------------------------
280 * AD_LWBD == AD_LWAST, and AD_UPBD == AD_UPAST:
281 * = AST of compiler-generated temp vars, *except*:
282 * -- in a module they're undefined;
283 * -- if the lower bound is explicit (assumed shape array),
284 * AD_LWBD = AST of lower bound = sem.bounds[i].lwast,
285 * and the others are as above.
286 *
287 * Explicit-shape arrays:
288 * ----------------------
289 * AD_LWBD / AD_UPBD:
290 * = sem.bounds[i].lwast / upast
291 * = AST of lower / upper bound as it appears in the program.
292 * AD_LWBD = NULL for default lower bound.
293 * AD_UPBD = NULL for '*' (assumed size).
294 *
295 * AD_LWAST / AD_UPAST:
296 * = AST of lower / upper bound, *except*:
297 * -- if the bound is non-constant and we're not in a module,
298 * it's the AST of a compiler-generated temp var;
299 * -- AD_UPAST = NULL for '*' (assumed size).
300 */
301 static DTYPE
_mk_arrdsc(int start_of_base)302 _mk_arrdsc(int start_of_base)
303 {
304 DTYPE dtype;
305 ISZ_T last_mp, last_lb, last_ub, zbase;
306 LOGICAL last_mp_const, last_lb_const, last_ub_const, zbase_const;
307 ADSC *ad;
308 int i;
309 int adjarr, runtime;
310 int ast;
311 LOGICAL need_temps, struct_base_dim;
312
313 need_temps = TRUE;
314 /*
315 * don't create any bounds temps if in a module specification or
316 * if within an interface block in the module specification
317 */
318 if (IN_MODULE_SPEC || (IN_MODULE && sem.interface &&
319 sem.interf_base[sem.interface - 1].currsub == 0))
320 need_temps = FALSE;
321
322 /* adjustable array for interface we need temp */
323 if (need_temps == FALSE && sem.interface)
324 need_temps = TRUE;
325
326 dtype = get_array_dtype(sem.arrdim.ndim, DT_NONE);
327 ad = AD_DPTR(dtype);
328
329 /* these inits shut lint up */
330 last_lb_const = last_ub_const = 0;
331 last_lb = last_ub = 0;
332
333 if (sem.arrdim.ndefer) {
334 /* A deferred or assumed-shape array.
335 * sem.bounds[i] is defined as follows:
336 *
337 * bounds lowtype lowb lwast uptype upb upast
338 * ----------------------------------------------------------
339 * ( : ) S_NULL -- -- -- -- --
340 * (<e>: ) S_EXPR -- <ast> -- -- --
341 * ----------------------------------------------------------
342 */
343 if (sem.arrdim.ndefer != sem.arrdim.ndim) {
344 errsev(152);
345 sem.arrdim.ndefer = 0;
346 }
347 if (need_temps) {
348 /* Create temporaries for the lower and upper bounds,
349 * the multipliers, and the zero base offset.
350 */
351 for (i = 0;; i++) {
352 int lowtype;
353 if (i == 0)
354 last_mp = astb.bnd.one;
355 else
356 last_mp = mk_bnd_ast();
357 AD_MLPYR(ad, i) = last_mp;
358
359 if (i == sem.arrdim.ndim)
360 break; /* -- loop exit point-- */
361
362 lowtype = sem.bounds[i].lowtype;
363 if (i < start_of_base) { /* normal case */
364 if (lowtype != S_EXPR) {
365 AD_LWBD(ad, i) = AD_LWAST(ad, i) = mk_bnd_ast();
366 } else {
367 AD_LWBD(ad, i) = sem.bounds[i].lwast;
368 AD_LWAST(ad, i) = mk_bnd_ast();
369 AD_ASSUMSHP(ad) = 1;
370 }
371 AD_UPBD(ad, i) = AD_UPAST(ad, i) = mk_bnd_ast();
372 } else { /* in a structure base */
373 AD_LWBD(ad, i) = sem.bounds[i].lowb;
374 AD_LWAST(ad, i) = sem.bounds[i].lwast;
375 AD_UPBD(ad, i) = sem.bounds[i].upb;
376 AD_UPAST(ad, i) = sem.bounds[i].upast;
377 if (lowtype == S_EXPR)
378 AD_ASSUMSHP(ad) = 1;
379 }
380 last_lb = AD_LWAST(ad, i);
381 last_ub = AD_UPAST(ad, i);
382 }
383 AD_ZBASE(ad) = mk_bnd_ast();
384 } else {
385 /* temps aren't created for the bounds; just propagate any
386 * assumed-shape lower bounds.
387 */
388 for (i = 0; i < sem.arrdim.ndim; i++) {
389 if (sem.bounds[i].lowtype == S_EXPR) {
390 AD_LWBD(ad, i) = sem.bounds[i].lwast;
391 AD_ASSUMSHP(ad) = 1;
392 }
393 }
394 }
395 for (i = 0; i < sem.arrdim.ndim; i++) {
396 AD_EXTNTAST(ad, i) =
397 mk_shared_extent(AD_LWAST(ad, i), AD_UPAST(ad, i), i);
398 }
399 AD_NOBOUNDS(ad) = AD_DEFER(ad) = 1;
400 return dtype;
401 }
402
403 adjarr = runtime = 0;
404 for (i = 0; i < sem.arrdim.ndim; i++) {
405 if (sem.bounds[i].lowtype == S_EXPR) {
406 if (chk_len_parm_expr(sem.bounds[i].lwast, sem.stag_dtype, 1) ||
407 chk_kind_parm_expr(sem.bounds[i].lwast, sem.stag_dtype, 1, 0)) {
408 need_temps = FALSE;
409 }
410 if (!adjarr && runtime_array(sem.bounds[i].lwast))
411 ++runtime;
412 else
413 ++adjarr;
414 }
415 if (sem.bounds[i].uptype == S_EXPR) {
416 if (chk_len_parm_expr(sem.bounds[i].upast, sem.stag_dtype, 1) ||
417 chk_kind_parm_expr(sem.bounds[i].upast, sem.stag_dtype, 1, 0)) {
418 need_temps = FALSE;
419 }
420 if (!adjarr && runtime_array(sem.bounds[i].upast))
421 ++runtime;
422 else
423 ++adjarr;
424 }
425 }
426 if (adjarr)
427 AD_ADJARR(ad) = 1;
428
429 zbase_const = TRUE;
430 zbase = 0;
431 for (i = 0;; i++) {
432 /* compute multiplier for this dimension: */
433
434 if (i == 0) {
435 last_mp = 1;
436 AD_MLPYR(ad, 0) = astb.bnd.one;
437 last_mp_const = TRUE;
438 } else if (last_mp_const && last_lb_const && last_ub_const) {
439 last_mp = last_mp * (last_ub - last_lb + 1);
440 AD_MLPYR(ad, i) = mk_isz_cval(last_mp, astb.bnd.dtype);
441 } else if (!last_ub_const && last_ub == 0)
442 AD_MLPYR(ad, i) = 0;
443 else {
444 /* don't generate an expression, use a temporary */
445 if (AD_LWAST(ad, i - 1) == astb.bnd.one &&
446 AD_MLPYR(ad, i - 1) == astb.bnd.one && last_ub) {
447 last_mp = last_ub;
448 last_mp_const = last_ub_const;
449 } else {
450 ast = mk_mlpyr_expr(AD_LWAST(ad, i - 1), AD_UPAST(ad, i - 1),
451 AD_MLPYR(ad, i - 1));
452 last_mp = mk_shared_bnd_ast(ast);
453 last_mp_const = FALSE;
454 }
455 AD_MLPYR(ad, i) = last_mp;
456 }
457 if (i == sem.arrdim.ndim)
458 break; /* ----- loop exit point ----- */
459
460 /* Process lower bound for this dimension.
461 * sem.bounds[i] is defined as follows:
462 *
463 * lower-bound lowtype lowb lwast
464 * --------------------------------------------------------------
465 * <NULL> S_CONST 1 0 (!)
466 * <literal or named const> S_CONST <const-val> <ast>
467 * <non const expr> S_EXPR 1 (!) <ast>
468 * --------------------------------------------------------------
469 */
470
471 struct_base_dim = (i >= start_of_base);
472 last_lb = sem.bounds[i].lowb;
473 last_lb_const = (sem.bounds[i].lowtype != S_EXPR);
474
475 AD_LWBD(ad, i) = struct_base_dim ? sem.bounds[i].lowb : sem.bounds[i].lwast;
476
477 switch (sem.bounds[i].lowtype) {
478 case S_EXPR:
479 if (need_temps)
480 /* create a temp for this bound */
481 if (A_TYPEG(sem.bounds[i].lwast) == A_CONV &&
482 valid_kind_parm_expr(sem.bounds[i].lwast)) {
483 AD_LWAST(ad, i) = last_lb =
484 struct_base_dim ? A_LOPG(sem.bounds[i].lwast)
485 : mk_shared_bnd_ast(sem.bounds[i].lwast);
486 } else
487 AD_LWAST(ad, i) = last_lb =
488 struct_base_dim ? mk_bnd_int(sem.bounds[i].lwast)
489 : mk_shared_bnd_ast(sem.bounds[i].lwast);
490 else {
491 /* don't create a temp; the bound is what was declared */
492 if (A_TYPEG(sem.bounds[i].lwast) == A_CONV &&
493 valid_kind_parm_expr(sem.bounds[i].lwast)) {
494 AD_LWAST(ad, i) = A_LOPG(sem.bounds[i].lwast);
495 } else
496 AD_LWAST(ad, i) = mk_bnd_int(sem.bounds[i].lwast);
497 last_lb = astb.bnd.one;
498 }
499 break;
500 default:
501 /* S_CONST: this lower bound is a constant. */
502 AD_LWAST(ad, i) = (sem.bounds[i].lowb == 1)
503 ? astb.bnd.one
504 : mk_bnd_int(sem.bounds[i].lwast);
505 break;
506 }
507
508 if (zbase_const && last_lb_const && last_mp_const)
509 zbase = zbase + sem.bounds[i].lowb * last_mp;
510 else
511 zbase_const = FALSE;
512
513 /* Process upper bound for this dimension.
514 * sem.bounds[i] is defined as follows:
515 *
516 * upper-bound uptype upb upast
517 * --------------------------------------------------------------
518 * * S_STAR 0 0
519 * <literal or named const> S_CONST <const-val> <ast>
520 * <non const expr> S_EXPR 1 (!) <ast>
521 * --------------------------------------------------------------
522 */
523 last_ub = sem.bounds[i].upb;
524 last_ub_const = (sem.bounds[i].uptype == S_CONST);
525
526 AD_UPBD(ad, i) = struct_base_dim ? sem.bounds[i].upb
527 : sem.bounds[i].upast; /* 0 for '*'*/
528 switch (sem.bounds[i].uptype) {
529 case S_EXPR:
530 if (need_temps)
531 /* create a temp for this bound */
532 if (A_TYPEG(sem.bounds[i].upast) == A_CONV &&
533 valid_kind_parm_expr(sem.bounds[i].upast)) {
534 AD_UPAST(ad, i) = last_ub =
535 struct_base_dim ? A_LOPG(sem.bounds[i].upast)
536 : mk_shared_bnd_ast(sem.bounds[i].upast);
537 } else
538 AD_UPAST(ad, i) = last_ub =
539 struct_base_dim ? mk_bnd_int(sem.bounds[i].upast)
540 : mk_shared_bnd_ast(sem.bounds[i].upast);
541 else {
542 /* don't create a temp; the bound is what was declared */
543 if (A_TYPEG(sem.bounds[i].upast) == A_CONV &&
544 valid_kind_parm_expr(sem.bounds[i].upast)) {
545 AD_UPAST(ad, i) = A_LOPG(sem.bounds[i].upast);
546 } else
547 AD_UPAST(ad, i) = mk_bnd_int(sem.bounds[i].upast);
548 last_ub = astb.bnd.one;
549 }
550 break;
551 case S_CONST:
552 /* this upper bound is a constant. */
553 AD_UPAST(ad, i) = mk_bnd_int(sem.bounds[i].upast);
554 break;
555 default:
556 /* S_STAR: "*" was specified for this upper bound. */
557 if (i + 1 != sem.arrdim.ndim)
558 error(48, 3, gbl.lineno, CNULL, CNULL);
559 AD_UPAST(ad, i) = sem.bounds[i].upast; /* == NULL */
560 AD_ASSUMSZ(ad) = 1;
561 break;
562 }
563
564 AD_EXTNTAST(ad, i) = mk_shared_extent(AD_LWAST(ad, i), AD_UPAST(ad, i), i);
565 } /* end of for loop */
566
567 if (!need_temps && (adjarr || runtime) && sem.interface) {
568 AD_NUMELM(ad) = 0;
569 }
570
571 if (zbase_const)
572 AD_ZBASE(ad) = mk_isz_cval(zbase, astb.bnd.dtype);
573 else {
574 ast = mk_zbase_expr(ad);
575 AD_ZBASE(ad) = mk_shared_bnd_ast(ast);
576 }
577 return dtype;
578 }
579
580 DTYPE
mk_arrdsc(void)581 mk_arrdsc(void)
582 {
583 return _mk_arrdsc(99);
584 }
585
586 static void
save_dim_specs(SEM_DIM_SPECS * aa)587 save_dim_specs(SEM_DIM_SPECS *aa)
588 {
589 if (sem.in_dim) {
590 BCOPY(aa, &sem.bounds[0], struct _sem_bounds, MAXDIMS);
591 aa->arrdim = sem.arrdim;
592 }
593 }
594
595 static void
restore_dim_specs(SEM_DIM_SPECS * aa)596 restore_dim_specs(SEM_DIM_SPECS *aa)
597 {
598 if (sem.in_dim) {
599 BCOPY(&sem.bounds[0], aa, struct _sem_bounds, MAXDIMS);
600 sem.arrdim = aa->arrdim;
601 }
602 }
603
604 /** \brief Process an explicit shape list has been parsed and all bounds
605 information has been deposited into a few semant global data
606 structures.
607 \param sptr sptr of the deferred array
608 \param astparent ast of the parent pointer
609 \param savedelete ?
610
611 From this collection of information:
612 + Generate assignments which define the lower and upper bounds for the
613 deferred array; where the bounds are stored (asts) are located in the
614 array descriptor.
615 + Create a subscript AST which is used to represent the explicit shape;
616 the bounds for the explicit shape use the bounds asts which are the
617 destinations of the generated assignments; note that each subscript
618 is represented as a triple.
619 */
620 int
gen_defer_shape(int sptr,int astparent,int savedelete)621 gen_defer_shape(int sptr, int astparent, int savedelete)
622 {
623 int dt;
624 int numdim;
625 int subs[MAXDIMS];
626 int i;
627 int ast, std;
628 int src, lb, ub;
629 int extent;
630 ITEM *itemp;
631
632 dt = DTYPEG(sptr);
633 numdim = ADD_NUMDIM(dt);
634 for (i = 0; i < numdim; i++) {
635 if (sem.bounds[i].lwast)
636 src = sem.bounds[i].lwast;
637 else
638 src = astb.bnd.one;
639 if (ADD_DEFER(dt)) {
640
641 lb = ADD_LWBD(dt, i);
642 } else {
643 lb = ADD_LWAST(dt, i);
644 }
645 if (lb && A_TYPEG(lb) != A_CNST) {
646 ast = mk_assn_stmt(check_member(astparent, lb), src, astb.bnd.dtype);
647 std = add_stmt(ast);
648 ASSNP(sym_of_ast(lb), 1);
649 if (savedelete) {
650 itemp = (ITEM *)getitem(1, sizeof(ITEM));
651 itemp->ast = mk_id(sptr);
652 itemp->t.ilm = std;
653 itemp->next = sem.p_dealloc_delete;
654 sem.p_dealloc_delete = itemp;
655 }
656 }
657
658 if (ADD_DEFER(dt)) {
659 ub = ADD_UPBD(dt, i);
660 } else {
661 ub = ADD_UPAST(dt, i);
662 }
663 if (ub && A_TYPEG(ub) != A_CNST) {
664 int ext, useub;
665 useub = sem.bounds[i].upast;
666 if (A_TYPEG(ub) == A_ID || A_TYPEG(ub) == A_SUBSCR) {
667 ast = mk_assn_stmt(check_member(astparent, ub), sem.bounds[i].upast,
668 astb.bnd.dtype);
669 std = add_stmt(ast);
670 ASSNP(sym_of_ast(ub), 1);
671 if (savedelete) {
672 itemp = (ITEM *)getitem(1, sizeof(ITEM));
673 itemp->ast = mk_id(sptr);
674 itemp->t.ilm = std;
675 itemp->next = sem.p_dealloc_delete;
676 sem.p_dealloc_delete = itemp;
677 }
678 useub = ub;
679 }
680
681 /* Need to make an assignment to the extent also */
682 if (src == astb.bnd.one) {
683 extent = useub;
684 } else {
685 extent =
686 mk_extent_expr(check_member(astparent, lb), sem.bounds[i].upast);
687 }
688 ext = ADD_EXTNTAST(dt, i);
689 if (A_TYPEG(ext) == A_ID || A_TYPEG(ext) == A_SUBSCR) {
690 ast = mk_assn_stmt(check_member(astparent, ext),
691 check_member(astparent, extent), astb.bnd.dtype);
692
693 std = add_stmt(ast);
694 ASSNP(sym_of_ast(ADD_EXTNTAST(dt, i)), 1);
695 if (savedelete) {
696 itemp = (ITEM *)getitem(1, sizeof(ITEM));
697 itemp->ast = mk_id(sptr);
698 itemp->t.ilm = std;
699 itemp->next = sem.p_dealloc_delete;
700 sem.p_dealloc_delete = itemp;
701 }
702 }
703 }
704 }
705
706 for (i = 0; i < sem.arrdim.ndim; i++) {
707 if (ADD_DEFER(dt)) {
708 lb = ADD_LWBD(dt, i);
709 ub = ADD_UPBD(dt, i);
710 } else {
711 lb = ADD_LWAST(dt, i);
712 ub = ADD_UPAST(dt, i);
713 }
714 if (lb == 0)
715 lb = astb.bnd.one;
716 subs[i] =
717 mk_triple(check_member(astparent, lb), check_member(astparent, ub), 0);
718 }
719 ast = check_member(astparent, mk_id(sptr));
720 ast = mk_subscr(ast, subs, sem.arrdim.ndim, (int)DTYPEG(sptr));
721
722 return ast;
723 }
724
725 void
add_p_dealloc_item(int sptr)726 add_p_dealloc_item(int sptr)
727 {
728 int depth;
729 ITEM *itemp;
730
731 if (sem.use_etmps) {
732 /* Add allocatable temps created for an expression to the 'etmp'
733 * list; they need to deallocated at the end of processing the
734 * expression.
735 */
736 add_etmp(sptr);
737 return;
738 }
739
740 /* Don't add it twice */
741 for (itemp = sem.p_dealloc; itemp; itemp = itemp->next)
742 if (A_SPTRG(itemp->ast) == sptr)
743 return;
744
745 for (depth = sem.doif_depth; depth > 0 && DI_ID(depth) == DI_FORALL; --depth)
746 ;
747
748 itemp = (ITEM *)getitem(1, sizeof(ITEM));
749 itemp->ast = mk_id(sptr);
750 itemp->next = sem.p_dealloc;
751 itemp->t.conval = depth;
752 sem.p_dealloc = itemp;
753 }
754
755
756 /** \brief Generate deallocates for the temporary arrays in the sem.p_delloc
757 * list.
758 */
759 void
gen_deallocate_arrays()760 gen_deallocate_arrays()
761 {
762 if (sem.p_dealloc) {
763 ITEM *p, *t;
764 int depth;
765 for (depth = sem.doif_depth; depth > 0 && DI_ID(depth) == DI_FORALL;
766 --depth)
767 ;
768 p = NULL; /* p points to last item on remaining list */
769 for (t = sem.p_dealloc; t; t = t->next) {
770 if (t->t.conval == depth) {
771 (void)gen_alloc_dealloc(TK_DEALLOCATE, t->ast, 0);
772 } else {
773 /* leave on the list */
774 if (p != NULL) {
775 p->next = t;
776 } else {
777 sem.p_dealloc = t;
778 }
779 p = t;
780 }
781 }
782 /* p points to last item on remaining list, if any */
783 if (p) {
784 p->next = NULL;
785 } else {
786 sem.p_dealloc = NULL;
787 }
788 }
789 }
790
791 /*
792 * For certain expression, such as if expressions, it's necessary to keep
793 * a list of any allocatable temps created while processing the expression.
794 * These temps, if they're deallocated at the end of the statement a memory
795 * leak may occur because the statement may actually change the control
796 * flow. These temps must be deallocated at the end of the processing
797 * the expression.
798 */
799 static void
add_etmp(int sptr)800 add_etmp(int sptr)
801 {
802 ITEM *x;
803
804 x = (ITEM *)getitem(0, sizeof(ITEM));
805 x->next = sem.etmp_list;
806 sem.etmp_list = x;
807 x->t.sptr = sptr;
808 }
809
810 void
mk_defer_shape(SPTR sptr)811 mk_defer_shape(SPTR sptr)
812 {
813 int i;
814 int dt;
815 int numdim;
816 ADSC *ad;
817
818 dt = DTYPEG(sptr);
819 ad = AD_DPTR(dt);
820 numdim = AD_NUMDIM(ad);
821
822 if (AD_LWAST(ad, 0))
823 return;
824
825 if (IN_MODULE_SPEC)
826 MDALLOCP(sptr, 1); /* mark global allocatable array */
827 else
828 for (i = 0; i < numdim; i++) {
829 AD_LWAST(ad, i) = mk_bnd_ast();
830 AD_UPAST(ad, i) = mk_bnd_ast();
831 AD_EXTNTAST(ad, i) = mk_bnd_ast();
832 }
833 }
834
835 /*
836 * return '1' if astx is a A_ID of a compiler-created temp
837 */
838 static int
tempvar(int astx)839 tempvar(int astx)
840 {
841 if (A_TYPEG(astx) == A_ID &&
842 (CCSYMG(A_SPTRG(astx)) || HCCSYMG(A_SPTRG(astx))))
843 return 1;
844 return 0;
845 } /* tempvar */
846
847 void
mk_assumed_shape(SPTR sptr)848 mk_assumed_shape(SPTR sptr)
849 {
850 int i;
851 DTYPE dt = DTYPEG(sptr);
852 ADSC *ad = AD_DPTR(dt);
853 int numdim = AD_NUMDIM(ad);
854
855 for (i = 0; i < numdim; i++)
856 if (AD_LWBD(ad, i) == AD_LWAST(ad, i) &&
857 A_TYPEG(AD_LWBD(ad, i)) != A_CNST && tempvar(AD_LWBD(ad, i)) &&
858 !XBIT(54, 2) && !XBIT(58, 0x400000)) {
859 AD_LWBD(ad, i) = astb.bnd.one;
860 AD_LWAST(ad, i) = astb.bnd.one;
861 }
862 AD_ASSUMSHP(ad) = 1;
863 }
864
865 /** \brief Get a compiler array temporary of type dtype which is used to
866 represent array constants.
867 */
868 SPTR
get_arr_const(DTYPE dtype)869 get_arr_const(DTYPE dtype)
870 {
871 static int iavl;
872 /* stype will get changed to ST_ARRAY when it's dinit'd */
873 SPTR sptr = getcctmp('c', iavl++, ST_UNKNOWN, dtype);
874 SCP(sptr, SC_LOCAL);
875 NODESCP(sptr, 0);
876 return sptr;
877 }
878
879 DTYPE
select_kind(DTYPE dtype,int ty,INT kind_val)880 select_kind(DTYPE dtype, int ty, INT kind_val)
881 {
882 int out_dtype;
883
884 if (kind_val < 0) {
885 error(81, 3, gbl.lineno, "- KIND value must be non-negative", CNULL);
886 return dtype;
887 }
888 out_dtype = -1;
889 switch (ty) {
890 case TY_INT:
891 case TY_INT8:
892 switch (kind_val) {
893 case 8:
894 if (!XBIT(57, 0x2))
895 out_dtype = DT_INT8;
896 break;
897 case 4:
898 out_dtype = DT_INT4;
899 break;
900 case 2:
901 out_dtype = DT_SINT;
902 break;
903 case 1:
904 out_dtype = DT_BINT;
905 break;
906 }
907 break;
908 case TY_CMPLX:
909 case TY_DCMPLX:
910 switch (kind_val) {
911 case 16:
912 if (!XBIT(57, 0x8))
913 out_dtype = DT_QCMPLX;
914 if (XBIT(57, 0x10)) {
915 error(437, 2, gbl.lineno, "COMPLEX(16)", "COMPLEX(8)");
916 out_dtype = DT_CMPLX16;
917 }
918 break;
919 case 8:
920 out_dtype = DT_CMPLX16;
921 break;
922 case 4:
923 out_dtype = DT_CMPLX8;
924 break;
925 }
926 break;
927 case TY_REAL:
928 case TY_DBLE:
929 switch (kind_val) {
930 case 16:
931 if (!XBIT(57, 0x4))
932 out_dtype = DT_QUAD;
933 if (XBIT(57, 0x10)) {
934 error(437, 2, gbl.lineno, "REAL(16)", "REAL(8)");
935 out_dtype = DT_REAL8;
936 }
937 break;
938 case 8:
939 out_dtype = DT_REAL8;
940 break;
941 case 4:
942 out_dtype = DT_REAL4;
943 break;
944 }
945 break;
946 case TY_LOG:
947 case TY_LOG8:
948 switch (kind_val) {
949 case 8:
950 if (!XBIT(57, 0x2))
951 out_dtype = DT_LOG8;
952 break;
953 case 4:
954 out_dtype = DT_LOG4;
955 break;
956 case 2:
957 out_dtype = DT_SLOG;
958 break;
959 case 1:
960 out_dtype = DT_BLOG;
961 break;
962 }
963 break;
964 case TY_CHAR:
965 if (kind_val == 2)
966 out_dtype = DT_NCHAR;
967 if (kind_val == 1)
968 out_dtype = DT_CHAR;
969 break;
970 default:
971 error(81, 3, gbl.lineno, "- KIND = specified with a non-intrinsic type",
972 CNULL);
973 return dtype;
974 }
975 if (out_dtype == -1) {
976 error(81, 3, gbl.lineno, "- KIND parameter has unknown value for data type",
977 CNULL);
978 return dtype;
979 }
980 return out_dtype;
981 }
982
983 typedef struct {
984 LOGICAL is_const;
985 INT scalar_cnt; /* # of scalar expressions */
986 int aggr_cnt; /* ast expr of # of elements in implied do or array
987 expression. */
988 int eltype; /* element dtype */
989 int zln; /* element dtype is zero length char */
990 int arrtype; /* array dtype record */
991 int tmp; /* sptr of temp array */
992 int tmpid; /* id ast of array tmp */
993 int subs[MAXDIMS]; /* current subscripts - used in _construct() */
994 int indx[MAXDIMS]; /* current subscript value */
995 INT element_cnt[MAXDIMS]; /* # of scalar expressions */
996 int indx_tmpid[MAXDIMS]; /* id ast of subscripting temporary */
997 int level; /* implied do nesting level */
998 int width;
999 } _ACS;
1000
1001 static _ACS acs;
1002 static LOGICAL _can_fold(int);
1003 static void constructf90(int, ACL *);
1004 static void _dinit_acl(ACL *, LOGICAL);
1005
1006 static int acl_array_num = 0;
1007
1008 static char *_iexpr_op[] = {
1009 "?0?", "ADD", "SUB", "MUL", "DIV", "EXP", "NEG",
1010 "INTR_CALL", "ARRAYREF", "MEMBR_SEL", "CONV", "CAT", "EXPK", "LEQV",
1011 "LNEQV", "LOR", "LAND", "EQ", "GE", "GT", "LE",
1012 "LT", "NE", "LNOT", "EXPX", "TRIPLE",
1013 };
1014
1015 static char *
iexpr_op(int op)1016 iexpr_op(int op)
1017 {
1018 if (op <= sizeof(_iexpr_op) / sizeof(char *))
1019 return _iexpr_op[op];
1020 return "?N?";
1021 }
1022
1023 /** \brief Given an allocatable array and an explicit shape list which has been
1024 deposited in the semant 'bounds' structure, generate assignments to
1025 the arrays bounds temporaries, and allocate the array. Save the id
1026 ast
1027 of the array for an ensuing deallocate of the array.
1028 */
1029 void
gen_allocate_array(int arr)1030 gen_allocate_array(int arr)
1031 {
1032 int alloc_obj = gen_defer_shape(arr, 0, arr);
1033 if (is_deferlenchar_dtype(acs.arrtype)) {
1034 get_static_descriptor(arr);
1035 get_all_descriptors(arr);
1036 }
1037 gen_alloc_dealloc(TK_ALLOCATE, alloc_obj, 0);
1038 add_p_dealloc_item(arr);
1039 }
1040
1041 #if DEBUG
1042 static void
_printacl(int in_array,ACL * aclp,FILE * f)1043 _printacl(int in_array, ACL *aclp, FILE *f)
1044 {
1045 SST *stkp;
1046 ACL *member_aclp;
1047 DTYPE dtype;
1048 int sptr;
1049 int save_array_num;
1050
1051 /* print a list of aclps */
1052
1053 for (; aclp != NULL; aclp = aclp->next) {
1054 switch (aclp->id) {
1055 case AC_AST:
1056 fprintf(f, "%d:", acl_array_num);
1057 fprintf(f, "ast%d", aclp->u1.ast);
1058 dtype = A_DTYPEG(aclp->u1.ast);
1059 if (!in_array)
1060 acl_array_num += compute_width_dtype(dtype);
1061 break;
1062 case AC_EXPR:
1063 fprintf(f, "%d:", acl_array_num);
1064 stkp = aclp->u1.stkp;
1065 dtype = SST_DTYPEG(stkp);
1066 switch (SST_IDG(stkp)) {
1067 case S_ACONST:
1068 fprintf(f, "missed aconst");
1069 break;
1070 case S_CONST:
1071 fprintf(f, "const");
1072 break;
1073 case S_SCONST:
1074 fprintf(f, "missed sconst");
1075 break;
1076 case S_EXPR:
1077 fprintf(f, "expr");
1078 break;
1079 case S_IDENT:
1080 fprintf(f, "ident");
1081 break;
1082 default:
1083 fprintf(f, "?SST_ID%d", SST_IDG(stkp));
1084 break;
1085 }
1086 if (!in_array)
1087 acl_array_num += compute_width_dtype(dtype);
1088 break;
1089 case AC_ACONST:
1090 fprintf(f, "(/");
1091 _printacl(1, aclp->subc, f);
1092 fprintf(f, "/)");
1093 dtype = aclp->dtype;
1094 if (!in_array)
1095 acl_array_num += compute_width_dtype(dtype);
1096 break;
1097 case AC_SCONST:
1098 save_array_num = acl_array_num;
1099
1100 dtype = aclp->dtype;
1101 sptr = DTY(dtype + 3); /* tag sptr */
1102 fprintf(f, "%s(", SYMNAME(sptr));
1103 member_aclp = aclp->subc;
1104 _printacl(0, member_aclp, f);
1105 fprintf(f, ")");
1106
1107 if (in_array)
1108 acl_array_num = save_array_num;
1109 break;
1110 case AC_IDO:
1111 fprintf(f, "(");
1112 _printacl(in_array, aclp->subc, f);
1113 fprintf(f, ",i=l,u,s)");
1114 break;
1115 case AC_REPEAT:
1116 fprintf(f, "REPEAT[%d](", aclp->u1.count);
1117 _printacl(in_array, aclp->subc, f);
1118 fprintf(f, ")");
1119 break;
1120 case AC_IEXPR:
1121 dtype = aclp->dtype;
1122 fprintf(f, "AC_IEXPR(dtype %d, op %s)", dtype,
1123 iexpr_op(aclp->u1.expr->op));
1124 break;
1125 default:
1126 interr("_printacl .id", aclp->id, 3);
1127 break;
1128 }
1129 if (aclp->next)
1130 fprintf(f, ",");
1131 }
1132 }
1133
1134 void
printacl(char * s,ACL * aclp,FILE * f)1135 printacl(char *s, ACL *aclp, FILE *f)
1136 {
1137 if (f == NULL)
1138 f = stderr;
1139 acl_array_num = 0;
1140 fprintf(f, "%s-line %d: ", s, gbl.lineno);
1141 _printacl(1, aclp, f);
1142 fprintf(f, "\n");
1143 }
1144
1145 static void
_dumpacl(int nest,ACL * aclp,FILE * f)1146 _dumpacl(int nest, ACL *aclp, FILE *f)
1147 {
1148 /* dump a list of aclps */
1149 for (; aclp != NULL; aclp = aclp->next) {
1150 int sptr, dtype, ast, astinit, astlimit, aststep, astcount;
1151 SST *stkp;
1152 DOINFO *doinfo;
1153
1154 fprintf(f, "\n%*.*s", 2 * nest, 2 * nest, " ");
1155 switch (aclp->id) {
1156 case AC_AST:
1157 dtype = A_DTYPEG(aclp->u1.ast);
1158 ast = aclp->u1.ast;
1159 fprintf(f, "dtype %d, ast(%d) ", dtype, ast);
1160 if (ast) {
1161 printast(ast);
1162 if (A_ALIASG(ast)) {
1163 fprintf(f, " [alias");
1164 if (A_ALIASG(ast) != ast) {
1165 ast = A_ALIASG(ast);
1166 fprintf(f, "(%d) ", ast);
1167 printast(ast);
1168 }
1169 fprintf(f, "]");
1170 }
1171 }
1172 break;
1173 case AC_EXPR:
1174 stkp = aclp->u1.stkp;
1175 dtype = SST_DTYPEG(stkp);
1176 ast = SST_ASTG(stkp);
1177 switch (SST_IDG(stkp)) {
1178 case S_ACONST:
1179 fprintf(f, "expr aconst, dtype %d", dtype);
1180 ast = 0;
1181 break;
1182 case S_CONST:
1183 fprintf(f, "expr const, dtype %d", dtype);
1184 break;
1185 case S_SCONST:
1186 fprintf(f, "expr sconst, dtype %d", dtype);
1187 break;
1188 case S_EXPR:
1189 fprintf(f, "expr expr, dtype %d", dtype);
1190 break;
1191 case S_IDENT:
1192 sptr = SST_SYMG(stkp);
1193 fprintf(f, "expr ident %d=%s, dtype %d", sptr,
1194 (sptr > 0 && sptr < stb.stg_avail) ? SYMNAME(sptr) : "", dtype);
1195 break;
1196 default:
1197 fprintf(f, "expr unknown, dtype %d", dtype);
1198 break;
1199 }
1200 if (ast) {
1201 fprintf(f, ", ast(%d) ", ast);
1202 printast(ast);
1203 if (A_ALIASG(ast)) {
1204 fprintf(f, " [alias");
1205 if (A_ALIASG(ast) != ast) {
1206 ast = A_ALIASG(ast);
1207 fprintf(f, "(%d) ", ast);
1208 printast(ast);
1209 }
1210 fprintf(f, "]");
1211 }
1212 }
1213 break;
1214 case AC_CONST:
1215 fprintf(f, "const dtype %d conval %d", aclp->dtype, aclp->conval);
1216 break;
1217 case AC_ACONST:
1218 dtype = aclp->dtype;
1219 fprintf(f, "array, dtype %d", dtype);
1220 _dumpacl(nest + 1, aclp->subc, f);
1221 break;
1222 case AC_SCONST:
1223 dtype = aclp->dtype;
1224 sptr = DTY(dtype + 3); /* tag sptr */
1225 fprintf(f, "structure %s dtype %d", SYMNAME(sptr), dtype);
1226 _dumpacl(nest + 1, aclp->subc, f);
1227 break;
1228 case AC_IDO:
1229 doinfo = aclp->u1.doinfo;
1230 sptr = doinfo->index_var;
1231 astinit = doinfo->init_expr;
1232 astlimit = doinfo->limit_expr;
1233 aststep = doinfo->step_expr;
1234 astcount = doinfo->count;
1235 fprintf(f, "DO [ast(%d)] %s = ast(%d), ast(%d), ast(%d) = [", astcount,
1236 SYMNAME(sptr), astinit, astlimit, aststep);
1237 if (astcount)
1238 printast(astcount);
1239 fprintf(f, "] ");
1240 if (astinit)
1241 printast(astinit);
1242 fprintf(f, ", ");
1243 if (astlimit)
1244 printast(astlimit);
1245 fprintf(f, ", ");
1246 if (aststep)
1247 printast(aststep);
1248 _dumpacl(nest + 1, aclp->subc, f);
1249 break;
1250 case AC_REPEAT:
1251 fprintf(f, "REPEAT*%d", aclp->u1.count);
1252 _dumpacl(nest + 1, aclp->subc, f);
1253 break;
1254 case AC_IEXPR:
1255 dtype = aclp->dtype;
1256 fprintf(f, "AC_IEXPR dtype %d, op %s", dtype,
1257 iexpr_op(aclp->u1.expr->op));
1258 break;
1259 case AC_CONVAL:
1260 dtype = aclp->dtype;
1261 fprintf(f, "AC_CONVAL dtype %d, conval %d", dtype, aclp->conval);
1262 break;
1263 default:
1264 fprintf(f, "unknown aclp->id %d", aclp->id);
1265 break;
1266 }
1267 }
1268 }
1269
1270 void
dumpacl(char * s,ACL * aclp,FILE * f)1271 dumpacl(char *s, ACL *aclp, FILE *f)
1272 {
1273 if (f == NULL)
1274 f = stderr;
1275 acl_array_num = 0;
1276 fprintf(f, "ACL(%s):", s);
1277 _dumpacl(1, aclp, f);
1278 fprintf(f, "\n");
1279 }
1280 #endif
1281
1282 static int
compute_width_dtype(DTYPE in_dtype)1283 compute_width_dtype(DTYPE in_dtype)
1284 {
1285 int sum;
1286 int member_dtype;
1287 int sptr;
1288 int stag;
1289 DTYPE dtype = DDTG(in_dtype);
1290
1291 if (DTY(dtype) != TY_DERIVED)
1292 return 1;
1293 stag = DTY(dtype + 3);
1294 if (VISITG(stag))
1295 return 1;
1296 VISITP(stag, 1);
1297 sum = 0;
1298 /* for each member */
1299 sptr = DTY(dtype + 1);
1300 for (; sptr != NOSYM; sptr = SYMLKG(sptr)) {
1301 member_dtype = DTYPEG(sptr);
1302 if (DTYG(member_dtype) == TY_DERIVED)
1303 sum += compute_width_dtype(member_dtype);
1304 else
1305 sum++;
1306 }
1307 VISITP(stag, 0);
1308 return sum;
1309 }
1310
1311 /* This code computes the number of arrays that are going to be
1312 created to store the aclp (== 1, unless this is an array of
1313 derived types.
1314 */
1315 static int cw_array_num = 0;
1316 static int max_cw_array_num = 0;
1317
1318 static void
_compute_width(int in_array,ACL * aclp)1319 _compute_width(int in_array, ACL *aclp)
1320 {
1321 int save_cw_array_num;
1322 DTYPE dtype;
1323
1324 /* if we are !in_array then we are in a structure, and
1325 the following element (or array) will represent a new
1326 mangled component, so increment cw_array_num */
1327
1328 for (; aclp != NULL; aclp = aclp->next) {
1329 switch (aclp->id) {
1330 case AC_AST:
1331 case AC_CONST:
1332 dtype = A_DTYPEG(aclp->u1.ast);
1333 goto have_dtype;
1334 case AC_EXPR:
1335 dtype = SST_DTYPEG(aclp->u1.stkp);
1336 have_dtype:
1337 aclp->u2.array_i = cw_array_num; /* save index */
1338 if (!in_array)
1339 cw_array_num += compute_width_dtype(dtype);
1340 if ((cw_array_num - 1) > max_cw_array_num)
1341 max_cw_array_num = (cw_array_num - 1);
1342 break;
1343 case AC_ACONST:
1344 _compute_width(1, aclp->subc); /* element list */
1345 dtype = aclp->dtype;
1346 if (!in_array)
1347 cw_array_num += compute_width_dtype(dtype);
1348 if ((cw_array_num - 1) > max_cw_array_num)
1349 max_cw_array_num = (cw_array_num - 1);
1350 break;
1351 case AC_SCONST:
1352 save_cw_array_num = cw_array_num;
1353
1354 _compute_width(0, aclp->subc); /* member list */
1355
1356 if (in_array)
1357 cw_array_num = save_cw_array_num;
1358 break;
1359 case AC_IDO:
1360 _compute_width(in_array, aclp->subc); /* IDO ac list */
1361 break;
1362 case AC_REPEAT:
1363 _compute_width(in_array, aclp->subc); /* item repeated */
1364 break;
1365 case AC_IEXPR:
1366 _compute_width(in_array, aclp->subc);
1367 break;
1368 default:
1369 interr("compute width aclp->id", aclp->id, 3);
1370 break;
1371 }
1372 }
1373 }
1374
1375 /** \brief Check if array has zero size.
1376
1377 It expects lowerbound and upper bound to be constant asts.
1378 Don't use NUM_ELEM because it could return 1 as number of element,
1379 If dtype is zero, it loosely check aggregate size which must be done
1380 after chk_constructor/(2).
1381 */
1382 ISZ_T
size_of_array(DTYPE dtype)1383 size_of_array(DTYPE dtype)
1384 {
1385 int i;
1386 ADSC *ad;
1387 int numdim;
1388 ISZ_T dim_size;
1389 ISZ_T size = 1;
1390 ISZ_T d;
1391
1392 if (dtype) {
1393 #define DEFAULT_DIM_SIZE 127
1394
1395 #if DEBUG
1396 assert(DTY(dtype) == TY_ARRAY, "extent_of, expected TY_ARRAY", dtype, 3);
1397 #endif
1398 if ((d = DTY(dtype + 2)) <= 0) {
1399 interr("extent_of: no array descriptor", (int)d, 3);
1400 return 0;
1401 }
1402
1403 switch (DTY(dtype)) {
1404 case TY_ARRAY:
1405 if (DTY(dtype + 2) != 0) {
1406 ad = AD_DPTR(dtype);
1407 numdim = AD_NUMDIM(ad);
1408 if (numdim < 1 || numdim > 7) {
1409 interr("extent_of: bad numdim", 0, 1);
1410 numdim = 0;
1411 }
1412 for (i = 0; i < numdim; i++) {
1413 if (A_TYPEG(AD_LWAST(ad, i)) != A_CNST &&
1414 A_TYPEG(AD_UPAST(ad, i)) != A_CNST) {
1415 dim_size = DEFAULT_DIM_SIZE;
1416 } else {
1417 dim_size = ad_val_of(sym_of_ast(AD_UPAST(ad, i))) -
1418 ad_val_of(sym_of_ast(AD_LWAST(ad, i))) + 1;
1419 }
1420 size *= dim_size;
1421 }
1422 }
1423 break;
1424
1425 default:
1426 return size;
1427 }
1428 } else if (acs.aggr_cnt == astb.bnd.zero && acs.scalar_cnt == 0) {
1429 return 0;
1430 }
1431 return size;
1432 }
1433
1434 static int
compute_width(ACL * aclp)1435 compute_width(ACL *aclp)
1436 {
1437 cw_array_num = 0;
1438 max_cw_array_num = 0;
1439 _compute_width(1, aclp);
1440 return (max_cw_array_num + 1);
1441 }
1442
1443 /** \brief Check the array constructor and decide the dtype.
1444
1445 It is called when we first recognize an array constructor.
1446 */
1447 DTYPE
chk_constructor(ACL * aclp,DTYPE dtype)1448 chk_constructor(ACL *aclp, DTYPE dtype)
1449 {
1450 SEM_DIM_SPECS dim_specs_tmp;
1451 #if DEBUG
1452 if (DBGBIT(3, 64))
1453 printacl("chk_constructor", aclp, gbl.dbgfil);
1454 assert(aclp->id == AC_ACONST, "chk_constructor aclp->id:", aclp->id, 3);
1455 #endif
1456
1457 save_dim_specs(&dim_specs_tmp);
1458 BZERO(&acs, _ACS, 1);
1459 acs.aggr_cnt = astb.bnd.zero;
1460 acs.is_const = TRUE;
1461
1462 sem.top = &sem.dostack[0];
1463 compute_size(true, aclp->subc, dtype);
1464 if (dtype) {
1465 acs.eltype = dtype;
1466 }
1467
1468 switch (DTY(acs.eltype)) {
1469 case TY_CHAR:
1470 case TY_NCHAR:
1471 if (!A_ALIASG(DTY(acs.eltype + 1))) {
1472 } else if (acs.zln) {
1473 /* should be an error */
1474 acs.eltype = get_type(2, DTY(acs.eltype), astb.i1);
1475 }
1476 break;
1477 }
1478
1479 sem.arrdim.ndim = 1;
1480
1481 sem.bounds[0].lowtype = S_CONST;
1482 sem.bounds[0].lowb = 1;
1483 sem.bounds[0].lwast = 0;
1484
1485 if (acs.aggr_cnt == astb.bnd.zero) {
1486 sem.bounds[0].uptype = S_CONST;
1487 sem.bounds[0].upb = acs.scalar_cnt;
1488 sem.bounds[0].upast = mk_isz_cval((INT)acs.scalar_cnt, astb.bnd.dtype);
1489 sem.arrdim.ndefer = 0;
1490 } else {
1491 sem.bounds[0].uptype = S_EXPR;
1492 sem.bounds[0].upb = 0;
1493 sem.bounds[0].upast = mk_binop(
1494 OP_ADD, acs.aggr_cnt, mk_isz_cval((INT)acs.scalar_cnt, astb.bnd.dtype),
1495 astb.bnd.dtype);
1496 sem.arrdim.ndefer = 1;
1497 acs.is_const = FALSE;
1498 }
1499 if (sem.gcvlen && is_deferlenchar_dtype(acs.eltype)) {
1500 sem.arrdim.ndefer = 1;
1501 }
1502 aclp->size = sem.bounds[0].upast;
1503
1504 acs.arrtype = mk_arrdsc();
1505 DTY(acs.arrtype + 1) = acs.eltype;
1506 restore_dim_specs(&dim_specs_tmp);
1507
1508 aclp->is_const = acs.is_const; /* store in acl */
1509 aclp->dtype = acs.arrtype; /* store in acl and also return*/
1510 return acs.arrtype;
1511 }
1512
1513 /** \brief Initialize a named array constant (array PARAMETER), ensuring that
1514 it's only being done within the context of its host subprogram.
1515 */
1516 void
init_named_array_constant(int arr,int host)1517 init_named_array_constant(int arr, int host)
1518 {
1519 if (ENCLFUNCG(arr) == 0 || ENCLFUNCG(arr) == host)
1520 /* emit the data inits for the named array constant */
1521 init_sptr_w_acl((int)CONVAL1G(arr), (ACL *)get_getitem_p(CONVAL2G(arr)));
1522 }
1523
1524 static int ALLOCATE_ARRAYS = TRUE;
1525
1526 SPTR
get_param_alias_var(SPTR param_sptr,DTYPE dtype)1527 get_param_alias_var(SPTR param_sptr, DTYPE dtype)
1528 {
1529 char *np = mangle_name(SYMNAME(param_sptr), "ac");
1530 SPTR alias_sptr = getsymbol(np);
1531
1532 STYPEP(alias_sptr, ST_VAR);
1533 DTYPEP(alias_sptr, dtype);
1534 DCLDP(alias_sptr, 1);
1535 SCP(alias_sptr, SC_STATIC);
1536 SCOPEP(alias_sptr, stb.curr_scope);
1537 CONVAL1P(param_sptr, alias_sptr);
1538 PARAMP(alias_sptr, PARAMG(param_sptr));
1539 PARAMVALP(alias_sptr, PARAMVALG(param_sptr));
1540 DINITP(alias_sptr, 1);
1541 HCCSYMP(alias_sptr, 1);
1542 NMCNSTP(alias_sptr, param_sptr);
1543 sym_is_refd(alias_sptr);
1544 REFP(alias_sptr, 1);
1545 return alias_sptr;
1546 }
1547
1548 static int
convert_ctmp_array_to_param(int cctmpsptr,ACL * aclp)1549 convert_ctmp_array_to_param(int cctmpsptr, ACL *aclp)
1550 {
1551 /* A temp has been generated to hold the value of an array
1552 * constructor and this temp is used in an expression. Convert
1553 * the temp to a named constant so that the initialization
1554 * values are available (in the associated A_INIT list) for use
1555 * in expression evaluation (esp. named constant initialization
1556 * expressions) */
1557
1558 SST tmp_sst;
1559 SST init;
1560 DTYPE dtype = DTYPEG(cctmpsptr);
1561 int aliassptr;
1562
1563 PARAMP(cctmpsptr, 1);
1564 STYPEP(cctmpsptr, ST_ARRAY);
1565 SCP(cctmpsptr, SC_NONE);
1566
1567 BZERO(&tmp_sst, SST, 1);
1568 SST_IDP(&tmp_sst, S_IDENT);
1569 SST_SYMP(&tmp_sst, cctmpsptr);
1570 dinit_struct_param(cctmpsptr, aclp, aclp->dtype);
1571
1572 STYPEP(cctmpsptr, ST_PARAM);
1573 SCOPEP(cctmpsptr, stb.curr_scope);
1574
1575 aliassptr = get_param_alias_var(cctmpsptr, dtype);
1576 STYPEP(aliassptr, ST_ARRAY);
1577
1578 BZERO(&init, SST, 1);
1579 SST_IDP(&init, S_ACONST);
1580 SST_DTYPEP(&init, aclp->dtype);
1581 SST_ACLP(&init, aclp);
1582
1583 construct_acl_for_sst(&init, DTYPEG(cctmpsptr));
1584
1585 if (sem.interface == 0) {
1586 CONVAL2P(cctmpsptr, put_getitem_p(aclp));
1587 } else {
1588 IGNOREP(cctmpsptr, 0);
1589 }
1590
1591 return aliassptr;
1592 }
1593
1594 /** \brief Assign \a aclp values to \a in_sptr.
1595
1596 If \a in_sptr is 0, it assigns values to temporaries. init_sptr_w_acl() is
1597 called at the point we are trying to use (a possibly array/struct nested)
1598 constructor; eg. in mkexpr1(). If acl is constant, dinit_constructor()
1599 uses data initialization to assign the values; otherwise, _construct is
1600 called to generate runtime code to assign values. (is_const means: is
1601 constant, we can do it, and we're in the right context to do it.)
1602 */
1603 int
init_sptr_w_acl(int in_sptr,ACL * aclp)1604 init_sptr_w_acl(int in_sptr, ACL *aclp)
1605 {
1606 int sptr_supplied;
1607 int sptr;
1608 int ast;
1609 SST tmp_sst;
1610 VAR *ivl;
1611 SEM_DIM_SPECS dim_specs_tmp;
1612
1613 #if DEBUG
1614 if (DBGBIT(3, 64))
1615 printacl("init_sptr_w_acl", aclp, gbl.dbgfil);
1616 #endif
1617
1618 if (in_sptr && DINITG(in_sptr))
1619 return in_sptr;
1620
1621 if (in_sptr && ENCLFUNCG(in_sptr) &&
1622 STYPEG(ENCLFUNCG(in_sptr)) == ST_MODULE) {
1623 /* the DINIT flag used to be enough. But now interf.c sets DINIT to
1624 zero. So for MODULE var$ac referenced outside the module, we can
1625 assume the initialization has already been done. */
1626 return in_sptr;
1627 }
1628
1629 if (aclp->id != AC_ACONST) {
1630 interr("init_sptr_w_acl aclp->id:", aclp->id, 3);
1631 return 0;
1632 }
1633
1634 save_dim_specs(&dim_specs_tmp);
1635 BZERO(&acs, _ACS, 1);
1636
1637 sptr_supplied = (in_sptr != 0);
1638 sptr = in_sptr;
1639
1640 /* chk_constructor() was called earlier and set up this information */
1641 acs.is_const = aclp->is_const;
1642 acs.arrtype = aclp->dtype;
1643 sem.arrdim.ndefer = AD_DEFER(AD_DPTR(acs.arrtype));
1644
1645 if (sem.dinit_data) {
1646 if (sptr_supplied) {
1647 acs.tmp = 0;
1648 } else {
1649 acs.tmp = get_arr_const(acs.arrtype);
1650 }
1651
1652 sptr = acs.tmp;
1653 /* converts to AC_AST ACL */
1654 aclp->subc = rewrite_acl(aclp->subc, aclp->dtype, aclp->id);
1655
1656 if (!sptr_supplied) {
1657 acs.tmp = sptr = convert_ctmp_array_to_param(sptr, aclp);
1658 }
1659
1660 ast = mk_id(sptr);
1661 SST_IDP(&tmp_sst, S_IDENT);
1662 SST_ASTP(&tmp_sst, ast);
1663 SST_DTYPEP(&tmp_sst, DTYPEG(sptr));
1664 SST_SHAPEP(&tmp_sst, A_SHAPEG(ast));
1665 ivl = dinit_varref(&tmp_sst);
1666 dinit(ivl, aclp);
1667 } else if (acs.is_const) {
1668 if (sptr_supplied) {
1669 acs.tmp = 0;
1670 } else {
1671 acs.tmp = get_arr_const(acs.arrtype);
1672 }
1673
1674 /* converts AC_AST to AC_IEXPR. */
1675 aclp->subc = rewrite_acl(aclp->subc, aclp->dtype, aclp->id);
1676 } else {
1677 if (sem.arrdim.ndefer) {
1678 ALLOCATE_ARRAYS = 0; /* allocate for these array temps is done here */
1679 }
1680
1681 sptr = acs.tmp = get_arr_temp(acs.arrtype, FALSE, FALSE, FALSE);
1682 ALLOCATE_ARRAYS = 1;
1683 if (sem.arrdim.ndefer) {
1684 sem.bounds[0].lwast = astb.bnd.one;
1685 sem.bounds[0].upast = aclp->size;
1686 /* assign values to the bounds temporaries and allocate the
1687 * array.
1688 */
1689 gen_allocate_array(acs.tmp);
1690 }
1691
1692 /* generate code to assign aclp values to the temporary */
1693 constructf90(acs.tmp, aclp);
1694 acs.tmp = sptr; /* if we recursed, asc.tmp may have changed */
1695 }
1696
1697 /* if the user didn't supply an sptr, use the temporary
1698 created above. */
1699 if (!sptr_supplied) {
1700 sptr = acs.tmp;
1701 }
1702
1703 if (acs.is_const) {
1704 if (!sem.dinit_data) {
1705 dinit_constructor(sptr, aclp);
1706 } else if (sptr_supplied) {
1707 interr("acl not resolved as constant", sptr, 2);
1708 }
1709 }
1710 restore_dim_specs(&dim_specs_tmp);
1711 return sptr;
1712 }
1713
1714 /* add_flag gets set to false, when we see a SCONST. We want to
1715 recurse on structure constructor to set acs.is_const, but we
1716 don't want to add to the counts for any components of the
1717 structure constructor.
1718 Convert the dtype to the dtype passed as argument.
1719 */
1720 static void
compute_size(bool add_flag,ACL * aclp,DTYPE dtype)1721 compute_size(bool add_flag, ACL *aclp, DTYPE dtype)
1722 {
1723 for (; aclp != NULL; aclp = aclp->next) {
1724 switch (aclp->id) {
1725 case AC_AST:
1726 compute_size_ast(add_flag, aclp, dtype);
1727 break;
1728 case AC_EXPR:
1729 dtype = compute_size_expr(add_flag, aclp, dtype);
1730 break;
1731 case AC_ACONST:
1732 compute_size(add_flag, aclp->subc, dtype);
1733 break;
1734 case AC_SCONST:
1735 compute_size_sconst(add_flag, aclp, dtype);
1736 break;
1737 case AC_IDO:
1738 compute_size_ido(add_flag, aclp, dtype);
1739 if (sem.dinit_error) {
1740 return;
1741 }
1742 break;
1743 default:
1744 interr("compute_size,ill.id", aclp->id, 3);
1745 }
1746 }
1747 }
1748
1749 static void
compute_size_ast(bool add_flag,ACL * aclp,DTYPE dtype)1750 compute_size_ast(bool add_flag, ACL *aclp, DTYPE dtype)
1751 {
1752 if (acs.eltype == 0 || acs.zln) {
1753 if (acs.eltype != 0) {
1754 acs.zln = 0;
1755 }
1756 if (dtype == 0) {
1757 dtype = DDTG(A_DTYPEG(aclp->u1.ast));
1758 }
1759 if (A_TYPEG(aclp->u1.ast) == A_ID) {
1760 dtype = fix_dtype(A_SPTRG(aclp->u1.ast), dtype);
1761 }
1762 acs.eltype = dtype;
1763 switch (DTY(acs.eltype)) {
1764 case TY_CHAR:
1765 case TY_NCHAR:
1766 if (A_ALIASG(DTY(acs.eltype + 1)) &&
1767 get_isz_cval(A_SPTRG(A_ALIASG(DTY(acs.eltype + 1)))) == 0) {
1768 acs.zln = 1;
1769 }
1770 }
1771 }
1772 if (add_flag)
1773 acs.scalar_cnt++;
1774 }
1775
1776 static DTYPE
compute_size_expr(bool add_flag,ACL * aclp,DTYPE dtype)1777 compute_size_expr(bool add_flag, ACL *aclp, DTYPE dtype)
1778 {
1779 DTYPE dt2, dtype2;
1780 SST *stkp = aclp->u1.stkp;
1781 LOGICAL specified_dtype = dtype != 0;
1782 DTYPE dt = DDTG(dtype);
1783 dtype2 = SST_DTYPEG(stkp);
1784 dt2 = DDTG(SST_DTYPEG(stkp));
1785 if (!specified_dtype) {
1786 dtype = dtype2;
1787 dt = dt2;
1788 }
1789
1790 if (acs.eltype == 0 || acs.zln) {
1791 int id = SST_IDG(stkp);
1792 if (acs.eltype != 0) {
1793 acs.zln = 0;
1794 }
1795 if (id == S_IDENT) {
1796 dt = fix_dtype(SST_SYMG(stkp), dt);
1797 } else if (id == S_EXPR || id == S_LVALUE) {
1798 if (dtype == DT_ASSCHAR || dtype == DT_DEFERCHAR
1799 || dtype == DT_ASSNCHAR || dtype == DT_DEFERNCHAR
1800 ) {
1801 dt = adjust_ch_length(dt, SST_ASTG(stkp));
1802 } else if (dt == DT_ASSCHAR || dt == DT_DEFERCHAR
1803 || dt == DT_ASSNCHAR || dt == DT_DEFERNCHAR
1804 ) {
1805 dt = fix_dtype(SST_SYMG(stkp), dt);
1806 }
1807 }
1808 /* need to change the type for the first element too */
1809 if (specified_dtype && acs.eltype == 0 &&
1810 add_flag) { /* if we're in a struct, don't do */
1811 if (DTY(dt) == TY_CHAR && DTY(dtype) == TY_CHAR)
1812 if (dtype2 != DT_DEFERCHAR && dtype2 != DT_DEFERNCHAR)
1813 dtype = SST_DTYPEG(stkp);
1814 else if (DTY(dt) == TY_NCHAR && DTY(dtype) == TY_NCHAR)
1815 if (dtype2 != DT_DEFERCHAR && dtype2 != DT_DEFERNCHAR)
1816 dtype = SST_DTYPEG(stkp);
1817 else if (DTY(dtype) == TY_ARRAY) {
1818 if (DDTG(dtype) != dt) {
1819 errsev(95);
1820 }
1821 } else {
1822 cngtyp(stkp, acs.eltype);
1823 dtype = SST_DTYPEG(stkp);
1824 }
1825 }
1826 acs.eltype = dt;
1827 switch (DTY(acs.eltype)) {
1828 case TY_CHAR:
1829 case TY_NCHAR:
1830 if (A_ALIASG(DTY(acs.eltype + 1)) &&
1831 get_isz_cval(A_SPTRG(A_ALIASG(DTY(acs.eltype + 1)))) == 0) {
1832 acs.zln = 1;
1833 }
1834 }
1835 } else {
1836 /* don't use chktyp here; chktyp evals semantic stack entry
1837 * causes S_CONST to become S_EXPR.
1838 */
1839 if (add_flag) { /* if we're in a struct, don't do */
1840 if (DTY(dt) == TY_CHAR && DTY(dtype) == TY_CHAR)
1841 if (dtype2 != DT_DEFERCHAR && dtype2 != DT_DEFERNCHAR)
1842 dtype = SST_DTYPEG(stkp);
1843 else if (DTY(dt) == TY_NCHAR && DTY(dtype) == TY_NCHAR)
1844 if (dtype2 != DT_DEFERCHAR && dtype2 != DT_DEFERNCHAR)
1845 dtype = SST_DTYPEG(stkp);
1846 else if (DTY(dtype) == TY_ARRAY) {
1847 if (!eq_dtype(DDTG(dtype), acs.eltype)) {
1848 errsev(95);
1849 }
1850 } else {
1851 cngtyp(stkp, acs.eltype);
1852 dtype = SST_DTYPEG(stkp);
1853 }
1854 }
1855 }
1856 switch (SST_IDG(stkp)) {
1857 case S_ACONST:
1858 interr("compute_size, AC_ACONST in AC_EXPR", 0, 3);
1859 if (add_flag)
1860 acs.scalar_cnt += CONVAL2G(sym_of_ast(AD_NUMELM(AD_DPTR(dtype))));
1861 break;
1862 case S_CONST:
1863 mkexpr(stkp);
1864 if (add_flag)
1865 acs.scalar_cnt++;
1866 break;
1867 default:
1868 mkexpr(stkp);
1869 if (DTY(dtype) != TY_ARRAY) {
1870 int ast = SST_ASTG(stkp);
1871 if (add_flag)
1872 acs.scalar_cnt++;
1873 if (!ast) {
1874 acs.is_const = FALSE;
1875 } else if (A_ALIASG(ast) || (acs.level && _can_fold(ast))) {
1876 /* do nothing */
1877 } else if (A_TYPEG(ast) == A_ID) {
1878 int sptr = A_SPTRG(ast);
1879 if (STYPEG(sptr) != ST_VAR || !PARAMVALG(sptr)) {
1880 acs.is_const = FALSE;
1881 }
1882 } else {
1883 acs.is_const = FALSE;
1884 }
1885 } else {
1886 int ast;
1887 if (add_flag) {
1888 int sz = size_of_ast((int)SST_ASTG(stkp));
1889 if (A_ALIASG(sz))
1890 acs.scalar_cnt += ad_val_of(A_SPTRG(A_ALIASG(sz)));
1891 else
1892 acs.aggr_cnt = mk_binop(OP_ADD, acs.aggr_cnt, sz, astb.bnd.dtype);
1893 }
1894 ast = SST_ASTG(stkp);
1895 if (!ast) {
1896 acs.is_const = FALSE;
1897 } else if (A_TYPEG(ast) == A_ID) {
1898 int sptr = A_SPTRG(ast);
1899 if (STYPEG(sptr) != ST_ARRAY || !PARAMVALG(sptr)) {
1900 acs.is_const = FALSE;
1901 }
1902 } else if (!_can_fold(ast)) {
1903 acs.is_const = FALSE;
1904 }
1905 }
1906 }
1907 return specified_dtype ? dtype : DT_NONE;
1908 }
1909
1910 static void
compute_size_ido(bool add_flag,ACL * aclp,DTYPE dtype)1911 compute_size_ido(bool add_flag, ACL *aclp, DTYPE dtype)
1912 {
1913 DOINFO *doinfo = aclp->u1.doinfo;
1914 INT initval, limitval, stepval;
1915 int save_scalar_cnt, save_aggr_cnt;
1916 int id;
1917 if (sem.dinit_data) {
1918 /* set up for the possibility that a nested implied
1919 * do will require counting the number of elements
1920 */
1921 sem.top->sptr = aclp->u1.doinfo->index_var;
1922 sem.top->currval = initval = dinit_eval(doinfo->init_expr);
1923 if (sem.dinit_error) {
1924 return;
1925 }
1926 sem.top->upbd = limitval = dinit_eval(doinfo->limit_expr);
1927 if (sem.dinit_error) {
1928 return;
1929 }
1930 sem.top->step = stepval = dinit_eval(doinfo->step_expr);
1931 if (sem.dinit_error) {
1932 return;
1933 }
1934 sem.top++;
1935
1936 if (A_ALIASG(doinfo->count)) {
1937 acs.level++;
1938 DOVARP(doinfo->index_var, 1);
1939 }
1940 }
1941 if (add_flag) {
1942 save_scalar_cnt = acs.scalar_cnt;
1943 save_aggr_cnt = acs.aggr_cnt;
1944 /*
1945 * scalar_cnt & aggr_cnt will reflect the number of items
1946 * immediately contained by this implied do.
1947 */
1948 acs.scalar_cnt = 0;
1949 acs.aggr_cnt = astb.bnd.zero;
1950 }
1951 compute_size(add_flag, aclp->subc, dtype);
1952 /*
1953 * size is the 'cnt*scalar_cnt + cnt*aggr_cnt'
1954 */
1955 id = mk_id(doinfo->index_var);
1956 if (add_flag && contains_ast(acs.aggr_cnt, id)) {
1957 /* The size expression depends on the loop index variable.
1958 * This is tricky because we need the size to allocate
1959 * the temporary before we generate the loop. First,
1960 * if there is a scalar_cnt, convert it to an expression
1961 * to be added later (size can't be a constant now).
1962 */
1963 if (acs.scalar_cnt != 0) {
1964 acs.aggr_cnt =
1965 mk_binop(OP_ADD, acs.aggr_cnt,
1966 mk_isz_cval(acs.scalar_cnt, astb.bnd.dtype), astb.bnd.dtype);
1967 acs.scalar_cnt = 0;
1968 }
1969 /* Now we need to evaluate the size expression for each
1970 * value of the loop index variable and add the results.
1971 * There are two cases:
1972 */
1973 if (A_ALIASG(doinfo->init_expr) && A_ALIASG(doinfo->limit_expr) &&
1974 A_ALIASG(doinfo->step_expr)) {
1975 int i;
1976 int ast;
1977
1978 /* In the easy case, the loop control expressions are
1979 * constants, so we can iterate at compile time,
1980 * substituting each value of the loop variable and
1981 * adding the sizes.
1982 */
1983 initval = CONVAL2G(A_SPTRG(A_ALIASG(doinfo->init_expr)));
1984 limitval = CONVAL2G(A_SPTRG(A_ALIASG(doinfo->limit_expr)));
1985 stepval = CONVAL2G(A_SPTRG(A_ALIASG(doinfo->step_expr)));
1986 ast = astb.bnd.zero;
1987 if (stepval >= 0) {
1988 for (i = initval; i <= limitval; i += stepval) {
1989 ast_visit(1, 1);
1990 ast_replace(id, mk_cval(i, astb.bnd.dtype));
1991 ast =
1992 mk_binop(OP_ADD, ast, ast_rewrite(acs.aggr_cnt), astb.bnd.dtype);
1993 ast_unvisit();
1994 }
1995 } else {
1996 for (i = initval; i >= limitval; i += stepval) {
1997 ast_visit(1, 1);
1998 ast_replace(id, mk_cval(i, astb.bnd.dtype));
1999 ast =
2000 mk_binop(OP_ADD, ast, ast_rewrite(acs.aggr_cnt), astb.bnd.dtype);
2001 ast_unvisit();
2002 }
2003 }
2004 acs.aggr_cnt = ast;
2005 } else {
2006 /* Non-constant loop control expression(s).
2007 * Must generate a run-time loop to add sizes.
2008 */
2009 int odovar, dovar, sum, sumid, newid, doif;
2010 DOINFO newdoinfo;
2011 int ast;
2012
2013 /* Duplicate loop info, but substitute a new index var. */
2014 newdoinfo = *doinfo;
2015 odovar = doinfo->index_var;
2016 dovar = get_temp(DDTG(DTYPEG(odovar)));
2017 STYPEP(dovar, STYPEG(odovar));
2018 DTYPEP(dovar, DTYPEG(odovar));
2019 if (SCG(odovar) == SC_PRIVATE) {
2020 SCP(dovar, SC_PRIVATE);
2021 } else {
2022 SCP(dovar, SC_LOCAL);
2023 }
2024 HIDDENP(dovar, 1);
2025 newdoinfo.index_var = dovar;
2026 newid = mk_id(dovar);
2027
2028 /* Get a temp for the sum and initialize to zero. */
2029 sum = get_temp(astb.bnd.dtype);
2030 sumid = mk_id(sum);
2031 ast = mk_assn_stmt(sumid, astb.bnd.zero, astb.bnd.dtype);
2032 add_stmt(ast);
2033
2034 /* Rewrite the size expression to use the new index var. */
2035 ast_visit(1, 1);
2036 ast_replace(id, newid);
2037 ast = ast_rewrite(acs.aggr_cnt);
2038 ast_unvisit();
2039
2040 /* Generate the loop. */
2041 NEED_DOIF(doif, DI_DO);
2042 add_stmt(do_begin(&newdoinfo));
2043 ast = mk_binop(OP_ADD, sumid, ast, astb.bnd.dtype);
2044 ast = mk_assn_stmt(sumid, ast, astb.bnd.dtype);
2045 add_stmt(ast);
2046 do_end(&newdoinfo);
2047
2048 /* Size is now in our sum temporary. */
2049 acs.aggr_cnt = sumid;
2050 }
2051 } else if (A_ALIASG(doinfo->count)) {
2052 if (add_flag) {
2053 int v = CONVAL2G(A_SPTRG(A_ALIASG(doinfo->count)));
2054 acs.scalar_cnt *= v;
2055 acs.aggr_cnt = mk_binop(OP_MUL, acs.aggr_cnt, mk_cval(v, astb.bnd.dtype),
2056 astb.bnd.dtype);
2057 }
2058 if (sem.dinit_data) {
2059 acs.level--;
2060 DOVARP(doinfo->index_var, 0);
2061 } else
2062 acs.is_const = FALSE;
2063 } else if (sem.dinit_data) {
2064 /* TODO: why is this not a simple division?? */
2065 /* must count them */
2066 int i, v = 0;
2067 for (i = initval; i <= limitval; i += stepval, v++)
2068 ;
2069
2070 acs.scalar_cnt *= v;
2071 if (v) {
2072 acs.aggr_cnt = mk_binop(OP_MUL, acs.aggr_cnt, mk_cval(v, astb.bnd.dtype),
2073 astb.bnd.dtype);
2074 acs.level--;
2075 DOVARP(doinfo->index_var, 0);
2076 }
2077 } else {
2078 if (add_flag) {
2079 if (acs.scalar_cnt != 0) {
2080 acs.aggr_cnt = mk_binop(OP_ADD, acs.aggr_cnt,
2081 mk_isz_cval(acs.scalar_cnt, astb.bnd.dtype),
2082 astb.bnd.dtype);
2083 acs.scalar_cnt = 0;
2084 }
2085 acs.aggr_cnt =
2086 mk_binop(OP_MUL, doinfo->count, acs.aggr_cnt, astb.bnd.dtype);
2087 }
2088 acs.is_const = FALSE;
2089 }
2090 if (add_flag) {
2091 /*
2092 * fold counts due to the implied do into the totals
2093 */
2094 acs.scalar_cnt += save_scalar_cnt;
2095 acs.aggr_cnt =
2096 mk_binop(OP_ADD, acs.aggr_cnt, save_aggr_cnt, astb.bnd.dtype);
2097 }
2098 if (sem.dinit_data) {
2099 sem.top--;
2100 }
2101 }
2102
2103 static void
compute_size_sconst(bool add_flag,ACL * aclp,DTYPE dtype)2104 compute_size_sconst(bool add_flag, ACL *aclp, DTYPE dtype)
2105 {
2106 if (add_flag) {
2107 acs.scalar_cnt++;
2108 }
2109 if (acs.eltype == 0) {
2110 acs.eltype = dtype != 0 ? dtype : aclp->dtype;
2111 }
2112 compute_size(false, aclp->subc, dtype);
2113 if (ALLOCFLDG(DTY(aclp->dtype + 3))) {
2114 acs.is_const = FALSE;
2115 }
2116 }
2117
2118 static LOGICAL
_can_fold(int ast)2119 _can_fold(int ast)
2120 {
2121 int sptr, asd, ndim, i, b;
2122
2123 if (ast == 0)
2124 return FALSE;
2125 if (A_ALIASG(ast))
2126 return TRUE;
2127 switch (A_TYPEG(ast)) {
2128 case A_ID:
2129 /* see if this ident is an active do index variable: */
2130 sptr = A_SPTRG(ast);
2131 if (DOVARG(sptr))
2132 return TRUE;
2133
2134 /* if the ID has PARAMVAL, subscripts are foldable */
2135 if (PARAMVALG(sptr))
2136 return TRUE;
2137 break;
2138
2139 case A_MEM:
2140 return _can_fold(A_PARENTG(ast));
2141
2142 case A_SUBSCR:
2143 if (!_can_fold(A_LOPG(ast)))
2144 return FALSE;
2145 asd = A_ASDG(ast);
2146 ndim = ASD_NDIM(asd);
2147 for (i = 0; i < ndim; ++i) {
2148 int ss = ASD_SUBS(asd, i);
2149 if (!_can_fold(ss))
2150 return FALSE;
2151 }
2152 return TRUE;
2153 break;
2154
2155 case A_TRIPLE:
2156 b = A_LBDG(ast);
2157 if (b == 0 || !_can_fold(b))
2158 return FALSE;
2159 b = A_UPBDG(ast);
2160 if (b == 0 || !_can_fold(b))
2161 return FALSE;
2162 b = A_STRIDEG(ast);
2163 if (b != 0 && !_can_fold(b))
2164 return FALSE;
2165 return TRUE;
2166 break;
2167
2168 case A_CNST:
2169 return TRUE;
2170
2171 case A_UNOP:
2172 if (!DT_ISINT(A_DTYPEG(ast)))
2173 return FALSE;
2174 if (A_OPTYPEG(ast) == OP_SUB)
2175 return _can_fold((int)A_LOPG(ast));
2176 break;
2177
2178 case A_BINOP:
2179 if (!DT_ISINT(A_DTYPEG(ast)))
2180 return FALSE;
2181 switch (A_OPTYPEG(ast)) {
2182 case OP_ADD:
2183 case OP_SUB:
2184 case OP_MUL:
2185 case OP_DIV:
2186 if (!_can_fold((int)A_LOPG(ast)))
2187 return FALSE;
2188 return _can_fold((int)A_ROPG(ast));
2189 }
2190 break;
2191
2192 case A_CONV:
2193 case A_PAREN:
2194 return _can_fold((int)A_LOPG(ast));
2195
2196 default:
2197 break;
2198 }
2199 return FALSE;
2200 }
2201
2202 /* ------------------------------------------------------------------------- */
2203 /* small routines used by constructf90(). generate subscripts as they are
2204 * needed. */
2205
2206 static int sub_i = 7;
2207 static int tmpids[MAXDIMS];
2208
2209 static void
init_constructf90()2210 init_constructf90()
2211 {
2212 int i;
2213
2214 for (i = 0; i < 7; i++) {
2215 acs.element_cnt[i] = 0; /* # of individual constructor items */
2216 acs.indx[i] = astb.bnd.one; /* subscript of first element */
2217 acs.indx_tmpid[i] = 0; /* no subscripting temporary yet */
2218 acs.subs[i] = astb.bnd.one;
2219 tmpids[i] = 0;
2220 }
2221 sub_i = 7;
2222 }
2223
2224 static int
add_subscript(int base_id,int indexast,DTYPE dtype)2225 add_subscript(int base_id, int indexast, DTYPE dtype)
2226 {
2227 int dest;
2228
2229 acs.subs[sub_i] = indexast;
2230 /* generate subscripts as they are seen */
2231 dest = mk_subscr(base_id, &acs.subs[sub_i], 1, dtype);
2232 return dest;
2233 }
2234
2235 static int
apply_shape_subscripts(int base_id,int shp,DTYPE dtype)2236 apply_shape_subscripts(int base_id, int shp, DTYPE dtype)
2237 {
2238 int dest;
2239 int i, ndim;
2240 int ast;
2241 int subs[MAXDIMS];
2242
2243 ndim = SHD_NDIM(shp);
2244 for (i = 0; i < ndim; i++) {
2245 ast = mk_triple(SHD_LWB(shp, i), SHD_UPB(shp, i), SHD_STRIDE(shp, i));
2246 subs[i] = ast;
2247 }
2248 dest = mk_subscr(base_id, subs, ndim, dtype);
2249 return dest;
2250 }
2251
2252 static void
push_subscript()2253 push_subscript()
2254 {
2255 sub_i--;
2256 }
2257
2258 static void
pop_subscript()2259 pop_subscript()
2260 {
2261 sub_i++;
2262 }
2263
2264 static void
clear_element_cnt()2265 clear_element_cnt()
2266 {
2267 acs.element_cnt[sub_i] = 0;
2268 }
2269
2270 static void
incr_element_cnt()2271 incr_element_cnt()
2272 {
2273 acs.element_cnt[sub_i]++;
2274 }
2275
2276 static INT
get_element_cnt()2277 get_element_cnt()
2278 {
2279 return acs.element_cnt[sub_i];
2280 }
2281
2282 static int
get_subscripting_tmp(int indexast)2283 get_subscripting_tmp(int indexast)
2284 {
2285 int ast;
2286
2287 if (!tmpids[sub_i])
2288 tmpids[sub_i] = mk_id(get_temp(astb.bnd.dtype));
2289 if (indexast != tmpids[sub_i]) {
2290 ast = mk_assn_stmt(tmpids[sub_i], indexast, astb.bnd.dtype);
2291 add_stmt(ast);
2292 }
2293 return (tmpids[sub_i]);
2294 }
2295
2296 static void
incr_tmp(int tmpid)2297 incr_tmp(int tmpid)
2298 {
2299 int ast;
2300
2301 ast = mk_binop(OP_ADD, tmpid, astb.bnd.one, astb.bnd.dtype);
2302 ast = mk_assn_stmt(tmpid, ast, astb.bnd.dtype);
2303 add_stmt(ast);
2304 }
2305
2306 #define THRESHHOLD 20
2307
2308 static int
size_of_shape_dim(int shape,int i)2309 size_of_shape_dim(int shape, int i)
2310 {
2311 int sz;
2312 if (SHD_LWB(shape, i) == SHD_STRIDE(shape, i)) {
2313 sz = SHD_UPB(shape, i);
2314 } else {
2315 sz = mk_binop(OP_SUB, SHD_UPB(shape, i), SHD_LWB(shape, i), astb.bnd.dtype);
2316 sz = mk_binop(OP_ADD, sz, SHD_STRIDE(shape, i), astb.bnd.dtype);
2317 }
2318 if (SHD_STRIDE(shape, i) != astb.bnd.one) {
2319 sz = mk_binop(OP_DIV, sz, SHD_STRIDE(shape, i), astb.bnd.dtype);
2320 }
2321 return sz;
2322 } /* size_of_shape_dim */
2323
2324 static int
get_shape_arraydtype(int shape,int eltype)2325 get_shape_arraydtype(int shape, int eltype)
2326 {
2327 int arrtype, i, n;
2328 int sz;
2329
2330 n = sem.arrdim.ndim = SHD_NDIM(shape);
2331 sem.arrdim.ndefer = 0;
2332
2333 for (i = 0; i < n; ++i) {
2334 sem.bounds[i].lowtype = S_CONST;
2335 sem.bounds[i].lowb = 1;
2336 sem.bounds[i].lwast = 0;
2337
2338 sz = size_of_shape_dim(shape, i);
2339 if (A_ALIASG(sz) && (ad_val_of(A_SPTRG(A_ALIASG(sz))) < THRESHHOLD)) {
2340 /* small constant size */
2341 sem.bounds[i].uptype = S_CONST;
2342 sem.bounds[i].upb = ad_val_of(A_SPTRG(A_ALIASG(sz)));
2343 sem.bounds[i].upast = sz;
2344 } else {
2345 sem.bounds[i].uptype = S_EXPR;
2346 sem.bounds[i].upb = 0;
2347 sem.bounds[i].upast = sz;
2348 sem.arrdim.ndefer++;
2349 }
2350 }
2351
2352 if (is_deferlenchar_dtype(acs.arrtype))
2353 sem.arrdim.ndefer = 1;
2354
2355 arrtype = mk_arrdsc();
2356 DTY(arrtype + 1) = eltype;
2357 return arrtype;
2358 } /* get_shape_arraydtype */
2359
2360 static void
mkexpr_assign_temp(SST * stkptr)2361 mkexpr_assign_temp(SST *stkptr)
2362 {
2363 int ast, a, simple;
2364 DTYPE dtype;
2365 int dest;
2366 int id;
2367
2368 mkexpr(stkptr);
2369 /* may have to change to create temp based on shape if we are in
2370 structure and doing array assignment of a multiple dimension array. */
2371
2372 simple = 1;
2373 ast = SST_ASTG(stkptr);
2374 for (a = ast; a > 0;) {
2375 switch (A_TYPEG(a)) {
2376 case A_ID:
2377 a = 0;
2378 break;
2379 case A_MEM:
2380 a = A_PARENTG(a);
2381 break;
2382 default:
2383 simple = 0;
2384 a = 0;
2385 break;
2386 }
2387 }
2388 /* if we have an array expression, we need to assign it to
2389 a temporary so that we can subscript it. */
2390 if (DTY(dtype = SST_DTYPEG(stkptr)) == TY_ARRAY && !simple) {
2391 if (is_deferlenchar_ast(ast)) {
2392 dtype = get_shape_arraydtype(A_SHAPEG(ast), DTY(acs.arrtype + 1));
2393 } else {
2394 dtype = get_shape_arraydtype(A_SHAPEG(ast), DTY(dtype + 1));
2395 }
2396 id = get_arr_temp(dtype, FALSE, FALSE, FALSE);
2397 if (sem.arrdim.ndefer)
2398 gen_allocate_array(id);
2399 ast = ast_rewrite_indices(ast);
2400 dest = mk_id(id);
2401 ast = mk_assn_stmt(dest, ast, dtype);
2402 add_stmt(ast);
2403 SST_ASTP(stkptr, dest);
2404 }
2405 }
2406
2407 /* if we have a%b, a and b are arrays, subscripts i,j,
2408 * turn this into a(i)%b(j); this is overkill, since F90
2409 * only allows one vector subscript in a member tree */
2410 static int
add_dt_subscr(int ast,int * subs,int numdim)2411 add_dt_subscr(int ast, int *subs, int numdim)
2412 {
2413 int lop, dtype;
2414 switch (A_TYPEG(ast)) {
2415 case A_SUBSCR:
2416 /* already have the subscripts */
2417 lop = A_LOPG(ast);
2418 if (A_TYPEG(lop) == A_ID) {
2419 assert(numdim == 0, "add_dt_subscr: too many subscripts", numdim, 3);
2420 } else if (A_TYPEG(lop) == A_MEM) {
2421 int parent, mem, asd, ndim, i, oldsubs[MAXDIMS];
2422 parent = add_dt_subscr(A_PARENTG(lop), subs, numdim);
2423 mem = A_MEMG(lop);
2424 dtype = DTYPEG(A_SPTRG(mem));
2425 mem = mk_member(parent, mem, dtype);
2426 asd = A_ASDG(ast);
2427 ndim = ASD_NDIM(asd);
2428 for (i = 0; i < ndim; ++i) {
2429 oldsubs[i] = ASD_SUBS(asd, i);
2430 }
2431 ast = mk_subscr(mem, oldsubs, ndim, DTY(dtype + 1));
2432 } else {
2433 interr("add_dt_subscr: unexpected subscript parent", A_TYPEG(lop), 3);
2434 }
2435 break;
2436
2437 case A_MEM:
2438 dtype = DTYPEG(A_SPTRG(A_MEMG(ast)));
2439 /* apply subscripts? */
2440 if (DTY(dtype) != TY_ARRAY) {
2441 int parent;
2442 parent = add_dt_subscr(A_PARENTG(ast), subs, numdim);
2443 ast = mk_member(parent, A_MEMG(ast), dtype);
2444 } else {
2445 int parent, ndim, odim;
2446 /* take some subscripts here */
2447 ndim = ADD_NUMDIM(dtype);
2448 odim = numdim - ndim;
2449 assert(odim >= 0, "add_dt_subscr: not enough subscripts", numdim - ndim,
2450 3);
2451 parent = add_dt_subscr(A_PARENTG(ast), subs, odim);
2452 ast = mk_member(parent, A_MEMG(ast), dtype);
2453 ast = mk_subscr(ast, subs + odim, ndim, DTY(dtype + 1));
2454 }
2455 break;
2456 case A_ID:
2457 dtype = DTYPEG(A_SPTRG(ast));
2458 /* apply subscripts? */
2459 if (DTY(dtype) != TY_ARRAY) {
2460 assert(numdim == 0, "add_dt_subscr: too many subscripts", numdim, 3);
2461 } else {
2462 int ndim;
2463 /* take rest of subscripts here */
2464 ndim = ADD_NUMDIM(dtype);
2465 assert(ndim == numdim, "add_dt_subscr: wrong number of subscripts",
2466 numdim - ndim, 3);
2467 ast = mk_subscr(ast, subs, ndim, DTY(dtype + 1));
2468 }
2469 break;
2470 }
2471 return ast;
2472 } /* add_dt_subscr */
2473
2474 static int oldindex[MAXDIMS], newindex[MAXDIMS], numindex;
2475
2476 static void
ast_replace_index(int old,int new)2477 ast_replace_index(int old, int new)
2478 {
2479 oldindex[numindex] = old;
2480 newindex[numindex] = new;
2481 ++numindex;
2482 } /* ast_replace_index */
2483
2484 static int
ast_rewrite_indices(int ast)2485 ast_rewrite_indices(int ast)
2486 {
2487 int i, newast;
2488 ast_visit(1, 1);
2489 for (i = 0; i < numindex; ++i) {
2490 ast_replace(oldindex[i], newindex[i]);
2491 }
2492 newast = ast_rewrite(ast);
2493 ast_unvisit();
2494 return newast;
2495 } /* ast_rewrite_indices */
2496
2497 static ACL *
acl_rewrite_asts(ACL * aclp)2498 acl_rewrite_asts(ACL *aclp)
2499 {
2500 int ast, initast, limitast, countast, stepast;
2501 SST *stkp, *sst;
2502 DOINFO *doinfo;
2503 ACL *newaclp, *subc, *next;
2504
2505 newaclp = 0;
2506 if (aclp->next) {
2507 next = acl_rewrite_asts(aclp->next);
2508 if (next != aclp->next) {
2509 newaclp = GET_ACL(15);
2510 *newaclp = *aclp;
2511 newaclp->next = next;
2512 }
2513 }
2514 switch (aclp->id) {
2515 case AC_AST:
2516 ast = ast_rewrite(aclp->u1.ast);
2517 if (ast != aclp->u1.ast) {
2518 if (newaclp == 0) {
2519 newaclp = GET_ACL(15);
2520 *newaclp = *aclp;
2521 }
2522 newaclp->u1.ast = ast;
2523 }
2524 break;
2525 case AC_EXPR:
2526 stkp = aclp->u1.stkp;
2527 ast = SST_ASTG(stkp);
2528 switch (SST_IDG(stkp)) {
2529 case S_ACONST:
2530 break;
2531 case S_CONST:
2532 ast = ast_rewrite(ast);
2533 break;
2534 case S_SCONST:
2535 ast = ast_rewrite(ast);
2536 break;
2537 case S_EXPR:
2538 ast = ast_rewrite(ast);
2539 break;
2540 case S_LVALUE:
2541 ast = ast_rewrite(ast);
2542 break;
2543 case S_IDENT:
2544 ast = ast_rewrite(ast);
2545 break;
2546 default:
2547 interr("acl_rewrite_asts: unknown expr type", SST_IDG(stkp), 3);
2548 break;
2549 }
2550 if (ast != SST_ASTG(stkp)) {
2551 NEW(sst, SST, SST_SIZE);
2552 if (sst == NULL)
2553 error(7, 4, 0, CNULL, CNULL);
2554 *sst = *stkp;
2555 SST_ASTP(sst, ast);
2556 if (newaclp == 0) {
2557 newaclp = GET_ACL(15);
2558 *newaclp = *aclp;
2559 }
2560 newaclp->u1.stkp = sst;
2561 }
2562 break;
2563 case AC_ACONST:
2564 case AC_SCONST:
2565 case AC_REPEAT:
2566 subc = acl_rewrite_asts(aclp->subc);
2567 if (subc != aclp->subc) {
2568 if (newaclp == 0) {
2569 newaclp = GET_ACL(15);
2570 *newaclp = *aclp;
2571 }
2572 newaclp->subc = subc;
2573 }
2574 break;
2575 case AC_IDO:
2576 doinfo = aclp->u1.doinfo;
2577 initast = ast_rewrite(doinfo->init_expr);
2578 limitast = ast_rewrite(doinfo->limit_expr);
2579 stepast = ast_rewrite(doinfo->step_expr);
2580 countast = ast_rewrite(doinfo->count);
2581 if (initast != doinfo->init_expr || limitast != doinfo->limit_expr ||
2582 stepast != doinfo->step_expr || countast != doinfo->count) {
2583 doinfo = get_doinfo(15);
2584 *doinfo = *(aclp->u1.doinfo);
2585 doinfo->init_expr = initast;
2586 doinfo->limit_expr = limitast;
2587 doinfo->step_expr = stepast;
2588 doinfo->count = countast;
2589 }
2590 subc = acl_rewrite_asts(aclp->subc);
2591 if (doinfo != aclp->u1.doinfo || subc != aclp->subc) {
2592 if (newaclp == 0) {
2593 newaclp = GET_ACL(15);
2594 *newaclp = *aclp;
2595 }
2596 newaclp->subc = subc;
2597 newaclp->u1.doinfo = doinfo;
2598 }
2599 break;
2600 default:
2601 interr("acl_rewrite_asts: unknown ACL id", aclp->id, 3);
2602 break;
2603 }
2604 return newaclp ? newaclp : aclp;
2605 } /* acl_rewrite_asts */
2606
2607 static int
gen_null_intrin()2608 gen_null_intrin()
2609 {
2610 int func_ast, ast;
2611 func_ast = mk_id(intast_sym[I_NULL]);
2612 ast = mk_func_node(A_INTR, func_ast, 0, 0);
2613 A_DTYPEP(ast, DT_WORD);
2614 EXPSTP(intast_sym[I_NULL], 1);
2615 A_OPTYPEP(ast, I_NULL);
2616 return ast;
2617 }
2618
2619 static int
_constructf90(int base_id,int in_indexast,bool in_array,ACL * aclp)2620 _constructf90(int base_id, int in_indexast, bool in_array, ACL *aclp)
2621 {
2622 int i;
2623 SST *stkp;
2624 DOINFO *doinfo;
2625 int ast;
2626 DTYPE dtype;
2627 int odovar, dovar;
2628 int dest;
2629 int src_subs[MAXDIMS];
2630 int src;
2631 int tmpsptr;
2632 int mem_sptr, mem_sptr_id, cmem_sptr;
2633 ACL *mem_aclp;
2634 ACL *tmp;
2635 int tmpid;
2636 int indexast;
2637 INT cnt;
2638 LOGICAL sdscismbr;
2639
2640 indexast = in_indexast;
2641
2642 #if DEBUG
2643 if (DBGBIT(3, 64))
2644 printacl("_constructf90", aclp, gbl.dbgfil);
2645 #endif
2646
2647 for (; aclp != NULL; aclp = aclp->next) {
2648 switch (aclp->id) {
2649 case AC_ACONST:
2650 if (in_array) {
2651 indexast = _constructf90(base_id, indexast, true, aclp->subc);
2652 } else {
2653 push_subscript();
2654 indexast = _constructf90(base_id, SHD_LWB(A_SHAPEG(base_id), 0), true,
2655 aclp->subc);
2656 pop_subscript();
2657 }
2658 break;
2659 case AC_SCONST:
2660 mem_aclp = aclp->subc;
2661 dtype = aclp->dtype;
2662 if (in_array)
2663 dest = add_subscript(base_id, indexast, dtype);
2664 else
2665 dest = base_id;
2666 dtype = DDTG(dtype);
2667
2668 mem_sptr = DTY(dtype + 1);
2669 for (; mem_sptr != NOSYM; mem_sptr = SYMLKG(mem_sptr)) {
2670 if (!is_unl_poly(mem_sptr) && no_data_components(DTYPEG(mem_sptr)))
2671 continue;
2672 /* skip $td */
2673 if (CLASSG(mem_sptr) && DESCARRAYG(mem_sptr))
2674 continue;
2675 if (XBIT(58, 0x10000) && POINTERG(mem_sptr) && !F90POINTERG(mem_sptr)) {
2676 SST *astkp;
2677 int aast;
2678 int stmtast, asptr;
2679 if (!mem_aclp) {
2680 /* Check to see if there's a default
2681 * initialization for this missing element in the
2682 * structure constructor. If not, then issue an
2683 * error message.
2684 */
2685 mem_aclp = get_struct_default_init(mem_sptr);
2686 if (!mem_aclp) {
2687 error(155, 3, gbl.lineno, "No default initialization for",
2688 SYMNAME(mem_sptr));
2689 mem_aclp = GET_ACL(15);
2690 mem_aclp->id = AC_AST;
2691 mem_aclp->dtype = DT_PTR;
2692 mem_aclp->u1.ast = astb.i0;
2693 }
2694 }
2695 if (mem_aclp->id == AC_AST &&
2696 (mem_aclp->dtype == DT_PTR || POINTERG(mem_sptr)) &&
2697 mem_aclp->u1.ast == astb.i0) {
2698 /* Convert this to NULL then assign ptr */
2699 aast = gen_null_intrin();
2700 } else if (DTY(DTYPEG(mem_sptr)) == TY_PTR &&
2701 DTY(DTY(DTYPEG(mem_sptr) + 1)) == TY_PROC) {
2702 /* cannot call mkexpr which later call mkexpr1
2703 * for procedure(subroutine) assignment of
2704 * derived type in structure constructor.
2705 */
2706 mkexpr2(mem_aclp->u1.stkp);
2707 astkp = mem_aclp->u1.stkp;
2708 aast = SST_ASTG(astkp);
2709 } else {
2710 mkexpr(mem_aclp->u1.stkp);
2711 astkp = mem_aclp->u1.stkp;
2712 aast = SST_ASTG(astkp);
2713 }
2714 if ((A_TYPEG(aast) == A_INTR && A_OPTYPEG(aast) == I_NULL) ||
2715 (DTY(DTYPEG(mem_sptr)) == TY_PTR &&
2716 DTY(DTY(DTYPEG(mem_sptr) + 1)) == TY_PROC)) {
2717
2718 if (!(A_TYPEG(aast) == A_INTR && A_OPTYPEG(aast) == I_NULL))
2719 (void)chk_pointer_target(mem_sptr, aast);
2720
2721 stmtast = add_ptr_assign(mkmember(dtype, dest, NMPTRG(mem_sptr)),
2722 aast, 0);
2723 add_stmt(ast_rewrite_indices(stmtast));
2724 mem_aclp = mem_aclp->next;
2725 if (SDSCG(mem_sptr) && STYPEG(SDSCG(mem_sptr)) == ST_MEMBER) {
2726 cmem_sptr = mem_sptr;
2727 if (SYMLKG(mem_sptr) == MIDNUMG(cmem_sptr)) {
2728 /* point to pointer */
2729 mem_sptr = SYMLKG(mem_sptr);
2730 }
2731 if (SYMLKG(mem_sptr) == PTROFFG(cmem_sptr)) {
2732 /* point to offset */
2733 mem_sptr = SYMLKG(mem_sptr);
2734 }
2735 if (SYMLKG(mem_sptr) == SDSCG(cmem_sptr)) {
2736 /* point to sdsc */
2737 mem_sptr = SYMLKG(mem_sptr);
2738 }
2739 if (CLASSG(cmem_sptr) && DESCARRAYG(mem_sptr)) {
2740 /* points to $td */
2741 mem_sptr = SYMLKG(mem_sptr);
2742 }
2743 } else if (MIDNUMG(mem_sptr)) {
2744 mem_sptr = MIDNUMG(mem_sptr); /* skip $o, $sd, $p */
2745 }
2746 } else if (SDSCG(mem_sptr)) {
2747 (void)chk_pointer_target(mem_sptr, aast);
2748 astkp = mem_aclp->u1.stkp;
2749 i = NMPTRG(mem_sptr);
2750 if (SST_IDG(astkp) == S_IDENT) {
2751 asptr = SST_SYMG(astkp);
2752 aast = mk_id(asptr);
2753 } else if (SST_IDG(astkp) == S_LVALUE) {
2754 aast = mem_aclp->u1.stkp->ast;
2755 if (aast == 0) {
2756 asptr = SST_LSYMG(astkp);
2757 aast = mk_id(asptr);
2758 }
2759 } else {
2760 aast = mem_aclp->u1.stkp->ast;
2761 }
2762 if (STYPEG(SDSCG(mem_sptr)) == ST_MEMBER) {
2763 /* do a 'pointer-assign' here. skip over
2764 * base pointer/offset/descriptor */
2765 stmtast = add_ptr_assign(mkmember(dtype, dest, i), aast, 0);
2766 (void)add_stmt(ast_rewrite_indices(stmtast));
2767 cmem_sptr = mem_sptr;
2768 if (SYMLKG(mem_sptr) == MIDNUMG(cmem_sptr)) {
2769 /* point to pointer */
2770 mem_sptr = SYMLKG(mem_sptr);
2771 }
2772 mem_aclp = mem_aclp->next;
2773 if (SYMLKG(mem_sptr) == PTROFFG(cmem_sptr)) {
2774 /* point to offset */
2775 mem_sptr = SYMLKG(mem_sptr);
2776 }
2777 mem_aclp = mem_aclp->next;
2778 if (SYMLKG(mem_sptr) == SDSCG(cmem_sptr)) {
2779 /* point to sdsc */
2780 mem_sptr = SYMLKG(mem_sptr);
2781 }
2782 mem_aclp = mem_aclp->next;
2783 if (CLASSG(cmem_sptr) && DESCARRAYG(mem_sptr)) {
2784 /* points to $td, no aclp, part of sdsc */
2785 mem_sptr = SYMLKG(mem_sptr);
2786 }
2787 mem_aclp = mem_aclp->next; /* past sdsc */
2788 } else {
2789 stmtast = add_ptr_assign(mkmember(dtype, dest, i), aast, 0);
2790 (void)add_stmt(ast_rewrite_indices(stmtast));
2791 mem_aclp = mem_aclp->next;
2792 mem_sptr = MIDNUMG(mem_sptr); /* skip $o, $sd, $p */
2793 }
2794 } else {
2795 mem_aclp = mem_aclp->next; /* skip pointee */
2796 }
2797 continue;
2798 } else if (ALLOCATTRG(mem_sptr)) {
2799 int stmt, orig_mem_sptr;
2800 ast = mk_id(mem_sptr);
2801 orig_mem_sptr = mem_sptr;
2802 if (mem_aclp->id == AC_ACONST) {
2803 mem_sptr_id = mk_member(dest, ast, DTYPEG(mem_sptr));
2804 tmpsptr = getcctmp_sc('f', sem.dtemps++, ST_ARRAY, mem_aclp->dtype,
2805 SC_STATIC);
2806 NODESCP(tmpsptr, 0);
2807 tmp = clone_init_const(mem_aclp, FALSE);
2808 init_sptr_w_acl(tmpsptr, tmp);
2809 acs.is_const = 0;
2810 ast = mk_id(tmpsptr);
2811 ast = mk_assn_stmt(mem_sptr_id, ast, mem_aclp->dtype);
2812 stmt = add_stmt(ast);
2813 /* need init $p $sd */
2814 (void)add_stmt_before(add_nullify_ast(mem_sptr_id), stmt);
2815 } else if (mem_aclp->id == AC_SCONST) {
2816 if (is_unl_poly(mem_sptr)) {
2817 mem_sptr_id = mk_member(dest, ast, mem_aclp->dtype);
2818 } else {
2819 mem_sptr_id = mk_member(dest, ast, DTYPEG(mem_sptr));
2820 }
2821 tmpsptr = getcctmp_sc('f', sem.dtemps++, ST_VAR, mem_aclp->dtype,
2822 SC_STATIC);
2823 NODESCP(tmpsptr, 0);
2824 tmp = clone_init_const(mem_aclp, FALSE);
2825 init_derived_w_acl(tmpsptr, tmp);
2826 acs.is_const = 0;
2827 ast = mk_id(tmpsptr);
2828 ast = mk_assn_stmt(mem_sptr_id, ast, mem_aclp->dtype);
2829 stmt = add_stmt(ast);
2830
2831 } else if (mem_aclp->id == AC_EXPR &&
2832 A_TYPEG(mem_aclp->u1.stkp->ast) == A_INTR &&
2833 A_OPTYPEG(mem_aclp->u1.stkp->ast) == I_NULL) {
2834 mem_sptr_id = mk_member(dest, ast, DTYPEG(mem_sptr));
2835 ast = add_nullify_ast(mem_sptr_id);
2836 stmt = add_stmt(ast);
2837 } else if ((DTYPEG(mem_sptr)) == DT_DEFERCHAR ||
2838 (DTYPEG(mem_sptr)) == DT_DEFERNCHAR) {
2839
2840 mem_sptr_id = mk_member(dest, ast, DTYPEG(mem_sptr));
2841 if (mem_aclp->id == AC_AST && mem_aclp->u1.ast == astb.i0) {
2842 ast = add_nullify_ast(mem_sptr_id);
2843 } else {
2844 ast = add_nullify_ast(mem_sptr_id);
2845 stmt = add_stmt(ast);
2846 mkexpr(mem_aclp->u1.stkp);
2847 ast = mem_aclp->u1.stkp->ast;
2848 ast = mk_assn_stmt(mem_sptr_id, ast, A_DTYPEG(ast));
2849 }
2850
2851 stmt = add_stmt(ast);
2852
2853 if (SDSCG(mem_sptr) && STYPEG(SDSCG(mem_sptr)) == ST_MEMBER) {
2854 cmem_sptr = mem_sptr;
2855 if (SYMLKG(mem_sptr) == MIDNUMG(cmem_sptr)) {
2856 /* point to pointer */
2857 mem_sptr = SYMLKG(mem_sptr);
2858 }
2859 if (SYMLKG(mem_sptr) == PTROFFG(cmem_sptr)) {
2860 /* point to offset */
2861 mem_sptr = SYMLKG(mem_sptr);
2862 }
2863 if (SYMLKG(mem_sptr) == SDSCG(cmem_sptr)) {
2864 /* point to sdsc */
2865 mem_sptr = SYMLKG(mem_sptr);
2866 }
2867 if (CLASSG(cmem_sptr) && DESCARRAYG(mem_sptr)) {
2868 /* points to $td */
2869 mem_sptr = SYMLKG(mem_sptr);
2870 }
2871 } else {
2872 mem_sptr = MIDNUMG(mem_sptr); /* skip $o, $sd, $p */
2873 }
2874 mem_aclp = mem_aclp->next;
2875 continue;
2876
2877 } else {
2878 if (mem_aclp->id == AC_EXPR && is_unl_poly(mem_sptr)) {
2879 mem_sptr_id = mk_member(dest, ast, SST_DTYPEG(mem_aclp->u1.stkp));
2880 } else {
2881 mem_sptr_id = mk_member(dest, ast, DTYPEG(mem_sptr));
2882 }
2883 if (mem_aclp->id == AC_AST && mem_aclp->u1.ast == astb.i0) {
2884 ast = add_nullify_ast(mem_sptr_id);
2885 } else {
2886 mkexpr(mem_aclp->u1.stkp);
2887 ast = mem_aclp->u1.stkp->ast;
2888 ast = mk_assn_stmt(mem_sptr_id, ast, A_DTYPEG(ast));
2889 }
2890 stmt = add_stmt(ast);
2891 }
2892
2893 sdscismbr = (SDSCG(mem_sptr) && STYPEG(SDSCG(mem_sptr)) == ST_MEMBER);
2894 mem_sptr = SYMLKG(mem_sptr); /* point to pointer */
2895 mem_aclp = mem_aclp->next;
2896 if (sdscismbr) {
2897 mem_sptr = SYMLKG(mem_sptr); /* point to offset */
2898 if (DTY(DTYPEG(orig_mem_sptr)) == TY_ARRAY)
2899 mem_sptr = SYMLKG(mem_sptr); /* point to sdsc */
2900 }
2901 continue;
2902 }
2903 i = NMPTRG(mem_sptr);
2904 mem_sptr_id = mkmember(dtype, dest, i);
2905 if (mem_aclp == 0) {
2906 /* interr("ran out of aclp",sptr,2); */
2907 break;
2908 }
2909 tmp = mem_aclp->next;
2910 mem_aclp->next = 0; /* decouple aclp */
2911 i = _constructf90(mem_sptr_id, 0, false, mem_aclp);
2912 mem_aclp->next = tmp; /* relink behind us */
2913 mem_aclp = tmp;
2914 }
2915 if (in_array) {
2916 indexast = mk_binop(OP_ADD, indexast, astb.bnd.one, astb.bnd.dtype);
2917 incr_element_cnt();
2918 }
2919 break;
2920 case AC_EXPR:
2921 stkp = aclp->u1.stkp;
2922 if (in_array)
2923 mkexpr_assign_temp(stkp);
2924 else
2925 mkexpr(stkp);
2926 dtype = SST_DTYPEG(stkp);
2927 if (DTY(dtype) == TY_ARRAY) {
2928 /* constructor item is an array */
2929 int shp;
2930 int shpdest;
2931 int ndim;
2932 int iv;
2933
2934 if (!in_array) {
2935 /* handle case where a (possibly multiple dimensioned
2936 array is assigned to a structure element. */
2937 src = SST_ASTG(stkp);
2938 shp = A_SHAPEG(src);
2939 dest = base_id;
2940 shpdest = A_SHAPEG(dest);
2941 ndim = SHD_NDIM(shp);
2942 add_shape_rank(ndim);
2943 for (i = 0; i < ndim; i++) {
2944 ast = extent_of_shape(shp, i);
2945 ast = mk_binop(
2946 OP_SUB,
2947 mk_binop(OP_ADD, SHD_LWB(shpdest, i), ast, astb.bnd.dtype),
2948 astb.i1, astb.bnd.dtype);
2949 add_shape_spec(SHD_LWB(shpdest, i), ast, astb.i1);
2950 }
2951 shpdest = mk_shape();
2952 dest = apply_shape_subscripts(base_id, shpdest, dtype);
2953 ast = mk_assn_stmt(dest, src, dtype);
2954 ast = ast_rewrite_indices(ast);
2955 (void)add_stmt(ast);
2956 break;
2957 }
2958
2959 tmpid = get_subscripting_tmp(indexast);
2960
2961 /* get do begins for src array objects */
2962 shp = A_SHAPEG(SST_ASTG(stkp));
2963 ndim = SHD_NDIM(shp);
2964 for (i = ndim - 1; i >= 0; i--) {
2965 iv = get_temp(astb.bnd.dtype);
2966 ast = mk_stmt(A_DO, 0);
2967 dovar = mk_id(iv);
2968 A_DOVARP(ast, dovar);
2969 A_M1P(ast, SHD_LWB(shp, i));
2970 A_M2P(ast, SHD_UPB(shp, i));
2971 A_M3P(ast, SHD_STRIDE(shp, i));
2972 ast = ast_rewrite_indices(ast);
2973 (void)add_stmt(ast);
2974 src_subs[i] = A_DOVARG(ast);
2975 }
2976
2977 src = add_dt_subscr(SST_ASTG(stkp), src_subs, ndim);
2978
2979 dest = add_subscript(base_id, tmpid, DTY(dtype + 1));
2980
2981 ast = mk_assn_stmt(dest, src, DTY(dtype + 1));
2982 ast = ast_rewrite_indices(ast);
2983 (void)add_stmt(ast);
2984
2985 /* increment the subscripting temporary */
2986 incr_tmp(tmpid);
2987
2988 for (i = 0; i < ndim; i++) {
2989 ast = mk_stmt(A_ENDDO, 0);
2990 (void)add_stmt(ast);
2991 }
2992
2993 clear_element_cnt();
2994 indexast = tmpid;
2995 } else {
2996 /* constructor item is a scalar */
2997 src = SST_ASTG(stkp);
2998 dest = base_id;
2999 dtype = A_DTYPEG(dest);
3000 if (in_array) {
3001 dtype = DDTG(dtype);
3002 dest = add_subscript(dest, indexast, dtype);
3003 }
3004 if (DTY(dtype) != TY_ARRAY && ast_is_sym(src) &&
3005 has_layout_desc(memsym_of_ast(src))) {
3006 int argt, dest_td_sym, src_td_sym;
3007 dest_td_sym = getccsym('d', sem.dtemps++, ST_VAR);
3008 DTYPEP(dest_td_sym, dtype);
3009 src_td_sym = getccsym('d', sem.dtemps++, ST_VAR);
3010 DTYPEP(src_td_sym, A_DTYPEG(src));
3011 argt = mk_argt(5);
3012 ARGT_ARG(argt, 0) = dest;
3013 ARGT_ARG(argt, 1) = mk_id(get_static_type_descriptor(dest_td_sym));
3014 ARGT_ARG(argt, 2) = src;
3015 ARGT_ARG(argt, 3) = mk_id(get_static_type_descriptor(src_td_sym));
3016 ARGT_ARG(argt, 4) = mk_unop(OP_VAL, mk_cval1(1, DT_INT), DT_INT);
3017 ast = mk_id(sym_mkfunc_nodesc(mkRteRtnNm(RTE_poly_asn), DT_NONE));
3018 ast = mk_func_node(A_CALL, ast, 5, argt);
3019 } else {
3020 ast = mk_assn_stmt(dest, src, dtype);
3021 }
3022 ast = ast_rewrite_indices(ast);
3023 (void)add_stmt(ast);
3024 if (in_array) {
3025 indexast = mk_binop(OP_ADD, indexast, astb.bnd.one, astb.bnd.dtype);
3026 incr_element_cnt();
3027 }
3028 }
3029 break;
3030 case AC_IDO:
3031 tmpid = get_subscripting_tmp(indexast);
3032
3033 acs.level++;
3034 clear_element_cnt();
3035 doinfo = aclp->u1.doinfo;
3036 /* for array constructor, we must create a new symbol
3037 * for the implied 'do' loop */
3038 odovar = doinfo->index_var;
3039 /* insert a new one */
3040 dovar = get_temp(DDTG(DTYPEG(odovar)));
3041 STYPEP(dovar, STYPEG(odovar));
3042 DTYPEP(dovar, DTYPEG(odovar));
3043 if (SCG(odovar) == SC_PRIVATE) {
3044 SCP(dovar, SC_PRIVATE);
3045 } else {
3046 SCP(dovar, SC_LOCAL);
3047 }
3048 HIDDENP(dovar, 1);
3049 ast_replace_index(mk_id(odovar), mk_id(dovar));
3050 doinfo->index_var = dovar;
3051 ast = do_begin(doinfo);
3052 ast = ast_rewrite_indices(ast);
3053
3054 /* Folling line of code is an extension, where we allow
3055 * a ac-do-variable to be referenced in limit expression.
3056 * Do not rewrite ast of limit_expr. For example,
3057 * do i = 1, n
3058 * x = (/i,i = 1,fox(i)/)
3059 * end do
3060 * i in fox(i) is from do i=1, not implied-do-variable i
3061 */
3062
3063 if (!XBIT(57, 0x4000))
3064 A_M2P(ast, doinfo->limit_expr);
3065
3066 (void)add_stmt(ast);
3067 /* Value-list must be rewritten too. */
3068 ast_visit(1, 1);
3069 ast_replace(mk_id(odovar), mk_id(dovar));
3070 aclp->subc = acl_rewrite_asts(aclp->subc);
3071 ast_unvisit();
3072
3073 _constructf90(base_id, tmpid, in_array, aclp->subc);
3074
3075 if ((cnt = get_element_cnt())) {
3076 /* increment the subscripting temporary */
3077 i = mk_isz_cval(cnt, astb.bnd.dtype);
3078 i = mk_binop(OP_ADD, tmpid, i, astb.bnd.dtype);
3079 ast = mk_assn_stmt(tmpid, i, astb.bnd.dtype);
3080 ast = ast_rewrite_indices(ast);
3081 (void)add_stmt(ast);
3082 }
3083
3084 NEED_DOIF(i, DI_DO); /* need a loop stack entry for do_end() */
3085 do_end(doinfo);
3086 --numindex; /* done with this loop */
3087 indexast = tmpid;
3088 clear_element_cnt();
3089 acs.level--;
3090 break;
3091 case AC_AST: /* default init */
3092 ast = aclp->u1.ast;
3093 dtype = A_DTYPEG(ast);
3094
3095 if (is_iso_cptr(dtype)) {
3096 mem_sptr = DTY(dtype + 1);
3097 ast = mkmember(dtype, ast, NMPTRG(mem_sptr));
3098 }
3099
3100 if (in_array) {
3101 dtype = DDTG(A_DTYPEG(base_id));
3102 dest = add_subscript(base_id, indexast, dtype);
3103 } else {
3104 dtype = A_DTYPEG(base_id);
3105 dest = base_id;
3106 }
3107
3108 ast = mk_assn_stmt(dest, ast, dtype);
3109
3110 ast = ast_rewrite_indices(ast);
3111 (void)add_stmt(ast);
3112 if (in_array) {
3113 indexast = mk_binop(OP_ADD, indexast, astb.bnd.one, astb.bnd.dtype);
3114 incr_element_cnt();
3115 }
3116 break;
3117 case AC_IEXPR:
3118 break;
3119 default:
3120 interr("_construct,ill.id", aclp->id, 3);
3121 break;
3122 }
3123 }
3124
3125 return indexast;
3126 }
3127
3128 static void
constructf90(int arr,ACL * aclp)3129 constructf90(int arr, ACL *aclp)
3130 {
3131 DTYPE dtype;
3132 int lower;
3133 bool inarray;
3134
3135 init_constructf90();
3136
3137 acs.level = 0;
3138 acs.width = compute_width(aclp);
3139
3140 dtype = DTYPEG(arr);
3141 inarray = DTY(dtype) == TY_ARRAY;
3142 if (inarray) {
3143 lower = ADD_LWAST(dtype, 0);
3144 if (lower == 0)
3145 lower = astb.bnd.one;
3146 push_subscript();
3147 } else {
3148 lower = astb.bnd.one;
3149 }
3150
3151 acs.tmpid = mk_id(arr);
3152
3153 numindex = 0;
3154 _constructf90(acs.tmpid, lower, inarray, aclp);
3155
3156 if (DTY(dtype) == TY_ARRAY) {
3157 pop_subscript();
3158 }
3159
3160 if (sub_i != 7)
3161 interr("sub_i in constructf90 is not back", sub_i, 2);
3162 }
3163
3164 ACL *
mk_init_intrinsic(AC_INTRINSIC init_intr)3165 mk_init_intrinsic(AC_INTRINSIC init_intr)
3166 {
3167 AEXPR *aexpr;
3168 ACL *expracl = GET_ACL(15);
3169
3170 expracl->id = AC_IEXPR;
3171 expracl->u1.expr = aexpr = (AEXPR *)getitem(15, sizeof(AEXPR));
3172 BZERO(aexpr, AEXPR, 1);
3173 aexpr->op = AC_INTR_CALL;
3174 aexpr->lop = GET_ACL(15);
3175 aexpr->lop->id = AC_ICONST;
3176 aexpr->lop->u1.i = init_intr;
3177
3178 return expracl;
3179 }
3180
3181 static ACL *
mk_ulbound_intrin(AC_INTRINSIC intrin,int ast)3182 mk_ulbound_intrin(AC_INTRINSIC intrin, int ast)
3183 {
3184 ACL *argacl;
3185 ACL *dimval;
3186 ACL **r;
3187 AEXPR *aexpr;
3188 int ubound[MAXDIMS];
3189 int lbound[MAXDIMS];
3190 int i;
3191 LOGICAL must_convert;
3192 ACL *expracl = mk_init_intrinsic(intrin);
3193 int arg_count = A_ARGCNTG(ast);
3194 int argt = A_ARGSG(ast);
3195 int argast = ARGT_ARG(argt, 0);
3196 int shape = A_SHAPEG(argast);
3197 int rank = SHD_NDIM(shape);
3198 int dtyper, dtyper2;
3199
3200 for (i = 0; i < rank; i++) {
3201 if (A_TYPEG(argast) == A_ID) {
3202 ubound[i] = ubound_of_shape(shape, i);
3203 lbound[i] = lbound_of_shape(shape, i);
3204 } else {
3205 ubound[i] = extent_of_shape(shape, i);
3206 lbound[i] = astb.i1;
3207 }
3208 }
3209
3210 aexpr = expracl->u1.expr;
3211
3212 argacl = aexpr->rop = GET_ACL(15);
3213 argacl->id = AC_ACONST;
3214 sem.arrdim.ndim = 1;
3215 sem.arrdim.ndefer = 0;
3216 sem.bounds[0].lowtype = S_CONST;
3217 sem.bounds[0].lowb = 1;
3218 sem.bounds[0].lwast = 0;
3219 sem.bounds[0].uptype = S_CONST;
3220 sem.bounds[0].upb = rank;
3221 sem.bounds[0].upast = mk_cval(rank, stb.user.dt_int);
3222 dtyper = mk_arrdsc();
3223 DTY(dtyper + 1) = stb.user.dt_int;
3224 argacl->dtype = dtyper;
3225
3226 must_convert = FALSE;
3227 if (arg_count == 2 && argacl->dtype != stb.user.dt_int)
3228 must_convert = TRUE;
3229
3230 r = &argacl->subc;
3231 for (i = 0; i < rank; i++) {
3232 *r = GET_ACL(15);
3233 (*r)->id = AC_AST;
3234 (*r)->dtype = stb.user.dt_int;
3235 (*r)->is_const = TRUE;
3236 if (intrin == AC_I_ubound) {
3237 (*r)->u1.ast = ubound[i];
3238 } else {
3239 (*r)->u1.ast = lbound[i];
3240 }
3241 if (must_convert) {
3242 (*r)->u1.ast = mk_convert((*r)->u1.ast, stb.user.dt_int);
3243 }
3244 r = &(*r)->next;
3245 }
3246
3247 if (arg_count == 2) {
3248 argast = ARGT_ARG(argt, 1);
3249 if (!_can_fold(argast)) {
3250 error(87, 3, gbl.lineno, NULL, NULL);
3251 }
3252 argacl = construct_acl_from_ast(argast, stb.user.dt_int, 0);
3253 if (!argacl) {
3254 return 0;
3255 }
3256 aexpr->rop->next = argacl;
3257 expracl->dtype = stb.user.dt_int;
3258
3259 dimval = eval_init_expr_item(argacl);
3260 if (!dimval) {
3261 return 0;
3262 }
3263 i = dimval->conval;
3264 if (dimval->dtype == DT_INT8)
3265 i = get_int_cval(i);
3266 if ((intrin == AC_I_ubound && !_can_fold(ubound[i - 1])) ||
3267 (intrin == AC_I_lbound && !_can_fold(lbound[i - 1]))) {
3268 error(87, 3, gbl.lineno, NULL, NULL);
3269 sem.dinit_error = TRUE;
3270 return 0;
3271 }
3272 } else {
3273 for (i = 0; i < rank; i++) {
3274 if ((intrin == AC_I_ubound && !_can_fold(ubound[i])) ||
3275 (intrin == AC_I_lbound && !_can_fold(lbound[i]))) {
3276 error(87, 3, gbl.lineno, NULL, NULL);
3277 sem.dinit_error = TRUE;
3278 return 0;
3279 }
3280 }
3281 expracl->dtype = A_DTYPEG(ast);
3282 ;
3283 }
3284
3285 return expracl;
3286 }
3287
3288 static ACL *
mk_reshape_intrin(int ast)3289 mk_reshape_intrin(int ast)
3290 {
3291 ACL *expracl;
3292 int arg_count;
3293 int argt;
3294 AEXPR *aexpr;
3295 int srcast;
3296 int shapeast;
3297 int padast = 0;
3298 int orderast = 0;
3299 ACL *a;
3300 int new_sz, old_sz;
3301
3302 expracl = mk_init_intrinsic(AC_I_reshape);
3303 aexpr = expracl->u1.expr;
3304
3305 arg_count = A_ARGCNTG(ast);
3306 argt = A_ARGSG(ast);
3307
3308 /* Ignore arg2, the shape was built and plugged in ref_pd */
3309 shapeast = ARGT_ARG(argt, 1);
3310 srcast = ARGT_ARG(argt, 0);
3311
3312 new_sz = get_int_cval(sym_of_ast(ADD_NUMELM(A_DTYPEG(ast))));
3313 old_sz = get_int_cval(sym_of_ast(ADD_NUMELM(A_DTYPEG(srcast))));
3314 if (arg_count > 2) {
3315 padast = ARGT_ARG(argt, 2);
3316 if (arg_count > 3) {
3317 orderast = ARGT_ARG(argt, 3);
3318 }
3319 }
3320
3321 /* compute the number of elements in the source */
3322 if (new_sz > old_sz && !padast) {
3323 error(4, 3, gbl.lineno,
3324 "Source and shape argument size mismatch, too few source constants",
3325 NULL);
3326 sem.dinit_error = TRUE;
3327 return 0;
3328 }
3329
3330 expracl->dtype = A_DTYPEG(ast);
3331
3332 aexpr->rop = construct_acl_from_ast(srcast, A_DTYPEG(srcast), 0);
3333 if (!aexpr->rop) {
3334 return 0;
3335 }
3336 aexpr->rop->next = construct_acl_from_ast(shapeast, A_DTYPEG(shapeast), 0);
3337 if (!aexpr->rop->next) {
3338 return 0;
3339 }
3340
3341 if (arg_count > 2) {
3342 if (padast) {
3343 aexpr->rop->next->next =
3344 construct_acl_from_ast(padast, A_DTYPEG(padast), 0);
3345 if (!aexpr->rop->next->next) {
3346 return 0;
3347 }
3348 } else {
3349 a = GET_ACL(15);
3350 a->id = AC_AST;
3351 a->dtype = stb.user.dt_int;
3352 a->u1.ast = astb.i0;
3353 aexpr->rop->next->next = a;
3354 }
3355
3356 if (arg_count > 3 && orderast) {
3357 aexpr->rop->next->next->next =
3358 construct_acl_from_ast(orderast, A_DTYPEG(orderast), 0);
3359 if (!aexpr->rop->next->next->next) {
3360 return 0;
3361 }
3362 }
3363 }
3364
3365 return expracl;
3366 }
3367
3368 static ACL *
mk_shape_intrin(int ast)3369 mk_shape_intrin(int ast)
3370 {
3371 ACL *expracl;
3372 ACL *argacl;
3373 int argast;
3374 ACL **r;
3375 AEXPR *aexpr;
3376 int rank;
3377 int shape;
3378 int argt;
3379 int ubound[MAXDIMS];
3380 int lbound[MAXDIMS];
3381 int i;
3382
3383 expracl = mk_init_intrinsic(AC_I_shape);
3384 expracl->dtype = A_DTYPEG(ast);
3385
3386 argt = A_ARGSG(ast);
3387
3388 argast = ARGT_ARG(argt, 0);
3389 shape = A_SHAPEG(argast);
3390 rank = SHD_NDIM(shape);
3391
3392 for (i = 0; i < rank; i++) {
3393 if (A_TYPEG(argast) == A_ID) {
3394 ubound[i] = ubound_of_shape(shape, i);
3395 lbound[i] = lbound_of_shape(shape, i);
3396 if (lbound[i] != astb.i1 || lbound[i] != astb.i0) {
3397 ubound[i] = extent_of_shape(shape, i);
3398 }
3399 } else {
3400 ubound[i] = extent_of_shape(shape, i);
3401 lbound[i] = astb.i1;
3402 }
3403 }
3404
3405 aexpr = expracl->u1.expr;
3406
3407 argacl = aexpr->rop = GET_ACL(15);
3408 argacl->id = AC_ACONST;
3409 argacl->dtype = A_DTYPEG(argast);
3410
3411 r = &argacl->subc;
3412 for (i = 0; i < rank; i++) {
3413 *r = GET_ACL(15);
3414 (*r)->id = AC_AST;
3415 (*r)->dtype = stb.user.dt_int;
3416 (*r)->is_const = TRUE;
3417 (*r)->u1.ast = ubound[i];
3418 r = &(*r)->next;
3419 }
3420
3421 return expracl;
3422 }
3423
3424 static ACL *
mk_size_intrin(int ast)3425 mk_size_intrin(int ast)
3426 {
3427 ACL *expracl;
3428 ACL **csub_acl;
3429 ACL *c_acl;
3430 ACL *arg2acl;
3431 ACL *dimval;
3432 int arg1ast;
3433 int arg2ast;
3434 DTYPE dtype;
3435 int shape;
3436 int rank;
3437 int i;
3438 int argt;
3439 int arg_count;
3440
3441 /* Build a new arg list that contains:
3442 * 1) array size (possible astb.i0)
3443 * 2) array constructor containing the size of each dimension
3444 * 3) original DIM arg (optional)
3445 * (athough I'm not sure why, it would be much easier to just
3446 * plug the size value).
3447 */
3448
3449 expracl = mk_init_intrinsic(AC_I_size);
3450 expracl->dtype = stb.user.dt_int;
3451
3452 arg_count = A_ARGCNTG(ast);
3453 argt = A_ARGSG(ast);
3454
3455 arg1ast = ARGT_ARG(argt, 0);
3456 shape = A_SHAPEG(arg1ast);
3457 rank = SHD_NDIM(shape);
3458
3459 if (arg_count == 1) {
3460 if (A_TYPEG(arg1ast) == A_ID &&
3461 (ASUMSZG(A_SPTRG(arg1ast)) || ASSUMSHPG(A_SPTRG(arg1ast)))) {
3462 error(87, 3, gbl.lineno, NULL, NULL);
3463 sem.dinit_error = TRUE;
3464 return 0;
3465 }
3466 } else {
3467 arg2ast = ARGT_ARG(argt, 1);
3468 if (!_can_fold(arg2ast)) {
3469 error(422, 3, gbl.lineno, NULL, NULL);
3470 sem.dinit_error = TRUE;
3471 return 0;
3472 }
3473 arg2acl = construct_acl_from_ast(arg2ast, A_DTYPEG(arg2ast), 0);
3474 if (!arg2acl) {
3475 return 0;
3476 }
3477 dimval = eval_init_expr_item(arg2acl);
3478 if (!dimval) {
3479 return 0;
3480 }
3481 i = dimval->conval;
3482 if (i > rank) {
3483 error(423, 3, gbl.lineno, NULL, NULL);
3484 sem.dinit_error = TRUE;
3485 return 0;
3486 }
3487 }
3488
3489 expracl->u1.expr->rop = c_acl = GET_ACL(15);
3490 c_acl->id = AC_AST;
3491 c_acl->dtype = stb.user.dt_int;
3492 if (A_TYPEG(arg1ast) == A_ID &&
3493 (ASUMSZG(A_SPTRG(arg1ast)) || ASSUMSHPG(A_SPTRG(arg1ast)))) {
3494 c_acl->u1.ast = astb.i0;
3495 } else {
3496 c_acl->u1.ast = size_of_ast(arg1ast);
3497 }
3498 if (c_acl->dtype != A_DTYPEG(c_acl->u1.ast))
3499 c_acl->u1.ast = mk_convert(c_acl->u1.ast, c_acl->dtype);
3500
3501 /* shape/dtype for arg 2 */
3502 sem.arrdim.ndim = 1;
3503 sem.arrdim.ndefer = 0;
3504 sem.bounds[0].lowtype = S_CONST;
3505 sem.bounds[0].lowb = 1;
3506 sem.bounds[0].lwast = 0;
3507 sem.bounds[0].uptype = S_CONST;
3508 sem.bounds[0].upb = rank;
3509 sem.bounds[0].upast = mk_cval(rank, stb.user.dt_int);
3510 dtype = mk_arrdsc();
3511 DTY(dtype + 1) = stb.user.dt_int;
3512
3513 c_acl->next = GET_ACL(15);
3514 c_acl = c_acl->next;
3515 c_acl->id = AC_ACONST;
3516 c_acl->dtype = dtype;
3517 csub_acl = &c_acl->subc;
3518 for (i = 0; i < rank; i++) {
3519 *csub_acl = c_acl = GET_ACL(15);
3520 c_acl->id = AC_AST;
3521 c_acl->dtype = stb.user.dt_int;
3522
3523 if (_can_fold(SHD_LWB(shape, i)) && _can_fold(SHD_UPB(shape, i))) {
3524 c_acl->u1.ast = extent_of_shape(shape, i);
3525 } else if (arg_count == 1 || i == dimval->conval - 1) {
3526 error(87, 3, gbl.lineno, NULL, NULL);
3527 sem.dinit_error = TRUE;
3528 return 0;
3529 } else {
3530 c_acl->u1.ast = astb.i0;
3531 }
3532
3533 csub_acl = &(*csub_acl)->next;
3534 }
3535
3536 if (arg_count == 2) {
3537 expracl->u1.expr->rop->next->next = arg2acl;
3538 }
3539
3540 return expracl;
3541 }
3542
3543 static ACL *
mk_transfer_intrin(int ast)3544 mk_transfer_intrin(int ast)
3545 {
3546 int argt;
3547 int argast;
3548 ACL *expracl;
3549 ACL *arglist;
3550
3551 expracl = mk_init_intrinsic(AC_I_transfer);
3552
3553 argt = A_ARGSG(ast);
3554 argast = ARGT_ARG(argt, 0);
3555 arglist = construct_acl_from_ast(argast, A_DTYPEG(argast), 0);
3556 if (arglist == 0) {
3557 sem.dinit_error = TRUE;
3558 return 0;
3559 }
3560
3561 #ifdef try_without_this
3562 /* Maybe we don't need the 2nd and 3rd args.
3563 A_DTYPEG(ast) gives the type of the result.
3564 */
3565 /* Can't call construct_acl_from_ast() for the mold argument because
3566 * it need not be a constant. All we really need is the element type.
3567 */
3568 argast = ARGT_ARG(argt, 1);
3569 aclp = GET_ACL(15);
3570 aclp->id = AC_AST;
3571 aclp->dtype = DDTG(A_DTYPEG(argast));
3572 aclp->u1.ast = mk_cval(0, aclp->dtype);
3573 arglist->next = aclp;
3574
3575 /* size of result */
3576 argast = ARGT_ARG(argt, 2);
3577 aclp = construct_acl_from_ast(argast, A_DTYPEG(argast), 0);
3578 if (aclp == 0) {
3579 sem.dinit_error = TRUE;
3580 return 0;
3581 }
3582 arglist->next->next = aclp;
3583 #endif
3584
3585 expracl->dtype = A_DTYPEG(ast);
3586 expracl->u1.expr->rop = arglist;
3587 return expracl;
3588 }
3589
3590 static ACL *
construct_arg_list(int ast)3591 construct_arg_list(int ast)
3592 {
3593 int argt = A_ARGSG(ast);
3594 ACL *argroot = NULL;
3595 ACL **curarg = &argroot;
3596 int i;
3597
3598 for (i = 0; i < A_ARGCNTG(ast); i++) {
3599 int argast = ARGT_ARG(argt, i);
3600 /* argast is 0 for optional args */
3601 if (argast) {
3602 *curarg = construct_acl_from_ast(argast, A_DTYPEG(argast), 0);
3603 if (!*curarg) {
3604 return 0;
3605 }
3606 curarg = &(*curarg)->next;
3607 }
3608 }
3609 return argroot;
3610 }
3611
3612 static ACL *
mk_nonelem_init_intrinsic(AC_INTRINSIC init_intr,int ast,DTYPE dtype)3613 mk_nonelem_init_intrinsic(AC_INTRINSIC init_intr, int ast, DTYPE dtype)
3614 {
3615 ACL *expracl = mk_init_intrinsic(init_intr);
3616 ACL *arglist = construct_arg_list(ast);
3617
3618 if (sem.dinit_error) {
3619 return 0;
3620 }
3621 expracl->dtype = dtype;
3622 expracl->u1.expr->rop = arglist;
3623 return expracl;
3624 }
3625
3626 static ACL *
mk_elem_init_intrinsic(AC_INTRINSIC init_intr,int ast,DTYPE dtype,int parent_acltype)3627 mk_elem_init_intrinsic(AC_INTRINSIC init_intr, int ast, DTYPE dtype,
3628 int parent_acltype)
3629 {
3630 ACL *arg1acl;
3631 ACL *a;
3632 DTYPE arg1dtype;
3633 DTYPE dtypebase = DDTG(dtype);
3634 ACL *expracl = mk_init_intrinsic(init_intr);
3635 ACL *arglist = construct_arg_list(ast);
3636
3637 if (!arglist) {
3638 sem.dinit_error = TRUE;
3639 return 0;
3640 }
3641
3642 arg1acl = arglist;
3643 arg1dtype = arg1acl->dtype;
3644 expracl->dtype = dtypebase;
3645 expracl->u1.expr->rop = arglist;
3646
3647 if (DTY(dtype) == TY_ARRAY) {
3648 if (DTY(arg1dtype) != TY_ARRAY && parent_acltype != AC_ACONST)
3649 expracl->repeatc = ADD_NUMELM(dtype);
3650 a = GET_ACL(15);
3651 a->id = AC_ACONST;
3652 a->dtype = dtype;
3653 a->subc = expracl;
3654 expracl = a;
3655 }
3656 return expracl;
3657 }
3658
3659 static AC_INTRINSIC
get_ac_intrinsic(int ast)3660 get_ac_intrinsic(int ast)
3661 {
3662 SPTR sptr = A_SPTRG(A_LOPG(ast));
3663 switch (STYPEG(sptr)) {
3664 case ST_PD:
3665 return map_PD_to_AC(PDNUMG(sptr));
3666 case ST_INTRIN:
3667 case ST_GENERIC:
3668 return map_I_to_AC(INTASTG(sptr));
3669 case ST_PROC:
3670 if (A_TYPEG(ast) == A_INTR) {
3671 return map_I_to_AC(A_OPTYPEG(ast));
3672 } else {
3673 return AC_I_NONE;
3674 }
3675 default:
3676 return AC_I_NONE;
3677 }
3678 }
3679
3680 /* Map I_* to AC_I_* constants. */
3681 static AC_INTRINSIC
map_I_to_AC(int intrin)3682 map_I_to_AC(int intrin)
3683 {
3684 switch (intrin) {
3685 case I_ICHAR:
3686 return AC_I_ichar;
3687 case I_IISHFT:
3688 case I_JISHFT:
3689 case I_KISHFT:
3690 return AC_I_ishft;
3691 case I_LSHIFT:
3692 return AC_I_lshift;
3693 case I_RSHIFT:
3694 return AC_I_rshift;
3695 case I_IMIN0:
3696 case I_MIN0:
3697 case I_AMIN1:
3698 case I_DMIN1:
3699 case I_KMIN0:
3700 case I_JMIN0:
3701 case I_AMIN0:
3702 case I_AIMIN0:
3703 case I_MIN1:
3704 case I_IMIN1:
3705 case I_JMIN1:
3706 case I_KMIN1:
3707 case I_AJMIN0:
3708 case I_MIN:
3709 return AC_I_min;
3710 case I_IMAX0:
3711 case I_MAX0:
3712 case I_AMAX1:
3713 case I_DMAX1:
3714 case I_KMAX0:
3715 case I_JMAX0:
3716 case I_AMAX0:
3717 case I_AIMAX0:
3718 case I_MAX1:
3719 case I_IMAX1:
3720 case I_JMAX1:
3721 case I_KMAX1:
3722 case I_AJMAX0:
3723 case I_MAX:
3724 return AC_I_max;
3725 case I_ABS:
3726 return AC_I_abs;
3727 case I_DBLE:
3728 case I_DFLOAT:
3729 case I_FLOAT:
3730 case I_REAL:
3731 return AC_I_fltconvert;
3732 case I_MOD:
3733 case I_AMOD:
3734 case I_DMOD:
3735 return AC_I_mod;
3736 case I_SQRT:
3737 case I_DSQRT:
3738 return AC_I_sqrt;
3739 case I_EXP:
3740 case I_DEXP:
3741 return AC_I_exp;
3742 case I_LOG:
3743 case I_ALOG:
3744 case I_DLOG:
3745 return AC_I_log;
3746 case I_LOG10:
3747 case I_ALOG10:
3748 case I_DLOG10:
3749 return AC_I_log10;
3750 case I_SIN:
3751 case I_DSIN:
3752 return AC_I_sin;
3753 case I_COS:
3754 case I_DCOS:
3755 return AC_I_cos;
3756 case I_TAN:
3757 case I_DTAN:
3758 return AC_I_tan;
3759 case I_ASIN:
3760 case I_DASIN:
3761 return AC_I_asin;
3762 case I_ACOS:
3763 case I_DACOS:
3764 return AC_I_acos;
3765 case I_ATAN:
3766 case I_DATAN:
3767 return AC_I_atan;
3768 case I_ATAN2:
3769 case I_DATAN2:
3770 return AC_I_atan2;
3771 case I_IAND:
3772 return AC_I_iand;
3773 case I_IOR:
3774 return AC_I_ior;
3775 case I_IEOR:
3776 return AC_I_ieor;
3777 case I_MERGE:
3778 return AC_I_merge;
3779 case I_SCALE:
3780 return AC_I_scale;
3781 case I_MAXLOC:
3782 return AC_I_maxloc;
3783 case I_MAXVAL:
3784 return AC_I_maxval;
3785 case I_MINLOC:
3786 return AC_I_minloc;
3787 case I_MINVAL:
3788 return AC_I_minval;
3789 default:
3790 return AC_I_NONE;
3791 }
3792 }
3793
3794 /* Map PD_* to AC_I_* constants. */
3795 static AC_INTRINSIC
map_PD_to_AC(int pdnum)3796 map_PD_to_AC(int pdnum)
3797 {
3798 switch (pdnum) {
3799 case PD_lbound:
3800 return AC_I_lbound;
3801 case PD_ubound:
3802 return AC_I_ubound;
3803 case PD_reshape:
3804 return AC_I_reshape;
3805 case PD_size:
3806 return AC_I_size;
3807 case PD_selected_int_kind:
3808 return AC_I_selected_int_kind;
3809 case PD_selected_real_kind:
3810 #ifdef PD_ieee_selected_real_kind
3811 case PD_ieee_selected_real_kind:
3812 #endif
3813 return AC_I_selected_real_kind;
3814 case PD_selected_char_kind:
3815 return AC_I_selected_char_kind;
3816 case PD_adjustl:
3817 return AC_I_adjustl;
3818 case PD_adjustr:
3819 return AC_I_adjustr;
3820 case PD_achar:
3821 return AC_I_char;
3822 case PD_iachar:
3823 return AC_I_ichar;
3824 case PD_int:
3825 return AC_I_int;
3826 case PD_nint:
3827 return AC_I_nint;
3828 case PD_char:
3829 return AC_I_char;
3830 case PD_index:
3831 return AC_I_index;
3832 case PD_repeat:
3833 return AC_I_repeat;
3834 case PD_len_trim:
3835 return AC_I_len_trim;
3836 case PD_trim:
3837 return AC_I_trim;
3838 case PD_scan:
3839 return AC_I_scan;
3840 case PD_verify:
3841 return AC_I_verify;
3842 case PD_null:
3843 return AC_I_null;
3844 case PD_shape:
3845 return AC_I_shape;
3846 case PD_real:
3847 return AC_I_fltconvert;
3848 case PD_floor:
3849 return AC_I_floor;
3850 case PD_ceiling:
3851 return AC_I_ceiling;
3852 case PD_transfer:
3853 return AC_I_transfer;
3854 case PD_scale:
3855 return AC_I_scale;
3856 case PD_maxloc:
3857 return AC_I_maxloc;
3858 case PD_maxval:
3859 return AC_I_maxval;
3860 case PD_minloc:
3861 return AC_I_minloc;
3862 case PD_minval:
3863 return AC_I_minval;
3864 default:
3865 return AC_I_NONE;
3866 }
3867 }
3868
3869 static ACL *
construct_intrinsic_acl(int ast,DTYPE dtype,int parent_acltype)3870 construct_intrinsic_acl(int ast, DTYPE dtype, int parent_acltype)
3871 {
3872 AC_INTRINSIC intrin = get_ac_intrinsic(ast);
3873 switch (intrin) {
3874 case AC_I_char:
3875 case AC_I_adjustl:
3876 case AC_I_adjustr:
3877 case AC_I_ichar:
3878 case AC_I_index:
3879 case AC_I_int:
3880 case AC_I_ishft:
3881 case AC_I_max:
3882 case AC_I_min:
3883 case AC_I_nint:
3884 case AC_I_len_trim:
3885 case AC_I_ishftc:
3886 case AC_I_fltconvert:
3887 case AC_I_scan:
3888 case AC_I_verify:
3889 case AC_I_floor:
3890 case AC_I_ceiling:
3891 case AC_I_mod:
3892 case AC_I_sqrt:
3893 case AC_I_exp:
3894 case AC_I_log:
3895 case AC_I_log10:
3896 case AC_I_sin:
3897 case AC_I_cos:
3898 case AC_I_tan:
3899 case AC_I_asin:
3900 case AC_I_acos:
3901 case AC_I_atan:
3902 case AC_I_atan2:
3903 case AC_I_abs:
3904 case AC_I_iand:
3905 case AC_I_ior:
3906 case AC_I_ieor:
3907 case AC_I_merge:
3908 case AC_I_scale:
3909 return mk_elem_init_intrinsic(intrin, ast, dtype, parent_acltype);
3910 case AC_I_maxloc:
3911 case AC_I_maxval:
3912 case AC_I_minloc:
3913 case AC_I_minval:
3914 return mk_elem_init_intrinsic(intrin, ast, dtype, parent_acltype);
3915 case AC_I_lshift:
3916 /* LSHIFT(i, shift) == ISHFT(i, shift) */
3917 return mk_elem_init_intrinsic(AC_I_ishft, ast, dtype, parent_acltype);
3918 case AC_I_rshift: {
3919 /* RSHIFT(i, shift) == ISHFT(-i, shift) */
3920 int argt = A_ARGSG(ast);
3921 int val = ARGT_ARG(argt, 0);
3922 int shift = ARGT_ARG(argt, 1);
3923 int new_shift = mk_unop(OP_SUB, shift, A_DTYPEG(shift));
3924 int new_ast = ast_intr(I_ISHFT, A_DTYPEG(ast), 2, val, new_shift);
3925 return mk_elem_init_intrinsic(AC_I_ishft, new_ast, dtype, parent_acltype);
3926 }
3927 case AC_I_len:
3928 case AC_I_lbound:
3929 case AC_I_ubound:
3930 return mk_ulbound_intrin(intrin, ast);
3931 case AC_I_null:
3932 case AC_I_repeat:
3933 case AC_I_trim:
3934 case AC_I_selected_int_kind:
3935 case AC_I_selected_real_kind:
3936 case AC_I_selected_char_kind:
3937 return mk_nonelem_init_intrinsic(intrin, ast, A_DTYPEG(ast));
3938 case AC_I_size:
3939 return mk_size_intrin(ast);
3940 case AC_I_reshape:
3941 return mk_reshape_intrin(ast);
3942 case AC_I_shape:
3943 return mk_shape_intrin(ast);
3944 case AC_I_transfer:
3945 return mk_transfer_intrin(ast);
3946 default:
3947 error(155, ERR_Severe, gbl.lineno,
3948 "Intrinsic not supported in initialization:",
3949 SYMNAME(A_SPTRG(A_LOPG(ast))));
3950 sem.dinit_error = TRUE;
3951 return 0;
3952 }
3953 }
3954
3955 static int
get_ast_op(int op)3956 get_ast_op(int op)
3957 {
3958 int ast_op;
3959
3960 switch (op) {
3961 case AC_NEG:
3962 ast_op = OP_NEG;
3963 break;
3964 case AC_ADD:
3965 ast_op = OP_ADD;
3966 break;
3967 case AC_SUB:
3968 ast_op = OP_SUB;
3969 break;
3970 case AC_MUL:
3971 ast_op = OP_MUL;
3972 break;
3973 case AC_DIV:
3974 ast_op = OP_DIV;
3975 break;
3976 case AC_CAT:
3977 ast_op = OP_CAT;
3978 break;
3979 case AC_LEQV:
3980 ast_op = OP_LEQV;
3981 break;
3982 case AC_LNEQV:
3983 ast_op = OP_LNEQV;
3984 break;
3985 case AC_LOR:
3986 ast_op = OP_LOR;
3987 break;
3988 case AC_LAND:
3989 ast_op = OP_LAND;
3990 break;
3991 case AC_EQ:
3992 ast_op = OP_EQ;
3993 break;
3994 case AC_GE:
3995 ast_op = OP_GE;
3996 break;
3997 case AC_GT:
3998 ast_op = OP_GT;
3999 break;
4000 case AC_LE:
4001 ast_op = OP_LE;
4002 break;
4003 case AC_LT:
4004 ast_op = OP_LT;
4005 break;
4006 case AC_NE:
4007 ast_op = OP_NE;
4008 break;
4009 case AC_LNOT:
4010 ast_op = OP_LNOT;
4011 break;
4012 case AC_EXP:
4013 case AC_EXPK:
4014 case AC_EXPX:
4015 ast_op = OP_XTOI;
4016 break;
4017 default:
4018 interr("get_ast_op: unexpected operator in initialization expr", op, 3);
4019 }
4020 return ast_op;
4021 }
4022
4023 static int
get_ac_op(int ast)4024 get_ac_op(int ast)
4025 {
4026 int ac_op;
4027
4028 switch (A_OPTYPEG(ast)) {
4029 case OP_NEG:
4030 ac_op = AC_NEG;
4031 break;
4032 case OP_ADD:
4033 ac_op = AC_ADD;
4034 break;
4035 case OP_SUB:
4036 ac_op = AC_SUB;
4037 break;
4038 case OP_MUL:
4039 ac_op = AC_MUL;
4040 break;
4041 case OP_DIV:
4042 ac_op = AC_DIV;
4043 break;
4044 case OP_CAT:
4045 ac_op = AC_CAT;
4046 break;
4047 case OP_LEQV:
4048 ac_op = AC_LEQV;
4049 break;
4050 case OP_LNEQV:
4051 ac_op = AC_LNEQV;
4052 break;
4053 case OP_LOR:
4054 ac_op = AC_LOR;
4055 break;
4056 case OP_LAND:
4057 ac_op = AC_LAND;
4058 break;
4059 case OP_EQ:
4060 ac_op = AC_EQ;
4061 break;
4062 case OP_GE:
4063 ac_op = AC_GE;
4064 break;
4065 case OP_GT:
4066 ac_op = AC_GT;
4067 break;
4068 case OP_LE:
4069 ac_op = AC_LE;
4070 break;
4071 case OP_LT:
4072 ac_op = AC_LT;
4073 break;
4074 case OP_NE:
4075 ac_op = AC_NE;
4076 break;
4077 case OP_LNOT:
4078 ac_op = AC_LNOT;
4079 break;
4080 case OP_XTOI:
4081 switch (DDTG(A_DTYPEG(A_ROPG(ast)))) {
4082 case DT_INT8:
4083 ac_op = AC_EXPK;
4084 break;
4085 case DT_REAL4:
4086 case DT_REAL8:
4087 ac_op = AC_EXPX;
4088 break;
4089 default:
4090 ac_op = AC_EXP;
4091 break;
4092 }
4093 break;
4094 default:
4095 interr("get_ac_op: unexpected operator in initialization expr",
4096 A_OPTYPEG(ast), 3);
4097 }
4098 return ac_op;
4099 }
4100
4101 static ACL *
eval_do_idx(int ast)4102 eval_do_idx(int ast)
4103 {
4104 ACL *aclp = NULL;
4105 DOSTACK *p;
4106 int sptr = A_SPTRG(ast);
4107
4108 if (!sptr)
4109 return aclp;
4110
4111 for (p = sem.dostack; p < sem.top; p++) {
4112 if (p->sptr == sptr) {
4113 aclp = GET_ACL(15);
4114 aclp->id = AC_CONST;
4115 aclp->dtype = A_DTYPEG(ast);
4116 aclp->is_const = 1;
4117 aclp->u1.ast = ast;
4118
4119 if (DT_ISWORD(A_DTYPEG(ast)))
4120 aclp->u1.ast = mk_cval1(p->currval, A_DTYPEG(ast));
4121 else
4122 aclp->u1.ast = mk_cnst(p->currval);
4123 return aclp;
4124 }
4125 }
4126 return aclp;
4127 }
4128
4129 ACL *
construct_acl_from_ast(int ast,DTYPE dtype,int parent_acltype)4130 construct_acl_from_ast(int ast, DTYPE dtype, int parent_acltype)
4131 {
4132 ACL *aclp, *subscr_aclp;
4133 ACL *u, *l, *s;
4134 ACL *prev;
4135 int lParent_acltype;
4136 int sptr;
4137 int asd;
4138 int sub_ast;
4139 int ndim;
4140 int i;
4141 int m_sptr;
4142 int p_dtype;
4143
4144 if (!ast) {
4145 errsev(457);
4146 sem.dinit_error = TRUE;
4147 return 0;
4148 }
4149 if (!_can_fold(ast) &&
4150 (A_TYPEG(ast) == A_ID && !DOVARG(A_SPTRG(ast)) &&
4151 !(STYPEG(A_SPTRG(ast)) == ST_MEMBER) &&
4152 !(STYPEG(A_SPTRG(ast)) == ST_PARAM || PARAMG(A_SPTRG(ast)))) &&
4153 !(HCCSYMG(A_SPTRG(ast)) && DINITG(A_SPTRG(ast)))) {
4154 ACL *acl = eval_do_idx(ast);
4155 if (acl)
4156 return acl;
4157 errsev(87);
4158 sem.dinit_error = TRUE;
4159 return 0;
4160 }
4161
4162 switch (A_TYPEG(ast)) {
4163 case A_FUNC:
4164 errsev(87);
4165 sem.dinit_error = TRUE;
4166 return 0;
4167 case A_ID:
4168 aclp = GET_ACL(15);
4169 aclp->id = AC_AST;
4170 aclp->dtype = A_DTYPEG(ast);
4171 aclp->is_const = 1;
4172 aclp->u1.ast = ast;
4173
4174 if (DTY(DDTG(dtype)) == TY_DERIVED &&
4175 (parent_acltype != AC_SCONST || DDTG(A_DTYPEG(ast)) != DDTG(dtype)) &&
4176 !(DTY(dtype) == TY_ARRAY && DTY(A_DTYPEG(ast)) == TY_ARRAY)) {
4177 prev = aclp;
4178 aclp = GET_ACL(15);
4179 aclp->id = AC_SCONST;
4180 aclp->dtype = DDTG(A_DTYPEG(ast));
4181 aclp->is_const = 1;
4182 aclp->subc = prev;
4183 }
4184 if (DTY(dtype) == TY_ARRAY && DTY(A_DTYPEG(ast)) != TY_ARRAY &&
4185 parent_acltype != AC_ACONST) {
4186 aclp->repeatc = ADD_NUMELM(dtype);
4187 prev = aclp;
4188 aclp = GET_ACL(15);
4189 aclp->id = AC_ACONST;
4190 aclp->dtype = dtype;
4191 aclp->is_const = 1;
4192 aclp->subc = prev;
4193 }
4194 break;
4195 case A_CNST:
4196 aclp = GET_ACL(15);
4197 aclp->id = AC_AST;
4198 aclp->dtype = A_DTYPEG(ast);
4199 aclp->is_const = 1;
4200 aclp->u1.ast = ast;
4201 if (DTY(dtype) == TY_ARRAY && DTY(A_DTYPEG(ast)) != TY_ARRAY &&
4202 parent_acltype != AC_ACONST) {
4203 aclp->repeatc = ADD_NUMELM(dtype);
4204 prev = aclp;
4205 aclp = GET_ACL(15);
4206 aclp->id = AC_ACONST;
4207 aclp->dtype = dtype;
4208 aclp->is_const = 1;
4209 aclp->subc = prev;
4210 }
4211 break;
4212 case A_BINOP:
4213 aclp = GET_ACL(15);
4214 aclp->id = AC_IEXPR;
4215 aclp->dtype = A_DTYPEG(ast);
4216 aclp->u1.expr = (AEXPR *)getitem(15, sizeof(AEXPR));
4217 aclp->u1.expr->op = get_ac_op(ast);
4218 /* this ACL may become the child of an AC_ACONST; set the last argument of
4219 * call to construct_acl_from_ast appropriately
4220 */
4221 lParent_acltype =
4222 (DTY(dtype) == TY_ARRAY && parent_acltype != AC_ACONST) ? AC_ACONST : 0;
4223 aclp->u1.expr->lop = construct_acl_from_ast(
4224 A_LOPG(ast), A_DTYPEG(A_LOPG(ast)), lParent_acltype);
4225 aclp->u1.expr->rop = construct_acl_from_ast(
4226 A_ROPG(ast), A_DTYPEG(A_ROPG(ast)), lParent_acltype);
4227
4228 if (!aclp->u1.expr->lop || !aclp->u1.expr->rop) {
4229 return 0;
4230 }
4231 if (DTY(dtype) == TY_ARRAY && parent_acltype != AC_ACONST) {
4232 prev = aclp;
4233 aclp = GET_ACL(15);
4234 aclp->id = AC_ACONST;
4235 aclp->dtype = dtype;
4236 aclp->is_const = 1;
4237 aclp->subc = prev;
4238 }
4239 break;
4240 case A_UNOP:
4241 aclp = GET_ACL(15);
4242 aclp->id = AC_IEXPR;
4243 aclp->dtype = A_DTYPEG(ast);
4244 aclp->u1.expr = (AEXPR *)getitem(15, sizeof(AEXPR));
4245 aclp->u1.expr->op = AC_NEG;
4246 if (get_ac_op(ast) == AC_LNOT)
4247 aclp->u1.expr->op = AC_LNOT;
4248 aclp->u1.expr->lop = construct_acl_from_ast(A_LOPG(ast), A_DTYPEG(ast), 0);
4249 if (!aclp->u1.expr->lop) {
4250 return 0;
4251 }
4252 aclp->u1.expr->rop = NULL;
4253 if (DTY(dtype) == TY_ARRAY && parent_acltype != AC_ACONST) {
4254 prev = aclp;
4255 aclp = GET_ACL(15);
4256 aclp->id = AC_ACONST;
4257 aclp->dtype = dtype;
4258 aclp->is_const = 1;
4259 aclp->subc = prev;
4260 }
4261 break;
4262 case A_CONV:
4263 if (DDTG(A_DTYPEG(ast)) == DDTG(A_DTYPEG(A_LOPG(ast)))) {
4264 aclp = construct_acl_from_ast(A_LOPG(ast), 0, 0);
4265 if (!aclp) {
4266 return 0;
4267 }
4268 } else {
4269 aclp = GET_ACL(15);
4270 aclp->id = AC_IEXPR;
4271 aclp->dtype = A_DTYPEG(ast);
4272 aclp->u1.expr = (AEXPR *)getitem(15, sizeof(AEXPR));
4273 aclp->u1.expr->op = AC_CONV;
4274 aclp->u1.expr->lop =
4275 construct_acl_from_ast(A_LOPG(ast), DDTG(A_DTYPEG(ast)), 0);
4276 if (!aclp->u1.expr->lop) {
4277 return 0;
4278 }
4279 aclp->u1.expr->rop = NULL;
4280 if (DTY(dtype) == TY_ARRAY && parent_acltype != AC_ACONST) {
4281 prev = aclp;
4282 aclp = GET_ACL(15);
4283 aclp->id = AC_ACONST;
4284 aclp->dtype = dtype;
4285 aclp->is_const = 1;
4286 aclp->subc = prev;
4287 }
4288 }
4289 break;
4290 case A_SUBSCR:
4291 aclp = GET_ACL(15);
4292 aclp->id = AC_IEXPR;
4293 aclp->u1.expr = (AEXPR *)getitem(15, sizeof(AEXPR));
4294 aclp->u1.expr->op = AC_ARRAYREF;
4295 aclp->u1.expr->lop = construct_acl_from_ast(A_LOPG(ast), 0, 0);
4296 if (!aclp->u1.expr->lop) {
4297 return 0;
4298 }
4299 aclp->dtype = A_DTYPEG(ast);
4300 asd = A_ASDG(ast);
4301 ndim = ASD_NDIM(asd);
4302 prev = NULL;
4303 for (i = 0; i < ndim; i++) {
4304 sub_ast = ASD_SUBS(asd, i);
4305 subscr_aclp = GET_ACL(15);
4306 subscr_aclp->id = AC_IEXPR;
4307 subscr_aclp->u1.expr = (AEXPR *)getitem(15, sizeof(AEXPR));
4308 subscr_aclp->u1.expr->op = AC_TRIPLE;
4309 subscr_aclp->dtype = A_DTYPEG(sub_ast);
4310 subscr_aclp->u1.expr->lop = NULL;
4311 if (prev == NULL) {
4312 aclp->u1.expr->rop = subscr_aclp;
4313 } else {
4314 prev->next = subscr_aclp;
4315 }
4316 prev = subscr_aclp;
4317
4318 l = GET_ACL(15);
4319 l->id = AC_AST;
4320 l->dtype = astb.bnd.dtype;
4321 l->is_const = 1;
4322
4323 u = GET_ACL(15);
4324 u->id = AC_AST;
4325 u->dtype = astb.bnd.dtype;
4326 u->is_const = 1;
4327
4328 s = GET_ACL(15);
4329 s->id = AC_AST;
4330 s->dtype = astb.bnd.dtype;
4331 s->is_const = 1;
4332
4333 again:
4334 switch (A_TYPEG(sub_ast)) {
4335 case A_TRIPLE:
4336 l->u1.ast = A_LBDG(sub_ast);
4337 l->dtype = A_DTYPEG(A_LBDG(sub_ast));
4338 u->u1.ast = A_UPBDG(sub_ast);
4339 u->dtype = A_DTYPEG(A_UPBDG(sub_ast));
4340 if (A_STRIDEG(sub_ast) == 0) {
4341 s->u1.ast = astb.bnd.one;
4342 u->dtype = A_DTYPEG(astb.bnd.one);
4343 } else {
4344 s->u1.ast = A_STRIDEG(sub_ast);
4345 u->dtype = A_DTYPEG(A_STRIDEG(sub_ast));
4346 }
4347 break;
4348 case A_SUBSCR:
4349 /* This needs updated for sub_ast that is an array section
4350 * of multi-dimension array with rank one.
4351 */
4352 ast = sub_ast;
4353 asd = A_ASDG(ast);
4354 sub_ast = ASD_SUBS(asd, 0);
4355 subscr_aclp->u1.expr->lop = construct_acl_from_ast(A_LOPG(ast), 0, 0);
4356 goto again;
4357 break;
4358 case A_CONV:
4359 ast = sub_ast;
4360 sub_ast = A_LOPG(sub_ast);
4361 goto again;
4362 break;
4363 case A_ID:
4364 if (DTY(A_DTYPEG(sub_ast)) == TY_ARRAY) {
4365 int shape;
4366 shape = A_SHAPEG(sub_ast);
4367 if (SHD_LWB(shape, 0)) {
4368 l->u1.ast = SHD_LWB(shape, 0);
4369 l->dtype = A_DTYPEG(SHD_LWB(shape, 0));
4370 } else {
4371 l->u1.ast = astb.bnd.one;
4372 l->dtype = A_DTYPEG(astb.bnd.one);
4373 }
4374 u->u1.ast = SHD_UPB(shape, 0);
4375 u->dtype = A_DTYPEG(SHD_UPB(shape, 0));
4376 s->u1.ast = astb.bnd.one;
4377 s->dtype = A_DTYPEG(astb.bnd.one);
4378 subscr_aclp->u1.expr->lop = construct_acl_from_ast(sub_ast, 0, 0);
4379 break;
4380 }
4381 /* fall thru */
4382 default:
4383 l->u1.ast = sub_ast;
4384 l->dtype = A_DTYPEG(sub_ast);
4385 u->u1.ast = sub_ast;
4386 u->dtype = A_DTYPEG(sub_ast);
4387 s->u1.ast = astb.bnd.one;
4388 s->dtype = A_DTYPEG(astb.bnd.one);
4389 break;
4390 }
4391
4392 l->next = u;
4393 u->next = s;
4394 s->next = NULL;
4395 subscr_aclp->u1.expr->rop = l;
4396 }
4397 break;
4398 case A_MEM:
4399 aclp = GET_ACL(15);
4400 aclp->id = AC_IEXPR;
4401 aclp->dtype = A_DTYPEG(ast);
4402 aclp->u1.expr = (AEXPR *)getitem(15, sizeof(AEXPR));
4403 aclp->u1.expr->op = AC_MEMBR_SEL;
4404 aclp->u1.expr->lop = construct_acl_from_ast(A_PARENTG(ast), 0, 0);
4405 if (!aclp->u1.expr->lop) {
4406 return 0;
4407 }
4408
4409 /* find the field number */
4410 p_dtype = A_DTYPEG(A_PARENTG(ast));
4411 m_sptr = A_SPTRG(A_MEMG(ast));
4412 for (sptr = DTY(p_dtype + 1), i = 0; sptr > NOSYM && sptr != m_sptr;
4413 sptr = SYMLKG(sptr), i++)
4414 ;
4415 l = GET_ACL(15);
4416 l->id = AC_AST;
4417 l->dtype = DT_INT4;
4418 l->u1.ast = mk_cval(i, l->dtype);
4419
4420 aclp->u1.expr->rop = l;
4421 break;
4422 case A_INTR:
4423 aclp = construct_intrinsic_acl(ast, dtype, parent_acltype);
4424 if (aclp && DTY(dtype) == TY_ARRAY && DTY(A_DTYPEG(ast)) != TY_ARRAY &&
4425 parent_acltype != AC_ACONST &&
4426 !(STYPEG(A_SPTRG(A_LOPG(ast))) == ST_PD &&
4427 PDNUMG(A_SPTRG(A_LOPG(ast))) == PD_null)) {
4428 if (aclp->dtype == dtype) {
4429 if (aclp->subc && aclp->subc->repeatc == ADD_NUMELM(dtype))
4430 break;
4431 }
4432 aclp->repeatc = ADD_NUMELM(dtype);
4433 prev = aclp;
4434 aclp = GET_ACL(15);
4435 aclp->id = AC_ACONST;
4436 aclp->dtype = dtype;
4437 aclp->is_const = 1;
4438 aclp->subc = prev;
4439 }
4440
4441 break;
4442 default:
4443 interr("unexpected ast type in initialization expr", ast, 3);
4444 }
4445
4446 return aclp;
4447 }
4448
4449 static int
next_member(int member)4450 next_member(int member)
4451 {
4452 int new_mbr = SYMLKG(member);
4453
4454 if (POINTERG(member) || ALLOCATTRG(member))
4455 while (new_mbr != NOSYM && HCCSYMG(new_mbr))
4456 new_mbr = SYMLKG(new_mbr);
4457
4458 return new_mbr == NOSYM ? 0 : new_mbr;
4459 }
4460
4461 ACL *
rewrite_acl(ACL * aclp,DTYPE dtype,int parent_acltype)4462 rewrite_acl(ACL *aclp, DTYPE dtype, int parent_acltype)
4463 {
4464 SST *stkp;
4465 int ast;
4466 int sptr;
4467 int mbr_sptr;
4468 int wrk_dtype = dtype;
4469 DOINFO *doinfo;
4470 ACL *cur_aclp;
4471 ACL *wrk_aclp;
4472 ACL *prev_aclp = NULL;
4473 ACL *ret_aclp = aclp;
4474 ACL *sav_aclp = NULL;
4475 if (no_data_components(dtype)) {
4476 return 0;
4477 }
4478 if (parent_acltype == AC_SCONST) {
4479 mbr_sptr = DTY(DDTG(dtype) + 1);
4480 wrk_dtype = DTYPEG(mbr_sptr);
4481 }
4482
4483 for (cur_aclp = aclp; cur_aclp != NULL; cur_aclp = cur_aclp->next) {
4484 wrk_aclp = cur_aclp;
4485 switch (cur_aclp->id) {
4486 case AC_EXPR:
4487 stkp = cur_aclp->u1.stkp;
4488 again:
4489 ast = SST_ASTG(stkp);
4490 if (SST_IDG(stkp) == S_ACONST) {
4491 /* attempt to avoid ICE by calling mkexpr() on
4492 * S_ACONST
4493 */
4494 mkexpr(stkp);
4495 if (SST_IDG(stkp) != S_ACONST)
4496 goto again;
4497 interr("rewrite_acl: unexpected S_ACONST", 0, 3);
4498 wrk_aclp->subc = SST_ACLG(stkp);
4499 wrk_aclp->id = AC_ACONST;
4500 wrk_aclp->repeatc = 0;
4501 } else if (SST_IDG(stkp) == S_IDENT) {
4502 sptr = SST_SYMG(stkp);
4503 if (STYPEG(sptr) == ST_PARAM || PARAMG(sptr)) {
4504 ast = mk_id(sptr);
4505 wrk_aclp = construct_acl_from_ast(ast, wrk_dtype, parent_acltype);
4506 wrk_aclp->u1.ast = ast;
4507 }
4508 /* MORE is this necessary */
4509 else if (STYPEG(sptr) == ST_PD || STYPEG(sptr) == ST_INTRIN) {
4510 wrk_aclp = SST_ACLG(stkp);
4511 } else {
4512 errsev(87);
4513 sem.dinit_error = TRUE;
4514 continue;
4515 }
4516 } else if (SST_IDG(stkp) == S_CONST) {
4517 wrk_aclp =
4518 construct_acl_from_ast(SST_ASTG(stkp), wrk_dtype, parent_acltype);
4519 } else if (SST_IDG(stkp) == S_EXPR &&
4520 (A_TYPEG(ast) == A_ID || A_TYPEG(ast) == A_CNST)) {
4521 wrk_aclp =
4522 construct_acl_from_ast(SST_ASTG(stkp), wrk_dtype, parent_acltype);
4523 } else
4524 wrk_aclp = construct_acl_from_ast(ast, wrk_dtype, parent_acltype);
4525 break;
4526 case AC_IDO:
4527 /* must make a copy of DOINFO because we don't know where
4528 * the current one was allocated or when it will be freed.
4529 */
4530 doinfo = get_doinfo(15);
4531 *doinfo = *cur_aclp->u1.doinfo;
4532 wrk_aclp->u1.doinfo = doinfo;
4533
4534 DOVARP(cur_aclp->u1.doinfo->index_var, 1);
4535 wrk_aclp->subc = rewrite_acl(cur_aclp->subc, DDTG(dtype), 0);
4536 if (!wrk_aclp->subc) {
4537 return 0;
4538 }
4539 DOVARP(cur_aclp->u1.doinfo->index_var, 0);
4540 wrk_aclp->repeatc = 0;
4541
4542 break;
4543 case AC_SCONST:
4544 case AC_TYPEINIT:
4545 wrk_aclp->subc =
4546 rewrite_acl(cur_aclp->subc, cur_aclp->dtype, cur_aclp->id);
4547 if (!wrk_aclp->subc) {
4548 return 0;
4549 }
4550 if (DTY(wrk_dtype) == TY_ARRAY && parent_acltype != AC_ACONST) {
4551 wrk_aclp->repeatc = ADD_NUMELM(wrk_dtype);
4552 sav_aclp = wrk_aclp;
4553 wrk_aclp = GET_ACL(15);
4554 wrk_aclp->id = AC_ACONST;
4555 wrk_aclp->dtype = wrk_dtype;
4556 wrk_aclp->is_const = 1;
4557 wrk_aclp->subc = sav_aclp;
4558 }
4559 break;
4560 case AC_ACONST:
4561 wrk_aclp->subc =
4562 rewrite_acl(cur_aclp->subc, cur_aclp->dtype, cur_aclp->id);
4563 if (!wrk_aclp->subc) {
4564 break;
4565 }
4566 wrk_aclp->repeatc = aclp->repeatc;
4567 break;
4568 case AC_AST:
4569 wrk_aclp = construct_acl_from_ast(cur_aclp->u1.ast, cur_aclp->dtype,
4570 parent_acltype);
4571 if (wrk_aclp) {
4572 wrk_aclp->repeatc = cur_aclp->repeatc;
4573 wrk_aclp->sptr = cur_aclp->sptr;
4574 }
4575 break;
4576 case AC_IEXPR:
4577 wrk_aclp = cur_aclp;
4578 break;
4579 case AC_REPEAT:
4580 default:
4581 interr("unexpected acl expresion type", cur_aclp->id, 3);
4582 break;
4583 }
4584
4585 if (wrk_aclp) {
4586 if (prev_aclp) {
4587 prev_aclp->next = wrk_aclp;
4588 } else {
4589 ret_aclp = wrk_aclp;
4590 }
4591 prev_aclp = wrk_aclp;
4592 }
4593
4594 if (parent_acltype == AC_SCONST) {
4595 mbr_sptr = next_member(mbr_sptr);
4596 wrk_dtype = DTYPEG(mbr_sptr);
4597 }
4598 }
4599
4600 if (sem.dinit_error) {
4601 ret_aclp = 0;
4602 }
4603
4604 return ret_aclp;
4605 }
4606
4607 static int
init_types_compatable(SST * istkp,DTYPE dtype,int sptr)4608 init_types_compatable(SST *istkp, DTYPE dtype, int sptr)
4609 {
4610
4611 if (STYPEG(sptr) == ST_PD && PDNUMG(sptr) == PD_null &&
4612 SST_DTYPEG(istkp) == DT_WORD) {
4613 return TRUE;
4614 }
4615
4616 if ((DTY(dtype) != TY_ARRAY && DTY(dtype) != DTY(SST_DTYPEG(istkp))) ||
4617 (DTY(dtype) == TY_ARRAY && DTY(SST_DTYPEG(istkp)) == TY_ARRAY &&
4618 !cmpat_dtype_with_size(dtype, SST_DTYPEG(istkp))) ||
4619 (DTY(dtype) == TY_ARRAY && DTY(SST_DTYPEG(istkp)) != TY_ARRAY &&
4620 DDTG(dtype) != SST_DTYPEG(istkp))) {
4621 return FALSE;
4622 }
4623 return TRUE;
4624 }
4625
4626 void
construct_acl_for_sst(SST * istkp,DTYPE dtype)4627 construct_acl_for_sst(SST *istkp, DTYPE dtype)
4628 {
4629 ACL *aclp = 0;
4630 int sptr = 0;
4631
4632 switch (SST_IDG(istkp)) {
4633 case S_IDENT:
4634 /* the ident must be a named constant or an alias for a named constant */
4635 aclp = SST_ACLG(istkp);
4636 if (aclp) {
4637 sptr = A_SPTRG(aclp->u1.ast);
4638 } else {
4639 sptr = SST_SYMG(istkp);
4640 }
4641 if ((!sptr || !(STYPEG(sptr) == ST_PARAM || PARAMG(sptr))) &&
4642 (!has_type_parameter(dtype) || !sem.param_struct_constr)) {
4643 if (!no_data_components(dtype)) {
4644 errsev(87);
4645 }
4646 sem.dinit_error = TRUE;
4647 SST_ACLP(istkp, 0);
4648 return;
4649 }
4650 /* the types must be compatable */
4651 if (!init_types_compatable(istkp, dtype, sptr)) {
4652 errsev(91);
4653 sem.dinit_error = TRUE;
4654 SST_ACLP(istkp, 0);
4655 return;
4656 }
4657 if (!aclp) {
4658 /* PARAMETER defined in a module, already processed */
4659 SST_ACLP(istkp, (ACL *)get_getitem_p(CONVAL2G(NMCNSTG(sptr))));
4660 } else if (DTY(DDTG(dtype)) == TY_DERIVED) {
4661 SST_ACLP(istkp, construct_acl_from_ast(aclp->u1.ast, dtype, 0));
4662 }
4663 if (DTY(dtype) == TY_ARRAY && (aclp = SST_ACLG(istkp)) &&
4664 DTY(aclp->dtype) != TY_ARRAY && aclp->id == AC_IEXPR &&
4665 aclp->u1.expr->op == AC_INTR_CALL) {
4666 aclp->repeatc = ADD_NUMELM(dtype);
4667 }
4668 break;
4669 case S_EXPR:
4670 case S_CONST:
4671 case S_LVALUE:
4672 SST_ACLP(istkp, construct_acl_from_ast(SST_ASTG(istkp), dtype, 0));
4673 break;
4674 case S_ACONST:
4675 SST_ACLP(istkp, rewrite_acl(SST_ACLG(istkp), dtype, 0));
4676 break;
4677 case S_SCONST:
4678 if (DDTG(dtype) != SST_DTYPEG(istkp)) {
4679 if (DTY(DDTG(dtype)) == TY_DERIVED &&
4680 DTY(SST_DTYPEG(istkp)) == TY_DERIVED) {
4681
4682 /* For parameterized derived types, the following from F2008 spec
4683 * applies (there's similar language in F2003 spec):
4684 * Section 5.2.3 ...
4685 * If initialization is = constant-expr, the variable is initially
4686 * defined with the value specified by the constant-expr; if
4687 * necessary, the value is converted according to the rules of
4688 * intrinsic assignment (7.2.1.3) to a value that agrees in type,
4689 * type parameters, and shape with the variable.
4690 *
4691 * Therefore, if the type on the LHS is a parameterized derived
4692 * type, check its "base type" with the type on the RHS. If they
4693 * are identical, then we have a legal initialization since the
4694 * value is to be "converted".
4695 */
4696
4697 int tag1, dty1, dty2;
4698 tag1 = DTY(DDTG(dtype) + 3);
4699 dty1 = (BASETYPEG(tag1)) ? BASETYPEG(tag1) : DDTG(dtype);
4700 dty2 = SST_DTYPEG(istkp);
4701 if (dty1 == dty2)
4702 goto sconst_ok;
4703 }
4704 errsev(91);
4705 sem.dinit_error = TRUE;
4706 SST_ACLP(istkp, 0);
4707 return;
4708 }
4709 sconst_ok:
4710 SST_ACLP(istkp, rewrite_acl(SST_ACLG(istkp), dtype, 0));
4711 break;
4712 default:
4713 interr("unexpected sst type for initialization list", SST_IDG(istkp), 3);
4714 }
4715 }
4716
4717 ACL *
get_acl(int area)4718 get_acl(int area)
4719 {
4720 ACL *a;
4721 a = (ACL *)getitem(area, sizeof(ACL));
4722 BZERO(a, ACL, 1);
4723 return a;
4724 }
4725
4726 ACL *
save_acl(ACL * oldp)4727 save_acl(ACL *oldp)
4728 {
4729 ACL *rootp, *newp;
4730 SST *stkp;
4731 DOINFO *doinfo;
4732
4733 if (oldp == NULL)
4734 return NULL;
4735
4736 rootp = newp = GET_ACL(15);
4737
4738 while (TRUE) {
4739 *newp = *oldp;
4740 switch (oldp->id) {
4741 case AC_EXPR:
4742 stkp = oldp->u1.stkp;
4743 if (SST_IDG(stkp) == S_ACONST) {
4744 newp->subc = SST_ACLG(stkp);
4745 newp->id = AC_ACONST;
4746 } else if (oldp->repeatc && oldp->size) {
4747 } else {
4748 newp->u1.ast = SST_ASTG(stkp);
4749 newp->id = AC_AST;
4750 }
4751 break;
4752 case AC_IDO:
4753 newp->subc = save_acl(oldp->subc);
4754 doinfo = get_doinfo(ACL_SAVE_AREA);
4755 *doinfo = *oldp->u1.doinfo;
4756 newp->u1.doinfo = doinfo;
4757 break;
4758 case AC_REPEAT:
4759 case AC_SCONST:
4760 case AC_ACONST:
4761 newp->subc = save_acl(oldp->subc);
4762 break;
4763 case AC_AST:
4764 case AC_ICONST:
4765 case AC_CONST:
4766 break;
4767 case AC_IEXPR:
4768 if (newp->u1.expr->lop) {
4769 newp->u1.expr->lop = save_acl(oldp->u1.expr->lop);
4770 }
4771 if (newp->u1.expr->rop) {
4772 newp->u1.expr->rop = save_acl(oldp->u1.expr->rop);
4773 }
4774 break;
4775 default:
4776 interr("save_acl,ill.id", oldp->id, 3);
4777 break;
4778 }
4779 oldp = oldp->next;
4780 if (oldp == NULL)
4781 break;
4782 newp->next = GET_ACL(15);
4783 newp = newp->next;
4784 }
4785
4786 return rootp;
4787 }
4788
4789 static int dinit_array = 0;
4790 static void
dinit_constructor(SPTR arr,ACL * aclp)4791 dinit_constructor(SPTR arr, ACL *aclp)
4792 {
4793 if (DINITG(arr))
4794 return;
4795
4796 {
4797 VAR *ivl = (VAR *)getitem(15, sizeof(VAR));
4798 int ast = mk_id(arr);
4799 SCP(arr, SC_STATIC);
4800 STYPEP(arr, ST_ARRAY);
4801 ivl->id = Varref;
4802 ivl->u.varref.ptr = ast;
4803 ivl->u.varref.id = S_IDENT;
4804 ivl->u.varref.dtype = A_DTYPEG(ast);
4805 ivl->u.varref.shape = A_SHAPEG(ast);
4806 ivl->u.varref.subt = NULL;
4807 ivl->next = NULL;
4808 DINITP(arr, 1);
4809 if (SCG(arr) != SC_NONE)
4810 sym_is_refd(arr);
4811
4812 dinit(ivl, aclp);
4813 }
4814 DINITP(arr, 1); /* will set for ST_DERIVED arrays, too - to indicate that
4815 components have been inited. */
4816 }
4817
4818 static void
put_a_init_tree(int ast,int dinit_array)4819 put_a_init_tree(int ast, int dinit_array)
4820 {
4821 ACL temp;
4822 for (; ast; ast = A_RIGHTG(ast)) {
4823 if (A_TYPEG(ast) != A_INIT) {
4824 interr("put_a_init_tree: unknown ast type", A_TYPEG(ast), 3);
4825 } else {
4826 DTYPE dtype = A_DTYPEG(ast);
4827 switch (DTY(dtype)) {
4828 case TY_ARRAY:
4829 put_a_init_tree(A_LEFTG(ast), dinit_array);
4830 break;
4831 case TY_DERIVED:
4832 dinit_put(DINIT_TYPEDEF, DTY(dtype + 3));
4833 put_a_init_tree(A_LEFTG(ast), dinit_array);
4834 dinit_put(DINIT_ENDTYPE, 0);
4835 break;
4836 default:
4837 temp.id = AC_AST;
4838 temp.u1.ast = A_LEFTG(ast);
4839 temp.next = NULL;
4840 temp.subc = NULL;
4841 temp.dtype = A_DTYPEG(A_LEFTG(ast));
4842 temp.u2.array_i = dinit_array;
4843 _dinit_acl(&temp, FALSE);
4844 break;
4845 }
4846 }
4847 }
4848 } /* put_a_init_tree */
4849
4850 static void
_dinit_acl(ACL * aclp,LOGICAL optimpldo)4851 _dinit_acl(ACL *aclp, LOGICAL optimpldo)
4852 {
4853 SST *stkp;
4854 DOINFO *doinfo;
4855 int ast, last, lastright;
4856 DTYPE dtype;
4857 int sptr;
4858 INT count, step;
4859 DOSTACK *tp;
4860
4861 for (; aclp != NULL; aclp = aclp->next) {
4862 switch (aclp->id) {
4863 case AC_EXPR:
4864 stkp = aclp->u1.stkp;
4865 if (SST_IDG(stkp) == S_IDENT) {
4866 _dinit_acl(stkp->value.cnval.acl, FALSE);
4867 } else {
4868 /* the only AC_EXPR's left are those with A_INIT trees */
4869 ast = aclp->repeatc;
4870 last = aclp->size;
4871 /* break the list at 'last' */
4872 lastright = A_RIGHTG(last);
4873 A_RIGHTP(last, 0);
4874 put_a_init_tree(ast, dinit_array);
4875 /* restore the list at 'last' */
4876 A_RIGHTP(last, lastright);
4877 }
4878 break;
4879 case AC_AST:
4880 ast = aclp->u1.ast;
4881 sptr = 0;
4882 dtype = A_DTYPEG(ast);
4883 if (ast && A_TYPEG(ast) == A_ID) {
4884 sptr = A_SPTRG(ast);
4885 }
4886 if (sptr && (STYPEG(sptr) == ST_VAR || STYPEG(sptr) == ST_ARRAY) &&
4887 PARAMVALG(sptr)) {
4888 /* put out the initialization values */
4889 put_a_init_tree(PARAMVALG(sptr), dinit_array);
4890 } else if (DTY(dtype) == TY_ARRAY) {
4891 /* constructor item is an array */
4892 interr("_dinit_acl,array", ast, 3);
4893 } else if (A_ALIASG(ast)) {
4894 /* constructor item is a scalar constant */
4895 ast = A_ALIASG(ast);
4896 sptr = A_SPTRG(ast);
4897 switch (DTY(dtype)) {
4898 case TY_WORD:
4899 case TY_BINT:
4900 case TY_SINT:
4901 case TY_INT:
4902 case TY_BLOG:
4903 case TY_SLOG:
4904 case TY_LOG:
4905 case TY_REAL:
4906 dinit_put(dtype, CONVAL2G(sptr));
4907 break;
4908 case TY_CHAR:
4909 dinit_put(DINIT_STR, (INT)sptr);
4910 break;
4911 default:
4912 dinit_put(dtype, (INT)sptr);
4913 break;
4914 }
4915 } else if (DTY(astb.bnd.dtype) == TY_INT8) {
4916 /* constructor item is a scalar expression*/
4917 INT v[2];
4918
4919 /* NOTE: dinit_eval() returns a 4-byte int. this is
4920 wrong, but until it gets fixed, this will have to
4921 do. */
4922 v[1] = dinit_eval(ast);
4923 if (v[1] < 0)
4924 v[0] = -1;
4925 else
4926 v[0] = 0;
4927 dinit_put(astb.bnd.dtype, getcon(v, astb.bnd.dtype));
4928 } else
4929 /* constructor item is a scalar expression*/
4930 dinit_put(astb.bnd.dtype, dinit_eval(ast));
4931
4932 break;
4933 case AC_SCONST:
4934 dinit_put(DINIT_TYPEDEF, DTY(aclp->dtype + 3));
4935 _dinit_acl(aclp->subc, FALSE);
4936 dinit_put(DINIT_ENDTYPE, 0);
4937 break;
4938 case AC_ACONST:
4939 dinit_put(DINIT_STARTARY, 0);
4940 _dinit_acl(aclp->subc, FALSE);
4941 dinit_put(DINIT_ENDARY, 0);
4942 break;
4943 case AC_IDO:
4944 doinfo = aclp->u1.doinfo;
4945 if (sem.top == &sem.dostack[MAX_DOSTACK]) {
4946 /* nesting maximum exceeded. */
4947 errsev(34);
4948 return;
4949 }
4950 count = CONVAL2G(A_SPTRG(A_ALIASG(doinfo->count)));
4951 tp = sem.top;
4952 tp->sptr = doinfo->index_var;
4953 tp->currval = dinit_eval(doinfo->init_expr);
4954 step = dinit_eval(doinfo->step_expr);
4955 ++sem.top;
4956 /*
4957 * optimize the case where the initializer controlled by the
4958 * implied do is a single scalar constant
4959 */
4960 if (optimpldo && aclp->subc->id == AC_AST && aclp->subc->next == NULL &&
4961 DTY(A_DTYPEG(aclp->subc->u1.ast)) != TY_ARRAY &&
4962 A_ALIASG(aclp->subc->u1.ast)) {
4963 dinit_put(DINIT_REPEAT, count);
4964 _dinit_acl(aclp->subc, optimpldo);
4965 tp->currval += count * step;
4966 } else
4967 while (count-- > 0) {
4968 _dinit_acl(aclp->subc, optimpldo);
4969 tp->currval += step;
4970 }
4971 --sem.top;
4972 break;
4973 case AC_REPEAT:
4974 dinit_put(DINIT_REPEAT, aclp->u1.count);
4975 ast = aclp->subc->u1.ast;
4976 dtype = A_DTYPEG(ast);
4977 ast = A_ALIASG(ast);
4978 sptr = A_SPTRG(ast);
4979 if (DT_ISWORD(dtype))
4980 dinit_put(dtype, CONVAL2G(sptr));
4981 else
4982 dinit_put(dtype, (INT)sptr);
4983 break;
4984 default:
4985 interr("_dinit_acl,ill.id", aclp->id, 3);
4986 break;
4987 }
4988 }
4989 }
4990
4991 typedef struct struct_init {
4992 int default_count; /* is sptr+1, sptr is the last default init */
4993 int dt_count; /* number of members */
4994 ACL **default_acl; /* if sptr is inited, points to default acl*/
4995 ACL **dt_acl; /* points to all inited acl */
4996 } struct_init;
4997
4998 static struct_init dt_init = {0, 0, NULL, NULL};
4999
5000 #define DTC_DEFAULT_HEAD dt_init.default_acl
5001 #define DTC_ACL_HEAD dt_init.dt_acl
5002 #define DTC_DEFAULT(i) dt_init.default_acl[i]
5003 #define DTC_ACL(i) dt_init.dt_acl[i]
5004 #define DTC_DEFAULT_CNT dt_init.default_count
5005 #define DTC_DT_CNT dt_init.dt_count
5006
5007 static char *
make_structkwd_str(DTYPE dtype,int * num_of_member,int * is_extend)5008 make_structkwd_str(DTYPE dtype, int *num_of_member, int *is_extend)
5009 {
5010 int i;
5011 char *name;
5012 int optional = 1; /* all are optional */
5013 int len;
5014 int size;
5015 int avl;
5016 int member_sptr, ptr_sptr = 0, thissptr, myparent;
5017 char *kwd_str = NULL;
5018 char *first_str = NULL;
5019 int num, is_extend2, num_of_member2;
5020 int possible_ext = 1;
5021
5022 num = 0;
5023 avl = 0;
5024 i = 0;
5025 len = 0;
5026 size = 100;
5027 NEW(kwd_str, char, size);
5028 *kwd_str = '\0';
5029 member_sptr = DTY(dtype + 1);
5030 ptr_sptr = member_sptr;
5031 for (; member_sptr > NOSYM; member_sptr = SYMLKG(member_sptr)) {
5032 if (POINTERG(member_sptr))
5033 ptr_sptr = member_sptr;
5034 if (is_tbp_or_final(member_sptr)) {
5035 possible_ext = 0;
5036 continue; /* skip tbp */
5037 }
5038 name = SYMNAME(member_sptr);
5039 len = strlen(name);
5040 if (ptr_sptr &&
5041 (member_sptr == MIDNUMG(ptr_sptr) || member_sptr == PTROFFG(ptr_sptr) ||
5042 member_sptr == SDSCG(ptr_sptr) ||
5043 (CLASSG(member_sptr) && DESCARRAYG(member_sptr)))) {
5044 /* skip pointer related members */
5045 possible_ext = 0;
5046 continue;
5047 }
5048 ptr_sptr =
5049 USELENG(member_sptr) || POINTERG(member_sptr) || ALLOCATTRG(member_sptr)
5050 ? member_sptr
5051 : 0;
5052
5053 /* NOTE: should make kwd_str static */
5054 thissptr = DTY(dtype + 1);
5055 myparent = PARENTG(thissptr);
5056 if (myparent && myparent == PARENTG(member_sptr) && possible_ext &&
5057 (DTY(DTYPEG(member_sptr)) == TY_DERIVED ||
5058 DTY(DTYPEG(member_sptr)) == TY_STRUCT)) {
5059 *is_extend = 1;
5060 first_str =
5061 make_structkwd_str(DTYPEG(member_sptr), &num_of_member2, &is_extend2);
5062 len = strlen(first_str);
5063 i = 0;
5064 num += num_of_member2;
5065 avl += len; /* len chars in name, 1 for ' ', 1 for null */
5066 if (avl > size) {
5067 NEED(avl, kwd_str, char, size, size + avl + 100);
5068 }
5069 strcpy(kwd_str, first_str);
5070 FREE(first_str);
5071 } else {
5072 if (member_sptr <= DTC_DEFAULT_CNT - 1 && DTC_DEFAULT(member_sptr))
5073 optional = 1;
5074 else
5075 optional = 0;
5076 i = avl;
5077 avl +=
5078 (optional + len + 2); /* len chars in name, 1 for ' ', 1 for null */
5079 NEED(avl, kwd_str, char, size, size + 100);
5080 if (optional)
5081 kwd_str[i++] = '*';
5082 strcpy(kwd_str + i, name);
5083 kwd_str[i + len] = ' ';
5084 kwd_str[i + len + 1] = '\0';
5085 ++num;
5086 avl--;
5087 }
5088 possible_ext = 0; /* only the first member is extended type member */
5089 }
5090
5091 *num_of_member = num;
5092
5093 /* Allocate ACL pointers to all members , reuse if possible*/
5094 if (DTC_DT_CNT < num) {
5095 NEED(num, DTC_ACL_HEAD, ACL *, DTC_DT_CNT, num);
5096 }
5097 BZERO(DTC_ACL_HEAD, ACL *, DTC_DT_CNT);
5098 return kwd_str;
5099 }
5100
5101 void
clean_struct_default_init(int sptr)5102 clean_struct_default_init(int sptr)
5103 {
5104 int i;
5105 if (sptr == 0) {
5106 FREE(DTC_DEFAULT_HEAD);
5107 FREE(DTC_ACL_HEAD);
5108 DTC_DEFAULT_HEAD = NULL;
5109 DTC_ACL_HEAD = NULL;
5110 DTC_DEFAULT_CNT = 0;
5111 DTC_DT_CNT = 0;
5112 } else {
5113 /* only clean from the sptr, this is a case of contained routine */
5114 if (DTC_DEFAULT_CNT == 0)
5115 return;
5116 for (i = sptr; i < DTC_DEFAULT_CNT; ++i) {
5117 DTC_DEFAULT(i) = NULL;
5118 }
5119 DTC_DT_CNT = 0;
5120 FREE(DTC_ACL_HEAD);
5121 DTC_ACL_HEAD = NULL;
5122 }
5123 }
5124
5125 static int
has_init_value(SPTR sptr)5126 has_init_value(SPTR sptr)
5127 {
5128 if (sptr < DTC_DEFAULT_CNT) {
5129 if (DTC_DEFAULT(sptr))
5130 return 1;
5131 }
5132 return 0;
5133 }
5134
5135 static ACL *
rewrite_typeinit_to_sconst(ACL * ict)5136 rewrite_typeinit_to_sconst(ACL *ict)
5137 {
5138 ACL *newacl = ict;
5139 if (ict->id == AC_TYPEINIT) {
5140 newacl = GET_ACL(15);
5141 newacl->id = AC_SCONST;
5142 newacl->dtype = ict->dtype;
5143 newacl->next = ict->next;
5144 newacl->repeatc = ict->repeatc;
5145 newacl->subc = rewrite_typeinit_to_sconst(ict->subc);
5146 }
5147 return newacl;
5148 }
5149
5150 /** \brief Duplicate a derived type component's default initializations.
5151 *
5152 * \param new_sptr is the component that receives the initialization copy.
5153 * \param old_sptr has the default initialization that we want to duplicate.
5154 *
5155 * We need to duplicate the initialization of a derived type component when
5156 * we create new instances of the derived type with different kind/len
5157 * type parameters.
5158 */
5159 void
dup_struct_init(int new_sptr,int old_sptr)5160 dup_struct_init(int new_sptr, int old_sptr)
5161 {
5162
5163 if (!has_init_value(old_sptr))
5164 return;
5165
5166 if (DTC_DEFAULT_CNT == 0) {
5167 NEED(new_sptr + 1, DTC_DEFAULT_HEAD, ACL *, DTC_DEFAULT_CNT, new_sptr + 10);
5168 BZERO(DTC_DEFAULT_HEAD, ACL *, DTC_DEFAULT_CNT);
5169 } else if (DTC_DEFAULT_CNT - 1 < new_sptr) {
5170 int oldcnt = DTC_DEFAULT_CNT;
5171 NEED(new_sptr + 1, DTC_DEFAULT_HEAD, ACL *, DTC_DEFAULT_CNT, new_sptr + 10);
5172 BZERO((DTC_DEFAULT_HEAD + oldcnt), ACL *, DTC_DEFAULT_CNT - oldcnt);
5173 }
5174
5175 DTC_DEFAULT(new_sptr) = DTC_DEFAULT(old_sptr);
5176 }
5177
5178 void
save_struct_init(ACL * ict)5179 save_struct_init(ACL *ict)
5180 {
5181 ACL *newacl = ict;
5182
5183 if (DTC_DEFAULT_CNT == 0) {
5184 NEED(ict->sptr + 1, DTC_DEFAULT_HEAD, ACL *, DTC_DEFAULT_CNT,
5185 ict->sptr + 10);
5186 BZERO(DTC_DEFAULT_HEAD, ACL *, DTC_DEFAULT_CNT);
5187 } else if (DTC_DEFAULT_CNT - 1 < ict->sptr) {
5188 int oldcnt = DTC_DEFAULT_CNT;
5189 NEED(ict->sptr + 1, DTC_DEFAULT_HEAD, ACL *, DTC_DEFAULT_CNT,
5190 ict->sptr + 10);
5191 BZERO((DTC_DEFAULT_HEAD + oldcnt), ACL *, DTC_DEFAULT_CNT - oldcnt);
5192 }
5193 #if DEBUG
5194 #endif
5195
5196 if (ict->id == AC_TYPEINIT) {
5197 newacl = rewrite_typeinit_to_sconst(ict);
5198 }
5199
5200 /* in module, the ..$p is put in .mod file instead of member symbol */
5201 if (HCCSYMG(ict->sptr) && NEEDMODG(SCOPEG(ict->sptr))) {
5202 int sptr = VARIANTG(ict->sptr);
5203 if ((POINTERG(sptr) || ALLOCATTRG(sptr))) {
5204 if (MIDNUMG(sptr) == ict->sptr && SYMLKG(sptr) == ict->sptr) {
5205 DTC_DEFAULT(sptr) = newacl;
5206 return;
5207 }
5208 }
5209 }
5210 DTC_DEFAULT(ict->sptr) = newacl;
5211 }
5212
5213 static ACL *
get_struct_default_init(int sptr)5214 get_struct_default_init(int sptr)
5215 {
5216 if (sptr > 0 && sptr <= DTC_DEFAULT_CNT - 1) {
5217 ACL *init_acl = DTC_DEFAULT(sptr);
5218 if (init_acl) {
5219 return clone_init_const(init_acl, 0);
5220 }
5221 return init_acl;
5222 } else {
5223 return NULL;
5224 }
5225 }
5226
5227 /** \brief Check whether derived type has components with default
5228 * initializations.
5229 *
5230 * \param dtype is the derived type we want to check.
5231 *
5232 * \return pointer to first default initializer, else NULL.
5233 */
5234 ACL *
all_default_init(DTYPE dtype)5235 all_default_init(DTYPE dtype)
5236 {
5237 int mem, myparent, thissptr;
5238 ACL *rslt, *dflt;
5239 int possible_ext = 1;
5240
5241 rslt = dflt = NULL;
5242 if (DTY(dtype) != TY_DERIVED && DTY(dtype) != TY_STRUCT &&
5243 DTY(dtype) != TY_UNION) {
5244 return NULL;
5245 }
5246
5247 thissptr = DTY(dtype + 1);
5248 for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
5249 if (POINTERG(mem))
5250 thissptr = mem;
5251 myparent = PARENTG(thissptr);
5252 if (myparent && myparent == PARENTG(mem) && possible_ext &&
5253 DTY(DTYPEG(mem)) == TY_DERIVED) {
5254 dflt = all_default_init(DTYPEG(mem));
5255 if (dflt)
5256 return dflt;
5257 } else {
5258 if (is_tbp_or_final(mem))
5259 continue; /* skip tbp */
5260 if (thissptr &&
5261 (mem == MIDNUMG(thissptr) || mem == PTROFFG(thissptr) ||
5262 mem == SDSCG(thissptr) || (CLASSG(mem) && DESCARRAYG(mem)))) {
5263 /* skip pointer related members */
5264 possible_ext = 0;
5265 continue;
5266 }
5267 if (mem > 0 && mem <= DTC_DEFAULT_CNT - 1) {
5268 rslt = DTC_DEFAULT(mem);
5269 if (rslt == NULL) {
5270 return NULL;
5271 } else if (!dflt) {
5272 dflt = clone_init_const(rslt, 0);
5273 }
5274 } else {
5275 return NULL;
5276 }
5277 }
5278 possible_ext = 0;
5279 }
5280 return dflt;
5281 }
5282
5283 static ACL *
get_exttype_list(int cnt)5284 get_exttype_list(int cnt)
5285 {
5286 int i;
5287 ACL *first = NULL;
5288 ACL *prev = NULL;
5289 for (i = 0; i < cnt; ++i) {
5290 if (DTC_ACL(i)) {
5291 if (first == NULL) {
5292 first = DTC_ACL(i);
5293 prev = first;
5294 prev->next = NULL;
5295 } else {
5296 prev->next = DTC_ACL(i);
5297 prev = prev->next;
5298 prev->next = NULL;
5299 }
5300 }
5301 }
5302 return first;
5303 }
5304
5305 static int
set_exttype_list(ACL * aclp)5306 set_exttype_list(ACL *aclp)
5307 {
5308 int i;
5309 ACL *first = aclp;
5310 for (i = 0; first != NULL; ++i) {
5311 DTC_ACL(i) = first;
5312 first = first->next;
5313 }
5314 for (; i < DTC_DT_CNT; ++i) {
5315 DTC_ACL(i) = 0;
5316 }
5317 return i;
5318 }
5319
5320 static int
get_exttype_default(DTYPE dtype,int pos)5321 get_exttype_default(DTYPE dtype, int pos)
5322 {
5323 int ptr_sptr = 0, thissptr, myparent;
5324 int member_sptr = DTY(dtype + 1);
5325 int possible_ext = 1;
5326 if (pos >= DTC_DT_CNT)
5327 return pos;
5328
5329 ptr_sptr = member_sptr;
5330 for (; member_sptr > NOSYM; member_sptr = SYMLKG(member_sptr)) {
5331 if (no_data_components(DTYPEG(member_sptr))) {
5332 possible_ext = 0;
5333 continue;
5334 }
5335 if (CLASSG(member_sptr) && VTABLEG(member_sptr) && BINDG(member_sptr)) {
5336 possible_ext = 0;
5337 continue;
5338 }
5339 if (POINTERG(member_sptr))
5340 ptr_sptr = member_sptr;
5341 if (ptr_sptr &&
5342 (member_sptr == MIDNUMG(ptr_sptr) || member_sptr == PTROFFG(ptr_sptr) ||
5343 member_sptr == SDSCG(ptr_sptr) ||
5344 (CLASSG(member_sptr) && DESCARRAYG(member_sptr)))) {
5345 /* skip pointer related members */
5346 possible_ext = 0;
5347 continue;
5348 }
5349 ptr_sptr =
5350 USELENG(member_sptr) || POINTERG(member_sptr) || ALLOCATTRG(member_sptr)
5351 ? member_sptr
5352 : 0;
5353
5354 thissptr = DTY(dtype + 1);
5355 myparent = PARENTG(thissptr);
5356 if (myparent && myparent == PARENTG(member_sptr) && possible_ext &&
5357 DTY(DTYPEG(member_sptr)) == TY_DERIVED) {
5358 if (!no_data_components(DTYPEG(member_sptr)))
5359 pos = get_exttype_default(DTYPEG(member_sptr), pos);
5360 } else {
5361 if (DTC_ACL(pos) == NULL)
5362 DTC_ACL(pos) = get_struct_default_init(member_sptr);
5363 ++pos;
5364 }
5365
5366 possible_ext = 0; /* only the first member is extended type member */
5367 if (pos > DTC_DT_CNT)
5368 return pos;
5369 }
5370 return pos;
5371 }
5372
5373 /* Also create a new ACL of base type if the initialization list of
5374 * extended type is not in the form of base_type(..).
5375 * This is getting complicated.
5376 */
5377
5378 static LOGICAL
get_keyword_components(ACL * in_aclp,int cnt,char * kwdarg,DTYPE dtype,int is_extend)5379 get_keyword_components(ACL *in_aclp, int cnt, char *kwdarg, DTYPE dtype,
5380 int is_extend)
5381 {
5382 SST *stkp;
5383 int pos;
5384 int i;
5385 char *kwd, *np;
5386 int kwd_len;
5387 char *actual_kwd; /* name of keyword used with the actual arg */
5388 int actual_kwd_len;
5389 LOGICAL kwd_present;
5390 ACL *t_aclp, *aclp = in_aclp->subc;
5391 int member_sptr;
5392
5393 /* convention for the keyword 'variable' arguments ---
5394 * the keyword specifier is of the form
5395 * #<pos>#<base>#<kwd>
5396 * where,
5397 * <pos> = digit indicating the zero-relative positional index where
5398 * the variable arguments begin in the argument list.
5399 * <base> = digit indicating value to be subtracted from the digit
5400 * string suffix of the keyword.
5401 * <kwd> = name of the keyword which varies (i.e., the prefix).
5402 */
5403
5404 if (*kwdarg == '\0' || *kwdarg == ' ')
5405 return TRUE;
5406 kwd_present = FALSE;
5407 for (i = 0; i < cnt; i++) {
5408 DTC_ACL(i) = NULL;
5409 }
5410
5411 for (pos = 0; aclp != NULL; pos++) {
5412 if (aclp->id == AC_EXPR) {
5413 stkp = aclp->u1.stkp;
5414 if (SST_IDG(stkp) == S_KEYWORD) {
5415 kwd_present = TRUE;
5416 actual_kwd = scn.id.name + SST_CVALG(stkp);
5417 actual_kwd_len = strlen(actual_kwd);
5418 kwd = kwdarg;
5419 for (i = 0; TRUE; i++) {
5420 if (*kwd == '*')
5421 kwd++;
5422 kwd_len = 0;
5423 for (np = kwd; TRUE; np++, kwd_len++)
5424 if (*np == ' ' || *np == '\0')
5425 break;
5426 if (kwd_len == actual_kwd_len &&
5427 strncmp(kwd, actual_kwd, actual_kwd_len) == 0)
5428 break;
5429 if (*np == '\0')
5430 goto ill_keyword;
5431 kwd = np + 1; /* skip over blank */
5432 }
5433 if (i > cnt)
5434 error(155, 3, gbl.lineno,
5435 "Too many elements in structure constructor", CNULL);
5436 if (DTC_ACL(i))
5437 goto ill_keyword;
5438 stkp = SST_E3G(stkp);
5439 aclp->u1.stkp = stkp; /* Should this be done?*/
5440 if (SST_IDG(stkp) == S_SCONST)
5441 DTC_ACL(i) = SST_ACLG(stkp);
5442 else
5443 DTC_ACL(i) = aclp; /* should SST_IDG change?*/
5444 } else {
5445 if (kwd_present) {
5446 error(155, 4, gbl.lineno,
5447 "Positional components must not follow keyword arguments",
5448 CNULL);
5449 return TRUE;
5450 }
5451 if (pos > cnt)
5452 error(155, 3, gbl.lineno,
5453 "Too many elements in structure constructor", CNULL);
5454 if (DTC_ACL(pos)) {
5455 char print[22];
5456 kwd = kwdarg;
5457 for (i = 0; TRUE; i++) {
5458 if (*kwd == '*' || *kwd == ' ')
5459 kwd++;
5460 if (*kwd == '\0') {
5461 error(155, 3, gbl.lineno,
5462 "Invalid element in structure constructor", CNULL);
5463 return TRUE;
5464 }
5465 kwd_len = 0;
5466 for (np = kwd; TRUE; np++) {
5467 if (*np == ' ' || *np == '\0')
5468 break;
5469 kwd_len++;
5470 }
5471 if (i == pos)
5472 break;
5473 kwd = np;
5474 }
5475 if (kwd_len > 21)
5476 kwd_len = 21;
5477 strncpy(print, kwd, kwd_len);
5478 print[kwd_len] = '\0';
5479 error(79, 3, gbl.lineno, print, CNULL);
5480 return TRUE;
5481 }
5482 DTC_ACL(pos) = aclp;
5483 }
5484 } else {
5485 if (kwd_present) {
5486 error(155, 4, gbl.lineno,
5487 "Positional components must not follow keyword components",
5488 CNULL);
5489 return TRUE;
5490 }
5491 DTC_ACL(pos) = aclp;
5492 }
5493 aclp = aclp->next;
5494 if (pos > cnt)
5495 errsev(67);
5496 }
5497
5498 if (is_extend) {
5499 /* for extended type, the first member is the base type. */
5500 /* if kwd_present, then it must list all members in base type(s). */
5501 aclp = in_aclp->subc;
5502 member_sptr = DTY(dtype + 1);
5503 if (!no_data_components(DTYPEG(member_sptr))) {
5504 if (kwd_present || pos < cnt) {
5505 /* get default value here if keyword is present */
5506 pos = get_exttype_default(dtype, 0);
5507 }
5508 aclp = get_exttype_list(cnt);
5509 if (!(aclp->id == AC_SCONST &&
5510 cmpat_dtype_with_size(aclp->dtype, DTYPEG(member_sptr)))) {
5511 aclp = get_exttype_struct_constructor(aclp, dtype, &t_aclp);
5512 }
5513 in_aclp->subc = aclp;
5514 return kwd_present;
5515 }
5516 }
5517
5518 /* determine if required component is not present. */
5519
5520 kwd = kwdarg;
5521 for (pos = 0; pos < cnt; pos++, kwd = np) {
5522 if (*kwd == ' ')
5523 kwd++;
5524 kwd_len = 0;
5525 for (np = kwd; TRUE; np++) {
5526 if (*np == ' ' || *np == '\0')
5527 break;
5528 kwd_len++;
5529 }
5530 if (DTC_ACL(pos) && sem.new_param_dt) {
5531 /* We have an initializer in a type parameter position...
5532 * skip over the type parameter since it is not defined in
5533 * the structure constructor portion of the syntax. Instead,
5534 * set the next component to this value and the type parameter
5535 * to its default value.
5536 */
5537 int i;
5538 char *buf = getitem(0, kwd_len + 1);
5539 strncpy(buf, kwd, kwd_len);
5540 buf[kwd_len] = '\0';
5541
5542 if (*buf == '*')
5543 ++buf;
5544
5545 put_default_kind_type_param(sem.new_param_dt, 0, 0);
5546 put_length_type_param(sem.new_param_dt, 0);
5547
5548 i = get_kind_parm_by_name(buf, sem.new_param_dt);
5549 if (i != 0) {
5550 SST *e1;
5551 int j;
5552
5553 for (j = (cnt - 1); j > pos; --j)
5554 DTC_ACL(j) = DTC_ACL(j - 1);
5555
5556 e1 = (SST *)getitem(ACL_SAVE_AREA, sizeof(SST));
5557 if (i < 0) {
5558 int val = 0;
5559 i = get_len_set_parm_by_name(buf, sem.new_param_dt, &val);
5560 if (val) {
5561 SST_IDP(e1, S_EXPR);
5562 SST_DTYPEP(e1, DT_INT);
5563 SST_ASTP(e1, val);
5564 } else {
5565 SST_IDP(e1, S_CONST);
5566 SST_DTYPEP(e1, DT_INT);
5567 SST_CVALP(e1, i);
5568 SST_ASTP(e1, mk_cval1(i, DT_INT));
5569 SST_SHAPEP(e1, 0);
5570 }
5571 } else {
5572
5573 SST_IDP(e1, S_CONST);
5574 SST_DTYPEP(e1, DT_INT);
5575 SST_CVALP(e1, i);
5576 SST_ASTP(e1, mk_cval1(i, DT_INT));
5577 SST_SHAPEP(e1, 0);
5578 }
5579
5580 t_aclp = GET_ACL(15);
5581 t_aclp->id = AC_EXPR;
5582 t_aclp->repeatc = t_aclp->size = 0;
5583 t_aclp->next = NULL;
5584 t_aclp->subc = NULL;
5585 t_aclp->u1.stkp = e1;
5586 DTC_ACL(pos) = t_aclp;
5587 continue;
5588 }
5589 } else if (DTC_ACL(pos) == NULL) {
5590 /* If missing value in structure constructor is a type parameter,
5591 * then fill in the value here.
5592 */
5593 int i;
5594 char *buf = getitem(0, kwd_len + 1);
5595 strncpy(buf, kwd, kwd_len);
5596 buf[kwd_len] = '\0';
5597 if (*buf == '*')
5598 ++buf;
5599 if (sem.new_param_dt) {
5600 /* Make sure the default values are initialized */
5601 put_default_kind_type_param(sem.new_param_dt, 0, 0);
5602 put_length_type_param(sem.new_param_dt, 0);
5603 }
5604 if ((sem.new_param_dt &&
5605 (i = get_kind_parm_by_name(buf, sem.new_param_dt)))) {
5606 SST *e1;
5607 e1 = (SST *)getitem(ACL_SAVE_AREA, sizeof(SST));
5608 if (i < 0) {
5609 int val = 0;
5610 i = get_len_set_parm_by_name(buf, sem.new_param_dt, &val);
5611 if (val) {
5612 SST_IDP(e1, S_EXPR);
5613 SST_DTYPEP(e1, DT_INT);
5614 SST_ASTP(e1, val);
5615 } else {
5616 SST_IDP(e1, S_CONST);
5617 SST_DTYPEP(e1, DT_INT);
5618 SST_CVALP(e1, i);
5619 SST_ASTP(e1, mk_cval1(i, DT_INT));
5620 SST_SHAPEP(e1, 0);
5621 }
5622 } else {
5623
5624 SST_IDP(e1, S_CONST);
5625 SST_DTYPEP(e1, DT_INT);
5626 SST_CVALP(e1, i);
5627 SST_ASTP(e1, mk_cval1(i, DT_INT));
5628 SST_SHAPEP(e1, 0);
5629 }
5630
5631 t_aclp = GET_ACL(15);
5632 t_aclp->id = AC_EXPR;
5633 t_aclp->repeatc = t_aclp->size = 0;
5634 t_aclp->next = NULL;
5635 t_aclp->subc = NULL;
5636 t_aclp->u1.stkp = e1;
5637
5638 DTC_ACL(pos) = t_aclp;
5639 continue;
5640 }
5641 }
5642 if (*kwd == '*') {
5643 continue;
5644 }
5645
5646 if (DTC_ACL(pos) == NULL) {
5647 char print[22];
5648 if (kwd_len > 21)
5649 kwd_len = 21;
5650 strncpy(print, kwd, kwd_len);
5651 print[kwd_len] = '\0';
5652 error(155, 4, gbl.lineno,
5653 "No default initialization in structure constructor- member",
5654 print);
5655
5656 return kwd_present;
5657 }
5658 }
5659
5660 return kwd_present;
5661
5662 ill_keyword:
5663 error(155, 4, gbl.lineno,
5664 "Invalid component initialization in structure constructor", CNULL);
5665 return kwd_present;
5666 }
5667
5668 /* Put in_aclp in a form similar its datatype.
5669 * Also check the default init value here.
5670 */
5671 static ACL *
get_exttype_struct_constructor(ACL * in_aclp,DTYPE dtype,ACL ** prev_aclp)5672 get_exttype_struct_constructor(ACL *in_aclp, DTYPE dtype, ACL **prev_aclp)
5673 {
5674 int member_dtype, field_dtype;
5675 int member_sptr;
5676 int ptr_sptr = 0, thissptr, myparent;
5677 ACL *aclp, *head_aclp, *curr_aclp;
5678 SST *stkp;
5679 int ast, possible_ext = 1;
5680
5681 aclp = in_aclp;
5682 head_aclp = in_aclp;
5683 curr_aclp = NULL;
5684
5685 #if DEBUG
5686 if (DBGBIT(3, 64))
5687 printacl("get_exttype_struct_constructor", aclp, gbl.dbgfil);
5688 #endif
5689
5690 member_sptr = DTY(dtype + 1);
5691 ptr_sptr = member_sptr;
5692 if (member_sptr == 0) {
5693 error(155, 3, gbl.lineno, "Use of derived type name before definition:",
5694 SYMNAME(DTY(dtype + 3)));
5695 return in_aclp;
5696 }
5697 for (; member_sptr != NOSYM && aclp != NULL;
5698 member_sptr = SYMLKG(member_sptr)) {
5699 if (no_data_components(DTYPEG(member_sptr))) {
5700 possible_ext = 0;
5701 continue;
5702 }
5703 if (is_tbp_or_final(member_sptr)) {
5704 possible_ext = 0;
5705 continue; /* skip tbp */
5706 }
5707
5708 if (POINTERG(member_sptr))
5709 ptr_sptr = member_sptr;
5710 if (ptr_sptr &&
5711 (member_sptr == MIDNUMG(ptr_sptr) || member_sptr == PTROFFG(ptr_sptr) ||
5712 member_sptr == SDSCG(ptr_sptr) ||
5713 (CLASSG(member_sptr) && DESCARRAYG(member_sptr)))) {
5714 /* skip pointer related members */
5715 possible_ext = 0;
5716 continue;
5717 }
5718 ptr_sptr =
5719 USELENG(member_sptr) || POINTERG(member_sptr) || ALLOCATTRG(member_sptr)
5720 ? member_sptr
5721 : 0;
5722 thissptr = DTY(dtype + 1);
5723 myparent = PARENTG(thissptr);
5724 member_dtype = DTYPEG(member_sptr);
5725 field_dtype = member_dtype;
5726 if (possible_ext) {
5727 switch (aclp->id) {
5728 case AC_AST:
5729 ast = aclp->u1.ast;
5730 field_dtype = A_DTYPEG(ast);
5731 break;
5732 case AC_EXPR:
5733 stkp = aclp->u1.stkp;
5734 field_dtype = SST_DTYPEG(stkp);
5735 if (SST_IDG(stkp) == S_IDENT || SST_IDG(stkp) == S_LVALUE ||
5736 (SST_IDG(stkp) == S_EXPR && A_TYPEG(SST_ASTG(stkp)) == A_ID)) {
5737 SPTR sptr;
5738 if (SST_IDG(stkp) == S_IDENT) {
5739 sptr = SST_SYMG(stkp);
5740 } else if (SST_IDG(stkp) == S_EXPR &&
5741 A_TYPEG(SST_ASTG(stkp)) == A_ID) {
5742 sptr = A_SPTRG(SST_ASTG(stkp));
5743 } else {
5744 sptr = SST_LSYMG(stkp);
5745 }
5746 if (DESCARRAYG(sptr) && DESCARRAYG(member_sptr)) {
5747 field_dtype = DDTG(field_dtype);
5748 }
5749 if (SCG(member_sptr) == SC_BASED &&
5750 (SCG(sptr) == SC_BASED || TARGETG(sptr) ||
5751 (SCG(sptr) == SC_CMBLK && POINTERG(sptr) &&
5752 !F90POINTERG(sptr)))) {
5753 field_dtype = DDTG(field_dtype);
5754 }
5755 } else if (SST_IDG(stkp) == S_EXPR) {
5756 field_dtype = 0;
5757 }
5758 break;
5759 case AC_ACONST:
5760 case AC_SCONST:
5761 field_dtype = aclp->dtype;
5762 break;
5763 default:
5764 field_dtype = 0;
5765 break;
5766 }
5767 }
5768
5769 if (myparent && myparent == PARENTG(member_sptr) && possible_ext &&
5770 DTY(member_dtype) == TY_DERIVED &&
5771 !no_data_components(DTYPEG(member_dtype))) {
5772 if (!cmpat_dtype_with_size(field_dtype, member_dtype)) {
5773 head_aclp = GET_ACL(15);
5774 head_aclp->id = AC_SCONST;
5775 head_aclp->dtype = DDTG(member_dtype);
5776 head_aclp->next = NULL;
5777 *prev_aclp = aclp;
5778 head_aclp->subc = get_exttype_struct_constructor(
5779 aclp, DDTG(DTYPEG(member_sptr)), prev_aclp);
5780 if (*prev_aclp) {
5781 aclp = (*prev_aclp)->next;
5782 (*prev_aclp)->next = NULL;
5783 *prev_aclp = aclp;
5784 }
5785 curr_aclp = head_aclp;
5786 head_aclp->next = NULL;
5787 } else {
5788 *prev_aclp = aclp;
5789 if (curr_aclp)
5790 curr_aclp->next = aclp;
5791 curr_aclp = aclp;
5792 aclp = aclp->next;
5793 }
5794 } else {
5795 *prev_aclp = aclp;
5796 if (curr_aclp)
5797 curr_aclp->next = aclp;
5798 curr_aclp = aclp;
5799 aclp = aclp->next;
5800 }
5801
5802 possible_ext = 0;
5803 }
5804 return head_aclp;
5805 }
5806
5807 void
chk_struct_constructor(ACL * in_aclp)5808 chk_struct_constructor(ACL *in_aclp)
5809 {
5810 DTYPE dtype, member_dtype, field_dtype;
5811 int field_rank, member_rank;
5812 int member_sptr, memnum, cnt;
5813 int ptr_sptr = 0;
5814 ACL *aclp, *prev_aclp;
5815 SST *stkp;
5816 int ast, shape;
5817 int is_extend = 0;
5818 char *keyword;
5819
5820 aclp = in_aclp;
5821 #if DEBUG
5822 if (DBGBIT(3, 64))
5823 printacl("chk_struct_constructor", aclp, gbl.dbgfil);
5824 #endif
5825 assert(aclp->id == AC_SCONST, "bad id in chk_struct_constructor", aclp->id,
5826 3);
5827
5828 dtype = aclp->dtype;
5829 aclp = aclp->subc; /* go down to member list */
5830 member_sptr = DTY(dtype + 1);
5831 ptr_sptr = member_sptr;
5832 if (member_sptr == 0) {
5833 error(155, 3, gbl.lineno, "Use of derived type name before definition:",
5834 SYMNAME(DTY(dtype + 3)));
5835 return;
5836 }
5837 keyword = make_structkwd_str(dtype, &memnum, &is_extend);
5838 if (get_keyword_components(in_aclp, memnum, keyword, dtype, is_extend)) {
5839 ;
5840 }
5841 FREE(keyword);
5842 if (is_extend) {
5843 cnt = set_exttype_list(in_aclp->subc);
5844 }
5845
5846 cnt = 0;
5847 prev_aclp = NULL;
5848 for (; member_sptr != NOSYM; member_sptr = SYMLKG(member_sptr)) {
5849 if (POINTERG(member_sptr))
5850 ptr_sptr = member_sptr;
5851 if (no_data_components(DTYPEG(member_sptr)))
5852 continue;
5853 if (is_tbp_or_final(member_sptr))
5854 continue; /* skip tbp */
5855 if (ptr_sptr &&
5856 (member_sptr == MIDNUMG(ptr_sptr) || member_sptr == PTROFFG(ptr_sptr) ||
5857 member_sptr == SDSCG(ptr_sptr) ||
5858 (CLASSG(member_sptr) && DESCARRAYG(member_sptr)))) {
5859 continue; /* skip pointer-related members */
5860 }
5861 ptr_sptr =
5862 USELENG(member_sptr) || POINTERG(member_sptr) || ALLOCATTRG(member_sptr)
5863 ? member_sptr
5864 : 0;
5865
5866 aclp = DTC_ACL(cnt);
5867 if (aclp == NULL) {
5868 aclp = get_struct_default_init(member_sptr);
5869 }
5870 if (aclp)
5871 aclp->next = NULL;
5872 else
5873 error(155, 4, gbl.lineno,
5874 "No default initialization in structure constructor- member",
5875 SYMNAME(member_sptr));
5876
5877 if (prev_aclp == NULL) {
5878 prev_aclp = aclp;
5879 in_aclp->subc = aclp;
5880 } else {
5881 prev_aclp->next = aclp;
5882 prev_aclp = aclp;
5883 }
5884 member_dtype = DTYPEG(member_sptr);
5885 member_rank = rank_of(member_dtype);
5886
5887 ast = 0;
5888 switch (aclp->id) {
5889 case AC_AST:
5890 ast = aclp->u1.ast;
5891 field_dtype = A_DTYPEG(ast);
5892 shape = A_SHAPEG(ast);
5893 field_rank = (shape == 0) ? 0 : SHD_NDIM(shape);
5894 if ((POINTERG(member_sptr) || ALLOCATTRG(member_sptr))) {
5895 if (aclp->dtype == DT_PTR) {
5896 int tdtype = aclp->ptrdtype;
5897 if (DTY(tdtype) == TY_PTR) {
5898 field_dtype = DTY(tdtype + 1);
5899 }
5900 }
5901 }
5902 break;
5903 case AC_EXPR:
5904 stkp = aclp->u1.stkp;
5905 field_dtype = SST_DTYPEG(stkp);
5906 if (field_dtype)
5907 field_rank = rank_of(field_dtype);
5908 if (SST_IDG(stkp) == S_IDENT || SST_IDG(stkp) == S_LVALUE ||
5909 (SST_IDG(stkp) == S_EXPR && A_TYPEG(SST_ASTG(stkp)) == A_ID)) {
5910 int newast, sptr;
5911 if (SST_IDG(stkp) == S_IDENT) {
5912 sptr = SST_SYMG(stkp);
5913 } else if (SST_IDG(stkp) == S_EXPR && A_TYPEG(SST_ASTG(stkp)) == A_ID) {
5914 sptr = A_SPTRG(SST_ASTG(stkp));
5915 } else {
5916 sptr = SST_LSYMG(stkp);
5917 }
5918 if (DESCARRAYG(sptr) && DESCARRAYG(member_sptr)) {
5919 field_dtype = DDTG(field_dtype);
5920 member_dtype = DDTG(member_dtype);
5921 }
5922 if (SCG(member_sptr) == SC_BASED &&
5923 (SCG(sptr) == SC_BASED || TARGETG(sptr) ||
5924 (SCG(sptr) == SC_CMBLK && POINTERG(sptr) && !F90POINTERG(sptr)))) {
5925 /* add ACLs for pointer/offset/descriptor */
5926 ACL *naclp;
5927 SST *sp;
5928 int sdsc, ptroff, midnum;
5929 ast = SST_ASTG(stkp);
5930 if (ast) {
5931 shape = A_SHAPEG(ast);
5932 field_rank = (shape == 0) ? 0 : SHD_NDIM(shape);
5933 }
5934 field_dtype = DDTG(field_dtype);
5935 member_dtype = DDTG(member_dtype);
5936 if ((TARGETG(sptr) || POINTERG(sptr)) && SDSCG(sptr) == 0 &&
5937 !F90POINTERG(sptr)) {
5938 get_static_descriptor(sptr);
5939 if (POINTERG(sptr) || (ALLOCATTRG(sptr) && TARGETG(sptr))) {
5940 get_all_descriptors(sptr);
5941 }
5942 }
5943 sdsc = SDSCG(sptr);
5944 if (sdsc && SDSCG(member_sptr) &&
5945 STYPEG(SDSCG(member_sptr)) == ST_MEMBER) {
5946
5947 sp = (SST *)getitem(ACL_AREA, sizeof(SST));
5948 if (SST_IDG(stkp) == S_IDENT) {
5949 SST_IDP(sp, S_IDENT);
5950 SST_SYMP(sp, sdsc);
5951 } else {
5952 SST_IDP(sp, S_LVALUE);
5953 SST_SYMP(sp, SST_SYMG(stkp));
5954 SST_LSYMP(sp, sdsc);
5955 newast = check_member(ast, mk_id(sdsc));
5956 SST_ASTP(sp, newast);
5957 SST_SHAPEP(sp, A_SHAPEG(newast));
5958 }
5959 SST_DTYPEP(sp, DTYPEG(sdsc));
5960 naclp = GET_ACL(ACL_AREA);
5961 naclp->id = AC_EXPR;
5962 naclp->repeatc = naclp->size = 0;
5963 naclp->next = prev_aclp->next;
5964 naclp->subc = NULL;
5965 naclp->u1.stkp = sp;
5966 prev_aclp->next = naclp;
5967 prev_aclp = naclp;
5968
5969 sp = (SST *)getitem(ACL_AREA, sizeof(SST));
5970 ptroff = PTROFFG(sptr);
5971 if (ptroff == 0) {
5972 SST_IDP(sp, S_CONST);
5973 SST_SYMP(sp, stb.i0);
5974 SST_DTYPEP(sp, DTYPEG(stb.i0));
5975 } else if (SST_IDG(stkp) == S_IDENT) {
5976 SST_IDP(sp, S_IDENT);
5977 SST_SYMP(sp, ptroff);
5978 SST_DTYPEP(sp, DTYPEG(ptroff));
5979 } else {
5980 SST_IDP(sp, S_LVALUE);
5981 SST_SYMP(sp, SST_SYMG(stkp));
5982 SST_LSYMP(sp, ptroff);
5983 newast = check_member(ast, mk_id(ptroff));
5984 SST_ASTP(sp, newast);
5985 SST_SHAPEP(sp, A_SHAPEG(newast));
5986 SST_DTYPEP(sp, DTYPEG(ptroff));
5987 }
5988 naclp = GET_ACL(ACL_AREA);
5989 naclp->id = AC_EXPR;
5990 naclp->repeatc = naclp->size = 0;
5991 naclp->next = prev_aclp->next;
5992 naclp->subc = NULL;
5993 naclp->u1.stkp = sp;
5994 prev_aclp->next = naclp;
5995 prev_aclp = naclp;
5996
5997 sp = (SST *)getitem(ACL_AREA, sizeof(SST));
5998 midnum = MIDNUMG(sptr);
5999 if (midnum == 0) {
6000 SST_IDP(sp, S_CONST);
6001 SST_SYMP(sp, stb.i0);
6002 SST_DTYPEP(sp, DTYPEG(stb.i0));
6003 } else if (SST_IDG(stkp) == S_IDENT) {
6004 SST_IDP(sp, S_IDENT);
6005 SST_SYMP(sp, midnum);
6006 SST_DTYPEP(sp, DTYPEG(midnum));
6007 } else {
6008 SST_IDP(sp, S_LVALUE);
6009 SST_SYMP(sp, SST_SYMG(stkp));
6010 SST_LSYMP(sp, midnum);
6011 newast = check_member(ast, mk_id(midnum));
6012 SST_ASTP(sp, newast);
6013 SST_SHAPEP(sp, A_SHAPEG(ast));
6014 SST_DTYPEP(sp, DTYPEG(midnum));
6015 }
6016 naclp = GET_ACL(ACL_AREA);
6017 naclp->id = AC_EXPR;
6018 naclp->repeatc = naclp->size = 0;
6019 naclp->next = prev_aclp->next;
6020 naclp->subc = NULL;
6021 naclp->u1.stkp = sp;
6022 prev_aclp->next = naclp;
6023 prev_aclp = naclp;
6024 }
6025 }
6026 } else if (SST_IDG(stkp) == S_EXPR) {
6027 /* handle call to NULL() */
6028 ast = SST_ASTG(stkp);
6029 field_dtype = 0;
6030 field_rank = 0;
6031 if (A_TYPEG(ast) == A_INTR && A_OPTYPEG(ast) == I_NULL) {
6032 field_dtype = A_DTYPEG(ast);
6033 if (POINTERG(member_sptr) || ALLOCATTRG(member_sptr)) {
6034 member_dtype = DT_PTR;
6035 }
6036 }
6037 }
6038 break;
6039 case AC_ACONST:
6040 case AC_SCONST:
6041 field_dtype = aclp->dtype;
6042 field_rank = rank_of(field_dtype);
6043 break;
6044 default:
6045 field_dtype = 0;
6046 field_rank = 0;
6047 break;
6048 }
6049 if ((field_rank && member_rank && field_rank != member_rank) ||
6050 (field_dtype && !cmpat_dtype_with_size(field_dtype, member_dtype))) {
6051 if (DTY(DTYPEG(member_sptr)) != TY_PTR &&
6052 DTY(DTY(DTYPEG(member_sptr) + 1)) != TY_PROC)
6053 error(155, 2, gbl.lineno, "Mismatched data type for member",
6054 SYMNAME(member_sptr));
6055 }
6056 if (is_illegal_expr_in_init(member_sptr, ast, aclp->dtype)) {
6057 error(457, 3, gbl.lineno, CNULL, CNULL);
6058 }
6059
6060 cnt++;
6061 }
6062 if (cnt > memnum)
6063 error(155, 4, gbl.lineno,
6064 "Too many elements in structure constructor- type",
6065 SYMNAME(DTY(dtype + 3)));
6066
6067 /* may want to set is_const flag in aclp if all members are constant */
6068 }
6069
6070 static bool
is_illegal_expr_in_init(SPTR member_sptr,int ast,DTYPE acl_dtype)6071 is_illegal_expr_in_init(SPTR member_sptr, int ast, DTYPE acl_dtype)
6072 {
6073 if (!sem.dinit_data)
6074 return false;
6075 if (!POINTERG(member_sptr) && !ALLOCATTRG(member_sptr))
6076 return false;
6077 if (ast == 0)
6078 return true;
6079 if (A_TYPEG(ast) == A_INTR && A_OPTYPEG(ast) == I_NULL)
6080 return false;
6081 if (ast != astb.i0 || acl_dtype != DT_PTR ||
6082 DTY(ENCLDTYPEG(member_sptr)) != TY_DERIVED)
6083 return true;
6084 return false;
6085 }
6086
6087 int
init_derived_w_acl(int in_sptr,ACL * sconst)6088 init_derived_w_acl(int in_sptr, ACL *sconst)
6089 {
6090 int sptr, dtype, tag;
6091
6092 if (in_sptr)
6093 sptr = in_sptr;
6094 else {
6095 dtype = sconst->dtype;
6096 tag = DTY(dtype + 3);
6097 sptr = get_next_sym(SYMNAME(tag), "d");
6098 STYPEP(sptr, ST_VAR);
6099 DCLDP(sptr, 1);
6100 SCP(sptr, sem.sc);
6101 DTYPEP(sptr, dtype);
6102 add_alloc_mem_initialize(sptr);
6103 }
6104
6105 constructf90(sptr, sconst);
6106
6107 return sptr;
6108 }
6109
6110 /*
6111 * keep track of an initialization ast tree.
6112 * this is a list of ast nodes linked by A_RIGHT fields;
6113 * the A_TYPE is A_INIT
6114 * the A_LEFT field points to the initialization value.
6115 * the A_SPTR field, if set, points to the variable or member symbol.
6116 */
6117
6118 typedef struct {
6119 int head, tail;
6120 } ASTLIST;
6121
6122 static void
append_init_list(ASTLIST * target,ASTLIST * src)6123 append_init_list(ASTLIST *target, ASTLIST *src)
6124 {
6125 if (target->head == 0) {
6126 *target = *src;
6127 } else {
6128 A_RIGHTP(target->tail, src->head);
6129 target->tail = src->tail;
6130 }
6131 }
6132
6133 static void
add_init(ASTLIST * list,int left,DTYPE dtype,int sptr)6134 add_init(ASTLIST *list, int left, DTYPE dtype, int sptr)
6135 {
6136 int ast;
6137 ast = mk_init(left, dtype);
6138 A_SPTRP(ast, sptr);
6139 if (list->head == 0) {
6140 list->head = ast;
6141 } else {
6142 A_RIGHTP(list->tail, ast);
6143 }
6144 list->tail = ast;
6145 } /* add_init */
6146
6147 static LOGICAL out_of_elements_message;
6148
6149 /*
6150 * Evaluate a constant expression. Code borrowed from dinit_eval() and
6151 * changed to allow expression types other than integer.
6152 * Part of the fix for FS2281.
6153 */
6154 static INT
const_eval(int ast)6155 const_eval(int ast)
6156 {
6157 DOSTACK *p;
6158 int sptr;
6159 INT val;
6160 int lop, rop;
6161 INT term;
6162 INT lv, rv;
6163 int count;
6164 int sign;
6165
6166 if (ast == 0)
6167 return 1L;
6168 if (A_ALIASG(ast)) {
6169 ast = A_ALIASG(ast);
6170 goto eval_cnst;
6171 }
6172 switch (A_TYPEG(ast) /* opc */) {
6173 case A_ID:
6174 if (!DT_ISINT(A_DTYPEG(ast)))
6175 goto cnst_err;
6176 if (A_ALIASG(ast)) {
6177 ast = A_ALIASG(ast);
6178 goto eval_cnst;
6179 }
6180 /* see if this ident is an active do index variable: */
6181 sptr = A_SPTRG(ast);
6182 for (p = sem.dostack; p < sem.top; p++)
6183 if (p->sptr == sptr)
6184 return p->currval;
6185 /* else - illegal use of variable: */
6186 error(64, 3, gbl.lineno, SYMNAME(sptr), CNULL);
6187 sem.dinit_error = TRUE;
6188 return 1L;
6189
6190 case A_CNST:
6191 goto eval_cnst;
6192
6193 case A_UNOP:
6194 val = const_eval((int)A_LOPG(ast));
6195 if (A_OPTYPEG(ast) == OP_SUB)
6196 val = negate_const(val, A_DTYPEG(ast));
6197 if (A_OPTYPEG(ast) == OP_LNOT)
6198 val = ~(val);
6199 return val;
6200
6201 case A_BINOP:
6202 switch (A_OPTYPEG(ast)) {
6203 case OP_ADD:
6204 case OP_SUB:
6205 case OP_MUL:
6206 case OP_DIV:
6207 return const_fold(A_OPTYPEG(ast), const_eval((int)A_LOPG(ast)),
6208 const_eval((int)A_ROPG(ast)), A_DTYPEG(ast));
6209
6210 case OP_EQ:
6211 case OP_GE:
6212 case OP_GT:
6213 case OP_LE:
6214 case OP_LT:
6215 case OP_NE:
6216 val = const_fold(OP_CMP, const_eval((int)A_LOPG(ast)),
6217 const_eval((int)A_ROPG(ast)), A_DTYPEG(A_LOPG(ast)));
6218 switch (A_OPTYPEG(ast)) {
6219 case OP_EQ:
6220 val = (val == 0);
6221 break;
6222 case OP_GE:
6223 val = (val >= 0);
6224 break;
6225 case OP_GT:
6226 val = (val > 0);
6227 break;
6228 case OP_LE:
6229 val = (val <= 0);
6230 break;
6231 case OP_LT:
6232 val = (val < 0);
6233 break;
6234 case OP_NE:
6235 val = (val != 0);
6236 break;
6237 }
6238 val = val ? SCFTN_TRUE : SCFTN_FALSE;
6239 return val;
6240
6241 case OP_LEQV:
6242 case OP_LNEQV:
6243 case OP_LOR:
6244 case OP_LAND:
6245 lv = const_eval((int)A_LOPG(ast));
6246 rv = const_eval((int)A_ROPG(ast));
6247 switch (A_OPTYPEG(ast)) {
6248 case OP_LEQV:
6249 val = (lv == rv) ? SCFTN_TRUE : SCFTN_FALSE;
6250 case OP_LNEQV:
6251 val = (lv == rv) ? SCFTN_FALSE : SCFTN_TRUE;
6252 case OP_LOR:
6253 val = (lv == SCFTN_TRUE || rv == SCFTN_TRUE) ? SCFTN_TRUE : SCFTN_FALSE;
6254 case OP_LAND:
6255 val = (lv == SCFTN_TRUE && rv == SCFTN_TRUE) ? SCFTN_TRUE : SCFTN_FALSE;
6256 }
6257 return val;
6258
6259 case OP_XTOI:
6260 lop = A_LOPG(ast);
6261 rop = A_ROPG(ast);
6262 if (A_DTYPEG(rop) == DT_INT8) {
6263 term = stb.k1;
6264 if (A_DTYPEG(lop) != DT_INT8)
6265 term = cngcon(term, DT_INT8, A_DTYPEG(lop));
6266 val = term;
6267 lv = const_eval(lop);
6268 rv = const_eval(rop);
6269 count = get_int_cval(rv);
6270 count = (count < 0) ? -count : count;
6271 while (count--)
6272 val = const_fold(OP_MUL, val, lv, A_DTYPEG(lop));
6273 if (get_int_cval(rv) < 0) {
6274 /* exponentiation to a negative power */
6275 val = const_fold(OP_DIV, term, val, A_DTYPEG(lop));
6276 }
6277 } else if (DT_ISINT(A_DTYPEG(rop))) {
6278 term = 1;
6279 if (A_DTYPEG(lop) != DT_INT4)
6280 term = cngcon(term, DT_INT4, A_DTYPEG(lop));
6281 val = term;
6282 lv = const_eval(lop);
6283 rv = const_eval(rop);
6284 if (A_DTYPEG(rop) != DT_INT4)
6285 rv = cngcon(rv, A_DTYPEG(rop), DT_INT4);
6286 if (rv >= 0)
6287 sign = 0;
6288 else {
6289 rv = -rv;
6290 sign = 1;
6291 }
6292 while (rv--)
6293 val = const_fold(OP_MUL, val, lv, A_DTYPEG(lop));
6294 if (sign) {
6295 /* exponentiation to a negative power */
6296 val = const_fold(OP_DIV, term, val, A_DTYPEG(lop));
6297 }
6298 } else {
6299 lv = const_eval(lop);
6300 rv = const_eval(rop);
6301 val = const_fold(OP_XTOI, lv, rv, A_DTYPEG(lop));
6302 }
6303 return val;
6304 }
6305 break;
6306
6307 case A_CONV:
6308 val = const_eval((int)A_LOPG(ast));
6309 return cngcon(val, A_DTYPEG(A_LOPG(ast)), A_DTYPEG(ast));
6310
6311 case A_PAREN:
6312 return const_eval((int)A_LOPG(ast));
6313 case A_INTR:
6314 switch (A_OPTYPEG(ast)) {
6315 case I_NULL:
6316 return 0;
6317 case I_NCHAR:
6318
6319 /* kanji/international character sets */
6320
6321 val = A_ARGSG(ast);
6322 val = ARGT_ARG(val, 0);
6323 if (A_TYPEG(val) == A_CNST) {
6324 int con1, con2, bytes;
6325 con1 = A_SPTRG(val);
6326 con2 = CONVAL1G(con1);
6327 count = size_of(DTYPEG(con2));
6328 val = kanji_char((unsigned char *)stb.n_base + CONVAL1G(con2), count,
6329 &bytes);
6330 return val;
6331 }
6332 break;
6333 case I_ICHAR:
6334 case I_IACHAR:
6335 val = A_ARGSG(ast);
6336 val = ARGT_ARG(val, 0);
6337 if (A_TYPEG(val) == A_CNST) {
6338 val = A_SPTRG(val);
6339 count = size_of(DTYPEG(val));
6340 if (count == 1) {
6341 val = stb.n_base[CONVAL1G(val)] & 0xff;
6342 return val;
6343 }
6344 }
6345 break;
6346 case I_INT:
6347 val = A_ARGSG(ast);
6348 ast = ARGT_ARG(val, 0);
6349 val = const_eval(ast);
6350 return cngcon(val, A_DTYPEG(ast), DT_INT);
6351 case I_INT8:
6352 val = A_ARGSG(ast);
6353 ast = ARGT_ARG(val, 0);
6354 val = const_eval(ast);
6355 return cngcon(val, A_DTYPEG(ast), DT_INT8);
6356 case I_INT4:
6357 val = A_ARGSG(ast);
6358 ast = ARGT_ARG(val, 0);
6359 val = const_eval(ast);
6360 return cngcon(val, A_DTYPEG(ast), DT_INT4);
6361 case I_INT2:
6362 val = A_ARGSG(ast);
6363 ast = ARGT_ARG(val, 0);
6364 val = const_eval(ast);
6365 return cngcon(val, A_DTYPEG(ast), DT_SINT);
6366 case I_INT1:
6367 val = A_ARGSG(ast);
6368 ast = ARGT_ARG(val, 0);
6369 val = const_eval(ast);
6370 return cngcon(val, A_DTYPEG(ast), DT_BINT);
6371 case I_SIZE: {
6372 int sz;
6373 val = A_ARGSG(ast);
6374 ast = ARGT_ARG(val, 0);
6375 ast = ADD_NUMELM(A_DTYPEG(ast));
6376 sz = get_const_from_ast(ast);
6377 if (XBIT(68, 0x1) && A_ALIASG(ast) && !DT_ISWORD(A_DTYPEG(ast))) {
6378 sz = get_int_cval(sz);
6379 }
6380 return sz;
6381 }
6382 case I_LBOUND: {
6383 int lwb;
6384 val = A_ARGSG(ast);
6385 ast = ARGT_ARG(val, 0);
6386 ast = ADD_LWAST(A_DTYPEG(ast), val - 1);
6387 lwb = get_const_from_ast(ast);
6388 if (XBIT(68, 0x1) && A_ALIASG(ast) && !DT_ISWORD(A_DTYPEG(ast))) {
6389 lwb = get_int_cval(lwb);
6390 }
6391 return lwb;
6392 }
6393 case I_UBOUND: {
6394 int upb;
6395 val = A_ARGSG(ast);
6396 ast = ARGT_ARG(val, 0);
6397 ast = ADD_UPAST(A_DTYPEG(ast), val - 1);
6398 upb = get_const_from_ast(ast);
6399 if (XBIT(68, 0x1) && A_ALIASG(ast) && !DT_ISWORD(A_DTYPEG(ast))) {
6400 upb = get_int_cval(upb);
6401 }
6402 return upb;
6403 }
6404 case I_MAX0: {
6405 int max, i, tmp;
6406 val = A_ARGSG(ast);
6407 max = get_const_from_ast(ARGT_ARG(val, 0));
6408 for (i = 1; i < A_ARGCNTG(ast); ++i) {
6409 tmp = get_const_from_ast(ARGT_ARG(val, i));
6410 if (tmp > max) {
6411 max = tmp;
6412 }
6413 }
6414 return max;
6415 }
6416 case I_MIN0: {
6417 int min, i, tmp;
6418 val = A_ARGSG(ast);
6419 min = get_const_from_ast(ARGT_ARG(val, 0));
6420 for (i = 1; i < A_ARGCNTG(ast); ++i) {
6421 tmp = get_const_from_ast(ARGT_ARG(val, i));
6422 if (tmp < min) {
6423 min = tmp;
6424 }
6425 }
6426 return min;
6427 }
6428 }
6429 break;
6430 default:
6431 break;
6432 }
6433 cnst_err:
6434 errsev(69);
6435 sem.dinit_error = TRUE;
6436 A_DTYPEP(ast, DT_INT);
6437 return 1L;
6438
6439 eval_cnst:
6440 val = A_SPTRG(ast);
6441 if (DT_ISWORD(DTY(A_DTYPEG(ast))))
6442 val = CONVAL2G(val);
6443 return val;
6444 }
6445
6446 /*
6447 * make sure 'ast' is a constant of the proper datatype
6448 */
6449 static int
dinit_getval(int ast,DTYPE dtype)6450 dinit_getval(int ast, DTYPE dtype)
6451 {
6452 DTYPE adtype;
6453 int aval, val;
6454 if (!A_ALIASG(ast)) {
6455 /* nothing to do right now */
6456 if (dtype == 0)
6457 dtype = A_DTYPEG(ast);
6458 aval = dinit_eval(ast);
6459 ast = mk_cval(aval, DT_INT);
6460 }
6461 if (dtype == 0)
6462 return ast;
6463 adtype = A_DTYPEG(ast);
6464 if (adtype == dtype)
6465 return ast;
6466 if (!DT_ISSCALAR(adtype) || !DT_ISSCALAR(dtype)) {
6467 return 0;
6468 }
6469 ast = A_ALIASG(ast);
6470 aval = A_SPTRG(ast);
6471 adtype = DTYPEG(aval);
6472 if (DT_ISWORD(adtype))
6473 aval = CONVAL2G(aval);
6474 val = cngcon(aval, adtype, dtype);
6475 ast = mk_cval1(val, dtype);
6476 return ast;
6477 } /* dinit_getval */
6478
6479 /*
6480 * Similar to dinit_getval, above, but allows types other than integer.
6481 * Part of the fix for FS2281.
6482 */
6483 static int
dinit_getval1(int ast,DTYPE dtype)6484 dinit_getval1(int ast, DTYPE dtype)
6485 {
6486 DTYPE adtype;
6487 INT aval, val;
6488 if (!A_ALIASG(ast)) {
6489 if (dtype == 0)
6490 dtype = A_DTYPEG(ast);
6491 aval = const_eval(ast);
6492 ast = mk_cval1(aval, A_DTYPEG(ast));
6493 }
6494 if (dtype == 0)
6495 return ast;
6496 adtype = A_DTYPEG(ast);
6497 if (adtype == dtype)
6498 return ast;
6499 if (!DT_ISSCALAR(adtype) || !DT_ISSCALAR(dtype)) {
6500 return 0;
6501 }
6502 ast = A_ALIASG(ast);
6503 aval = A_SPTRG(ast);
6504 adtype = DTYPEG(aval);
6505 if (DT_ISWORD(adtype))
6506 aval = CONVAL2G(aval);
6507 val = cngcon(aval, adtype, dtype);
6508 ast = mk_cval1(val, dtype);
6509 return ast;
6510 } /* dinit_getval1 */
6511
6512 static int
unop_init_list(int llist,int optype)6513 unop_init_list(int llist, int optype)
6514 {
6515 int ll, list, last, nlist;
6516 list = last = 0;
6517 if (!llist) {
6518 /* error return */
6519 interr("unop_init_list, no llist", 0, 3);
6520 return 0;
6521 }
6522 for (ll = llist; ll; ll = A_RIGHTG(ll)) {
6523 int le;
6524 le = A_LEFTG(ll);
6525 if (A_TYPEG(le) == A_INIT) {
6526 nlist = unop_init_list(le, optype);
6527 } else {
6528 /* do the operation */
6529 nlist = mk_unop(optype, le, A_DTYPEG(le));
6530 }
6531 nlist = mk_init(nlist, A_DTYPEG(nlist));
6532 if (last) {
6533 A_RIGHTP(last, nlist);
6534 } else {
6535 list = nlist;
6536 }
6537 last = nlist;
6538 }
6539 return list;
6540 } /* unop_init_list */
6541
6542 static int
binop_init_list(int llist,int rlist,int lop,int rop,int optype)6543 binop_init_list(int llist, int rlist, int lop, int rop, int optype)
6544 {
6545 int ll, rl, list, last, nlist;
6546 list = last = 0;
6547 if (lop && rop) {
6548 /* error return */
6549 interr("binop_init_list, lop&&rop", 0, 3);
6550 return 0;
6551 }
6552 if (!lop && !llist) {
6553 /* error return */
6554 interr("binop_init_list, neither lop nor llist", 0, 3);
6555 return 0;
6556 }
6557 if (!rop && !rlist) {
6558 /* error return */
6559 interr("binop_init_list, neither rop nor rlist", 0, 3);
6560 return 0;
6561 }
6562 if (!llist && !rlist) {
6563 /* error return */
6564 interr("binop_init_list, neither llist nor rlist", 0, 3);
6565 return 0;
6566 }
6567 if (llist && rlist) {
6568 for (ll = llist, rl = rlist; ll && rl;
6569 ll = A_RIGHTG(ll), rl = A_RIGHTG(rl)) {
6570 /* ll and rl are at an 'A_INIT' */
6571 int le, re;
6572 le = A_LEFTG(ll);
6573 re = A_LEFTG(rl);
6574 if (A_TYPEG(le) == A_INIT && A_TYPEG(re) == A_INIT) {
6575 nlist = binop_init_list(le, re, 0, 0, optype);
6576 } else if (A_TYPEG(le) == A_INIT) {
6577 nlist = binop_init_list(le, 0, 0, re, optype);
6578 } else if (A_TYPEG(re) == A_INIT) {
6579 nlist = binop_init_list(0, re, le, 0, optype);
6580 } else {
6581 /* do the operation */
6582 nlist = mk_binop(optype, le, re, A_DTYPEG(le));
6583 }
6584 nlist = mk_init(nlist, A_DTYPEG(nlist));
6585 if (last) {
6586 A_RIGHTP(last, nlist);
6587 } else {
6588 list = nlist;
6589 }
6590 last = nlist;
6591 }
6592 } else if (llist) {
6593 for (ll = llist; ll; ll = A_RIGHTG(ll)) {
6594 int le;
6595 le = A_LEFTG(ll);
6596 if (A_TYPEG(le) == A_INIT) {
6597 nlist = binop_init_list(le, 0, 0, rop, optype);
6598 } else {
6599 /* do the operation */
6600 nlist = mk_binop(optype, le, rop, A_DTYPEG(le));
6601 }
6602 nlist = mk_init(nlist, A_DTYPEG(nlist));
6603 if (last) {
6604 A_RIGHTP(last, nlist);
6605 } else {
6606 list = nlist;
6607 }
6608 last = nlist;
6609 }
6610 } else if (rlist) {
6611 for (rl = rlist; rl; rl = A_RIGHTG(rl)) {
6612 int re;
6613 re = A_LEFTG(rl);
6614 if (A_TYPEG(re) == A_INIT) {
6615 nlist = binop_init_list(0, re, lop, 0, optype);
6616 } else {
6617 /* do the operation */
6618 nlist = mk_binop(optype, lop, re, A_DTYPEG(re));
6619 }
6620 nlist = mk_init(nlist, A_DTYPEG(nlist));
6621 if (last) {
6622 A_RIGHTP(last, nlist);
6623 } else {
6624 list = nlist;
6625 }
6626 last = nlist;
6627 }
6628 }
6629 return list;
6630 } /* binop_init_list */
6631
6632 static void
add_subscript_list(ASTLIST * list,int ast,int arraylist,int ssval[],int ndim)6633 add_subscript_list(ASTLIST *list, int ast, int arraylist, int ssval[], int ndim)
6634 {
6635 /* find shape for array at 'ast', use that plus values of ssval[]
6636 * to pick a value from 'arraylist' */
6637 int a, sh, i, offset, o;
6638 a = A_LOPG(ast);
6639 sh = A_SHAPEG(a);
6640 assert(SHD_NDIM(sh) == ndim,
6641 "add_subscript_list, shape rank != subscript rank",
6642 SHD_NDIM(sh) - ndim, 3);
6643 offset = 0;
6644 for (i = 0; i < SHD_NDIM(sh); ++i) {
6645 int l, lsptr, lb, u, usptr, ub, ss, ssptr, ssv;
6646 l = SHD_LWB(sh, i);
6647 assert(A_ALIASG(l), "add_subscript_list: nonconstant array lower bound", l,
6648 3);
6649 l = A_ALIASG(l);
6650 lsptr = A_SPTRG(l);
6651 lb = CONVAL2G(lsptr);
6652 u = SHD_UPB(sh, i);
6653 assert(A_ALIASG(u), "add_subscript_list: nonconstant array upper bound", u,
6654 3);
6655 u = A_ALIASG(u);
6656 usptr = A_SPTRG(u);
6657 ub = CONVAL2G(usptr);
6658 ss = ssval[i];
6659 assert(A_ALIASG(ss), "add_subscript_list: nonconstant subscript", ss, 3);
6660 ss = A_ALIASG(ss);
6661 ssptr = A_SPTRG(ss);
6662 ssv = CONVAL2G(ssptr);
6663 if (ub >= lb)
6664 offset *= (ub - lb + 1);
6665 if (ssv >= lb)
6666 offset += ssv - lb;
6667 }
6668 /* skip 'offset' items from the arraylist, add that value to 'list' */
6669 for (o = arraylist; o && offset; o = A_RIGHTG(o), --offset)
6670 ;
6671 if (o) {
6672 DTYPE dtype = DDTG(A_DTYPEG(ast));
6673 add_init(list, A_LEFTG(o), dtype, 0);
6674 }
6675 } /* add_subscript_list */
6676
6677 static void
build_subscript_list(ASTLIST * list,int ast,int arraylist,int ssval[],int sslist[],int dim,int ndim)6678 build_subscript_list(ASTLIST *list, int ast, int arraylist, int ssval[],
6679 int sslist[], int dim, int ndim)
6680 {
6681 if (sslist[dim] == 0) {
6682 /* only one value for dimension 'dim' */
6683 if (dim > 0) {
6684 build_subscript_list(list, ast, arraylist, ssval, sslist, dim - 1, ndim);
6685 } else {
6686 add_subscript_list(list, ast, arraylist, ssval, ndim);
6687 }
6688 } else {
6689 /* step dimension 'dim' through all of its values */
6690 int l;
6691 for (l = sslist[dim]; l; l = A_RIGHTG(l)) {
6692 ssval[dim] = A_LEFTG(l);
6693 if (dim > 0) {
6694 build_subscript_list(list, ast, arraylist, ssval, sslist, dim - 1,
6695 ndim);
6696 } else {
6697 add_subscript_list(list, ast, arraylist, ssval, ndim);
6698 }
6699 }
6700 }
6701 } /* build_subscript_list */
6702
6703 static void
build_array_list(ASTLIST * list,int ast,DTYPE dtype,int sptr)6704 build_array_list(ASTLIST *list, int ast, DTYPE dtype, int sptr)
6705 {
6706 int asptr, lop, rop, asd, ndim, i;
6707 int lower, upper, stride, d, ssval[MAXDIMS], sslist[MAXDIMS];
6708 ASTLIST larray;
6709 int fldsptr, past;
6710 list->head = 0;
6711 list->tail = 0;
6712 switch (A_TYPEG(ast)) {
6713 case A_CNST:
6714 add_init(list, ast, dtype, 0);
6715 break;
6716 case A_MEM: {
6717 DTYPE dtype;
6718 int a;
6719 fldsptr = A_SPTRG(A_MEMG(ast));
6720 past = A_PARENTG(ast);
6721 asptr = A_SPTRG(past);
6722 for (a = A_LEFTG(PARAMVALG(asptr)); a; a = A_RIGHTG(a)) {
6723 if (A_SPTRG(a) == fldsptr) {
6724 break;
6725 }
6726 }
6727 if (!a) {
6728 interr("field initializer not found", 0, 3);
6729 sem.dinit_error = TRUE;
6730 break;
6731 }
6732 dtype = DDTG(DTYPEG(A_SPTRG(a)));
6733 for (a = A_LEFTG(a); a; a = A_RIGHTG(a)) {
6734 add_init(list, A_LEFTG(a), dtype, 0);
6735 }
6736 } break;
6737 case A_ID:
6738 /* an array name */
6739 asptr = A_SPTRG(ast);
6740 switch (STYPEG(asptr)) {
6741 case ST_ARRAY:
6742 case ST_IDENT:
6743 case ST_VAR:
6744 if (PARAMVALG(asptr)) {
6745 DTYPE dtype = DDTG(DTYPEG(asptr));
6746 int a;
6747 for (a = A_LEFTG(PARAMVALG(asptr)); a; a = A_RIGHTG(a)) {
6748 add_init(list, A_LEFTG(a), dtype, 0);
6749 }
6750 }
6751 break;
6752
6753 default:
6754 errsev(69);
6755 sem.dinit_error = TRUE;
6756 break;
6757 }
6758 break;
6759 case A_SUBSCR:
6760 /* subscripted array */
6761 build_array_list(&larray, A_LOPG(ast), dtype, sptr);
6762 /* get the subscript; take the one element, or the
6763 * sequence of elements requested */
6764 if (sem.dinit_error)
6765 break;
6766 asd = A_ASDG(ast);
6767 ndim = ASD_NDIM(asd);
6768 assert(ndim <= 7, "build_array_list, >7 dimensions", ndim, 3);
6769 assert(A_SHAPEG(A_LOPG(ast)), "build_array_list, shapeless array", 0, 3);
6770 for (i = 0; i < ndim; ++i) {
6771 int ss;
6772 ss = ASD_SUBS(asd, i);
6773 if (A_SHAPEG(ss) || A_TYPEG(ss) == A_TRIPLE) {
6774 ASTLIST ssl;
6775 build_array_list(&ssl, ss, astb.bnd.dtype, 0);
6776 ssval[i] = 0;
6777 sslist[i] = ssl.head;
6778 } else {
6779 ssval[i] = dinit_getval(ss, astb.bnd.dtype);
6780 sslist[i] = 0;
6781 }
6782 }
6783 build_subscript_list(list, ast, larray.head, ssval, sslist, ndim - 1, ndim);
6784 break;
6785 case A_UNOP:
6786 /* get the right operand */
6787 build_array_list(list, A_LOPG(ast), dtype, sptr);
6788 if (sem.dinit_error)
6789 break;
6790 /* negate? */
6791 switch (A_OPTYPEG(ast)) {
6792 case OP_SUB:
6793 /* negate everything on the list */
6794 unop_init_list(list->head, A_OPTYPEG(ast));
6795 break;
6796 case OP_ADD:
6797 break;
6798 default:
6799 errsev(69);
6800 sem.dinit_error = TRUE;
6801 }
6802 break;
6803 case A_BINOP:
6804 /* get right operand */
6805 lop = A_LOPG(ast);
6806 while (A_TYPEG(lop) == A_CONV)
6807 lop = A_LOPG(lop);
6808 rop = A_ROPG(ast);
6809 while (A_TYPEG(rop) == A_CONV)
6810 rop = A_LOPG(rop);
6811 if (A_SHAPEG(lop) && !A_SHAPEG(rop)) {
6812 build_array_list(list, lop, dtype, sptr);
6813 if (sem.dinit_error)
6814 break;
6815 binop_init_list(list->head, 0, 0, rop, A_OPTYPEG(ast));
6816 } else if (!A_SHAPEG(lop) && A_SHAPEG(rop)) {
6817 build_array_list(list, rop, dtype, sptr);
6818 if (sem.dinit_error)
6819 break;
6820 binop_init_list(0, list->head, lop, 0, A_OPTYPEG(ast));
6821 } else {
6822 ASTLIST list2;
6823 build_array_list(list, lop, dtype, sptr);
6824 if (sem.dinit_error)
6825 break;
6826 list2.head = list2.tail = 0;
6827 build_array_list(&list2, rop, dtype, sptr);
6828 if (sem.dinit_error)
6829 break;
6830 binop_init_list(list->head, list2.head, 0, 0, A_OPTYPEG(ast));
6831 }
6832 break;
6833 case A_CONV:
6834 case A_PAREN:
6835 build_array_list(list, A_LOPG(ast), dtype, sptr);
6836 break;
6837 case A_TRIPLE:
6838 /* build a list of items from the triplet */
6839 lower = dinit_getval(A_LBDG(ast), astb.bnd.dtype);
6840 upper = dinit_getval(A_UPBDG(ast), astb.bnd.dtype);
6841 if (A_STRIDEG(ast)) {
6842 stride = dinit_getval(A_STRIDEG(ast), astb.bnd.dtype);
6843 } else {
6844 stride = astb.bnd.one;
6845 }
6846 if (lower == 0 || upper == 0 || stride == 0) {
6847 errsev(69);
6848 sem.dinit_error = TRUE;
6849 break;
6850 }
6851 lower = A_ALIASG(lower);
6852 upper = A_ALIASG(upper);
6853 stride = A_ALIASG(stride);
6854 if (lower == 0 || upper == 0 || stride == 0) {
6855 errsev(69);
6856 sem.dinit_error = TRUE;
6857 break;
6858 }
6859 lower = A_SPTRG(lower);
6860 upper = A_SPTRG(upper);
6861 stride = A_SPTRG(stride);
6862 lower = CONVAL2G(lower);
6863 upper = CONVAL2G(upper);
6864 stride = CONVAL2G(stride);
6865 if (stride == 0) {
6866 errsev(69);
6867 sem.dinit_error = TRUE;
6868 break;
6869 } else if (stride > 0 && lower > upper) {
6870 errsev(69);
6871 sem.dinit_error = TRUE;
6872 break;
6873 } else if (stride < 0 && lower < upper) {
6874 errsev(69);
6875 sem.dinit_error = TRUE;
6876 break;
6877 }
6878 if (lower <= upper) {
6879 for (d = lower; d <= upper; d += stride) {
6880 /* make a constant with value 'd'; add to A_INIT list */
6881 int a = mk_isz_cval(d, astb.bnd.dtype);
6882 add_init(list, a, astb.bnd.dtype, 0);
6883 }
6884 } else {
6885 for (d = lower; d >= upper; d += stride) {
6886 /* make a constant with value 'd'; add to A_INIT list */
6887 int a = mk_isz_cval(d, astb.bnd.dtype);
6888 add_init(list, a, astb.bnd.dtype, 0);
6889 }
6890 }
6891 break;
6892 default:
6893 errsev(69);
6894 sem.dinit_error = TRUE;
6895 break;
6896 }
6897 } /* build_array_list */
6898
6899 static void
add_array_init(ASTLIST * list,int ast,DTYPE dtype,int sptr)6900 add_array_init(ASTLIST *list, int ast, DTYPE dtype, int sptr)
6901 {
6902 /* given an array-shaped expression ast, add 'init' items */
6903 ASTLIST newlist;
6904 newlist.head = 0;
6905 newlist.tail = 0;
6906
6907 build_array_list(&newlist, ast, dtype, sptr);
6908 if (newlist.head) {
6909 if (list->head == 0) {
6910 list->head = newlist.head;
6911 } else {
6912 A_RIGHTP(list->tail, newlist.head);
6913 }
6914 list->tail = newlist.tail;
6915 }
6916 } /* add_array_init */
6917
6918 static ACL *
dinit_fill_struct(ASTLIST * list,ACL * aclp,int sdtype,int sptr,int memberlist,int init_single)6919 dinit_fill_struct(ASTLIST *list, ACL *aclp, int sdtype, int sptr,
6920 int memberlist, int init_single)
6921 {
6922 int i, idx_sptr, aa, tmpcon;
6923 ACL *a;
6924 ACL *b;
6925 INT initval, limitval, stepval, save_conval1;
6926 INT num[2];
6927 ASTLIST newlist = {0, 0};
6928 if (aclp == NULL)
6929 return NULL;
6930 #if DEBUG
6931 if (DBGBIT(3, 64))
6932 dumpacl("dinit_fill_struct", aclp, gbl.dbgfil);
6933 #endif
6934 for (a = aclp; a; a = a->next) {
6935 SST *stkp;
6936 DOINFO *doinfo;
6937 int aast, dtype, ddtype, member, count;
6938 if (memberlist && sptr == 0 && !out_of_elements_message) {
6939 interr("dinit_fill_struct, out of derived type elements", 0, 0);
6940 out_of_elements_message = TRUE;
6941 }
6942 switch (a->id) {
6943 case AC_AST:
6944 dtype = A_DTYPEG(a->u1.ast);
6945 aast = a->u1.ast;
6946 if (A_TYPEG(aast) == A_ID && PARAMG(A_SPTRG(aast))) {
6947 if (PARAMVALG(A_SPTRG(aast))) {
6948 add_init(list, A_LEFTG(PARAMVALG(A_SPTRG(aast))), dtype, sptr);
6949 }
6950 } else {
6951 aast = dinit_getval(aast, sdtype);
6952 add_init(list, aast, dtype, sptr);
6953 }
6954 break;
6955 case AC_EXPR:
6956 /* get the AST */
6957 stkp = a->u1.stkp;
6958 dtype = SST_DTYPEG(stkp);
6959 a->repeatc = a->size = 0;
6960 aast = SST_ASTG(stkp);
6961 if (SST_IDG(stkp) == S_ACONST) {
6962 interr("dinit_fill_struct, unexpected S_ACONST", 0, 3);
6963 aast = 0;
6964 } else if (A_TYPEG(aast) == A_INTR || A_TYPEG(aast) == A_BINOP) {
6965 ACL *iaclp = construct_acl_from_ast(aast, sdtype, 0);
6966 if (!iaclp) {
6967 return 0;
6968 }
6969 iaclp = eval_init_expr_item(iaclp);
6970 if (!iaclp) {
6971 return 0;
6972 }
6973 newlist.head = newlist.tail = 0;
6974 dinit_fill_struct(&newlist, iaclp, sdtype, sptr, memberlist,
6975 init_single);
6976 append_init_list(list, &newlist);
6977 } else {
6978 int save;
6979 aast = SST_ASTG(stkp);
6980 if (A_SHAPEG(aast) != 0 || A_TYPEG(aast) == A_SUBSCR) {
6981 save = list->tail;
6982 add_array_init(list, aast, dtype, sptr);
6983 if (save) {
6984 a->repeatc = A_RIGHTG(save);
6985 } else {
6986 a->repeatc = list->head;
6987 }
6988 a->size = list->tail;
6989 } else if (A_TYPEG(aast) == A_ID && PARAMVALG(A_SPTRG(aast))) {
6990 aa = mk_init(PARAMVALG(A_SPTRG(aast)), dtype);
6991 A_SPTRP(aa, sptr);
6992 add_init(list, aast, dtype, sptr);
6993 } else {
6994 if (DTY(sdtype) == TY_ARRAY) {
6995 aast = dinit_getval1(aast, DTY(sdtype + 1));
6996 } else
6997 aast = dinit_getval1(aast, sdtype);
6998
6999 if (A_TYPEG(SST_ASTG(stkp)) == A_CNST &&
7000 A_DTYPEG(aast) != A_DTYPEG(SST_ASTG(stkp))) {
7001 /* constant initialization value needed type conversion,
7002 * rewrite the ACL instance to use converted value */
7003 a->id = AC_AST;
7004 a->dtype = sdtype;
7005 a->u1.ast = aast;
7006 }
7007 add_init(list, aast, dtype, sptr);
7008 }
7009 }
7010 break;
7011 case AC_IEXPR:
7012 if (POINTERG(sptr)) {
7013 /* maybe this should always be done */
7014 a->sptr = sptr;
7015 }
7016 b = eval_init_expr_item(a);
7017 if (!b) {
7018 return 0;
7019 }
7020 newlist.head = newlist.tail = 0;
7021 if (POINTERG(sptr)) {
7022 /* And, MUST be ST_MEMBER */
7023 b = dinit_fill_struct(&newlist, b, b->dtype, MIDNUMG(sptr), 1,
7024 init_single);
7025 } else {
7026 if (DTY(b->dtype) == TY_ARRAY)
7027 dtype = b->dtype;
7028 else
7029 dtype = sdtype;
7030 b = dinit_fill_struct(&newlist, b, dtype, sptr, 0, init_single);
7031 }
7032 append_init_list(list, &newlist);
7033 break;
7034 case AC_ACONST:
7035 dtype = a->dtype;
7036 if (DTY(dtype) != TY_ARRAY) {
7037 interr("dinit_fill_struct, expecting ARRAY type", dtype, 1);
7038 ddtype = dtype;
7039 } else {
7040 ddtype = DDTG(sdtype);
7041 }
7042 newlist.head = newlist.tail = 0;
7043 b = dinit_fill_struct(&newlist, a->subc, ddtype, sptr, 0, FALSE);
7044 if (list && DTY(sdtype) != TY_ARRAY)
7045 append_init_list(list, &newlist);
7046 else {
7047 if (DTY(ddtype) == TY_DERIVED) {
7048 add_init(list, newlist.head, ddtype, sptr);
7049 } else
7050 add_init(list, newlist.head, dtype, sptr);
7051 }
7052 break;
7053 case AC_SCONST:
7054 dtype = a->dtype;
7055 if (DTY(dtype) != TY_DERIVED) {
7056 interr("dinit_fill_struct, expecting DERIVED type", dtype, 1);
7057 member = 0;
7058 ddtype = 0;
7059 } else {
7060 member = DTY(dtype + 1);
7061 if (member) {
7062 ddtype = DTYPEG(member);
7063 if (no_data_components(ddtype)) {
7064 member = next_member(member);
7065 if (member)
7066 ddtype = DTYPEG(member);
7067 else
7068 ddtype = 0;
7069 }
7070 } else {
7071 ddtype = 0;
7072 }
7073 }
7074 newlist.head = newlist.tail = 0;
7075 b = dinit_fill_struct(&newlist, a->subc, ddtype, member, 1, member != 0);
7076 add_init(list, newlist.head, dtype, sptr);
7077 if (sdtype && dtype != sdtype) {
7078 /* coerce */
7079 interr("initialization coercion needed", sdtype, 1);
7080 }
7081 break;
7082 case AC_IDO:
7083 if (sem.top == &sem.dostack[MAX_DOSTACK]) {
7084 /* nesting maximum exceeded. */
7085 errsev(34);
7086 return NULL;
7087 }
7088 doinfo = a->u1.doinfo;
7089 ++sem.top;
7090 newlist.head = newlist.tail = 0;
7091 idx_sptr = doinfo->index_var;
7092 initval = dinit_eval(doinfo->init_expr);
7093 limitval = dinit_eval(doinfo->limit_expr);
7094 stepval = dinit_eval(doinfo->step_expr);
7095 save_conval1 = CONVAL1G(idx_sptr);
7096 if (stepval >= 0) {
7097 for (i = initval; i <= limitval; i += stepval) {
7098 switch (DTY(DTYPEG(idx_sptr))) {
7099 case TY_INT8:
7100 case TY_LOG8:
7101 ISZ_2_INT64(i, num);
7102 tmpcon = getcon(num, DTYPEG(idx_sptr));
7103 CONVAL1P(idx_sptr, tmpcon);
7104 break;
7105 default:
7106 CONVAL1P(idx_sptr, i);
7107 break;
7108 }
7109 b = dinit_fill_struct(&newlist, a->subc, sdtype, sptr, 0, sptr != 0);
7110 }
7111 } else {
7112 for (i = initval; i >= limitval; i += stepval) {
7113 switch (DTY(DTYPEG(idx_sptr))) {
7114 case TY_INT8:
7115 case TY_LOG8:
7116 ISZ_2_INT64(i, num);
7117 tmpcon = getcon(num, DTYPEG(idx_sptr));
7118 CONVAL1P(idx_sptr, tmpcon);
7119 break;
7120 default:
7121 CONVAL1P(idx_sptr, i);
7122 break;
7123 }
7124 b = dinit_fill_struct(&newlist, a->subc, sdtype, sptr, 0, sptr != 0);
7125 }
7126 }
7127 append_init_list(list, &newlist);
7128 CONVAL1P(idx_sptr, save_conval1);
7129 --sem.top;
7130 break;
7131 case AC_REPEAT:
7132 count = a->u1.count;
7133 while (--count >= 0) {
7134 b = dinit_fill_struct(list, a->subc, sdtype, sptr, 0, sptr != 0);
7135 }
7136 break;
7137 case AC_CONVAL:
7138 if (a->conval == 0) {
7139 aast = a->u1.ast;
7140 } else if (DT_ISWORD(a->dtype)) {
7141 aast = mk_cval1(a->conval, a->dtype);
7142 } else {
7143 aast = mk_cnst(a->conval);
7144 }
7145 dtype = A_DTYPEG(aast);
7146 aast = dinit_getval(aast, sdtype);
7147 add_init(list, aast, dtype, sptr);
7148 break;
7149 }
7150 if (memberlist && sptr) {
7151 /* move 'sptr' along the member list */
7152 if (STYPEG(sptr) != ST_MEMBER) {
7153 interr("dinit_fill_struct, expecing member", sptr, 1);
7154 return a->next;
7155 }
7156 sptr = next_member(sptr);
7157 if (sptr <= NOSYM) {
7158 return a->next;
7159 }
7160 sdtype = DTYPEG(sptr);
7161 } else if (init_single) {
7162 /* initializing a single symbol */
7163 return a->next;
7164 }
7165 }
7166 return NULL;
7167 } /* dinit_fill_struct */
7168
7169 void
dinit_struct_param(SPTR sptr,ACL * sconst,DTYPE dtype)7170 dinit_struct_param(SPTR sptr, ACL *sconst, DTYPE dtype)
7171 {
7172 ASTLIST newlist;
7173 /* set up 'sptr' as having a parameter value */
7174 PARAMP(sptr, 1);
7175 /* put the 'parameter' value in the ASTs */
7176 out_of_elements_message = FALSE;
7177 sem.top = &sem.dostack[0];
7178 newlist.head = newlist.tail = 0;
7179 dinit_fill_struct(&newlist, sconst, dtype, sptr, 0, sptr != 0);
7180 PARAMVALP(sptr, newlist.head);
7181 } /* dinit_struct_param */
7182
7183 /** \brief In DATA statement, do the stuff in dinit_struct_const in two steps.
7184 */
7185 ACL *
dinit_struct_vals(ACL * sconst,DTYPE dtype,SPTR component_sptr)7186 dinit_struct_vals(ACL *sconst, DTYPE dtype, SPTR component_sptr)
7187 {
7188 SST *item_stkp;
7189 int ast;
7190 ACL *aclp;
7191 ACL *ict; /* Initializer Constant Tree */
7192 ACL *last;
7193 ACL *first;
7194 /* need to check for number of entries */
7195 /* allocate and init an Initializer Constant Tree */
7196 int count = 0;
7197 SPTR member_sptr = DTY(dtype + 1);
7198 SPTR sptr = component_sptr != NOSYM ? component_sptr : DTY(dtype + 3);
7199 last = NULL;
7200 for (aclp = sconst->subc; aclp != NULL; aclp = aclp->next) {
7201 if (aclp->id == AC_ACONST) {
7202 ict = aclp;
7203 ict->sptr = member_sptr;
7204 } else if (aclp->id == AC_SCONST) {
7205 ict = dinit_struct_vals(aclp, aclp->dtype, member_sptr);
7206 ict->sptr = member_sptr;
7207 } else if (aclp->id == AC_EXPR && SST_IDG(aclp->u1.stkp) == S_IDENT &&
7208 STYPEG(SST_SYMG(aclp->u1.stkp)) == ST_PD &&
7209 PDNUMG(SST_SYMG(aclp->u1.stkp)) == PD_null) {
7210 ict = SST_ACLG(aclp->u1.stkp);
7211 } else {
7212 item_stkp = aclp->u1.stkp;
7213 ast = item_stkp->ast;
7214 if (!ast || (!A_ALIASG(ast) &&
7215 (A_TYPEG(ast) == A_INTR && A_OPTYPEG(ast) != I_NULL))) {
7216 int errsptr;
7217 errsptr = SST_SYMG(item_stkp);
7218 if (ast == 0 && errsptr) {
7219 error(155, 3, gbl.lineno,
7220 "DATA initialization with nonconstant value -",
7221 SYMNAME(errsptr));
7222 sem.dinit_error = TRUE;
7223 } else {
7224 error(155, 3, gbl.lineno,
7225 "DATA initialization with nonconstant expression", "");
7226 sem.dinit_error = TRUE;
7227 return NULL;
7228 }
7229 ict = NULL;
7230 } else {
7231 ict = GET_ACL(15);
7232 ict->id = AC_AST;
7233 ict->next = NULL;
7234 ict->subc = NULL;
7235 ict->u1.ast = SST_ASTG(item_stkp); /* the data constant */
7236 ict->repeatc = 0; /* no repeat count */
7237 ict->sptr = member_sptr;
7238 ict->dtype = SST_DTYPEG(item_stkp);
7239 }
7240 }
7241 if (ict != NULL) {
7242 if (last == NULL)
7243 first = ict;
7244 else
7245 last->next = ict;
7246 last = ict;
7247 }
7248 if (member_sptr != 0)
7249 member_sptr = SYMLKG(member_sptr);
7250 }
7251 ict = GET_ACL(15);
7252 ict->id = AC_SCONST;
7253 ict->next = NULL;
7254 ict->subc = first;
7255 ict->u1.ast = count;
7256 ict->repeatc = astb.bnd.one; /* repeat count */
7257 ict->sptr = sptr;
7258 ict->dtype = dtype;
7259 return ict;
7260 }
7261
7262 /** \brief Create an initialization node for a variable reference in a data
7263 statement.
7264
7265 If the variable reference is an array section (tpr1652) an implied do is
7266 generated for each subscript which is a triple. For example, the array
7267 section:
7268 <pre>
7269 A(i1, L2:U2, L3:U3, i4)
7270 </pre>
7271 is transformed into:
7272 <pre>
7273 ( ( A(i1, j2, j3, i4) j2 = L2, U2 ), j3 = L3, U3 )
7274 </pre>
7275 Each triple subscript is replaced by an implied do index variable, and
7276 the expressions in the triplet becomes the bounds of the implied do.
7277 Sections are to be initialized in array element order (i.e., column major).
7278 An implied do nest is produced by a left to right scan of the subscripts
7279 (the leftmost triple represents the innermost implied do).
7280
7281 If the variable reference is a member of a whole array, turn the whole
7282 array reference into a subscripted reference where each subscript is
7283 a triple. Then, the subscripted referenced is handled as described
7284 above.
7285
7286 For other variable references, a single initialization node is created.
7287 */
7288 VAR *
dinit_varref(SST * stkp)7289 dinit_varref(SST *stkp)
7290 {
7291 VAR *ivl;
7292 int ast;
7293 ITEM *mhd, *p;
7294 int i;
7295 int ndim;
7296 int subs[MAXDIMS];
7297
7298 mhd = NULL;
7299 for (ast = SST_ASTG(stkp); A_TYPEG(ast) == A_MEM; ast = A_PARENTG(ast)) {
7300 p = (ITEM *)getitem(0, sizeof(ITEM));
7301 p->next = mhd;
7302 p->ast = ast;
7303 mhd = p;
7304 }
7305 if (mhd && A_TYPEG(ast) == A_ID && DTY(A_DTYPEG(ast)) == TY_ARRAY) {
7306 int ss;
7307 ADSC *ad;
7308 ss = A_SPTRG(ast);
7309 ad = AD_DPTR(DTYPEG(ss));
7310 ndim = AD_NUMDIM(ad);
7311 i = 0;
7312 while (i < ndim) {
7313 subs[i] = mk_triple(AD_LWAST(ad, i), AD_UPAST(ad, i), 0);
7314 i++;
7315 }
7316 ast = mk_subscr(ast, subs, ndim, A_DTYPEG(ast));
7317 }
7318 if (A_TYPEG(ast) == A_SUBSCR) {
7319 /*
7320 * the variable reference is subscripted; check if any of the subcripts
7321 * are triples.
7322 */
7323 int asd;
7324 int triple[MAXDIMS];
7325 LOGICAL any_triple;
7326 int newast;
7327
7328 any_triple = FALSE;
7329 asd = A_ASDG(ast);
7330 ndim = ASD_NDIM(asd);
7331 for (i = 0; i < ndim; i++) {
7332 /*
7333 * If a subscript in dimension 'i' (zero-based) is a triple:
7334 * 1. save the ast of the triple in triple[i].
7335 * 2. create an integer variable which will be the implied do
7336 * index in dimension 'i'.
7337 * 3. create the ast of the do variable which will be the
7338 * subscript in dimension 'i' and save in subs[i].
7339 *
7340 * Otherwise, triple[i] is set to 0 (subscript in the dimension
7341 * 'i' is not a triple).
7342 */
7343 subs[i] = ASD_SUBS(asd, i);
7344 if (A_TYPEG(subs[i]) == A_TRIPLE) {
7345 any_triple = TRUE;
7346 triple[i] = subs[i];
7347 subs[i] = mk_id(get_temp(astb.bnd.dtype));
7348 } else
7349 triple[i] = 0;
7350 }
7351 if (any_triple) {
7352 VAR *newivl;
7353 VAR *endl;
7354 /*
7355 * Create a subscripted reference, where the triples are replaced
7356 * by their respective index variables; the other subscripts
7357 * are used as is. This subscripted reference becomes the object
7358 * in a variable reference initialization node.
7359 */
7360 newast = mk_subscr(A_LOPG(ast), subs, ndim, DTY(A_DTYPEG(ast) + 1));
7361 for (p = mhd; p != NULL; p = p->next) {
7362 newast = mk_member(newast, A_MEMG(p->ast), A_DTYPEG(p->ast));
7363 }
7364 ivl = (VAR *)getitem(15, sizeof(VAR));
7365 ivl->id = Varref;
7366 ivl->u.varref.ptr = newast;
7367 ivl->u.varref.id = S_LVALUE;
7368 ivl->u.varref.dtype = A_DTYPEG(newast);
7369 ivl->u.varref.shape = A_SHAPEG(newast);
7370 ivl->u.varref.subt = NULL;
7371 ivl->next = NULL;
7372 if (SCG(SST_LSYMG(stkp)) == SC_BASED) {
7373 error(116, 3, gbl.lineno, SYMNAME(SST_LSYMG(stkp)), "(DATA)");
7374 sem.dinit_error = TRUE;
7375 }
7376 /* keep track of the 'end' (outer) init. node; note that 'ivl'
7377 * represents the current init. node
7378 */
7379 endl = ivl;
7380 for (i = 0; i < ndim; i++) {
7381 if (triple[i]) {
7382 /* build a doend element for the dinit var list */
7383 newivl = (VAR *)getitem(15, sizeof(VAR));
7384 endl->next = newivl; /* current -> Doend */
7385 newivl->id = Doend;
7386 newivl->next = NULL;
7387 endl = newivl; /* end of this do is the Doend */
7388 /*
7389 * Create the dostart element, link it to the doend element,
7390 * and link all in the order dostart -> current node ->
7391 * doend.
7392 */
7393 newivl->u.doend.dostart = (VAR *)getitem(15, sizeof(VAR));
7394 newivl = newivl->u.doend.dostart;
7395 newivl->id = Dostart;
7396 newivl->u.dostart.indvar = subs[i];
7397 newivl->u.dostart.lowbd = A_LBDG(triple[i]);
7398 newivl->u.dostart.upbd = A_UPBDG(triple[i]);
7399 newivl->u.dostart.step = A_STRIDEG(triple[i]);
7400 newivl->next = ivl; /* Dostart -> current */
7401 ivl = newivl; /* Dostart is the new current node */
7402 }
7403 }
7404 SST_VLBEGP(stkp, ivl); /* Dostart of the outermost implied do*/
7405 SST_VLENDP(stkp, endl); /* Doend of the outermost implied do*/
7406 sem.dinit_data = TRUE;
7407 return NULL; /* tell semant that a section was initialized */
7408 }
7409 }
7410 /* build a single element for the dinit var list */
7411 ivl = (VAR *)getitem(15, sizeof(VAR));
7412 ivl->id = Varref;
7413 ivl->u.varref.ptr = SST_ASTG(stkp);
7414 ivl->u.varref.id = SST_IDG(stkp);
7415 ivl->u.varref.dtype = SST_DTYPEG(stkp);
7416 ivl->u.varref.shape = SST_SHAPEG(stkp);
7417 ivl->u.varref.subt = NULL;
7418 ivl->next = NULL;
7419 return ivl;
7420 }
7421
7422 /** \brief Get a compiler temporary of any scalar dtype.
7423 */
7424 SPTR
get_temp(DTYPE dtype)7425 get_temp(DTYPE dtype)
7426 {
7427 SPTR sptr;
7428 DTYPE dt;
7429 #if DEBUG
7430 assert(DT_ISSCALAR(dtype) || DTY(dtype) == TY_DERIVED,
7431 "get_temp:nonscalar dt", dtype, 3);
7432 #endif
7433 if (DTY(dtype) == TY_CHAR || DTY(dtype) == TY_NCHAR)
7434 return get_ch_temp(dtype);
7435
7436 if (!sem.temps_reset) {
7437 BZERO(temps_ctr, char, sizeof(temps_ctr));
7438 sem.temps_reset = TRUE;
7439 }
7440
7441 do {
7442 sptr = getcctmp_sc('i', TEMPS_CTR(0), ST_VAR, dtype, sem.sc);
7443 dt = DTYPEG(sptr);
7444 } while (dt != dtype);
7445
7446 return sptr;
7447 }
7448
7449 DTYPE
get_temp_dtype(DTYPE dtype,int expr)7450 get_temp_dtype(DTYPE dtype, int expr)
7451 {
7452 if (dtype == DT_ASSCHAR || dtype == DT_ASSNCHAR || dtype == DT_DEFERCHAR ||
7453 dtype == DT_DEFERNCHAR) {
7454 int len;
7455 if (A_TYPEG(expr) == A_INTR && A_OPTYPEG(expr) == I_TRIM)
7456 len = ast_intr(I_LEN_TRIM, astb.bnd.dtype, 1, ARGT_ARG(A_ARGSG(expr), 0));
7457 else {
7458 len = ast_intr(I_LEN, astb.bnd.dtype, 1, expr);
7459 }
7460 dtype = get_type(2, DTY(dtype), len);
7461 }
7462 return dtype;
7463 }
7464
7465 SPTR
get_itemp(DTYPE dtype)7466 get_itemp(DTYPE dtype)
7467 {
7468 SPTR sptr = getccsym_sc('i', sem.itemps++, ST_VAR, sem.sc);
7469 DTYPEP(sptr, dtype);
7470 return sptr;
7471 }
7472
7473 static void
allocate_temp(SPTR sptr)7474 allocate_temp(SPTR sptr)
7475 {
7476 DTYPE dtype;
7477 int subs[MAXDIMS], i, n, ast;
7478
7479 add_p_dealloc_item(sptr);
7480
7481 dtype = DTYPEG(sptr);
7482 ast = mk_id(sptr);
7483 /* char length variable? */
7484 if (DTYG(dtype) == TY_CHAR || DTYG(dtype) == TY_NCHAR) {
7485 int cvlen, len, rhs, asn, dty;
7486 dty = DDTG(dtype);
7487 cvlen = CVLENG(sptr);
7488 if (cvlen) {
7489 len = mk_id(cvlen);
7490 rhs = DTY(dty + 1);
7491 rhs = mk_convert(rhs, DTYPEG(cvlen));
7492 rhs = ast_intr(I_MAX, DTYPEG(cvlen), 2, rhs, mk_cval(0, DTYPEG(cvlen)));
7493 asn = mk_assn_stmt(len, rhs, DTYPEG(cvlen));
7494 (void)add_stmt(asn);
7495 }
7496 }
7497 if (DTY(dtype) == TY_ARRAY) {
7498 ADD_DEFER(dtype) = 1;
7499 /* insert allocate statement */
7500 n = ADD_NUMDIM(dtype);
7501 for (i = 0; i < n; ++i) {
7502 subs[i] = mk_triple(ADD_LWBD(dtype, i), ADD_UPBD(dtype, i), 0);
7503 }
7504 ast = mk_subscr(ast, subs, n, dtype);
7505 }
7506 gen_alloc_dealloc(TK_ALLOCATE, ast, 0);
7507 } /* allocate_temp */
7508
7509 /** \brief Get a compiler array temporary of type dtype.
7510 */
7511 SPTR
get_arr_temp(DTYPE dtype,LOGICAL nodesc,LOGICAL alloc_deferred,LOGICAL constructor)7512 get_arr_temp(DTYPE dtype, LOGICAL nodesc, LOGICAL alloc_deferred,
7513 LOGICAL constructor)
7514 {
7515 SPTR sptr;
7516 int needalloc;
7517 SC_KIND sc = sem.sc;
7518 DTYPE dt = DTY(dtype + 1);
7519
7520 if (DTY(dt) == TY_CHAR || DTY(dt) == TY_NCHAR)
7521 return get_ch_temp(dtype);
7522 if (!sem.temps_reset) {
7523 BZERO(temps_ctr, char, sizeof(temps_ctr));
7524 sem.temps_reset = TRUE;
7525 }
7526
7527 /*
7528 * Examine dtype to determine if an allocatable temp is needed:
7529 * o has deferred shape, or
7530 * o the size is not constant.
7531 *
7532 * If an allocatable temp is needed, its storage class is always
7533 * SC_LOCAL or SC_PRIVATE.
7534 */
7535 needalloc = 0;
7536 if (ADD_DEFER(dtype)) {
7537 needalloc = 1;
7538 } else {
7539 int d;
7540 /* if the size is not constant, mark it as adjustable */
7541 for (d = 0; d < ADD_NUMDIM(dtype); ++d) {
7542 int lb, ub;
7543 lb = ADD_LWBD(dtype, d);
7544 if (lb && A_ALIASG(lb) == 0) {
7545 needalloc = 1;
7546 break;
7547 }
7548 ub = ADD_UPBD(dtype, d);
7549 if (ub && A_ALIASG(ub) == 0) {
7550 needalloc = 1;
7551 break;
7552 }
7553 }
7554 }
7555 if (needalloc && sc != SC_PRIVATE)
7556 sc = SC_LOCAL;
7557
7558 do {
7559 int tmpc;
7560 if (!needalloc)
7561 tmpc = TEMPS_CTR(1);
7562 else
7563 tmpc = TEMPS_STK(1);
7564 if (constructor)
7565 /* Creating a temporary for an array constructor within an OpenACC region.
7566 * Mark this by using letter 'x' in the name of the temporary so that it
7567 * can be identified by the accelerator backend.
7568 * Caution: Any change to this naming scheme must also be reflected in
7569 * routine add_implicit_private in accel.c.
7570 */
7571 sptr = getcctmp_sc('x', tmpc, ST_ARRAY, dtype, sc);
7572 else
7573 sptr = getcctmp_sc('a', tmpc, ST_ARRAY, dtype, sc);
7574 dt = DTYPEG(sptr);
7575 if (DTY(dt + 1) == DTY(dtype + 1) && ADD_DEFER(dtype) == ADD_DEFER(dt) &&
7576 nodesc == NODESCG(sptr) && conformable(dt, dtype))
7577 break;
7578 } while (dt != dtype);
7579
7580 if (needalloc) {
7581 ALLOCP(sptr, 1);
7582 if (!alloc_deferred && ADD_DEFER(dtype)) {
7583 /* if deferred shape, temp will be treated as allocatable */
7584 ;
7585 } else if (ALLOCATE_ARRAYS) {
7586 int d;
7587 /* if the size is not constant, allocate it, but
7588 * first ensure that each dimension has a lower bound.
7589 */
7590 for (d = 0; d < ADD_NUMDIM(dtype); ++d) {
7591 if (ADD_LWBD(dtype, d) == 0)
7592 ADD_LWBD(dtype, d) = astb.bnd.one;
7593 }
7594 allocate_temp(sptr);
7595 }
7596 }
7597 NODESCP(sptr, nodesc);
7598 return sptr;
7599 }
7600
7601 /** \brief Get a compiler-created allocatable array temp to represent the
7602 result of run-time function computing the adjustl/adjustr intrinsic.
7603
7604 The result of the run-time is the length (which we don't actually use), but
7605 it's needed to effect array/forall processing in the compiler. Eventually,
7606 in outconv.c, the temp is discarded, as well as the return value of the
7607 runtime routine.
7608 */
7609 SPTR
get_adjlr_arr_temp(DTYPE dtype)7610 get_adjlr_arr_temp(DTYPE dtype)
7611 {
7612 SPTR sptr;
7613 ALLOCATE_ARRAYS = 0; /* no need to generate an allocate of the temp*/
7614 sptr = get_arr_temp(dtype, TRUE, FALSE, FALSE);
7615 ALLOCATE_ARRAYS = 1;
7616 return sptr;
7617 }
7618
7619 /** \brief Get a compiler array temporary of from a shape of an ast.
7620 */
7621 SPTR
get_shape_arr_temp(int arg)7622 get_shape_arr_temp(int arg)
7623 {
7624 int shape = A_SHAPEG(arg);
7625 DTYPE dtype = get_shape_arraydtype(shape, DTY(A_DTYPEG(arg) + 1));
7626 SPTR tmp = get_arr_temp(dtype, FALSE, FALSE, FALSE);
7627 if (sem.arrdim.ndefer)
7628 gen_allocate_array(tmp);
7629 return tmp;
7630 }
7631
7632 /** \brief Get a character compiler temporary of type dtype.
7633 */
7634 SPTR
get_ch_temp(DTYPE dtype)7635 get_ch_temp(DTYPE dtype)
7636 {
7637 SPTR sptr;
7638 DTYPE dt;
7639 SYMTYPE stype;
7640 int len;
7641 bool needalloc = false;
7642 SC_KIND sc = sem.sc;
7643
7644 if (!sem.temps_reset) {
7645 BZERO(temps_ctr, char, sizeof(temps_ctr));
7646 sem.temps_reset = TRUE;
7647 }
7648
7649 /*
7650 * Examine dtype to determine if an allocatable temp is needed:
7651 * o the length is not a constant, or
7652 * o if array, the size is not constant.
7653 *
7654 * If an allocatable temp is needed, its storage class is always
7655 * SC_LOCAL.
7656 */
7657 dt = DDTG(dtype);
7658 /* This is pretty bogus, _INF_CLEN for temps, ugh. */
7659 if (dt == DT_ASSCHAR || dt == DT_DEFERCHAR) {
7660 dt = get_type(2, TY_CHAR, mk_cval(_INF_CLEN, DT_INT4));
7661 error(310, 2, gbl.lineno,
7662 "Unsafe fixed-length string temporary*500 being used", CNULL);
7663 } else if (dt == DT_ASSNCHAR || dt == DT_DEFERNCHAR) {
7664 dt = get_type(2, TY_NCHAR, mk_cval(_INF_CLEN, DT_INT4));
7665 error(310, 2, gbl.lineno,
7666 "Unsafe fixed-length string temporary*500 being used", CNULL);
7667 }
7668
7669 /* if the length is not a constant, make it 'adjustable' */
7670 len = DTY(dt + 1);
7671 if (A_ALIASG(len) == 0) {
7672 /* will fill in CVLEN field */
7673 needalloc = true;
7674 }
7675 stype = ST_VAR;
7676 if (DTY(dtype) == TY_ARRAY) {
7677 int d;
7678 /* if the size is not constant, mark it as adjustable */
7679 stype = ST_ARRAY;
7680 for (d = 0; d < ADD_NUMDIM(dtype); ++d) {
7681 int lb, ub;
7682 lb = ADD_LWBD(dtype, d);
7683 if (lb && A_ALIASG(lb) == 0) {
7684 needalloc = true;
7685 break;
7686 }
7687 ub = ADD_UPBD(dtype, d);
7688 if (ub && A_ALIASG(ub) == 0) {
7689 needalloc = true;
7690 break;
7691 }
7692 }
7693 }
7694 if (needalloc)
7695 sc = SC_LOCAL;
7696
7697 do {
7698 int tmpc;
7699 if (!needalloc)
7700 tmpc = TEMPS_CTR(1);
7701 else
7702 tmpc = TEMPS_STK(1);
7703 sptr = getcctmp_sc('s', tmpc, stype, dtype, sc);
7704 dt = DTYPEG(sptr);
7705 } while (dt != dtype);
7706
7707 if (needalloc) {
7708 int clen;
7709 ALLOCP(sptr, 1);
7710 /* if the length is not a constant, make it 'adjustable' */
7711 if (sem.gcvlen && is_deferlenchar_dtype(dtype)) {
7712 clen = ast_intr(I_LEN, astb.bnd.dtype, 1, mk_id(sptr));
7713 } else if (A_ALIASG(len) == 0) {
7714 /* fill in CVLEN field */
7715 ADJLENP(sptr, 1);
7716 if (CVLENG(sptr) == 0) {
7717 clen = sym_get_scalar(SYMNAME(sptr), "len", astb.bnd.dtype);
7718 CVLENP(sptr, clen);
7719 if (SCG(sptr) == SC_DUMMY)
7720 CCSYMP(clen, 1);
7721 }
7722 }
7723 if (DTY(dtype) == TY_ARRAY) {
7724 if (ALLOCATE_ARRAYS) {
7725 int d;
7726 /* if the size is not constant, allocate it, but need to
7727 * first ensure that each dimension has a lower bound.
7728 */
7729 for (d = 0; d < ADD_NUMDIM(dtype); ++d) {
7730 if (ADD_LWBD(dtype, d) == 0)
7731 ADD_LWBD(dtype, d) = astb.bnd.one;
7732 }
7733 if (!sem.arrdim.ndefer || ADJLENG(sptr))
7734 allocate_temp(sptr);
7735 }
7736 } else {
7737 allocate_temp(sptr);
7738 }
7739 }
7740 return sptr;
7741 }
7742
7743 int
need_alloc_ch_temp(DTYPE dtype)7744 need_alloc_ch_temp(DTYPE dtype)
7745 {
7746 if (sem.use_etmps) {
7747 /*
7748 * if the dtype warrants an allocatable temp, need to add a fake
7749 * etmp entry so that its expression context, such as a relational
7750 * expression, is fully evaluated and assigned to a temp.
7751 */
7752 if (dtype == DT_ASSCHAR || dtype == DT_ASSNCHAR || dtype == DT_DEFERCHAR ||
7753 dtype == DT_DEFERNCHAR || !A_ALIASG(DTY(dtype + 1))) {
7754 add_etmp(0);
7755 return 1;
7756 }
7757 }
7758 return 0;
7759 }
7760
7761 /** \brief Compare \a str and \a pattern like strcmp() but ignoring the case of
7762 str.
7763 \a pattern is all lower case.
7764 */
7765 int
sem_strcmp(char * str,char * pattern)7766 sem_strcmp(char *str, char *pattern)
7767 {
7768 char *p1, *p2;
7769 int ch;
7770
7771 p1 = str;
7772 p2 = pattern;
7773 do {
7774 ch = *p1;
7775 if (ch >= 'A' && ch <= 'Z')
7776 ch += ('a' - 'A'); /* to lower case */
7777 if (ch != *p2)
7778 return (ch - *p2);
7779 if (ch == '\0')
7780 return 0;
7781 p1++;
7782 p2++;
7783 } while (1);
7784 }
7785
7786 /** \brief Return TRUE if fortran character constant is equal to pattern
7787 (pattern is always uppercase).
7788 */
7789 LOGICAL
sem_eq_str(int con,char * pattern)7790 sem_eq_str(int con, char *pattern)
7791 {
7792 char *p1, *p2;
7793 int len;
7794 int c1, c2;
7795
7796 p1 = stb.n_base + CONVAL1G(con);
7797 p2 = pattern;
7798 for (len = string_length(DTYPEG(con)); len > 0; len--) {
7799 c1 = *p1;
7800 if (c1 >= 'a' && c1 <= 'z') /* convert to upper case */
7801 c1 = c1 + ('A' - 'a');
7802 c2 = *p2;
7803 if (c2 == '\0' || c1 != c2)
7804 break;
7805 p1++;
7806 p2++;
7807 }
7808
7809 if (len == 0)
7810 return TRUE;
7811
7812 /* verify that remaining characters of con are blank: */
7813 while (len--)
7814 if (*p1++ != ' ')
7815 return FALSE;
7816 return TRUE;
7817 }
7818
7819 /** \brief Allocate a temporary, assign it the value, and return the assignment
7820 * ast.
7821 */
7822 int
sem_tempify(SST * stkptr)7823 sem_tempify(SST *stkptr)
7824 {
7825 int argtyp;
7826 SST tmpsst;
7827 int tmpsym;
7828 int assn;
7829 argtyp = SST_DTYPEG(stkptr);
7830 argtyp = get_temp_dtype(argtyp, SST_ASTG(stkptr));
7831 if (DTY(argtyp) != TY_ARRAY) {
7832 tmpsym = get_temp(argtyp);
7833 } else {
7834 tmpsym = get_arr_temp(argtyp, FALSE, A_SHAPEG(SST_ASTG(stkptr)), FALSE);
7835 }
7836 mkident(&tmpsst);
7837 SST_SYMP(&tmpsst, tmpsym);
7838 SST_DTYPEP(&tmpsst, argtyp);
7839 assn = assign(&tmpsst, stkptr);
7840 return assn;
7841 }
7842
7843 /** \brief Update the SWEL list for a `SELECTCASE` construct represented by
7844 the \a doif structure.
7845
7846 A new SWEL item is created for a case value or a range of case
7847 values denoted by the arguments \a lc and \a uc. The order of the items in
7848 the list will correspond to the case values in ascending order.
7849
7850 Kind of case | lc | uc
7851 ---------------|--------|------
7852 case (:c) | c | -1
7853 case (c) | c | 0 (c is a sym pointer)
7854 case (c:) | c | 1
7855 case (c:d) | c | d (c and d are sym pointers)
7856 */
7857 void
add_case_range(int doif,int lc,int uc)7858 add_case_range(int doif, int lc, int uc)
7859 {
7860 SWEL *swel;
7861 int ni;
7862 int bef;
7863 int i;
7864 int (*p_cmp)(int, int);
7865
7866 ni = sem.switch_avl++; /* relative ptr to new SWEL item */
7867 NEED(sem.switch_avl, switch_base, SWEL, sem.switch_size,
7868 sem.switch_size + 300);
7869
7870 /* The first SWEL item's next field locates the head of the list */
7871 bef = DI_SWEL_HD(doif);
7872 if (DT_ISLOG(DI_DTYPE(doif))) {
7873 for (i = switch_base[bef].next; i != 0; i = switch_base[i].next) {
7874 if (switch_base[i].val == lc)
7875 goto dup_error;
7876 }
7877 switch_base[ni].val = lc;
7878 switch_base[ni].next = switch_base[bef].next;
7879 switch_base[bef].next = ni;
7880 return;
7881 }
7882 if (DI_DTYPE(doif) == DT_INT8)
7883 p_cmp = _i8_cmp;
7884 else if (DT_ISINT(DI_DTYPE(doif)))
7885 p_cmp = _i4_cmp;
7886 else {
7887 /* character */
7888 if (DTY(DI_DTYPE(doif)) == TY_NCHAR)
7889 p_cmp = _nchar_cmp;
7890 else
7891 p_cmp = _char_cmp;
7892 }
7893
7894 for (i = switch_base[bef].next; i != 0; i = switch_base[i].next) {
7895 swel = switch_base + i;
7896 if ((*p_cmp)(lc, swel->val) < 0) {
7897 /* lc < current case value 'val' */
7898 if (swel->uval == -1)
7899 /* (lc) in (:val) */
7900 goto range_error;
7901 if (uc == 1)
7902 /* (lc :) in (val ...) */
7903 goto range_error;
7904 if (uc > 1 && (*p_cmp)(uc, swel->val) >= 0)
7905 /* (lc:uc), lc < val, uc >= val */
7906 goto range_error;
7907 break;
7908 }
7909 if ((*p_cmp)(lc, swel->val) == 0) {
7910 /* lc == current case value */
7911 if (uc == 0 && swel->uval == 0)
7912 goto dup_error;
7913 goto range_error;
7914 }
7915
7916 /* lc > current case value */
7917 if (uc == -1)
7918 /* lc > val, (:lc) specified */
7919 goto range_error;
7920 if (swel->uval == 1)
7921 /* lc in (val:) */
7922 goto range_error;
7923 if (swel->uval > 1) {
7924 if ((*p_cmp)(lc, swel->uval) <= 0)
7925 /* lc in (val:uval) */
7926 goto range_error;
7927 }
7928 bef = i;
7929 }
7930
7931 /* insert new swel item into list */
7932 switch_base[ni].val = lc;
7933 switch_base[ni].uval = uc;
7934 switch_base[ni].next = switch_base[bef].next;
7935 switch_base[bef].next = ni;
7936 return;
7937
7938 dup_error:
7939 error(310, 3, gbl.lineno, "Duplicate case value", CNULL);
7940 sem.switch_avl--;
7941 return;
7942
7943 range_error:
7944 error(310, 3, gbl.lineno, "Overlapping case value", CNULL);
7945 sem.switch_avl--;
7946 }
7947
7948 /** \brief Compare functions whose arguments are pointers to ST_CONST
7949 symbol table entries.
7950 \return a number less than, equal to, or greater than 0, depending on the
7951 comparison
7952 */
7953 int
_i4_cmp(int l,int r)7954 _i4_cmp(int l, int r)
7955 {
7956 INT v1, v2;
7957
7958 v1 = CONVAL2G(l);
7959 v2 = CONVAL2G(r);
7960 if (v1 < v2)
7961 return -1;
7962 if (v1 == v2)
7963 return 0;
7964 return 1;
7965 }
7966
7967 int
_i8_cmp(int l,int r)7968 _i8_cmp(int l, int r)
7969 {
7970 DBLINT64 v1, v2;
7971
7972 v1[0] = CONVAL1G(l);
7973 v1[1] = CONVAL2G(l);
7974 v2[0] = CONVAL1G(r);
7975 v2[1] = CONVAL2G(r);
7976 return cmp64(v1, v2);
7977 }
7978
7979 int
_char_cmp(int l,int r)7980 _char_cmp(int l, int r)
7981 {
7982 char *v1, *v2;
7983
7984 v1 = stb.n_base + CONVAL1G(l);
7985 v2 = stb.n_base + CONVAL1G(r);
7986 return strcmp(v1, v2);
7987 }
7988
7989 int
_nchar_cmp(int l,int r)7990 _nchar_cmp(int l, int r)
7991 {
7992 #define KANJI_BLANK 0xA1A1
7993 int bytes, val1, val2;
7994 int cvlen1, cvlen2;
7995 char *p, *q;
7996
7997 cvlen1 = string_length(DTYPEG(l));
7998 cvlen2 = string_length(DTYPEG(r));
7999 p = stb.n_base + CONVAL1G(l);
8000 q = stb.n_base + CONVAL1G(r);
8001
8002 while (cvlen1 > 0 && cvlen2 > 0) {
8003 val1 = kanji_char((unsigned char *)p, cvlen1, &bytes);
8004 p += bytes, cvlen1 -= bytes;
8005 val2 = kanji_char((unsigned char *)q, cvlen2, &bytes);
8006 q += bytes, cvlen2 -= bytes;
8007 if (val1 != val2)
8008 return (val1 - val2);
8009 }
8010
8011 while (cvlen1 > 0) {
8012 val1 = kanji_char((unsigned char *)p, cvlen1, &bytes);
8013 p += bytes, cvlen1 -= bytes;
8014 if (val1 != KANJI_BLANK)
8015 return (val1 - KANJI_BLANK);
8016 }
8017
8018 while (cvlen2 > 0) {
8019 val2 = kanji_char((unsigned char *)q, cvlen2, &bytes);
8020 q += bytes, cvlen2 -= bytes;
8021 if (val2 != KANJI_BLANK)
8022 return (KANJI_BLANK - val2);
8023 }
8024 return 0;
8025 }
8026
8027 /** \brief Check if we are currently in a block FORALL scope;
8028 if so, issue an error message.
8029 */
8030 LOGICAL
not_in_forall(char * stmttype)8031 not_in_forall(char *stmttype)
8032 {
8033 if (sem.doif_depth > 0 && DI_ID(sem.doif_depth) == DI_FORALL) {
8034 error(441, 3, gbl.lineno, stmttype, CNULL);
8035 return TRUE;
8036 }
8037 return FALSE;
8038 } /* not_in_forall */
8039
8040 /** \brief If we are accepting cuda syntax return TRUE.
8041 Otherwise issue an error message and return FALSE.
8042 */
8043 LOGICAL
cuda_enabled(char * at_or_near)8044 cuda_enabled(char *at_or_near)
8045 {
8046 error(34, 3, gbl.lineno, at_or_near, CNULL);
8047 return FALSE;
8048 } /* cuda_enabled */
8049
8050 LOGICAL
in_device_code(int sptr)8051 in_device_code(int sptr)
8052 {
8053 return FALSE;
8054 }
8055
8056 static void
add_to_list(ACL * val,ACL ** root)8057 add_to_list(ACL *val, ACL **root)
8058 {
8059 ACL *tail;
8060 if (*root) {
8061 for (tail = *root; tail->next; tail = tail->next)
8062 ;
8063 tail->next = val;
8064 } else {
8065 *root = val;
8066 }
8067 }
8068
8069 static ACL *
clone_init_const(ACL * original,int temp)8070 clone_init_const(ACL *original, int temp)
8071 {
8072 ACL *clone;
8073
8074 if (!original)
8075 return NULL;
8076 clone = GET_ACL(15);
8077 *clone = *original;
8078 if (clone->subc) {
8079 clone_init_const_list(clone->subc, temp);
8080 }
8081 if (clone->id == AC_IEXPR) {
8082 if (clone->u1.expr->lop) {
8083 clone_init_const_list(clone->u1.expr->lop, temp);
8084 }
8085 if (clone->u1.expr->rop) {
8086 clone_init_const_list(clone->u1.expr->rop, temp);
8087 }
8088 }
8089 clone->next = NULL;
8090 return clone;
8091 }
8092
8093 static ACL *
clone_init_const_list(ACL * original,int temp)8094 clone_init_const_list(ACL *original, int temp)
8095 {
8096 ACL *clone;
8097
8098 clone = clone_init_const(original, temp);
8099 for (original = original->next; original; original = original->next) {
8100 add_to_list(clone_init_const(original, temp), &clone);
8101 }
8102 return clone;
8103 }
8104
8105 static INT
get_int_from_init_conval(ACL * aclp)8106 get_int_from_init_conval(ACL *aclp)
8107 {
8108 INT ret;
8109
8110 if (DT_ISWORD(aclp->dtype)) {
8111 ret = aclp->conval;
8112 } else {
8113 ret = CONVAL2G(aclp->conval);
8114 }
8115 return ret;
8116 }
8117
8118 /* Intrinsic evaluation routines for data initialization
8119 * Stolen from semfunc.c and hacked to generate ACL initialization values.
8120 */
8121 static ACL *
eval_ishft(ACL * arg,DTYPE dtype)8122 eval_ishft(ACL *arg, DTYPE dtype)
8123 {
8124 ACL *rslt;
8125 ACL *wrkarg;
8126 ACL *arg2;
8127 INT val;
8128 INT conval;
8129 INT res[4];
8130 INT shftval;
8131
8132 arg = eval_init_expr(arg);
8133 rslt = clone_init_const(arg, TRUE);
8134 wrkarg = (rslt->id == AC_ACONST ? rslt->subc : rslt);
8135 arg2 = arg->next;
8136 shftval = get_int_from_init_conval(arg2);
8137 if (shftval > bits_in(wrkarg->dtype)) {
8138 error(4, 3, gbl.lineno, "ISHFT SHIFT argument too big for I argument\n",
8139 NULL);
8140 return 0;
8141 }
8142
8143 for (; wrkarg; wrkarg = wrkarg->next) {
8144 val = get_int_from_init_conval(wrkarg);
8145 switch (size_of(wrkarg->dtype)) {
8146 case 2:
8147 val = get_int_from_init_conval(wrkarg);
8148 if (shftval >= 0) {
8149 if (shftval >= 16)
8150 conval = 0;
8151 else {
8152 conval = ULSHIFT(val, shftval);
8153 conval = ULSHIFT(conval, 16);
8154 conval = ARSHIFT(conval, 16);
8155 }
8156 } else {
8157 if (shftval <= -16)
8158 conval = 0;
8159 else {
8160 val &= 0xffff;
8161 conval = URSHIFT(val, -shftval);
8162 }
8163 }
8164 conval = cngcon(conval, DT_WORD, DDTG(dtype));
8165 break;
8166 case 4:
8167 /*
8168 * because this ilm is used for the ISHFT intrinsic, count
8169 * is defined for values -32 to 32; some hw (i.e., n10) shifts
8170 * by cnt mod 32.
8171 */
8172 val = get_int_from_init_conval(wrkarg);
8173 if (shftval >= 0) {
8174 if (shftval >= 32)
8175 conval = 0;
8176 else
8177 conval = ULSHIFT(val, shftval);
8178 } else {
8179 if (shftval <= -32)
8180 conval = 0;
8181 else
8182 conval = URSHIFT(val, -shftval);
8183 }
8184 conval = cngcon(conval, DT_WORD, DDTG(dtype));
8185
8186 break;
8187 case 8:
8188 /* val and shftval are symbol pointers */
8189 /* get the value for shftval */
8190 res[0] = CONVAL1G(wrkarg->conval);
8191 res[1] = CONVAL2G(wrkarg->conval);
8192 if (shftval >= 0) {
8193 if (shftval >= 64) {
8194 res[0] = 0;
8195 res[1] = 0;
8196 } else if (shftval >= 32) {
8197 /* shift val by 32 bits or more */
8198 res[0] = ULSHIFT(res[1], shftval - 32);
8199 res[1] = 0;
8200 } else {
8201 /* shift by less than 32 bits; shift high-order
8202 * bits of low-order word into high-order word */
8203 res[0] = ULSHIFT(res[0], shftval) | URSHIFT(res[1], 32 - shftval);
8204 res[1] = ULSHIFT(res[1], shftval);
8205 }
8206 } else {
8207 shftval = -shftval;
8208 if (shftval >= 64) {
8209 res[0] = 0;
8210 res[1] = 0;
8211 } else if (shftval >= 32) {
8212 /* shift val by 32 bits or more */
8213 res[1] = URSHIFT(res[0], shftval - 32);
8214 res[0] = 0;
8215 } else {
8216 /* shift by less than 32 bits; shift low-order
8217 * bits of high-order word into low-order word */
8218 res[1] = URSHIFT(res[1], shftval) | ULSHIFT(res[0], 32 - shftval);
8219 res[0] = URSHIFT(res[0], shftval);
8220 }
8221 }
8222 conval = getcon(res, DT_INT8);
8223
8224 break;
8225 }
8226 wrkarg->id = AC_CONVAL;
8227 wrkarg->conval = conval;
8228 wrkarg->dtype = dtype;
8229 }
8230
8231 return rslt;
8232 }
8233
8234 #define INTINTRIN2(iname, ent, op) \
8235 static ACL *ent(ACL *arg, DTYPE dtype) \
8236 { \
8237 ACL *arg1 = eval_init_expr_item(arg); \
8238 ACL *arg2 = eval_init_expr_item(arg->next); \
8239 ACL *rslt = clone_init_const(arg1, TRUE); \
8240 arg1 = rslt->id == AC_ACONST ? rslt->subc : rslt; \
8241 arg2 = arg2->id == AC_ACONST ? arg2->subc : arg2; \
8242 for (; arg1; arg1 = arg1->next, arg2 = arg2->next) { \
8243 int con1 = arg1->conval; \
8244 int con2 = arg2->conval; \
8245 int num1[2], num2[2], res[2], conval; \
8246 if (DT_ISWORD(arg1->dtype)) { \
8247 num1[0] = 0, num1[1] = con1; \
8248 } else { \
8249 num1[0] = CONVAL1G(con1), num1[1] = CONVAL2G(con1); \
8250 } \
8251 if (DT_ISWORD(arg2->dtype)) { \
8252 num2[0] = 0, num2[1] = con2; \
8253 } else { \
8254 num2[0] = CONVAL1G(con2), num2[1] = CONVAL2G(con2); \
8255 } \
8256 res[0] = num1[0] op num2[0]; \
8257 res[1] = num1[1] op num2[1]; \
8258 conval = DT_ISWORD(dtype) ? res[1] : getcon(res, DT_INT8); \
8259 arg1->conval = conval; \
8260 arg1->dtype = dtype; \
8261 } \
8262 return rslt; \
8263 }
8264
8265 INTINTRIN2("iand", eval_iand, &)
8266 INTINTRIN2("ior", eval_ior, |)
8267 INTINTRIN2("ieor", eval_ieor, ^)
8268
8269 static ACL *
eval_ichar(ACL * arg,DTYPE dtype)8270 eval_ichar(ACL *arg, DTYPE dtype)
8271 {
8272 ACL *rslt;
8273 ACL *wrkarg;
8274 int srcdty;
8275 int rsltdtype = DDTG(dtype);
8276 int clen;
8277 INT c;
8278 int dum;
8279
8280 rslt = arg = eval_init_expr(arg);
8281 wrkarg = (rslt->id == AC_ACONST ? rslt->subc : rslt);
8282 srcdty = DTY(wrkarg->dtype);
8283 for (; wrkarg; wrkarg = wrkarg->next) {
8284 if (srcdty == TY_NCHAR) {
8285 c = CONVAL1G(wrkarg->conval);
8286 clen = size_of(DTYPEG(c));
8287 c = kanji_char((unsigned char *)stb.n_base + CONVAL1G(c), clen, &dum);
8288 } else {
8289 c = stb.n_base[CONVAL1G(wrkarg->conval)] & 0xff;
8290 }
8291 if (DTY(rsltdtype) == TY_INT8) {
8292 INT res[4];
8293 INT conval;
8294 res[0] = 0;
8295 res[1] = c;
8296 conval = getcon(res, DT_INT8);
8297 dtype = DT_INT8;
8298 wrkarg->conval = A_SPTRG(mk_cval1(conval, dtype));
8299 } else {
8300 wrkarg->conval = c;
8301 }
8302 wrkarg->id = AC_CONVAL;
8303 wrkarg->dtype = rsltdtype;
8304 }
8305 if (rslt->id == AC_ACONST) {
8306 rslt->dtype = dup_array_dtype(arg->dtype);
8307 DTY(rslt->dtype + 1) = dtype;
8308 } else
8309 rslt->dtype = dtype;
8310 return rslt;
8311 }
8312
8313 static ACL *
eval_char(ACL * arg,DTYPE dtype)8314 eval_char(ACL *arg, DTYPE dtype)
8315 {
8316 ACL *rslt;
8317 ACL *wrkarg;
8318 char c;
8319 int sptr;
8320
8321 rslt = arg = eval_init_expr(arg);
8322 wrkarg = (rslt->id == AC_ACONST ? rslt->subc : rslt);
8323 for (; wrkarg; wrkarg = wrkarg->next) {
8324 c = get_int_from_init_conval(wrkarg);
8325 sptr = getstring(&c, 1);
8326 wrkarg->dtype = dtype;
8327 wrkarg->conval = sptr;
8328 wrkarg->u1.ast = mk_cnst(sptr);
8329 }
8330 return rslt;
8331 }
8332
8333 static ACL *
eval_int(ACL * arg,DTYPE dtype)8334 eval_int(ACL *arg, DTYPE dtype)
8335 {
8336 ACL *rslt;
8337 ACL *wrkarg;
8338
8339 rslt = arg = eval_init_expr(arg);
8340 wrkarg = (rslt->id == AC_ACONST ? rslt->subc : rslt);
8341 for (; wrkarg; wrkarg = wrkarg->next) {
8342 wrkarg->conval = cngcon(wrkarg->conval, wrkarg->dtype, DDTG(dtype));
8343 wrkarg->dtype = dtype;
8344 }
8345 return rslt;
8346 }
8347
8348 static ACL *
eval_fltconvert(ACL * arg,DTYPE dtype)8349 eval_fltconvert(ACL *arg, DTYPE dtype)
8350 {
8351 ACL *rslt;
8352 ACL *wrkarg;
8353 int rsltdtype = DDTG(dtype);
8354
8355 rslt = arg = eval_init_expr(arg);
8356 wrkarg = (rslt->id == AC_ACONST ? rslt->subc : rslt);
8357 for (; wrkarg; wrkarg = wrkarg->next) {
8358 wrkarg->conval = cngcon(wrkarg->conval, wrkarg->dtype, rsltdtype);
8359 wrkarg->dtype = rsltdtype;
8360 }
8361 return rslt;
8362 }
8363
8364 #define GET_DBLE(x, y) \
8365 x[0] = CONVAL1G(y); \
8366 x[1] = CONVAL2G(y)
8367 #define GET_QUAD(x, y) \
8368 x[0] = CONVAL1G(y); \
8369 x[1] = CONVAL2G(y); \
8370 x[2] = CONVAL3G(y); \
8371 x[3] = CONVAL4G(y);
8372 #define GETVALI64(x, b) \
8373 x[0] = CONVAL1G(b); \
8374 x[1] = CONVAL2G(b);
8375
8376 static ACL *
eval_abs(ACL * arg,DTYPE dtype)8377 eval_abs(ACL *arg, DTYPE dtype)
8378 {
8379 ACL *rslt;
8380 ACL *wrkarg;
8381 INT con1, res[4], num1[4], num2[4];
8382 DTYPE rsltdtype = dtype;
8383 float f1, f2;
8384
8385 rslt = arg = eval_init_expr(arg);
8386 wrkarg = (rslt->id == AC_ACONST ? rslt->subc : rslt);
8387 for (; wrkarg; wrkarg = wrkarg->next) {
8388 switch (DTY(wrkarg->dtype)) {
8389 case TY_SINT:
8390 case TY_BINT:
8391 case TY_INT:
8392 con1 = wrkarg->conval;
8393 con1 = con1 >= 0 ? con1 : -con1;
8394 break;
8395 case TY_INT8:
8396 con1 = wrkarg->conval; /* sptr */
8397 GETVALI64(num1, con1);
8398 GETVALI64(num2, stb.k0);
8399 if (cmp64(num1, num2) == -1) {
8400 neg64(num1, res);
8401 con1 = getcon(res, DT_INT8);
8402 }
8403 break;
8404 case TY_REAL:
8405 con1 = wrkarg->conval;
8406 res[0] = 0;
8407 xfabsv(con1, &res[1]);
8408 con1 = res[1];
8409 break;
8410 case TY_DBLE:
8411 con1 = wrkarg->conval;
8412 GET_DBLE(num1, con1);
8413 xdabsv(num1, res);
8414 con1 = getcon(res, dtype);
8415 break;
8416 case TY_CMPLX:
8417 con1 = wrkarg->conval;
8418 f1 = CONVAL1G(con1);
8419 f2 = CONVAL2G(con1);
8420 f1 = f1 * f1;
8421 f2 = f2 * f2;
8422 f2 = f1 + f2;
8423 xfsqrt(f2, &con1);
8424 dtype = rsltdtype = DT_REAL;
8425 wrkarg->dtype = dtype;
8426 break;
8427 case TY_DCMPLX:
8428 con1 = wrkarg->conval;
8429 rsltdtype = DT_REAL;
8430 break;
8431 default:
8432 con1 = wrkarg->conval;
8433 break;
8434 }
8435
8436 wrkarg->conval = cngcon(con1, wrkarg->dtype, rsltdtype);
8437 wrkarg->dtype = dtype;
8438 }
8439 return rslt;
8440 }
8441
8442 /* scale(X, I) = X * 2 **I, X is real type, I is an integer */
8443 static ACL *
eval_scale(ACL * arg,DTYPE dtype)8444 eval_scale(ACL *arg, DTYPE dtype)
8445 {
8446 ACL *rslt;
8447 ACL *arg2;
8448 INT i, conval1, conval2, conval;
8449 DBLINT64 inum1, inum2;
8450 INT e;
8451 DBLE dconval;
8452
8453 rslt = arg = eval_init_expr(arg);
8454 conval1 = arg->conval;
8455 arg2 = arg->next;
8456
8457 if (arg2->dtype == DT_INT8)
8458 error(205, ERR_Warning, gbl.lineno, SYMNAME(arg2->conval),
8459 "- Illegal specification of scale factor");
8460
8461 i = arg2->dtype == DT_INT8 ? CONVAL2G(arg2->conval) : arg2->conval;
8462
8463 switch (size_of(arg->dtype)) {
8464 case 4:
8465 /* 8-bit exponent (127) to get an exponent value in the
8466 * range -126 .. +127 */
8467 e = 127 + i;
8468 if (e < 0)
8469 e = 0;
8470 else if (e > 255)
8471 e = 255;
8472
8473 /* calculate decimal value from it's IEEE 754 form*/
8474 conval2 = e << 23;
8475 xfmul(conval1, conval2, &conval);
8476 rslt->conval = conval;
8477 break;
8478
8479 case 8:
8480 e = 1023 + i;
8481 if (e < 0)
8482 e = 0;
8483 else if (e > 2047)
8484 e = 2047;
8485
8486 inum1[0] = CONVAL1G(conval1);
8487 inum1[1] = CONVAL2G(conval1);
8488
8489 inum2[0] = e << 20;
8490 inum2[1] = 0;
8491 xdmul(inum1, inum2, dconval);
8492 rslt->conval = getcon(dconval, DT_REAL8);
8493 break;
8494 }
8495
8496 return rslt;
8497 }
8498
8499 static ACL *
eval_merge(ACL * arg,DTYPE dtype)8500 eval_merge(ACL *arg, DTYPE dtype)
8501 {
8502 ACL *tsource = eval_init_expr_item(arg);
8503 ACL *fsource = eval_init_expr_item(arg->next);
8504 ACL *mask = eval_init_expr_item(arg->next->next);
8505 ACL *result = clone_init_const(tsource, TRUE);
8506 ACL *r = result;
8507 if (tsource->id == AC_ACONST)
8508 tsource = tsource->subc;
8509 if (fsource->id == AC_ACONST)
8510 fsource = fsource->subc;
8511 if (mask->id == AC_ACONST)
8512 mask = mask->subc;
8513 if (r->id == AC_ACONST)
8514 r = r->subc;
8515 for (; r != 0; r = r->next) {
8516 int cond = DT_ISWORD(mask->dtype) ? mask->conval : CONVAL2G(mask->conval);
8517 r->conval = cond ? tsource->conval : fsource->conval;
8518 r->dtype = dtype;
8519 tsource = tsource->next;
8520 fsource = fsource->next;
8521 mask = mask->next;
8522 }
8523 return result;
8524 }
8525
8526 /* Compare two constant ACLs. Return x > y or x < y depending on want_max.
8527 */
8528 static bool
cmp_acl(DTYPE dtype,ACL * x,ACL * y,bool want_max,bool back)8529 cmp_acl(DTYPE dtype, ACL *x, ACL *y, bool want_max, bool back)
8530 {
8531 int cmp;
8532 switch (DTY(dtype)) {
8533 case TY_CHAR:
8534 cmp = strcmp(stb.n_base + CONVAL1G(x->conval),
8535 stb.n_base + CONVAL1G(y->conval));
8536 break;
8537 case TY_BINT:
8538 case TY_SINT:
8539 case TY_INT:
8540 if (x->conval == y->conval) {
8541 cmp = 0;
8542 } else if (x->conval > y->conval) {
8543 cmp = 1;
8544 } else {
8545 cmp = -1;
8546 }
8547 break;
8548 case TY_REAL:
8549 cmp = xfcmp(x->conval, y->conval);
8550 break;
8551 case TY_INT8:
8552 case TY_DBLE:
8553 cmp = const_fold(OP_CMP, x->conval, y->conval, dtype);
8554 break;
8555 default:
8556 interr("cmp_acl: bad dtype", dtype, ERR_Severe);
8557 return false;
8558 }
8559 if (back) {
8560 return want_max ? cmp >= 0 : cmp <= 0;
8561 } else {
8562 return want_max ? cmp > 0 : cmp < 0;
8563 }
8564 }
8565
8566 /* An index into a Fortran array. ndims is in [1,MAXDIMS], index[] is the
8567 * index itself, extent[] is the extent in each dimension.
8568 * index[i] is in [1,extent[i]] for i in 1..ndims
8569 */
8570 typedef struct {
8571 unsigned ndims;
8572 unsigned index[MAXDIMS + 1];
8573 unsigned extent[MAXDIMS + 1];
8574 } INDEX;
8575
8576 /* Increment an array index starting at the left and carrying to the right. */
8577 static bool
incr_index(INDEX * index)8578 incr_index(INDEX *index)
8579 {
8580 unsigned d;
8581 for (d = 1; d <= index->ndims; ++d) {
8582 if (index->index[d] < index->extent[d]) {
8583 index->index[d] += 1;
8584 return true; /* no carry needed */
8585 }
8586 index->index[d] = 1;
8587 }
8588 return false;
8589 }
8590
8591 static unsigned
get_offset_without_dim(INDEX * index,unsigned dim)8592 get_offset_without_dim(INDEX *index, unsigned dim)
8593 {
8594 if (dim == 0) {
8595 return 0;
8596 } else {
8597 unsigned result = 0;
8598 unsigned d;
8599 for (d = index->ndims; d > 0; --d) {
8600 if (d != dim) {
8601 result *= index->extent[d];
8602 result += index->index[d] - 1;
8603 }
8604 }
8605 return result;
8606 }
8607 }
8608
8609 /* Create an array dtype from the extents in index, omitting dimension dim. */
8610 static DTYPE
mk_dtype_without_dim(INDEX * index,unsigned dim,DTYPE elem_dtype)8611 mk_dtype_without_dim(INDEX *index, unsigned dim, DTYPE elem_dtype)
8612 {
8613 DTYPE array_dtype;
8614 unsigned i, j;
8615 for (i = 1, j = 0; i <= index->ndims; ++i) {
8616 if (i != dim) {
8617 sem.bounds[j].lowtype = S_CONST;
8618 sem.bounds[j].lowb = 1;
8619 sem.bounds[j].lwast = 0;
8620 sem.bounds[j].uptype = S_CONST;
8621 sem.bounds[j].upb = index->extent[i];
8622 sem.bounds[j].upast = mk_cval(index->extent[i], stb.user.dt_int);
8623 ++j;
8624 }
8625 }
8626 sem.arrdim.ndim = index->ndims - 1;
8627 sem.arrdim.ndefer = 0;
8628 array_dtype = mk_arrdsc();
8629 DTY(array_dtype + 1) = elem_dtype;
8630 return array_dtype;
8631 }
8632
8633 /* Get an ACL representing the smallest/largest value of this type. */
8634 static ACL *
get_minmax_val(DTYPE dtype,bool want_max)8635 get_minmax_val(DTYPE dtype, bool want_max)
8636 {
8637 int ast = want_max ? mk_smallest_val(dtype) : mk_largest_val(dtype);
8638 return eval_init_expr_item(construct_acl_from_ast(ast, dtype, 0));
8639 }
8640
8641 static ACL *
convert_acl_dtype(ACL * head,int oldtype,int newtype)8642 convert_acl_dtype(ACL *head, int oldtype, int newtype)
8643 {
8644 DTYPE dtype;
8645 ACL *cur_lop;
8646 if (DTY(oldtype) == TY_DERIVED || DTY(oldtype) == TY_STRUCT ||
8647 DTY(oldtype) == TY_CHAR || DTY(oldtype) == TY_NCHAR ||
8648 DTY(oldtype) == TY_UNION) {
8649 return head;
8650 }
8651 dtype = DDTG(newtype);
8652
8653 /* make sure all are AC_CONST */
8654 for (cur_lop = head; cur_lop; cur_lop = cur_lop->next) {
8655 if (cur_lop->id != AC_CONST)
8656 return head;
8657 }
8658
8659 for (cur_lop = head; cur_lop; cur_lop = cur_lop->next) {
8660 if (cur_lop->dtype != dtype) {
8661 cur_lop->dtype = dtype;
8662 cur_lop->conval = cngcon(cur_lop->conval, DDTG(oldtype), DDTG(newtype));
8663 }
8664 }
8665 return head;
8666 }
8667
8668 /* Evaluate {min,max}{val,loc}{elems, dim, mask, back).
8669 * index describes the shape of the array; elem_dt the type of elems.
8670 */
8671 static ACL *
do_eval_minval_or_maxval(INDEX * index,DTYPE elem_dt,DTYPE loc_dt,ACL * elems,unsigned dim,ACL * mask,bool back,AC_INTRINSIC intrin)8672 do_eval_minval_or_maxval(INDEX *index, DTYPE elem_dt, DTYPE loc_dt, ACL *elems,
8673 unsigned dim, ACL *mask, bool back,
8674 AC_INTRINSIC intrin)
8675 {
8676 unsigned ndims = index->ndims;
8677 unsigned i;
8678 ACL **vals;
8679 unsigned *locs;
8680 unsigned vals_size = 1;
8681 unsigned locs_size;
8682 bool want_max = intrin == AC_I_maxloc || intrin == AC_I_maxval;
8683 bool want_val = intrin == AC_I_minval || intrin == AC_I_maxval;
8684
8685 /* vals[vals_size] contains the result for {min,max}val()
8686 * locs[locs_size] contains the result for {min,max}loc() */
8687 if (dim == 0) {
8688 locs_size = ndims;
8689 } else {
8690 unsigned d;
8691 for (d = 1; d <= ndims; ++d) {
8692 if (d != dim)
8693 vals_size *= index->extent[d];
8694 }
8695 locs_size = vals_size;
8696 }
8697 NEW(vals, ACL *, vals_size);
8698 for (i = 0; i < vals_size; ++i) {
8699 vals[i] = get_minmax_val(elem_dt, want_max);
8700 }
8701
8702 NEW(locs, unsigned, locs_size);
8703 BZERO(locs, unsigned, locs_size);
8704
8705 { /* iterate over elements computing min/max into vals[] and locs[] */
8706 ACL *elem;
8707 for (elem = elems; elem != 0; elem = elem->next) {
8708 if (elem->dtype != elem_dt) {
8709 elem = convert_acl_dtype(elem, elem->dtype, elem_dt);
8710 }
8711
8712 if (mask->conval) {
8713 ACL *val = eval_init_expr_item(elem);
8714 unsigned offset = get_offset_without_dim(index, dim);
8715 ACL *prev_val = vals[offset];
8716 if (cmp_acl(elem_dt, val, prev_val, want_max, back)) {
8717 vals[offset] = val;
8718 if (dim == 0) {
8719 BCOPY(locs, &index->index[1], int, ndims);
8720 } else {
8721 locs[offset] = index->index[dim];
8722 }
8723 }
8724 }
8725 if (mask->next)
8726 mask = mask->next;
8727 incr_index(index);
8728 }
8729 }
8730
8731 { /* build result from vals[] or locs[] */
8732 ACL *result;
8733 ACL *subc = NULL; /* elements of result array */
8734 if (!want_val) {
8735 for (i = 0; i < locs_size; i++) {
8736 ACL *elem = GET_ACL(15);
8737 BZERO(elem, ACL, 1);
8738 elem->id = AC_CONST;
8739 elem->dtype = loc_dt;
8740 elem->is_const = true;
8741 elem->conval = locs[i];
8742 elem->u1.ast = mk_cval(locs[i], loc_dt);
8743 add_to_list(elem, &subc);
8744 }
8745 } else if (dim > 0) {
8746 for (i = 0; i < vals_size; i++) {
8747 add_to_list(vals[i], &subc);
8748 }
8749 } else {
8750 return vals[0]; /* minval/maxval with no dim has scalar result */
8751 }
8752
8753 result = GET_ACL(15);
8754 BZERO(result, ACL, 1);
8755 result->id = AC_ACONST;
8756 result->dtype =
8757 mk_dtype_without_dim(index, dim, want_val ? elem_dt : loc_dt);
8758 result->is_const = 1;
8759 result->subc = subc;
8760 return result;
8761 }
8762 }
8763
8764 static ACL *
eval_minval_or_maxval(ACL * arg,DTYPE dtype,AC_INTRINSIC intrin)8765 eval_minval_or_maxval(ACL *arg, DTYPE dtype, AC_INTRINSIC intrin)
8766 {
8767 DTYPE elem_dt = array_element_dtype(dtype);
8768 DTYPE loc_dtype = DT_INT;
8769 ACL *array = eval_init_expr_item(arg);
8770 unsigned dim = 0; /* 0 means no DIM specified, otherwise in 1..ndims */
8771 ACL *mask = 0;
8772 INDEX index;
8773 unsigned d;
8774 ACL *arg2;
8775 bool back = FALSE;
8776
8777 while (arg = arg->next) {
8778 if (DT_ISLOG(arg->dtype)) { /* back */
8779 arg2 = eval_init_expr_item(arg);
8780 back = arg2->conval;
8781 } else if (DT_ISINT(arg->dtype)) { /* dim */
8782 arg2 = eval_init_expr_item(arg);
8783 dim = arg2->conval;
8784 assert(dim == arg2->conval, "DIM value must be an integer!", 0,
8785 ERR_Fatal);
8786 } else { //(DT_ISLOG_ARR(arg->dtype))
8787 mask = eval_init_expr_item(arg);
8788 if (mask != 0 && mask->id == AC_ACONST)
8789 mask = mask->subc;
8790 }
8791 }
8792
8793 if (mask == 0) {
8794 /* mask defaults to .true. */
8795 mask = GET_ACL(15);
8796 BZERO(mask, ACL, 1);
8797 mask->id = AC_CONST;
8798 mask->dtype = DT_LOG;
8799 mask->is_const = 1;
8800 mask->conval = 1;
8801 mask->u1.ast = mk_cval(gbl.ftn_true, DT_LOG);
8802 }
8803 /* index contains the rank and extents of the array dtype */
8804 BZERO(&index, INDEX, 1);
8805 index.ndims = ADD_NUMDIM(dtype);
8806 for (d = 1; d <= index.ndims; ++d) {
8807 int lwbd = get_int_cval(A_SPTRG(ADD_LWAST(dtype, d - 1)));
8808 int upbd = get_int_cval(A_SPTRG(ADD_UPAST(dtype, d - 1)));
8809 int extent = upbd - lwbd + 1;
8810 index.extent[d] = extent;
8811 index.index[d] = 1;
8812 }
8813 return do_eval_minval_or_maxval(&index, elem_dt, loc_dtype, array->subc, dim,
8814 mask, back, intrin);
8815 }
8816
8817 /* evaluate min or max, depending on want_max flag */
8818 static ACL *
eval_min_or_max(ACL * arg,DTYPE dtype,LOGICAL want_max)8819 eval_min_or_max(ACL *arg, DTYPE dtype, LOGICAL want_max)
8820 {
8821 ACL *rslt;
8822 ACL *wrkarg1, *head, *c;
8823 ACL **arglist;
8824 int nargs;
8825 int nelems = 0;
8826 int i, j, repeatc1, repeatc2;
8827 ADSC *adsc;
8828 ACL *root = NULL;
8829
8830 /* at this point we only know argument types but we don't know the
8831 * lhs of min(...) type
8832 * Therefore, create a result based on the result of args.
8833 */
8834
8835 rslt = GET_ACL(15);
8836 BZERO(rslt, ACL, 1);
8837 rslt->dtype = arg->dtype;
8838
8839 for (wrkarg1 = arg, nargs = 0; wrkarg1; wrkarg1 = wrkarg1->next, nargs++)
8840 ;
8841
8842 NEW(arglist, ACL *, nargs);
8843 for (i = 0, wrkarg1 = arg; i < nargs; i++, wrkarg1 = wrkarg1->next) {
8844 head = arglist[i] = eval_init_expr(wrkarg1);
8845 if (DTY(head->dtype) == TY_ARRAY) {
8846 int num;
8847 adsc = AD_DPTR(head->dtype);
8848 num = get_int_cval(A_SPTRG(AD_NUMELM(adsc)));
8849 if (nelems == 0) {
8850 nelems = num;
8851 } else if (nelems != num) {
8852 /* error */
8853 }
8854 rslt->id = AC_ACONST;
8855 rslt->dtype = head->dtype;
8856 }
8857 }
8858 if (nelems == 0) {
8859 nelems = 1; /* scalar only */
8860 c = rslt;
8861 c->id = AC_CONST;
8862 c->repeatc = astb.bnd.one;
8863 c->next = NULL;
8864 add_to_list(c, &root);
8865 } else {
8866 for (j = 0; j < nelems; j++) {
8867 c = GET_ACL(15);
8868 c->id = AC_CONST;
8869 c->repeatc = astb.bnd.one;
8870 c->next = NULL;
8871 add_to_list(c, &root);
8872 }
8873 rslt->subc = root;
8874 rslt->repeatc = 0;
8875 }
8876
8877 wrkarg1 = arglist[0];
8878 for (i = 1; i < nargs; i++) {
8879 ACL *wrkarg2 = arglist[i];
8880 if (wrkarg2->id == AC_ACONST) {
8881 wrkarg2 = wrkarg2->subc;
8882 if (wrkarg2->repeatc)
8883 repeatc2 = get_int_cval(A_SPTRG(wrkarg2->repeatc));
8884 else
8885 repeatc2 = 1;
8886 } else {
8887 repeatc2 = nelems;
8888 }
8889 if (wrkarg1->id == AC_ACONST) {
8890 wrkarg1 = wrkarg1->subc;
8891 if (wrkarg1->repeatc)
8892 repeatc1 = get_int_cval(A_SPTRG(wrkarg1->repeatc));
8893 else
8894 repeatc1 = 1;
8895 } else {
8896 repeatc1 = nelems;
8897 }
8898
8899 c = root;
8900 for (j = 0; j < nelems; j++) {
8901 if (cmp_acl(dtype, wrkarg2, wrkarg1, want_max, FALSE)) {
8902 c->u1 = wrkarg2->u1;
8903 c->conval = wrkarg2->conval;
8904 c->dtype = wrkarg2->dtype;
8905 } else if (root != wrkarg1) {
8906 c->u1 = wrkarg1->u1;
8907 c->conval = wrkarg1->conval;
8908 c->dtype = wrkarg1->dtype;
8909 }
8910 if (--repeatc2 <= 0) {
8911 wrkarg2 = wrkarg2->next;
8912 if (wrkarg2 && wrkarg2->repeatc)
8913 repeatc2 = get_int_cval(A_SPTRG(wrkarg2->repeatc));
8914 else
8915 repeatc2 = 1;
8916 }
8917 c = c->next;
8918 if (wrkarg1 == root) { /* result becomes argument on next
8919 * iteration of outer loop
8920 */
8921 wrkarg1 = c;
8922 repeatc1 = 1;
8923 } else if (--repeatc1 <= 0) {
8924 wrkarg1 = wrkarg1->next;
8925 if (wrkarg2 && wrkarg2->repeatc)
8926 repeatc2 = get_int_cval(A_SPTRG(wrkarg2->repeatc));
8927 else
8928 repeatc2 = 1;
8929 }
8930 }
8931 wrkarg1 = c = root;
8932 }
8933 return rslt;
8934 }
8935
8936 static ACL *
eval_nint(ACL * arg,DTYPE dtype)8937 eval_nint(ACL *arg, DTYPE dtype)
8938 {
8939 ACL *rslt;
8940 ACL *wrkarg;
8941 int conval;
8942
8943 rslt = arg = eval_init_expr(arg);
8944 wrkarg = (rslt->id == AC_ACONST ? rslt->subc : rslt);
8945 for (; wrkarg; wrkarg = wrkarg->next) {
8946 INT num1[4];
8947 INT res[4];
8948 INT con1;
8949 DTYPE dtype1 = wrkarg->dtype;
8950
8951 switch (DTY(dtype1)) {
8952 case TY_REAL:
8953 con1 = wrkarg->conval;
8954 num1[0] = CONVAL2G(stb.flt0);
8955 if (xfcmp(con1, num1[0]) >= 0) {
8956 INT fv2_23;
8957 xffloat(1 << 23, &fv2_23);
8958 if (xfcmp(con1, fv2_23) >= 0)
8959 xfadd(con1, CONVAL2G(stb.flt0), &res[0]);
8960 else
8961 xfadd(con1, CONVAL2G(stb.flthalf), &res[0]);
8962 } else {
8963 INT fvm2_23;
8964 xffloat(-(1 << 23), &fvm2_23);
8965 if (xfcmp(con1, fvm2_23) <= 0)
8966 xfsub(con1, CONVAL2G(stb.flt0), &res[0]);
8967 else
8968 xfsub(con1, CONVAL2G(stb.flthalf), &res[0]);
8969 }
8970 break;
8971 case TY_DBLE:
8972 con1 = wrkarg->conval;
8973 if (const_fold(OP_CMP, con1, stb.dbl0, DT_REAL8) >= 0) {
8974 INT dv2_52[2] = {0x43300000, 0x00000000};
8975 INT d2_52;
8976 d2_52 = getcon(dv2_52, DT_DBLE);
8977 if (const_fold(OP_CMP, con1, d2_52, DT_REAL8) >= 0)
8978 res[0] = const_fold(OP_ADD, con1, stb.dbl0, DT_REAL8);
8979 else
8980 res[0] = const_fold(OP_ADD, con1, stb.dblhalf, DT_REAL8);
8981 } else {
8982 INT dvm2_52[2] = {0xc3300000, 0x00000000};
8983 INT dm2_52;
8984 dm2_52 = getcon(dvm2_52, DT_DBLE);
8985 if (const_fold(OP_CMP, con1, dm2_52, DT_REAL8) <= 0)
8986 res[0] = const_fold(OP_SUB, con1, stb.dblhalf, DT_REAL8);
8987 else
8988 res[0] = const_fold(OP_SUB, con1, stb.dbl0, DT_REAL8);
8989 }
8990 break;
8991 }
8992 conval = cngcon(res[0], dtype1, dtype);
8993 wrkarg->dtype = dtype;
8994 wrkarg->conval = conval;
8995 }
8996 return rslt;
8997 }
8998
8999 static ACL *
eval_floor(ACL * arg,DTYPE dtype)9000 eval_floor(ACL *arg, DTYPE dtype)
9001 {
9002 ACL *rslt;
9003 ACL *wrkarg;
9004 int conval;
9005
9006 rslt = arg = eval_init_expr(arg);
9007 wrkarg = (rslt->id == AC_ACONST ? rslt->subc : rslt);
9008 for (; wrkarg; wrkarg = wrkarg->next) {
9009 INT num1[4];
9010 INT con1;
9011 int adjust;
9012
9013 adjust = 0;
9014 con1 = wrkarg->conval;
9015 switch (DTY(wrkarg->dtype)) {
9016 case TY_REAL:
9017 conval = cngcon(con1, DT_REAL4, dtype);
9018 num1[0] = CONVAL2G(stb.flt0);
9019 if (xfcmp(con1, num1[0]) < 0) {
9020 con1 = cngcon(conval, dtype, DT_REAL4);
9021 if (xfcmp(con1, wrkarg->conval) != 0)
9022 adjust = 1;
9023 }
9024 break;
9025 case TY_DBLE:
9026 conval = cngcon(con1, DT_REAL8, dtype);
9027 if (const_fold(OP_CMP, con1, stb.dbl0, DT_REAL8) < 0) {
9028 con1 = cngcon(conval, dtype, DT_REAL8);
9029 if (const_fold(OP_CMP, con1, wrkarg->conval, DT_REAL8) != 0)
9030 adjust = 1;
9031 }
9032 break;
9033 }
9034 if (adjust) {
9035 if (DT_ISWORD(dtype))
9036 conval--;
9037 else {
9038 num1[0] = 0;
9039 num1[1] = 1;
9040 con1 = getcon(num1, dtype);
9041 conval = const_fold(OP_SUB, conval, con1, dtype);
9042 }
9043 }
9044 wrkarg->conval = conval;
9045 wrkarg->dtype = dtype;
9046 }
9047 return rslt;
9048 }
9049
9050 static ACL *
eval_ceiling(ACL * arg,DTYPE dtype)9051 eval_ceiling(ACL *arg, DTYPE dtype)
9052 {
9053 ACL *rslt;
9054 ACL *wrkarg;
9055 int conval;
9056
9057 rslt = eval_init_expr(arg);
9058 wrkarg = (rslt->id == AC_ACONST ? rslt->subc : rslt);
9059 for (; wrkarg; wrkarg = wrkarg->next) {
9060 INT num1[4];
9061 INT con1;
9062 int adjust;
9063
9064 adjust = 0;
9065 con1 = wrkarg->conval;
9066 switch (DTY(wrkarg->dtype)) {
9067 case TY_REAL:
9068 conval = cngcon(con1, DT_REAL4, dtype);
9069 num1[0] = CONVAL2G(stb.flt0);
9070 if (xfcmp(con1, num1[0]) > 0) {
9071 con1 = cngcon(conval, dtype, DT_REAL4);
9072 if (xfcmp(con1, wrkarg->conval) != 0)
9073 adjust = 1;
9074 }
9075 break;
9076 case TY_DBLE:
9077 conval = cngcon(con1, DT_REAL8, dtype);
9078 if (const_fold(OP_CMP, con1, stb.dbl0, DT_REAL8) > 0) {
9079 con1 = cngcon(conval, dtype, DT_REAL8);
9080 if (const_fold(OP_CMP, con1, wrkarg->conval, DT_REAL8) != 0)
9081 adjust = 1;
9082 }
9083 break;
9084 }
9085 if (adjust) {
9086 if (DT_ISWORD(dtype))
9087 conval++;
9088 else {
9089 num1[0] = 0;
9090 num1[1] = 1;
9091 con1 = getcon(num1, dtype);
9092 conval = const_fold(OP_ADD, conval, con1, dtype);
9093 }
9094 }
9095 wrkarg->conval = conval;
9096 wrkarg->dtype = dtype;
9097 }
9098 return rslt;
9099 }
9100
9101 static ACL *
eval_mod(ACL * arg,DTYPE dtype)9102 eval_mod(ACL *arg, DTYPE dtype)
9103 {
9104 ACL *rslt, *arg1, *arg2;
9105 int conval1, conval2, conval3;
9106
9107 rslt = arg = eval_init_expr(arg);
9108 arg1 = arg->id == AC_ACONST ? arg->subc : arg;
9109 arg2 = arg->next->id == AC_ACONST ? arg->next->subc : arg->next;
9110 arg->next = 0;
9111 dtype = DDTG(dtype);
9112 for (; arg1; arg1 = arg1->next) {
9113 /* mod(a,p) == a-int(a/p)*p */
9114 conval1 = cngcon(arg1->conval, arg1->dtype, dtype);
9115 conval2 = cngcon(arg2->conval, arg2->dtype, dtype);
9116 conval3 = const_fold(OP_DIV, conval1, conval2, dtype);
9117 conval3 = cngcon(conval3, dtype, DT_INT8);
9118 conval3 = cngcon(conval3, DT_INT8, dtype);
9119 conval3 = const_fold(OP_MUL, conval3, conval2, dtype);
9120 conval3 = const_fold(OP_SUB, conval1, conval3, dtype);
9121 arg1->conval = conval3;
9122 arg1->dtype = dtype;
9123 if (arg2->next)
9124 arg2 = arg2->next;
9125 }
9126 return rslt;
9127 }
9128
9129 static ACL *
eval_repeat(ACL * arg,DTYPE dtype)9130 eval_repeat(ACL *arg, DTYPE dtype)
9131 {
9132 ACL *rslt = NULL;
9133 ACL *arg1;
9134 ACL *arg2;
9135 int i, j, cvlen, newlen;
9136 INT ncopies;
9137 char *p, *cp, *str;
9138
9139 arg = eval_init_expr(arg);
9140 arg1 = arg;
9141 arg2 = arg->next;
9142 ncopies = get_int_from_init_conval(arg2);
9143 newlen = size_of(dtype);
9144 cvlen = size_of(arg1->dtype);
9145
9146 NEW(str, char, newlen);
9147 cp = str;
9148 j = ncopies;
9149 while (j-- > 0) {
9150 i = cvlen;
9151 p = stb.n_base + CONVAL1G(arg1->conval);
9152 while (i-- > 0)
9153 *cp++ = *p++;
9154 }
9155
9156 rslt = GET_ACL(15);
9157 rslt->id = AC_CONVAL;
9158 rslt->dtype = dtype;
9159 rslt->repeatc = astb.i1;
9160 rslt->conval = getstring(str, newlen);
9161
9162 FREE(str);
9163 return rslt;
9164 }
9165
9166 /* Store the value 'conval' of type 'dtype' into 'destination'. */
9167 static void
transfer_store(INT conval,DTYPE dtype,char * destination)9168 transfer_store(INT conval, DTYPE dtype, char *destination)
9169 {
9170 int *dest = (int *)destination;
9171 INT real, imag;
9172
9173 if (DT_ISWORD(dtype)) {
9174 dest[0] = conval;
9175 return;
9176 }
9177
9178 switch (DTY(dtype)) {
9179 case TY_DWORD:
9180 case TY_INT8:
9181 case TY_LOG8:
9182 case TY_DBLE:
9183 dest[0] = CONVAL2G(conval);
9184 dest[1] = CONVAL1G(conval);
9185 break;
9186
9187 case TY_CMPLX:
9188 dest[0] = CONVAL1G(conval);
9189 dest[1] = CONVAL2G(conval);
9190 break;
9191
9192 case TY_DCMPLX:
9193 real = CONVAL1G(conval);
9194 imag = CONVAL2G(conval);
9195 dest[0] = CONVAL2G(real);
9196 dest[1] = CONVAL1G(real);
9197 dest[2] = CONVAL2G(imag);
9198 dest[3] = CONVAL1G(imag);
9199 break;
9200
9201 case TY_CHAR:
9202 memcpy(dest, stb.n_base + CONVAL1G(conval), size_of(dtype));
9203 break;
9204
9205 default:
9206 interr("transfer_store: unexpected dtype", dtype, 3);
9207 }
9208 }
9209
9210 /* Get a value of type 'dtype' from buffer 'source'. */
9211 static INT
transfer_load(DTYPE dtype,char * source)9212 transfer_load(DTYPE dtype, char *source)
9213 {
9214 int *src = (int *)source;
9215 INT num[2], real[2], imag[2];
9216
9217 if (DT_ISWORD(dtype))
9218 return src[0];
9219
9220 switch (DTY(dtype)) {
9221 case TY_DWORD:
9222 case TY_INT8:
9223 case TY_LOG8:
9224 case TY_DBLE:
9225 num[1] = src[0];
9226 num[0] = src[1];
9227 break;
9228
9229 case TY_CMPLX:
9230 num[0] = src[0];
9231 num[1] = src[1];
9232 break;
9233
9234 case TY_DCMPLX:
9235 real[1] = src[0];
9236 real[0] = src[1];
9237 imag[1] = src[2];
9238 imag[0] = src[3];
9239 num[0] = getcon(real, DT_REAL8);
9240 num[1] = getcon(imag, DT_REAL8);
9241 break;
9242
9243 case TY_CHAR:
9244 return getstring(source, size_of(dtype));
9245
9246 default:
9247 interr("transfer_load: unexpected dtype", dtype, 3);
9248 }
9249
9250 return getcon(num, dtype);
9251 }
9252
9253 static ACL *
eval_transfer(ACL * arg,DTYPE dtype)9254 eval_transfer(ACL *arg, DTYPE dtype)
9255 {
9256 ACL *src;
9257 ACL *rslt;
9258 int ssize, sdtype, rsize, rdtype;
9259 int need, avail;
9260 char value[256];
9261 char *buffer = value;
9262 char *bp;
9263 INT pad;
9264
9265 arg = eval_init_expr(arg);
9266 src = clone_init_const(arg, TRUE);
9267 /* Find the type and size of the source and result. */
9268 sdtype = DDTG(arg->dtype);
9269 ssize = size_of(sdtype);
9270 rdtype = DDTG(dtype);
9271 rsize = size_of(rdtype);
9272
9273 /* Be sure we have enough space. */
9274 need = (rsize > ssize ? rsize : ssize) * 2;
9275 if (sizeof(value) < need) {
9276 NEW(buffer, char, need);
9277 return 0;
9278 }
9279
9280 /* Get a pad value in case we have to fill. */
9281 if (DTY(sdtype) == TY_CHAR)
9282 memset(buffer, ' ', ssize);
9283 else
9284 BZERO(buffer, char, ssize);
9285 pad = transfer_load(sdtype, buffer);
9286
9287 src->next = 0;
9288 if (DTY(src->dtype) == TY_ARRAY)
9289 src = src->subc;
9290 bp = buffer;
9291 avail = 0;
9292 if (DTY(dtype) != TY_ARRAY) {
9293 /* Result is scalar. */
9294 while (avail < rsize) {
9295 if (src) {
9296 transfer_store(src->conval, sdtype, bp);
9297 src = src->next;
9298 } else
9299 transfer_store(pad, sdtype, bp);
9300 bp += ssize;
9301 avail += ssize;
9302 }
9303 rslt = GET_ACL(15);
9304 rslt->id = AC_CONVAL;
9305 rslt->dtype = rdtype;
9306 rslt->conval = transfer_load(rdtype, buffer);
9307 } else {
9308 /* Result is array. */
9309 ACL *root, **current;
9310 ISZ_T i, nelem;
9311 int j;
9312
9313 nelem = get_const_from_ast(ADD_NUMELM(dtype));
9314 root = NULL;
9315 current = &root;
9316 for (i = 0; i < nelem; i++) {
9317 while (avail < rsize) {
9318 if (src) {
9319 transfer_store(src->conval, sdtype, bp);
9320 src = src->next;
9321 } else
9322 transfer_store(pad, sdtype, bp);
9323 bp += ssize;
9324 avail += ssize;
9325 }
9326 rslt = GET_ACL(15);
9327 rslt->id = AC_CONVAL;
9328 rslt->dtype = rdtype;
9329 rslt->conval = transfer_load(rdtype, buffer);
9330 *current = rslt;
9331 current = &(rslt->next);
9332 bp -= rsize;
9333 avail -= rsize;
9334 for (j = 0; j < avail; j++)
9335 buffer[j] = buffer[rsize + j];
9336 }
9337 rslt = GET_ACL(15);
9338 rslt->id = AC_ACONST;
9339 rslt->dtype = dtype;
9340 rslt->subc = root;
9341 }
9342
9343 if (buffer != value)
9344 FREE(buffer);
9345 return rslt;
9346 }
9347
9348 static ACL *
eval_len_trim(ACL * arg)9349 eval_len_trim(ACL *arg)
9350 {
9351 ACL *rslt;
9352 ACL *wrkarg;
9353 char *p;
9354 int cvlen, result;
9355
9356 rslt = arg = eval_init_expr(arg);
9357 wrkarg = (rslt->id == AC_ACONST ? rslt->subc : rslt);
9358 for (; wrkarg; wrkarg = wrkarg->next) {
9359 p = stb.n_base + CONVAL1G(wrkarg->conval);
9360 result = cvlen = size_of(wrkarg->dtype);
9361 p += cvlen - 1;
9362 /* skip trailing blanks */
9363 while (cvlen-- > 0) {
9364 if (*p-- != ' ')
9365 break;
9366 result--;
9367 }
9368 wrkarg->dtype = stb.user.dt_int;
9369 rslt->conval = get_default_int_val(result);
9370 }
9371 return rslt;
9372 }
9373
9374 static ACL *
eval_selected_real_kind(ACL * arg)9375 eval_selected_real_kind(ACL *arg)
9376 {
9377 ACL *rslt;
9378 ACL *wrkarg;
9379 int r;
9380 INT con;
9381
9382 r = 4;
9383
9384 wrkarg = arg = eval_init_expr(arg);
9385 con = get_int_from_init_conval(wrkarg);
9386 if (con <= 6)
9387 r = 4;
9388 else if (con <= 15)
9389 r = 8;
9390 else
9391 r = -1;
9392
9393 if (arg->next) {
9394 wrkarg = arg->next;
9395 con = get_int_from_init_conval(wrkarg);
9396 if (con <= 37) {
9397 if (r > 0 && r < 4)
9398 r = 4;
9399 } else if (con <= 307) {
9400 if (r > 0 && r < 8)
9401 r = 8;
9402 } else {
9403 if (r > 0)
9404 r = 0;
9405 r -= 2;
9406 }
9407 }
9408
9409 rslt = GET_ACL(15);
9410 rslt->id = AC_CONVAL;
9411 rslt->dtype = stb.user.dt_int;
9412 rslt->repeatc = astb.i1;
9413 rslt->conval = get_default_int_val(r);
9414
9415 return rslt;
9416 }
9417
9418 static ACL *
eval_selected_int_kind(ACL * arg)9419 eval_selected_int_kind(ACL *arg)
9420 {
9421 ACL *rslt;
9422 int r;
9423 INT con;
9424
9425 rslt = eval_init_expr(arg);
9426 con = get_int_from_init_conval(rslt);
9427 if (con > 18 || (con > 9 && XBIT(57, 2)))
9428 r = -1;
9429 else if (con > 9)
9430 r = 8;
9431 else if (con > 4)
9432 r = 4;
9433 else if (con > 2)
9434 r = 2;
9435 else
9436 r = 1;
9437 rslt->id = AC_CONVAL;
9438 rslt->dtype = stb.user.dt_int;
9439 rslt->repeatc = astb.i1;
9440 rslt->conval = get_default_int_val(r);
9441
9442 return rslt;
9443 }
9444
9445 static ACL *
eval_selected_char_kind(ACL * arg)9446 eval_selected_char_kind(ACL *arg)
9447 {
9448 ACL *rslt;
9449 int r;
9450
9451 rslt = eval_init_expr(arg);
9452 r = _selected_char_kind(rslt->conval);
9453 rslt->id = AC_CONVAL;
9454 rslt->dtype = stb.user.dt_int;
9455 rslt->repeatc = astb.i1;
9456 rslt->conval = get_default_int_val(r);
9457
9458 return rslt;
9459 }
9460
9461 static ACL *
eval_scan(ACL * arg)9462 eval_scan(ACL *arg)
9463 {
9464 ACL *rslt = NULL;
9465 ACL *c;
9466 ACL *wrkarg;
9467 int i, j;
9468 int l_string, l_set;
9469 char *p_string, *p_set;
9470 INT back = 0;
9471
9472 arg = eval_init_expr(arg);
9473 p_set = stb.n_base + CONVAL1G(arg->next->conval);
9474 l_set = size_of(arg->next->dtype);
9475
9476 if (arg->next->next) {
9477 back = get_int_from_init_conval(arg->next->next);
9478 }
9479
9480 wrkarg = clone_init_const(arg, TRUE);
9481 wrkarg = (wrkarg->id == AC_ACONST ? wrkarg->subc : wrkarg);
9482 for (; wrkarg; wrkarg = wrkarg->next) {
9483 p_string = stb.n_base + CONVAL1G(wrkarg->conval);
9484 l_string = size_of(wrkarg->dtype);
9485
9486 c = GET_ACL(15);
9487 c->id = AC_CONVAL;
9488 c->dtype = stb.dt_int;
9489 c->repeatc = wrkarg->repeatc;
9490
9491 if (back == 0) {
9492 for (i = 0; i < l_string; ++i)
9493 for (j = 0; j < l_set; ++j)
9494 if (p_set[j] == p_string[i]) {
9495 c->conval = i + 1;
9496 goto addtolist;
9497 }
9498 } else {
9499 for (i = l_string - 1; i >= 0; --i)
9500 for (j = 0; j < l_set; ++j)
9501 if (p_set[j] == p_string[i]) {
9502 c->conval = i + 1;
9503 goto addtolist;
9504 }
9505 }
9506 c->conval = 0;
9507
9508 addtolist:
9509 add_to_list(c, &rslt);
9510 }
9511 rslt->repeatc = arg->repeatc;
9512 return rslt;
9513 }
9514
9515 static ACL *
eval_verify(ACL * arg)9516 eval_verify(ACL *arg)
9517 {
9518 ACL *rslt = NULL;
9519 ACL *c;
9520 ACL *wrkarg;
9521 int i, j;
9522 int l_string, l_set;
9523 char *p_string, *p_set;
9524 INT back = 0;
9525
9526 arg = eval_init_expr(arg);
9527 p_set = stb.n_base + CONVAL1G(arg->next->conval);
9528 l_set = size_of(arg->next->dtype);
9529
9530 if (arg->next->next) {
9531 back = get_int_from_init_conval(arg->next->next);
9532 }
9533
9534 wrkarg = clone_init_const(arg, TRUE);
9535 wrkarg = (wrkarg->id == AC_ACONST ? wrkarg->subc : wrkarg);
9536 for (; wrkarg; wrkarg = wrkarg->next) {
9537 p_string = stb.n_base + CONVAL1G(wrkarg->u1.ast);
9538 l_string = size_of(wrkarg->dtype);
9539
9540 c = GET_ACL(15);
9541 c->id = AC_CONVAL;
9542 c->dtype = stb.dt_int;
9543 c->conval = 0;
9544 c->repeatc = wrkarg->repeatc;
9545
9546 if (back == 0) {
9547 for (i = 0; i < l_string; ++i) {
9548 for (j = 0; j < l_set; ++j) {
9549 if (p_set[j] == p_string[i])
9550 goto contf;
9551 }
9552 c->conval = i + 1;
9553 break;
9554 contf:;
9555 }
9556 } else {
9557 for (i = l_string - 1; i >= 0; --i) {
9558 for (j = 0; j < l_set; ++j) {
9559 if (p_set[j] == p_string[i])
9560 goto contb;
9561 }
9562 c->conval = i + 1;
9563 break;
9564 contb:;
9565 }
9566 }
9567
9568 add_to_list(c, &rslt);
9569 }
9570 rslt->repeatc = arg->repeatc;
9571 return rslt;
9572 }
9573
9574 static ACL *
eval_index(ACL * arg)9575 eval_index(ACL *arg)
9576 {
9577 ACL *rslt = NULL;
9578 ACL *c;
9579 ACL *wrkarg;
9580 int i, n;
9581 int l_string, l_substring;
9582 char *p_string, *p_substring;
9583 INT back = 0;
9584
9585 arg = eval_init_expr(arg);
9586 p_substring = stb.n_base + CONVAL1G(arg->next->conval);
9587 l_substring = size_of(arg->next->dtype);
9588
9589 if (arg->next->next) {
9590 back = get_int_from_init_conval(arg->next->next);
9591 }
9592
9593 wrkarg = clone_init_const(arg, TRUE);
9594 wrkarg = (wrkarg->id == AC_ACONST ? wrkarg->subc : wrkarg);
9595 for (; wrkarg; wrkarg = wrkarg->next) {
9596 p_string = stb.n_base + CONVAL1G(wrkarg->conval);
9597 l_string = size_of(wrkarg->dtype);
9598
9599 c = GET_ACL(15);
9600 c->id = AC_CONST;
9601 c->dtype = stb.dt_int;
9602 c->repeatc = wrkarg->repeatc;
9603
9604 n = l_string - l_substring;
9605 if (n < 0)
9606 c->conval = 0;
9607 if (back == 0) {
9608 if (l_substring == 0)
9609 c->conval = 0;
9610 for (i = 0; i <= n; ++i) {
9611 if (p_string[i] == p_substring[0] &&
9612 strncmp(p_string + i, p_substring, l_substring) == 0)
9613 c->conval = i + 1;
9614 }
9615 } else {
9616 if (l_substring == 0)
9617 c->conval = l_string + 1;
9618 for (i = n; i >= 0; --i) {
9619 if (p_string[i] == p_substring[0] &&
9620 strncmp(p_string + i, p_substring, l_substring) == 0)
9621 c->conval = i + 1;
9622 }
9623 }
9624 add_to_list(c, &rslt);
9625 }
9626 rslt->repeatc = arg->repeatc;
9627 return rslt;
9628 }
9629
9630 static ACL *
eval_trim(ACL * arg,DTYPE dtype)9631 eval_trim(ACL *arg, DTYPE dtype)
9632 {
9633 ACL *rslt;
9634 char *p, *cp, *str;
9635 int i, cvlen, newlen;
9636
9637 rslt = eval_init_expr(arg);
9638 p = stb.n_base + CONVAL1G(rslt->conval);
9639 cvlen = newlen = size_of(rslt->dtype);
9640
9641 i = 0;
9642 p += cvlen - 1;
9643 /* skip trailing blanks */
9644 while (cvlen-- > 0) {
9645 if (*p-- != ' ')
9646 break;
9647 newlen--;
9648 }
9649
9650 if (newlen == 0) {
9651 str = " ";
9652 rslt->conval = getstring(str, strlen(str));
9653 } else {
9654 str = cp = getitem(0, newlen);
9655 i = newlen;
9656 cp += newlen - 1;
9657 p++;
9658 while (i-- > 0) {
9659 *cp-- = *p--;
9660 }
9661
9662 rslt->conval = getstring(str, newlen);
9663 }
9664
9665 rslt->dtype = get_type(2, DTY(dtype), newlen);
9666 return rslt;
9667 }
9668
9669 static ACL *
eval_adjustl(ACL * arg)9670 eval_adjustl(ACL *arg)
9671 {
9672 ACL *rslt;
9673 ACL *wrkarg;
9674 char *p, *cp, *str;
9675 char ch;
9676 int i, cvlen, origlen;
9677
9678 arg = eval_init_expr(arg);
9679 rslt = clone_init_const(arg, TRUE);
9680 wrkarg = (rslt->id == AC_ACONST ? rslt->subc : rslt);
9681 for (; wrkarg; wrkarg = wrkarg->next) {
9682 p = stb.n_base + CONVAL1G(wrkarg->conval);
9683 cvlen = size_of(wrkarg->dtype);
9684 origlen = cvlen;
9685 str = cp = getitem(0, cvlen + 1); /* +1 just in case cvlen is 0 */
9686 i = 0;
9687 /* left justify string - skip leading blanks */
9688 while (cvlen-- > 0) {
9689 ch = *p++;
9690 if (ch != ' ') {
9691 *cp++ = ch;
9692 break;
9693 }
9694 i++;
9695 }
9696 while (cvlen-- > 0)
9697 *cp++ = *p++;
9698 /* append blanks */
9699 while (i-- > 0)
9700 *cp++ = ' ';
9701 wrkarg->conval = getstring(str, origlen);
9702 }
9703
9704 return rslt;
9705 }
9706
9707 static ACL *
eval_adjustr(ACL * arg)9708 eval_adjustr(ACL *arg)
9709 {
9710 ACL *rslt;
9711 ACL *wrkarg;
9712 char *p, *cp, *str;
9713 char ch;
9714 int i, cvlen, origlen;
9715
9716 arg = eval_init_expr(arg);
9717 rslt = clone_init_const(arg, TRUE);
9718 wrkarg = (rslt->id == AC_ACONST ? rslt->subc : rslt);
9719 for (; wrkarg; wrkarg = wrkarg->next) {
9720 p = stb.n_base + CONVAL1G(wrkarg->conval);
9721 origlen = cvlen = size_of(wrkarg->dtype);
9722 str = cp = getitem(0, cvlen + 1); /* +1 just in case cvlen is 0 */
9723 i = 0;
9724 p += cvlen - 1;
9725 cp += cvlen - 1;
9726 /* right justify string - skip trailing blanks */
9727 while (cvlen-- > 0) {
9728 ch = *p--;
9729 if (ch != ' ') {
9730 *cp-- = ch;
9731 break;
9732 }
9733 i++;
9734 }
9735 while (cvlen-- > 0)
9736 *cp-- = *p--;
9737 /* insert blanks */
9738 while (i-- > 0)
9739 *cp-- = ' ';
9740 wrkarg->id = AC_CONVAL;
9741 wrkarg->conval = getstring(str, origlen);
9742 }
9743
9744 return rslt;
9745 }
9746
9747 static ACL *
eval_shape(ACL * arg,DTYPE dtype)9748 eval_shape(ACL *arg, DTYPE dtype)
9749 {
9750 ACL *rslt;
9751
9752 rslt = clone_init_const(arg, TRUE);
9753 rslt->dtype = dtype;
9754 return rslt;
9755 }
9756
9757 static ACL *
eval_size(ACL * arg)9758 eval_size(ACL *arg)
9759 {
9760 ACL *arg1;
9761 ACL *arg2;
9762 ACL *arg3;
9763 ACL *rslt;
9764 int dim;
9765 int i;
9766
9767 arg = eval_init_expr(arg);
9768 arg1 = arg;
9769 arg2 = arg->next;
9770 if ((arg3 = arg->next->next)) {
9771 arg3 = eval_init_expr_item(arg3);
9772 if (!arg3) {
9773 return 0;
9774 }
9775 dim = arg3->conval;
9776
9777 for (i = 1, arg2 = arg2->subc; i < dim && arg2; i++, arg2 = arg2->next)
9778 ;
9779 rslt = clone_init_const(arg2, TRUE);
9780 } else {
9781 rslt = clone_init_const(arg1, TRUE);
9782 }
9783
9784 return rslt;
9785 }
9786
9787 static ACL *
eval_ul_bound(ACL * arg)9788 eval_ul_bound(ACL *arg)
9789 {
9790 ACL *arg1;
9791 ACL *arg2;
9792 INT arg2const;
9793 ACL *rslt;
9794 ADSC *adsc;
9795 int rank;
9796 int i;
9797
9798 arg = arg1 = eval_init_expr(arg);
9799 adsc = AD_DPTR(arg1->dtype);
9800 rank = AD_UPBD(adsc, 0);
9801 if (arg->next) {
9802 arg2 = arg->next;
9803 arg2const = get_int_from_init_conval(arg2);
9804
9805 if (arg2const > rank) {
9806 error(155, 3, gbl.lineno, "DIM argument greater than the array rank",
9807 CNULL);
9808 return 0;
9809 }
9810 rslt = arg1->subc;
9811 for (i = 1; rslt && i < arg2const; i++) {
9812 rslt = rslt->next;
9813 }
9814 rslt = clone_init_const(rslt, TRUE);
9815 } else {
9816 rslt = clone_init_const(arg1, TRUE);
9817 }
9818 return rslt;
9819 }
9820
9821 static int
copy_initconst_to_array(ACL ** arr,ACL * c,int count)9822 copy_initconst_to_array(ACL **arr, ACL *c, int count)
9823 {
9824 int i;
9825 int acnt;
9826 ACL *acl;
9827
9828 for (i = 0; i < count;) {
9829 if (c == NULL)
9830 break;
9831 switch (c->id) {
9832 case AC_ACONST:
9833 acnt = copy_initconst_to_array(arr, c->subc,
9834 count - i); /* MORE: count - i??? */
9835 i += acnt;
9836 arr += acnt;
9837 break;
9838 case AC_CONST:
9839 case AC_AST:
9840 acl = *arr = clone_init_const(c, TRUE);
9841 /* if there is a repeat */
9842 if (acl->repeatc > 0) {
9843 acnt = get_int_cval(A_SPTRG(acl->repeatc));
9844 arr += acnt;
9845 i += acnt;
9846 } else {
9847 arr++;
9848 i++;
9849 }
9850 break;
9851 default:
9852 interr("copy_initconst_to_array: unexpected const type", c->id, 3);
9853 return count;
9854 }
9855 c = c->next;
9856 }
9857 return i;
9858 }
9859
9860 static ACL *
eval_reshape(ACL * arg,DTYPE dtype)9861 eval_reshape(ACL *arg, DTYPE dtype)
9862 {
9863 ACL *srclist;
9864 ACL *tacl;
9865 ACL *pad = NULL;
9866 ACL *wrklist = NULL;
9867 ACL *orderarg = NULL;
9868 ACL **old_val = NULL;
9869 ACL **new_val = NULL;
9870 ACL *c = NULL;
9871 ADSC *adsc = AD_DPTR(dtype);
9872 int *new_index;
9873 int src_sz, dest_sz;
9874 int rank;
9875 INT order[MAXDIMS];
9876 int lwb[MAXDIMS];
9877 int upb[MAXDIMS];
9878 int mult[MAXDIMS];
9879 int i;
9880 int count;
9881
9882 arg = eval_init_expr(arg);
9883 srclist = clone_init_const(arg, TRUE);
9884 if (arg->next->next) {
9885 pad = arg->next->next;
9886 if (pad->id == AC_ACONST) {
9887 pad = eval_init_expr_item(pad);
9888 }
9889 if (arg->next->next->next && arg->next->next->next->id == AC_ACONST) {
9890 orderarg = eval_init_expr_item(arg->next->next->next);
9891 }
9892 }
9893
9894 src_sz = get_int_cval(A_SPTRG(ADD_NUMELM(arg->dtype)));
9895 dest_sz = 1;
9896
9897 rank = AD_NUMDIM(adsc);
9898 for (i = 0; i < rank; i++) {
9899 lwb[i] = 0;
9900 upb[i] = get_int_cval(A_SPTRG(AD_UPBD(adsc, i)));
9901 mult[i] = dest_sz;
9902 dest_sz *= upb[i];
9903 }
9904
9905 if (orderarg == NULL) {
9906 if (src_sz == dest_sz) {
9907 return srclist;
9908 }
9909 for (i = 0; i < rank; i++) {
9910 order[i] = i;
9911 }
9912 } else {
9913 LOGICAL out_of_order;
9914
9915 out_of_order = FALSE;
9916 c = (orderarg->id == AC_ACONST ? orderarg->subc : orderarg);
9917 for (i = 0; c && i < rank; c = c->next, i++) {
9918 order[i] =
9919 DT_ISWORD(c->dtype) ? c->conval - 1 : get_int_cval(c->conval) - 1;
9920 if (order[i] != i)
9921 out_of_order = TRUE;
9922 }
9923 if (!out_of_order && src_sz == dest_sz) {
9924 return srclist;
9925 }
9926 }
9927
9928 NEW(old_val, ACL *, dest_sz);
9929 if (old_val == NULL)
9930 return 0;
9931 BZERO(old_val, ACL *, dest_sz);
9932 /* MORE use GET_ACL for new_value */
9933 NEW(new_val, ACL *, dest_sz);
9934 NEW(new_index, int, dest_sz);
9935 if (new_val == NULL || new_index == NULL) {
9936 return 0;
9937 }
9938 BZERO(old_val, ACL *, dest_sz);
9939 BZERO(new_index, int, dest_sz);
9940
9941 count = dest_sz > src_sz ? src_sz : dest_sz;
9942 wrklist = srclist->id == AC_ACONST ? srclist->subc : srclist;
9943 (void)copy_initconst_to_array(old_val, wrklist, count);
9944
9945 if (dest_sz > src_sz) {
9946 count = dest_sz - src_sz;
9947 wrklist = pad->id == AC_ACONST ? pad->subc : pad;
9948 while (count > 0) {
9949 i = copy_initconst_to_array(old_val + src_sz, wrklist, count);
9950 count -= i;
9951 src_sz += i;
9952 }
9953 }
9954
9955 /* index to access source in linear order */
9956 i = 0;
9957 while (TRUE) {
9958 int index; /* index where to store each element of new val */
9959 int j;
9960
9961 index = 0;
9962 for (j = 0; j < rank; j++)
9963 index += lwb[j] * mult[j];
9964
9965 /* new_index contains old_val index */
9966 new_index[index] = i;
9967
9968 /* update loop indices */
9969 for (j = 0; j < rank; j++) {
9970 int loop;
9971 loop = order[j];
9972 lwb[loop]++;
9973 if (lwb[loop] < upb[loop])
9974 break;
9975 lwb[loop] = 0; /* reset and go on to the next loop */
9976 }
9977 if (j >= rank)
9978 break;
9979 i++;
9980 }
9981
9982 for (i = 0; i < dest_sz; i++) {
9983 ACL *tacl, *tail;
9984 int idx, start, end;
9985 int index = new_index[i];
9986 int repeatc;
9987 if (old_val[index]) {
9988 if (old_val[index]->repeatc)
9989 repeatc = get_int_cval(A_SPTRG(old_val[index]->repeatc));
9990 else
9991 repeatc = 1;
9992 if (repeatc <= 1) {
9993 new_val[i] = old_val[index];
9994 new_val[i]->id = AC_CONVAL;
9995 } else {
9996 idx = index + 1;
9997 start = i;
9998 end = repeatc - 1;
9999 while (new_index[++start] == idx) {
10000 ++idx;
10001 if (end <= 0 || start > dest_sz - 1)
10002 break;
10003 }
10004 old_val[index]->next = NULL;
10005 tacl = clone_init_const(old_val[index], TRUE);
10006 tacl->repeatc = mk_cval(idx - index, DT_INT);
10007 tacl->id = AC_CONVAL;
10008 old_val[index]->repeatc = mk_cval(index - (idx - index), DT_INT);
10009 new_val[i] = tacl;
10010 }
10011 } else {
10012 tail = old_val[index];
10013 idx = index;
10014 while (tail == NULL && idx >= 0) {
10015 tail = old_val[idx--];
10016 }
10017 tail->next = NULL;
10018 tacl = clone_init_const(tail, TRUE);
10019 start = i;
10020 end = get_int_cval(A_SPTRG(tail->repeatc)) - 1;
10021 idx = index + 1;
10022 while (new_index[++start] == idx) {
10023 ++idx;
10024 --end;
10025 if (end <= 0 || start > dest_sz - 1)
10026 break;
10027 }
10028 tail->repeatc = mk_cval(index - (idx - index), DT_INT);
10029 tacl->repeatc = mk_cval(idx - index, DT_INT);
10030 tacl->id = AC_CONVAL;
10031 new_val[i] = tacl;
10032 }
10033 }
10034 tacl = new_val[0];
10035 for (i = 0; i < dest_sz - 1; ++i) {
10036 if (new_val[i + 1] == NULL) {
10037 continue;
10038 } else {
10039 tacl->next = new_val[i + 1];
10040 tacl = new_val[i + 1];
10041 }
10042 }
10043 if (new_val[dest_sz - 1])
10044 (new_val[dest_sz - 1])->next = NULL;
10045 srclist = *new_val;
10046
10047 FREE(old_val);
10048 FREE(new_index);
10049
10050 return srclist;
10051 }
10052
10053 static ACL *
eval_null(int sptr)10054 eval_null(int sptr)
10055 {
10056 ACL *root = NULL;
10057 ACL *c;
10058
10059 /* for <ptr>$p */
10060 c = GET_ACL(15);
10061 c->id = AC_CONVAL;
10062 c->dtype = DT_PTR;
10063 c->u1.ast = astb.bnd.zero;
10064 c->conval = 0;
10065 add_to_list(c, &root);
10066 if (DTY(DTYPEG(sptr)) == TY_ARRAY) {
10067 /* for <ptr>$o */
10068 c = GET_ACL(15);
10069 c->id = AC_CONVAL;
10070 c->dtype = DT_PTR;
10071 c->sptr = PTROFFG(sptr);
10072 c->u1.ast = astb.bnd.zero;
10073 c->conval = 0;
10074 add_to_list(c, &root);
10075 /* for <ptr>$sd[1] */
10076 c = GET_ACL(15);
10077 c->id = AC_CONVAL;
10078 c->dtype = astb.bnd.dtype;
10079 c->sptr = SDSCG(sptr);
10080 c->u1.ast = astb.bnd.zero;
10081 c->conval = 0;
10082 add_to_list(c, &root);
10083 }
10084
10085 return root;
10086 }
10087
10088 static ACL *
eval_sqrt(ACL * arg,DTYPE dtype)10089 eval_sqrt(ACL *arg, DTYPE dtype)
10090 {
10091 ACL *rslt;
10092 ACL *wrkarg;
10093 INT conval;
10094
10095 rslt = arg = eval_init_expr(arg);
10096 wrkarg = (rslt->id == AC_ACONST ? rslt->subc : rslt);
10097 for (; wrkarg; wrkarg = wrkarg->next) {
10098 INT num1[4];
10099 INT res[4];
10100 INT con1;
10101
10102 con1 = wrkarg->conval;
10103 switch (DTY(wrkarg->dtype)) {
10104 case TY_REAL:
10105 xfsqrt(con1, &res[0]);
10106 conval = res[0];
10107 break;
10108 case TY_DBLE:
10109 num1[0] = CONVAL1G(con1);
10110 num1[1] = CONVAL2G(con1);
10111 xdsqrt(num1, res);
10112 conval = getcon(res, DT_DBLE);
10113 break;
10114 case TY_CMPLX:
10115 case TY_DCMPLX:
10116 /*
10117 a = sqrt(real**2 + imag**2); "hypot(real,imag)
10118 if (a == 0) {
10119 x = 0;
10120 y = 0;
10121 }
10122 else if (real > 0) {
10123 x = sqrt(0.5 * (a + real));
10124 y = 0.5 * (imag / x);
10125 }
10126 else {
10127 y = sqrt(0.5 * (a - real));
10128 if (imag < 0)
10129 y = -y;
10130 x = 0.5 * (imag / y);
10131 }
10132 res.real = x;
10133 res.imag = y;
10134 */
10135
10136 error(155, 3, gbl.lineno,
10137 "Intrinsic not supported in initialization:", "sqrt");
10138 break;
10139 default:
10140 error(155, 3, gbl.lineno,
10141 "Intrinsic not supported in initialization:", "sqrt");
10142 break;
10143 }
10144 conval = cngcon(conval, wrkarg->dtype, dtype);
10145 wrkarg->conval = conval;
10146 wrkarg->dtype = dtype;
10147 }
10148 return rslt;
10149 }
10150
10151 /*---------------------------------------------------------------------*/
10152
10153 #define FPINTRIN1(iname, ent, fscutil, dscutil) \
10154 static ACL *ent(ACL *arg, DTYPE dtype) \
10155 { \
10156 ACL *rslt; \
10157 ACL *wrkarg; \
10158 INT conval; \
10159 rslt = arg = eval_init_expr(arg); \
10160 wrkarg = (rslt->id == AC_ACONST ? rslt->subc : rslt); \
10161 for (; wrkarg; wrkarg = wrkarg->next) { \
10162 INT num1[4]; \
10163 INT res[4]; \
10164 INT con1; \
10165 con1 = wrkarg->conval; \
10166 switch (DTY(wrkarg->dtype)) { \
10167 case TY_REAL: \
10168 fscutil(con1, &res[0]); \
10169 conval = res[0]; \
10170 break; \
10171 case TY_DBLE: \
10172 num1[0] = CONVAL1G(con1); \
10173 num1[1] = CONVAL2G(con1); \
10174 dscutil(num1, res); \
10175 conval = getcon(res, DT_DBLE); \
10176 break; \
10177 case TY_CMPLX: \
10178 case TY_DCMPLX: \
10179 error(155, 3, gbl.lineno, \
10180 "Intrinsic not supported in initialization:", iname); \
10181 break; \
10182 case TY_HALF: \
10183 /* fallthrough to error */ \
10184 default: \
10185 error(155, 3, gbl.lineno, \
10186 "Intrinsic not supported in initialization:", iname); \
10187 break; \
10188 } \
10189 conval = cngcon(conval, wrkarg->dtype, dtype); \
10190 wrkarg->conval = conval; \
10191 wrkarg->dtype = dtype; \
10192 } \
10193 return rslt; \
10194 }
10195
10196 FPINTRIN1("exp", eval_exp, xfexp, xdexp)
10197
10198 FPINTRIN1("log", eval_log, xflog, xdlog)
10199
10200 FPINTRIN1("log10", eval_log10, xflog10, xdlog10)
10201
10202 FPINTRIN1("sin", eval_sin, xfsin, xdsin)
10203
10204 FPINTRIN1("cos", eval_cos, xfcos, xdcos)
10205
10206 FPINTRIN1("tan", eval_tan, xftan, xdtan)
10207
10208 FPINTRIN1("asin", eval_asin, xfasin, xdasin)
10209
10210 FPINTRIN1("acos", eval_acos, xfacos, xdacos)
10211
10212 FPINTRIN1("atan", eval_atan, xfatan, xdatan)
10213
10214 #define FPINTRIN2(iname, ent, fscutil, dscutil) \
10215 static ACL *ent(ACL *arg, DTYPE dtype) \
10216 { \
10217 ACL *rslt = arg; \
10218 ACL *arg1, *arg2; \
10219 INT conval; \
10220 arg1 = eval_init_expr_item(arg); \
10221 arg2 = eval_init_expr_item(arg->next); \
10222 rslt = clone_init_const(arg1, TRUE); \
10223 arg1 = (rslt->id == AC_ACONST ? rslt->subc : rslt); \
10224 arg2 = (arg2->id == AC_ACONST ? arg2->subc : arg2); \
10225 for (; arg1; arg1 = arg1->next, arg2 = arg2->next) { \
10226 INT num1[4], num2[4]; \
10227 INT res[4]; \
10228 INT con1, con2; \
10229 con1 = arg1->conval; \
10230 con2 = arg2->conval; \
10231 switch (DTY(arg1->dtype)) { \
10232 case TY_REAL: \
10233 fscutil(con1, con2, &res[0]); \
10234 conval = res[0]; \
10235 break; \
10236 case TY_DBLE: \
10237 num1[0] = CONVAL1G(con1); \
10238 num1[1] = CONVAL2G(con1); \
10239 num2[0] = CONVAL1G(con2); \
10240 num2[1] = CONVAL2G(con2); \
10241 dscutil(num1, num2, res); \
10242 conval = getcon(res, DT_DBLE); \
10243 break; \
10244 case TY_CMPLX: \
10245 case TY_DCMPLX: \
10246 error(155, 3, gbl.lineno, \
10247 "Intrinsic not supported in initialization:", iname); \
10248 break; \
10249 case TY_HALF: \
10250 /* fallthrough to error */ \
10251 default: \
10252 error(155, 3, gbl.lineno, \
10253 "Intrinsic not supported in initialization:", iname); \
10254 break; \
10255 } \
10256 conval = cngcon(conval, arg1->dtype, dtype); \
10257 arg1->conval = conval; \
10258 arg1->dtype = dtype; \
10259 } \
10260 return rslt; \
10261 }
10262
10263 FPINTRIN2("atan2", eval_atan2, xfatan2, xdatan2)
10264
10265 static INT
get_const_from_ast(int ast)10266 get_const_from_ast(int ast)
10267 {
10268 DTYPE dtype = A_DTYPEG(ast);
10269 INT c = 0;
10270
10271 if (A_TYPEG(ast) == A_ID) {
10272
10273 if (DTY(dtype) == TY_CHAR || DTY(dtype) == TY_NCHAR) {
10274 c = A_SPTRG(ast);
10275 } else {
10276 c = CONVAL1G(A_SPTRG(ast));
10277 }
10278 } else if (A_ALIASG(ast)) {
10279 if (DT_ISWORD(A_DTYPEG(ast))) {
10280 c = CONVAL2G(A_SPTRG(A_ALIASG(ast)));
10281 } else {
10282 c = A_SPTRG(A_ALIASG(ast));
10283 }
10284 } else {
10285 if (A_TYPEG(ast) == A_BINOP || A_TYPEG(ast) == A_INTR) {
10286 return const_eval(ast);
10287 }
10288 interr("get_const_from_ast: can't get const value", 0, 3);
10289 }
10290
10291 return c;
10292 }
10293
10294 static struct {
10295 ACL *root;
10296 ACL *roottail;
10297 ACL *arrbase;
10298 int ndims;
10299 struct {
10300 DTYPE dtype;
10301 ISZ_T idx;
10302 ACL *subscr_base;
10303 ISZ_T lowb;
10304 ISZ_T upb;
10305 ISZ_T stride;
10306 } sub[MAXDIMS];
10307 struct {
10308 ISZ_T lowb;
10309 ISZ_T upb;
10310 ISZ_T mplyr;
10311 } dim[MAXDIMS];
10312 } sb;
10313
10314 static ISZ_T
eval_sub_index(int dim)10315 eval_sub_index(int dim)
10316 {
10317 int repeatc;
10318 ISZ_T o_lowb, elem_offset;
10319 ACL *subscr_base;
10320 ADSC *adsc = AD_DPTR(sb.sub[dim].dtype);
10321 o_lowb = ad_val_of(sym_of_ast(AD_LWAST(adsc, 0)));
10322 subscr_base = sb.sub[dim].subscr_base;
10323
10324 elem_offset = (sb.sub[dim].idx - o_lowb);
10325 while (elem_offset && subscr_base) {
10326 if (subscr_base->repeatc)
10327 repeatc = get_int_cval(A_SPTRG(subscr_base->repeatc));
10328 else
10329 repeatc = 1;
10330 if (repeatc > 1) {
10331 while (repeatc > 0 && elem_offset) {
10332 --repeatc;
10333 --elem_offset;
10334 }
10335 } else {
10336 subscr_base = subscr_base->next;
10337 --elem_offset;
10338 }
10339 }
10340 return get_ival(subscr_base->dtype, subscr_base->conval);
10341 }
10342
10343 static int
eval_sb(int d)10344 eval_sb(int d)
10345 {
10346 int i;
10347 int t_ub = 0;
10348 ISZ_T sub_idx;
10349 ISZ_T elem_offset;
10350 ISZ_T repeat;
10351 ACL *v;
10352 ACL *c;
10353 ACL tmp;
10354
10355 #define TRACE_EVAL_SB 0
10356 if (d == 0) {
10357 #if TRACE_EVAL_SB
10358 printf("-----\n");
10359 #endif
10360 sb.sub[0].idx = sb.sub[0].lowb;
10361 if (sb.sub[0].stride > 0)
10362 t_ub = 1;
10363 while ((t_ub ? sb.sub[0].idx <= sb.sub[0].upb
10364 : sb.sub[0].idx >= sb.sub[0].upb)) {
10365 /* compute element offset */
10366 elem_offset = 0;
10367 for (i = 0; i < sb.ndims; i++) {
10368 sub_idx = sb.sub[i].idx;
10369 if (sb.sub[i].subscr_base) {
10370 sub_idx = eval_sub_index(i);
10371 }
10372 assert(sub_idx >= sb.dim[i].lowb && sub_idx <= sb.dim[i].upb,
10373 "Subscript for array is out-of-bounds", sub_idx, 0);
10374
10375 elem_offset += (sub_idx - sb.dim[i].lowb) * sb.dim[i].mplyr;
10376 #if TRACE_EVAL_SB
10377 printf("%3d ", sub_idx);
10378 #endif
10379 }
10380 #if TRACE_EVAL_SB
10381 printf(" elem_offset - %ld\n", elem_offset);
10382 #endif
10383 /* get initialization value at element offset */
10384 v = sb.arrbase;
10385 while (v && elem_offset) {
10386 if (v->repeatc)
10387 repeat = get_int_cval(A_SPTRG(v->repeatc));
10388 else
10389 repeat = 1;
10390 if (repeat > 1) {
10391 while (v && repeat > 0 && elem_offset) {
10392 --elem_offset;
10393 --repeat;
10394 }
10395 } else {
10396 v = v->next;
10397 --elem_offset;
10398 }
10399 }
10400 if (v == NULL) {
10401 interr("initialization expression: invalid array subscripts\n",
10402 elem_offset, 3);
10403 return 1;
10404 }
10405 /*
10406 * evaluate initialization value and add (repeat copies) to
10407 * initialization list
10408 */
10409 tmp = *v;
10410 tmp.next = 0;
10411 tmp.repeatc = astb.i1;
10412 c = eval_init_expr_item(clone_init_const(&tmp, TRUE));
10413 c->next = NULL;
10414
10415 add_to_list(c, &sb.root);
10416 sb.sub[0].idx += sb.sub[0].stride;
10417 }
10418 #if TRACE_EVAL_SB
10419 printf("-----\n");
10420 #endif
10421 return 0;
10422 }
10423 if (sb.sub[d].stride > 0) {
10424 for (sb.sub[d].idx = sb.sub[d].lowb; sb.sub[d].idx <= sb.sub[d].upb;
10425 sb.sub[d].idx += sb.sub[d].stride) {
10426 if (eval_sb(d - 1))
10427 return 1;
10428 }
10429 } else {
10430 for (sb.sub[d].idx = sb.sub[d].lowb; sb.sub[d].idx >= sb.sub[d].upb;
10431 sb.sub[d].idx += sb.sub[d].stride) {
10432 if (eval_sb(d - 1))
10433 return 1;
10434 }
10435 }
10436 return 0;
10437 }
10438
10439 static ACL *
eval_const_array_section(ACL * lop,int ldtype)10440 eval_const_array_section(ACL *lop, int ldtype)
10441 {
10442 ADSC *adsc = AD_DPTR(ldtype);
10443 int ndims = 0;
10444 int i;
10445
10446 sb.root = sb.roottail = NULL;
10447 if (lop->id == AC_ACONST) {
10448 sb.arrbase = eval_array_constructor(lop);
10449 } else {
10450 sb.arrbase = lop;
10451 }
10452
10453 if (sb.ndims != AD_NUMDIM(adsc)) {
10454 interr("initialization expression: subscript/dimension mis-match\n", ldtype,
10455 3);
10456 return 0;
10457 }
10458 ndims = AD_NUMDIM(adsc);
10459 for (i = 0; i < ndims; i++) {
10460 sb.dim[i].lowb = ad_val_of(sym_of_ast(AD_LWAST(adsc, i)));
10461 sb.dim[i].upb = ad_val_of(sym_of_ast(AD_UPAST(adsc, i)));
10462 sb.dim[i].mplyr = ad_val_of(sym_of_ast(AD_MLPYR(adsc, i)));
10463 }
10464
10465 sb.ndims = ndims;
10466 if (eval_sb(ndims - 1))
10467 return 0;
10468
10469 return sb.root;
10470 }
10471
10472 static ISZ_T
get_ival(DTYPE dtype,INT conval)10473 get_ival(DTYPE dtype, INT conval)
10474 {
10475 switch (DTY(dtype)) {
10476 case TY_INT8:
10477 case TY_LOG8:
10478 return get_isz_cval(conval);
10479 default:
10480 return conval;
10481 }
10482 }
10483
10484 static ACL *
eval_const_array_triple_section(ACL * curr_e)10485 eval_const_array_triple_section(ACL *curr_e)
10486 {
10487 ACL *c, *lop, *rop, *t_lop;
10488 ACL *v;
10489 int ndims = 0;
10490
10491 sb.root = sb.roottail = NULL;
10492 c = curr_e;
10493 do {
10494 rop = c->u1.expr->rop;
10495 lop = c->u1.expr->lop;
10496 sb.sub[ndims].subscr_base = 0;
10497 sb.sub[ndims].dtype = 0;
10498 if (lop) {
10499 t_lop = eval_init_expr(lop);
10500 sb.sub[ndims].dtype = t_lop->dtype;
10501 if (t_lop->id == AC_ACONST)
10502 sb.sub[ndims].subscr_base = eval_array_constructor(t_lop);
10503 else
10504 sb.sub[ndims].subscr_base = t_lop;
10505 }
10506 if (rop == 0) {
10507 interr("initialization expression: missing array section lb\n", 0, 3);
10508 return 0;
10509 }
10510 v = eval_init_expr(rop);
10511 if (!v || !v->is_const) {
10512 interr("initialization expression: non-constant lb\n", 0, 3);
10513 return 0;
10514 }
10515 sb.sub[ndims].lowb = get_ival(v->dtype, v->conval);
10516
10517 if ((rop = rop->next) == 0) {
10518 interr("initialization expression: missing array section ub\n", 0, 3);
10519 return 0;
10520 }
10521 v = eval_init_expr(rop);
10522 if (!v || !v->is_const) {
10523 interr("initialization expression: non-constant ub\n", 0, 3);
10524 return 0;
10525 }
10526
10527 sb.sub[ndims].upb = get_ival(v->dtype, v->conval);
10528
10529 if ((rop = rop->next) == 0) {
10530 interr("initialization expression: missing array section stride\n", 0, 3);
10531 return 0;
10532 }
10533 v = eval_init_expr(rop);
10534 if (!v || !v->is_const) {
10535 interr("initialization expression: non-constant stride\n", 0, 3);
10536 return 0;
10537 }
10538
10539 sb.sub[ndims].stride = get_ival(v->dtype, v->conval);
10540
10541 if (++ndims >= 7) {
10542 interr("initialization expression: too many dimensions\n", 0, 3);
10543 return 0;
10544 }
10545 c = c->next;
10546 } while (c);
10547
10548 sb.ndims = ndims;
10549 return sb.root;
10550 }
10551
10552 static void
mk_cmp(ACL * c,int op,INT l_conval,INT r_conval,int rdtype,int dt)10553 mk_cmp(ACL *c, int op, INT l_conval, INT r_conval, int rdtype, int dt)
10554 {
10555 switch (get_ast_op(op)) {
10556 case OP_EQ:
10557 case OP_GE:
10558 case OP_GT:
10559 case OP_LE:
10560 case OP_LT:
10561 case OP_NE:
10562 l_conval = const_fold(OP_CMP, l_conval, r_conval, rdtype);
10563 switch (get_ast_op(op)) {
10564 case OP_EQ:
10565 l_conval = l_conval == 0;
10566 break;
10567 case OP_GE:
10568 l_conval = l_conval >= 0;
10569 break;
10570 case OP_GT:
10571 l_conval = l_conval > 0;
10572 break;
10573 case OP_LE:
10574 l_conval = l_conval <= 0;
10575 break;
10576 case OP_LT:
10577 l_conval = l_conval < 0;
10578 break;
10579 case OP_NE:
10580 l_conval = l_conval != 0;
10581 break;
10582 }
10583 l_conval = l_conval ? SCFTN_TRUE : SCFTN_FALSE;
10584 c->conval = l_conval;
10585 break;
10586 case OP_LEQV:
10587 l_conval = const_fold(OP_CMP, l_conval, r_conval, rdtype);
10588 c->conval = l_conval == 0;
10589 break;
10590 case OP_LNEQV:
10591 l_conval = const_fold(OP_CMP, l_conval, r_conval, rdtype);
10592 c->conval = l_conval != 0;
10593 break;
10594 case OP_LOR:
10595 c->conval = l_conval | r_conval;
10596 break;
10597 case OP_LAND:
10598 c->conval = l_conval & r_conval;
10599 break;
10600 default:
10601 c->conval = const_fold(get_ast_op(op), l_conval, r_conval, dt);
10602 }
10603 }
10604
10605 static ACL *
eval_init_op(int op,ACL * lop,DTYPE ldtype,ACL * rop,DTYPE rdtype,SPTR sptr,DTYPE dtype)10606 eval_init_op(int op, ACL *lop, DTYPE ldtype, ACL *rop, DTYPE rdtype, SPTR sptr,
10607 DTYPE dtype)
10608 {
10609 ACL *root = NULL;
10610 ACL *c;
10611 ACL *cur_lop;
10612 ACL *cur_rop;
10613 DTYPE dt = DDTG(dtype);
10614 DTYPE e_dtype;
10615 int l_repeatc;
10616 int r_repeatc;
10617 INT l_conval;
10618 INT r_conval;
10619 int count;
10620 int lsptr;
10621 int rsptr;
10622 char *s;
10623 int llen;
10624 int rlen;
10625
10626 if (!lop) {
10627 return 0;
10628 }
10629
10630 if (op == AC_NEG || op == AC_LNOT) {
10631 cur_lop = (lop->id == AC_ACONST ? lop->subc : lop);
10632 for (; cur_lop; cur_lop = cur_lop->next) {
10633 c = GET_ACL(15);
10634 c->id = AC_CONST;
10635 c->dtype = dt;
10636 c->repeatc = astb.i1;
10637 l_conval = cur_lop->conval;
10638 if (dt != cur_lop->dtype) {
10639 l_conval = cngcon(l_conval, DDTG(cur_lop->dtype), dt);
10640 }
10641 if (op == AC_LNOT)
10642 c->conval = ~(l_conval);
10643 else
10644 c->conval = negate_const(l_conval, dt);
10645 add_to_list(c, &root);
10646 }
10647 } else if (op == AC_ARRAYREF) {
10648 root = eval_const_array_section(lop, ldtype);
10649 } else if (op == AC_CAT) {
10650 lsptr = lop->conval;
10651 rsptr = rop->conval;
10652 llen = string_length(DTYPEG(lsptr));
10653 rlen = string_length(DTYPEG(rsptr));
10654 s = getitem(0, llen + rlen);
10655 BCOPY(s, stb.n_base + CONVAL1G(lsptr), char, llen);
10656 BCOPY(s + llen, stb.n_base + CONVAL1G(rsptr), char, rlen);
10657
10658 c = GET_ACL(15);
10659 c->id = AC_CONST;
10660 c->dtype =
10661 get_type(2, DTY(DDTG(DTYPEG(lsptr))), mk_cval(llen + rlen, DT_INT4));
10662 c->repeatc = astb.i1;
10663 c->conval = c->sptr = getstring(s, llen + rlen);
10664 c->u1.ast = mk_cnst(c->conval);
10665 add_to_list(c, &root);
10666 } else if (op == AC_CONV) {
10667 cur_lop = (lop->id == AC_ACONST ? lop->subc : lop);
10668 if (cur_lop->repeatc)
10669 l_repeatc = get_int_cval(A_SPTRG(cur_lop->repeatc));
10670 else
10671 l_repeatc = 1;
10672 for (; cur_lop;) {
10673 c = GET_ACL(15);
10674 c->id = AC_CONST;
10675 c->dtype = dt;
10676 c->repeatc = astb.i1;
10677 c->conval = cngcon(cur_lop->conval, cur_lop->dtype, DDTG(dtype));
10678 add_to_list(c, &root);
10679 if (--l_repeatc <= 0) {
10680 cur_lop = cur_lop->next;
10681 if (cur_lop) {
10682 if (cur_lop->repeatc)
10683 l_repeatc = get_int_cval(A_SPTRG(cur_lop->repeatc));
10684 else
10685 l_repeatc = 1;
10686 }
10687 }
10688 }
10689 } else if (op == AC_MEMBR_SEL) {
10690 sptr = A_SPTRG(lop->u1.ast);
10691 if (DTY(DTYPEG(sptr)) != TY_DERIVED || !PARAMG(sptr)) {
10692 error(
10693 4, 3, gbl.lineno,
10694 "Left hand side of % operator must be a named constant derived type",
10695 NULL);
10696 return 0;
10697 }
10698
10699 sptr = NMCNSTG(sptr);
10700 c = clone_init_const(get_getitem_p(CONVAL2G(sptr)), TRUE);
10701
10702 if (c->id != AC_SCONST) {
10703 interr("Malformed member select operator, lhs not a derived type "
10704 "initializaer",
10705 op, 3);
10706 return 0;
10707 }
10708
10709 for (c = c->subc, count = CONVAL2G(A_SPTRG(rop->u1.ast)); c && count;
10710 c = c->next, --count)
10711 ;
10712
10713 if (!c || count != 0) {
10714 interr("Malformed member select operator, invalid member specifier", op,
10715 3);
10716 return 0;
10717 }
10718
10719 root = clone_init_const(c, TRUE);
10720 root = eval_init_expr(root);
10721 } else if (op == AC_INTR_CALL) {
10722 AC_INTRINSIC intrin = lop->u1.i;
10723 switch (intrin) {
10724 case AC_I_adjustl:
10725 root = eval_adjustl(rop);
10726 break;
10727 case AC_I_adjustr:
10728 root = eval_adjustr(rop);
10729 break;
10730 case AC_I_char:
10731 root = eval_char(rop, dtype);
10732 break;
10733 case AC_I_ichar:
10734 root = eval_ichar(rop, dtype);
10735 break;
10736 case AC_I_index:
10737 root = eval_index(rop);
10738 break;
10739 case AC_I_int:
10740 root = eval_int(rop, dtype);
10741 break;
10742 case AC_I_ishft:
10743 root = eval_ishft(rop, dtype);
10744 break;
10745 case AC_I_len_trim:
10746 root = eval_len_trim(rop);
10747 break;
10748 case AC_I_ubound:
10749 case AC_I_lbound:
10750 root = eval_ul_bound(rop);
10751 break;
10752 case AC_I_min:
10753 root = eval_min_or_max(rop, dtype, /*want_max*/ FALSE);
10754 break;
10755 case AC_I_max:
10756 root = eval_min_or_max(rop, dtype, /*want_max*/ TRUE);
10757 break;
10758 case AC_I_nint:
10759 root = eval_nint(rop, dtype);
10760 break;
10761 case AC_I_null:
10762 root = eval_null(sptr);
10763 break;
10764 case AC_I_fltconvert:
10765 root = eval_fltconvert(rop, dtype);
10766 break;
10767 case AC_I_repeat:
10768 root = eval_repeat(rop, dtype);
10769 break;
10770 case AC_I_transfer:
10771 root = eval_transfer(rop, dtype);
10772 break;
10773 case AC_I_reshape:
10774 root = eval_reshape(rop, dtype);
10775 break;
10776 case AC_I_selected_int_kind:
10777 root = eval_selected_int_kind(rop);
10778 break;
10779 case AC_I_selected_real_kind:
10780 root = eval_selected_real_kind(rop);
10781 break;
10782 case AC_I_selected_char_kind:
10783 root = eval_selected_char_kind(rop);
10784 break;
10785 case AC_I_scan:
10786 root = eval_scan(rop);
10787 break;
10788 case AC_I_shape:
10789 root = eval_shape(rop, dtype);
10790 break;
10791 case AC_I_size:
10792 root = eval_size(rop);
10793 break;
10794 case AC_I_trim:
10795 root = eval_trim(rop, dtype);
10796 break;
10797 case AC_I_verify:
10798 root = eval_verify(rop);
10799 break;
10800 case AC_I_floor:
10801 root = eval_floor(rop, dtype);
10802 break;
10803 case AC_I_ceiling:
10804 root = eval_ceiling(rop, dtype);
10805 break;
10806 case AC_I_mod:
10807 root = eval_mod(rop, dtype);
10808 break;
10809 case AC_I_sqrt:
10810 root = eval_sqrt(rop, dtype);
10811 break;
10812 case AC_I_exp:
10813 root = eval_exp(rop, dtype);
10814 break;
10815 case AC_I_log:
10816 root = eval_log(rop, dtype);
10817 break;
10818 case AC_I_log10:
10819 root = eval_log10(rop, dtype);
10820 break;
10821 case AC_I_sin:
10822 root = eval_sin(rop, dtype);
10823 break;
10824 case AC_I_cos:
10825 root = eval_cos(rop, dtype);
10826 break;
10827 case AC_I_tan:
10828 root = eval_tan(rop, dtype);
10829 break;
10830 case AC_I_asin:
10831 root = eval_asin(rop, dtype);
10832 break;
10833 case AC_I_acos:
10834 root = eval_acos(rop, dtype);
10835 break;
10836 case AC_I_atan:
10837 root = eval_atan(rop, dtype);
10838 break;
10839 case AC_I_atan2:
10840 root = eval_atan2(rop, dtype);
10841 break;
10842 case AC_I_abs:
10843 root = eval_abs(rop, dtype);
10844 break;
10845 case AC_I_iand:
10846 root = eval_iand(rop, dtype);
10847 break;
10848 case AC_I_ior:
10849 root = eval_ior(rop, dtype);
10850 break;
10851 case AC_I_ieor:
10852 root = eval_ieor(rop, dtype);
10853 break;
10854 case AC_I_merge:
10855 root = eval_merge(rop, dtype);
10856 break;
10857 case AC_I_scale:
10858 root = eval_scale(rop, dtype);
10859 break;
10860 case AC_I_maxloc:
10861 case AC_I_maxval:
10862 case AC_I_minloc:
10863 case AC_I_minval:
10864 root = eval_minval_or_maxval(rop, rdtype, intrin);
10865 break;
10866 default:
10867 interr("eval_init_op(semutil2.c): intrinsic not supported in "
10868 "initialization",
10869 intrin, ERR_Severe);
10870 /* Try to avoid a seg fault by returning something reasonable */
10871 root = GET_ACL(15);
10872 root->id = AC_CONST;
10873 root->repeatc = astb.i1;
10874 root->dtype = dtype;
10875 root->conval = cngcon(0, DT_INT, dtype);
10876 }
10877 } else if (DTY(ldtype) == TY_ARRAY && DTY(rdtype) == TY_ARRAY) {
10878 /* array <binop> array */
10879 cur_lop = (lop->id == AC_ACONST ? lop->subc : lop);
10880 cur_rop = (rop->id == AC_ACONST ? rop->subc : rop);
10881 if (cur_lop->repeatc)
10882 l_repeatc = get_int_cval(A_SPTRG(cur_lop->repeatc));
10883 else
10884 l_repeatc = 1;
10885 if (cur_rop->repeatc)
10886 r_repeatc = get_int_cval(A_SPTRG(cur_rop->repeatc));
10887 else
10888 r_repeatc = 1;
10889 e_dtype = DDTG(dtype);
10890 for (; cur_rop && cur_lop;) {
10891 c = GET_ACL(15);
10892 c->id = AC_CONST;
10893 c->dtype = dt;
10894 l_conval = cur_lop->conval;
10895 if (DDTG(cur_lop->dtype) != e_dtype) {
10896 l_conval = cngcon(l_conval, DDTG(cur_lop->dtype), e_dtype);
10897 }
10898 r_conval = cur_rop->conval;
10899 if (DDTG(cur_rop->dtype) != e_dtype) {
10900 r_conval = cngcon(r_conval, DDTG(cur_rop->dtype), e_dtype);
10901 }
10902 c->conval = const_fold(get_ast_op(op), l_conval, r_conval, dt);
10903 add_to_list(c, &root);
10904 if (--l_repeatc <= 0) {
10905 cur_lop = cur_lop->next;
10906 if (cur_lop) {
10907 if (cur_lop->repeatc)
10908 l_repeatc = get_int_cval(A_SPTRG(cur_lop->repeatc));
10909 else
10910 l_repeatc = 1;
10911 }
10912 }
10913 if (--r_repeatc <= 0) {
10914 cur_rop = cur_rop->next;
10915 if (cur_rop) {
10916 if (cur_rop->repeatc)
10917 r_repeatc = get_int_cval(A_SPTRG(cur_rop->repeatc));
10918 else
10919 r_repeatc = 1;
10920 }
10921 }
10922 }
10923 } else if (DTY(ldtype) == TY_ARRAY) {
10924 /* array <binop> scalar */
10925 cur_lop = (lop->id == AC_ACONST ? lop->subc : lop);
10926 if (cur_lop->repeatc)
10927 l_repeatc = get_int_cval(A_SPTRG(cur_lop->repeatc));
10928 else
10929 l_repeatc = 1;
10930 e_dtype = DDTG(dtype) != DT_LOG ? DDTG(dtype) : DDTG(rop->dtype);
10931 r_conval = rop->conval;
10932 if (rop->dtype != e_dtype) {
10933 r_conval = cngcon(r_conval, rop->dtype, e_dtype);
10934 }
10935 for (; cur_lop;) {
10936 c = GET_ACL(15);
10937 c->id = AC_CONST;
10938 c->dtype = dt;
10939 c->repeatc = astb.i1;
10940 l_conval = cur_lop->conval;
10941 if (DDTG(cur_lop->dtype) != e_dtype) {
10942 l_conval = cngcon(l_conval, DDTG(cur_lop->dtype), e_dtype);
10943 }
10944
10945 mk_cmp(c, op, l_conval, r_conval, rdtype, dt);
10946 add_to_list(c, &root);
10947 if (--l_repeatc <= 0) {
10948 cur_lop = cur_lop->next;
10949 if (cur_lop) {
10950 if (cur_lop->repeatc)
10951 l_repeatc = get_int_cval(A_SPTRG(cur_lop->repeatc));
10952 else
10953 l_repeatc = 1;
10954 }
10955 }
10956 }
10957 } else if (DTY(rdtype) == TY_ARRAY) {
10958 /* scalar <binop> array */
10959 cur_rop = (rop->id == AC_ACONST ? rop->subc : rop);
10960 if (cur_rop->repeatc)
10961 r_repeatc = get_int_cval(A_SPTRG(cur_rop->repeatc));
10962 else
10963 r_repeatc = 1;
10964 e_dtype = DDTG(dtype) != DT_LOG ? DDTG(dtype) : DDTG(lop->dtype);
10965 l_conval = lop->conval;
10966 if (lop->dtype != e_dtype) {
10967 l_conval = cngcon(l_conval, lop->dtype, e_dtype);
10968 }
10969 for (cur_rop = rop; cur_rop;) {
10970 c = GET_ACL(15);
10971 c->id = AC_CONST;
10972 c->dtype = dt;
10973 c->repeatc = astb.i1;
10974 r_conval = cur_rop->conval;
10975 if (DDTG(cur_rop->dtype) != e_dtype) {
10976 r_conval = cngcon(r_conval, DDTG(cur_rop->dtype), e_dtype);
10977 }
10978 mk_cmp(c, op, l_conval, r_conval, rdtype, dt);
10979 add_to_list(c, &root);
10980 if (--r_repeatc <= 0) {
10981 cur_rop = cur_rop->next;
10982 if (cur_rop) {
10983 if (cur_rop->repeatc)
10984 r_repeatc = get_int_cval(A_SPTRG(cur_rop->repeatc));
10985 else
10986 r_repeatc = 1;
10987 }
10988 }
10989 }
10990 } else {
10991 /* scalar <binop> scalar */
10992 root = GET_ACL(15);
10993 root->id = AC_CONST;
10994 root->repeatc = astb.i1;
10995 root->dtype = dt;
10996 op = get_ast_op(op);
10997 switch (op) {
10998 case OP_EQ:
10999 case OP_GE:
11000 case OP_GT:
11001 case OP_LE:
11002 case OP_LT:
11003 case OP_NE:
11004 l_conval = const_fold(OP_CMP, lop->conval, rop->conval, ldtype);
11005 switch (op) {
11006 case OP_EQ:
11007 l_conval = (l_conval == 0);
11008 break;
11009 case OP_GE:
11010 l_conval = (l_conval >= 0);
11011 break;
11012 case OP_GT:
11013 l_conval = (l_conval > 0);
11014 break;
11015 case OP_LE:
11016 l_conval = (l_conval <= 0);
11017 break;
11018 case OP_LT:
11019 l_conval = (l_conval < 0);
11020 break;
11021 case OP_NE:
11022 l_conval = (l_conval != 0);
11023 break;
11024 }
11025 l_conval = l_conval ? SCFTN_TRUE : SCFTN_FALSE;
11026 root->conval = l_conval;
11027 break;
11028 case OP_LEQV:
11029 l_conval = const_fold(OP_CMP, lop->conval, rop->conval, ldtype);
11030 root->conval = (l_conval == 0);
11031 break;
11032 case OP_LNEQV:
11033 l_conval = const_fold(OP_CMP, lop->conval, rop->conval, ldtype);
11034 root->conval = (l_conval != 0);
11035 break;
11036 case OP_LOR:
11037 root->conval = lop->conval | rop->conval;
11038 break;
11039 case OP_LAND:
11040 root->conval = lop->conval & rop->conval;
11041 break;
11042 default:
11043 l_conval = lop->conval;
11044 if (lop->dtype != dt) {
11045 l_conval = cngcon(l_conval, lop->dtype, dt);
11046 }
11047 r_conval = rop->conval;
11048 if (rop->dtype != dt) {
11049 r_conval = cngcon(r_conval, rop->dtype, dt);
11050 }
11051 root->conval = const_fold(get_ast_op(op), l_conval, r_conval, dt);
11052 break;
11053 }
11054 }
11055 return root;
11056 }
11057
11058 static ACL *
eval_array_constructor(ACL * e)11059 eval_array_constructor(ACL *e)
11060 {
11061 ACL *root = NULL;
11062 ACL *cur_e;
11063 ACL *new_e;
11064
11065 /* collapse nested array contstructors */
11066 for (cur_e = e->subc; cur_e; cur_e = cur_e->next) {
11067 if (cur_e->id == AC_ACONST) {
11068 new_e = eval_array_constructor(cur_e);
11069 } else {
11070 new_e = eval_init_expr_item(cur_e);
11071 if (!new_e) {
11072 return 0;
11073 }
11074 if (new_e->id == AC_ACONST) {
11075 new_e = eval_array_constructor(new_e);
11076 }
11077 }
11078 add_to_list(new_e, &root);
11079 }
11080 return root;
11081 }
11082
11083 static ACL *
eval_init_expr_item(ACL * cur_e)11084 eval_init_expr_item(ACL *cur_e)
11085 {
11086 ACL *new_e = NULL;
11087 ACL *lop = NULL;
11088 ACL *rop = NULL;
11089 ACL *temp = NULL;
11090 int sptr;
11091
11092 switch (cur_e->id) {
11093 case AC_AST:
11094 if (A_TYPEG(cur_e->u1.ast) == A_ID &&
11095 DTY(A_DTYPEG(cur_e->u1.ast)) == TY_ARRAY) {
11096 sptr = A_SPTRG(cur_e->u1.ast);
11097 if (PARAMG(sptr)) {
11098 if (STYPEG(sptr) != ST_PARAM) {
11099 sptr = NMCNSTG(sptr);
11100 }
11101 new_e = clone_init_const(get_getitem_p(CONVAL2G(sptr)), TRUE);
11102 new_e = eval_init_expr(new_e);
11103 break;
11104 } else {
11105 return 0;
11106 }
11107 }
11108 /* ELSE FALL THRU */
11109 case AC_CONST:
11110 new_e = clone_init_const(cur_e, TRUE);
11111 if (new_e->id == AC_AST) {
11112 new_e->id = AC_CONST;
11113 new_e->conval = get_const_from_ast(new_e->u1.ast);
11114 }
11115 break;
11116 case AC_ICONST:
11117 new_e = clone_init_const(cur_e, TRUE);
11118 break;
11119 case AC_IEXPR:
11120 if (cur_e->u1.expr->op != AC_INTR_CALL) {
11121 lop = eval_init_expr(cur_e->u1.expr->lop);
11122 rop = temp = cur_e->u1.expr->rop;
11123 if (temp && cur_e->u1.expr->op == AC_ARRAYREF &&
11124 temp->u1.expr->op == AC_TRIPLE) {
11125 rop = eval_const_array_triple_section(temp);
11126 } else if (temp)
11127 rop = eval_init_expr(temp);
11128 } else {
11129 lop = cur_e->u1.expr->lop;
11130 rop = cur_e->u1.expr->rop;
11131 }
11132 new_e = eval_init_op(cur_e->u1.expr->op, lop, cur_e->u1.expr->lop->dtype,
11133 rop, rop ? cur_e->u1.expr->rop->dtype : 0, cur_e->sptr,
11134 cur_e->dtype);
11135 break;
11136 case AC_ACONST:
11137 new_e = clone_init_const(cur_e, TRUE);
11138 new_e->subc = eval_array_constructor(cur_e);
11139 if (new_e->subc)
11140 new_e->subc = convert_acl_dtype(new_e->subc, DDTG(new_e->subc->dtype),
11141 DDTG(new_e->dtype));
11142 break;
11143 case AC_SCONST:
11144 new_e = clone_init_const(cur_e, TRUE);
11145 new_e->subc = eval_init_expr(new_e->subc);
11146 break;
11147 case AC_IDO:
11148 new_e = eval_do(cur_e);
11149 break;
11150 case AC_CONVAL:
11151 new_e = cur_e;
11152 break;
11153 default:
11154 /* MORE internal error */
11155 break;
11156 }
11157
11158 return new_e;
11159 }
11160
11161 ACL *
eval_init_expr(ACL * e)11162 eval_init_expr(ACL *e)
11163 {
11164 ACL *root = NULL;
11165 ACL *cur_e;
11166 ACL *new_e;
11167
11168 for (cur_e = e; cur_e; cur_e = cur_e->next) {
11169 switch (cur_e->id) {
11170 case AC_SCONST:
11171 new_e = clone_init_const(cur_e, TRUE);
11172 new_e->subc = eval_init_expr(new_e->subc);
11173 if (!new_e->subc) {
11174 return 0;
11175 }
11176 if (new_e->subc->dtype == cur_e->dtype) {
11177 new_e->subc = new_e->subc->subc;
11178 }
11179 break;
11180 case AC_ACONST:
11181 new_e = clone_init_const(cur_e, TRUE);
11182 new_e->subc = eval_array_constructor(cur_e);
11183 if (new_e->subc)
11184 new_e->subc = convert_acl_dtype(new_e->subc, DDTG(new_e->subc->dtype),
11185 DDTG(new_e->dtype));
11186 break;
11187 default:
11188 new_e = eval_init_expr_item(cur_e);
11189 break;
11190 }
11191 if (!new_e) {
11192 return 0;
11193 }
11194 add_to_list(new_e, &root);
11195 }
11196
11197 return root;
11198 }
11199
11200 static ACL *
eval_do(ACL * ido)11201 eval_do(ACL *ido)
11202 {
11203 INT i;
11204 DOINFO *di = ido->u1.doinfo;
11205 INT initval;
11206 INT limitval;
11207 INT stepval;
11208 int idx_sptr = di->index_var;
11209 ACL *root = NULL;
11210 ACL *ict;
11211 INT num[2];
11212 INT sav_conval1 = CONVAL1G(idx_sptr);
11213 int inflag = 0;
11214
11215 initval = dinit_eval(di->init_expr);
11216 if (sem.dinit_error) {
11217 interr("Non-constant implied DO initial value", di->init_expr, 3);
11218 return 0;
11219 }
11220
11221 limitval = dinit_eval(di->limit_expr);
11222 if (sem.dinit_error) {
11223 interr("Non-constant implied DO limit value", di->init_expr, 3);
11224 return 0;
11225 }
11226
11227 stepval = dinit_eval(di->step_expr);
11228 if (sem.dinit_error) {
11229 interr("Non-constant implied DO step value", di->init_expr, 3);
11230 return 0;
11231 }
11232
11233 if (stepval >= 0) {
11234 for (i = initval; i <= limitval; i += stepval) {
11235 switch (DTY(DTYPEG(idx_sptr))) {
11236 case TY_INT8:
11237 case TY_LOG8:
11238 ISZ_2_INT64(i, num);
11239 /* implied do loop index variable is not A_CNST,
11240 * it is A_ID, so put it in CONVAL1P, so that
11241 * get_const_from_ast get it right.
11242 */
11243 CONVAL1P(idx_sptr, getcon(num, DTYPEG(idx_sptr)));
11244 break;
11245 default:
11246 CONVAL1P(idx_sptr, i);
11247 break;
11248 }
11249
11250 ict = eval_init_expr(ido->subc);
11251 if (!ict) {
11252 return 0;
11253 }
11254 ict->u1.ast = mk_cval1(ict->conval, ict->dtype);
11255 add_to_list(ict, &root);
11256 inflag = 1;
11257 }
11258 } else {
11259 for (i = initval; i >= limitval; i += stepval) {
11260 switch (DTY(DTYPEG(idx_sptr))) {
11261 case TY_INT8:
11262 case TY_LOG8:
11263 ISZ_2_INT64(i, num);
11264 CONVAL1P(idx_sptr, getcon(num, DTYPEG(idx_sptr)));
11265 break;
11266 default:
11267 CONVAL1P(idx_sptr, i);
11268 break;
11269 }
11270 ict = eval_init_expr(ido->subc);
11271 if (!ict) {
11272 return 0;
11273 }
11274 ict->u1.ast = mk_cval1(ict->conval, ict->dtype);
11275 add_to_list(ict, &root);
11276 inflag = 1;
11277 }
11278 }
11279 if (inflag == 0 && ido->subc) {
11280 ict = eval_init_expr(ido->subc);
11281 add_to_list(ict, &root);
11282 }
11283
11284 CONVAL1P(idx_sptr, sav_conval1);
11285
11286 return root;
11287 }
11288
11289 static INT
get_default_int_val(INT r)11290 get_default_int_val(INT r)
11291 {
11292 INT tmp[2];
11293 if (DTY(stb.user.dt_int) != TY_INT8) {
11294 return r;
11295 }
11296 tmp[1] = r;
11297 if (r >= 0)
11298 tmp[0] = 0;
11299 else
11300 tmp[0] = -1;
11301 return getcon(tmp, DT_INT8);
11302 }
11303
11304 VAR *
gen_varref_var(int ast,DTYPE dtype)11305 gen_varref_var(int ast, DTYPE dtype)
11306 {
11307 SST tmp_sst;
11308 VAR *ivl;
11309
11310 SST_IDP(&tmp_sst, S_IDENT);
11311 SST_ASTP(&tmp_sst, ast);
11312 SST_DTYPEP(&tmp_sst, dtype);
11313 SST_SHAPEP(&tmp_sst, A_SHAPEG(ast));
11314 ivl = dinit_varref(&tmp_sst);
11315
11316 return ivl;
11317 }
11318
11319 /** \brief Process an AC_TYPEINIT.
11320
11321 Look for an initialization template for this type. If one already exists
11322 then return it. Otherwise build one (and return it).
11323 */
11324 SPTR
get_dtype_init_template(DTYPE dtype)11325 get_dtype_init_template(DTYPE dtype)
11326 {
11327 DTYPE element_dtype =
11328 is_array_dtype(dtype) ? array_element_dtype(dtype) : dtype;
11329 SPTR tag_sptr = get_struct_tag_sptr(element_dtype);
11330 int init_ict = get_struct_initialization_tree(element_dtype);
11331 ACL *aclp, *tmpl_aclp;
11332 SPTR sptr = NOSYM;
11333 char namebuf[128];
11334 const char prefix[] = "_dtInit";
11335
11336 assert(DTY(element_dtype) == TY_DERIVED,
11337 "get_dtype_init_template: element dtype not derived", dtype,
11338 ERR_Fatal);
11339 aclp = get_getitem_p(init_ict);
11340 if (aclp) {
11341 assert(eq_dtype(DDTG(aclp->dtype), element_dtype),
11342 "get_dtype_init_template: element dtype mismatch", dtype, ERR_Fatal);
11343 }
11344
11345 if (is_unresolved_parameterized_dtype(element_dtype))
11346 return NOSYM;
11347
11348 if (tag_sptr > NOSYM) {
11349 if ((sptr = TYPDEF_INITG(tag_sptr)) > NOSYM &&
11350 (SCG(sptr) == SC_STATIC || SCG(sptr) == SC_CMBLK)) {
11351 /* Reuse an existing initialization template object. */
11352 return sptr;
11353 }
11354 }
11355 snprintf(namebuf, sizeof namebuf, ".%s%04d", prefix, (int)element_dtype);
11356 namebuf[sizeof namebuf - 1] = '\0'; /* Windows snprintf bug workaround */
11357
11358 /* no existing initialization template yet for this derived type; build one */
11359 if (aclp) {
11360 sptr = getccssym_sc(prefix, (int)element_dtype, ST_VAR, SC_STATIC);
11361 DTYPEP(sptr, element_dtype);
11362 DCLDP(sptr, TRUE);
11363 INITIALIZERP(sptr, TRUE);
11364
11365 tmpl_aclp = GET_ACL(15);
11366 *tmpl_aclp = *aclp;
11367 tmpl_aclp->sptr = sptr;
11368 dinit((VAR *)NULL, tmpl_aclp);
11369 if (tag_sptr > NOSYM)
11370 TYPDEF_INITP(tag_sptr, sptr);
11371 }
11372 return sptr;
11373 }
11374
11375 void
gen_derived_type_alloc_init(ITEM * itemp)11376 gen_derived_type_alloc_init(ITEM *itemp)
11377 {
11378 int ast = itemp->ast;
11379 DTYPE dtype = A_DTYPEG(ast);
11380 ACL *aclp;
11381 SPTR prototype;
11382 int ict = get_struct_initialization_tree(dtype);
11383
11384 if (ict == 0)
11385 return;
11386
11387 if ((aclp = get_getitem_p(ict)) && aclp->dtype &&
11388 (!dtype || !has_type_parameter(aclp->dtype)))
11389 dtype = aclp->dtype;
11390
11391 /* TODO: use init_derived_type() from semfin.c here instead? */
11392 prototype = get_dtype_init_template(dtype);
11393 if (prototype > NOSYM) {
11394 int src_ast = mk_id(prototype);
11395 add_stmt(mk_assn_stmt(itemp->ast, src_ast, A_DTYPEG(itemp->ast)));
11396 }
11397 }
11398
11399 static int firstalloc;
11400
11401 void
check_dealloc_clauses(ITEM * list,ITEM * spec)11402 check_dealloc_clauses(ITEM *list, ITEM *spec)
11403 {
11404 ITEM *itemp;
11405 int stat = 0;
11406 int errmsg = 0;
11407
11408 if (list == 0)
11409 list = ITEM_END;
11410 if (spec == 0)
11411 spec = ITEM_END;
11412 firstalloc = 1;
11413 for (itemp = spec; itemp != ITEM_END; itemp = itemp->next) {
11414 switch (itemp->t.conval) {
11415 case TK_STAT:
11416 if (stat == 1)
11417 error(155, 2, gbl.lineno, "Multiple STAT specifiers", CNULL);
11418 stat++;
11419 break;
11420 case TK_ERRMSG:
11421 if (errmsg == 1)
11422 error(155, 2, gbl.lineno, "Multiple ERRMSG specifiers", CNULL);
11423 errmsg++;
11424 break;
11425 default:
11426 error(155, 3, gbl.lineno, tokname[itemp->t.conval],
11427 "specifier invalid in DEALLOCATE");
11428 }
11429 }
11430 }
11431
11432 void
check_alloc_clauses(ITEM * list,ITEM * spec,int * srcast,int * mold_or_src)11433 check_alloc_clauses(ITEM *list, ITEM *spec, int *srcast, int *mold_or_src)
11434 {
11435 ITEM *itemp;
11436 int stat = 0;
11437 int pinned = 0;
11438 int errmsg = 0;
11439 int source = 0;
11440
11441 *srcast = 0;
11442 *mold_or_src = 0;
11443
11444 if (list == 0)
11445 list = ITEM_END;
11446 if (spec == 0)
11447 spec = ITEM_END;
11448 firstalloc = 1;
11449 for (itemp = spec; itemp != ITEM_END; itemp = itemp->next) {
11450 switch (itemp->t.conval) {
11451 case TK_STAT:
11452 if (stat == 1)
11453 error(155, 2, gbl.lineno, "Multiple STAT specifiers", CNULL);
11454 stat++;
11455 break;
11456 case TK_ERRMSG:
11457 if (errmsg == 1)
11458 error(155, 2, gbl.lineno, "Multiple ERRMSG specifiers", CNULL);
11459 errmsg++;
11460 break;
11461 case TK_SOURCE:
11462 case TK_MOLD:
11463 if (source == 1)
11464 error(155, 2, gbl.lineno, "Multiple SOURCE/MOLD specifiers", CNULL);
11465 source++;
11466 *srcast = itemp->ast;
11467 *mold_or_src = itemp->t.conval;
11468 break;
11469 case TK_ALIGN:
11470 break;
11471 }
11472 }
11473 }
11474
11475 int
gen_alloc_dealloc(int stmtyp,int object,ITEM * spec)11476 gen_alloc_dealloc(int stmtyp, int object, ITEM *spec)
11477 {
11478 int ast;
11479 ITEM *itemp;
11480 int sptr, objectsptr, sptr1;
11481 DTYPE dtype;
11482 int stmt;
11483 int store_stat = 0;
11484 int store_pinned = 0;
11485 int len_stmt;
11486
11487 if (spec == 0)
11488 spec = ITEM_END;
11489 objectsptr = sym_of_ast(object);
11490 ast = mk_stmt(A_ALLOC, 0);
11491 A_TKNP(ast, stmtyp); /* TK_ALLOCATE/TK_DEALLOCATE */
11492 A_SRCP(ast, object); /* object (ast) to be allocated/deallocated */
11493 A_FIRSTALLOCP(ast, firstalloc);
11494 firstalloc = 0;
11495 for (itemp = spec; itemp != ITEM_END; itemp = itemp->next) {
11496 switch (itemp->t.conval) {
11497 case TK_STAT:
11498 sptr = sym_of_ast(itemp->ast);
11499 dtype = DTYPEG(sptr);
11500 if (DTYG(dtype) == TY_INT8) {
11501 int tmp;
11502 tmp = mk_id(get_temp(DT_INT4));
11503 store_stat = mk_assn_stmt(itemp->ast, tmp, dtype);
11504 itemp->ast = tmp;
11505 }
11506 if (dtype != DT_INT && flg.standard && !XBIT(124, 0x10))
11507 error(155, 2, gbl.lineno, "Invalid type for STATUS specifier",
11508 SYMNAME(sptr));
11509 A_LOPP(ast, itemp->ast);
11510 break;
11511 case TK_ERRMSG:
11512 A_M3P(ast, itemp->ast);
11513 break;
11514 case TK_SOURCE:
11515 case TK_MOLD:
11516 A_STARTP(ast, itemp->ast);
11517 break;
11518 case TK_ALIGN:
11519 A_ALIGNP(ast, itemp->ast);
11520 break;
11521 }
11522 }
11523 stmt = add_stmt(ast);
11524
11525 sem.alloc_std = stmt; /* std of allocate */
11526
11527 /* This is for allocate statement, must set length before allocate
11528 * sem.gcvlen supposedly gets set only when it is character
11529 */
11530 if (is_deferlenchar_ast(object) &&
11531 stmtyp == TK_ALLOCATE) {
11532 if (sem.gcvlen) {
11533 len_stmt =
11534 mk_assn_stmt(get_len_of_deferchar_ast(object), sem.gcvlen, DT_INT);
11535 stmt = add_stmt_before(len_stmt, stmt);
11536 } else {
11537 #if DEBUG
11538 assert(sem.gcvlen != 0, "gen_alloc_dealloc: character size missing", 3,
11539 object);
11540 #endif
11541 }
11542 }
11543
11544 if (store_stat) {
11545 stmt = add_stmt_after(store_stat, stmt);
11546 }
11547 if (store_pinned) {
11548 add_stmt_after(store_pinned, stmt);
11549 }
11550
11551 return ast;
11552 }
11553
11554 /** \brief If temps were allocated while processing the expression, the
11555 expression
11556 needs to be assigned to a temp, the allocatable temps need to be
11557 deallocated, and the use of the expression is replaced by the temp.
11558 */
11559 int
check_etmp(SST * stkp)11560 check_etmp(SST *stkp)
11561 {
11562 int new, ast;
11563
11564 sem.use_etmps = FALSE;
11565 if (sem.etmp_list == NULL)
11566 return SST_ASTG(stkp);
11567 /*
11568 * Create a new temp, generate an assignment of the expression to
11569 * the temp.
11570 */
11571 ast = sem_tempify(stkp);
11572 (void)add_stmt(ast);
11573 new = A_DESTG(ast);
11574 gen_dealloc_etmps();
11575 return new;
11576 }
11577
11578 void
gen_dealloc_etmps(void)11579 gen_dealloc_etmps(void)
11580 {
11581 int sptr;
11582
11583 while (sem.etmp_list) {
11584 /* insert a deallocate for the symbol at this item */
11585 sptr = sem.etmp_list->t.sptr;
11586 if (sptr)
11587 gen_alloc_dealloc(TK_DEALLOCATE, mk_id(sptr), 0);
11588 sem.etmp_list = sem.etmp_list->next;
11589 }
11590 sem.use_etmps = FALSE;
11591 }
11592
11593 void
check_and_add_auto_dealloc_from_ast(int ast)11594 check_and_add_auto_dealloc_from_ast(int ast)
11595 {
11596 int sptr = sym_of_ast(ast);
11597
11598 check_and_add_auto_dealloc(sptr);
11599 }
11600
11601 void
check_and_add_auto_dealloc(int sptr)11602 check_and_add_auto_dealloc(int sptr)
11603 {
11604 if (gbl.rutype != RU_FUNC && gbl.rutype != RU_SUBR)
11605 return;
11606 if (SCG(sptr) != SC_BASED)
11607 return;
11608 if (!ALLOCG(sptr) || POINTERG(sptr) || SAVEG(sptr) || sem.savall)
11609 return;
11610 if (!ALLOCATTRG(sptr) && MIDNUMG(sptr) && PTRVG(MIDNUMG(sptr)))
11611 return;
11612 if (MIDNUMG(sptr))
11613 switch (SCG(MIDNUMG(sptr))) {
11614 case SC_CMBLK:
11615 case SC_PRIVATE:
11616 return;
11617 default:
11618 break;
11619 }
11620 if (sem.scope_stack &&
11621 SCOPEG(sptr) == sem.scope_stack[sem.scope_level].sptr) {
11622 add_auto_dealloc(sptr);
11623 }
11624 }
11625
11626 void
add_auto_dealloc(int sptr)11627 add_auto_dealloc(int sptr)
11628 {
11629 ITEM *itemp;
11630 for (itemp = sem.auto_dealloc; itemp; itemp = itemp->next) {
11631 if (itemp->t.sptr == sptr) {
11632 return;
11633 }
11634 }
11635 itemp = (ITEM *)getitem(15, sizeof(ITEM));
11636 itemp->t.sptr = sptr;
11637 itemp->next = sem.auto_dealloc;
11638 sem.auto_dealloc = itemp;
11639 }
11640
11641 static void
add_alloc_mem_initialize(int sptr)11642 add_alloc_mem_initialize(int sptr)
11643 {
11644 ITEM *itemp;
11645
11646 if (DTY(DTYPEG(sptr)) != TY_DERIVED || ALLOCATTRG(sptr) || POINTERG(sptr) ||
11647 !allocatable_member(sptr))
11648 return;
11649
11650 for (itemp = sem.alloc_mem_initialize; itemp; itemp = itemp->next) {
11651 if (itemp->t.sptr == sptr) {
11652 return;
11653 }
11654 }
11655 itemp = (ITEM *)getitem(15, sizeof(ITEM));
11656 itemp->t.sptr = sptr;
11657 itemp->next = sem.alloc_mem_initialize;
11658 sem.alloc_mem_initialize = itemp;
11659 }
11660
11661 void
add_type_param_initialize(int sptr)11662 add_type_param_initialize(int sptr)
11663 {
11664 ITEM *itemp;
11665 DTYPE dtype = DTYPEG(sptr);
11666 if (DTY(dtype) == TY_ARRAY)
11667 dtype = DTY(dtype + 1);
11668 if (DTY(dtype) != TY_DERIVED || !has_type_parameter(dtype))
11669 return;
11670 for (itemp = sem.type_initialize; itemp; itemp = itemp->next) {
11671 if (itemp->t.sptr == sptr) {
11672 return;
11673 }
11674 }
11675 itemp = (ITEM *)getitem(15, sizeof(ITEM));
11676 itemp->t.sptr = sptr;
11677 itemp->next = sem.type_initialize;
11678 sem.type_initialize = itemp;
11679 }
11680
11681 void
add_auto_finalize(int sptr)11682 add_auto_finalize(int sptr)
11683 {
11684 ITEM *itemp;
11685 for (itemp = sem.auto_finalize; itemp; itemp = itemp->next) {
11686 if (itemp->t.sptr == sptr) {
11687 return;
11688 }
11689 }
11690 itemp = (ITEM *)getitem(15, sizeof(ITEM));
11691 itemp->t.sptr = sptr;
11692 itemp->next = sem.auto_finalize;
11693 sem.auto_finalize = itemp;
11694 }
11695
11696 int
gen_finalization_for_sym(int sptr,int std,int memAst)11697 gen_finalization_for_sym(int sptr, int std, int memAst)
11698 {
11699 int fsptr;
11700 int argt;
11701 int ast;
11702 int desc;
11703 DTYPE dtype;
11704 int tag, st_type;
11705 FtnRtlEnum rtlRtn;
11706
11707 if (SAVEG(sptr) || sem.savall || !has_finalized_component(sptr))
11708 return std; /* no finalization needed */
11709
11710 if (DTY(DTYPEG(sptr)) == TY_ARRAY) {
11711 if (SDSCG(sptr) == 0) {
11712 get_static_descriptor(sptr);
11713 std = add_stmt_after(mk_stmt(A_CONTINUE, 0), std);
11714 std = init_sdsc(sptr, DTYPEG(sptr), std, 0);
11715 }
11716 desc = SDSCG(sptr);
11717
11718 dtype = DTYPEG(sptr);
11719
11720 dtype = DTY(dtype + 1);
11721 if (DTY(dtype) == TY_DERIVED) {
11722 int arg0;
11723 tag = DTY(dtype + 3);
11724 st_type = get_static_type_descriptor(tag);
11725 arg0 = check_member(memAst, mk_id(desc));
11726 std = gen_set_type(arg0, mk_id(st_type), std, FALSE, FALSE);
11727 }
11728 } else {
11729 desc = get_type_descr_arg(gbl.currsub, sptr);
11730 }
11731 rtlRtn = RTE_finalize;
11732 fsptr = sym_mkfunc_nodesc(mkRteRtnNm(rtlRtn), DT_NONE);
11733 argt = mk_argt(2);
11734
11735 ARGT_ARG(argt, 0) = check_member(memAst, mk_id(sptr));
11736 ARGT_ARG(argt, 1) = check_member(memAst, mk_id(desc));
11737
11738 ast = mk_id(fsptr);
11739 ast = mk_func_node(A_CALL, ast, 2, argt);
11740 std = add_stmt_after(ast, std);
11741 return std;
11742 }
11743
11744 static int
get_parm_ast(int parent,SPTR sptr,DTYPE dtype)11745 get_parm_ast(int parent, SPTR sptr, DTYPE dtype)
11746 {
11747 int mem, rslt, ast;
11748 if (DTY(dtype) == TY_ARRAY)
11749 dtype = DTY(dtype + 1);
11750 for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
11751 if (PARENTG(mem)) {
11752 ast = mk_member(parent, mk_id(mem), dtype);
11753 rslt = get_parm_ast(ast, sptr, DTYPEG(mem));
11754 if (rslt)
11755 return rslt;
11756 }
11757 if (strcmp(SYMNAME(sptr), SYMNAME(mem)) == 0) {
11758 ast = mk_member(parent, mk_id(mem), /*dtype*/ DTYPEG(mem));
11759 return ast;
11760 }
11761 }
11762 return 0;
11763 }
11764
11765 static int
remove_parent_from_ast(int ast)11766 remove_parent_from_ast(int ast)
11767 {
11768 int i, newast, newast2, nargs, newargs, orig_args;
11769 int asd;
11770
11771 switch (A_TYPEG(ast)) {
11772 case A_INTR:
11773 switch (A_OPTYPEG(ast)) {
11774 case I_INT1:
11775 case I_INT2:
11776 case I_INT4:
11777 case I_INT8:
11778 case I_INT:
11779 orig_args = A_ARGSG(ast);
11780 newast = remove_parent_from_ast(ARGT_ARG(orig_args, 0));
11781 newast2 = mk_stmt(A_INTR, A_DTYPEG(ast));
11782 A_OPTYPEP(newast2, A_OPTYPEG(ast));
11783 nargs = A_ARGCNTG(ast);
11784 newargs = mk_argt(nargs);
11785 ARGT_ARG(newargs, 0) = newast;
11786 for (i = 1; i < nargs; ++i)
11787 ARGT_ARG(newargs, i) = ARGT_ARG(orig_args, i);
11788 A_ARGSP(newast2, newargs);
11789 A_ARGCNTP(newast2, nargs);
11790 ast = newast;
11791 }
11792 break;
11793 case A_MEM:
11794 ast = mk_id(memsym_of_ast(ast));
11795 break;
11796 case A_CNST:
11797 break;
11798 case A_ID:
11799 break;
11800 case A_SUBSCR:
11801 asd = A_ASDG(ast);
11802 newast = remove_parent_from_ast(A_LOPG(ast));
11803 ast = mk_subscr_copy(newast, asd, A_DTYPEG(newast));
11804 break;
11805 case A_UNOP:
11806 newast = remove_parent_from_ast(A_LOPG(ast));
11807 ast = mk_unop(A_OPTYPEG(ast), newast, A_DTYPEG(ast));
11808 break;
11809 case A_CONV:
11810 newast = remove_parent_from_ast(A_LOPG(ast));
11811 ast = mk_convert(newast, A_DTYPEG(ast));
11812 break;
11813 case A_BINOP:
11814 newast = remove_parent_from_ast(A_LOPG(ast));
11815 newast2 = remove_parent_from_ast(A_ROPG(ast));
11816 ast = mk_binop(A_OPTYPEG(ast), newast, newast2, A_DTYPEG(ast));
11817 break;
11818 default:
11819 interr("remove_parent_from_ast: unexpected ast type", A_TYPEG(ast), 3);
11820 }
11821 return ast;
11822 }
11823
11824 int
add_parent_to_bounds(int parent,int ast)11825 add_parent_to_bounds(int parent, int ast)
11826 {
11827 int newast, i;
11828 if (parent == 0)
11829 return ast;
11830 switch (A_TYPEG(ast)) {
11831 case A_INTR:
11832 switch (A_OPTYPEG(ast)) {
11833 case I_INT1:
11834 case I_INT2:
11835 case I_INT4:
11836 case I_INT8:
11837 case I_INT:
11838 i = A_ARGSG(ast);
11839 newast = add_parent_to_bounds(parent, ARGT_ARG(i, 0));
11840 ARGT_ARG(i, 0) = newast;
11841 }
11842 break;
11843 case A_MEM:
11844 if (A_PARENTG(ast) == parent) {
11845 break;
11846 }
11847
11848 if (!A_PARENTG(ast)) {
11849 A_PARENTP(ast, parent);
11850 break;
11851 }
11852
11853 newast = add_parent_to_bounds(parent, A_PARENTG(ast));
11854 if (newast)
11855 A_PARENTP(ast, newast);
11856
11857 break;
11858 case A_CNST:
11859 break;
11860 case A_ID:
11861 newast = get_parm_ast(parent, sym_of_ast(ast), DTYPEG(sym_of_ast(parent)));
11862 if (newast)
11863 ast = newast;
11864 break;
11865 case A_SUBSCR:
11866 case A_UNOP:
11867 case A_CONV:
11868 newast = add_parent_to_bounds(parent, A_LOPG(ast));
11869 A_LOPP(ast, newast);
11870 break;
11871 case A_BINOP:
11872 newast = add_parent_to_bounds(parent, A_LOPG(ast));
11873 A_LOPP(ast, newast);
11874 newast = add_parent_to_bounds(parent, A_ROPG(ast));
11875 A_ROPP(ast, newast);
11876 break;
11877 default:
11878 interr("add_parent_to_bounds: unexpected ast type", A_TYPEG(ast), 3);
11879 }
11880 return ast;
11881 }
11882
11883 int
fix_mem_bounds(int parent,int mem)11884 fix_mem_bounds(int parent, int mem)
11885 {
11886 ADSC *ad;
11887 int numdim, i, bndast;
11888 int all_cnst;
11889 int zbase;
11890
11891 ad = AD_DPTR(DTYPEG(mem));
11892 numdim = AD_NUMDIM(ad);
11893 all_cnst = 1;
11894 zbase = AD_ZBASE(ad);
11895 if (zbase && A_TYPEG(zbase)) {
11896 AD_ZBASE(ad) = add_parent_to_bounds(parent, zbase);
11897 }
11898 for (i = 0; i < numdim; i++) {
11899 bndast = AD_LWAST(ad, i);
11900 if (bndast) {
11901 AD_LWAST(ad, i) = add_parent_to_bounds(parent, bndast);
11902 if (A_TYPEG(AD_LWAST(ad, i)) != A_CNST)
11903 all_cnst = 0;
11904 }
11905 bndast = AD_UPAST(ad, i);
11906 if (bndast) {
11907 AD_UPAST(ad, i) = add_parent_to_bounds(parent, bndast);
11908 if (A_TYPEG(AD_UPAST(ad, i)) != A_CNST)
11909 all_cnst = 0;
11910 }
11911 bndast = AD_EXTNTAST(ad, i);
11912 if (bndast) {
11913 AD_EXTNTAST(ad, i) = add_parent_to_bounds(parent, bndast);
11914 }
11915 }
11916
11917 return all_cnst;
11918 }
11919
11920 int
fix_mem_bounds2(int parent,int mem)11921 fix_mem_bounds2(int parent, int mem)
11922 {
11923 ADSC *ad, *bd;
11924 int numdim, i, bndast;
11925 int all_cnst;
11926 int zbase;
11927 int mem_dtype;
11928 int new_dtype;
11929
11930 /* This function is the same as fix_mem_bounds() above except we
11931 * assign a new dtype with mem that includes a new array descriptor.
11932 * Otherwise, we may overwrite a shared array descriptor with new
11933 * bounds information.
11934 */
11935
11936 mem_dtype = new_dtype = DTYPEG(mem);
11937 new_dtype = dup_array_dtype(new_dtype);
11938
11939 numdim = ADD_NUMDIM(mem_dtype);
11940 get_aux_arrdsc(new_dtype, numdim);
11941 bd = AD_DPTR(new_dtype);
11942 ad = AD_DPTR(mem_dtype);
11943
11944 /* Step 1: Construct bd w/ fields from mem_dtype minus any existing parent */
11945
11946 all_cnst = 1;
11947 zbase = ADD_ZBASE(mem_dtype);
11948 if (zbase && A_TYPEG(zbase)) {
11949 AD_ZBASE(bd) = remove_parent_from_ast(zbase);
11950 }
11951
11952 for (i = 0; i < numdim; i++) {
11953 bndast = ADD_LWAST(mem_dtype, i);
11954 if (bndast) {
11955 AD_LWBD(bd, i) = AD_LWAST(bd, i) = remove_parent_from_ast(bndast);
11956 if (A_TYPEG(ADD_LWAST(mem_dtype, i)) != A_CNST)
11957 all_cnst = 0;
11958 }
11959 bndast = ADD_UPAST(mem_dtype, i);
11960 if (bndast) {
11961 AD_UPBD(bd, i) = AD_UPAST(bd, i) = remove_parent_from_ast(bndast);
11962 if (A_TYPEG(ADD_UPAST(mem_dtype, i)) != A_CNST)
11963 all_cnst = 0;
11964 }
11965 bndast = ADD_EXTNTAST(mem_dtype, i);
11966 if (bndast) {
11967 AD_EXTNTAST(bd, i) = remove_parent_from_ast(bndast);
11968 }
11969 }
11970
11971 if (all_cnst)
11972 return 1;
11973
11974 AD_DEFER(bd) = AD_DEFER(ad);
11975 /* Step 2: Fill in parent into new array descriptor */
11976 ad = bd;
11977
11978 all_cnst = 1;
11979 zbase = AD_ZBASE(ad);
11980 if (zbase && A_TYPEG(zbase)) {
11981 AD_ZBASE(ad) = add_parent_to_bounds(parent, zbase);
11982 }
11983 for (i = 0; i < numdim; i++) {
11984 bndast = AD_LWAST(ad, i);
11985 if (bndast) {
11986 AD_LWAST(ad, i) = add_parent_to_bounds(parent, bndast);
11987 if (A_TYPEG(AD_LWAST(ad, i)) != A_CNST)
11988 all_cnst = 0;
11989 }
11990 bndast = AD_UPAST(ad, i);
11991 if (bndast) {
11992 AD_UPAST(ad, i) = add_parent_to_bounds(parent, bndast);
11993 if (A_TYPEG(AD_UPAST(ad, i)) != A_CNST)
11994 all_cnst = 0;
11995 }
11996 bndast = AD_EXTNTAST(ad, i);
11997 if (bndast) {
11998 AD_EXTNTAST(ad, i) = add_parent_to_bounds(parent, bndast);
11999 }
12000 }
12001
12002 DTYPEP(mem, new_dtype);
12003
12004 return all_cnst;
12005 }
12006
12007 /*
12008 * insert an assignment statement
12009 */
12010 static int
insert_assign(int lhs,int rhs,int std)12011 insert_assign(int lhs, int rhs, int std)
12012 {
12013 int newasn, newstd;
12014 if (lhs == rhs)
12015 return std;
12016 newasn = mk_assn_stmt(lhs, rhs, 0);
12017 newstd = add_stmt_after(newasn, std);
12018 return newstd;
12019 } /* insert_assign */
12020
12021 static int
get_header_member(int sdsc_ast,int info)12022 get_header_member(int sdsc_ast, int info)
12023 {
12024 int ast;
12025 int subs[1];
12026
12027 subs[0] = mk_isz_cval(info, astb.bnd.dtype);
12028 ast = mk_subscr(sdsc_ast, subs, 1, astb.bnd.dtype);
12029 return ast;
12030 }
12031
12032 static int
size_of_dtype(DTYPE dtype,SPTR sptr,int memberast)12033 size_of_dtype(DTYPE dtype, SPTR sptr, int memberast)
12034 {
12035 int sizeAst;
12036 if (DTY(dtype) == TY_CHAR) {
12037 /* assumed length character */
12038 if (dtype == DT_ASSCHAR || dtype == DT_DEFERCHAR) {
12039 sizeAst = sym_mkfunc_nodesc(mkRteRtnNm(RTE_lena), astb.bnd.dtype);
12040 sizeAst = begin_call(A_FUNC, sizeAst, 1);
12041 add_arg(check_member(memberast, mk_id(sptr)));
12042 } else {
12043 int clen;
12044 clen = DTY(dtype + 1);
12045 if (A_ALIASG(clen)) {
12046 sizeAst = A_ALIASG(clen);
12047 } else {
12048 sizeAst = clen;
12049 }
12050 sizeAst = mk_bnd_int(sizeAst);
12051 }
12052 } else {
12053 sizeAst = mk_isz_cval(size_of(dtype), astb.bnd.dtype);
12054 }
12055 return sizeAst;
12056 }
12057
12058 int
init_sdsc(int sptr,DTYPE dtype,int before_std,int parent_sptr)12059 init_sdsc(int sptr, DTYPE dtype, int before_std, int parent_sptr)
12060 {
12061 int sptrsdsc = SDSCG(sptr);
12062 ADSC *ad = AD_DPTR(dtype);
12063 int ndims = AD_NUMDIM(ad);
12064 int nargs = 5 + ndims * 2;
12065 int argt = mk_argt(nargs);
12066 int fsptr = sym_mkfunc(mkRteRtnNm(RTE_template), DT_NONE);
12067 int sptrsdsc_arg, ast, i, std;
12068
12069 assert(sptrsdsc > NOSYM, "init_sdsc: sptr has no SDSC", sptr, ERR_Fatal);
12070 sptrsdsc_arg = mk_id(sptrsdsc);
12071 if (STYPEG(sptrsdsc) == ST_MEMBER) {
12072 assert(STYPEG(sptrsdsc) != ST_MEMBER || parent_sptr > NOSYM,
12073 "init_sdsc: sptrdsc is member but no parent sptr", sptrsdsc,
12074 ERR_Fatal);
12075 sptrsdsc_arg = mk_member(mk_id(parent_sptr), sptrsdsc_arg, dtype);
12076 }
12077
12078 /* call RTE_template(desc, rank, flags, kind, len, {lb, ub}+) */
12079 ARGT_ARG(argt, 0) = sptrsdsc_arg;
12080 ARGT_ARG(argt, 1) = mk_isz_cval(ndims, astb.bnd.dtype);
12081 ARGT_ARG(argt, 2) = mk_isz_cval(0, astb.bnd.dtype);
12082 ARGT_ARG(argt, 3) = mk_isz_cval(dtype_to_arg(dtype + 1), astb.bnd.dtype);
12083 ARGT_ARG(argt, 4) = size_of_dtype(DDTG(dtype), sptr, 0);
12084
12085 for (i = 0; i < ndims; ++i) {
12086 ARGT_ARG(argt, 5 + 2 * i) = AD_LWAST(ad, i);
12087 ARGT_ARG(argt, 6 + 2 * i) = AD_UPAST(ad, i);
12088 }
12089
12090 ast =
12091 mk_func_node(A_CALL, mk_id(sym_mkfunc(mkRteRtnNm(RTE_template), DT_NONE)),
12092 nargs, argt);
12093 SDSCINITP(sptr, TRUE);
12094 A_DTYPEP(ast, DT_INT);
12095 NODESCP(fsptr, TRUE);
12096 std = add_stmt_before(ast, before_std);
12097
12098 /* call pghpf_instance(dest desc, targ desc, kind,len, 0) */
12099 argt = mk_argt(nargs = 5);
12100 ARGT_ARG(argt, 0) = sptrsdsc_arg;
12101 ARGT_ARG(argt, 1) = sptrsdsc_arg;
12102 ARGT_ARG(argt, 2) = mk_isz_cval(dtype_to_arg(dtype + 1), astb.bnd.dtype);
12103 ARGT_ARG(argt, 3) = size_of_dtype(DDTG(dtype), sptr, ast);
12104 ARGT_ARG(argt, 4) = mk_isz_cval(0, astb.bnd.dtype);
12105
12106 ast =
12107 mk_func_node(A_CALL, mk_id(sym_mkfunc(mkRteRtnNm(RTE_instance), DT_NONE)),
12108 nargs, argt);
12109 return add_stmt_after(ast, std);
12110 }
12111
12112 /** \brief Similar to init_sdsc() above, but it's also used to initialize
12113 * a descriptor's bounds from a subscript expression.
12114 *
12115 * \param sptr is the symbol table pointer of the symbol with the descriptor
12116 * to initialize.
12117 * \param dtype is the dtype used for initializing the descriptor.
12118 * \param before_std is the statement descriptor where we want to insert the
12119 * initialization code (inserted before this std).
12120 * \param parent_sptr is the symbol table pointer of the enclosing object
12121 * if sptr is an ST_MEMBER. Otherwise, it can be 0.
12122 * \param subscr is an AST representing the subscript expression that contains
12123 * the array bounds. If it's not an A_SUBSCR, then init_sdsc() is
12124 * called instead.
12125 * \param td_ast is an AST representing the descriptor that we are creating
12126 * an instance of.
12127 *
12128 * \return a statement descriptor of the generated statements.
12129 */
12130 int
init_sdsc_bounds(SPTR sptr,DTYPE dtype,int before_std,SPTR parent_sptr,int subscr,int td_ast)12131 init_sdsc_bounds(SPTR sptr, DTYPE dtype, int before_std, SPTR parent_sptr,
12132 int subscr, int td_ast)
12133 {
12134 SPTR sptrsdsc = SDSCG(sptr);
12135 ADSC *ad = AD_DPTR(dtype);
12136 int ndims = AD_NUMDIM(ad);
12137 int nargs = 5 + ndims * 2;
12138 int argt = mk_argt(nargs);
12139 SPTR fsptr = sym_mkfunc(mkRteRtnNm(RTE_template), DT_NONE);
12140 int sptrsdsc_arg, ast, i, std;
12141 int asd, triplet, stride;
12142
12143 if (!subscr || A_TYPEG(subscr) != A_SUBSCR) {
12144 return init_sdsc(sptr, dtype, before_std, parent_sptr);
12145 }
12146 assert(sptrsdsc > NOSYM, "init_sdsc_bounds: sptr has no SDSC", sptr,
12147 ERR_Fatal);
12148 sptrsdsc_arg = mk_id(sptrsdsc);
12149 if (STYPEG(sptrsdsc) == ST_MEMBER) {
12150 assert(STYPEG(sptrsdsc) != ST_MEMBER || parent_sptr > NOSYM,
12151 "init_sdsc_bounds: sptrdsc is member but no parent sptr", sptrsdsc,
12152 ERR_Fatal);
12153 sptrsdsc_arg = mk_member(mk_id(parent_sptr), sptrsdsc_arg, dtype);
12154 }
12155
12156 /* call RTE_template(desc, rank, flags, kind, len, {lb, ub}+) */
12157 ARGT_ARG(argt, 0) = sptrsdsc_arg;
12158 ARGT_ARG(argt, 1) = mk_isz_cval(ndims, astb.bnd.dtype);
12159 ARGT_ARG(argt, 2) = mk_isz_cval(0, astb.bnd.dtype);
12160 ARGT_ARG(argt, 3) = mk_isz_cval(dtype_to_arg(dtype + 1), astb.bnd.dtype);
12161 ARGT_ARG(argt, 4) = size_of_dtype(DDTG(dtype), sptr, 0);
12162
12163 asd = A_ASDG(subscr);
12164 for (i = 0; i < ndims; ++i) {
12165 triplet = ASD_SUBS(asd, i);
12166 if ((stride = A_STRIDEG(triplet)) != 0 && A_TYPEG(stride) == A_CNST &&
12167 ad_val_of(A_SPTRG(stride)) < 0) {
12168 ARGT_ARG(argt, 5 + 2 * i) = mk_bnd_int(A_UPBDG(triplet));
12169 ARGT_ARG(argt, 6 + 2 * i) = mk_bnd_int(A_LBDG(triplet));
12170 } else {
12171 ARGT_ARG(argt, 5 + 2 * i) = mk_bnd_int(A_LBDG(triplet));
12172 ARGT_ARG(argt, 6 + 2 * i) = mk_bnd_int(A_UPBDG(triplet));
12173 }
12174 }
12175
12176 ast =
12177 mk_func_node(A_CALL, mk_id(sym_mkfunc(mkRteRtnNm(RTE_template), DT_NONE)),
12178 nargs, argt);
12179 SDSCINITP(sptr, TRUE);
12180 A_DTYPEP(ast, DT_INT);
12181 NODESCP(fsptr, TRUE);
12182 std = add_stmt_before(ast, before_std);
12183
12184 /* call pghpf_instance(dest desc, targ desc, kind,len, 0) */
12185 argt = mk_argt(nargs = 5);
12186 ARGT_ARG(argt, 0) = td_ast != 0 ? td_ast : sptrsdsc_arg;
12187 ARGT_ARG(argt, 1) = sptrsdsc_arg;
12188 ARGT_ARG(argt, 2) = mk_isz_cval(dtype_to_arg(dtype + 1), astb.bnd.dtype);
12189 ARGT_ARG(argt, 3) = size_of_dtype(DDTG(dtype), sptr, ast);
12190 ARGT_ARG(argt, 4) = mk_isz_cval(0, astb.bnd.dtype);
12191
12192 ast =
12193 mk_func_node(A_CALL, mk_id(sym_mkfunc(mkRteRtnNm(RTE_instance), DT_NONE)),
12194 nargs, argt);
12195 return add_stmt_after(ast, std);
12196 }
12197
12198 static int
genPolyAsn(int dest,int src,int std,int parentMem)12199 genPolyAsn(int dest, int src, int std, int parentMem)
12200 {
12201 int argt, flag_con, astdest, dest_sdsc_ast, astsrc, src_sdsc_ast, fsptr;
12202 int ast;
12203
12204 astsrc = mk_id(src);
12205
12206 if (!parentMem) {
12207 if (!SDSCG(dest))
12208 get_static_descriptor(dest);
12209
12210 dest_sdsc_ast = mk_id(SDSCG(dest));
12211
12212 astdest = mk_id(dest);
12213 } else {
12214 int sdsc_mem = get_member_descriptor(dest);
12215 if (sdsc_mem > NOSYM) {
12216 int parentDty = DTYPEG(sym_of_ast(parentMem));
12217 if (DTY(parentDty) == TY_ARRAY)
12218 parentDty = DTY(parentDty + 1);
12219 dest_sdsc_ast = check_member(parentMem, mk_id(sdsc_mem));
12220 } else {
12221 if (!SDSCG(dest)) {
12222 get_static_descriptor(dest);
12223 }
12224 dest_sdsc_ast = mk_id(SDSCG(dest));
12225 }
12226
12227 astdest = check_member(parentMem, mk_id(dest));
12228 }
12229
12230 src_sdsc_ast = mk_id(get_static_type_descriptor(src));
12231 if (dest_sdsc_ast) {
12232 std = gen_set_type(dest_sdsc_ast, src_sdsc_ast, std, FALSE, FALSE);
12233 }
12234
12235 std = add_stmt_after(mk_stmt(A_CONTINUE, 0), std);
12236 std = init_sdsc(dest, parentMem ? A_DTYPEG(parentMem) : DTYPEG(dest), std,
12237 parentMem ? sym_of_ast(parentMem) : 0);
12238
12239 fsptr = sym_mkfunc_nodesc(mkRteRtnNm(RTE_poly_asn), DT_NONE);
12240 argt = mk_argt(5);
12241 flag_con = mk_cval1(1, DT_INT);
12242 flag_con = mk_unop(OP_VAL, flag_con, DT_INT);
12243 ARGT_ARG(argt, 4) = flag_con;
12244
12245 ARGT_ARG(argt, 0) = astdest;
12246 ARGT_ARG(argt, 1) = dest_sdsc_ast;
12247 ARGT_ARG(argt, 2) = astsrc;
12248 ARGT_ARG(argt, 3) = src_sdsc_ast;
12249 ast = mk_id(fsptr);
12250 ast = mk_func_node(A_CALL, ast, 5, argt);
12251 std = add_stmt_after(ast, std);
12252
12253 return std;
12254 }
12255
12256 static int
gen_kind_parm_assignments(SPTR sptr,DTYPE dtype,int std,int flag)12257 gen_kind_parm_assignments(SPTR sptr, DTYPE dtype, int std, int flag)
12258 {
12259 int mem, val, con;
12260 int ast, ast2;
12261 int sdsc_mem, i, j;
12262 int pass;
12263 int memDtype;
12264 int orig_dtype;
12265 static int parentMem = 0;
12266 static int firstAllocStd = 0;
12267
12268 orig_dtype = dtype;
12269 if (DTY(dtype) == TY_ARRAY) {
12270 dtype = DTY(dtype + 1);
12271 }
12272 if (DTY(dtype) != TY_DERIVED ||
12273 (!flag && (ALLOCATTRG(sptr) || POINTERG(sptr)) && SCG(sptr) != SC_DUMMY))
12274 return std;
12275 if (STYPEG(sptr) == ST_ARRAY || DTY(orig_dtype) == TY_ARRAY) {
12276 /* This code creates an array of PDTs. It first creates a scalar PDT object.
12277 * We then recursively call gen_kind_parm_assignments() on that object to
12278 * initialize the components that use the PDT's type parameters.
12279 * The firstAllocStd static variable is set to the std of the first
12280 * init code of a component that uses one of more type parameters. If
12281 * firstAllocStd is not set (i.e., it's -1) after the call to
12282 * gen_kind_parm_assignments(), then just return std. In this case, we
12283 * have a PDT with type parameters, but no components that use those type
12284 * parameters. If firstAllocStd > -1, then we have a PDT that uses
12285 * the type parameters. We use our temporary PDT (i.e., tmp) to create an
12286 * array of these by cloning it into each element of the array. This is very
12287 * similar to sourced allocation (e.g.,allocate(pdt_array(n),source=pdt)).
12288 * In fact, we clone tmp by calling the RTE_poly_asn() rte routine.
12289 * This routine is also called when we perform sourced allocation.
12290 * Although our technique is similar to source allocation, this code also
12291 * works with non-allocatable arrays.
12292 */
12293 int tmp = getccsym_sc('d', sem.dtemps++, ST_VAR, SC_STATIC);
12294 DTYPEP(tmp, dtype);
12295 firstAllocStd = -1;
12296 gen_kind_parm_assignments(tmp, dtype, std, flag);
12297 if (firstAllocStd > -1) {
12298 std = firstAllocStd;
12299 std = genPolyAsn(sptr, tmp, std, parentMem);
12300 }
12301 firstAllocStd = std;
12302 return std;
12303 }
12304 for (pass = 0; pass <= 1; ++pass) {
12305 for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
12306 memDtype = DTYPEG(mem);
12307 if (pass && DTY(memDtype) == TY_ARRAY && has_type_parameter(memDtype)) {
12308 int origParentMem = parentMem;
12309 int eleDtype = DTY(memDtype + 1);
12310 parentMem = (!parentMem) ? mk_member(mk_id(sptr), mk_id(mem), eleDtype)
12311 : mk_member(parentMem, mk_id(mem), eleDtype);
12312 std = gen_kind_parm_assignments(mem, memDtype, std, flag);
12313 parentMem = origParentMem;
12314 continue;
12315 }
12316 if (SCG(sptr) == SC_DUMMY && !flag) {
12317 continue;
12318 }
12319 if (PARENTG(mem)) {
12320 std = gen_kind_parm_assignments(sptr, DTYPEG(mem), std, flag);
12321 continue;
12322 }
12323 if ((!LENPARMG(mem) || A_TYPEG(LENG(mem)) == A_CNST) && SETKINDG(mem) &&
12324 !USEKINDG(mem) && (val = KINDG(mem))) {
12325 if (!pass) {
12326 con = mk_cval1(val, DT_INT);
12327 ast = add_parent_to_bounds(mk_id(sptr), mk_id(mem));
12328 ast = mk_assn_stmt(ast, con, DT_INT);
12329 std = add_stmt_after(ast, std);
12330 }
12331 } else if (LENPARMG(mem) && SETKINDG(mem) && !USEKINDG(mem) &&
12332 (val = KINDG(mem)) && LENG(mem)) {
12333 if (!pass) {
12334 ast = add_parent_to_bounds(mk_id(sptr), mk_id(mem));
12335 ast2 = LENG(mem);
12336 ast = mk_assn_stmt(ast, ast2, DT_INT);
12337 std = add_stmt_after(ast, std);
12338 }
12339 } else if (SETKINDG(mem) && !USEKINDG(mem) && KINDG(mem) &&
12340 (val = PARMINITG(mem))) {
12341 if (!pass) {
12342 con = mk_cval1(val, DT_INT);
12343 ast = add_parent_to_bounds(mk_id(sptr), mk_id(mem));
12344 ast = mk_assn_stmt(ast, con, DT_INT);
12345 std = add_stmt_after(ast, std);
12346 }
12347 } else if (INITKINDG(mem) && (val = PARMINITG(mem))) {
12348 if (!pass) {
12349 if (!chk_kind_parm_expr(val, dtype, 0, 1)) {
12350 char *buf;
12351 int len;
12352 len = strlen("Initialization must be a constant"
12353 " expression for component in object") +
12354 strlen(SYMNAME(mem)) + 1;
12355 buf = getitem(0, len);
12356 sprintf(buf,
12357 "Initialization must be a constant"
12358 " expression for component %s in object",
12359 SYMNAME(mem));
12360 error(155, 3, gbl.lineno, buf, SYMNAME(sptr));
12361 } else {
12362 val = chk_kind_parm_set_expr(val, dtype);
12363 if (A_TYPEG(val) == A_CNST) {
12364 if (USELENG(mem)) {
12365 error(155, 4, gbl.lineno,
12366 "Length type parameters may not be "
12367 "used with type components that have default "
12368 "initialization -",
12369 SYMNAME(mem));
12370 }
12371 ast = add_parent_to_bounds(mk_id(sptr), mk_id(mem));
12372 ast = mk_assn_stmt(ast, val, DT_INT);
12373 std = add_stmt_after(ast, std);
12374 } else {
12375 char *buf;
12376 int len;
12377 len = strlen("Initialization must be a constant"
12378 " expression for component in object") +
12379 strlen(SYMNAME(mem)) + 1;
12380 buf = getitem(0, len);
12381 sprintf(buf,
12382 "Initialization must be a constant"
12383 " expression for component %s in object",
12384 SYMNAME(mem));
12385 error(155, 3, gbl.lineno, buf, SYMNAME(sptr));
12386 }
12387 }
12388 }
12389 } else if (USELENG(mem) &&
12390 /*ALLOCG(mem) &&*/ DTY(DTYPEG(mem)) == TY_ARRAY) {
12391 if (pass) {
12392 i = mk_id(sptr);
12393 if (flag)
12394 fix_mem_bounds2(i, mem);
12395
12396 ast = mk_stmt(A_ALLOC, 0);
12397 A_TKNP(ast, TK_ALLOCATE);
12398 j = mk_member(i, mk_id(mem), dtype);
12399 A_SRCP(ast, j);
12400 std = add_stmt_after(ast, std);
12401 if (firstAllocStd < 0)
12402 firstAllocStd = std;
12403 std = add_stmt_before(mk_stmt(A_CONTINUE, 0), std);
12404 std = init_sdsc(mem, DTYPEG(mem), std, sptr);
12405
12406 if (!flag && gbl.rutype != RU_PROG) {
12407 i = mk_stmt(A_ALLOC, 0);
12408 A_TKNP(i, TK_DEALLOCATE);
12409 A_SRCP(i, j);
12410 A_DALLOCMEMP(i, 1);
12411 add_stmt_after(i, gbl.exitstd);
12412 }
12413 }
12414 } else if (USELENG(mem) && ALLOCG(mem) && DTY(DTYPEG(mem)) == TY_CHAR &&
12415 LENG(mem)) {
12416 if (pass) {
12417 int src_ast;
12418
12419 sdsc_mem = SDSCG(mem);
12420 sdsc_mem = mk_member(mk_id(sptr), mk_id(sdsc_mem), dtype);
12421 sdsc_mem = get_header_member(sdsc_mem, get_byte_len_indx());
12422
12423 ast = mk_stmt(A_ALLOC, 0);
12424 A_TKNP(ast, TK_ALLOCATE);
12425 src_ast = add_parent_to_bounds(mk_id(sptr), mk_id(mem));
12426 A_SRCP(ast, src_ast);
12427 std = add_stmt_after(ast, std);
12428 if (firstAllocStd < 0)
12429 firstAllocStd = std;
12430
12431 std = insert_assign(sdsc_mem, LENG(mem), std);
12432
12433 if (!flag && gbl.rutype != RU_PROG) {
12434 i = mk_stmt(A_ALLOC, 0);
12435 A_TKNP(i, TK_DEALLOCATE);
12436 A_SRCP(i, A_SRCG(ast));
12437 A_DALLOCMEMP(i, 1);
12438 add_stmt_after(i, gbl.exitstd);
12439 }
12440 }
12441 } else if (!SETKINDG(mem) && !USEKINDG(mem) && KINDG(mem) &&
12442 !PARMINITG(mem)) {
12443 int len;
12444 char *buf;
12445 len = strlen(SYMNAME(mem)) + strlen(SYMNAME(sptr)) +
12446 strlen("Missing value for kind type parameter in") + 1;
12447 buf = getitem(0, len);
12448 sprintf(buf, "Missing value for kind type parameter %s in %s",
12449 SYMNAME(mem), SYMNAME(sptr));
12450 error(155, 3, gbl.lineno, buf, CNULL);
12451 }
12452 }
12453 }
12454 return std;
12455 }
12456
12457 void
fix_type_param_members(SPTR sptr,DTYPE dtype)12458 fix_type_param_members(SPTR sptr, DTYPE dtype)
12459 {
12460
12461 int mem, i, ast;
12462 for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
12463 if (USELENG(mem) && ALLOCG(mem) && DTY(DTYPEG(mem)) == TY_ARRAY) {
12464 i = mk_id(sptr);
12465 fix_mem_bounds(i, mem);
12466 } else if (USELENG(mem) && ALLOCG(mem) && DTY(DTYPEG(mem)) == TY_CHAR &&
12467 LENG(mem)) {
12468 ast = add_parent_to_bounds(mk_id(sptr), LENG(mem));
12469 LENP(mem, ast);
12470 DTY(DTYPEG(mem) + 1) = ast;
12471 }
12472 }
12473 }
12474
12475 void
gen_type_initialize_for_sym(SPTR sptr,int std,int flag,DTYPE dtype2)12476 gen_type_initialize_for_sym(SPTR sptr, int std, int flag, DTYPE dtype2)
12477 {
12478 DTYPE orig_dtype = dtype2 ? dtype2 : DTYPEG(sptr);
12479 DTYPE dtype = orig_dtype;
12480
12481 if (is_array_dtype(dtype))
12482 dtype = array_element_dtype(dtype);
12483 if (DTY(dtype) == TY_DERIVED) {
12484 if (std < 0) {
12485 int ast = mk_stmt(A_CONTINUE, 0);
12486 std = add_stmt(ast);
12487 }
12488 gen_kind_parm_assignments(sptr, orig_dtype, std, flag);
12489 }
12490 }
12491
12492 static void
gen_alloc_mem_initialize_for_sym2(int sptr,int std,int ast,int visit_flag)12493 gen_alloc_mem_initialize_for_sym2(int sptr, int std, int ast, int visit_flag)
12494 {
12495 typedef struct visitDty {
12496 int dty;
12497 struct visitDty *next;
12498 } VISITDTY;
12499
12500 static VISITDTY *visit_list = 0;
12501 VISITDTY *curr, *new_visit, *prev;
12502
12503 int sptrmem, aast, mem_sptr_id, dtype, bast;
12504
12505 dtype = (sptr) ? DTYPEG(sptr) : DTYPEG(memsym_of_ast(ast));
12506
12507 if (DTY(dtype) != TY_DERIVED)
12508 return;
12509
12510 if (visit_list) {
12511 for (curr = visit_list; curr; curr = curr->next) {
12512 if (curr->dty == dtype)
12513 return;
12514 }
12515 }
12516
12517 NEW(new_visit, VISITDTY, 1);
12518 new_visit->dty = dtype;
12519 new_visit->next = visit_list;
12520 visit_list = new_visit;
12521
12522 for (sptrmem = DTY(DDTG(dtype) + 1); sptrmem > NOSYM;
12523 sptrmem = SYMLKG(sptrmem)) {
12524 if (ALLOCATTRG(sptrmem)) {
12525 aast = mk_id(sptrmem);
12526 bast = (ast) ? ast : mk_id(sptr);
12527 mem_sptr_id = mk_member(bast, aast, DTYPEG(sptrmem));
12528 add_stmt_after(add_nullify_ast(mem_sptr_id), std);
12529 } else if (allocatable_member(sptrmem)) {
12530 aast = mk_id(sptrmem);
12531 bast = (ast) ? ast : mk_id(sptr);
12532 bast = mk_member(bast, aast, DTYPEG(sptrmem));
12533 gen_alloc_mem_initialize_for_sym2(0, std, bast, 1);
12534 }
12535 }
12536
12537 if (!visit_flag && visit_list) {
12538 for (prev = curr = visit_list; curr;) {
12539 curr = curr->next;
12540 FREE(prev);
12541 prev = curr;
12542 }
12543 visit_list = 0;
12544 }
12545 }
12546
12547 void
gen_alloc_mem_initialize_for_sym(int sptr,int std)12548 gen_alloc_mem_initialize_for_sym(int sptr, int std)
12549 {
12550 gen_alloc_mem_initialize_for_sym2(sptr, std, 0, 0);
12551 }
12552
12553 static void
__gen_conditional_dealloc(int do_cond,int dealloc_item,int after,int test_presence)12554 __gen_conditional_dealloc(int do_cond, int dealloc_item, int after,
12555 int test_presence)
12556 {
12557 int argt;
12558 int ifast;
12559 int ast;
12560 int tsptr;
12561 int std;
12562
12563 std = after;
12564 if (do_cond) {
12565 /* generate
12566 * if( allocated(itemp->t.sptr ) then
12567 * deallocate(itemp->t.sptr)
12568 * ifend
12569 */
12570 int present;
12571 if (test_presence) {
12572 present = ast_intr(I_PRESENT, stb.user.dt_log, 1, dealloc_item);
12573 ifast = mk_stmt(A_IFTHEN, 0);
12574 A_IFEXPRP(ifast, present);
12575 std = add_stmt_after(ifast, std);
12576 }
12577 argt = mk_argt(1);
12578 ARGT_ARG(argt, 0) = dealloc_item;
12579 tsptr = getsymbol("allocated");
12580 ast = mk_id(tsptr);
12581 A_DTYPEP(ast, A_DTYPEG(dealloc_item));
12582 ast = mk_func_node(A_INTR, ast, 1, argt);
12583 A_DTYPEP(ast, stb.user.dt_log);
12584 A_OPTYPEP(ast, I_ALLOCATED);
12585 ifast = mk_stmt(A_IFTHEN, 0);
12586 A_IFEXPRP(ifast, ast);
12587 std = add_stmt_after(ifast, std);
12588 }
12589
12590 ast = mk_stmt(A_ALLOC, 0);
12591 A_TKNP(ast, TK_DEALLOCATE);
12592 A_SRCP(ast, dealloc_item);
12593 std = add_stmt_after(ast, std);
12594
12595 if (do_cond) {
12596 std = add_stmt_after(mk_stmt(A_ENDIF, 0), std);
12597 if (test_presence)
12598 std = add_stmt_after(mk_stmt(A_ENDIF, 0), std);
12599 }
12600 }
12601
12602 void
gen_conditional_dealloc(int do_cond,int dealloc_item,int after)12603 gen_conditional_dealloc(int do_cond, int dealloc_item, int after)
12604 {
12605 __gen_conditional_dealloc(do_cond, dealloc_item, after, 0);
12606 }
12607
12608 int
gen_conditional_alloc(int cond,int alloc_item,int after)12609 gen_conditional_alloc(int cond, int alloc_item, int after)
12610 {
12611 int argt;
12612 int ifast;
12613 int ast;
12614 int tsptr;
12615
12616 /* generate
12617 * if( allocated(cond) ) then
12618 * allocate(alloc_item)
12619 * ifend
12620 */
12621 if (cond) {
12622 argt = mk_argt(1);
12623 ARGT_ARG(argt, 0) = cond;
12624 tsptr = getsymbol("allocated");
12625 ast = mk_id(tsptr);
12626 A_DTYPEP(ast, A_DTYPEG(cond));
12627 ast = mk_func_node(A_INTR, ast, 1, argt);
12628 A_DTYPEP(ast, stb.user.dt_log);
12629 A_OPTYPEP(ast, I_ALLOCATED);
12630 ifast = mk_stmt(A_IFTHEN, 0);
12631 A_IFEXPRP(ifast, ast);
12632 after = add_stmt_after(ifast, after);
12633 }
12634
12635 ast = mk_stmt(A_ALLOC, 0);
12636 A_TKNP(ast, TK_ALLOCATE);
12637 A_LOPP(ast, 0);
12638 A_SRCP(ast, alloc_item);
12639 after = add_stmt_after(ast, after);
12640
12641 if (cond)
12642 after = add_stmt_after(mk_stmt(A_ENDIF, 0), after);
12643 return after;
12644 }
12645
12646 void
gen_conditional_dealloc_for_sym(int sptr,int std)12647 gen_conditional_dealloc_for_sym(int sptr, int std)
12648 {
12649 int idast = mk_id(sptr);
12650 if (SCG(sptr) != SC_LOCAL) {
12651 if (flg.smp && gbl.internal > 1) {
12652 int scope = SCOPEG(sptr);
12653 if (scope && scope == SCOPEG(gbl.currsub)) {
12654 return;
12655 }
12656 }
12657 if (SCG(sptr) == SC_DUMMY && OPTARGG(sptr))
12658 __gen_conditional_dealloc(1, idast, std, 1);
12659 else
12660 __gen_conditional_dealloc(1, idast, std, 0);
12661 } else {
12662 /* must be derived type scalar or array which contains allocatable
12663 * components.
12664 */
12665 int ast;
12666 ast = mk_stmt(A_ALLOC, 0);
12667 A_TKNP(ast, TK_DEALLOCATE);
12668 A_SRCP(ast, idast);
12669 (void)add_stmt_after(ast, std);
12670 }
12671 }
12672
12673 int
gen_dealloc_for_sym(int sptr,int std)12674 gen_dealloc_for_sym(int sptr, int std)
12675 {
12676 int idast;
12677 int ast;
12678 int ss;
12679
12680 idast = mk_id(sptr);
12681 ast = mk_stmt(A_ALLOC, 0);
12682 A_TKNP(ast, TK_DEALLOCATE);
12683 A_SRCP(ast, idast);
12684 ss = add_stmt_after(ast, std);
12685 return ss;
12686 }
12687
12688 /** \brief This function initializes the type in a descriptor for an object
12689 * with an intrinsic type.
12690 *
12691 * This function generates a call to set_intrin_type() before the statement
12692 * descriptor, \param std.
12693 *
12694 * \param ast is the ast of the object that has a descriptor that needs to be
12695 * initialized.
12696 * \param sptr is the symbol table pointer of the object that has a descriptor
12697 * that needs to be initialized.
12698 * \param std is the statement descriptor that indicates where to add the call
12699 * to set_intrin_type().
12700 *
12701 * \return the std after the set_intrin_type() call.
12702 */
12703 static int
init_intrin_type_desc(int ast,SPTR sptr,int std)12704 init_intrin_type_desc(int ast, SPTR sptr, int std)
12705 {
12706
12707
12708 int type_ast;
12709 SPTR sdsc = STYPEG(sptr) == ST_MEMBER ? get_member_descriptor(sptr) :
12710 SDSCG(sptr);
12711 int sdsc_ast = STYPEG(sptr) == ST_MEMBER ?
12712 check_member(ast, mk_id(sdsc)) :
12713 mk_id(sdsc);
12714 DTYPE dtype = DDTG(DTYPEG(sptr));
12715 int intrin_type;
12716
12717 #if DEBUG
12718 assert(DT_ISBASIC(dtype), "init_intrin_type_desc: not basic dtype for ast",
12719 ast, 4);
12720 #endif
12721 intrin_type = mk_cval(dtype_to_arg(dtype), astb.bnd.dtype);
12722 intrin_type = mk_unop(OP_VAL, intrin_type, astb.bnd.dtype);
12723 type_ast = mk_set_type_call(sdsc_ast, intrin_type, TRUE);
12724 std = add_stmt_after(type_ast, std);
12725 return std;
12726 }
12727
12728 /** \brief Generate (re)allocation code for deferred length character objects
12729 * and traditional character objects that are allocatable scalars.
12730 *
12731 * This is typically used in generating (re)allocation code in
12732 * an assignment to an allocatable/deferred length character object.
12733 *
12734 * Reallocation code is generated for deferred length character
12735 * objects.
12736 *
12737 * For traditional character allocatable scalars, we allocate
12738 * the object if it has not already been allocated; we do not
12739 * generate reallocation code since the amount of space allocated
12740 * is fixed with traditional character allocatable objects.
12741 *
12742 * We update the character length descriptor information for
12743 * both deferred length and traditional character objects. This
12744 * is needed for proper I/O such as namelist processing.
12745 *
12746 * \param lhs is the ast of the object getting (re)allocated.
12747 * \param rhs is the ast of the object that supplies the character length.
12748 * \param std is the statement descriptor where we insert the (re)allocation
12749 * and/or length assignment code.
12750 */
12751 void
gen_automatic_reallocation(int lhs,int rhs,int std)12752 gen_automatic_reallocation(int lhs, int rhs, int std)
12753 {
12754
12755 int ast, len_stmt;
12756 int tsptr;
12757 int argt;
12758 int ifast, innerifast, binopast;
12759 int lhs_len, rhs_len;
12760 DTYPE dtypedest = A_DTYPEG(lhs);
12761
12762 /* generate the following for deferred length character objects:
12763 *
12764 * if( allocated(lhs) ) then
12765 * if(len(lhs) .ne. len(rhs)) then
12766 * deallocate(lhs)
12767 * lhs$len = rhs$len
12768 * allocate(lhs, len=lhs$len)
12769 * ifend
12770 * else
12771 * lhs$len = rhs$len
12772 * allocate(lhs, len=lhs$len)
12773 * ifend
12774 *
12775 * generate the following for traditional character allocatable objects:
12776 *
12777 * if( allocated(lhs) ) then
12778 * if(len(lhs) .ne. len(rhs)) then
12779 * lhs$len = rhs$len
12780 * ifend
12781 * else
12782 * lhs$len = rhs$len
12783 * allocate(lhs, len=the_declared_length)
12784 * ifend
12785 */
12786
12787 ifast = mk_stmt(A_IFTHEN, 0);
12788
12789 argt = mk_argt(1);
12790 ARGT_ARG(argt, 0) = lhs;
12791 tsptr = getsymbol("allocated");
12792 ast = mk_id(tsptr);
12793 A_DTYPEP(ast, A_DTYPEG(lhs));
12794 ast = mk_func_node(A_INTR, ast, 1, argt);
12795 A_DTYPEP(ast, stb.user.dt_log);
12796 A_OPTYPEP(ast, I_ALLOCATED);
12797 A_IFEXPRP(ifast, ast);
12798 std = add_stmt_before(ifast, std);
12799
12800 innerifast = mk_stmt(A_IFTHEN, 0);
12801 A_IFSTMTP(ifast, innerifast);
12802
12803 lhs_len = size_ast_of(lhs, DDTG(A_DTYPEG(lhs)));
12804 if (A_TYPEG(rhs) == A_FUNC) {
12805 /* need to get the interface from the A_FUNC ast. */
12806 int sym, iface = 0;
12807 sym = procsym_of_ast(A_LOPG(rhs));
12808 proc_arginfo(sym, NULL, NULL, &iface);
12809 rhs_len = string_expr_length(mk_id(iface));
12810 } else {
12811 rhs_len = string_expr_length(rhs);
12812 }
12813 binopast = mk_binop(OP_NE, lhs_len, rhs_len, DT_LOG);
12814 A_IFEXPRP(innerifast, binopast);
12815 std = add_stmt_after(innerifast, std);
12816
12817 if (dtypedest == DT_DEFERCHAR || dtypedest == DT_DEFERNCHAR) {
12818 /* reallocation is only required for deferred length character objects */
12819 ast = mk_stmt(A_ALLOC, 0);
12820 A_IFSTMTP(innerifast, ast);
12821
12822 A_TKNP(ast, TK_DEALLOCATE);
12823 A_SRCP(ast, lhs);
12824 std = add_stmt_after(ast, std);
12825 }
12826
12827 len_stmt = mk_assn_stmt(get_len_of_deferchar_ast(lhs), rhs_len, DT_INT);
12828 std = add_stmt_after(len_stmt, std);
12829
12830 if (dtypedest == DT_DEFERCHAR || dtypedest == DT_DEFERNCHAR) {
12831 /* reallocation is only required for deferred length character objects */
12832 ast = mk_stmt(A_ALLOC, 0);
12833 A_TKNP(ast, TK_ALLOCATE);
12834 A_SRCP(ast, lhs);
12835 A_FIRSTALLOCP(ast, 1);
12836 std = add_stmt_after(ast, std);
12837 }
12838
12839 std = add_stmt_after(mk_stmt(A_ENDIF, 0), std);
12840 std = add_stmt_after(mk_stmt(A_ELSE, 0), std);
12841
12842 len_stmt = mk_assn_stmt(get_len_of_deferchar_ast(lhs), rhs_len, DT_INT);
12843 std = add_stmt_after(len_stmt, std);
12844 ast = mk_stmt(A_ALLOC, 0);
12845 A_TKNP(ast, TK_ALLOCATE);
12846 A_SRCP(ast, lhs);
12847 A_FIRSTALLOCP(ast, 1);
12848 std = add_stmt_after(ast, std);
12849
12850 std = init_intrin_type_desc(lhs, memsym_of_ast(lhs), std);
12851
12852 add_stmt_after(mk_stmt(A_ENDIF, 0), std);
12853
12854 check_and_add_auto_dealloc_from_ast(lhs);
12855 }
12856
12857 /** \brief Check whether there is a subprogram statement; if not, create a
12858 dummy program symbol, and use that as the program.
12859 */
12860 void
dummy_program()12861 dummy_program()
12862 {
12863 if (sem.scope_level == 0) {
12864 char *tname;
12865 int sptr;
12866 /* get a symbol to be the outer scope */
12867 tname = "MAIN";
12868 sptr = declref(getsymbol(tname), ST_ENTRY, 'd');
12869 SYMLKP(sptr, NOSYM);
12870 SCP(sptr, SC_EXTERN);
12871 PARAMCTP(sptr, 0);
12872 FUNCLINEP(sptr, gbl.funcline);
12873 DTYPEP(sptr, DT_NONE);
12874 push_scope_level(sptr, SCOPE_NORMAL);
12875 push_scope_level(sptr, SCOPE_SUBPROGRAM);
12876 gbl.currsub = sptr;
12877 /* if the first statement was labelled, set the scope of the label */
12878 if (scn.currlab) {
12879 SCOPEP(scn.currlab, sptr);
12880 }
12881 }
12882 } /* dummy_program */
12883
12884 static void
rw_host_state(int wherefrom,int (* p_rw)(),FILE * fd)12885 rw_host_state(int wherefrom, int (*p_rw)(), FILE *fd)
12886 {
12887 if (wherefrom & 0x1) {
12888 rw_semant_state(p_rw, fd);
12889 }
12890 if (wherefrom & 0x10) {
12891 rw_gnr_state(p_rw, fd);
12892 }
12893 if (wherefrom & 0x2) {
12894 rw_sym_state(p_rw, fd);
12895 rw_dtype_state(p_rw, fd);
12896 rw_ast_state(p_rw, fd);
12897 rw_dinit_state(p_rw, fd);
12898 rw_dpmout_state(p_rw, fd);
12899 rw_import_state(p_rw, fd);
12900 }
12901 if (wherefrom & 0x4) {
12902 rw_mod_state(p_rw, fd);
12903 }
12904 if (wherefrom & 0x20) {
12905 rw_semant_state(p_rw, fd);
12906 rw_sym_state(p_rw, fd);
12907 rw_dtype_state(p_rw, fd);
12908 rw_ast_state(p_rw, fd);
12909 rw_dinit_state(p_rw, fd);
12910 rw_dpmout_state(p_rw, fd);
12911 rw_import_state(p_rw, fd);
12912 }
12913 } /* rw_host_state */
12914
12915 static FILE *state_file = NULL;
12916 static FILE *state_append_file = NULL;
12917 static int saved_symavl = 0;
12918 static int saved_astavl = 0;
12919 static int saved_dtyavl = 0;
12920 static LOGICAL state_still_pass_one = FALSE;
12921 static LOGICAL state_append_file_full = FALSE;
12922 static long state_file_position = 0;
12923 static int state_last_routine = 0;
12924
12925 /* labels for internal subprograms are saved in pass 1, and restored
12926 * in pass 2; they are saved as C strings in a char array;
12927 * the structure of the C array is:
12928 * s u b 1 \000 . L 0 0 1 0 0 \000 s u b 2 \000 . L 0 0 2 0 0 \000
12929 * . L 0 0 3 0 0 \000 s u b 3 \000 s u b 4 \000 . L 0 0 1 0 0 \000 ;
12930 * for four internal subprograms:
12931 * sub1 with label 100
12932 * sub2 with labels 200 and 300
12933 * sub3 with no labels
12934 * sub4 with another label 100
12935 * the semicolon at the end is used to tell when to stop for the last
12936 * subprogram's label list.
12937 */
12938 static char *saved_labels = NULL;
12939 static int saved_labels_size = 0, saved_labels_avail = 0, saved_labels_pos = 0;
12940
12941 /** \brief Called from semant.c to save the semant, sym, dtype, ast, and other
12942 'state' information from a host routine for internal subprograms, for 'pass
12943 1'.
12944 Also, for 'pass 2', save_host_state is called to overwrite the semant state
12945 information.
12946 */
12947 void
save_host_state(int wherefrom)12948 save_host_state(int wherefrom)
12949 {
12950 /* use quick binary read/write */
12951 if (state_file) {
12952 if (wherefrom & 0x21) {
12953 /* seek to the beginning before writing first data */
12954 fseek(state_file, 0L, 0);
12955 }
12956 } else {
12957 state_file = tmpf("b");
12958 if (state_file == NULL)
12959 errfatal(5);
12960 }
12961 if (wherefrom & 0x2) {
12962 /* clear the SECD field of ST_ARRDSC symbols */
12963 int sptr;
12964 for (sptr = stb.firstusym; sptr < stb.stg_avail; ++sptr) {
12965 if (STYPEG(sptr) == ST_ARRDSC) {
12966 /* clear SECD field */
12967 SECDP(sptr, 0);
12968 ALNDP(sptr, 0);
12969 }
12970 }
12971 }
12972 rw_host_state(wherefrom, (int (*)())fwrite, state_file);
12973 saved_symavl = stb.stg_avail;
12974 saved_astavl = astb.stg_avail;
12975 saved_dtyavl = stb.dt.stg_avail;
12976 } /* save_host_state */
12977
12978 #ifdef CLASSG
12979 static void
fix_invobj(int sptr)12980 fix_invobj(int sptr)
12981 {
12982 /* Called by fix_symtab() below. Decrements INVOBJ field of type bound
12983 * procedure due to fix_symtab() removing result argument of function.
12984 */
12985 int sptr2;
12986 for (sptr2 = 1; sptr2 < stb.stg_avail; ++sptr2) {
12987 int bind_sptr;
12988 if (STYPEG(sptr2) == ST_MEMBER && CLASSG(sptr2) && VTABLEG(sptr2) == sptr &&
12989 !NOPASSG(sptr2) && (bind_sptr = BINDG(sptr2)) > NOSYM &&
12990 STYPEG(bind_sptr) == ST_PROC && INVOBJINCG(bind_sptr)) {
12991 INVOBJINCP(bind_sptr, FALSE);
12992 INVOBJP(bind_sptr, INVOBJG(bind_sptr) - 1);
12993 }
12994 }
12995 }
12996 #endif
12997
12998 /* look through restored symbol for array-valued, pointer-valued,
12999 * or other functions that were turned into subprograms. */
13000 static void
fix_symtab()13001 fix_symtab()
13002 {
13003 int sptr, i;
13004 for (sptr = aux.list[ST_PROC]; sptr > NOSYM; sptr = SLNKG(sptr)) {
13005 if (!FUNCG(sptr) && FVALG(sptr) > NOSYM) {
13006 /* remake into a function */
13007 FUNCP(sptr, TRUE);
13008 /* Remove first parameter only if it is the
13009 * return value symbol.
13010 */
13011 if (aux.dpdsc_base[DPDSCG(sptr)] == FVALG(sptr)) {
13012 #ifdef CLASSG
13013 fix_invobj(sptr);
13014 #endif
13015 PARAMCTP(sptr, PARAMCTG(sptr) - 1);
13016 aux.dpdsc_base[DPDSCG(sptr)] = 0; /* clear the reserved fval field */
13017 DPDSCP(sptr, DPDSCG(sptr) + 1);
13018 }
13019 DTYPEP(sptr, DTYPEG(FVALG(sptr)));
13020 }
13021 }
13022 #if DEBUG
13023 /* aux.list[ST_PROC] must be terminated with NOSYM, not 0 */
13024 assert(sptr == NOSYM, "fix_symtab: corrupted aux.list[ST_PROC]", sptr, 3);
13025 #endif
13026 /* fixing up procedure pointers that contain interfaces and converting it
13027 * back from subroutine to functions.
13028 */
13029 for (i = sem.typroc_avail; sptr > NOSYM; i++) {
13030 int procdt, fval;
13031 procdt = sem.typroc_base[i];
13032 fval = DTY(procdt + 5);
13033 if (!fval)
13034 continue;
13035 sptr = DTY(procdt + 2);
13036 if (!FUNCG(sptr) && FVALG(sptr) > NOSYM) {
13037 FUNCP(sptr, TRUE);
13038 if (aux.dpdsc_base[DPDSCG(sptr)] == FVALG(sptr)) {
13039 #ifdef CLASSG
13040 fix_invobj(sptr);
13041 #endif
13042 PARAMCTP(sptr, PARAMCTG(sptr) - 1);
13043 aux.dpdsc_base[DPDSCG(sptr)] = 0; /* clear the reserved fval field */
13044 DPDSCP(sptr, DPDSCG(sptr) + 1);
13045 }
13046 DTYPEP(sptr, DTYPEG(FVALG(sptr)));
13047 }
13048 }
13049 } /* fix_symtab */
13050
13051 /** \brief Called at the end of an internal subprogram.
13052
13053 In pass 1:
13054 - Save the internal subprogram information, kind of like interface blocks.
13055 If there is more than 1 internal subprogram, the information is
13056 exported collectively, that is, all subprograms are exported each time.
13057 - Save any labels for internal subprograms.
13058 These labels are restored by restore_internal_subprograms() below.
13059 - Restores the host information for the next subprogram.
13060 - Reimport any internal subprograms as contained subprograms.
13061 This information will be reimported in pass 2 by
13062 restore_internal_subprograms() below.
13063
13064 In pass 2:
13065 - Restore the host information for the next subprogram,
13066 as this will have been saved by the save_host_state
13067 call for the host subprogram and will include all the contained
13068 subprograms information as imported in restore_internal_subprograms()
13069 for the host routine.
13070 */
13071 void
restore_host_state(int whichpass)13072 restore_host_state(int whichpass)
13073 {
13074 if (state_file == NULL)
13075 interr("no state file to restore", 0, 4);
13076
13077 if (whichpass == 2) {
13078 fseek(state_file, 0L, 0);
13079 rw_host_state(0x13, (int (*)())fread, state_file);
13080 /*astb.firstuast = astb.stg_avail;*/
13081 /* ### don't reset firstusym for main program */
13082 stb.firstusym = stb.stg_avail;
13083 state_still_pass_one = 0;
13084 fix_symtab();
13085 } else if (whichpass == 4) { /* for ipa import */
13086 fseek(state_file, 0L, 0);
13087 rw_host_state(0x2, (int (*)())fread, state_file);
13088 /*astb.firstuast = astb.stg_avail;*/
13089 /* ### don't reset firstusym for main program */
13090 stb.firstusym = stb.stg_avail;
13091 state_still_pass_one = 0;
13092 fix_symtab();
13093 } else {
13094 int nw, modbase, smodbase, len, lab, saved_scope;
13095 long end_of_file;
13096 char Mname[100], Sname[100], MMname[100], SSname[100];
13097 /* pass one */
13098 /* write the 'append' symbols into the 'append_file' */
13099 state_append_file_full = TRUE;
13100 if (!state_append_file) {
13101 state_append_file = tmpf("b");
13102 if (state_append_file == NULL)
13103 errfatal(5);
13104 state_file_position = 0;
13105 } else {
13106 if (!state_still_pass_one) {
13107 state_file_position = 0;
13108 fseek(state_append_file, state_file_position, 0);
13109 saved_labels_avail = 0;
13110 saved_labels_pos = 0;
13111 } else {
13112 /* what is the containing subprogram;
13113 * this is the subprogram on the top of the scope stack */
13114 if (state_last_routine == sem.scope_stack[sem.scope_level].sptr) {
13115 /* rewind to the last position */
13116 fseek(state_append_file, state_file_position, 0);
13117 } else {
13118 /* leave at the end */
13119 }
13120 }
13121 }
13122 state_last_routine = sem.scope_stack[sem.scope_level].sptr;
13123 modbase = 0;
13124 strcpy(Mname, "--");
13125 strcpy(Sname, SYMNAME(state_last_routine));
13126 if (sem.mod_sym) {
13127 modbase = CMEMFG(sem.mod_sym);
13128 strcpy(Mname, SYMNAME(sem.mod_sym));
13129 }
13130 fflush(state_append_file);
13131 state_file_position = ftell(state_append_file);
13132 /* write identifier to the file */
13133 fprintf(state_append_file, "- %s %s %d %d %d %d %d\n", Mname, Sname,
13134 SCOPEG(gbl.currsub), saved_symavl, saved_astavl, saved_dtyavl,
13135 modbase);
13136 export_append_host_sym(gbl.currsub);
13137 export_host_subprogram(state_append_file, gbl.currsub, saved_symavl,
13138 saved_astavl, saved_dtyavl);
13139 end_of_file = ftell(state_append_file); /* get position */
13140
13141 /* save labels from the internal subprogram */
13142 if (saved_labels == NULL) {
13143 saved_labels_size = 512;
13144 NEW(saved_labels, char, saved_labels_size);
13145 saved_labels_avail = 0;
13146 saved_labels_pos = 0;
13147 }
13148 len = strlen(SYMNAME(gbl.currsub));
13149 /* need len+1 char positions for the null char at the end of the
13150 * string; also need one more for the 'end everything' marker */
13151 NEED(saved_labels_avail + len + 2, saved_labels, char, saved_labels_size,
13152 saved_labels_size + 512);
13153 strcpy(saved_labels + saved_labels_avail, SYMNAME(gbl.currsub));
13154 saved_labels_avail += len + 1;
13155 for (lab = sem.flabels; lab > NOSYM; lab = SYMLKG(lab)) {
13156 len = strlen(SYMNAME(lab));
13157 NEED(saved_labels_avail + len + 2, saved_labels, char, saved_labels_size,
13158 saved_labels_size + 512);
13159 strcpy(saved_labels + saved_labels_avail, SYMNAME(lab));
13160 saved_labels_avail += len + 1;
13161 }
13162 sem.flabels = 0;
13163 saved_labels[saved_labels_avail] = ';';
13164
13165 fseek(state_file, 0L, 0);
13166 rw_host_state(0x3, (int (*)())fread, state_file);
13167 /*astb.firstuast = astb.stg_avail;*/
13168
13169 fseek(state_append_file, state_file_position, 0);
13170 nw = fscanf(state_append_file, "- %s %s %d %d %d %d %d\n", MMname, SSname,
13171 &saved_scope, &saved_symavl, &saved_astavl, &saved_dtyavl,
13172 &smodbase);
13173 if (strcmp(MMname, Mname) != 0 || strcmp(SSname, Sname) != 0 || nw != 7) {
13174 interr("unknown state file error", 0, 4);
13175 }
13176 /* import the contained subprogram symbols */
13177 import_host_subprogram(state_append_file, "state file", saved_symavl,
13178 saved_astavl, saved_dtyavl, 0, 0);
13179 state_still_pass_one = 1;
13180 /* move file for read and write to end of file */
13181 fseek(state_append_file, end_of_file, 0);
13182 }
13183 } /* restore_host_state */
13184
13185 /** \brief Called at the beginning of a subprogram in pass 2.
13186
13187 - Checks whether there is information available for subprograms
13188 contained in this one, as saved by restore_host_state().
13189 - If so, restores that more or less like an interface block.
13190 - If the current routine is an internal subprogram, its labels are
13191 restored. This is so FORMAT labels that appear in both the inner
13192 and outer subprogram are properly resolved.
13193 */
13194 void
restore_internal_subprograms(void)13195 restore_internal_subprograms(void)
13196 {
13197 if (gbl.currsub == 0)
13198 dummy_program();
13199 if (state_append_file && state_append_file_full) {
13200 int nw, last_routine, modbase, nmodbase, moddiff;
13201 int saved_scope;
13202 char Mname[100], Sname[100], MMname[100], SSname[100];
13203 if (state_still_pass_one) {
13204 state_still_pass_one = 0;
13205 state_file_position = 0;
13206 exterf_init_host();
13207 }
13208 nw = fseek(state_append_file, state_file_position, 0);
13209 nw = fscanf(state_append_file, "- %s %s %d %d %d %d %d\n", MMname, SSname,
13210 &saved_scope, &saved_symavl, &saved_astavl, &saved_dtyavl,
13211 &modbase);
13212 /* import the contained subprogram symbols */
13213 if (sem.scope_level) {
13214 last_routine = sem.scope_stack[sem.scope_level].sptr;
13215 strcpy(Sname, SYMNAME(last_routine));
13216 } else {
13217 strcpy(Sname, "MAIN");
13218 }
13219 /* adjust symbols in case they were moved around by module importing */
13220 nmodbase = 0;
13221 strcpy(Mname, "--");
13222 if (sem.mod_sym) {
13223 nmodbase = CMEMFG(sem.mod_sym);
13224 strcpy(Mname, SYMNAME(sem.mod_sym));
13225 }
13226 if (nw == 7 && strcmp(Mname, MMname) == 0 && strcmp(Sname, SSname) == 0) {
13227 moddiff = nmodbase - modbase;
13228 /* this is the information for this routine */
13229 import_host(state_append_file, "state file", saved_symavl, saved_astavl,
13230 saved_dtyavl, modbase, moddiff, saved_scope, stb.curr_scope);
13231 state_file_position = ftell(state_append_file);
13232 }
13233 }
13234 if (gbl.internal > 1) {
13235 /* restore any labels found */
13236 /* compare subprogram name */
13237 char *cp;
13238 cp = saved_labels + saved_labels_pos;
13239 if (strcmp(cp, SYMNAME(gbl.currsub))) {
13240 interr("unknown internal subprogram state error (labels)", gbl.currsub,
13241 4);
13242 }
13243 saved_labels_pos += strlen(cp) + 1;
13244 cp = saved_labels + saved_labels_pos;
13245 while (*cp == '.') {
13246 /* have a label */
13247 int sptr = getsymbol(cp);
13248 if (STYPEG(sptr) != ST_UNKNOWN &&
13249 (STYPEG(sptr) != ST_LABEL || SCOPEG(sptr) != stb.curr_scope)) {
13250 /* this was not a label for this subprogram already */
13251 sptr = insert_sym(sptr);
13252 }
13253 STYPEP(sptr, ST_LABEL);
13254 FMTPTP(sptr, 0);
13255 REFP(sptr, 0);
13256 ADDRESSP(sptr, 0);
13257 SYMLKP(sptr, NOSYM);
13258 SCOPEP(sptr, stb.curr_scope);
13259 saved_labels_pos += strlen(cp) + 1;
13260 cp = saved_labels + saved_labels_pos;
13261 }
13262 }
13263 } /* restore_internal_subprograms */
13264
13265 void
reset_internal_subprograms()13266 reset_internal_subprograms()
13267 {
13268 state_still_pass_one = 0;
13269 state_file_position = 0;
13270 state_append_file_full = FALSE;
13271 } /* reset_internal_subprograms */
13272
13273 static FILE *modstate_file = NULL;
13274 static FILE *modstate_append_file = NULL;
13275 static int modsaved_symavl, modsaved_astavl, modsaved_dtyavl;
13276 static int modstate_append_file_full = 0;
13277 static int mod_clear_init = 0;
13278 static LOGICAL modsave_ieee_features;
13279
13280 /** \brief Called at a CONTAINS clause
13281
13282 Writes the module information out quickly.
13283 It is split into two pieces: the first only writes out the semant
13284 information, before semfin() deallocates it, and the second appends
13285 everything else, including the module.c tables.
13286 */
13287 void
save_module_state1()13288 save_module_state1()
13289 {
13290 if (modstate_file) {
13291 fseek(modstate_file, 0L, 0);
13292 } else {
13293 modstate_file = tmpf("m");
13294 if (modstate_file == NULL)
13295 errfatal(5);
13296 }
13297 rw_host_state(0x1, (int (*)())fwrite, modstate_file);
13298 } /* save_module_state1 */
13299
13300 void
save_module_state2()13301 save_module_state2()
13302 {
13303 rw_host_state(0x16, (int (*)())fwrite, modstate_file);
13304 modsaved_symavl = stb.stg_avail;
13305 modsaved_astavl = astb.stg_avail;
13306 modsaved_dtyavl = stb.dt.stg_avail;
13307 modstate_append_file_full = 0;
13308 mod_clear_init = 1;
13309 modsave_ieee_features = sem.ieee_features;
13310 } /* save_module_state2 */
13311
13312 static FILE *modsave_file = NULL;
13313
13314 void
save_imported_modules_state()13315 save_imported_modules_state()
13316 {
13317 if (modsave_file) {
13318 fseek(modsave_file, 0L, 0);
13319 } else {
13320 modsave_file = tmpf("m");
13321 if (modsave_file == NULL)
13322 errfatal(5);
13323 }
13324 rw_host_state(0x20, (int (*)())fwrite, modsave_file);
13325 } /* save_imported_modules_state */
13326
13327 void
restore_imported_modules_state()13328 restore_imported_modules_state()
13329 {
13330 fseek(modsave_file, 0L, 0);
13331 rw_host_state(0x20, (int (*)())fread, modsave_file);
13332 } /* restore_imported_modules_state */
13333
13334 /*
13335 * consider:
13336 * module b
13337 * public :: f << at this point, we add a variable 'f'
13338 * contains
13339 * integer function f << now here, we add function 'f', hide variable 'f'
13340 * ...
13341 * the problem is that hiding variable 'f' happens too late, we've already
13342 * got all the information for 'f' in modstate_file; so we keep
13343 * track of this situation (semsym.c:replace_variable) and when it
13344 * arises, and we restore the module state, we re-hide 'f'.
13345 * We only need to keep track of a single variable at a time.
13346 */
13347 static int module_must_hide_this_symbol_sptr = 0;
13348
13349 void
module_must_hide_this_symbol(int sptr)13350 module_must_hide_this_symbol(int sptr)
13351 {
13352 module_must_hide_this_symbol_sptr = sptr;
13353 } /* module_must_hide_this_symbol */
13354
13355 /** \brief Called at start of module-contained subprogram, restores state.
13356 If this is the first 'restore' since the last 'reset',
13357 the 'module append' file is full and needs to be imported.
13358 */
13359 void
restore_module_state()13360 restore_module_state()
13361 {
13362 if (modstate_file == NULL)
13363 errfatal(5);
13364 /* First, read the binary-saved information */
13365 fseek(modstate_file, 0L, 0);
13366 rw_host_state(0x17, (int (*)())fread, modstate_file);
13367 /* for TPR 1654, if we need to set NEEDMOD for internal
13368 * subprograms, this is the place to set it
13369 * NEEDMODP( stb.curr_scope, 1 );
13370 */
13371 if (modstate_append_file_full) {
13372
13373 /* Next, import the module-contained subprogram */
13374 fseek(modstate_append_file, 0L, 0);
13375 import_host(modstate_append_file, "module state file", modsaved_symavl,
13376 modsaved_astavl, modsaved_dtyavl, 0, 0, 0, 0);
13377 }
13378 if (module_must_hide_this_symbol_sptr) {
13379 HIDDENP(module_must_hide_this_symbol_sptr, 1);
13380 module_must_hide_this_symbol_sptr = 0;
13381 }
13382 if (mod_clear_init) {
13383 /* clear the data-initialized bit for any module-initialized commons */
13384 int sptr;
13385 for (sptr = gbl.cmblks; sptr > NOSYM; sptr = SYMLKG(sptr)) {
13386 DINITP(sptr, 0);
13387 }
13388 }
13389 if (mod_clear_init || modstate_append_file_full) {
13390 modstate_append_file_full = 0;
13391 mod_clear_init = 0;
13392 /* Lastly, rewrite the module state file */
13393 fseek(modstate_file, 0L, 0);
13394 rw_host_state(0x17, (int (*)())fwrite, modstate_file);
13395 modsaved_symavl = stb.stg_avail;
13396 modsaved_astavl = astb.stg_avail;
13397 modsaved_dtyavl = stb.dt.stg_avail;
13398 }
13399 sem.ieee_features = modsave_ieee_features;
13400 } /* restore_module_state */
13401
13402 /** \brief Called at the end of a module-contained subprogram;
13403 rearranges the data structures for the module.
13404 */
13405 void
reset_module_state()13406 reset_module_state()
13407 {
13408 if (modstate_file == NULL)
13409 interr("no module state file to restore", 0, 4);
13410 if (sem.which_pass == 1) {
13411 fseek(modstate_file, 0L, 0);
13412 rw_host_state(0x17, (int (*)())fread, modstate_file);
13413 } else {
13414 /* export the module-contained subprogram */
13415 if (!modstate_append_file) {
13416 modstate_append_file = tmpf("m");
13417 if (modstate_append_file == NULL)
13418 errfatal(5);
13419 } else {
13420 fseek(modstate_append_file, 0L, 0);
13421 }
13422 export_module_subprogram(modstate_append_file, gbl.currsub, modsaved_symavl,
13423 modsaved_astavl, modsaved_dtyavl);
13424 modstate_append_file_full = 1;
13425 }
13426 } /* reset_module_state */
13427
13428 int
have_module_state()13429 have_module_state()
13430 {
13431 if (modstate_file == NULL)
13432 return 0;
13433 return 1;
13434 }
13435
13436 /** \brief Compilation is finished - deallocate storage, close files, etc.
13437 */
13438 void
sem_fini(void)13439 sem_fini(void)
13440 {
13441 if (state_file)
13442 fclose(state_file);
13443 state_file = NULL;
13444 if (state_append_file)
13445 fclose(state_append_file);
13446 state_append_file = NULL;
13447 if (saved_labels) {
13448 FREE(saved_labels);
13449 saved_labels = NULL;
13450 saved_labels_size = 0;
13451 saved_labels_avail = 0;
13452 saved_labels_pos = 0;
13453 }
13454 if (sem.eqv_base) {
13455 FREE(sem.eqv_base);
13456 sem.eqv_base = NULL;
13457 }
13458 if (sem.eqv_ss_base) {
13459 FREE(sem.eqv_ss_base);
13460 sem.eqv_ss_base = NULL;
13461 }
13462 import_fini();
13463 if (sem.non_private_base) {
13464 FREE(sem.non_private_base);
13465 sem.non_private_base = NULL;
13466 }
13467 } /* sem_fini */
13468
13469 void
sem_set_storage_class(int sptr)13470 sem_set_storage_class(int sptr)
13471 {
13472 if (STYPEG(sptr) == ST_ARRAY) {
13473 if (ALLOCG(sptr)) {
13474 SCP(sptr, SC_BASED);
13475 } else if (ASUMSZG(sptr)) {
13476 {
13477 error(50, 3, gbl.lineno, SYMNAME(sptr), CNULL);
13478 SCP(sptr, SC_DUMMY);
13479 }
13480 } else if (ASSUMLENG(sptr)) {
13481 error(452, 3, gbl.lineno, SYMNAME(sptr), CNULL);
13482 SCP(sptr, SC_DUMMY);
13483 } else {
13484 SCP(sptr, SC_LOCAL);
13485 if (ADJARRG(sptr) || RUNTIMEG(sptr)) {
13486 add_auto_array(sptr);
13487 if (has_allocattr(sptr)) {
13488 add_auto_dealloc(sptr);
13489 }
13490 } else if (ADJLENG(sptr))
13491 add_auto_char(sptr);
13492 }
13493 } else if (STYPEG(sptr) == ST_PROC)
13494 SCP(sptr, SC_EXTERN);
13495 else if (POINTERG(sptr)) {
13496 SCP(sptr, SC_BASED);
13497 if (ADJLENG(sptr))
13498 add_auto_char(sptr);
13499 } else if (!IS_INTRINSIC(STYPEG(sptr))) {
13500 /* if an intrinsic, this processing must be deferred until an
13501 * actual scalar reference confirms a nonintrinsic context.
13502 */
13503 SCP(sptr, SC_LOCAL);
13504 if (ADJLENG(sptr))
13505 add_auto_char(sptr);
13506 }
13507 }
13508
13509 /* ensure that the list of automatic arrays is in
13510 * the order they're declared
13511 */
13512 static void
add_auto_array(int sptr)13513 add_auto_array(int sptr)
13514 {
13515 SCP(sptr, SC_LOCAL);
13516 add_autobj(sptr);
13517 AD_NOBOUNDS(AD_DPTR(DTYPEG(sptr))) = 1;
13518 }
13519
13520 /* ensure that the list of automatic arrays is in
13521 * the order they're declared
13522 */
13523 static void
add_auto_char(int sptr)13524 add_auto_char(int sptr)
13525 {
13526 SCP(sptr, SC_LOCAL);
13527 add_autobj(sptr);
13528 }
13529
13530 static void
add_autobj(int sptr)13531 add_autobj(int sptr)
13532 {
13533 static int last_autobj;
13534
13535 if (gbl.autobj == NOSYM)
13536 /* first automatic array */
13537 gbl.autobj = sptr;
13538 else
13539 AUTOBJP(last_autobj, sptr);
13540 last_autobj = sptr;
13541 AUTOBJP(sptr, NOSYM);
13542 }
13543
13544 void
dmp_var(VAR * var,int indent,FILE * f)13545 dmp_var(VAR *var, int indent, FILE *f)
13546 {
13547 int i;
13548 if (f == NULL)
13549 f = stderr;
13550 for (i = 0; i < indent; ++i)
13551 fprintf(f, " ");
13552 switch (var->id) {
13553 case Dostart:
13554 fprintf(f, "Dostart: indvar=%d lowbd=%d upbd=%d step=%d (ASTs)\n",
13555 var->u.dostart.indvar, var->u.dostart.lowbd, var->u.dostart.upbd,
13556 var->u.dostart.step);
13557 break;
13558 case Doend:
13559 fprintf(f, "Doend for:\n");
13560 dmp_var(var->u.doend.dostart, indent + 1, f);
13561 break;
13562 case Varref: {
13563 char typebuf[300];
13564 DTYPE dtype = var->u.varref.dtype;
13565 VAR *members = var->u.varref.subt;
13566 FILE *save_dbgfil = gbl.dbgfil;
13567 getdtype(dtype, typebuf);
13568 /* id is S_* constant */
13569 fprintf(f, "Varref: id=%d ptr=AST:%d:", var->u.varref.id,
13570 var->u.varref.ptr);
13571 gbl.dbgfil = f;
13572 printast(var->u.varref.ptr);
13573 gbl.dbgfil = save_dbgfil;
13574 fprintf(f, " dtype=%d:%s shape=%d\n", dtype, typebuf, var->u.varref.shape);
13575 for (; members != 0; members = members->next) {
13576 dmp_var(members, indent + 1, f);
13577 }
13578 } break;
13579 default:
13580 interr("dmp_var: bad id", var->id, ERR_Severe);
13581 }
13582 }
13583
13584 void
dvar(VAR * var)13585 dvar(VAR *var)
13586 {
13587 dmp_var(var, 0, stderr);
13588 }
13589
13590 void
dmp_acl(ACL * acl,int indent)13591 dmp_acl(ACL *acl, int indent)
13592 {
13593 _dmp_acl(acl, indent, NULL);
13594 }
13595
13596 static void
_dmp_acl(ACL * acl,int indent,FILE * f)13597 _dmp_acl(ACL *acl, int indent, FILE *f)
13598 {
13599 ACL *c_aclp;
13600 char two_spaces[3] = " ";
13601
13602 if (!acl) {
13603 return;
13604 }
13605
13606 if (f == NULL)
13607 f = stderr;
13608 for (c_aclp = acl; c_aclp; c_aclp = c_aclp->next) {
13609 switch (c_aclp->id) {
13610 case AC_IDENT:
13611 put_prefix(two_spaces, indent, f);
13612 fprintf(
13613 f,
13614 "AC_IDENT: %d, repeatc=%d, is_const=%d, dtype=%d, sptr=%d, size=%d\n",
13615 c_aclp->u1.ast, c_aclp->repeatc, c_aclp->is_const, c_aclp->dtype,
13616 c_aclp->sptr, c_aclp->size);
13617 break;
13618 case AC_CONST:
13619 put_prefix(two_spaces, indent, f);
13620 fprintf(
13621 f,
13622 "AC_CONST: %d, repeatc=%d, is_const=%d, dtype=%d, sptr=%d, size=%d\n",
13623 c_aclp->u1.ast, c_aclp->repeatc, c_aclp->is_const, c_aclp->dtype,
13624 c_aclp->sptr, c_aclp->size);
13625 break;
13626 case AC_AST:
13627 put_prefix(two_spaces, indent, f);
13628 fprintf(
13629 f,
13630 "AC_AST: %d, repeatc=%d, is_const=%d, dtype=%d, sptr=%d, size=%d\n",
13631 c_aclp->u1.ast, c_aclp->repeatc, c_aclp->is_const, c_aclp->dtype,
13632 c_aclp->sptr, c_aclp->size);
13633 break;
13634 case AC_EXPR:
13635 put_prefix(two_spaces, indent, f);
13636 fprintf(f, "**** AC_EXPR: SST id %d ***\n", SST_IDG(c_aclp->u1.stkp));
13637 break;
13638 case AC_IEXPR:
13639 put_prefix(two_spaces, indent, f);
13640 fprintf(f,
13641 "AC_IEXPR: op %s, repeatc=%d, is_const=%d, dtype=%d, sptr=%d, "
13642 "size=%d\n",
13643 iexpr_op(c_aclp->u1.expr->op), c_aclp->repeatc, c_aclp->is_const,
13644 c_aclp->dtype, c_aclp->sptr, c_aclp->size);
13645 _dmp_acl(c_aclp->u1.expr->lop, indent + 1, f);
13646 _dmp_acl(c_aclp->u1.expr->rop, indent + 1, f);
13647 break;
13648 case AC_IDO:
13649 put_prefix(two_spaces, indent, f);
13650 fprintf(f, "AC_IDO: , dtype=%d, sptr=%d, size=%d\n", c_aclp->dtype,
13651 c_aclp->sptr, c_aclp->size);
13652 fprintf(f,
13653 " index var sptr %d, init expr ast %d, "
13654 "limit expr ast %d, step_expr ast %d, repeatc %d\n",
13655 c_aclp->u1.doinfo->index_var, c_aclp->u1.doinfo->init_expr,
13656 c_aclp->u1.doinfo->limit_expr, c_aclp->u1.doinfo->step_expr,
13657 c_aclp->repeatc);
13658 put_prefix(two_spaces, indent, f);
13659 fprintf(f, " Initialization Values:\n");
13660 _dmp_acl(c_aclp->subc, indent + 1, f);
13661 break;
13662 case AC_ACONST:
13663 put_prefix(two_spaces, indent, f);
13664 fprintf(f, "AC_ACONST: repeatc %d, dtype=%d, sptr=%d\n", c_aclp->repeatc,
13665 c_aclp->dtype, c_aclp->sptr);
13666 put_prefix(two_spaces, indent, f);
13667 fprintf(f, " Initialization Values:\n");
13668 _dmp_acl(c_aclp->subc, indent + 1, f);
13669 break;
13670 case AC_SCONST:
13671 put_prefix(two_spaces, indent, f);
13672 fprintf(f, "AC_SCONST: repeatc %d, dtype=%d, sptr=%d\n", c_aclp->repeatc,
13673 c_aclp->dtype, c_aclp->sptr);
13674 put_prefix(two_spaces, indent, f);
13675 fprintf(f, " Initialization Values:\n");
13676 _dmp_acl(c_aclp->subc, indent + 1, f);
13677 break;
13678 case AC_TYPEINIT:
13679 put_prefix(two_spaces, indent, f);
13680 fprintf(f, "AC_TYPEINIT: repeatc %d, dtype=%d, sptr=%d\n",
13681 c_aclp->repeatc, c_aclp->dtype, c_aclp->sptr);
13682 put_prefix(two_spaces, indent, f);
13683 fprintf(f, " Initialization Values:\n");
13684 _dmp_acl(c_aclp->subc, indent + 1, f);
13685 break;
13686 case AC_ICONST:
13687 put_prefix(two_spaces, indent, f);
13688 fprintf(f, "AC_ICONST: value %d\n", c_aclp->u1.i);
13689 break;
13690 case AC_REPEAT:
13691 case AC_LIST:
13692 default:
13693 put_prefix(two_spaces, indent, f);
13694 fprintf(f, "*** UNKNOWN/UNUSED ACL ID %d\n", c_aclp->id);
13695 break;
13696 }
13697 }
13698 }
13699
13700 static void
put_prefix(char * str,int cnt,FILE * f)13701 put_prefix(char *str, int cnt, FILE *f)
13702 {
13703 int i;
13704
13705 fprintf(f, " ");
13706 for (i = 0; i < cnt; i++)
13707 fprintf(f, "%s", str);
13708 }
13709
13710 int
mp_create_bscope(int reuse)13711 mp_create_bscope(int reuse)
13712 {
13713 int ast = 0, i;
13714 int astid;
13715 int uplevel_sptr = 0;
13716 int scope_sptr = 0;
13717 SPTR parent_sptr, parent_uplevel;
13718
13719 if (reuse) {
13720 i = sem.scope_level;
13721 scope_sptr = BLK_SCOPE_SPTR(i);
13722 while (scope_sptr == 0 && i) {
13723 scope_sptr = BLK_SCOPE_SPTR(i);
13724 --i;
13725 }
13726 if (scope_sptr == 0) {
13727 goto newscope;
13728 }
13729 ast = mk_stmt(A_MP_BMPSCOPE, 0);
13730 astid = mk_id(scope_sptr);
13731 A_STBLKP(ast, astid);
13732 (void)add_stmt(ast);
13733 return ast;
13734 }
13735 newscope:
13736 scope_sptr = getccssym("uplevel", sem.blksymnum++, ST_BLOCK);
13737 PARSYMSCTP(scope_sptr, 0);
13738 PARSYMSP(scope_sptr, 0);
13739 BLK_SCOPE_SPTR(sem.scope_level) = scope_sptr;
13740
13741 /* create a new uplevel_sptr per outlined region */
13742 uplevel_sptr = getccssym("uplevel", sem.blksymnum++, ST_BLOCK);
13743 PARSYMSCTP(uplevel_sptr, 0);
13744 PARSYMSP(uplevel_sptr, 0);
13745 PARUPLEVELP(scope_sptr, uplevel_sptr);
13746 BLK_UPLEVEL_SPTR(sem.scope_level) = uplevel_sptr;
13747 i = sem.scope_level - 1;
13748 parent_sptr = BLK_UPLEVEL_SPTR(i);
13749 while (i > 0 && parent_sptr == 0) {
13750 --i;
13751 parent_sptr = BLK_UPLEVEL_SPTR(i);
13752 }
13753 (void)llmp_create_uplevel(uplevel_sptr);
13754 if (parent_sptr) {
13755 llmp_uplevel_set_parent((SPTR)uplevel_sptr, parent_sptr);
13756 }
13757 ast = mk_stmt(A_MP_BMPSCOPE, 0);
13758 astid = mk_id(scope_sptr);
13759 A_STBLKP(ast, astid);
13760 (void)add_stmt(ast);
13761 return ast;
13762 }
13763
13764 int
mp_create_escope()13765 mp_create_escope()
13766 {
13767 int ast = 0;
13768
13769 ast = mk_stmt(A_MP_EMPSCOPE, 0);
13770 (void)add_stmt(ast);
13771 BLK_UPLEVEL_SPTR(sem.scope_level) = 0;
13772
13773 return ast;
13774 }
13775
13776 int
enter_lexical_block(int gen_debug)13777 enter_lexical_block(int gen_debug)
13778 {
13779 int sptr;
13780 int sptr1;
13781 int ast, std;
13782
13783 sptr = BLK_SCOPE_SPTR(sem.scope_level - 1);
13784
13785 if (gen_debug) {
13786 if (!sptr) {
13787 sptr = getccssym("uplevel", sem.blksymnum++, ST_BLOCK);
13788 PARSYMSCTP(sptr, 0);
13789 PARSYMSP(sptr, 0);
13790 }
13791 STARTLINEP(sptr, gbl.lineno);
13792 if (sptr != BLK_SYM(sem.scope_level - 1))
13793 ENCLFUNCP(sptr, BLK_SYM(sem.scope_level - 1));
13794 sptr1 = getlab();
13795 RFCNTI(sptr1);
13796 VOLP(sptr1, 1); /* so block is never deleted */
13797 STARTLABP(sptr, sptr1);
13798 ENCLFUNCP(sptr1, sptr);
13799 ast = mk_stmt(A_CONTINUE, 0);
13800 std = add_stmt_after(ast, (int)STD_PREV(0));
13801 STD_LABEL(std) = sptr1;
13802 }
13803 BLK_SYM(sem.scope_level) = sptr;
13804 return sptr;
13805 }
13806
13807 void
exit_lexical_block(int gen_debug)13808 exit_lexical_block(int gen_debug)
13809 {
13810 int sptr1;
13811 int blksym;
13812 int ast, std;
13813
13814 blksym = BLK_SYM(sem.scope_level);
13815 ENDLINEP(blksym, gbl.lineno);
13816 if (gen_debug) {
13817 sptr1 = getlab();
13818 RFCNTI(sptr1);
13819 VOLP(sptr1, 1); /* so block is never deleted */
13820 ENDLABP(blksym, sptr1);
13821 ENCLFUNCP(sptr1, blksym);
13822 ast = mk_stmt(A_CONTINUE, 0);
13823 std = add_stmt_after(ast, (int)STD_PREV(0));
13824 STD_LABEL(std) = sptr1;
13825 }
13826 }
13827
13828 static char *di_name[] = {
13829 "block IF",
13830 "IFELSE",
13831 "DO",
13832 "DOWHILE",
13833 "WHERE",
13834 "ELSEWHERE",
13835 "FORALL",
13836 "SELECTCASE",
13837 "PARALLEL directive",
13838 "PARALLELDO directive",
13839 "OMP DO directive",
13840 "DOACROSS directive",
13841 "PARALLELSECTIONS directive",
13842 "SECTIONS directive",
13843 "SINGLE directive",
13844 "CRITICAL directive",
13845 "MASTER directive",
13846 "ORDERED directive",
13847 "WORKSHARE directive",
13848 "PARALLELWORKSHARE directive",
13849 "TASK directive",
13850 "ACC REGION directive",
13851 "ACC KERNELS construct",
13852 "ACC PARALLEL construct",
13853 "ACC DO directive",
13854 "ACC LOOP directive",
13855 "ACC REGION DO directive",
13856 "ACC REGION LOOP directive",
13857 "ACC KERNELS DO directive",
13858 "ACC KERNELS LOOP directive",
13859 "ACC PARALLEL DO directive",
13860 "ACC PARALLEL LOOP directive",
13861 "ACC KERNEL construct",
13862 "ACC DATA REGION construct",
13863 "CUDA KERNEL directive",
13864 "SELECT TYPE",
13865 "ACC HOST DATA construct",
13866 "ACC ATOMIC CAPTURE construct",
13867 "DOCONCURRENT",
13868 "SIMD",
13869 "TASKGROUP",
13870 "TASKLOOP",
13871 "TARGET",
13872 "TARGETENTERDATA",
13873 "TARGETEXITDATA",
13874 "TARGETDATA",
13875 "TARGETUPDATE",
13876 "DISTRIBUTE",
13877 "TEAMS",
13878 "DECLARE TARGET",
13879 "ASSOCIATE",
13880 "DISTRIBUTE PARALLEL DO",
13881 "TARGET PARALLEL DO",
13882 "TARGET SIMD",
13883 "TARGET TEAMS DISTRIBUTE",
13884 "TEAMS DISTRIBUTE",
13885 "TARGET TEAMS DISTRIBUTE PARALLEL DO",
13886 "TEAMS DISTRIBUTE PARALLEL DO",
13887 "ACC SERIAL",
13888 "ACC SERIAL LOOP",
13889 };
13890
13891 void
sem_err104(int df,int lineno,char * str)13892 sem_err104(int df, int lineno, char *str)
13893 {
13894 if (df) {
13895 int id;
13896 id = DI_ID(df);
13897 if (id < sizeof(di_name) / sizeof(char *)) {
13898 char buff[256];
13899 sprintf(buff, "- %s %s", str, di_name[id]);
13900 error(104, 3, lineno, buff, CNULL);
13901 return;
13902 }
13903 interr("sem_err104:unk doif->ID", DI_ID(df), 3);
13904 }
13905 }
13906
13907 void
sem_err105(int df)13908 sem_err105(int df)
13909 {
13910 if (df) {
13911 int id;
13912 id = DI_ID(df);
13913 if (id < sizeof(di_name) / sizeof(char *)) {
13914 sem_err104(df, gbl.lineno, "unterminated");
13915 return;
13916 }
13917 }
13918 errsev(105);
13919 }
13920
13921 #if DEBUG
13922 void
_dmp_doif(int df,FILE * f)13923 _dmp_doif(int df, FILE *f)
13924 {
13925 int id;
13926 if (f == NULL)
13927 f = stderr;
13928 id = DI_ID(df);
13929 if (id >= sizeof(di_name) / sizeof(char *)) {
13930 fprintf(f, "Unknown DI_ID(%d) == %d\n", df, id);
13931 return;
13932 }
13933 fprintf(f, "[%3d] %.24s\n", df, di_name[id]);
13934 fprintf(f, " NAME:%d\n", DI_NAME(df));
13935 switch (id) {
13936 }
13937 if (DI_NEST(df)) {
13938 int i;
13939 fprintf(f, " Nest:0x%08lx ", DI_NEST(df));
13940 for (i = 0; i <= DI_MAXID; i++) {
13941 if (DI_B(i) & DI_NEST(df))
13942 fprintf(f, "|%s", di_name[i]);
13943 }
13944 }
13945 if (id == DI_DO) {
13946 fprintf(f, " doinfo:%p collapse:%d", DI_DOINFO(df),
13947 DI_DOINFO(df)->collapse);
13948 }
13949 fprintf(f, "\n");
13950 }
13951
13952 void
dmp_doif(FILE * f)13953 dmp_doif(FILE *f)
13954 {
13955 int df;
13956 if (f == NULL)
13957 f = stderr;
13958 fprintf(f, "----- DOIF (%d entries)\n", sem.doif_depth);
13959 for (df = 1; df <= sem.doif_depth; df++) {
13960 _dmp_doif(df, f);
13961 }
13962 }
13963 #endif
13964
13965 LOGICAL
is_alloc_ast(int ast)13966 is_alloc_ast(int ast)
13967 {
13968 if (ast)
13969 return (A_TYPEG(ast) == A_ALLOC && A_TKNG(ast) == TK_ALLOCATE);
13970 else
13971 return FALSE;
13972 }
13973
13974 LOGICAL
is_dealloc_ast(int ast)13975 is_dealloc_ast(int ast)
13976 {
13977 if (ast)
13978 return (A_TYPEG(ast) == A_ALLOC && A_TKNG(ast) == TK_DEALLOCATE);
13979 else
13980 return FALSE;
13981 }
13982
13983 LOGICAL
is_alloc_std(int std)13984 is_alloc_std(int std)
13985 {
13986 int ast;
13987 if (std) {
13988 ast = STD_AST(std);
13989 return (A_TYPEG(ast) == A_ALLOC && A_TKNG(ast) == TK_ALLOCATE);
13990 } else {
13991 return FALSE;
13992 }
13993 }
13994
13995 LOGICAL
is_dealloc_std(int std)13996 is_dealloc_std(int std)
13997 {
13998 int ast;
13999 if (std) {
14000 ast = STD_AST(std);
14001 return (A_TYPEG(ast) == A_ALLOC && A_TKNG(ast) == TK_DEALLOCATE);
14002 } else {
14003 return FALSE;
14004 }
14005 }
14006
14007 /** \brief Creates an ast that represents a call to a set type runtime routine.
14008 *
14009 * \param arg0 is the ast of the descriptor that receives the type from arg1.
14010 *
14011 * \param arg1 is the ast of the source descriptor. The type of arg1 is copied
14012 * into the arg0 descriptor.
14013 *
14014 * \param intrin_type is true when you want to use the RTE_set_intrin_type()
14015 * routine instead of the RTE_set_type() routine.
14016 *
14017 * \returns the call ast
14018 */
14019 int
mk_set_type_call(int arg0,int arg1,LOGICAL intrin_type)14020 mk_set_type_call(int arg0, int arg1, LOGICAL intrin_type)
14021 {
14022 int newargt, func, astnew;
14023
14024 newargt = mk_argt(2);
14025 ARGT_ARG(newargt, 0) = arg0;
14026 ARGT_ARG(newargt, 1) = arg1;
14027
14028 func = mk_id(sym_mkfunc_nodesc(
14029 mkRteRtnNm((intrin_type) ? RTE_set_intrin_type : RTE_set_type), DT_NONE));
14030 astnew = mk_func_node(A_CALL, func, 2, newargt);
14031
14032 return astnew;
14033 }
14034
14035 /** \brief Generates calls to RTE_set_type() or RTE_set_intrin_type() which
14036 * set the type descriptor field of an object's descriptor.
14037 *
14038 * \param dest_ast is the descriptor expression that's getting its type
14039 * descriptor set. Note: dest_ast may be a descriptor expression or an
14040 * expression that has a descriptor.
14041 *
14042 * \param src_ast is the expression that has the type descriptor that we are
14043 * copying to dest_ast. Note: src_ast may be a descriptor expression or an
14044 * expession that has a descriptor.
14045 *
14046 * \param std is the std where we will insert the call.
14047 *
14048 * \param insert_before is true when you want to insert the call before std,
14049 * otherwise we insert it after std.
14050 *
14051 * \param intrin_type is true when you want to use the RTE_set_intrin_type()
14052 * routine instead of the RTE_set_type() routine.
14053 *
14054 * \returns the new std after inserting the call.
14055 */
14056 int
gen_set_type(int dest_ast,int src_ast,int std,LOGICAL insert_before,LOGICAL intrin_type)14057 gen_set_type(int dest_ast, int src_ast, int std, LOGICAL insert_before,
14058 LOGICAL intrin_type)
14059 {
14060 int astnew, arg0, arg1, sptr, sdsc;
14061 int atype;
14062
14063 /* Walk the ast expression to find the invoking object (an A_MEM or A_ID) */
14064 for (atype = A_TYPEG(src_ast);
14065 atype == A_FUNC || atype == A_SUBSCR || atype == A_CONV ||
14066 atype == A_CALL || atype == A_MEM;
14067 atype = A_TYPEG(src_ast)) {
14068
14069 if (atype == A_MEM) {
14070 sptr = memsym_of_ast(src_ast);
14071 if (is_tbp(sptr)) {
14072 src_ast = A_PARENTG(src_ast);
14073 } else {
14074 break;
14075 }
14076 } else {
14077 src_ast = A_LOPG(src_ast);
14078 }
14079 }
14080
14081 /* get descriptor expression for dest_ast */
14082 sptr = memsym_of_ast(dest_ast);
14083 if (DESCARRAYG(sptr) || SCG(sptr) == SC_DUMMY) {
14084 arg0 = dest_ast;
14085 } else if (A_TYPEG(src_ast) == A_MEM) {
14086 sdsc = get_member_descriptor(sptr);
14087 arg0 = mk_member(mk_id(sym_of_ast(A_PARENTG(dest_ast))), mk_id(sdsc),
14088 A_DTYPEG(dest_ast));
14089 } else {
14090 sdsc = SDSCG(sptr);
14091 if (sdsc == 0) {
14092 arg0 = dest_ast;
14093 } else {
14094 arg0 = mk_id(sdsc);
14095 }
14096 }
14097
14098 /* get descriptor expression for src_ast */
14099 if (intrin_type) {
14100 arg1 = src_ast;
14101 } else {
14102 sptr = memsym_of_ast(src_ast);
14103 if (DESCARRAYG(sptr) || SCG(sptr) == SC_DUMMY) {
14104 arg1 = src_ast;
14105 } else if (A_TYPEG(src_ast) == A_MEM) {
14106 sdsc = get_member_descriptor(sptr);
14107 arg1 = mk_member(mk_id(sym_of_ast(A_PARENTG(src_ast))), mk_id(sdsc),
14108 A_DTYPEG(src_ast));
14109 } else {
14110 sdsc = SDSCG(sptr);
14111 if (sdsc == 0) {
14112 arg1 = src_ast;
14113 } else {
14114 arg1 = mk_id(sdsc);
14115 }
14116 }
14117 }
14118
14119 astnew = mk_set_type_call(arg0, arg1, intrin_type);
14120
14121 if (insert_before) {
14122 std = add_stmt_before(astnew, std);
14123 } else {
14124 std = add_stmt_after(astnew, std);
14125 }
14126
14127 return std;
14128 }
14129