1 /*
2 * Copyright (c) 1997-2019, NVIDIA CORPORATION. All rights reserved.
3 *
4 * Licensed under the Apache License, Version 2.0 (the "License");
5 * you may not use this file except in compliance with the License.
6 * You may obtain a copy of the License at
7 *
8 * http://www.apache.org/licenses/LICENSE-2.0
9 *
10 * Unless required by applicable law or agreed to in writing, software
11 * distributed under the License is distributed on an "AS IS" BASIS,
12 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13 * See the License for the specific language governing permissions and
14 * limitations under the License.
15 *
16 */
17
18 /**
19 \file
20 \brief Routines used by lower.c for lowering to ILMs
21 */
22
23 #include "gbldefs.h"
24 #include "global.h"
25 #include "error.h"
26 #include "comm.h"
27 #include "symtab.h"
28 #include "symutl.h"
29 #include "dtypeutl.h"
30 #include "ast.h"
31 #include "semant.h"
32 #include "dinit.h"
33 #include "soc.h"
34 #include "gramtk.h"
35 #include "rte.h"
36 #include "extern.h"
37 #include "rtlRtns.h"
38
39 #define INSIDE_LOWER
40 #include "lower.h"
41
42 static LOGICAL lower_check_ast(int ast, int *unused);
43
44 void
ast_error(char * s,int ast)45 ast_error(char *s, int ast)
46 {
47 lerror("%s [ast=%d,asttype=%d,datatype=%d]", s, ast, A_TYPEG(ast),
48 A_REPLG(ast));
49 if (gbl.dbgfil) {
50 if (gbl.dbgfil != stderr) {
51 fprintf(gbl.dbgfil,
52 "---------------------------\n"
53 "%s [ast=%d,asttype=%d,datatype=%d]\n",
54 s, ast, A_TYPEG(ast), A_REPLG(ast));
55 }
56 #if DEBUG
57 dump_one_ast(ast);
58 dbg_print_ast(ast, gbl.dbgfil);
59 #endif
60 }
61 } /* ast_error */
62
63 /* convert whatever type ilm is to BINT */
64 static int
conv_bint_ilm(int ast,int ilm,int dtype)65 conv_bint_ilm(int ast, int ilm, int dtype)
66 {
67 int s;
68 char *cp;
69 int n[4];
70 switch (DTYG(dtype)) {
71 case TY_BLOG:
72 case TY_BINT:
73 break;
74 case TY_SLOG:
75 case TY_SINT:
76 ilm = plower("oi", "STOI", ilm);
77 ilm = plower("oi", "ITOSC", ilm);
78 break;
79 case TY_LOG:
80 case TY_INT:
81 ilm = plower("oi", "ITOSC", ilm);
82 break;
83 case TY_LOG8:
84 case TY_INT8:
85 ilm = plower("oi", "I8TOI", ilm);
86 ilm = plower("oi", "ITOSC", ilm);
87 break;
88 case TY_REAL:
89 ilm = plower("oi", "FIX", ilm);
90 ilm = plower("oi", "ITOSC", ilm);
91 break;
92 case TY_DBLE:
93 ilm = plower("oi", "DFIX", ilm);
94 ilm = plower("oi", "ITOSC", ilm);
95 break;
96 case TY_CMPLX:
97 ilm = plower("oi", "REAL", ilm);
98 ilm = plower("oi", "FIX", ilm);
99 ilm = plower("oi", "ITOSC", ilm);
100 break;
101 case TY_DCMPLX:
102 ilm = plower("oi", "DREAL", ilm);
103 ilm = plower("oi", "DFIX", ilm);
104 ilm = plower("oi", "ITOSC", ilm);
105 break;
106 case TY_WORD:
107 if (ast && A_TYPEG(ast) == A_CNST) {
108 s = lower_getintcon(cngcon(CONVAL2G(A_SPTRG(ast)), DTYG(dtype), DT_INT4));
109 ilm = plower("oS", "ICON", s);
110 ilm = plower("oi", "UITOSC", ilm);
111 } else {
112 ilm = plower("oi", "UITOSC", ilm);
113 }
114 break;
115 case TY_DWORD:
116 /* convert by padding with blanks or truncating */
117 if (ast && A_TYPEG(ast) == A_CNST) {
118 s = lower_getintcon(cngcon(A_SPTRG(ast), DTYG(dtype), DT_INT4));
119 ilm = plower("oS", "ICON", s);
120 } else {
121 ilm = plower("oi", "K2I", ilm);
122 ilm = plower("oi", "ITOSC", ilm);
123 }
124 break;
125 case TY_HOLL:
126 /* convert by padding with blanks or truncating */
127 if (ast && A_TYPEG(ast) == A_CNST) {
128 s = lower_getintcon(cngcon(A_SPTRG(ast), DTYG(dtype), DT_BINT));
129 ilm = plower("oS", "ICON", s);
130 } else {
131 ast_error("unknown hollerith type for conversion to integer", ast);
132 }
133 break;
134 case TY_CHAR:
135 if (!ast || A_TYPEG(ast) != A_CNST) {
136 ast_error("cannot convert string to integer", ast);
137 } else {
138 int sptr;
139 sptr = A_SPTRG(ast);
140 cp = stb.n_base + CONVAL1G(sptr);
141 holtonum(cp, n, 1);
142 s = lower_getintcon(n[3]);
143 ilm = plower("oS", "ICON", s);
144 }
145 break;
146 default:
147 ast_error("unknown source type for conversion to integer", ast);
148 break;
149 }
150 return ilm;
151 } /* conv_bint_ilm */
152
153 /* convert whatever type ast is to BINT */
154 static int
conv_bint(int ast)155 conv_bint(int ast)
156 {
157 return conv_bint_ilm(ast, lower_ilm(ast), A_NDTYPEG(ast));
158 } /* conv_bint */
159
160 /* convert whatever type ilm is to SINT */
161 static int
conv_sint_ilm(int ast,int ilm,int dtype)162 conv_sint_ilm(int ast, int ilm, int dtype)
163 {
164 int s;
165 char *cp;
166 int n[4];
167 switch (DTYG(dtype)) {
168 case TY_BLOG:
169 case TY_BINT:
170 ilm = plower("oi", "SCTOI", ilm);
171 ilm = plower("oi", "ITOS", ilm);
172 break;
173 case TY_SLOG:
174 case TY_SINT:
175 break;
176 case TY_LOG:
177 case TY_INT:
178 ilm = plower("oi", "ITOS", ilm);
179 break;
180 case TY_LOG8:
181 case TY_INT8:
182 ilm = plower("oi", "I8TOI", ilm);
183 ilm = plower("oi", "ITOS", ilm);
184 break;
185 case TY_REAL:
186 ilm = plower("oi", "FIX", ilm);
187 ilm = plower("oi", "ITOS", ilm);
188 break;
189 case TY_DBLE:
190 ilm = plower("oi", "DFIX", ilm);
191 ilm = plower("oi", "ITOS", ilm);
192 break;
193 case TY_CMPLX:
194 ilm = plower("oi", "REAL", ilm);
195 ilm = plower("oi", "FIX", ilm);
196 ilm = plower("oi", "ITOS", ilm);
197 break;
198 case TY_DCMPLX:
199 ilm = plower("oi", "DREAL", ilm);
200 ilm = plower("oi", "DFIX", ilm);
201 ilm = plower("oi", "ITOS", ilm);
202 break;
203 case TY_WORD:
204 if (ast && A_TYPEG(ast) == A_CNST) {
205 s = lower_getintcon(cngcon(CONVAL2G(A_SPTRG(ast)), DTYG(dtype), DT_INT4));
206 ilm = plower("oS", "ICON", s);
207 ilm = plower("oi", "UITOS", ilm);
208 } else {
209 ilm = plower("oi", "UITOS", ilm);
210 }
211 break;
212 case TY_DWORD:
213 /* convert by padding with blanks or truncating */
214 if (ast && A_TYPEG(ast) == A_CNST) {
215 s = lower_getintcon(cngcon(A_SPTRG(ast), DTYG(dtype), DT_INT4));
216 ilm = plower("oS", "ICON", s);
217 ilm = plower("oi", "UITOS", ilm);
218 } else {
219 ilm = plower("oi", "K2I", ilm);
220 ilm = plower("oi", "ITOS", ilm);
221 }
222 break;
223 case TY_HOLL:
224 /* convert by padding with blanks or truncating */
225 if (ast && A_TYPEG(ast) == A_CNST) {
226 s = lower_getintcon(cngcon(A_SPTRG(ast), DTYG(dtype), DT_SINT));
227 ilm = plower("oS", "ICON", s);
228 } else {
229 ast_error("unknown hollerith type for conversion to integer", ast);
230 }
231 break;
232 case TY_CHAR:
233 if (!ast || A_TYPEG(ast) != A_CNST) {
234 ast_error("cannot convert string to integer", ast);
235 } else {
236 int sptr;
237 sptr = A_SPTRG(ast);
238 cp = stb.n_base + CONVAL1G(sptr);
239 holtonum(cp, n, 2);
240 s = lower_getintcon(n[3]);
241 ilm = plower("oS", "ICON", s);
242 ilm = plower("oi", "UITOS", ilm);
243 }
244 break;
245 default:
246 ast_error("unknown source type for conversion to integer", ast);
247 break;
248 }
249 return ilm;
250 } /* conv_sint_ilm */
251
252 /* convert whatever type ast is to SINT */
253 static int
conv_sint(int ast)254 conv_sint(int ast)
255 {
256 return conv_sint_ilm(ast, lower_ilm(ast), A_NDTYPEG(ast));
257 } /* conv_sint */
258
259 /* convert whatever type ilm is to INT */
260 static int
conv_int_ilm(int ast,int ilm,int dtype)261 conv_int_ilm(int ast, int ilm, int dtype)
262 {
263 int s;
264 char *cp;
265 int n[4];
266 switch (DTYG(dtype)) {
267 case TY_BINT:
268 case TY_BLOG:
269 ilm = plower("oi", "SCTOI", ilm);
270 break;
271 case TY_SINT:
272 case TY_SLOG:
273 ilm = plower("oi", "STOI", ilm);
274 break;
275 case TY_INT:
276 case TY_LOG:
277 break;
278 case TY_PTR:
279 if (XBIT(49, 0x100)) { /* 64-bit pointers */
280 ilm = plower("oi", "I8TOI", ilm);
281 }
282 break;
283 case TY_INT8:
284 case TY_LOG8:
285 ilm = plower("oi", "I8TOI", ilm);
286 break;
287 case TY_REAL:
288 ilm = plower("oi", "FIX", ilm);
289 break;
290 case TY_DBLE:
291 ilm = plower("oi", "DFIX", ilm);
292 break;
293 case TY_CMPLX:
294 ilm = plower("oi", "REAL", ilm);
295 ilm = plower("oi", "FIX", ilm);
296 break;
297 case TY_DCMPLX:
298 ilm = plower("oi", "DREAL", ilm);
299 ilm = plower("oi", "DFIX", ilm);
300 break;
301 case TY_WORD:
302 if (ast && A_TYPEG(ast) == A_CNST) {
303 s = lower_getintcon(cngcon(CONVAL2G(A_SPTRG(ast)), DTYG(dtype), DT_INT4));
304 ilm = plower("oS", "ICON", s);
305 } else {
306 ilm = plower("oi", "UITOI", ilm);
307 }
308 break;
309 case TY_DWORD:
310 if (ast && A_TYPEG(ast) == A_CNST) {
311 s = lower_getintcon(cngcon(A_SPTRG(ast), DTYG(dtype), DT_INT4));
312 ilm = plower("oS", "ICON", s);
313 } else {
314 ilm = plower("oi", "K2I", ilm);
315 }
316 break;
317 case TY_HOLL:
318 /* convert by padding with blanks or truncating */
319 if (ast && A_TYPEG(ast) == A_CNST) {
320 s = lower_getintcon(cngcon(A_SPTRG(ast), DTYG(dtype), DT_INT4));
321 ilm = plower("oS", "ICON", s);
322 } else {
323 ast_error("unknown hollerith type for conversion to integer", ast);
324 }
325 break;
326 case TY_CHAR:
327 if (!ast || A_TYPEG(ast) != A_CNST) {
328 ast_error("cannot convert string to integer", ast);
329 } else {
330 int sptr;
331 sptr = A_SPTRG(ast);
332 cp = stb.n_base + CONVAL1G(sptr);
333 holtonum(cp, n, 4);
334 s = lower_getintcon(n[3]);
335 ilm = plower("oS", "ICON", s);
336 }
337 break;
338 default:
339 ast_error("unknown source type for conversion to integer", ast);
340 break;
341 }
342 return ilm;
343 } /* conv_int_ilm */
344
345 /* convert whatever type ast is to INT */
346 static int
conv_int(int ast)347 conv_int(int ast)
348 {
349 return conv_int_ilm(ast, lower_ilm(ast), A_NDTYPEG(ast));
350 } /* conv_int */
351
352 /* convert whatever type ilm is to INT8 */
353 static int
conv_int8_ilm(int ast,int ilm,int dtype)354 conv_int8_ilm(int ast, int ilm, int dtype)
355 {
356 int s;
357 char *cp;
358 int n[4];
359 switch (DTYG(dtype)) {
360 case TY_BINT:
361 case TY_BLOG:
362 case TY_SINT:
363 case TY_SLOG:
364 case TY_INT:
365 case TY_LOG:
366 ilm = conv_int_ilm(ast, ilm, dtype);
367 ilm = plower("oi", "ITOI8", ilm);
368 break;
369 case TY_PTR:
370 if (!XBIT(49, 0x100)) { /* not 64-bit pointers */
371 ilm = plower("oi", "ITOI8", ilm);
372 }
373 break;
374 case TY_INT8:
375 case TY_LOG8:
376 break;
377 case TY_REAL:
378 ilm = plower("oi", "KFIX", ilm);
379 break;
380 case TY_DBLE:
381 ilm = plower("oi", "KDFIX", ilm);
382 break;
383 case TY_CMPLX:
384 ilm = plower("oi", "REAL", ilm);
385 ilm = plower("oi", "KFIX", ilm);
386 break;
387 case TY_DCMPLX:
388 ilm = plower("oi", "DREAL", ilm);
389 ilm = plower("oi", "KDFIX", ilm);
390 break;
391 case TY_WORD:
392 if (ast && A_TYPEG(ast) == A_CNST) {
393 s = cngcon(CONVAL2G(A_SPTRG(ast)), DTYG(dtype), DT_INT8);
394 ilm = plower("oS", "KCON", s);
395 } else {
396 ilm = plower("oi", "UI2K", ilm);
397 }
398 break;
399 case TY_DWORD:
400 if (ast && A_TYPEG(ast) == A_CNST) {
401 s = cngcon(A_SPTRG(ast), DTYG(dtype), DT_INT8);
402 ilm = plower("oS", "KCON", s);
403 }
404 break;
405 case TY_HOLL:
406 /* convert by padding with blanks or truncating */
407 if (ast && A_TYPEG(ast) == A_CNST) {
408 s = cngcon(A_SPTRG(ast), DTYG(dtype), DT_INT8);
409 ilm = plower("oS", "KCON", s);
410 } else {
411 ast_error("unknown hollerith type for conversion to integer*8", ast);
412 }
413 break;
414 case TY_CHAR:
415 if (!ast || A_TYPEG(ast) != A_CNST) {
416 ast_error("cannot convert string to integer", ast);
417 } else {
418 int sptr;
419 sptr = A_SPTRG(ast);
420 cp = stb.n_base + CONVAL1G(sptr);
421 holtonum(cp, n, 8);
422 if (flg.endian == 0) {
423 int swap;
424 /* for little endian, need to swap words in each double word
425 * quantity. Order of bytes in a word is okay, but not the
426 * order of words.
427 */
428 swap = n[2];
429 n[2] = n[3];
430 n[3] = swap;
431 }
432 s = getcon(n + 2, DT_INT8);
433 VISITP(s, 1);
434 lower_use_datatype(DT_INT8, 1);
435 ilm = plower("oS", "ICON", s);
436 }
437 break;
438 default:
439 ast_error("unknown source type for conversion to integer*8", ast);
440 break;
441 }
442 return ilm;
443 } /* conv_int8_ilm */
444
445 /* convert whatever type ast is to INT8 */
446 static int
conv_int8(int ast)447 conv_int8(int ast)
448 {
449 return conv_int8_ilm(ast, lower_ilm(ast), A_NDTYPEG(ast));
450 } /* conv_int8 */
451
452 /* convert whatever type ilm is to WORD */
453 static int
conv_word_ilm(int ast,int ilm,int dtype)454 conv_word_ilm(int ast, int ilm, int dtype)
455 {
456 int s;
457 switch (DTYG(dtype)) {
458 case TY_BINT:
459 case TY_BLOG:
460 ilm = plower("oi", "SCTOUI", ilm);
461 break;
462 case TY_SINT:
463 case TY_SLOG:
464 ilm = plower("oi", "STOUI", ilm);
465 break;
466 case TY_INT:
467 case TY_LOG:
468 ilm = plower("oi", "ITOUI", ilm);
469 break;
470 case TY_INT8:
471 case TY_LOG8:
472 ilm = plower("oi", "K2I", ilm);
473 break;
474 case TY_REAL:
475 ilm = plower("oi", "RTOUI", ilm);
476 break;
477 case TY_DBLE:
478 ilm = plower("oi", "DTOUI", ilm);
479 break;
480 case TY_CMPLX:
481 ilm = plower("oi", "CTOUDI", ilm);
482 ilm = plower("oi", "UDITOUI", ilm);
483 break;
484 case TY_DCMPLX:
485 ilm = plower("oi", "CDTOUDI", ilm);
486 ilm = plower("oi", "UDITOUI", ilm);
487 break;
488 case TY_WORD:
489 break;
490 case TY_DWORD:
491 ilm = plower("oi", "K2I", ilm);
492 ilm = plower("oi", "ITOUI", ilm);
493 break;
494 case TY_HOLL:
495 /* convert by padding with blanks or truncating */
496 if (ast && A_TYPEG(ast) == A_CNST) {
497 s = lower_getintcon(cngcon(A_SPTRG(ast), DTYG(dtype), DT_WORD));
498 ilm = plower("oS", "ICON", s);
499 } else {
500 ast_error("unknown hollerith type for conversion to word", ast);
501 }
502 break;
503 default:
504 ast_error("unknown source type for conversion to word", ast);
505 break;
506 }
507 return ilm;
508 } /* conv_word_ilm */
509
510 /* convert whatever type ast is to WORD */
511 static int
conv_word(int ast)512 conv_word(int ast)
513 {
514 return conv_word_ilm(ast, lower_ilm(ast), A_NDTYPEG(ast));
515 } /* conv_word */
516
517 /* convert whatever type ilm is to DWORD */
518 static int
conv_dword_ilm(int ast,int ilm,int dtype)519 conv_dword_ilm(int ast, int ilm, int dtype)
520 {
521 int s;
522 switch (DTYG(dtype)) {
523 case TY_BINT:
524 case TY_BLOG:
525 ilm = plower("oi", "SCTOI", ilm);
526 ilm = plower("oi", "I2K", ilm);
527 break;
528 case TY_SINT:
529 case TY_SLOG:
530 ilm = plower("oi", "STOI", ilm);
531 ilm = plower("oi", "I2K", ilm);
532 break;
533 case TY_INT:
534 case TY_LOG:
535 ilm = plower("oi", "I2K", ilm);
536 break;
537 case TY_INT8:
538 case TY_LOG8:
539 break;
540 case TY_REAL:
541 ilm = plower("oi", "RTOUI", ilm);
542 ilm = plower("oi", "UI2K", ilm);
543 break;
544 case TY_DBLE:
545 ilm = plower("oi", "D2K", ilm);
546 break;
547 case TY_CMPLX:
548 ilm = plower("oi", "CTOUDI", ilm);
549 ilm = plower("oi", "UDITOD", ilm);
550 ilm = plower("oi", "D2K", ilm);
551 break;
552 case TY_DCMPLX:
553 ilm = plower("oi", "CDTOUDI", ilm);
554 ilm = plower("oi", "UDITOD", ilm);
555 ilm = plower("oi", "D2K", ilm);
556 break;
557 case TY_WORD:
558 ilm = plower("oi", "UI2K", ilm);
559 break;
560 case TY_DWORD:
561 break;
562 case TY_HOLL:
563 /* convert by padding with blanks or truncating */
564 if (ast && A_TYPEG(ast) == A_CNST) {
565 s = cngcon(A_SPTRG(ast), DTYG(dtype), DT_INT8);
566 ilm = plower("oS", "KCON", s);
567 } else {
568 ast_error("unknown hollerith type for conversion to integer*8", ast);
569 }
570 break;
571 default:
572 ast_error("unknown source type for conversion to integer*8", ast);
573 break;
574 }
575 return ilm;
576 } /* conv_dword_ilm */
577
578 /* convert whatever type ast is to DWORD */
579 static int
conv_dword(int ast)580 conv_dword(int ast)
581 {
582 return conv_dword_ilm(ast, lower_ilm(ast), A_NDTYPEG(ast));
583 } /* conv_dword */
584
585 /* convert whatever type ilm is to BLOG */
586 static int
conv_blog_ilm(int ast,int ilm,int dtype)587 conv_blog_ilm(int ast, int ilm, int dtype)
588 {
589 int s;
590 switch (DTYG(dtype)) {
591 case TY_BLOG:
592 case TY_BINT:
593 break;
594 case TY_SLOG:
595 case TY_SINT:
596 ilm = plower("oi", "STOI", ilm);
597 ilm = plower("oi", "ITOSC", ilm);
598 break;
599 case TY_LOG:
600 case TY_INT:
601 ilm = plower("oi", "ITOSC", ilm);
602 break;
603 case TY_LOG8:
604 case TY_INT8:
605 ilm = plower("oi", "I8TOI", ilm);
606 ilm = plower("oi", "ITOSC", ilm);
607 case TY_WORD:
608 if (ast && A_TYPEG(ast) == A_CNST) {
609 s = lower_getintcon(cngcon(CONVAL2G(A_SPTRG(ast)), DTYG(dtype), DT_SLOG));
610 ilm = plower("oS", "LCON", s);
611 } else {
612 ilm = plower("oi", "UITOSC", ilm);
613 }
614 break;
615 case TY_DWORD:
616 if (ast && A_TYPEG(ast) == A_CNST) {
617 s = lower_getintcon(cngcon(A_SPTRG(ast), DTYG(dtype), DT_SLOG));
618 ilm = plower("oS", "LCON", s);
619 } else {
620 ilm = plower("oi", "K2I", ilm);
621 ilm = plower("oi", "ITOSC", ilm);
622 }
623 break;
624 case TY_HOLL:
625 /* convert by padding with blanks or truncating */
626 if (ast && A_TYPEG(ast) == A_CNST) {
627 s = lower_getintcon(cngcon(A_SPTRG(ast), DTYG(dtype), DT_LOG4));
628 ilm = plower("oS", "LCON", s);
629 } else {
630 ast_error("unknown type for conversion to logical", ast);
631 }
632 break;
633 default:
634 ast_error("unknown source type for conversion to logical", ast);
635 break;
636 }
637 return ilm;
638 } /* conv_blog_ilm */
639
640 /* convert whatever type ast is to BLOG */
641 static int
conv_blog(int ast)642 conv_blog(int ast)
643 {
644 return conv_blog_ilm(ast, lower_ilm(ast), A_NDTYPEG(ast));
645 } /* conv_blog */
646
647 /* convert whatever type ilm is to SLOG */
648 static int
conv_slog_ilm(int ast,int ilm,int dtype)649 conv_slog_ilm(int ast, int ilm, int dtype)
650 {
651 int s;
652 switch (DTYG(dtype)) {
653 case TY_BLOG:
654 case TY_BINT:
655 ilm = plower("oi", "SCTOI", ilm);
656 ilm = plower("oi", "ITOS", ilm);
657 break;
658 case TY_SLOG:
659 case TY_SINT:
660 break;
661 case TY_LOG:
662 case TY_INT:
663 ilm = plower("oi", "ITOS", ilm);
664 break;
665 case TY_WORD:
666 if (ast && A_TYPEG(ast) == A_CNST) {
667 s = lower_getintcon(cngcon(CONVAL2G(A_SPTRG(ast)), DTYG(dtype), DT_SLOG));
668 ilm = plower("oS", "LCON", s);
669 } else {
670 ilm = plower("oi", "UITOS", ilm);
671 }
672 break;
673 case TY_LOG8:
674 case TY_INT8:
675 ilm = plower("oi", "I8TOI", ilm);
676 ilm = plower("oi", "ITOS", ilm);
677 break;
678 case TY_DWORD:
679 if (ast && A_TYPEG(ast) == A_CNST) {
680 s = lower_getintcon(cngcon(A_SPTRG(ast), DTYG(dtype), DT_SLOG));
681 ilm = plower("oS", "LCON", s);
682 } else {
683 ilm = plower("oi", "K2I", ilm);
684 ilm = plower("oi", "ITOS", ilm);
685 }
686 break;
687 case TY_HOLL:
688 /* convert by padding with blanks or truncating */
689 if (ast && A_TYPEG(ast) == A_CNST) {
690 s = lower_getintcon(cngcon(A_SPTRG(ast), DTYG(dtype), DT_LOG4));
691 ilm = plower("oS", "LCON", s);
692 } else {
693 ast_error("unknown type for conversion to logical", ast);
694 }
695 break;
696 default:
697 ast_error("unknown source type for conversion to logical", ast);
698 break;
699 }
700 return ilm;
701 } /* conv_slog_ilm */
702
703 /* convert whatever type ast is to SLOG */
704 static int
conv_slog(int ast)705 conv_slog(int ast)
706 {
707 return conv_slog_ilm(ast, lower_ilm(ast), A_NDTYPEG(ast));
708 } /* conv_slog */
709
710 /* convert whatever type ilm is to LOG */
711 static int
conv_log_ilm(int ast,int ilm,int dtype)712 conv_log_ilm(int ast, int ilm, int dtype)
713 {
714 int s;
715 switch (DTYG(dtype)) {
716 case TY_BLOG:
717 case TY_BINT:
718 ilm = plower("oi", "SCTOI", ilm);
719 break;
720 case TY_SLOG:
721 case TY_SINT:
722 ilm = plower("oi", "STOI", ilm);
723 break;
724 case TY_LOG:
725 break;
726 case TY_INT:
727 if (ast && A_TYPEG(ast) == A_CNST) {
728 s = lower_getlogcon(cngcon(CONVAL2G(A_SPTRG(ast)), DTYG(dtype), DT_LOG4));
729 ilm = plower("oS", "LCON", s);
730 } else {
731 return ilm;
732 }
733 break;
734 case TY_WORD:
735 if (ast && A_TYPEG(ast) == A_CNST) {
736 s = lower_getlogcon(cngcon(CONVAL2G(A_SPTRG(ast)), DTYG(dtype), DT_LOG4));
737 ilm = plower("oS", "LCON", s);
738 } else {
739 ilm = plower("oi", "UITOI", ilm);
740 }
741 break;
742 case TY_DWORD:
743 if (ast && A_TYPEG(ast) == A_CNST) {
744 s = lower_getlogcon(cngcon(A_SPTRG(ast), DTYG(dtype), DT_LOG4));
745 ilm = plower("oS", "LCON", s);
746 } else {
747 ilm = plower("oi", "K2I", ilm);
748 }
749 break;
750 case TY_HOLL:
751 /* convert by padding with blanks or truncating */
752 if (ast && A_TYPEG(ast) == A_CNST) {
753 s = lower_getintcon(cngcon(A_SPTRG(ast), DTYG(dtype), DT_LOG4));
754 ilm = plower("oS", "LCON", s);
755 } else {
756 ast_error("unknown type for conversion to logical", ast);
757 }
758 break;
759 case TY_REAL:
760 case TY_DBLE:
761 case TY_LOG8:
762 case TY_INT8:
763 case TY_CMPLX:
764 case TY_DCMPLX:
765 ilm = conv_int_ilm(ast, ilm, dtype);
766 break;
767 case TY_CHAR:
768 if (DTY(dtype + 1) == astb.i1 && ast && A_TYPEG(ast) == A_CNST) {
769 int sptr = A_SPTRG(ast);
770 /* create an integer with the value of the character */
771 s = (int)(stb.n_base[CONVAL1G(sptr)]);
772 s = lower_getintcon(s);
773 ilm = plower("oS", "ICON", s);
774 } else {
775 ast_error("cannot convert string to logical", ast);
776 }
777 break;
778 default:
779 ast_error("unknown source type for conversion to logical", ast);
780 break;
781 }
782 return ilm;
783 } /* conv_log_ilm */
784
785 /* convert whatever type ast is to LOG */
786 static int
conv_log(int ast)787 conv_log(int ast)
788 {
789 return conv_log_ilm(ast, lower_ilm(ast), A_NDTYPEG(ast));
790 } /* conv_log */
791
792 /* convert whatever type ilm is to LOG8 */
793 static int
conv_log8_ilm(int ast,int ilm,int dtype)794 conv_log8_ilm(int ast, int ilm, int dtype)
795 {
796 int s;
797 switch (DTYG(dtype)) {
798 case TY_BLOG:
799 case TY_BINT:
800 case TY_SLOG:
801 case TY_SINT:
802 case TY_LOG:
803 case TY_INT:
804 case TY_REAL:
805 ilm = conv_log_ilm(ast, ilm, dtype);
806 ilm = plower("oi", "ITOI8", ilm);
807 break;
808 case TY_WORD:
809 /* convert by padding with blanks or truncating */
810 if (ast && A_TYPEG(ast) == A_CNST) {
811 s = A_SPTRG(ast);
812 s = cngcon(CONVAL2G(s), DTYG(dtype), DT_LOG8);
813 ilm = plower("oS", "KCON", s);
814 } else {
815 ilm = plower("oi", "UI2K", ilm);
816 }
817 break;
818 case TY_DWORD:
819 /* convert by padding with blanks or truncating */
820 if (ast && A_TYPEG(ast) == A_CNST) {
821 s = cngcon(A_SPTRG(ast), DTYG(dtype), DT_LOG8);
822 ilm = plower("oS", "KCON", s);
823 }
824 break;
825 case TY_HOLL:
826 /* convert by padding with blanks or truncating */
827 if (ast && A_TYPEG(ast) == A_CNST) {
828 s = cngcon(A_SPTRG(ast), DTYG(dtype), DT_LOG8);
829 ilm = plower("oS", "KCON", s);
830 } else {
831 ast_error("unknown type for conversion to logical", ast);
832 }
833 break;
834 case TY_LOG8:
835 case TY_INT8:
836 break;
837 case TY_DBLE:
838 case TY_CMPLX:
839 case TY_DCMPLX:
840 ilm = conv_int8_ilm(ast, ilm, dtype);
841 break;
842 case TY_CHAR:
843 if (DTY(dtype + 1) == astb.i1 && ast && A_TYPEG(ast) == A_CNST) {
844 int sptr = A_SPTRG(ast);
845 /* create an integer with the value of the character */
846 s = (int)(stb.n_base[CONVAL1G(sptr)]);
847 s = lower_getintcon(s);
848 ilm = plower("oS", "ICON", s);
849 ilm = plower("oi", "ITOI8", ilm);
850 } else {
851 ast_error("cannot convert string to logical", ast);
852 }
853 break;
854 default:
855 ast_error("unknown source type for conversion to logical*8", ast);
856 break;
857 }
858 return ilm;
859 } /* conv_log8_ilm */
860
861 /* convert whatever type ast is to LOG8 */
862 static int
conv_log8(int ast)863 conv_log8(int ast)
864 {
865 return conv_log8_ilm(ast, lower_ilm(ast), A_NDTYPEG(ast));
866 } /* conv_log8 */
867
868 /* convert whatever type ilm is to REAL */
869 static int
conv_real_ilm(int ast,int ilm,int dtype)870 conv_real_ilm(int ast, int ilm, int dtype)
871 {
872 int s;
873 switch (DTYG(dtype)) {
874 case TY_BINT:
875 case TY_BLOG:
876 case TY_SINT:
877 case TY_SLOG:
878 case TY_LOG:
879 case TY_INT:
880 ilm = conv_int_ilm(ast, ilm, dtype);
881 ilm = plower("oi", "FLOAT", ilm);
882 break;
883 case TY_LOG8:
884 case TY_INT8:
885 ilm = plower("oi", "FLOATK", ilm);
886 break;
887 case TY_REAL:
888 break;
889 case TY_DBLE:
890 ilm = plower("oi", "SNGL", ilm);
891 break;
892 case TY_CMPLX:
893 ilm = plower("oi", "REAL", ilm);
894 break;
895 case TY_DCMPLX:
896 ilm = plower("oi", "DREAL", ilm);
897 ilm = plower("oi", "SNGL", ilm);
898 break;
899 case TY_WORD:
900 if (ast && A_TYPEG(ast) == A_CNST) {
901 s = lower_getrealcon(
902 cngcon(CONVAL2G(A_SPTRG(ast)), DTYG(dtype), DT_REAL4));
903 ilm = plower("oS", "RCON", s);
904 } else {
905 ilm = plower("oi", "UITOR", ilm);
906 }
907 break;
908 case TY_DWORD:
909 if (ast && A_TYPEG(ast) == A_CNST) {
910 s = lower_getrealcon(cngcon(A_SPTRG(ast), DTYG(dtype), DT_REAL4));
911 ilm = plower("oS", "RCON", s);
912 } else {
913 ilm = plower("oi", "K2R", ilm);
914 }
915 break;
916 case TY_HOLL:
917 /* convert by padding with blanks or truncating */
918 if (ast && A_TYPEG(ast) == A_CNST) {
919 s = lower_getrealcon(cngcon(A_SPTRG(ast), DTYG(dtype), DT_REAL4));
920 ilm = plower("oS", "RCON", s);
921 } else {
922 ast_error("unknown type for conversion to real", ast);
923 }
924 break;
925 case TY_PTR:
926 dtype = DTY(dtype + 1);
927 if (DTY(dtype) == TY_PROC)
928 dtype = DTY(dtype + 1);
929 return conv_real_ilm(ast, ilm, dtype);
930 default:
931 ast_error("unknown source type for conversion to real", ast);
932 break;
933 }
934 return ilm;
935 } /* conv_real_ilm */
936
937 /* convert whatever type ast is to REAL */
938 static int
conv_real(int ast)939 conv_real(int ast)
940 {
941 return conv_real_ilm(ast, lower_ilm(ast), A_NDTYPEG(ast));
942 } /* conv_real */
943
944 /* convert whatever type ilm is to DBLE */
945 static int
conv_dble_ilm(int ast,int ilm,int dtype)946 conv_dble_ilm(int ast, int ilm, int dtype)
947 {
948 int s;
949 switch (DTYG(dtype)) {
950 case TY_BINT:
951 case TY_BLOG:
952 case TY_SINT:
953 case TY_SLOG:
954 ilm = conv_int_ilm(ast, ilm, dtype);
955 case TY_LOG:
956 case TY_INT:
957 ilm = plower("oi", "DFLOAT", ilm);
958 break;
959 case TY_LOG8:
960 case TY_INT8:
961 ilm = plower("oi", "DFLOATK", ilm);
962 break;
963 case TY_REAL:
964 ilm = plower("oi", "DBLE", ilm);
965 break;
966 case TY_DBLE:
967 break;
968 case TY_CMPLX:
969 ilm = plower("oi", "REAL", ilm);
970 ilm = plower("oi", "DBLE", ilm);
971 break;
972 case TY_DCMPLX:
973 ilm = plower("oi", "DREAL", ilm);
974 break;
975 case TY_WORD:
976 /* convert by padding with blanks or truncating */
977 if (ast && A_TYPEG(ast) == A_CNST) {
978 s = cngcon(CONVAL2G(A_SPTRG(ast)), DTYG(dtype), DT_REAL8);
979 ilm = plower("oS", "DCON", s);
980 } else {
981 ilm = plower("oi", "UITOD", ilm);
982 }
983 break;
984 case TY_DWORD:
985 /* convert by padding with blanks or truncating */
986 if (ast && A_TYPEG(ast) == A_CNST) {
987 s = cngcon(A_SPTRG(ast), DTYG(dtype), DT_REAL8);
988 ilm = plower("oS", "DCON", s);
989 } else {
990 ilm = plower("oi", "K2D", ilm);
991 }
992 break;
993 case TY_HOLL:
994 /* convert by padding with blanks or truncating */
995 if (ast && A_TYPEG(ast) == A_CNST) {
996 s = cngcon(A_SPTRG(ast), DTYG(dtype), DT_REAL8);
997 ilm = plower("oS", "DCON", s);
998 } else {
999 ast_error("unknown hollerith type for conversion to real*8", ast);
1000 }
1001 break;
1002 default:
1003 ast_error("unknown source type for conversion to double precision", ast);
1004 break;
1005 }
1006 return ilm;
1007 } /* conv_dble_ilm */
1008
1009 /* convert whatever type ast is to DBLE */
1010 static int
conv_dble(int ast)1011 conv_dble(int ast)
1012 {
1013 return conv_dble_ilm(ast, lower_ilm(ast), A_NDTYPEG(ast));
1014 } /* conv_dble */
1015
1016 /* convert whatever type ilm is to CMPLX */
1017 static int
conv_cmplx_ilm(int ast,int ilm,int dtype)1018 conv_cmplx_ilm(int ast, int ilm, int dtype)
1019 {
1020 int ilmimag, ilmreal, s;
1021 switch (DTYG(dtype)) {
1022 case TY_BINT:
1023 case TY_BLOG:
1024 case TY_SINT:
1025 case TY_SLOG:
1026 ilm = conv_int_ilm(ast, ilm, dtype);
1027 case TY_LOG:
1028 case TY_INT:
1029 ilm = plower("oi", "FLOAT", ilm);
1030 ilmimag = plower("oS", "RCON", lowersym.realzero);
1031 ilm = plower("oii", "CMPLX", ilm, ilmimag);
1032 break;
1033 case TY_LOG8:
1034 case TY_INT8:
1035 ilm = plower("oi", "I8TOI", ilm);
1036 ilm = plower("oi", "FLOAT", ilm);
1037 ilmimag = plower("oS", "RCON", lowersym.realzero);
1038 ilm = plower("oii", "CMPLX", ilm, ilmimag);
1039 break;
1040 case TY_REAL:
1041 ilmimag = plower("oS", "RCON", lowersym.realzero);
1042 ilm = plower("oii", "CMPLX", ilm, ilmimag);
1043 break;
1044 case TY_DBLE:
1045 ilm = plower("oi", "SNGL", ilm);
1046 ilmimag = plower("oS", "RCON", lowersym.realzero);
1047 ilm = plower("oii", "CMPLX", ilm, ilmimag);
1048 break;
1049 case TY_CMPLX:
1050 break;
1051 case TY_DCMPLX:
1052 ilmimag = plower("oi", "DIMAG", ilm);
1053 ilmimag = plower("oi", "SNGL", ilmimag);
1054 ilmreal = plower("oi", "DREAL", ilm);
1055 ilmreal = plower("oi", "SNGL", ilmreal);
1056 ilm = plower("oii", "CMPLX", ilmreal, ilmimag);
1057 break;
1058 case TY_WORD:
1059 if (ast && A_TYPEG(ast) == A_CNST) {
1060 s = lower_getrealcon(
1061 cngcon(CONVAL2G(A_SPTRG(ast)), DTYG(dtype), DT_REAL4));
1062 ilmreal = plower("oS", "RCON", s);
1063 } else {
1064 ilmreal = plower("oi", "UITOR", ilm);
1065 }
1066 ilmimag = plower("oS", "RCON", lowersym.realzero);
1067 ilm = plower("oii", "CMPLX", ilmreal, ilmimag);
1068 break;
1069 case TY_DWORD:
1070 case TY_HOLL:
1071 /* convert by padding with blanks or truncating */
1072 if (ast && A_TYPEG(ast) == A_CNST) {
1073 s = cngcon(A_SPTRG(ast), DTYG(dtype), DT_CMPLX8);
1074 ilm = plower("oS", "CCON", s);
1075 } else {
1076 ast_error("unknown type for conversion to complex", ast);
1077 }
1078 break;
1079 default:
1080 ast_error("unknown source type for conversion to complex", ast);
1081 break;
1082 }
1083 return ilm;
1084 } /* conv_cmplx_ilm */
1085
1086 /* convert whatever type ast is to CMPLX */
1087 static int
conv_cmplx(int ast)1088 conv_cmplx(int ast)
1089 {
1090 return conv_cmplx_ilm(ast, lower_ilm(ast), A_NDTYPEG(ast));
1091 } /* conv_cmplx */
1092
1093 /* convert whatever type ilm is to DCMPLX */
1094 static int
conv_dcmplx_ilm(int ast,int ilm,int dtype)1095 conv_dcmplx_ilm(int ast, int ilm, int dtype)
1096 {
1097 int ilmimag, ilmreal, s;
1098 switch (DTYG(dtype)) {
1099 case TY_BINT:
1100 case TY_BLOG:
1101 case TY_SINT:
1102 case TY_SLOG:
1103 ilm = conv_int_ilm(ast, ilm, dtype);
1104 case TY_LOG:
1105 case TY_INT:
1106 ilm = plower("oi", "DFLOAT", ilm);
1107 ilmimag = plower("oS", "DCON", lowersym.dblezero);
1108 ilm = plower("oii", "DCMPLX", ilm, ilmimag);
1109 break;
1110 case TY_LOG8:
1111 case TY_INT8:
1112 ilm = plower("oi", "DFLOATK", ilm);
1113 ilmimag = plower("oS", "DCON", lowersym.dblezero);
1114 ilm = plower("oii", "DCMPLX", ilm, ilmimag);
1115 break;
1116 case TY_REAL:
1117 ilm = plower("oi", "DBLE", ilm);
1118 ilmimag = plower("oS", "DCON", lowersym.dblezero);
1119 ilm = plower("oii", "DCMPLX", ilm, ilmimag);
1120 break;
1121 case TY_DBLE:
1122 ilmimag = plower("oS", "DCON", lowersym.dblezero);
1123 ilm = plower("oii", "DCMPLX", ilm, ilmimag);
1124 break;
1125 case TY_CMPLX:
1126 ilmimag = plower("oi", "IMAG", ilm);
1127 ilmimag = plower("oi", "DBLE", ilmimag);
1128 ilmreal = plower("oi", "REAL", ilm);
1129 ilmreal = plower("oi", "DBLE", ilmreal);
1130 ilm = plower("oii", "DCMPLX", ilmreal, ilmimag);
1131 break;
1132 case TY_DCMPLX:
1133 break;
1134 case TY_WORD:
1135 if (ast && A_TYPEG(ast) == A_CNST) {
1136 s = cngcon(CONVAL2G(A_SPTRG(ast)), DTYG(dtype), DT_REAL8);
1137 ilmreal = plower("oS", "DCON", s);
1138 } else {
1139 ilmreal = plower("oi", "UITOD", ilm);
1140 }
1141 ilmimag = plower("oS", "DCON", lowersym.dblezero);
1142 ilm = plower("oii", "DCMPLX", ilmreal, ilmimag);
1143 break;
1144 case TY_DWORD:
1145 if (ast && A_TYPEG(ast) == A_CNST) {
1146 s = cngcon(A_SPTRG(ast), DTYG(dtype), DT_REAL8);
1147 ilmreal = plower("oS", "DCON", s);
1148 } else {
1149 ilmreal = plower("oi", "K2D", ilm);
1150 }
1151 ilmimag = plower("oS", "DCON", lowersym.dblezero);
1152 ilm = plower("oii", "DCMPLX", ilmreal, ilmimag);
1153 break;
1154 case TY_HOLL:
1155 /* convert by padding with blanks or truncating */
1156 if (ast && A_TYPEG(ast) == A_CNST) {
1157 s = cngcon(A_SPTRG(ast), DTYG(dtype), DT_CMPLX16);
1158 ilm = plower("oS", "CDCON", s);
1159 } else {
1160 ast_error("unknown hollerith type for conversion to complex*16", ast);
1161 }
1162 break;
1163 default:
1164 ast_error("unknown source type for conversion to complex*16", ast);
1165 break;
1166 }
1167 return ilm;
1168 } /* conv_dcmplx_ilm */
1169
1170 /* convert whatever type ast is to DCMPLX */
1171 static int
conv_dcmplx(int ast)1172 conv_dcmplx(int ast)
1173 {
1174 return conv_dcmplx_ilm(ast, lower_ilm(ast), A_NDTYPEG(ast));
1175 } /* conv_dcmplx */
1176
1177 int
lower_conv_ilm(int ast,int ilm,int fromdtype,int todtype)1178 lower_conv_ilm(int ast, int ilm, int fromdtype, int todtype)
1179 {
1180 if (DTYG(fromdtype) == DTYG(todtype))
1181 return ilm;
1182
1183 switch (DTYG(todtype)) {
1184 case TY_BINT:
1185 ilm = conv_bint_ilm(ast, ilm, fromdtype);
1186 break;
1187 case TY_SINT:
1188 ilm = conv_sint_ilm(ast, ilm, fromdtype);
1189 break;
1190 case TY_INT:
1191 ilm = conv_int_ilm(ast, ilm, fromdtype);
1192 break;
1193 case TY_BLOG:
1194 ilm = conv_blog_ilm(ast, ilm, fromdtype);
1195 break;
1196 case TY_SLOG:
1197 ilm = conv_slog_ilm(ast, ilm, fromdtype);
1198 break;
1199 case TY_LOG:
1200 ilm = conv_log_ilm(ast, ilm, fromdtype);
1201 break;
1202 case TY_INT8:
1203 ilm = conv_int8_ilm(ast, ilm, fromdtype);
1204 break;
1205 case TY_REAL:
1206 ilm = conv_real_ilm(ast, ilm, fromdtype);
1207 break;
1208 case TY_DBLE:
1209 ilm = conv_dble_ilm(ast, ilm, fromdtype);
1210 break;
1211 case TY_CMPLX:
1212 ilm = conv_cmplx_ilm(ast, ilm, fromdtype);
1213 break;
1214 case TY_DCMPLX:
1215 ilm = conv_dcmplx_ilm(ast, ilm, fromdtype);
1216 break;
1217 case TY_WORD:
1218 ilm = conv_word_ilm(ast, ilm, fromdtype);
1219 break;
1220 case TY_DWORD:
1221 ilm = conv_dword_ilm(ast, ilm, fromdtype);
1222 break;
1223 default:
1224 ast_error("unknown target type for ilm conversion", ast);
1225 lerror("target type was %d", todtype);
1226 break;
1227 }
1228 return ilm;
1229 } /* lower_conv_ilm */
1230
1231 int
lower_conv(int ast,int dtype)1232 lower_conv(int ast, int dtype)
1233 {
1234 int ilm, adtype;
1235 adtype = A_NDTYPEG(ast);
1236 ilm = lower_ilm(ast);
1237 if (adtype <= 0 || eq_dtype(DTYG(adtype), DTYG(dtype)))
1238 return ilm;
1239
1240 switch (DTYG(dtype)) {
1241 case TY_BINT:
1242 ilm = conv_bint(ast);
1243 break;
1244 case TY_SINT:
1245 ilm = conv_sint(ast);
1246 break;
1247 case TY_INT:
1248 ilm = conv_int(ast);
1249 break;
1250 case TY_INT8:
1251 ilm = conv_int8(ast);
1252 break;
1253 case TY_BLOG:
1254 ilm = conv_blog(ast);
1255 break;
1256 case TY_SLOG:
1257 ilm = conv_slog(ast);
1258 break;
1259 case TY_LOG:
1260 ilm = conv_log(ast);
1261 break;
1262 case TY_LOG8:
1263 ilm = conv_log8(ast);
1264 break;
1265 case TY_REAL:
1266 ilm = conv_real(ast);
1267 break;
1268 case TY_DBLE:
1269 ilm = conv_dble(ast);
1270 break;
1271 case TY_CMPLX:
1272 ilm = conv_cmplx(ast);
1273 break;
1274 case TY_DCMPLX:
1275 ilm = conv_dcmplx(ast);
1276 break;
1277 case TY_WORD:
1278 ilm = conv_word(ast);
1279 break;
1280 case TY_DWORD:
1281 ilm = conv_dword(ast);
1282 break;
1283 case TY_PTR:
1284 /* convert to the pointee type */
1285 return lower_conv(ast, DTY(dtype + 1));
1286 default:
1287 ast_error("unknown target type for ast conversion", ast);
1288 lerror("target type was %d", dtype);
1289 break;
1290 }
1291 return ilm;
1292 } /* lower_conv */
1293
1294 char *
ltyped(char * opname,int dtype)1295 ltyped(char *opname, int dtype)
1296 {
1297 static char OP[100];
1298 switch (DTYG(dtype)) {
1299 case TY_BINT:
1300 case TY_SINT:
1301 case TY_INT:
1302 case TY_WORD:
1303 strcpy(OP, "I");
1304 break;
1305 case TY_PTR:
1306 if (XBIT(49, 0x100)) { /* 64-bit pointers */
1307 strcpy(OP, "K");
1308 } else {
1309 strcpy(OP, "I");
1310 }
1311 break;
1312 case TY_INT8:
1313 case TY_DWORD:
1314 case TY_LOG8:
1315 strcpy(OP, "K");
1316 break;
1317 case TY_REAL:
1318 strcpy(OP, "R");
1319 break;
1320 case TY_DBLE:
1321 strcpy(OP, "D");
1322 break;
1323 case TY_CMPLX:
1324 strcpy(OP, "C");
1325 break;
1326 case TY_DCMPLX:
1327 strcpy(OP, "CD");
1328 break;
1329 case TY_BLOG:
1330 case TY_SLOG:
1331 case TY_LOG:
1332 strcpy(OP, "L");
1333 break;
1334 case TY_CHAR:
1335 strcpy(OP, "CH");
1336 break;
1337 case TY_NCHAR:
1338 strcpy(OP, "NCH");
1339 break;
1340 default:
1341 strcpy(OP, "");
1342 lerror("untyped operation %s (type %d)", opname, dtype);
1343 break;
1344 }
1345 strcat(OP, opname);
1346 return OP;
1347 } /* typed */
1348
1349 static char *
styped(char * opname,int dtype)1350 styped(char *opname, int dtype)
1351 {
1352 static char OP[100];
1353 switch (DTYG(dtype)) {
1354 case TY_BINT:
1355 case TY_SINT:
1356 case TY_INT:
1357 strcpy(OP, "I");
1358 break;
1359 case TY_INT8:
1360 case TY_LOG8:
1361 strcpy(OP, "K");
1362 break;
1363 case TY_REAL:
1364 strcpy(OP, "R");
1365 break;
1366 case TY_DBLE:
1367 strcpy(OP, "D");
1368 break;
1369 case TY_CMPLX:
1370 strcpy(OP, "C");
1371 break;
1372 case TY_DCMPLX:
1373 strcpy(OP, "CD");
1374 break;
1375 case TY_BLOG:
1376 case TY_SLOG:
1377 case TY_LOG:
1378 strcpy(OP, "L");
1379 break;
1380 case TY_CHAR:
1381 strcpy(OP, "S");
1382 break;
1383 case TY_NCHAR:
1384 strcpy(OP, "NS");
1385 break;
1386 default:
1387 strcpy(OP, "");
1388 lerror("untyped s-operation %s (type %d)", opname, dtype);
1389 break;
1390 }
1391 strcat(OP, opname);
1392 return OP;
1393 } /* styped */
1394
1395 /* generate the ILM for a simple arithmetic binary operator.
1396 * the prefix for the operator name depends on the expression type */
1397 static int
lower_bin_arith(int ast,char * opname,int ldtype,int rdtype)1398 lower_bin_arith(int ast, char *opname, int ldtype, int rdtype)
1399 {
1400 int dtype, ilm, lilm, rilm;
1401 dtype = A_NDTYPEG(ast);
1402 if (dtype <= 0) {
1403 ast_error("unrecognized data type in lower_bin_arith", ast);
1404 return 0;
1405 }
1406 lilm = lower_conv(A_LOPG(ast), ldtype);
1407 rilm = lower_conv(A_ROPG(ast), rdtype);
1408 switch (DTYG(dtype)) {
1409 case TY_BINT:
1410 case TY_SINT:
1411 case TY_INT:
1412 case TY_INT8:
1413 case TY_REAL:
1414 case TY_DBLE:
1415 case TY_CMPLX:
1416 case TY_DCMPLX:
1417 case TY_WORD:
1418 case TY_DWORD:
1419 /* OK */
1420 break;
1421 case TY_BLOG:
1422 case TY_SLOG:
1423 case TY_LOG:
1424 case TY_LOG8:
1425 ast_error("logical result for arithmetic operation", ast);
1426 return 0;
1427 case TY_CHAR:
1428 case TY_NCHAR:
1429 ast_error("character result for arithmetic operation", ast);
1430 return 0;
1431 case TY_QUAD:
1432 case TY_QCMPLX:
1433 default:
1434 ast_error("unknown result for arithmetic operation", ast);
1435 return 0;
1436 }
1437 ilm = plower("oii", ltyped(opname, dtype), lilm, rilm);
1438 return ilm;
1439 } /* lower_bin_arith */
1440
1441 /* generate the ILM for a simple arithmetic unary operator.
1442 * the prefix for the operator name depends on the expression type */
1443 static int
lower_un_arith(int ast,char * opname,int ldtype)1444 lower_un_arith(int ast, char *opname, int ldtype)
1445 {
1446 int dtype, ilm, lilm;
1447 dtype = A_NDTYPEG(ast);
1448 if (dtype <= 0) {
1449 ast_error("unrecognized data type in lower_un_arith", ast);
1450 return 0;
1451 }
1452 lilm = lower_conv(A_LOPG(ast), ldtype);
1453 switch (DTYG(dtype)) {
1454 case TY_BINT:
1455 case TY_SINT:
1456 case TY_INT:
1457 case TY_INT8:
1458 case TY_REAL:
1459 case TY_DBLE:
1460 case TY_QUAD:
1461 case TY_CMPLX:
1462 case TY_DCMPLX:
1463 case TY_QCMPLX:
1464 case TY_WORD:
1465 case TY_DWORD:
1466 break;
1467 case TY_BLOG:
1468 case TY_SLOG:
1469 case TY_LOG:
1470 case TY_LOG8:
1471 ast_error("logical result for arithmetic operation", ast);
1472 return 0;
1473 case TY_CHAR:
1474 case TY_NCHAR:
1475 ast_error("character result for arithmetic operation", ast);
1476 return 0;
1477 default:
1478 ast_error("unknown result for arithmetic operation", ast);
1479 return 0;
1480 }
1481 ilm = plower("oi", ltyped(opname, dtype), lilm);
1482 return ilm;
1483 } /* lower_un_arith */
1484
1485 /* generate the ILM for a simple comparison operator.
1486 * the prefix for the operator name depends on the expression type */
1487 static int
lower_bin_comparison(int ast,char * op)1488 lower_bin_comparison(int ast, char *op)
1489 {
1490 int dtype, ilm, lilm, rilm, base;
1491 char opname[15];
1492
1493 dtype = A_NDTYPEG(ast);
1494 if (dtype <= 0) {
1495 ast_error("unrecognized data type in lower_bin_comparison", ast);
1496 return 0;
1497 }
1498 strcpy(opname, op);
1499 switch (DTYG(dtype)) {
1500 case TY_LOG:
1501 case TY_BLOG:
1502 case TY_SLOG:
1503 case TY_BINT:
1504 case TY_SINT:
1505 case TY_INT:
1506 case TY_WORD:
1507 break;
1508 case TY_LOG8:
1509 case TY_INT8:
1510 case TY_DWORD:
1511 strcat(opname, "8");
1512 break;
1513
1514 case TY_REAL:
1515 case TY_DBLE:
1516 case TY_QUAD:
1517 case TY_CMPLX:
1518 case TY_DCMPLX:
1519 case TY_QCMPLX:
1520 ast_error("arithmetic result for comparison operation", ast);
1521 return 0;
1522 case TY_CHAR:
1523 case TY_NCHAR:
1524 ast_error("character result for comparison operation", ast);
1525 return 0;
1526 default:
1527 ast_error("unknown result for comparison operation", ast);
1528 return 0;
1529 }
1530 dtype = A_NDTYPEG(A_LOPG(ast));
1531 if (dtype <= 0) {
1532 ast_error("unrecognized data type in lower_bin_comparison", ast);
1533 return 0;
1534 }
1535 base = 0;
1536 switch (DTYG(dtype)) {
1537 case TY_BINT:
1538 case TY_SINT:
1539 case TY_INT:
1540 case TY_INT8:
1541 case TY_REAL:
1542 case TY_DBLE:
1543 case TY_CMPLX:
1544 case TY_DCMPLX:
1545 break;
1546 case TY_BLOG:
1547 dtype = DT_BINT;
1548 break;
1549 case TY_SLOG:
1550 dtype = DT_SINT;
1551 break;
1552 case TY_WORD:
1553 case TY_LOG:
1554 dtype = DT_INT4;
1555 break;
1556 case TY_DWORD:
1557 case TY_LOG8:
1558 dtype = DT_INT8;
1559 break;
1560 case TY_CHAR:
1561 case TY_NCHAR:
1562 base = 1;
1563 break;
1564 case TY_QUAD:
1565 case TY_QCMPLX:
1566 default:
1567 ast_error("unknown operand type for comparison operation", ast);
1568 return 0;
1569 }
1570 if (base) {
1571 lilm = lower_base(A_LOPG(ast));
1572 rilm = lower_base(A_ROPG(ast));
1573 } else {
1574 lilm = lower_ilm(A_LOPG(ast));
1575 rilm = lower_conv(A_ROPG(ast), dtype);
1576 }
1577 ilm = plower("oii", styped("CMP", dtype), lilm, rilm);
1578 ilm = plower("oi", opname, ilm);
1579 return ilm;
1580 } /* lower_bin_comparison */
1581
1582 /* for a logical operation (and,or,not) if the operand
1583 * is not another logical operation, add an lnop */
1584 static int
add_lnop(int ilm,int ast,int dtype)1585 add_lnop(int ilm, int ast, int dtype)
1586 {
1587 char *opc;
1588 switch (A_TYPEG(ast)) {
1589 case A_BINOP:
1590 switch (A_OPTYPEG(ast)) {
1591 case OP_LNEQV:
1592 case OP_LEQV:
1593 case OP_LOR:
1594 case OP_LAND:
1595 case OP_SCAND:
1596 return ilm;
1597 }
1598 break;
1599 case A_UNOP:
1600 switch (A_OPTYPEG(ast)) {
1601 case OP_LNOT:
1602 return ilm;
1603 }
1604 break;
1605 }
1606 /* otherwise, add LNOP */
1607 switch (DTYG(dtype)) {
1608 case TY_LOG8:
1609 case TY_INT8:
1610 case TY_DWORD:
1611 opc = "LNOP8";
1612 break;
1613 default:
1614 opc = "LNOP";
1615 break;
1616 }
1617 ilm = plower("oi", opc, ilm);
1618 plower("o", "NOP");
1619 return ilm;
1620 } /* add_lnop */
1621
1622 /* generate the ILM for a simple logical binary operator.
1623 * the suffix for the operator name depends on the expression type */
1624 static int
lower_bin_logical(int ast,char * op)1625 lower_bin_logical(int ast, char *op)
1626 {
1627 int dtype, ilm, lilm, rilm;
1628 char opname[15];
1629 dtype = A_NDTYPEG(ast);
1630 if (dtype <= 0) {
1631 ast_error("unrecognized data type in lower_bin_logical", ast);
1632 return 0;
1633 }
1634 strcpy(opname, op);
1635 switch (DTYG(dtype)) {
1636 case TY_LOG:
1637 case TY_BLOG:
1638 case TY_SLOG:
1639 case TY_BINT:
1640 case TY_SINT:
1641 case TY_INT:
1642 case TY_WORD:
1643 break;
1644 case TY_LOG8:
1645 case TY_INT8:
1646 case TY_DWORD:
1647 strcat(opname, "8");
1648 break;
1649
1650 case TY_REAL:
1651 case TY_DBLE:
1652 case TY_QUAD:
1653 case TY_CMPLX:
1654 case TY_DCMPLX:
1655 case TY_QCMPLX:
1656 ast_error("arithmetic result for logical operation", ast);
1657 return 0;
1658 case TY_CHAR:
1659 case TY_NCHAR:
1660 ast_error("character result for logical operation", ast);
1661 return 0;
1662 default:
1663 ast_error("unknown result for logical operation", ast);
1664 return 0;
1665 }
1666 lilm = lower_conv(A_LOPG(ast), dtype);
1667 rilm = lower_conv(A_ROPG(ast), dtype);
1668 lilm = add_lnop(lilm, A_LOPG(ast), dtype);
1669 rilm = add_lnop(rilm, A_ROPG(ast), dtype);
1670 ilm = plower("oii", opname, lilm, rilm);
1671 return ilm;
1672 } /* lower_bin_logical */
1673
1674 /* generate the ILM for a simple logical unary operator.
1675 * the suffix for the operator name depends on the expression type */
1676 static int
lower_un_logical(int ast,char * op)1677 lower_un_logical(int ast, char *op)
1678 {
1679 int dtype, ilm, lilm;
1680 char opname[15];
1681 dtype = A_NDTYPEG(ast);
1682 if (dtype <= 0) {
1683 ast_error("unrecognized data type in lower_un_logical", ast);
1684 return 0;
1685 }
1686 strcpy(opname, op);
1687 switch (DTYG(dtype)) {
1688 case TY_SLOG:
1689 case TY_BLOG:
1690 case TY_LOG:
1691 break;
1692 case TY_LOG8:
1693 strcat(opname, "8");
1694 break;
1695
1696 case TY_BINT:
1697 case TY_SINT:
1698 case TY_INT:
1699 case TY_WORD:
1700 break;
1701 case TY_INT8:
1702 case TY_DWORD:
1703 strcat(opname, "8");
1704 break;
1705 case TY_REAL:
1706 case TY_DBLE:
1707 case TY_QUAD:
1708 case TY_CMPLX:
1709 case TY_DCMPLX:
1710 case TY_QCMPLX:
1711 ast_error("arithmetic result for logical operation", ast);
1712 return 0;
1713 case TY_CHAR:
1714 case TY_NCHAR:
1715 ast_error("character result for logical operation", ast);
1716 return 0;
1717 default:
1718 ast_error("unknown result for logical operation", ast);
1719 return 0;
1720 }
1721 lilm = lower_conv(A_LOPG(ast), dtype);
1722 lilm = add_lnop(lilm, A_LOPG(ast), dtype);
1723 ilm = plower("oi", opname, lilm);
1724 return ilm;
1725 } /* lower_un_logical */
1726
1727 int
lower_parenthesize_expression(int ast)1728 lower_parenthesize_expression(int ast)
1729 {
1730 int adtype;
1731 adtype = A_NDTYPEG(ast);
1732 if (ast == astb.ptr0 || ast == astb.ptr1 || ast == astb.ptr0c)
1733 return A_ILMG(ast);
1734 if (A_TYPEG(ast) == A_PAREN && (DT_ISNUMERIC(adtype) || DT_ISLOG(adtype))) {
1735 int a = A_LOPG(ast);
1736 if (A_TYPEG(a) == A_ID || A_TYPEG(a) == A_CNST) {
1737 int temp, lilm, rilm, ilm;
1738 temp = lower_scalar_temp(adtype);
1739 lilm = plower("oS", "BASE", temp);
1740 rilm = A_ILMG(ast);
1741 lower_typestore(adtype, lilm, rilm);
1742 ilm = plower("oS", "BASE", temp);
1743 return ilm;
1744 }
1745 }
1746 return A_ILMG(ast);
1747 } /* parenthesize_expression */
1748
1749 /* Return true for RTE functions that permit null pointers as args.
1750 * Don't insert null pointer check, even if -Mchkptr is set.
1751 */
1752 static bool
function_null_allowed(SPTR sptr)1753 function_null_allowed(SPTR sptr)
1754 {
1755 static FtnRtlEnum rtl_functions_null_allowed[] = {
1756 RTE_associated,
1757 RTE_associated_chara,
1758 RTE_associated_t,
1759 RTE_associated_tchara,
1760 RTE_conformable_11v,
1761 RTE_conformable_1dv,
1762 RTE_conformable_22v,
1763 RTE_conformable_2dv,
1764 RTE_conformable_33v,
1765 RTE_conformable_3dv,
1766 RTE_conformable_d1v,
1767 RTE_conformable_d2v,
1768 RTE_conformable_d3v,
1769 RTE_conformable_dd,
1770 RTE_conformable_dnv,
1771 RTE_conformable_ndv,
1772 RTE_conformable_nnv,
1773 RTE_extends_type_of,
1774 RTE_lena,
1775 RTE_lentrima,
1776 RTE_same_type_as,
1777 RTE_no_rtn /* marks end of list */
1778 };
1779 int i;
1780 for (i = 0;; i += 1) {
1781 char *rtnNm;
1782 FtnRtlEnum rtn = rtl_functions_null_allowed[i];
1783 if (rtn == RTE_no_rtn)
1784 return false;
1785 if (strcmp(SYMNAME(sptr), mkRteRtnNm(rtn)) == 0)
1786 return true;
1787 }
1788 }
1789
1790 int get_byval(int, int);
1791
1792 static int
lower_function(int ast)1793 lower_function(int ast)
1794 {
1795 int count, realcount, args, symfunc, dtype, i, ilm, ilm2;
1796 int dtproc, iface = 0, sptr, prevsptr, paramc;
1797 int callee;
1798 int functmp, functmpilm, functmpinc, funcusetmp, funcusecall;
1799 int paramcount, params, save_disable_ptr_chk;
1800 static int functmpcount;
1801 int is_procsym = 0;
1802 char *UCALL;
1803 char *PUFUNC;
1804 char *UFUNC;
1805 int is_tbp, tbp_nopass_arg, tbp_nopass_sdsc, tbp_mem;
1806 int tbp_bind, tbp_imp, tbp_inv;
1807 int unlpoly; /* CLASS(*) */
1808 int retdesc;
1809 int bindC_structret = 0;
1810 bool procDummyNeedsDesc;
1811
1812 /* symfunc = A_SPTRG( A_LOPG( ast ) );*/
1813 symfunc = procsym_of_ast(A_LOPG(ast));
1814 if (STYPEG(symfunc) == ST_MEMBER && CLASSG(symfunc) && CCSYMG(symfunc) &&
1815 VTABLEG(symfunc)) {
1816 symfunc = (IFACEG(symfunc)) ? IFACEG(symfunc) : VTABLEG(symfunc);
1817 }
1818
1819 procDummyNeedsDesc = proc_arg_needs_proc_desc(symfunc);
1820
1821 switch (A_TYPEG(A_LOPG(ast))) {
1822 case A_ID:
1823 case A_LABEL:
1824 case A_ENTRY:
1825 case A_SUBSCR:
1826 case A_SUBSTR:
1827 case A_MEM:
1828 tbp_mem = memsym_of_ast(A_LOPG(ast));
1829 if (STYPEG(tbp_mem) == ST_PROC && CLASSG(tbp_mem) && IS_TBP(tbp_mem)) {
1830 i = 0;
1831 get_implementation(TBPLNKG(tbp_mem), tbp_mem, 0, &i);
1832 if (STYPEG(BINDG(i)) == ST_OPERATOR ||
1833 STYPEG(BINDG(i)) == ST_USERGENERIC) {
1834 i = get_specific_member(TBPLNKG(tbp_mem), VTABLEG(i));
1835 }
1836
1837 tbp_mem = i;
1838 }
1839
1840 break;
1841 default:
1842 tbp_mem = 0;
1843 }
1844 tbp_nopass_arg = is_tbp = tbp_nopass_sdsc = tbp_bind = tbp_inv = 0;
1845 if (tbp_mem && CLASSG(tbp_mem) && CCSYMG(tbp_mem) &&
1846 STYPEG(tbp_mem) == ST_MEMBER) {
1847 tbp_bind = BINDG(tbp_mem);
1848 is_procsym = 1;
1849 is_tbp = 1;
1850 UCALL = "UVCALLA";
1851 PUFUNC = "PUVFUNCA";
1852 UFUNC = "UVFUNCA";
1853 #if DEBUG
1854 assert(!tbp_bind || STYPEG(tbp_bind) == ST_PROC,
1855 "lower_function: invalid stype for type bound procedure",
1856 STYPEG(tbp_bind), 4);
1857 #endif
1858 if (!INVOBJG(tbp_bind) && !NOPASSG(tbp_mem)) {
1859 /* Try to resolve INVOBJ. INVOBJ may be 0 here due to a
1860 * late attempt to resolve a generic routine/operator (e.g.,
1861 * a call to queue_tbp(0,0,0,0,TBP_COMPLETE_GENERIC) in
1862 * is_intrinsic_opr() of semgnr.c).
1863 * When we call queue_tbp(0,0,0,0,TBP_COMPLETE_GENERIC), we might
1864 * generate one or more tbp symbols with the same name. This can occur
1865 * if a tbp symbol and/or implementation is used in different
1866 * contexts. Therefore, tbp_bind and its INVOBJ field may not get
1867 * fully resolved until later.
1868 */
1869 get_tbp_argno(tbp_bind, ENCLDTYPEG(tbp_mem));
1870 }
1871 #if DEBUG
1872 assert(!INVOBJG(tbp_bind) != !NOPASSG(tbp_mem),
1873 "lower_function: either invobj or nopass must be set; not "
1874 "none or both",
1875 symfunc, 4);
1876 #endif
1877 if (NOPASSG(tbp_mem)) {
1878 tbp_nopass_arg = pass_sym_of_ast(A_LOPG(ast));
1879 tbp_nopass_sdsc =
1880 A_INVOKING_DESCG(ast) ? sym_of_ast(A_INVOKING_DESCG(ast)) : 0;
1881 if (!tbp_nopass_sdsc)
1882 tbp_nopass_sdsc = get_type_descr_arg(gbl.currsub, tbp_nopass_arg);
1883 lower_expression(A_LOPG(ast));
1884 tbp_nopass_arg = lower_base(A_LOPG(ast));
1885 } else {
1886 tbp_inv = find_dummy_position(symfunc, PASSG(tbp_mem));
1887 if (tbp_inv == 0)
1888 tbp_inv = max_binding_invobj(symfunc, INVOBJG(tbp_bind));
1889 }
1890 } else if (!is_procedure_ptr(symfunc) && !procDummyNeedsDesc) {
1891 is_procsym = 1;
1892 UCALL = "UCALL";
1893 PUFUNC = "PUFUNC";
1894 UFUNC = "UFUNC";
1895 } else if (procDummyNeedsDesc || is_procedure_ptr(symfunc)) {
1896 is_procsym = STYPEG(symfunc) == ST_PROC;
1897 UCALL = "UPCALLA";
1898 PUFUNC = "PUFUNC";
1899 UFUNC = "PUFUNCA";
1900 } else {
1901 is_procsym = 0;
1902 UCALL = "UCALLA";
1903 PUFUNC = "PUFUNCA";
1904 UFUNC = "UFUNCA";
1905 }
1906 count = A_ARGCNTG(ast);
1907 NEED(count, lower_argument, int, lower_argument_size, count + 10);
1908 args = A_ARGSG(ast);
1909 save_disable_ptr_chk = lower_disable_ptr_chk;
1910 if (is_procsym) {
1911 if (function_null_allowed(symfunc)) {
1912 lower_disable_ptr_chk = 1;
1913 }
1914
1915 callee = (procDummyNeedsDesc || is_procedure_ptr(symfunc))
1916 ? lower_base(A_LOPG(ast))
1917 : symfunc;
1918 paramcount = PARAMCTG(symfunc);
1919 params = DPDSCG(symfunc);
1920 /* get result datatype from function name */
1921 if (is_tbp != 1)
1922 dtype = A_NDTYPEG(A_LOPG(ast));
1923 else
1924 dtype = DTYPEG(callee);
1925 } else {
1926 dtype = DTYPEG(symfunc);
1927 #if DEBUG
1928 assert(DTY(dtype) == TY_PTR, "lower_ptrfunction, expected TY_PTR dtype",
1929 symfunc, 4);
1930 #endif
1931 dtproc = DTY(dtype + 1);
1932 #if DEBUG
1933 assert(DTY(dtproc) == TY_PROC, "lower_ptrfunction, expected TY_PROC dtype",
1934 symfunc, 4);
1935 #endif
1936 if (DTY(dtproc + 2) > NOSYM) {
1937 /* The procedure pointer has an interface. Get the function result
1938 * type from that interface, since the result type in the procedure
1939 * pointer's DTYPE record can be wrong and I don't know how to fix them.
1940 */
1941 dtype = DTYPEG(DTY(dtproc + 2));
1942 } else {
1943 dtype = DTY(dtproc + 1); /* result type */
1944 }
1945 lower_expression(A_LOPG(ast));
1946 callee = lower_base(A_LOPG(ast));
1947 iface = DTY(dtproc + 2);
1948 paramcount = DTY(dtproc + 3);
1949 params = DTY(dtproc + 4);
1950 }
1951 A_NDTYPEP(ast, dtype);
1952 functmp = 0;
1953 functmpinc = 0;
1954 funcusetmp = 0;
1955 funcusecall = 0;
1956 switch (DTYG(dtype)) {
1957 case TY_CMPLX:
1958 case TY_DCMPLX:
1959 functmpinc = 1; /* count the function temp as an extra argument */
1960 ++functmpcount;
1961 functmp = lower_scalar_temp(dtype);
1962 break;
1963 case TY_CHAR:
1964 case TY_NCHAR:
1965 ++functmpcount;
1966 functmp = lower_scalar_temp(dtype);
1967 funcusetmp = 1;
1968 break;
1969 case TY_DERIVED:
1970 case TY_STRUCT:
1971 if (CFUNCG(symfunc)) {
1972 retdesc = check_return(DTYPEG(FVALG(symfunc)));
1973 if (retdesc != CLASS_MEM && retdesc != CLASS_PTR) {
1974 bindC_structret = 1;
1975 } else {
1976 funcusecall = 1;
1977 }
1978 } else {
1979 funcusecall = 1;
1980 }
1981 if (CFUNCG(symfunc) || (iface && CFUNCG(iface))) {
1982 CSTRUCTRETP(symfunc, 1);
1983 }
1984 functmpinc = 1; /* count the function temp as an extra argument */
1985 ++functmpcount;
1986 functmp = lower_scalar_temp(dtype);
1987 ARGP(functmp, 1);
1988 funcusetmp = 1;
1989 break;
1990 default:
1991 break;
1992 }
1993 realcount = 0;
1994 for (i = 0; i < count; ++i) {
1995 int a;
1996 a = ARGT_ARG(args, i);
1997 if (a > 0) {
1998 if (A_TYPEG(a) != A_LABEL)
1999 lower_expression(a);
2000 switch (A_TYPEG(a)) {
2001 case A_ID:
2002 case A_MEM:
2003 case A_SUBSCR:
2004 case A_CNST:
2005 break;
2006 default:
2007 lower_ilm(a);
2008 }
2009 }
2010 }
2011 paramc = 0;
2012 sptr = 0;
2013 for (i = 0; i < count; ++i) {
2014 int a, param, byval;
2015 prevsptr = sptr;
2016 sptr = 0;
2017 a = ARGT_ARG(args, i);
2018 lower_argument[i] = 0;
2019 param = 0;
2020 if (paramc < paramcount) {
2021 param = aux.dpdsc_base[params + paramc];
2022 ++paramc;
2023 if (symfunc == gbl.currsub) {
2024 /* argument list was rewritten; use original argument */
2025 int nparam = NEWARGG(param);
2026 if (nparam)
2027 param = nparam;
2028 }
2029 }
2030 if (a == 0)
2031 continue;
2032 byval = 0;
2033 ++realcount;
2034 if (byval) {
2035 switch (A_TYPEG(a)) {
2036 int dt;
2037
2038 case A_ID:
2039 /* for nonscalar identifiers, just pass by reference */
2040 sptr = A_SPTRG(a);
2041
2042 switch (STYPEG(sptr)) {
2043 case ST_VAR:
2044 case ST_IDENT:
2045 if (param && POINTERG(param) && POINTERG(sptr))
2046 goto by_reference;
2047 break;
2048 default:
2049 goto by_reference;
2050 }
2051 goto by_value;
2052 case A_UNOP:
2053 if (A_OPTYPEG(a) == OP_BYVAL)
2054 goto by_reference;
2055 goto by_value;
2056 case A_MEM:
2057 /* if the formal is a pointer, pass the pointer address,
2058 * otherwise pass the data base address */
2059 sptr = A_SPTRG(A_MEMG(a));
2060 if (param && POINTERG(param) && POINTERG(sptr))
2061 goto by_reference;
2062 case A_INTR:
2063 if (is_iso_cloc(a)) {
2064 /* byval C_LOC(x) == regular pass by reference (X),
2065 no type checking
2066 */
2067 a = ARGT_ARG(A_ARGSG(a), 0);
2068 goto by_reference;
2069 }
2070 /* default fall through */
2071 default:
2072 /* expressions & scalar variables -- always emit BYVAL.
2073 * expand will take do the right thing for nonscalar
2074 * expressions.
2075 */
2076 by_value:
2077 dt = A_DTYPEG(a);
2078 ilm = lower_ilm(a);
2079 if (DTY(dt) == TY_CHAR || DTY(dt) == TY_NCHAR) {
2080 if (DTY(dt) == TY_CHAR)
2081 ilm = plower("oi", "ICHAR", ilm);
2082 else
2083 ilm = plower("oi", "INCHAR", ilm);
2084 if (DTY(stb.user.dt_int) == TY_INT8)
2085 ilm = plower("oi", "ITOI8", ilm);
2086 dt = stb.user.dt_int;
2087 }
2088 lower_argument[i] = plower("oid", "BYVAL", ilm, dt);
2089 break;
2090 }
2091 continue;
2092 }
2093 by_reference:
2094 unlpoly = 0;
2095 if (param && is_unl_poly(param)) {
2096 unlpoly = 1;
2097 }
2098 switch (A_TYPEG(a)) {
2099 case A_ID:
2100 /* if the formal is a pointer, pass the pointer address,
2101 * otherwise pass the data base address */
2102 sptr = A_SPTRG(a);
2103 if (param && ((POINTERG(param) && POINTERG(sptr)) ||
2104 (ALLOCATTRG(param) && ALLOCATTRG(sptr)))) {
2105 lower_disable_ptr_chk = 1;
2106 if (DTY(DTYPEG(sptr)) == TY_ARRAY && !XBIT(57, 0x80000)) {
2107 lower_argument[i] = lower_base(a);
2108 } else {
2109 ilm = lower_target(a);
2110 ilm2 = plower("oS", "BASE", sptr);
2111 lower_argument[i] = plower("oii", "PARG", ilm, ilm2);
2112 }
2113 lower_disable_ptr_chk = 0;
2114 } else {
2115 lower_argument[i] = lower_base(a);
2116 }
2117 switch (STYPEG(sptr)) {
2118 case ST_PROC:
2119 case ST_ENTRY:
2120 case ST_MODPROC:
2121 break;
2122 default:
2123 if (DTYPEG(sptr)) {
2124 lower_argument[i] =
2125 plower_arg("oid", lower_argument[i], DTYPEG(sptr), unlpoly);
2126 }
2127 }
2128 break;
2129 case A_MEM:
2130 /* if the formal is a pointer, pass the pointer address,
2131 * otherwise pass the data base address */
2132 sptr = A_SPTRG(A_MEMG(a));
2133 if (param && ((POINTERG(param) && POINTERG(sptr)) ||
2134 (ALLOCATTRG(param) && ALLOCATTRG(sptr)))) {
2135 lower_disable_ptr_chk = 1;
2136 if (DTY(DTYPEG(sptr)) == TY_ARRAY && !XBIT(57, 0x80000)) {
2137 lower_argument[i] = lower_base(a);
2138 } else {
2139 ilm = lower_target(a);
2140 ilm2 = plower("oS", "BASE", sptr);
2141 lower_argument[i] = plower("oii", "PARG", ilm, ilm2);
2142 }
2143 lower_disable_ptr_chk = 0;
2144 } else {
2145 lower_argument[i] = lower_base(a);
2146 }
2147 lower_argument[i] =
2148 plower_arg("oid", lower_argument[i], DTYPEG(sptr), unlpoly);
2149 break;
2150 case A_SUBSCR:
2151 case A_CNST:
2152 lower_argument[i] = lower_base(a);
2153 if (A_DTYPEG(a)) {
2154 lower_argument[i] =
2155 plower_arg("oid", lower_argument[i], A_DTYPEG(a), unlpoly);
2156 }
2157 break;
2158 default:
2159 lower_argument[i] = lower_parenthesize_expression(a);
2160 if (A_DTYPEG(a)) {
2161 lower_argument[i] =
2162 plower_arg("oid", lower_argument[i], A_DTYPEG(a), unlpoly);
2163 }
2164 break;
2165 }
2166 }
2167 if (functmp) {
2168 functmpilm = plower("oS", "BASE", functmp);
2169 functmpilm = plower_arg("oid", functmpilm, DTYPEG(functmp), 0);
2170 }
2171 if (funcusecall) {
2172 ilm = plower("om", UCALL);
2173 } else {
2174 if (bindC_structret) {
2175 int retdesc = check_return(DTYPEG(FVALG(symfunc)));
2176 if (retdesc != CLASS_MEM && retdesc != CLASS_PTR) {
2177 ilm = plower("om", "SFUNC");
2178 }
2179 } else {
2180 if (procDummyNeedsDesc || is_procedure_ptr(symfunc)) {
2181 char *l;
2182 char op[100] = {'P', '\0'};
2183 int dtype2 = DTY(dtype + 1);
2184 if (DTY(dtype2) == TY_PROC) {
2185 if (DTY(dtype2 + 2)) {
2186 dtype2 = DTYPEG(DTY(dtype2 + 2));
2187 if (DTY(dtype2) == TY_ARRAY)
2188 dtype2 = DTY(dtype2 + 1);
2189 } else {
2190 dtype2 = DTY(dtype2 + 1);
2191 }
2192 l = ltyped(UFUNC + 1, dtype2);
2193 } else {
2194 l = ltyped(UFUNC + 1, dtype);
2195 }
2196 strcat(op, l);
2197 ilm = plower("om", op);
2198 } else {
2199 ilm = plower("om", ltyped(UFUNC, dtype));
2200 }
2201 }
2202 }
2203
2204 if (is_tbp) {
2205 int is_cfunc = (CFUNCG(symfunc) || (iface && CFUNCG(iface)));
2206 VTABLEP(tbp_mem, symfunc);
2207 plower("nnsm", realcount + functmpinc, is_cfunc, tbp_mem);
2208 } else if (procDummyNeedsDesc || is_procedure_ptr(symfunc)) {
2209 int sdsc = A_INVOKING_DESCG(ast) ? sym_of_ast(A_INVOKING_DESCG(ast))
2210 : SDSCG(memsym_of_ast(ast));
2211 int is_cfunc = (CFUNCG(symfunc) || (iface && CFUNCG(iface)));
2212 plower("nnsim", realcount + functmpinc, is_cfunc, sdsc, callee);
2213 } else if (is_procsym) {
2214 plower("nsm", realcount + functmpinc, callee);
2215 } else {
2216 int is_cfunc = (CFUNCG(symfunc) || (iface && CFUNCG(iface)));
2217 plower("nnim", realcount + functmpinc, is_cfunc, callee);
2218 }
2219
2220 if (is_tbp) {
2221 if (tbp_nopass_arg) {
2222 plower("im", tbp_nopass_arg);
2223 plower("sm", tbp_nopass_sdsc);
2224 } else {
2225 int a, sdsc, a_sptr, a_dtype;
2226 i = tbp_inv - 1;
2227 plower("im", lower_argument[i]);
2228 a = ARGT_ARG(args, i);
2229 a_sptr = memsym_of_ast(a);
2230 a_dtype = DTYPEG(a_sptr);
2231 if (DTY(a_dtype) == TY_ARRAY)
2232 a_dtype = DTY(a_dtype + 1);
2233 sdsc = A_INVOKING_DESCG(ast) ? sym_of_ast(A_INVOKING_DESCG(ast)) : 0;
2234 if (!sdsc) {
2235 if (!CLASSG(a_sptr) && DTY(a_dtype) == TY_DERIVED) {
2236 sdsc = get_static_type_descriptor(DTY(a_dtype + 3));
2237 } else {
2238 sdsc = get_type_descr_arg(gbl.currsub, a_sptr);
2239 }
2240 }
2241 plower("sm", sdsc);
2242 }
2243 }
2244
2245 if (functmp) {
2246 plower("am", functmpilm, dtype);
2247 }
2248
2249 for (i = 0; i < count; ++i) {
2250 int a;
2251 a = ARGT_ARG(args, i);
2252 if (a > 0) {
2253 plower("am", lower_argument[i], A_NDTYPEG(a));
2254 }
2255 }
2256 plower("C", symfunc);
2257 if (funcusetmp && !bindC_structret) {
2258 /* don't use the function return value, use the temp */
2259 ilm = plower("oS", "BASE", functmp);
2260 }
2261 A_ILMP(ast, ilm);
2262 lower_disable_ptr_chk = save_disable_ptr_chk;
2263 return ilm;
2264 } /* lower_function */
2265
2266 /* options argument to intrin_name: */
2267 /* I_K_r_D_C_CD means int, int8, real, real8, cmplx, cmpl16 char */
2268 /* prefix: I K none D C CD */
2269 #define in_I_K_r_D_C_CD 0x0331333
2270 /* prefix: I K R D C CD */
2271 #define in_I_K_R_D_C_CD 0x0333333
2272 /* prefix: I K R D C CD */
2273 #define in_Il_K_R_D_C_CD 0x0b33333
2274 /* prefix: I K R D */
2275 /* prefix: log */
2276 #define in_I_K_R_D 0x0333300
2277 /* prefix: I K none D */
2278 #define in_Il_K_R_D 0x0b33300
2279 /* prefix: I K none D */
2280 /* prefix: log */
2281 #define in_I_K_r_D 0x0331300
2282 /* prefix: I K R D */
2283 #define in_i_K_A_D 0x0135300
2284 /* prefix: none K */
2285 #define in_i_K 0x0130000
2286 /* prefix: log K */
2287 #define in_il_K 0x0930000
2288 /* prefix: I K */
2289 #define in_I_K 0x0330000
2290 /* prefix: none 64 */
2291 #define in_i_64 0x0150000
2292 /* prefix: none none */
2293 #define in_i_k 0x0110000
2294 /* prefix: none */
2295 #define in_i 0x0100000
2296 /* prefix: J K */
2297 #define in_J_K 0x0530000
2298 /* prefix: none A D */
2299 #define in_R_D 0x0003300
2300 /* prefix: R D */
2301 #define in_r_D 0x0001300
2302 /* prefix: R D C CD */
2303 #define in_R_D_C_CD 0x0001333
2304 /* prefix: none D C CD */
2305 #define in_r_D_C_CD 0x0001333
2306 /* prefix: none D */
2307 #define in_c_cD 0x0000015
2308 /* prefix: none A D */
2309 #define in_A_D 0x0005300
2310 /* prefix: D */
2311 #define in_d 0x0000100
2312 /* prefix: */
2313 #define in_c 0x1000000
2314 #define in_nc 0x2000000
2315 #define in_c_nc 0x3000000
2316
2317 #define IARGS 100
2318 static int intr_argbf[IARGS];
2319 static int *intrinsic_args = intr_argbf;
2320 static int intr_argsz = IARGS;
2321
2322 static int *
need_intr_argbf(int nargs)2323 need_intr_argbf(int nargs)
2324 {
2325 if (nargs > intr_argsz) {
2326 if (intr_argsz == IARGS) {
2327 intr_argsz = nargs + IARGS;
2328 NEW(intrinsic_args, int, nargs);
2329 } else {
2330 NEED(nargs, intrinsic_args, int, intr_argsz, nargs + IARGS);
2331 }
2332 }
2333 return intrinsic_args;
2334 }
2335
2336 static int
intrin_name(char * name,int ast,int options)2337 intrin_name(char *name, int ast, int options)
2338 {
2339 #define allowI 0x0100000
2340 #define prefixI 0x0200000
2341 #define prefixJ 0x0400000
2342 #define allowL 0x0800000
2343 #define allowK 0x0010000
2344 #define prefixK 0x0020000
2345 #define suffix64 0x0040000
2346 #define allowR 0x0001000
2347 #define prefixR 0x0002000
2348 #define prefixA 0x0004000
2349 #define allowD 0x0000100
2350 #define prefixD 0x0000200
2351 #define allowC 0x0000010
2352 #define prefixC 0x0000020
2353 #define allowCD 0x0000001
2354 #define prefixCD 0x0000002
2355 #define prefixcD 0x0000004
2356 #define allowchar 0x1000000
2357 #define allownchar 0x2000000
2358
2359 int dtype, ok, ilm;
2360 char *prefix;
2361 char *suffix;
2362 char intrname[50];
2363 dtype = A_NDTYPEG(ast);
2364 prefix = "";
2365 suffix = "";
2366 switch (DTYG(dtype)) {
2367 case TY_BINT:
2368 case TY_SINT:
2369 case TY_INT:
2370 case TY_WORD:
2371 ok = options & allowI;
2372 if (options & prefixI) {
2373 prefix = "I";
2374 } else if (options & prefixJ) {
2375 prefix = "J";
2376 }
2377 break;
2378 case TY_BLOG:
2379 case TY_SLOG:
2380 case TY_LOG:
2381 ok = options & allowL;
2382 if (options & prefixI) {
2383 prefix = "I";
2384 } else if (options & prefixJ) {
2385 prefix = "J";
2386 }
2387 break;
2388 case TY_DWORD:
2389 case TY_INT8:
2390 case TY_LOG8:
2391 ok = options & allowK;
2392 if (options & prefixK) {
2393 prefix = "K";
2394 } else if (options & suffix64) {
2395 suffix = "64";
2396 }
2397 break;
2398 case TY_REAL:
2399 ok = options & allowR;
2400 if (options & prefixR) {
2401 prefix = "R";
2402 } else if (options & prefixA) {
2403 prefix = "A";
2404 }
2405 break;
2406 case TY_DBLE:
2407 ok = options & allowD;
2408 if (options & prefixD) {
2409 prefix = "D";
2410 }
2411 break;
2412 case TY_CMPLX:
2413 ok = options & allowC;
2414 if (options & prefixC) {
2415 prefix = "C";
2416 }
2417 break;
2418 case TY_DCMPLX:
2419 ok = options & allowCD;
2420 if (options & prefixCD) {
2421 prefix = "CD";
2422 } else if (options & prefixcD) {
2423 prefix = "D";
2424 }
2425 break;
2426 case TY_CHAR:
2427 ok = options & allowchar;
2428 break;
2429 case TY_NCHAR:
2430 ok = options & allownchar;
2431 break;
2432 default:
2433 ast_error("unexpected type for intrinsic function", ast);
2434 ok = 1;
2435 break;
2436 }
2437 if (!ok) {
2438 ast_error("unexpected result type for intrinsic function", ast);
2439 }
2440 strcpy(intrname, prefix);
2441 strcat(intrname, name);
2442 strcat(intrname, suffix);
2443 ilm = plower("om", intrname);
2444 return ilm;
2445 } /* intrin_name */
2446
2447 static int
intrin_name_bsik(char * name,int ast)2448 intrin_name_bsik(char *name, int ast)
2449 {
2450 int dtype, ok, ilm;
2451 char *prefix;
2452 char intrname[50];
2453 dtype = A_NDTYPEG(ast);
2454 prefix = "";
2455 switch (DTYG(dtype)) {
2456 case TY_BINT:
2457 case TY_BLOG:
2458 prefix = "B";
2459 break;
2460 case TY_SINT:
2461 case TY_SLOG:
2462 prefix = "S";
2463 break;
2464 case TY_INT:
2465 case TY_WORD:
2466 case TY_LOG:
2467 prefix = "I";
2468 break;
2469 case TY_DWORD:
2470 case TY_INT8:
2471 case TY_LOG8:
2472 prefix = "K";
2473 break;
2474 default:
2475 ast_error("unexpected type for intrinsic function", ast);
2476 prefix = "I";
2477 break;
2478 }
2479 strcpy(intrname, prefix);
2480 strcat(intrname, name);
2481 ilm = plower("om", intrname);
2482 return ilm;
2483 }
2484
2485 /* return the 'REAL' type nearest in length to dtype */
2486 static int
nearest_real_type(int dtype)2487 nearest_real_type(int dtype)
2488 {
2489 switch (DTY(dtype)) {
2490 case TY_DWORD:
2491 case TY_QUAD:
2492 case TY_INT8:
2493 case TY_DBLE:
2494 case TY_DCMPLX:
2495 case TY_QCMPLX:
2496 case TY_LOG8:
2497 return DT_DBLE;
2498 default:
2499 return DT_REAL;
2500 }
2501 } /* nearest_real_type */
2502
2503 /*
2504 * return TRUE if this is a function which can have a NULL pointer argument
2505 * if so, we don't insert a null pointer check, even if -Mchkptr is set
2506 */
2507 static int
intrinsic_null_allowed(int intr)2508 intrinsic_null_allowed(int intr)
2509 {
2510 switch (intr) {
2511 case I_ALLOCATED:
2512 case I_ASSOCIATED:
2513 case I_PRESENT:
2514 case I_LEN:
2515 case I_IS_CONTIGUOUS:
2516 case I_C_ASSOCIATED:
2517 return TRUE;
2518 default:
2519 return FALSE;
2520 }
2521 } /* intrinsic_null_allowed */
2522
2523 static int
intrinsic_arg_dtype(int intr,int ast,int args,int nargs)2524 intrinsic_arg_dtype(int intr, int ast, int args, int nargs)
2525 {
2526 int dt, arg, i;
2527 switch (intr) {
2528 /* the first set of intrinsics do no type conversion;
2529 * they appear in the order they are listed in symini_ftn.n for the
2530 * f90 back end. */
2531 case I_SQRT:
2532 case I_DSQRT:
2533 case I_CSQRT:
2534 case I_CDSQRT:
2535
2536 case I_LOG:
2537 case I_ALOG:
2538 case I_DLOG:
2539 case I_CLOG:
2540 case I_CDLOG:
2541
2542 case I_LOG10:
2543 case I_ALOG10:
2544 case I_DLOG10:
2545
2546 case I_EXP:
2547 case I_DEXP:
2548 case I_CEXP:
2549 case I_CDEXP:
2550
2551 case I_SIN:
2552 case I_DSIN:
2553 case I_CSIN:
2554 case I_CDSIN:
2555
2556 case I_SIND:
2557 case I_DSIND:
2558
2559 case I_COS:
2560 case I_DCOS:
2561 case I_CCOS:
2562 case I_CDCOS:
2563
2564 case I_COSD:
2565 case I_DCOSD:
2566
2567 case I_TAN:
2568 case I_DTAN:
2569
2570 case I_TAND:
2571 case I_DTAND:
2572
2573 case I_ASIN:
2574 case I_DASIN:
2575
2576 case I_ASIND:
2577 case I_DASIND:
2578
2579 case I_ACOS:
2580 case I_DACOS:
2581
2582 case I_ACOSD:
2583 case I_DACOSD:
2584
2585 case I_ATAN:
2586 case I_DATAN:
2587
2588 case I_ATAND:
2589 case I_DATAND:
2590
2591 case I_ATAN2:
2592 case I_DATAN2:
2593
2594 case I_ATAN2D:
2595 case I_DATAN2D:
2596
2597 case I_SINH:
2598 case I_DSINH:
2599
2600 case I_COSH:
2601 case I_DCOSH:
2602
2603 case I_TANH:
2604 case I_DTANH:
2605
2606 case I_ERF:
2607 case I_ERFC:
2608 case I_ERFC_SCALED:
2609 case I_GAMMA:
2610 case I_LOG_GAMMA:
2611 case I_HYPOT:
2612 case I_ACOSH:
2613 case I_ASINH:
2614 case I_ATANH:
2615 case I_BESSEL_J0:
2616 case I_BESSEL_J1:
2617 case I_BESSEL_Y0:
2618 case I_BESSEL_Y1:
2619
2620 case I_IABS:
2621 case I_IIABS:
2622 case I_JIABS:
2623 case I_KIABS:
2624
2625 case I_AINT:
2626 case I_DINT:
2627
2628 case I_ANINT:
2629 case I_DNINT:
2630
2631 case I_CEILING:
2632 case I_FLOOR:
2633
2634 case I_CONJG:
2635 case I_DCONJG:
2636
2637 case I_IIDIM:
2638 case I_JIDIM:
2639 case I_KIDIM:
2640 case I_IDIM:
2641 case I_DIM:
2642 case I_DDIM:
2643
2644 case I_IMOD:
2645 case I_JMOD:
2646 case I_KMOD:
2647 case I_MOD:
2648 case I_AMOD:
2649 case I_DMOD:
2650
2651 case I_IISIGN:
2652 case I_JISIGN:
2653 case I_KISIGN:
2654 case I_ISIGN:
2655 case I_SIGN:
2656 case I_DSIGN:
2657
2658 case I_IIAND:
2659 case I_JIAND:
2660 case I_IIOR:
2661 case I_JIOR:
2662 case I_IIEOR:
2663 case I_JIEOR:
2664 case I_INOT:
2665 case I_JNOT:
2666 case I_IISHFT:
2667 case I_JISHFT:
2668 case I_KISHFT:
2669
2670 case I_IBITS:
2671 case I_IIBITS:
2672 case I_JIBITS:
2673 case I_KIBITS:
2674 case I_IBSET:
2675 case I_IIBSET:
2676 case I_JIBSET:
2677 case I_KIBSET:
2678 case I_BTEST:
2679 case I_BITEST:
2680 case I_BJTEST:
2681 case I_BKTEST:
2682 case I_IBCLR:
2683 case I_IIBCLR:
2684 case I_JIBCLR:
2685 case I_KIBCLR:
2686 case I_ISHFTC:
2687 case I_IISHFTC:
2688 case I_JISHFTC:
2689 case I_KISHFTC:
2690 case I_LSHIFT:
2691 case I_RSHIFT:
2692
2693 case I_IAND:
2694 case I_IOR:
2695 case I_IEOR:
2696 case I_XOR:
2697 case I_NOT:
2698 case I_ISHFT:
2699 case I_MAX:
2700 case I_MIN:
2701
2702 case I_AND:
2703 case I_OR:
2704 case I_EQV:
2705 case I_NEQV:
2706 case I_COMPL:
2707
2708 case I_LEADZ:
2709 case I_POPCNT:
2710 case I_POPPAR:
2711 return A_NDTYPEG(ast);
2712
2713 case I_ABS:
2714 case I_DABS:
2715 case I_CABS:
2716 case I_CDABS:
2717 case I_BESSEL_JN:
2718 case I_BESSEL_YN:
2719 /* don't coerce */
2720 return -1;
2721
2722 /* MAX, MIN */
2723 case I_MAX1:
2724 case I_MIN1:
2725 case I_IMAX1:
2726 case I_KMAX1:
2727 case I_IMIN1:
2728 case I_KMIN1:
2729 case I_JMAX1:
2730 case I_JMIN1:
2731 case I_AMAX1: /* r*4,r*4 -> r*4 */
2732 case I_AMIN1:
2733 return DT_REAL4;
2734 case I_DMAX1:
2735 case I_DMIN1:
2736 return DT_REAL8;
2737
2738 case I_MAX0: /* i*4,i*4 -> i*4 */
2739 case I_MIN0:
2740 case I_JMAX0: /* i*4,i*4 -> i*4 */
2741 case I_JMIN0:
2742 case I_AMAX0:
2743 case I_AMIN0:
2744 case I_AJMAX0:
2745 case I_AJMIN0:
2746 return DT_INT4;
2747 case I_IMAX0: /* i*2,i*2 -> i*2 */
2748 case I_IMIN0:
2749 case I_AIMAX0:
2750 case I_AIMIN0:
2751 return DT_SINT;
2752 case I_KMAX0:
2753 case I_KMIN0:
2754 return DT_INT8;
2755
2756 /* type conversion to integer */
2757 case I_IFIX:
2758 case I_IIFIX:
2759 case I_JIFIX:
2760 case I_IDINT:
2761 case I_IIDINT:
2762 case I_JIDINT:
2763 case I_IINT:
2764 case I_INT:
2765 case I_JINT:
2766 case I_INT1:
2767 case I_INT2:
2768 case I_INT4:
2769 case I_INT8:
2770 return -1;
2771
2772 /* conversion real to nearest integer */
2773 case I_ININT:
2774 case I_JNINT:
2775 case I_KNINT:
2776 return DT_REAL4;
2777
2778 /* conversion double to nearest integer */
2779 case I_IDNINT:
2780 case I_IIDNNT:
2781 case I_JIDNNT:
2782 case I_KIDNNT:
2783 return DT_REAL8;
2784
2785 /* generic, conversion to nearest integer */
2786 case I_NINT:
2787 return nearest_real_type(A_NDTYPEG(ARGT_ARG(args, 0)));
2788
2789 /* type conversion to real */
2790 case I_FLOATI:
2791 case I_FLOATJ:
2792 case I_FLOAT:
2793 case I_SNGL:
2794 case I_REAL:
2795 return -1;
2796
2797 /* type conversion to double */
2798 case I_DFLOTI:
2799 case I_DFLOAT:
2800 case I_DFLOTJ:
2801 case I_DREAL:
2802 case I_DBLE:
2803 return -1;
2804
2805 case I_DIMAG:
2806 case I_AIMAG:
2807 case I_IMAG:
2808 /* return imaginary part */
2809 if (A_NDTYPEG(ast) == DT_REAL8)
2810 return DT_CMPLX16;
2811 return DT_CMPLX8;
2812
2813 /* double precision product of reals */
2814 case I_DPROD:
2815 return DT_REAL4;
2816
2817 case I_CMPLX:
2818 case I_DCMPLX:
2819 return -1;
2820
2821 /* ichar family */
2822 case I_ICHAR:
2823 case I_IACHAR:
2824 /* just get base address of argument */
2825 intrinsic_args[0] = lower_base(ARGT_ARG(args, 0));
2826 return -1;
2827
2828 case I_LEN:
2829 case I_KLEN:
2830 case I_LEN_TRIM:
2831 intrinsic_args[0] = lower_base(ARGT_ARG(args, 0));
2832 return -1;
2833
2834 case I_INDEX:
2835 case I_KINDEX:
2836 return -1;
2837
2838 case I_LGE:
2839 case I_LGT:
2840 case I_LLE:
2841 case I_LLT:
2842 return -1;
2843
2844 case I_LOC:
2845 case I_C_FUNLOC:
2846 case I_C_LOC:
2847 intrinsic_args[0] = lower_base(ARGT_ARG(args, 0));
2848 return -1;
2849
2850 /* shift family */
2851 case I_SHIFT:
2852 intrinsic_args[0] = lower_conv(ARGT_ARG(args, 0), A_NDTYPEG(ast));
2853 intrinsic_args[1] = lower_conv(ARGT_ARG(args, 1), DT_INT4);
2854 return -1;
2855
2856 /* type conversion to char */
2857 case I_CHAR:
2858 return DT_INT4;
2859 case I_ACHAR:
2860 return DT_INT4;
2861 case I_NCHAR:
2862 return DT_INT4;
2863 case I_NLEN:
2864 intrinsic_args[0] = lower_base(ARGT_ARG(args, 0));
2865 return -1;
2866 case I_NINDEX:
2867 return -1;
2868
2869 case I_ALLOCATED:
2870 case I_ASSOCIATED:
2871 case I_PRESENT:
2872 case I_MERGE:
2873 case I_ILEN:
2874 case I_IS_CONTIGUOUS:
2875 case I_C_ASSOCIATED:
2876 return -1;
2877
2878 case I_SIZE:
2879 case I_LBOUND:
2880 case I_UBOUND:
2881 case I_MODULO:
2882 case I_EXPONENT:
2883 case I_FRACTION:
2884 case I_RRSPACING:
2885 case I_SPACING:
2886 case I_NEAREST:
2887 case I_SCALE:
2888 case I_SET_EXPONENT:
2889 case I_VERIFY:
2890 case I_RAN:
2891 return -1;
2892
2893 case I_ZEXT:
2894 case I_IZEXT:
2895 case I_JZEXT:
2896 return DT_INT4;
2897
2898 case NEW_INTRIN:
2899 return A_DTYPEG(ast);
2900 /*------------------*/
2901
2902 case I_DATE:
2903 case I_EXIT:
2904 case I_IDATE:
2905 case I_TIME:
2906 case I_MVBITS:
2907
2908 case I_SECNDS:
2909 case I_DATE_AND_TIME:
2910 case I_RANDOM_NUMBER:
2911 case I_RANDOM_SEED:
2912 case I_SYSTEM_CLOCK:
2913 case I_KIND:
2914 case I_SELECTED_INT_KIND:
2915 case I_SELECTED_REAL_KIND:
2916 case I_EPSILON:
2917 case I_HUGE:
2918 case I_TINY:
2919 case I_NULLIFY:
2920 case I_RANF:
2921 case I_RANGET:
2922 case I_RANSET:
2923 case I_INT_MULT_UPPER:
2924
2925 case I_ALL:
2926 case I_ANY:
2927 case I_COUNT:
2928 case I_DOT_PRODUCT:
2929 case I_NORM2:
2930 case I_MATMUL:
2931 case I_MATMUL_TRANSPOSE:
2932 case I_MAXLOC:
2933 case I_MAXVAL:
2934 case I_MINLOC:
2935 case I_MINVAL:
2936 case I_FINDLOC:
2937 case I_PACK:
2938 case I_PRODUCT:
2939 case I_SUM:
2940 case I_SPREAD:
2941 case I_TRANSPOSE:
2942 case I_UNPACK:
2943 case I_NUMBER_OF_PROCESSORS:
2944 case I_CSHIFT:
2945 case I_EOSHIFT:
2946 case I_RESHAPE:
2947 case I_SHAPE:
2948 case I_ADJUSTL:
2949 case I_ADJUSTR:
2950 case I_BIT_SIZE:
2951 case I_DIGITS:
2952 case I_LOGICAL:
2953 case I_MAXEXPONENT:
2954 case I_MINEXPONENT:
2955 case I_PRECISION:
2956 case I_RADIX:
2957 case I_RANGE:
2958 case I_REPEAT:
2959 case I_TRANSFER:
2960 case I_TRIM:
2961 case I_SCAN:
2962 case I_DOTPRODUCT:
2963 case I_PROCESSORS_SHAPE:
2964 case I_LASTVAL:
2965 case I_REDUCE_SUM:
2966 case I_REDUCE_PRODUCT:
2967 case I_REDUCE_ANY:
2968 case I_REDUCE_ALL:
2969 case I_REDUCE_PARITY:
2970 case I_REDUCE_IANY:
2971 case I_REDUCE_IALL:
2972 case I_REDUCE_IPARITY:
2973 case I_REDUCE_MINVAL:
2974 case I_REDUCE_MAXVAL:
2975 case I_PTR2_ASSIGN:
2976 case I_PTR_COPYIN:
2977 case I_PTR_COPYOUT:
2978 case I_UNIT:
2979 case I_LENGTH:
2980 case I_COT:
2981 case I_DCOT:
2982 case I_SHIFTL:
2983 case I_SHIFTR:
2984 case I_DSHIFTL:
2985 case I_DSHIFTR:
2986 default:
2987 return -1;
2988 }
2989 } /* intrinsic_arg_dtype */
2990
2991 static int
f90_function(char * name,int dtype,int args,int nargs)2992 f90_function(char *name, int dtype, int args, int nargs)
2993 {
2994 int i, symfunc, ilm;
2995 need_intr_argbf(nargs);
2996 symfunc = lower_makefunc(name, dtype, FALSE);
2997 for (i = 0; i < nargs; ++i) {
2998 intrinsic_args[i] = lower_base(ARGT_ARG(args, i));
2999 }
3000 ilm = plower("onsm", ltyped("FUNC", dtype), nargs, symfunc);
3001 return ilm;
3002 } /* f90_function */
3003
3004 static int
f90_value_function(char * name,int dtype,int args,int nargs)3005 f90_value_function(char *name, int dtype, int args, int nargs)
3006 {
3007 int i, symfunc, ilm;
3008 need_intr_argbf(nargs);
3009 symfunc = lower_makefunc(name, dtype, FALSE);
3010 for (i = 0; i < nargs; ++i) {
3011 ilm = lower_ilm(ARGT_ARG(args, i));
3012 ilm = plower("oi", "DPVAL", ilm);
3013 intrinsic_args[i] = ilm;
3014 }
3015 ilm = plower("onsm", ltyped("FUNC", dtype), nargs, symfunc);
3016 return ilm;
3017 } /* f90_value_function */
3018
3019 /* 2nd argument must be int */
3020 static int
f90_value_function_I2(char * name,int dtype,int args,int nargs)3021 f90_value_function_I2(char *name, int dtype, int args, int nargs)
3022 {
3023 int i, symfunc, ilm;
3024 need_intr_argbf(nargs);
3025 symfunc = lower_makefunc(name, dtype, FALSE);
3026 for (i = 0; i < nargs; ++i) {
3027 int ast = ARGT_ARG(args, i);
3028 ilm = lower_ilm(ast);
3029 if (i == 1) {
3030 ilm = lower_conv_ilm(ast, ilm, A_NDTYPEG(ast), DT_INT);
3031 }
3032 ilm = plower("oi", "DPVAL", ilm);
3033 intrinsic_args[i] = ilm;
3034 }
3035 ilm = plower("onsm", ltyped("FUNC", dtype), nargs, symfunc);
3036 return ilm;
3037 } /* f90_value_function_I2 */
3038
3039 static int
new_intrin_sym(int ast)3040 new_intrin_sym(int ast)
3041 {
3042 int ast_spec = 0;
3043 int sptr = A_SPTRG(ast);
3044
3045 switch (DTY(A_DTYPEG(ast))) {
3046 case TY_DCMPLX:
3047 ast_spec = GDCMPLXG(sptr);
3048 break;
3049 case TY_CMPLX:
3050 ast_spec = GCMPLXG(sptr);
3051 break;
3052 }
3053 return ast_spec;
3054 }
3055
3056 static int
lower_intrinsic(int ast)3057 lower_intrinsic(int ast)
3058 {
3059 int intr, ilm, ilm1, ilm2, args, nargs, i, arg0, argdtype, dty, dtype,
3060 symfunc, input_ast;
3061 int shape, cnt, num, arg, arg1, arg2, fromdtype;
3062 int sptr;
3063 int pairwise = 0, argsdone = 0, save_disable_ptr_chk;
3064 char *rtn_name;
3065 FtnRtlEnum rtlRtn;
3066 int retDtype;
3067 char *nm;
3068
3069 if (is_iso_cloc(ast)) {
3070 /*
3071 * semant may type cloc() as the derived type, c_ptr
3072 */
3073 A_NDTYPEP(ast, DT_PTR);
3074 }
3075 nargs = A_ARGCNTG(ast);
3076 args = A_ARGSG(ast);
3077 intr = A_OPTYPEG(ast);
3078
3079 if (intr != NEW_INTRIN) {
3080 symfunc = EXTSYMG(intast_sym[intr]);
3081 } else {
3082 symfunc = new_intrin_sym(A_LOPG(ast));
3083 }
3084 save_disable_ptr_chk = lower_disable_ptr_chk;
3085 if (intrinsic_null_allowed(intr)) {
3086 lower_disable_ptr_chk = 1;
3087 }
3088 need_intr_argbf(nargs);
3089 if (symfunc) {
3090 dtype = A_DTYPEG(ast);
3091 for (i = 0; i < nargs; ++i) {
3092 intrinsic_args[i] = lower_base(ARGT_ARG(args, i));
3093 }
3094 ilm = plower("onsm", ltyped("FUNC", dtype), nargs, symfunc);
3095 for (i = 0; i < nargs; ++i) {
3096 plower("im", intrinsic_args[i]);
3097 }
3098 plower("e");
3099 return ilm;
3100 }
3101 argdtype = intrinsic_arg_dtype(intr, ast, args, nargs);
3102 /* some intrinsics look only at one argument */
3103 switch (intr) {
3104 case I_IDNINT:
3105 case I_ININT:
3106 case I_JNINT:
3107 case I_KNINT:
3108 case I_NINT:
3109 case I_IIDNNT:
3110 case I_JIDNNT:
3111 case I_KIDNNT:
3112 case I_AINT:
3113 case I_DINT:
3114 case I_ANINT:
3115 case I_DNINT:
3116 case I_FLOOR:
3117 case I_CEILING:
3118 nargs = 1;
3119 }
3120 if (argdtype >= 0) {
3121 for (i = 0; i < nargs; ++i) {
3122 intrinsic_args[i] = lower_conv(ARGT_ARG(args, i), argdtype);
3123 }
3124 }
3125 switch (intr) {
3126 /* abs family */
3127 case I_IABS:
3128 case I_IIABS:
3129 case I_JIABS:
3130 case I_KIABS:
3131 ilm = intrin_name("ABS", ast, in_I_K_r_D_C_CD);
3132 break;
3133
3134 case I_ABS:
3135 case I_DABS:
3136 case I_CABS:
3137 case I_CDABS:
3138 /* use datatype of argument */
3139 arg1 = ARGT_ARG(args, 0);
3140 lower_expression(arg1);
3141 intrinsic_args[0] = lower_ilm(arg1);
3142 ilm = intrin_name("ABS", arg1, in_I_K_r_D_C_CD);
3143 break;
3144
3145 /* acos family */
3146 case I_ACOS:
3147 case I_DACOS:
3148 ilm = intrin_name("ACOS", ast, in_r_D);
3149 break;
3150 case I_ACOSD:
3151 case I_DACOSD:
3152 ilm = intrin_name("ACOSD", ast, in_r_D);
3153 break;
3154
3155 /* and family */
3156 case I_IIAND:
3157 case I_JIAND:
3158 case I_IAND:
3159 ilm = intrin_name("AND", ast, in_i_K);
3160 break;
3161
3162 case I_AND:
3163 ilm = intrin_name("AND", ast, in_i_K);
3164 break;
3165
3166 /* asin family */
3167 case I_ASIN:
3168 case I_DASIN:
3169 ilm = intrin_name("ASIN", ast, in_r_D);
3170 break;
3171 case I_ASIND:
3172 case I_DASIND:
3173 ilm = intrin_name("ASIND", ast, in_r_D);
3174 break;
3175
3176 /* atan family */
3177 case I_ATAN:
3178 case I_DATAN:
3179 ilm = intrin_name("ATAN", ast, in_r_D);
3180 break;
3181 case I_ATAND:
3182 case I_DATAND:
3183 ilm = intrin_name("ATAND", ast, in_r_D);
3184 break;
3185
3186 case I_ERF:
3187 ilm = intrin_name("ERF", ast, in_r_D);
3188 break;
3189 case I_ERFC:
3190 ilm = intrin_name("ERFC", ast, in_r_D);
3191 break;
3192 case I_ERFC_SCALED:
3193 ilm = intrin_name("ERFC_SCALED", ast, in_r_D);
3194 break;
3195 case I_GAMMA:
3196 ilm = intrin_name("GAMMA", ast, in_r_D);
3197 break;
3198 case I_LOG_GAMMA:
3199 ilm = intrin_name("LOG_GAMMA", ast, in_r_D);
3200 break;
3201 case I_HYPOT:
3202 ilm = intrin_name("HYPOT", ast, in_r_D);
3203 break;
3204 case I_ACOSH:
3205 ilm = intrin_name("ACOSH", ast, in_r_D);
3206 break;
3207 case I_ASINH:
3208 ilm = intrin_name("ASINH", ast, in_r_D);
3209 break;
3210 case I_ATANH:
3211 ilm = intrin_name("ATANH", ast, in_r_D);
3212 break;
3213 case I_BESSEL_J0:
3214 ilm = intrin_name("BESSEL_J0", ast, in_r_D);
3215 break;
3216 case I_BESSEL_J1:
3217 ilm = intrin_name("BESSEL_J1", ast, in_r_D);
3218 break;
3219 case I_BESSEL_Y0:
3220 ilm = intrin_name("BESSEL_Y0", ast, in_r_D);
3221 break;
3222 case I_BESSEL_Y1:
3223 ilm = intrin_name("BESSEL_Y1", ast, in_r_D);
3224 break;
3225 case I_BESSEL_YN:
3226 case I_BESSEL_JN:
3227 args = A_ARGSG(ast);
3228 arg1 = ARGT_ARG(args, 0);
3229 lower_expression(arg1);
3230 intrinsic_args[0] = lower_ilm(arg1);
3231 arg1 = ARGT_ARG(args, 1);
3232 lower_expression(arg1);
3233 intrinsic_args[1] = lower_ilm(arg1);
3234 if (intr == I_BESSEL_YN)
3235 ilm = intrin_name("BESSEL_YN", ast, in_r_D);
3236 else
3237 ilm = intrin_name("BESSEL_JN", ast, in_r_D);
3238 break;
3239
3240 /* atan2 family */
3241 case I_ATAN2:
3242 case I_DATAN2:
3243 ilm = intrin_name("ATAN2", ast, in_r_D);
3244 break;
3245 case I_ATAN2D:
3246 case I_DATAN2D:
3247 ilm = intrin_name("ATAN2D", ast, in_r_D);
3248 break;
3249
3250 /* char family */
3251 case I_CHAR:
3252 ilm = intrin_name("CHAR", ast, in_c);
3253 break;
3254 case I_ACHAR:
3255 ilm = intrin_name("CHAR", ast, in_c);
3256 break;
3257 case I_NCHAR:
3258 ilm = intrin_name("NCHAR", ast, in_nc);
3259 break;
3260
3261 /* cmplx */
3262 case I_CMPLX:
3263 case I_DCMPLX:
3264 arg1 = ARGT_ARG(args, 0);
3265 arg2 = 0;
3266 if (nargs >= 2)
3267 arg2 = ARGT_ARG(args, 1);
3268 if (arg2 == 0) {
3269 switch (DTYG(A_NDTYPEG(ast))) {
3270 case TY_CMPLX:
3271 ilm = lower_conv(arg1, DT_CMPLX8);
3272 break;
3273 case TY_DCMPLX:
3274 ilm = lower_conv(arg1, DT_CMPLX16);
3275 break;
3276 default:
3277 break;
3278 }
3279 A_ILMP(ast, ilm);
3280 return ilm;
3281 } else {
3282 switch (DTYG(A_NDTYPEG(ast))) {
3283 case TY_CMPLX:
3284 ilm = lower_conv(arg1, DT_REAL4);
3285 ilm2 = lower_conv(arg2, DT_REAL4);
3286 ilm = plower("oii", "CMPLX", ilm, ilm2);
3287 break;
3288 case TY_DCMPLX:
3289 ilm = lower_conv(arg1, DT_REAL8);
3290 ilm2 = lower_conv(arg2, DT_REAL8);
3291 ilm = plower("oii", "DCMPLX", ilm, ilm2);
3292 break;
3293 default:
3294 break;
3295 }
3296 A_ILMP(ast, ilm);
3297 return ilm;
3298 }
3299
3300 /* conjg family */
3301 case I_CONJG:
3302 case I_DCONJG:
3303 ilm = intrin_name("CONJG", ast, in_c_cD);
3304 break;
3305
3306 /* cos family */
3307 case I_COS:
3308 case I_DCOS:
3309 case I_CCOS:
3310 case I_CDCOS:
3311 ilm = intrin_name("COS", ast, in_r_D_C_CD);
3312 break;
3313 case I_COSD:
3314 case I_DCOSD:
3315 ilm = intrin_name("COSD", ast, in_r_D);
3316 break;
3317
3318 /* cosh family */
3319 case I_COSH:
3320 case I_DCOSH:
3321 ilm = intrin_name("COSH", ast, in_r_D);
3322 break;
3323
3324 /* dble family */
3325 case I_DFLOTI:
3326 case I_DFLOAT:
3327 case I_DFLOTJ:
3328 case I_DBLE:
3329 ilm = conv_dble(ARGT_ARG(args, 0));
3330 A_ILMP(ast, ilm);
3331 return ilm;
3332
3333 /* dprod */
3334 case I_DPROD:
3335 ilm = intrin_name("DPROD", ast, in_d);
3336 break;
3337
3338 /* dim family */
3339 case I_IIDIM:
3340 case I_JIDIM:
3341 case I_KIDIM:
3342 case I_IDIM:
3343 case I_DDIM:
3344 case I_DIM:
3345 ilm = intrin_name("DIM", ast, in_I_K_r_D);
3346 break;
3347
3348 /* exp family */
3349 case I_EXP:
3350 case I_DEXP:
3351 case I_CEXP:
3352 case I_CDEXP:
3353 ilm = intrin_name("EXP", ast, in_r_D_C_CD);
3354 break;
3355
3356 /* ibclr family */
3357 case I_IIBCLR:
3358 case I_JIBCLR:
3359 case I_KIBCLR:
3360 case I_IBCLR:
3361 ilm = intrin_name("BCLR", ast, in_I_K);
3362 break;
3363
3364 /* ibits family */
3365 case I_IIBITS:
3366 case I_JIBITS:
3367 case I_KIBITS:
3368 case I_IBITS:
3369 ilm = intrin_name("BITS", ast, in_I_K);
3370 break;
3371
3372 /* ibset family */
3373 case I_IIBSET:
3374 case I_JIBSET:
3375 case I_KIBSET:
3376 case I_IBSET:
3377 ilm = intrin_name("BSET", ast, in_I_K);
3378 break;
3379
3380 /* ibtest family */
3381 case I_BITEST:
3382 case I_BJTEST:
3383 case I_BTEST:
3384 ilm = intrin_name("BTEST", ast, in_il_K);
3385 break;
3386
3387 case I_BKTEST:
3388 if (argdtype != DT_LOG8) {
3389 /*
3390 * Need to have a special case for BTEST of 64-bit integers whose
3391 * result dtype is logical*4. Compute the BTEST in 64-bit and create
3392 * a logical*8 result and then convert the result to logical*4.
3393 * Without the special case, the arguments are converted to
3394 * integer*4 value and then a 32-bit BTEST is performed.
3395 */
3396 ilm1 = lower_conv(ARGT_ARG(args, 0), DT_INT8);
3397 ilm2 = lower_conv(ARGT_ARG(args, 1), DT_INT8);
3398 ilm = plower("om", "KBTEST");
3399 plower("im", ilm1);
3400 plower("im", ilm2);
3401 plower("e");
3402 ilm = plower("oi", "I8TOI", ilm);
3403 A_ILMP(ast, ilm);
3404 return ilm;
3405 }
3406 ilm = plower("om", "KBTEST");
3407 break;
3408
3409 /* ichar family */
3410 case I_ICHAR:
3411 case I_IACHAR:
3412 arg1 = ARGT_ARG(args, 0);
3413 fromdtype = A_NDTYPEG(arg1);
3414 if (DTY(fromdtype) == TY_NCHAR) {
3415 ilm = intrin_name("INCHAR", ast, in_i_k);
3416 } else {
3417 ilm = intrin_name("ICHAR", ast, in_i_k);
3418 }
3419 plower("im", intrinsic_args[0]);
3420 plower("e");
3421 dtype = A_DTYPEG(ast);
3422 if (dtype == DT_INT8) {
3423 /* convert to int8 */
3424 ilm = plower("oi", "ITOI8", ilm);
3425 }
3426 argsdone = 1;
3427 break;
3428
3429 /* imag family */
3430 case I_AIMAG:
3431 case I_DIMAG:
3432 ilm = intrin_name("IMAG", ast, in_r_D);
3433 break;
3434
3435 /* int family */
3436 case I_IDINT:
3437 case I_JIDINT:
3438 case I_IIDINT:
3439 case I_IINT:
3440 case I_JINT:
3441 case I_INT:
3442 case I_IFIX:
3443 case I_JIFIX:
3444 case I_IIFIX:
3445 case I_INT1:
3446 case I_INT2:
3447 case I_INT4:
3448 case I_INT8:
3449 dty = DTYG(A_NDTYPEG(ast));
3450 if (dty == TY_INT8) {
3451 ilm = conv_int8(ARGT_ARG(args, 0));
3452 } else if (dty == TY_INT) {
3453 ilm = conv_int(ARGT_ARG(args, 0));
3454 } else {
3455 ilm = lower_base(ARGT_ARG(args, 0));
3456 ilm2 = plower(
3457 "oS", "ICON",
3458 lower_getintcon(ty_to_lib[DTYG(A_NDTYPEG(ARGT_ARG(args, 0)))]));
3459 symfunc =
3460 lower_makefunc(mk_coercion_func_name(dty), A_NDTYPEG(ast), FALSE);
3461 ilm = plower("onsiiC", "IFUNC", 2, symfunc, ilm, ilm2, symfunc);
3462 }
3463 A_ILMP(ast, ilm);
3464 return ilm;
3465
3466 case I_C_LOC:
3467 case I_C_FUNLOC:
3468 case I_LOC:
3469 ilm = plower("om", "LOC");
3470 break;
3471
3472 case I_LOGICAL:
3473 arg1 = ARGT_ARG(args, 0);
3474 ilm = lower_conv(arg1, A_NDTYPEG(ast));
3475 argsdone = 1;
3476 break;
3477
3478 /* log family */
3479 case I_ALOG:
3480 case I_DLOG:
3481 case I_CLOG:
3482 case I_CDLOG:
3483 case I_LOG:
3484 ilm = intrin_name("LOG", ast, in_r_D_C_CD);
3485 break;
3486 case I_ALOG10:
3487 case I_DLOG10:
3488 case I_LOG10:
3489 ilm = intrin_name("LOG10", ast, in_r_D);
3490 break;
3491
3492 /* max family */
3493 case I_MAX:
3494 case I_MAX0: /* i*4,i*4 -> i*4 */
3495 case I_IMAX0: /* i*2,i*2 -> i*2 */
3496 case I_JMAX0: /* i*4,i*4 -> i*4 */
3497 case I_KMAX0: /* i*8,i*8 -> i*8 */
3498 case I_AMAX0:
3499 case I_AIMAX0:
3500 case I_AJMAX0:
3501 case I_MAX1:
3502 case I_IMAX1:
3503 case I_JMAX1:
3504 case I_KMAX1:
3505 case I_AMAX1: /* r*4,r*4 -> r*4 */
3506 case I_DMAX1:
3507 /*
3508 i0: BOS l0 n1 n0
3509 i4: BASE s37944 ;specstring$len
3510 i6: ICON s656 ;4
3511 i8: BASE s37931 ;speclist$len
3512 i10: KLD i8
3513 i12: I8TOI i10
3514 i14: KMAX i12 i6 ---> Should be "i14: IMAX i12 i6"
3515 i17: IMUL i14 i6
3516 i20: ITOI8 i17
3517 i22: KCON s610 ;0
3518 i24: KMAX i20 i22
3519 i27: KST i4 i24
3520 For intrinsic function, compiler will convert operands dtype to the same as
3521 the intrinsic, e.g. like "i20 ITOI8 i17" shows here. But when generating the
3522 MAX instruction, it checks operands dtype to decide which types of MAX to be
3523 generated. When we converting operands initially, symtab is not changed, so,
3524 MAX instruction just needs to use the same dtype as intrinsic function. e.g.
3525 the first KMAX is incorrect here, as operands type is integer not
3526 integer*8. To fix the issue, we check whether operands have the same dtype,
3527 if yes we just user the first operand dtype, otherwise use the
3528 intrinsic-func dtype as the operands have been converted the same as the one
3529 of intrinsic-func.
3530 */
3531 arg0 = ARGT_ARG(args, 0);
3532 arg1 = ARGT_ARG(args, 1);
3533 input_ast = A_NDTYPEG(arg0) == A_NDTYPEG(arg1) ? arg0 : ast;
3534 ilm = intrin_name("MAX", input_ast, in_I_K_R_D);
3535 pairwise = 1;
3536 break;
3537
3538 /* min family */
3539 case I_MIN:
3540 case I_MIN0:
3541 case I_IMIN0:
3542 case I_JMIN0:
3543 case I_KMIN0:
3544 case I_AMIN0:
3545 case I_AIMIN0:
3546 case I_AJMIN0:
3547 case I_MIN1:
3548 case I_IMIN1:
3549 case I_JMIN1:
3550 case I_KMIN1:
3551 case I_AMIN1:
3552 case I_DMIN1:
3553 arg0 = ARGT_ARG(args, 0);
3554 arg1 = ARGT_ARG(args, 1);
3555 input_ast = A_NDTYPEG(arg0) == A_NDTYPEG(arg1) ? arg0 : ast;
3556 ilm = intrin_name("MIN", input_ast, in_I_K_R_D);
3557 pairwise = 1;
3558 break;
3559
3560 /* mod family */
3561 case I_IMOD:
3562 case I_JMOD:
3563 case I_KMOD:
3564 case I_AMOD:
3565 case I_DMOD:
3566 case I_MOD:
3567 ilm = intrin_name("MOD", ast, in_i_K_A_D);
3568 break;
3569
3570 /* nint family */
3571 case I_IDNINT:
3572 case I_ININT:
3573 case I_JNINT:
3574 case I_KNINT:
3575 case I_NINT:
3576 case I_IIDNNT:
3577 case I_JIDNNT:
3578 case I_KIDNNT:
3579 dty = DTYG(A_NDTYPEG(ast));
3580 if (DTYG(A_NDTYPEG(ARGT_ARG(args, 0))) == TY_DBLE) {
3581 ilm = intrin_name("DNINT", ast, in_I_K);
3582 } else {
3583 ilm = intrin_name("NINT", ast, in_i_K);
3584 }
3585 if (dty != TY_INT && dty != TY_INT8) {
3586 plower("im", intrinsic_args[0]);
3587 plower("e");
3588 ilm2 = plower("oS", "ICON", lower_getintcon(ty_to_lib[TY_INT]));
3589 symfunc =
3590 lower_makefunc(mk_coercion_func_name(dty), A_NDTYPEG(ast), FALSE);
3591 ilm = plower("onsiiC", "IFUNC", 2, symfunc, ilm, ilm2, symfunc);
3592 A_ILMP(ast, ilm);
3593 return ilm;
3594 }
3595 break;
3596
3597 /* not family */
3598 case I_INOT:
3599 case I_JNOT:
3600 case I_NOT:
3601 case I_COMPL:
3602 ilm = intrin_name("NOT", ast, in_i_K);
3603 break;
3604
3605 /* or family */
3606 case I_IIOR:
3607 case I_JIOR:
3608 case I_IOR:
3609 case I_OR:
3610 ilm = intrin_name("OR", ast, in_i_K);
3611 break;
3612
3613 case I_DREAL:
3614 case I_REAL:
3615 arg = ARGT_ARG(args, 0);
3616 argdtype = A_NDTYPEG(arg);
3617 ilm = lower_ilm(arg);
3618 switch (DTYG(argdtype)) {
3619 case TY_CMPLX:
3620 ilm = plower("oi", "REAL", ilm);
3621 argdtype = DT_REAL4;
3622 break;
3623 case TY_DCMPLX:
3624 ilm = plower("oi", "DREAL", ilm);
3625 argdtype = DT_REAL8;
3626 break;
3627 default:
3628 break;
3629 }
3630 ilm = lower_conv_ilm(ast, ilm, argdtype, A_NDTYPEG(ast));
3631 return ilm;
3632
3633 /* real family */
3634 case I_FLOATI:
3635 case I_FLOATJ:
3636 case I_FLOAT:
3637 case I_SNGL:
3638 ilm = conv_real(ARGT_ARG(args, 0));
3639 A_ILMP(ast, ilm);
3640 return ilm;
3641
3642 /* sin family */
3643 case I_SIN:
3644 case I_DSIN:
3645 case I_CSIN:
3646 case I_CDSIN:
3647 ilm = intrin_name("SIN", ast, in_r_D_C_CD);
3648 break;
3649 case I_SIND:
3650 case I_DSIND:
3651 ilm = intrin_name("SIND", ast, in_r_D);
3652 break;
3653
3654 /* sinh family */
3655 case I_SINH:
3656 case I_DSINH:
3657 ilm = intrin_name("SINH", ast, in_r_D);
3658 break;
3659
3660 /* sqrt family */
3661 case I_SQRT:
3662 case I_DSQRT:
3663 case I_CSQRT:
3664 case I_CDSQRT:
3665 ilm = intrin_name("SQRT", ast, in_r_D_C_CD);
3666 break;
3667
3668 /* tan family */
3669 case I_TAN:
3670 case I_DTAN:
3671 ilm = intrin_name("TAN", ast, in_r_D);
3672 break;
3673 case I_TAND:
3674 case I_DTAND:
3675 ilm = intrin_name("TAND", ast, in_r_D);
3676 break;
3677
3678 /* tanh family */
3679 case I_TANH:
3680 case I_DTANH:
3681 ilm = intrin_name("TANH", ast, in_r_D);
3682 break;
3683
3684 /* shift family */
3685 case I_JISHFT:
3686 case I_KISHFT:
3687 case I_ISHFT:
3688 ilm = intrin_name("ISHFT", ast, in_J_K);
3689 break;
3690 case I_IISHFT:
3691 ilm = plower("om", "IISHFT");
3692 break;
3693 case I_IISHFTC:
3694 ilm = plower("om", "IISHFTC");
3695 break;
3696 case I_JISHFTC:
3697 case I_KISHFTC:
3698 case I_ISHFTC:
3699 ilm = intrin_name("SHFTC", ast, in_I_K);
3700 break;
3701 case I_SHIFT:
3702 ilm = intrin_name("SHIFT", ast, in_i_K);
3703 break;
3704 case I_LSHIFT:
3705 ilm = intrin_name("ULSHIFT", ast, in_i_K);
3706 break;
3707 case I_RSHIFT:
3708 ilm = intrin_name("URSHIFT", ast, in_i_K);
3709 break;
3710
3711 /* sign family */
3712 case I_IISIGN:
3713 case I_JISIGN:
3714 case I_KISIGN:
3715 case I_ISIGN:
3716 case I_DSIGN:
3717 case I_SIGN:
3718 ilm = intrin_name("SIGN", ast, in_I_K_r_D);
3719 break;
3720
3721 /* xor family */
3722 case I_IIEOR:
3723 case I_JIEOR:
3724 case I_IEOR:
3725 case I_XOR:
3726 case I_NEQV:
3727 ilm = intrin_name("XOR", ast, in_i_K);
3728 break;
3729
3730 case I_EQV:
3731 ilm = intrin_name("XNOR", ast, in_i_K);
3732 break;
3733
3734 case I_LEN:
3735 case I_KLEN:
3736 arg1 = ARGT_ARG(args, 0);
3737 fromdtype = A_NDTYPEG(arg1);
3738 if (DTY(fromdtype) == TY_NCHAR) {
3739 ilm = intrin_name("NLEN", ast, in_i);
3740 } else {
3741 ilm = intrin_name("LEN", ast, in_i_K);
3742 }
3743 break;
3744
3745 case I_LEN_TRIM:
3746 dtype = A_DTYPEG(ast);
3747 symfunc = lower_makefunc(mkRteRtnNm(RTE_lentrima), DT_INT8, FALSE);
3748 if (dtype == DT_INT8) {
3749 ilm = plower("onsm", "KFUNC", nargs, symfunc);
3750 } else {
3751 ilm = plower("onsm", "IFUNC", nargs, symfunc);
3752 }
3753 break;
3754
3755 case I_CEILING:
3756 dtype = A_NDTYPEG(ast);
3757 ilm = intrin_name("CEIL", ast, in_R_D);
3758 break;
3759 case I_FLOOR:
3760 dtype = A_NDTYPEG(ast);
3761 ilm = intrin_name("FLOOR", ast, in_R_D);
3762 break;
3763
3764 case I_AINT:
3765 case I_DINT:
3766 dtype = A_NDTYPEG(ast);
3767 ilm = intrin_name("INT", ast, in_A_D);
3768 break;
3769
3770 case I_ANINT:
3771 case I_DNINT:
3772 ilm = intrin_name("NINT", ast, in_A_D);
3773 break;
3774
3775 case I_INDEX:
3776 case I_KINDEX:
3777 if (nargs == 4) {
3778 int a3, s3;
3779 /* check for .false. third argument */
3780 a3 = ARGT_ARG(args, 2);
3781 if (A_TYPEG(a3) == A_CNST) {
3782 s3 = A_SPTRG(a3);
3783 if (DTYPEG(s3) == DT_LOG && CONVAL2G(s3) == 0) {
3784 nargs = 2;
3785 }
3786 }
3787 }
3788 if (nargs == 2) {
3789 for (i = 0; i < nargs; ++i) {
3790 intrinsic_args[i] = lower_base(ARGT_ARG(args, i));
3791 }
3792 if (DTY(A_DTYPEG(ARGT_ARG(args, 0))) == TY_NCHAR) {
3793 ilm = plower("om", "NINDEX");
3794 fromdtype = DT_INT4;
3795 } else if (A_NDTYPEG(ast) == DT_INT4) {
3796 ilm = plower("om", "INDEX");
3797 fromdtype = DT_INT4;
3798 } else if (A_NDTYPEG(ast) == DT_INT8) {
3799 ilm = plower("om", "KINDEX");
3800 fromdtype = DT_INT8;
3801 } else {
3802 ilm = plower("om", "INDEX");
3803 fromdtype = DT_INT4;
3804 }
3805 } else {
3806 dtype = A_DTYPEG(ast);
3807 if (dtype == DT_INT8) {
3808 fromdtype = DT_INT8;
3809 } else {
3810 fromdtype = DT_INT4;
3811 }
3812 ilm = f90_function(mkRteRtnNm(RTE_indexa), fromdtype, args, nargs);
3813 }
3814 break;
3815
3816 case I_NINDEX:
3817 for (i = 0; i < 2; ++i) {
3818 intrinsic_args[i] = lower_base(ARGT_ARG(args, i));
3819 }
3820 ilm = plower("om", "NINDEX");
3821 break;
3822
3823 case I_ALLOCATED:
3824 rtlRtn = RTE_allocated;
3825 ilm = f90_function(mkRteRtnNm(rtlRtn), stb.user.dt_log, args, nargs);
3826 break;
3827
3828 case I_PRESENT:
3829 /* single argument */
3830 arg0 = ARGT_ARG(args, 0);
3831 if (!XBIT(57, 0x20000000) && !XBIT(57, 0x8000)) {
3832 /* streamlined present -- 'absent' is just NULL */
3833 if (A_TYPEG(arg0) == A_ID) {
3834 int sym;
3835 sym = A_SPTRG(arg0);
3836 if (SCG(sym) == SC_BASED && MIDNUMG(sym) && XBIT(57, 0x80000)) {
3837 ilm1 = lower_base_sptr(MIDNUMG(sym));
3838 } else if (POINTERG(sym) && NEWARGG(sym)) {
3839 /* special case for optional pointer arguments */
3840 ilm1 = lower_base_sptr(NEWARGG(sym));
3841 } else
3842 ilm1 = lower_base(arg0);
3843 ilm2 = plower("oS", "ACON", lowersym.ptrnull);
3844 ilm = plower("oii", "PCMP", ilm1, ilm2);
3845 ilm = plower("oi", "NE", ilm);
3846 } else {
3847 /* something interesting created by IPA inlining or arg
3848 * propagation
3849 */
3850 sptr = lower_getlogcon(SCFTN_TRUE);
3851 ilm = plower("oS", "LCON", sptr);
3852 }
3853 } else {
3854 dtype = A_DTYPEG(ast);
3855 argdtype = A_NDTYPEG(arg0);
3856 if (DTYG(argdtype) == TY_CHAR || DTY(argdtype) == TY_NCHAR) {
3857 rtlRtn = RTE_presentc;
3858 } else {
3859 if (A_TYPEG(arg0) == A_ID && POINTERG(A_SPTRG(arg0)) &&
3860 !XBIT(57, 0x80000))
3861 rtlRtn = RTE_present_ptr;
3862 else {
3863 rtlRtn = RTE_present;
3864 }
3865 }
3866 symfunc = lower_makefunc(mkRteRtnNm(rtlRtn), dtype, FALSE);
3867 ilm1 = 0;
3868 if (A_TYPEG(arg0) == A_ID) {
3869 int sym;
3870 sym = A_SPTRG(arg0);
3871 if (SCG(sym) == SC_BASED && MIDNUMG(sym) && XBIT(57, 0x80000)) {
3872 ilm1 = lower_base_sptr(MIDNUMG(sym));
3873 } else if (POINTERG(sym) && NEWARGG(sym)) {
3874 /* special case for optional pointer arguments */
3875 ilm1 = lower_base_sptr(NEWARGG(sym));
3876 }
3877 }
3878 if (!ilm1)
3879 ilm1 = lower_base(arg0);
3880 ilm = plower("onsi", ltyped("FUNC", dtype), 1, symfunc, ilm1);
3881 }
3882 argsdone = 1;
3883 break;
3884
3885 case I_LGE:
3886 case I_LGT:
3887 case I_LLE:
3888 case I_LLT:
3889 if (nargs != 2) {
3890 lerror("wrong number of arguments for L[LG][ET] comparison intrinsic");
3891 return 0;
3892 }
3893 intrinsic_args[0] = lower_base(ARGT_ARG(args, 0));
3894 intrinsic_args[1] = lower_base(ARGT_ARG(args, 1));
3895 ilm = plower("oii", styped("CMP", A_DTYPEG(ARGT_ARG(args, 0))),
3896 intrinsic_args[0], intrinsic_args[1]);
3897 switch (intr) {
3898 case I_LGE:
3899 ilm = plower("oi", "GE", ilm);
3900 break;
3901 case I_LGT:
3902 ilm = plower("oi", "GT", ilm);
3903 break;
3904 case I_LLE:
3905 ilm = plower("oi", "LE", ilm);
3906 break;
3907 case I_LLT:
3908 ilm = plower("oi", "LT", ilm);
3909 break;
3910 }
3911 A_ILMP(ast, ilm);
3912 return ilm;
3913
3914 case I_MERGE:
3915 switch (DTY(A_DTYPEG(ast))) {
3916 case TY_BINT:
3917 case TY_SINT:
3918 case TY_INT:
3919 case TY_INT8:
3920 case TY_FLOAT:
3921 case TY_DBLE:
3922 case TY_BLOG:
3923 case TY_SLOG:
3924 case TY_LOG:
3925 case TY_LOG8:
3926 for (i = 0; i < 2; i++) {
3927 arg = ARGT_ARG(args, i);
3928 lower_expression(arg);
3929 intrinsic_args[i] = lower_ilm(arg);
3930 }
3931 intrinsic_args[2] = lower_conv(ARGT_ARG(args, 2), DT_LOG4);
3932 ilm = intrin_name("MERGE", ast, in_Il_K_R_D_C_CD);
3933 nargs = 3;
3934 break;
3935 default:
3936 /* just treat like a function call */
3937
3938 if ((DTY(A_DTYPEG(ast)) == TY_CMPLX || DTY(A_DTYPEG(ast)) == TY_DCMPLX) &&
3939 (XBIT(70, 0x40000000))) {
3940 for (i = 0; i < 2; i++) {
3941 arg = ARGT_ARG(args, i);
3942 lower_expression(arg);
3943 intrinsic_args[i] = lower_ilm(arg);
3944 }
3945 intrinsic_args[2] = lower_conv(ARGT_ARG(args, 2), DT_LOG4);
3946 ilm = intrin_name("MERGE", ast, in_R_D_C_CD);
3947 nargs = 3;
3948 } else {
3949 ilm = lower_function(ast);
3950 A_ILMP(ast, ilm);
3951 return ilm;
3952 }
3953 break;
3954 }
3955 break;
3956
3957 case I_ADJUSTL:
3958 case I_ADJUSTR:
3959 case I_TRIM:
3960 ilm = lower_function(ast);
3961 A_ILMP(ast, ilm);
3962 return ilm;
3963
3964 case I_ILEN:
3965 /* just treat like a function call, with pghpf prefix */
3966 ilm = lower_function(ast);
3967 A_ILMP(ast, ilm);
3968 return ilm;
3969
3970 case I_NLEN:
3971 ilm = intrin_name("NLEN", ast, in_i);
3972 break;
3973
3974 case I_SIZE:
3975 arg = ARGT_ARG(args, 0);
3976 shape = A_SHAPEG(arg);
3977 cnt = SHD_NDIM(shape);
3978 lower_expression(ARGT_ARG(args, 1));
3979 for (i = 0; i < cnt; ++i) {
3980 lower_expression(check_member(arg, SHD_LWB(shape, i)));
3981 if (SHD_UPB(shape, i))
3982 lower_expression(check_member(arg, SHD_UPB(shape, i)));
3983 lower_expression(check_member(arg, SHD_STRIDE(shape, i)));
3984 }
3985 num = 0;
3986 intrinsic_args[num++] =
3987 plower("oS", lowersym.bnd.con, lower_getiszcon(cnt));
3988 intrinsic_args[num++] = lower_base(ARGT_ARG(args, 1));
3989 for (i = 0; i < cnt; ++i) {
3990 argdtype = A_DTYPEG(arg);
3991 if (ASSUMSHPG(find_array(arg, 0)) &&
3992 A_TYPEG(ADD_LWBD(argdtype, i)) == A_CNST &&
3993 ADD_LWBD(argdtype, i) != astb.bnd.one && ADD_LWAST(argdtype, i)) {
3994 /* if the argument is an assumed shape array with constant lbound
3995 * that is not 1, the actual lower bound is in a compiler generated
3996 * temp that is set by code generated in dpm_out.c:set_assumed_bounds.
3997 */
3998 int lb = ADD_LWAST(argdtype, i);
3999 lower_expression(lb);
4000 intrinsic_args[num++] = lower_base(lb);
4001 } else {
4002 intrinsic_args[num++] =
4003 lower_base(check_member(arg, SHD_LWB(shape, i)));
4004 }
4005 if (SHD_UPB(shape, i)) {
4006 intrinsic_args[num++] =
4007 lower_base(check_member(arg, SHD_UPB(shape, i)));
4008 } else {
4009 intrinsic_args[num++] = lower_null_arg();
4010 }
4011 intrinsic_args[num++] =
4012 lower_base(check_member(arg, SHD_STRIDE(shape, i)));
4013 }
4014 dtype = A_DTYPEG(ast);
4015 symfunc = lower_makefunc(mkRteRtnNm(RTE_size), DT_INT8, FALSE);
4016 if (dtype == DT_INT8) {
4017 ilm = plower("onsm", "KFUNC", num, symfunc);
4018 } else {
4019 ilm = plower("onsm", "IFUNC", num, symfunc);
4020 }
4021 for (i = 0; i < num; ++i) {
4022 plower("im", intrinsic_args[i]);
4023 }
4024 plower("C", symfunc);
4025 A_ILMP(ast, ilm);
4026 return ilm;
4027
4028 case I_LBOUND:
4029 case I_UBOUND:
4030 arg = ARGT_ARG(args, 0);
4031 shape = A_SHAPEG(arg);
4032 cnt = SHD_NDIM(shape);
4033 lower_expression(ARGT_ARG(args, 1));
4034 for (i = 0; i < cnt; ++i) {
4035 lower_expression(check_member(arg, SHD_LWB(shape, i)));
4036 if (SHD_UPB(shape, i))
4037 lower_expression(check_member(arg, SHD_UPB(shape, i)));
4038 }
4039 num = 0;
4040 intrinsic_args[num++] = plower("oS", "ICON", lower_getintcon(cnt));
4041 intrinsic_args[num++] = lower_base(ARGT_ARG(args, 1));
4042 for (i = 0; i < cnt; ++i) {
4043 argdtype = A_DTYPEG(arg);
4044 if (ASSUMSHPG(find_array(arg, 0)) &&
4045 A_TYPEG(ADD_LWBD(argdtype, i)) == A_CNST &&
4046 ADD_LWBD(argdtype, i) != astb.bnd.one && ADD_LWAST(argdtype, i)) {
4047 /* if the argument is an assumed shape array with constant lbound
4048 * that is not 1, the actual lower bound is in a compiler generated
4049 * temp that is set by code generated in dpm_out.c:set_assumed_bounds.
4050 */
4051 int lb = ADD_LWAST(argdtype, i);
4052 lower_expression(lb);
4053 intrinsic_args[num++] = lower_base(lb);
4054 } else {
4055 intrinsic_args[num++] =
4056 lower_base(check_member(arg, SHD_LWB(shape, i)));
4057 }
4058 if (SHD_UPB(shape, i)) {
4059 intrinsic_args[num++] =
4060 lower_base(check_member(arg, SHD_UPB(shape, i)));
4061 } else {
4062 intrinsic_args[num++] = lower_null_arg();
4063 }
4064 }
4065 if (intr == I_LBOUND) {
4066 symfunc = lower_makefunc(mkRteRtnNm(RTE_lb), DT_INT4, FALSE);
4067 } else {
4068 symfunc = lower_makefunc(mkRteRtnNm(RTE_ub), DT_INT4, FALSE);
4069 }
4070 ilm = plower("onsm", "IFUNC", num, symfunc);
4071 for (i = 0; i < num; ++i) {
4072 plower("im", intrinsic_args[i]);
4073 }
4074 plower("C", symfunc);
4075 A_ILMP(ast, ilm);
4076 return ilm;
4077
4078 case I_MODULO:
4079 /*
4080 * see semfunc.c for the spelling of the function name.
4081 */
4082 dtype = A_NDTYPEG(ast);
4083 symfunc = A_SPTRG(A_LOPG(ast));
4084 for (i = 0; i < nargs; ++i) {
4085 ilm = lower_ilm(ARGT_ARG(args, i));
4086 ilm = plower("oi", "DPVAL", ilm);
4087 intrinsic_args[i] = ilm;
4088 }
4089 ilm = plower("onsm", ltyped("FUNC", dtype), nargs, symfunc);
4090 break;
4091
4092 case I_EXPONENT:
4093 dtype = A_DTYPEG(ast);
4094 switch (DTY(DDTG(A_NDTYPEG(ARGT_ARG(args, 0))))) {
4095 case TY_REAL:
4096 rtlRtn = RTE_exponx;
4097 break;
4098 case TY_DBLE:
4099 rtlRtn = RTE_expondx;
4100 break;
4101 default:
4102 ast_error("unexpected argument type for exponent", ast);
4103 break;
4104 }
4105 rtn_name = mkRteRtnNm(rtlRtn);
4106 retDtype = (dtype == DT_INT8) ? DT_INT8 : DT_INT4;
4107 ilm = f90_value_function(rtn_name, retDtype, args, nargs);
4108 break;
4109
4110 case I_FRACTION:
4111 if (DTY(DDTG(A_NDTYPEG(ARGT_ARG(args, 0)))) == TY_REAL) {
4112 ilm = f90_value_function(mkRteRtnNm(RTE_fracx), DT_REAL4, args, nargs);
4113 } else {
4114 ilm = f90_value_function(mkRteRtnNm(RTE_fracdx), DT_REAL8, args, nargs);
4115 }
4116 break;
4117
4118 case I_RRSPACING:
4119 if (DTY(DDTG(A_NDTYPEG(ast))) == TY_REAL) {
4120 ilm =
4121 f90_value_function(mkRteRtnNm(RTE_rrspacingx), DT_REAL4, args, nargs);
4122 } else {
4123 ilm = f90_value_function(mkRteRtnNm(RTE_rrspacingdx), DT_REAL8, args,
4124 nargs);
4125 }
4126 break;
4127 case I_SPACING:
4128 if (DTY(DDTG(A_NDTYPEG(ast))) == TY_REAL) {
4129 ilm = f90_value_function(mkRteRtnNm(RTE_spacingx), DT_REAL4, args, nargs);
4130 } else {
4131 ilm =
4132 f90_value_function(mkRteRtnNm(RTE_spacingdx), DT_REAL8, args, nargs);
4133 }
4134 break;
4135 case I_NEAREST:
4136 if (DTY(DDTG(A_NDTYPEG(ast))) == TY_REAL) {
4137 ilm = f90_value_function(mkRteRtnNm(RTE_nearestx), DT_REAL4, args, nargs);
4138 } else {
4139 ilm =
4140 f90_value_function(mkRteRtnNm(RTE_nearestdx), DT_REAL8, args, nargs);
4141 }
4142 break;
4143 case I_SCALE:
4144 if (DTY(DDTG(A_NDTYPEG(ast))) == TY_REAL) {
4145 ilm =
4146 f90_value_function_I2(mkRteRtnNm(RTE_scalex), DT_REAL4, args, nargs);
4147 } else {
4148 ilm =
4149 f90_value_function_I2(mkRteRtnNm(RTE_scaledx), DT_REAL8, args, nargs);
4150 }
4151 break;
4152 case I_SET_EXPONENT:
4153 if (DTY(DDTG(A_NDTYPEG(ast))) == TY_REAL) {
4154 ilm =
4155 f90_value_function_I2(mkRteRtnNm(RTE_setexpx), DT_REAL4, args, nargs);
4156 } else {
4157 ilm = f90_value_function_I2(mkRteRtnNm(RTE_setexpdx), DT_REAL8, args,
4158 nargs);
4159 }
4160 break;
4161 case I_VERIFY:
4162 dtype = A_DTYPEG(ast);
4163 rtlRtn = (DTY(DDTG(A_NDTYPEG(ARGT_ARG(args, 0)))) == TY_CHAR) ? RTE_verifya
4164 : RTE_nverify;
4165 retDtype = (dtype == DT_INT8) ? DT_INT8 : DT_INT4;
4166 ilm = f90_function(mkRteRtnNm(rtlRtn), retDtype, args, nargs);
4167 break;
4168 case I_SCAN:
4169 dtype = A_DTYPEG(ast);
4170 rtlRtn = (DTY(DDTG(A_NDTYPEG(ARGT_ARG(args, 0)))) == TY_CHAR) ? RTE_scana
4171 : RTE_scana;
4172 retDtype = (dtype == DT_INT8) ? DT_INT8 : DT_INT4;
4173 ilm = f90_function(mkRteRtnNm(rtlRtn), retDtype, args, nargs);
4174 break;
4175 case I_ASSOCIATED:
4176 /* determine whether the first argument is NULL or not,
4177 * and, if the second argument is present, whether the first
4178 * argument points to the second */
4179 arg1 = ARGT_ARG(args, 0);
4180 arg2 = ARGT_ARG(args, 1);
4181 ilm1 = lower_target(arg1);
4182 sptr = 0;
4183 switch (A_TYPEG(arg1)) {
4184 case A_ID:
4185 sptr = A_SPTRG(arg1);
4186 if (!XBIT(49, 0x20000000)) {
4187 ilm1 = lower_typeload(DT_ADDR, ilm1);
4188 } else {
4189 ilm1 = lower_typeload(DT_PTR, ilm1);
4190 }
4191 break;
4192 case A_MEM:
4193 sptr = A_SPTRG(A_MEMG(arg1));
4194 if (!XBIT(49, 0x20000000)) {
4195 ilm1 = lower_typeload(DT_ADDR, ilm1);
4196 } else {
4197 ilm1 = lower_typeload(DT_PTR, ilm1);
4198 }
4199 break;
4200 default:
4201 ilm1 = lower_typeload(DT_PTR, ilm1);
4202 break;
4203 }
4204 if (sptr && !XBIT(49, 0x20000000)) {
4205 ilm2 = plower("oS", "ACON", lowersym.ptrnull);
4206 ilm = plower("oii", "PCMP", ilm1, ilm2);
4207 } else if (DT_PTR == DT_INT || DT_PTR != DT_INT8) {
4208 ilm2 = plower("oS", "ICON", lowersym.intzero);
4209 ilm = plower("oii", "ICMP", ilm1, ilm2);
4210 } else {
4211 ilm2 = plower("oS", "KCON", lowersym.intzero);
4212 ilm = plower("oii", "KCMP", ilm1, ilm2);
4213 }
4214 ilm = plower("oi", "NE", ilm);
4215 if (arg2) {
4216 ilm2 = lower_address(arg2);
4217 if (sptr && !XBIT(49, 0x20000000)) {
4218 ilm2 = plower("oii", "PCMP", ilm1, ilm2);
4219 } else if (DT_PTR == DT_INT || DT_PTR != DT_INT8) {
4220 ilm2 = plower("oii", "ICMP", ilm1, ilm2);
4221 } else {
4222 ilm2 = plower("oii", "KCMP", ilm1, ilm2);
4223 }
4224 ilm2 = plower("oi", "EQ", ilm2);
4225 ilm = plower("oii", "LAND", ilm, ilm2);
4226 }
4227 argsdone = 1;
4228 break;
4229
4230 case I_C_ASSOCIATED:
4231 /* determine whether the first argument is NULL or not,
4232 * and, if the second argument is present, whether the first
4233 * argument points to the second */
4234 arg1 = ARGT_ARG(args, 0);
4235 arg2 = ARGT_ARG(args, 1);
4236 ilm1 = lower_base(arg1);
4237 ilm1 = lower_typeload(A_DTYPEG(arg1), ilm1);
4238 if (A_DTYPEG(arg1) == DT_INT4) {
4239 ilm2 = plower("oS", "ICON", lowersym.intzero);
4240 ilm = plower("oii", "ICMP", ilm1, ilm2);
4241 } else {
4242 ilm2 = plower("oS", "KCON", lowersym.intzero);
4243 ilm = plower("oii", "KCMP", ilm1, ilm2);
4244 }
4245 ilm = plower("oi", "NE", ilm);
4246 if (arg2) {
4247 ilm2 = lower_base(arg2);
4248 ilm2 = lower_typeload(A_DTYPEG(arg1), ilm2);
4249 if (A_DTYPEG(arg1) == DT_INT4) {
4250 ilm2 = plower("oii", "ICMP", ilm1, ilm2);
4251 } else {
4252 ilm2 = plower("oii", "KCMP", ilm1, ilm2);
4253 }
4254 ilm2 = plower("oi", "EQ", ilm2);
4255 ilm = plower("oii", "LAND", ilm, ilm2);
4256 }
4257 argsdone = 1;
4258 break;
4259
4260 case I_IS_CONTIGUOUS:
4261 ilm = f90_function(mkRteRtnNm(RTE_is_contiguous), stb.user.dt_log, args,
4262 nargs);
4263 break;
4264
4265 case I_RAN:
4266 for (i = 0; i < nargs; ++i) {
4267 intrinsic_args[i] = lower_base(ARGT_ARG(args, i));
4268 }
4269 if (A_DTYPEG(ast) != DT_REAL8) {
4270 symfunc = lower_makefunc("ftn_ran", DT_REAL4, FALSE);
4271 ilm = plower("onsm", "RFUNC", nargs, symfunc);
4272 } else {
4273 /* -r8 */
4274 symfunc = lower_makefunc("ftn_dran", DT_REAL8, FALSE);
4275 ilm = plower("onsm", "DFUNC", nargs, symfunc);
4276 }
4277 break;
4278
4279 case I_ZEXT:
4280 case I_IZEXT:
4281 symfunc = lower_makefunc("ftn_izext", DT_INT, TRUE);
4282 intrinsic_args[0] = plower("oi", "DPVAL", intrinsic_args[0]);
4283 intrinsic_args[1] = plower("on", "DPSCON", 4);
4284 nargs = 2;
4285 ilm = plower("onsm", "IFUNC", nargs, symfunc);
4286 break;
4287
4288 case I_JZEXT:
4289 symfunc = lower_makefunc("ftn_jzext", DT_INT, TRUE);
4290 intrinsic_args[0] = plower("oi", "DPVAL", intrinsic_args[0]);
4291 intrinsic_args[1] = plower("on", "DPSCON", 4);
4292 nargs = 2;
4293 ilm = plower("onsm", "IFUNC", nargs, symfunc);
4294 break;
4295
4296 case I_NUMBER_OF_PROCESSORS:
4297 symfunc = A_SPTRG(A_LOPG(ast));
4298 dtype = A_DTYPEG(ast);
4299 for (i = 0; i < nargs; ++i) {
4300 intrinsic_args[i] = lower_base(ARGT_ARG(args, i));
4301 }
4302 ilm = plower("onsm", ltyped("FUNC", dtype), nargs, symfunc);
4303 for (i = 0; i < nargs; ++i) {
4304 plower("im", intrinsic_args[i]);
4305 }
4306 plower("e");
4307 return ilm;
4308
4309 case I_LEADZ:
4310 ilm = intrin_name_bsik("LEADZ", ast);
4311 break;
4312 case I_POPCNT:
4313 ilm = intrin_name_bsik("POPCNT", ast);
4314 break;
4315 case I_POPPAR:
4316 ilm = intrin_name_bsik("POPPAR", ast);
4317 break;
4318
4319 case NEW_INTRIN:
4320 nm = SYMNAME(A_LOPG(A_SPTRG(ast)));
4321 if (strcmp(nm, "acos") == 0)
4322 ilm = intrin_name("ACOS", ast, in_r_D_C_CD);
4323 else if (strcmp(nm, "asin") == 0)
4324 ilm = intrin_name("ASIN", ast, in_r_D_C_CD);
4325 else if (strcmp(nm, "atan") == 0)
4326 ilm = intrin_name("ATAN", ast, in_r_D_C_CD);
4327 else if (strcmp(nm, "cosh") == 0)
4328 ilm = intrin_name("COSH", ast, in_r_D_C_CD);
4329 else if (strcmp(nm, "sinh") == 0)
4330 ilm = intrin_name("SINH", ast, in_r_D_C_CD);
4331 else if (strcmp(nm, "tanh") == 0)
4332 ilm = intrin_name("TANH", ast, in_r_D_C_CD);
4333 else if (strcmp(nm, "tan") == 0)
4334 ilm = intrin_name("TAN", ast, in_r_D_C_CD);
4335 else {
4336 ast_error("unrecognized NEW INTRINSIC", ast);
4337 break;
4338 }
4339 A_ILMP(ast, ilm);
4340 break;
4341
4342 /*------------------*/
4343
4344 case I_DATE:
4345 case I_EXIT:
4346 case I_IDATE:
4347 case I_TIME:
4348 case I_MVBITS:
4349
4350 case I_SECNDS:
4351 case I_DATE_AND_TIME:
4352 case I_RANDOM_NUMBER:
4353 case I_RANDOM_SEED:
4354 case I_CPU_TIME:
4355 case I_SYSTEM_CLOCK:
4356 case I_KIND:
4357 case I_SELECTED_INT_KIND:
4358 case I_SELECTED_REAL_KIND:
4359 case I_EPSILON:
4360 case I_HUGE:
4361 case I_TINY:
4362 case I_NULLIFY:
4363 case I_RANF:
4364 case I_RANGET:
4365 case I_RANSET:
4366 case I_INT_MULT_UPPER:
4367
4368 case I_ALL:
4369 case I_ANY:
4370 case I_COUNT:
4371 case I_DOT_PRODUCT:
4372 case I_MATMUL:
4373 case I_MATMUL_TRANSPOSE:
4374 case I_FINDLOC:
4375 case I_MAXLOC:
4376 case I_MAXVAL:
4377 case I_MINLOC:
4378 case I_MINVAL:
4379 case I_PACK:
4380 case I_PRODUCT:
4381 case I_SUM:
4382 case I_SPREAD:
4383 case I_TRANSPOSE:
4384 case I_UNPACK:
4385 case I_CSHIFT:
4386 case I_EOSHIFT:
4387 case I_RESHAPE:
4388 case I_SHAPE:
4389 case I_BIT_SIZE:
4390 case I_DIGITS:
4391 case I_MAXEXPONENT:
4392 case I_MINEXPONENT:
4393 case I_PRECISION:
4394 case I_RADIX:
4395 case I_RANGE:
4396 case I_REPEAT:
4397 case I_TRANSFER:
4398 case I_DOTPRODUCT:
4399 case I_PROCESSORS_SHAPE:
4400 case I_LASTVAL:
4401 case I_REDUCE_SUM:
4402 case I_REDUCE_PRODUCT:
4403 case I_REDUCE_ANY:
4404 case I_REDUCE_ALL:
4405 case I_REDUCE_PARITY:
4406 case I_REDUCE_IANY:
4407 case I_REDUCE_IALL:
4408 case I_REDUCE_IPARITY:
4409 case I_REDUCE_MINVAL:
4410 case I_REDUCE_MAXVAL:
4411 case I_PTR2_ASSIGN:
4412 case I_PTR_COPYIN:
4413 case I_PTR_COPYOUT:
4414 case I_UNIT:
4415 case I_LENGTH:
4416 case I_COT:
4417 case I_DCOT:
4418 case I_SHIFTL:
4419 case I_SHIFTR:
4420 case I_DSHIFTL:
4421 case I_DSHIFTR:
4422 case I_C_F_POINTER:
4423 case I_C_F_PROCPOINTER:
4424
4425 default:
4426 ast_error("unknown intrinsic function", ast);
4427 return 0;
4428 }
4429
4430 if (!argsdone) {
4431 if (pairwise && nargs > 2) {
4432 plower("ii", intrinsic_args[0], intrinsic_args[1]);
4433 for (i = 2; i < nargs; ++i) {
4434 ilm = plower("Oii", ilm, intrinsic_args[i]);
4435 }
4436 } else {
4437 for (i = 0; i < nargs; ++i) {
4438 plower("im", intrinsic_args[i]);
4439 }
4440 plower("e");
4441 }
4442 }
4443
4444 /* convert output type? */
4445 switch (intr) {
4446 /* max/min family */
4447 case I_MAX:
4448 case I_MIN:
4449 case I_MAX0: /* i*4,i*4 -> i*4 */
4450 case I_MIN0:
4451 case I_IMAX0: /* i*2,i*2 -> i*2 */
4452 case I_IMIN0:
4453 case I_JMAX0: /* i*4,i*4 -> i*4 */
4454 case I_JMIN0:
4455 case I_AMAX0:
4456 case I_AMIN0:
4457 case I_AIMAX0:
4458 case I_AIMIN0:
4459 case I_AJMAX0:
4460 case I_AJMIN0:
4461 case I_MAX1:
4462 case I_KMAX1:
4463 case I_MIN1:
4464 case I_KMIN1:
4465 case I_AMAX1: /* r*4,r*4 -> r*4 */
4466 case I_AMIN1:
4467 case I_DMAX1:
4468 case I_DMIN1:
4469 case I_IMAX1:
4470 case I_IMIN1:
4471 case I_JMAX1:
4472 case I_JMIN1:
4473 ilm = lower_conv_ilm(ast, ilm, argdtype, A_NDTYPEG(ast));
4474 break;
4475 case I_ANINT:
4476 case I_DNINT:
4477 dtype = DDTG(A_NDTYPEG(ast));
4478 if (dtype != DDTG(argdtype)) {
4479 ilm2 = plower("oS", "ICON", lower_getintcon(ty_to_lib[DTYG(argdtype)]));
4480 symfunc = lower_makefunc(mk_coercion_func_name(DTYG(dtype)), dtype, TRUE);
4481 ilm = plower("onsiiC", ltyped("FUNC", dtype), 2, symfunc, ilm, ilm2,
4482 symfunc);
4483 A_ILMP(ast, ilm);
4484 }
4485 break;
4486 case I_INDEX:
4487 case I_KINDEX:
4488 ilm = lower_conv_ilm(ast, ilm, fromdtype, A_NDTYPEG(ast));
4489 default:
4490 break;
4491 }
4492 lower_disable_ptr_chk = save_disable_ptr_chk;
4493
4494 return ilm;
4495 } /* lower_intrinsic */
4496
4497 #if AST_MAX != 165
4498 #error "Need to edit lowerexp.c to add or delete A_... AST types"
4499 #endif
4500
4501 static int _xtoi(int, int, char *);
4502
4503 static void
lower_ast(int ast,int * unused)4504 lower_ast(int ast, int *unused)
4505 {
4506 int dtype, rdtype, lop, rop, lilm, rilm, ilm = 0, base = 0;
4507 int ss, ndim, i, sptr, checksubscr, pointersubscr;
4508 int subscriptilm[10], subscriptilmx[10], lowerboundilm[10], upperboundilm[10];
4509 LOGICAL norm;
4510
4511 dtype = A_DTYPEG(ast);
4512 A_NDTYPEP(ast, dtype);
4513 switch (A_TYPEG(ast)) {
4514 case A_NULL:
4515 break;
4516 case A_BINOP:
4517 switch (A_OPTYPEG(ast)) {
4518 case OP_ADD:
4519 ilm = lower_bin_arith(ast, "ADD", dtype, dtype);
4520 break;
4521 case OP_CMP:
4522 ilm = lower_bin_arith(ast, "CMP", dtype, dtype);
4523 break;
4524 case OP_DIV:
4525 ilm = lower_bin_arith(ast, "DIV", dtype, dtype);
4526 break;
4527 case OP_LAND:
4528 case OP_SCAND:
4529 if (XBIT(125, 0x8))
4530 ilm = lower_bin_logical(ast, "UXLAND");
4531 else
4532 ilm = lower_bin_logical(ast, "LAND");
4533 break;
4534 case OP_LEQV:
4535 if (XBIT(125, 0x8))
4536 ilm = lower_bin_logical(ast, "UXLEQV");
4537 else
4538 ilm = lower_bin_logical(ast, "LEQV");
4539 break;
4540 case OP_LNEQV:
4541 if (XBIT(125, 0x8))
4542 ilm = lower_bin_logical(ast, "UXLNEQV");
4543 else
4544 ilm = lower_bin_logical(ast, "XOR");
4545 break;
4546 case OP_LOR:
4547 ilm = lower_bin_logical(ast, "LOR");
4548 break;
4549 case OP_MUL:
4550 ilm = lower_bin_arith(ast, "MUL", dtype, dtype);
4551 break;
4552 case OP_SUB:
4553 ilm = lower_bin_arith(ast, "SUB", dtype, dtype);
4554 break;
4555 case OP_XTOI:
4556 case OP_XTOX:
4557 rop = A_ROPG(ast);
4558 rdtype = A_NDTYPEG(rop);
4559 if (rdtype <= 0) {
4560 ast_error("unknown type in exponential power", ast);
4561 break;
4562 }
4563 switch (DTYG(rdtype)) {
4564 case TY_BINT:
4565 case TY_SINT:
4566 case TY_INT:
4567 #define __MAXPOW 10
4568 if (A_ALIASG(rop)) {
4569 int csym, cval;
4570 rop = A_ALIASG(rop);
4571 csym = A_SPTRG(rop);
4572 cval = CONVAL2G(csym);
4573 if ((flg.ieee && cval != 1 && cval != 2) ||
4574 XBIT(124, 0x200) || cval < 1 || cval > __MAXPOW) {
4575 /* don't replace ** with a sequence of multiplies */
4576 ilm = lower_bin_arith(ast, "TOI", dtype, DT_INT4);
4577 } else {
4578 ilm = lower_ilm(A_LOPG(ast));
4579 ilm = _xtoi(ilm, cval, ltyped("MUL", dtype));
4580 }
4581 } else {
4582 ilm = lower_bin_arith(ast, "TOI", dtype, DT_INT4);
4583 }
4584 break;
4585 case TY_INT8:
4586 if (A_ALIASG(rop)) {
4587 int csym, cval;
4588 rop = A_ALIASG(rop);
4589 csym = A_SPTRG(rop);
4590 cval = CONVAL2G(csym);
4591 if ((flg.ieee && cval != 1 && cval != 2) || CONVAL1G(csym) ||
4592 XBIT(124, 0x200) || cval < 1 || cval > __MAXPOW) {
4593 /* don't replace ** with a sequence of multiplies */
4594 ilm = lower_bin_arith(ast, "TOK", dtype, DT_INT8);
4595 } else {
4596 ilm = lower_ilm(A_LOPG(ast));
4597 ilm = _xtoi(ilm, cval, ltyped("MUL", dtype));
4598 }
4599 } else
4600 ilm = lower_bin_arith(ast, "TOK", dtype, DT_INT8);
4601 break;
4602 case TY_CMPLX:
4603 ilm = lower_bin_arith(ast, "TOC", dtype, dtype);
4604 break;
4605 case TY_DCMPLX:
4606 ilm = lower_bin_arith(ast, "TOCD", dtype, dtype);
4607 break;
4608 case TY_REAL:
4609 ilm = lower_bin_arith(ast, "TOR", dtype, dtype);
4610 break;
4611 case TY_DBLE:
4612 ilm = lower_bin_arith(ast, "TOD", dtype, dtype);
4613 break;
4614 default:
4615 ast_error("unexpected exponent type", ast);
4616 break;
4617 }
4618 break;
4619 case OP_EQ:
4620 ilm = lower_bin_comparison(ast, "EQ");
4621 break;
4622 case OP_GE:
4623 ilm = lower_bin_comparison(ast, "GE");
4624 break;
4625 case OP_GT:
4626 ilm = lower_bin_comparison(ast, "GT");
4627 break;
4628 case OP_LE:
4629 ilm = lower_bin_comparison(ast, "LE");
4630 break;
4631 case OP_LT:
4632 ilm = lower_bin_comparison(ast, "LT");
4633 break;
4634 case OP_NE:
4635 ilm = lower_bin_comparison(ast, "NE");
4636 break;
4637 case OP_CAT:
4638 lilm = lower_base(A_LOPG(ast));
4639 rilm = lower_base(A_ROPG(ast));
4640 if (DTY(A_NDTYPEG(ast)) == TY_NCHAR) {
4641 ilm = plower("oii", "NSCAT", lilm, rilm);
4642 } else {
4643 ilm = plower("oii", "SCAT", lilm, rilm);
4644 }
4645 break;
4646 case OP_AIF:
4647 case OP_CON:
4648 case OP_FUNC:
4649 case OP_LD:
4650 case OP_LOG:
4651 case OP_ST:
4652 default:
4653 ast_error("don't know how to handle type binary operator", ast);
4654 break;
4655 }
4656 base = ilm;
4657 break;
4658
4659 case A_CMPLXC:
4660 switch (DTYG(dtype)) {
4661 case TY_CMPLX:
4662 lilm = lower_conv(A_LOPG(ast), DT_REAL4);
4663 rilm = lower_conv(A_ROPG(ast), DT_REAL4);
4664 ilm = plower("oii", "CMPLX", lilm, rilm);
4665 case TY_DCMPLX:
4666 lilm = lower_conv(A_LOPG(ast), DT_REAL8);
4667 rilm = lower_conv(A_ROPG(ast), DT_REAL8);
4668 ilm = plower("oii", "DCMPLX", lilm, rilm);
4669 break;
4670 default:
4671 ast_error("unknown operand type for (real,imag)", ast);
4672 break;
4673 }
4674 base = ilm;
4675 break;
4676
4677 case A_CNST:
4678 if (dtype <= 0) {
4679 ast_error("unrecognized data type", ast);
4680 break;
4681 }
4682 sptr = A_SPTRG(ast);
4683 lower_visit_symbol(sptr);
4684 switch (DTYG(dtype)) {
4685 case TY_BINT:
4686 case TY_SINT:
4687 case TY_INT:
4688 ilm = plower("oS", "ICON", sptr);
4689 base = ilm;
4690 break;
4691 case TY_INT8:
4692 ilm = plower("oS", "KCON", sptr);
4693 base = ilm;
4694 break;
4695 case TY_LOG8:
4696 sptr = cngcon(sptr, DTYG(dtype), DT_INT8);
4697 ilm = plower("oS", "KCON", sptr);
4698 base = ilm;
4699 break;
4700 case TY_REAL:
4701 ilm = plower("oS", "RCON", sptr);
4702 base = ilm;
4703 break;
4704 case TY_DBLE:
4705 ilm = plower("oS", "DCON", sptr);
4706 base = ilm;
4707 break;
4708 case TY_CMPLX:
4709 ilm = plower("oS", "CCON", sptr);
4710 base = ilm;
4711 break;
4712 case TY_DCMPLX:
4713 ilm = plower("oS", "CDCON", sptr);
4714 base = ilm;
4715 break;
4716 case TY_BLOG:
4717 case TY_SLOG:
4718 case TY_LOG:
4719 sptr = lower_getintcon(cngcon(CONVAL2G(sptr), DTYG(dtype), DT_LOG4));
4720 ilm = plower("oS", "LCON", sptr);
4721 base = ilm;
4722 break;
4723 case TY_CHAR:
4724 case TY_NCHAR:
4725 ilm = plower("os", "BASE", sptr);
4726 base = ilm;
4727 break;
4728 case TY_HOLL:
4729 ilm = plower("os", "BASE", sptr);
4730 break;
4731 case TY_WORD:
4732 sptr = lower_getintcon(cngcon(CONVAL2G(sptr), DTYG(dtype), DT_INT4));
4733 ilm = plower("oS", "ICON", sptr);
4734 base = ilm;
4735 break;
4736 case TY_DWORD:
4737 sptr = cngcon(sptr, DTYG(dtype), DT_INT8);
4738 ilm = plower("oS", "KCON", sptr);
4739 base = ilm;
4740 break;
4741 default:
4742 ast_error("unrecognized constant type", ast);
4743 break;
4744 }
4745 break;
4746
4747 case A_CONV:
4748 /* see if no conversion is required */
4749 lop = A_LOPG(ast);
4750 if (eq_dtype(dtype, A_NDTYPEG(lop))) {
4751 /* no conversion, copy the ALIAS field, so
4752 * spurious converted constants appear constant */
4753 A_ALIASP(ast, A_ALIASG(lop));
4754 ilm = A_ILMG(lop);
4755 base = A_BASEG(lop);
4756 } else {
4757 int alias;
4758 alias = A_ALIASG(ast);
4759 if (alias && alias != ast && eq_dtype(dtype, A_DTYPEG(alias))) {
4760 /* put out the constant */
4761 lower_ast(alias, unused);
4762 ilm = A_ILMG(alias);
4763 base = A_BASEG(alias);
4764 } else {
4765 switch (DTYG(dtype)) {
4766 case TY_BINT:
4767 ilm = conv_bint(lop);
4768 break;
4769 case TY_SINT:
4770 ilm = conv_sint(lop);
4771 break;
4772 case TY_INT:
4773 ilm = conv_int(lop);
4774 break;
4775 case TY_PTR:
4776 if (XBIT(49, 0x100)) { /* 64-bit pointers */
4777 ilm = conv_int8(lop);
4778 } else {
4779 ilm = conv_int(lop);
4780 }
4781 break;
4782 case TY_INT8:
4783 ilm = conv_int8(lop);
4784 break;
4785 case TY_WORD:
4786 ilm = conv_word(lop);
4787 break;
4788 case TY_DWORD:
4789 ilm = conv_dword(lop);
4790 break;
4791 case TY_BLOG:
4792 ilm = conv_blog(lop);
4793 break;
4794 case TY_SLOG:
4795 ilm = conv_slog(lop);
4796 break;
4797 case TY_LOG:
4798 ilm = conv_log(lop);
4799 break;
4800 case TY_LOG8:
4801 ilm = conv_log8(lop);
4802 break;
4803 case TY_REAL:
4804 ilm = conv_real(lop);
4805 break;
4806 case TY_DBLE:
4807 ilm = conv_dble(lop);
4808 break;
4809 case TY_CMPLX:
4810 ilm = conv_cmplx(lop);
4811 break;
4812 case TY_DCMPLX:
4813 ilm = conv_dcmplx(lop);
4814 break;
4815 case TY_CHAR:
4816 case TY_NCHAR:
4817 ilm = lower_ilm(lop);
4818 break;
4819 default:
4820 ast_error("unknown target type for conversion", ast);
4821 lerror("target type was %d", dtype);
4822 break;
4823 }
4824 base = ilm;
4825 }
4826 }
4827 break;
4828
4829 case A_FUNC:
4830 /* function call */
4831 if (is_iso_cptr(A_DTYPEG(A_LOPG(ast))) && CFUNCG(A_SPTRG(A_LOPG(ast)))) {
4832 /* functions with BIND(c) and returning iso_cptrs should be treated as
4833 functions returning integers (pointers), for pass
4834 by value and all processing
4835 */
4836 A_NDTYPEP(A_LOPG(ast), DT_PTR);
4837 }
4838 ilm = lower_function(ast);
4839 base = ilm;
4840 break;
4841
4842 case A_ID:
4843 sptr = A_SPTRG(ast);
4844 dtype = DTYPEG(sptr);
4845 A_NDTYPEP(ast, dtype);
4846 break;
4847
4848 case A_INTR:
4849 ilm = lower_intrinsic(ast);
4850 base = ilm;
4851 break;
4852
4853 case A_INIT:
4854 ast_error("unexpected AST type", ast);
4855 break;
4856
4857 case A_LABEL:
4858 sptr = A_SPTRG(ast);
4859 if (FMTPTG(sptr)) {
4860 /* FORMAT label */
4861 if (lowersym.loc == 0) {
4862 lowersym.loc = lower_makefunc(mkRteRtnNm(RTE_loc), DT_PTR, FALSE);
4863 }
4864 ilm = plower("oS", "BASE", FMTPTG(sptr));
4865 if (XBIT(49, 0x100)) {
4866 ilm = plower("onsiC", "KFUNC", 1, lowersym.loc, ilm, lowersym.loc);
4867 } else {
4868 ilm = plower("onsiC", "IFUNC", 1, lowersym.loc, ilm, lowersym.loc);
4869 }
4870 } else {
4871 /* GOTO label */
4872 lower_visit_symbol(sptr);
4873 ilm = plower("oS", "ACON", sptr);
4874 }
4875 base = ilm;
4876 break;
4877
4878 case A_MEM: /* member */
4879 dtype = DTYPEG(A_SPTRG(A_MEMG(ast)));
4880
4881 if (DTY(dtype) == TY_PTR && DTY(DTY(dtype + 1)) != TY_PROC)
4882 dtype = DTY(dtype + 1);
4883 A_NDTYPEP(ast, dtype);
4884 break;
4885
4886 case A_PAREN:
4887 ilm = lower_ilm(A_LOPG(ast));
4888 base = ilm;
4889 break;
4890
4891 case A_SUBSCR:
4892 base = lower_base(A_LOPG(ast));
4893 sptr = 0;
4894 lop = A_LOPG(ast);
4895 if (A_TYPEG(lop) == A_ID) {
4896 sptr = A_SPTRG(lop);
4897 } else if (A_TYPEG(lop) == A_MEM) {
4898 sptr = A_SPTRG(A_MEMG(lop));
4899 }
4900 ss = A_ASDG(ast);
4901 ndim = ASD_NDIM(ss);
4902 for (i = 0; i < ndim; ++i) {
4903 lower_expression(ASD_SUBS(ss, i));
4904 subscriptilm[i] = lower_ilm(ASD_SUBS(ss, i));
4905 if (XBIT(68, 0x1)) {
4906 if (A_DTYPEG(ASD_SUBS(ss, i)) != DT_INT8)
4907 subscriptilm[i] = plower("oi", "ITOI8", subscriptilm[i]);
4908 subscriptilmx[i] = subscriptilm[i];
4909 } else {
4910 if (A_DTYPEG(ASD_SUBS(ss, i)) == DT_INT8)
4911 subscriptilmx[i] = plower("oi", "I8TOI", subscriptilm[i]);
4912 else
4913 subscriptilmx[i] = subscriptilm[i];
4914 }
4915 }
4916 norm = FALSE;
4917 if (XBIT(58, 0x22)) {
4918 norm = normalize_bounds(sptr);
4919 }
4920 checksubscr = 0;
4921 if (XBIT(70, 2) && !DESCARRAYG(sptr)) {
4922 /* -Mbounds set, no descriptor array */
4923 checksubscr = !lower_disable_subscr_chk;
4924 #ifdef CUDAG
4925 if (CUDAG(GBL_CURRFUNC) & (CUDA_DEVICE | CUDA_GLOBAL)) {
4926 checksubscr = 0;
4927 }
4928 #endif
4929 pointersubscr = 0;
4930 if (POINTERG(sptr))
4931 pointersubscr = 1;
4932 }
4933 /* need to linearize subscripts for HPF */
4934 if (sptr && !HCCSYMG(sptr) && LNRZDG(sptr) && XBIT(52, 4)) {
4935 int descilm, idxilm, linilm, desc;
4936 int dtype;
4937 desc = SDSCG(sptr);
4938 if (desc == 0 || NODESCG(sptr) || !DESCUSEDG(sptr) ||
4939 STYPEG(desc) == ST_PARAM) {
4940 /* linearized, -x 52 4, no descriptor.
4941 * actual bounds in datatype, don't need to normalize bounds */
4942 dtype = DTYPEG(sptr);
4943 /* dtype here is the linearized dtype.
4944 * get the old datatype */
4945 dtype = DTY(dtype - 1);
4946 if (dtype > 0) {
4947 lerror("unknown linearized datatype");
4948 return;
4949 }
4950 dtype = -dtype;
4951 linilm = 0;
4952 /* for reference A(i,j,k), dims A(i0:i1,j0:j1,k0:k1) */
4953 /* compute '((k-k0)*(j1-j0+1) + j-j0)*(i1-i0+1) + i-i0 + 1 */
4954 for (i = ndim - 1; i >= 0; --i) {
4955 int lw, up;
4956 int ssilm, lwilm, upilm, strideilm, oneilm;
4957 ssilm = subscriptilm[i];
4958 lw = ADD_LWBD(dtype, i);
4959 if (lw == 0)
4960 lw = astb.bnd.one;
4961 if ((lw == astb.bnd.one && i == 0) ||
4962 (lw == astb.bnd.zero && !checksubscr)) {
4963 lwilm = 0;
4964 } else {
4965 lw = check_member(ast, lw);
4966 lower_expression(lw);
4967 lwilm = lower_ilm(lw);
4968 }
4969 lowerboundilm[i] = lwilm;
4970 if (linilm == 0) {
4971 /* for rightmost dimension, get 'lin = k' */
4972 linilm = ssilm;
4973 if (checksubscr) {
4974 /* need upperboundilm for checks */
4975 up = ADD_UPAST(dtype, i);
4976 if (up == 0) {
4977 upilm = 0;
4978 } else {
4979 up = check_member(ast, up);
4980 lower_expression(up);
4981 upilm = lower_ilm(up);
4982 }
4983 upperboundilm[i] = upilm;
4984 }
4985 } else {
4986 /* compute '(UP-LO+1)*lin + j' */
4987 up = ADD_UPAST(dtype, i);
4988 if (up == 0)
4989 up = astb.bnd.one;
4990 up = check_member(ast, up);
4991 lower_expression(up);
4992 upilm = lower_ilm(up);
4993 upperboundilm[i] = upilm;
4994 if (lw == astb.bnd.one) {
4995 strideilm = upilm;
4996 } else {
4997 if (lw == astb.bnd.zero) {
4998 strideilm = upilm;
4999 } else {
5000 strideilm = plower("oii", lowersym.bnd.sub, upilm, lwilm);
5001 }
5002 oneilm = plower("oS", lowersym.bnd.con, lowersym.bnd.one);
5003 strideilm = plower("oii", lowersym.bnd.add, strideilm, oneilm);
5004 }
5005 linilm = plower("oii", lowersym.bnd.mul, linilm, strideilm);
5006 linilm = plower("oii", lowersym.bnd.add, linilm, ssilm);
5007 }
5008 /* compute 'lin-j0' */
5009 if (lw != astb.bnd.one || i > 0) {
5010 if (lw != astb.bnd.zero) {
5011 linilm = plower("oii", lowersym.bnd.sub, linilm, lwilm);
5012 }
5013 if (i == 0) {
5014 oneilm = plower("oS", lowersym.bnd.con, lowersym.bnd.one);
5015 linilm = plower("oii", lowersym.bnd.add, linilm, oneilm);
5016 }
5017 }
5018 }
5019 } else {
5020 int descdtype, descddty;
5021 /* linearized, -x 52 4, do have a descriptor.
5022 * array bounds and offset may be normalized.
5023 * multipliers are ok */
5024 dtype = DTYPEG(sptr);
5025 dtype = DTY(dtype - 1);
5026 if (dtype > 0) {
5027 lerror("unknown linearized datatype");
5028 return;
5029 }
5030 dtype = -dtype;
5031 descilm = lower_replacement(lop, desc);
5032 idxilm =
5033 plower("oS", lowersym.bnd.con, lower_getiszcon(get_xbase_index()));
5034 descdtype = DTYPEG(desc);
5035 descddty = DDTG(descdtype);
5036 linilm = plower("onidi", "ELEMENT", 1, descilm, descdtype, idxilm);
5037 linilm = lower_typeload(descddty, linilm);
5038 for (i = 0; i < ndim; ++i) {
5039 int silm;
5040 /* (subscript_i)*multiplier_i */
5041 /* lower_i and multiplier_i are in the descriptor */
5042 silm = subscriptilm[i];
5043 if (norm) {
5044 int lw, lwilm, oneilm;
5045 /* 2:10 is now 1:9, add original lower bound */
5046 lw = ADD_LWBD(dtype, i);
5047 if (lw != 0 && lw != astb.i1) {
5048 if (lw != astb.bnd.zero) {
5049 lw = check_member(ast, lw);
5050 lower_expression(lw);
5051 lwilm = lower_ilm(lw);
5052 silm = plower("oii", lowersym.bnd.sub, silm, lwilm);
5053 }
5054 oneilm = plower("oS", lowersym.bnd.con, lowersym.bnd.one);
5055 silm = plower("oii", lowersym.bnd.add, silm, oneilm);
5056 }
5057 }
5058 if (i == 0 && !POINTERG(sptr)) {
5059 /* subscript '0' needs no multiplier */
5060 rilm = silm;
5061 if (checksubscr) {
5062 /* needed for bounds checking */
5063 descilm = lower_replacement(lop, desc);
5064 }
5065 } else {
5066 descilm = lower_replacement(lop, desc);
5067 idxilm = plower("oS", lowersym.bnd.con,
5068 lower_getiszcon(get_multiplier_index(i)));
5069 rilm = plower("onidi", "ELEMENT", 1, descilm, descdtype, idxilm);
5070 rilm = lower_typeload(descddty, rilm);
5071 rilm = plower("oii", lowersym.bnd.mul, silm, rilm);
5072 }
5073 linilm = plower("oii", lowersym.bnd.add, linilm, rilm);
5074 if (checksubscr) {
5075 int lw, lwilm, oneilm;
5076 lwilm = 0;
5077 if (norm) {
5078 /* 2:10 is now 1:9, add original lower bound */
5079 lw = ADD_LWBD(dtype, i);
5080 if (lw != 0 && lw != astb.i1) {
5081 lw = check_member(ast, lw);
5082 lower_expression(lw);
5083 lwilm = lower_ilm(lw);
5084 oneilm = plower("oS", lowersym.bnd.con, lowersym.bnd.one);
5085 lwilm = plower("oii", lowersym.bnd.sub, lwilm, oneilm);
5086 }
5087 }
5088 idxilm = plower("oS", lowersym.bnd.con,
5089 lower_getiszcon(get_global_lower_index(i)));
5090 descdtype = DTYPEG(desc);
5091 rilm = plower("onidi", "ELEMENT", 1, descilm, descdtype, idxilm);
5092 rilm = lower_typeload(descddty, rilm);
5093 if (lwilm) {
5094 rilm = plower("oii", lowersym.bnd.add, rilm, lwilm);
5095 }
5096 lowerboundilm[i] = rilm;
5097 idxilm = plower("oS", lowersym.bnd.con,
5098 lower_getiszcon(get_global_extent_index(i)));
5099 rilm = plower("onidi", "ELEMENT", 1, descilm, descdtype, idxilm);
5100 rilm = lower_typeload(descddty, rilm);
5101 if (lwilm) {
5102 rilm = plower("oii", lowersym.bnd.add, rilm, lwilm);
5103 }
5104 idxilm = plower("oS", lowersym.bnd.con, lower_getiszcon(1));
5105 rilm = plower("oii", lowersym.bnd.sub, rilm, idxilm);
5106 rilm = plower("oii", lowersym.bnd.add, rilm, lowerboundilm[i]);
5107 upperboundilm[i] = rilm;
5108 if (pointersubscr && !XBIT(58, 0x8000000)) {
5109 /* undo effects of 'cyclic_section' in commgen.
5110 * subtract section offset,
5111 * divide by section stride */
5112 int strilm, offilm;
5113 strilm = plower("oS", lowersym.bnd.con,
5114 lower_getiszcon(get_section_stride_index(i)));
5115 strilm =
5116 plower("onidi", "ELEMENT", 1, descilm, descdtype, strilm);
5117 strilm = lower_typeload(descddty, strilm);
5118 strilm = plower("oii", lowersym.bnd.div, subscriptilm[i], strilm);
5119 offilm = plower("oS", lowersym.bnd.con,
5120 lower_getiszcon(get_section_offset_index(i)));
5121 offilm =
5122 plower("onidi", "ELEMENT", 1, descilm, descdtype, offilm);
5123 offilm = lower_typeload(descddty, offilm);
5124 offilm = plower("oii", lowersym.bnd.sub, strilm, offilm);
5125 subscriptilmx[i] = offilm;
5126 }
5127 }
5128 }
5129 }
5130 if (checksubscr) {
5131 lower_check_subscript(0, ast, ndim, subscriptilmx, lowerboundilm,
5132 upperboundilm);
5133 }
5134 ndim = 1;
5135 subscriptilm[0] = linilm;
5136 } else {
5137 int desc;
5138 int arrparam; /* array parameter */
5139 int checkit;
5140 arrparam = 0;
5141 checkit = 0;
5142 desc = SDSCG(sptr);
5143 if (sptr && checksubscr) {
5144 if (!HCCSYMG(sptr))
5145 checkit = 1;
5146 else if (PARAMG(sptr)) {
5147 arrparam = A_SPTRG(PARAMVALG(sptr));
5148 if (arrparam)
5149 checkit = 1;
5150 }
5151 }
5152 #ifdef CUDAG
5153 if (CUDAG(GBL_CURRFUNC) & (CUDA_DEVICE | CUDA_GLOBAL)) {
5154 checkit = 0;
5155 }
5156 #endif
5157 if (checkit) {
5158 /* fill in the bounds for checking */
5159 if (desc == 0 || NODESCG(sptr) || !DESCUSEDG(sptr) || ASUMSZG(sptr) ||
5160 STYPEG(desc) == ST_PARAM || ASSUMSHPG(sptr)) {
5161 int dtype;
5162 dtype = DTYPEG(sptr);
5163 for (i = ndim - 1; i >= 0; --i) {
5164 int lw, up, lwilm, upilm;
5165 lw = ADD_LWAST(dtype, i);
5166 if (lw == 0)
5167 lw = astb.bnd.one;
5168 if (lw == astb.bnd.one) {
5169 lwilm = 0;
5170 } else {
5171 lw = check_member(ast, lw);
5172 lower_expression(lw);
5173 lwilm = lower_ilm(lw);
5174 }
5175 lowerboundilm[i] = lwilm;
5176 /* need upperboundilm for checks */
5177 up = ADD_UPAST(dtype, i);
5178 if (up == 0) {
5179 upilm = 0;
5180 } else {
5181 up = check_member(ast, up);
5182 lower_expression(up);
5183 upilm = lower_ilm(up);
5184 }
5185 upperboundilm[i] = upilm;
5186 }
5187 } else {
5188 int descilm, idxilm, dtype, rilm, descdtype, descddty;
5189 /* array bounds in descriptor may be normalized */
5190 dtype = DTYPEG(sptr);
5191 descilm = lower_replacement(lop, desc);
5192 for (i = 0; i < ndim; ++i) {
5193 int lw, lwilm, oneilm;
5194 lwilm = 0;
5195 if (norm) {
5196 /* 2:10 is now 1:9, add original lower bound */
5197 lw = ADD_LWBD(dtype, i);
5198 if (lw != 0 && lw != astb.i1) {
5199 lw = check_member(ast, lw);
5200 lower_expression(lw);
5201 lwilm = lower_ilm(lw);
5202 oneilm = plower("oS", lowersym.bnd.con, lowersym.bnd.one);
5203 lwilm = plower("oii", lowersym.bnd.sub, lwilm, oneilm);
5204 }
5205 }
5206 idxilm = plower("oS", lowersym.bnd.con,
5207 lower_getiszcon(get_global_lower_index(i)));
5208 descdtype = DTYPEG(desc);
5209 descddty = DDTG(descdtype);
5210 rilm = plower("onidi", "ELEMENT", 1, descilm, descdtype, idxilm);
5211 rilm = lower_typeload(descddty, rilm);
5212 if (lwilm) {
5213 rilm = plower("oii", lowersym.bnd.add, rilm, lwilm);
5214 }
5215 lowerboundilm[i] = rilm;
5216 idxilm = plower("oS", lowersym.bnd.con,
5217 lower_getiszcon(get_global_extent_index(i)));
5218 rilm = plower("onidi", "ELEMENT", 1, descilm, descdtype, idxilm);
5219 rilm = lower_typeload(descddty, rilm);
5220 if (lwilm) {
5221 rilm = plower("oii", lowersym.bnd.add, rilm, lwilm);
5222 }
5223 idxilm = plower("oS", lowersym.bnd.con, lower_getiszcon(1));
5224 rilm = plower("oii", lowersym.bnd.sub, rilm, idxilm);
5225 rilm = plower("oii", lowersym.bnd.add, rilm, lowerboundilm[i]);
5226 upperboundilm[i] = rilm;
5227 if (pointersubscr && !XBIT(58, 0x8000000)) {
5228 /* undo effects of 'cyclic_section' in commgen.
5229 * subtract section offset,
5230 * divide by section stride */
5231 int strilm, offilm;
5232 strilm = plower("oS", lowersym.bnd.con,
5233 lower_getiszcon(get_section_stride_index(i)));
5234 strilm =
5235 plower("onidi", "ELEMENT", 1, descilm, descdtype, strilm);
5236 strilm = lower_typeload(descddty, strilm);
5237 strilm = plower("oii", lowersym.bnd.div, subscriptilm[i], strilm);
5238 offilm = plower("oS", lowersym.bnd.con,
5239 lower_getiszcon(get_section_offset_index(i)));
5240 offilm =
5241 plower("onidi", "ELEMENT", 1, descilm, descdtype, offilm);
5242 offilm = lower_typeload(descddty, offilm);
5243 offilm = plower("oii", lowersym.bnd.sub, strilm, offilm);
5244 subscriptilmx[i] = offilm;
5245 }
5246 }
5247 }
5248 lower_check_subscript(arrparam, ast, ndim, subscriptilmx, lowerboundilm,
5249 upperboundilm);
5250 }
5251 if (norm && desc != 0 && !NODESCG(sptr) && DESCUSEDG(sptr) &&
5252 STYPEG(desc) != ST_PARAM) {
5253 int dtype;
5254 /* subtract off original lower bound
5255 * 2:10 is now 1:9, subtract original lower bound */
5256 dtype = DTYPEG(sptr);
5257 for (i = 0; i < ndim; ++i) {
5258 int lw, lwilm, oneilm;
5259 lw = ADD_LWBD(dtype, i);
5260 rilm = subscriptilm[i];
5261 if (lw != 0 && lw != astb.i1) {
5262 if (lw != astb.bnd.zero) {
5263 lw = check_member(ast, lw);
5264 lower_expression(lw);
5265 lwilm = lower_ilm(lw);
5266 rilm = plower("oii", lowersym.bnd.sub, rilm, lwilm);
5267 }
5268 oneilm = plower("oS", lowersym.bnd.con, lowersym.bnd.one);
5269 rilm = plower("oii", lowersym.bnd.add, rilm, oneilm);
5270 }
5271 subscriptilm[i] = rilm;
5272 }
5273 }
5274 }
5275 base = plower("onidm", "ELEMENT", ndim, base, A_NDTYPEG(A_LOPG(ast)));
5276 for (i = 0; i < ndim; ++i) {
5277 plower("im", subscriptilm[i]);
5278 }
5279 plower("e");
5280 break;
5281
5282 case A_SUBSTR:
5283 ilm = lower_base(A_LOPG(ast));
5284 if (A_LEFTG(ast)) {
5285 lilm = lower_ilm(A_LEFTG(ast));
5286 } else {
5287 lilm = plower("oS", "ICON", lowersym.intone);
5288 }
5289 if (A_RIGHTG(ast)) {
5290 rilm = lower_ilm(A_RIGHTG(ast));
5291 } else {
5292 int len;
5293 int lop = A_LOPG(ast);
5294 len = DTY(A_NDTYPEG(lop) + 1); /* char string length */
5295 if (len && A_ALIASG(len)) {
5296 len = A_ALIASG(len);
5297 len = A_SPTRG(len);
5298 rilm = plower("oS", "ICON", len); /* ilm */
5299 } else {
5300 /* assumed length string, use 'len' function */
5301 rilm = plower("oi", "LEN", ilm);
5302 }
5303 }
5304 if (DTY(A_NDTYPEG(ast)) == TY_NCHAR) {
5305 ilm = plower("oiii", "NSUBS", ilm, lilm, rilm);
5306 } else {
5307 ilm = plower("oiii", "SUBS", ilm, lilm, rilm);
5308 }
5309 base = ilm;
5310 break;
5311
5312 case A_UNOP:
5313 switch (A_OPTYPEG(ast)) {
5314 case OP_NEG:
5315 case OP_SUB:
5316 ilm = lower_un_arith(ast, "NEG", dtype);
5317 base = ilm;
5318 break;
5319 case OP_LNOT:
5320 if (XBIT(125, 0x8))
5321 ilm = lower_un_logical(ast, "UXLNOT");
5322 else
5323 ilm = lower_un_logical(ast, "LNOT");
5324 base = ilm;
5325 break;
5326 case OP_ADD:
5327 ilm = lower_ilm(A_LOPG(ast));
5328 base = ilm;
5329 break;
5330 case OP_LOC: {
5331 /* use LOC operator */
5332 if (A_LOPG(ast) == astb.ptr0) {
5333 ilm = lower_null();
5334 } else if (A_LOPG(ast) == astb.ptr0c) {
5335 ilm = lower_null();
5336 } else {
5337 ilm = lower_base(A_LOPG(ast));
5338 ilm = plower("oi", "LOC", ilm);
5339 ilm = lower_conv_ilm(ast, ilm, DT_PTR, A_NDTYPEG(ast));
5340 }
5341 base = ilm;
5342 } break;
5343 case OP_VAL:
5344 if (ast == astb.ptr0) {
5345 ilm = base = lower_null_arg();
5346 } else if (ast == astb.ptr0c) {
5347 ilm = base = lower_nullc_arg();
5348 } else {
5349 ilm = lower_ilm(A_LOPG(ast));
5350 ilm = plower("oi", "DPVAL", ilm);
5351 base = ilm;
5352 }
5353 break;
5354 case OP_BYVAL:
5355 dtype = A_DTYPEG(A_LOPG(ast));
5356 ilm = lower_ilm(A_LOPG(ast));
5357 ilm = plower("oid", "BYVAL", ilm, dtype);
5358 base = ilm;
5359 break;
5360 case OP_REF:
5361 ilm = lower_ilm(A_LOPG(ast));
5362 ilm = plower("oi", "DPREF", ilm);
5363 base = ilm;
5364 break;
5365 default:
5366 ast_error("don't know how to handle type unary operator", ast);
5367 break;
5368 }
5369 break;
5370
5371 case A_COMMENT:
5372 case A_COMSTR:
5373 /* ignore comments */
5374 break;
5375 case A_MP_ATOMICREAD:
5376 ilm = lower_base(A_SRCG(ast));
5377 i = 0;
5378 ilm = plower("oin", "MP_ATOMICREAD", ilm, A_MEM_ORDERG(ast));
5379 base = ilm;
5380 break;
5381 /* ------------- unsupported AST types ------------- */
5382
5383 case A_ATOMIC:
5384 case A_ATOMICCAPTURE:
5385 case A_ATOMICREAD:
5386 case A_ATOMICWRITE:
5387 case A_BARRIER:
5388 case A_CRITICAL:
5389 case A_ELSEFORALL:
5390 case A_ELSEWHERE:
5391 case A_ENDATOMIC:
5392 case A_ENDCRITICAL:
5393 case A_ENDFORALL:
5394 case A_ENDMASTER:
5395 case A_ENDWHERE:
5396 case A_FORALL:
5397 case A_MASTER:
5398 case A_NOBARRIER:
5399 case A_TRIPLE:
5400 case A_WHERE:
5401 case A_MP_PARALLEL:
5402 case A_MP_ENDPARALLEL:
5403 case A_MP_CRITICAL:
5404 case A_MP_ENDCRITICAL:
5405 case A_MP_ATOMIC:
5406 case A_MP_ENDATOMIC:
5407 case A_MP_MASTER:
5408 case A_MP_ENDMASTER:
5409 case A_MP_SINGLE:
5410 case A_MP_ENDSINGLE:
5411 case A_MP_BARRIER:
5412 case A_MP_TASKWAIT:
5413 case A_MP_TASKYIELD:
5414 case A_MP_PDO:
5415 case A_MP_ENDPDO:
5416 case A_MP_SECTIONS:
5417 case A_MP_ENDSECTIONS:
5418 case A_MP_WORKSHARE:
5419 case A_MP_ENDWORKSHARE:
5420 case A_MP_BPDO:
5421 case A_MP_EPDO:
5422 case A_MP_SECTION:
5423 case A_MP_LSECTION:
5424 case A_MP_PRE_TLS_COPY:
5425 case A_MP_BCOPYIN:
5426 case A_MP_COPYIN:
5427 case A_MP_ECOPYIN:
5428 case A_MP_BCOPYPRIVATE:
5429 case A_MP_COPYPRIVATE:
5430 case A_MP_ECOPYPRIVATE:
5431 case A_MP_TASK:
5432 case A_MP_TASKLOOP:
5433 case A_MP_TASKFIRSTPRIV:
5434 case A_MP_TASKREG:
5435 case A_MP_TASKDUP:
5436 case A_MP_ETASKDUP:
5437 case A_MP_TASKLOOPREG:
5438 case A_MP_ETASKLOOPREG:
5439 case A_MP_ENDTASK:
5440 case A_MP_ETASKLOOP:
5441 case A_MP_BMPSCOPE:
5442 case A_MP_EMPSCOPE:
5443 case A_MP_BORDERED:
5444 case A_MP_EORDERED:
5445 case A_PREFETCH:
5446 case A_PRAGMA:
5447 case A_MP_TARGET:
5448 case A_MP_ENDTARGET:
5449 case A_MP_TEAMS:
5450 case A_MP_ENDTEAMS:
5451 case A_MP_DISTRIBUTE:
5452 case A_MP_ENDDISTRIBUTE:
5453 case A_MP_TARGETUPDATE:
5454 case A_MP_TARGETDATA:
5455 case A_MP_ENDTARGETDATA:
5456 case A_MP_TARGETENTERDATA:
5457 case A_MP_TARGETEXITDATA:
5458 case A_MP_CANCEL:
5459 case A_MP_CANCELLATIONPOINT:
5460 case A_MP_ATOMICWRITE:
5461 case A_MP_ATOMICUPDATE:
5462 case A_MP_ATOMICCAPTURE:
5463 default:
5464 ast_error("bad ast optype in expression", ast);
5465 break;
5466 }
5467 A_ILMP(ast, ilm);
5468 A_BASEP(ast, base);
5469 } /* lower_ast */
5470
5471 int
lower_null(void)5472 lower_null(void)
5473 {
5474 int ilm;
5475
5476 if (!XBIT(49, 0x20000000)) {
5477 ilm = plower("oS", "ACON", lowersym.ptrnull);
5478 } else if (XBIT(49, 0x100)) {
5479 ilm = plower("oS", "KCON", lowersym.intzero);
5480 } else {
5481 ilm = plower("oS", "ICON", lowersym.intzero);
5482 }
5483 return ilm;
5484 }
5485
5486 int
lower_null_arg(void)5487 lower_null_arg(void)
5488 {
5489 int ilm;
5490 ilm = lowersym_pghpf_cmem(&lowersym.ptr0);
5491 if (!XBIT(57, 0x8000))
5492 ilm = plower("oi", "DPVAL", ilm);
5493 return ilm;
5494 }
5495
5496 int
lower_nullc_arg(void)5497 lower_nullc_arg(void)
5498 {
5499 int ilm;
5500 ilm = lowersym_pghpf_cmem(&lowersym.ptr0c);
5501 if (!XBIT(57, 0x8000))
5502 ilm = plower("o", "DPNULL");
5503 return ilm;
5504 }
5505
5506 /*
5507 * raising an operand to a constant power >= 1. generate ILMs which
5508 * maximize cse's (i.e., generate a balanced tree).
5509 * opn - operand (ILM) raised to power 'pwr'
5510 * pwr - power (constant)
5511 * opc - mult ILM opcode
5512 */
5513 static int
_xtoi(int opn,int pwr,char * opc)5514 _xtoi(int opn, int pwr, char *opc)
5515 {
5516 int res;
5517 int p2; /* largest power of 2 such that 2**p2 <= opn**pwr */
5518 int n;
5519
5520 if (pwr >= 2) {
5521 p2 = 0;
5522 n = pwr;
5523 while ((n >>= 1) > 0)
5524 p2++;
5525
5526 n = 1 << p2; /* 2**p2 */
5527 res = opn;
5528 /* generate a balanced multiply tree whose height is p2 */
5529 while (p2-- > 0)
5530 res = plower("oii", opc, res, res);
5531
5532 /* residual */
5533 n = pwr - n;
5534 if (n > 0) {
5535 int right;
5536 right = _xtoi(opn, n, opc);
5537 res = plower("oii", opc, res, right);
5538 }
5539
5540 return res;
5541 }
5542 return opn;
5543 }
5544
5545 static int
lower_logical_expr(int ast)5546 lower_logical_expr(int ast)
5547 {
5548 int ilm;
5549 switch (A_NDTYPEG(ast)) {
5550 case TY_BINT:
5551 case TY_BLOG:
5552 case TY_SINT:
5553 case TY_SLOG:
5554 case TY_INT:
5555 case TY_LOG:
5556 case TY_INT8:
5557 case TY_LOG8:
5558 ilm = lower_ilm(ast);
5559 break;
5560 default:
5561 ilm = conv_int(ast);
5562 break;
5563 }
5564 return ilm;
5565 } /* lower_logical_expr */
5566
5567 void
lower_logical(int ast,iflabeltype * iflabp)5568 lower_logical(int ast, iflabeltype *iflabp)
5569 {
5570 int dtype, lop, rop, lilm, rilm, ilm = 0, ilm2;
5571 int ss, ndim, i, sptr;
5572 iflabeltype nlab;
5573
5574 dtype = A_DTYPEG(ast);
5575 A_NDTYPEP(ast, dtype);
5576
5577 switch (A_TYPEG(ast)) {
5578 case A_NULL:
5579 break;
5580 case A_BINOP:
5581 switch (A_OPTYPEG(ast)) {
5582 case OP_LAND:
5583 case OP_SCAND:
5584 if (iflabp->thenlabel == 0) {
5585 /* The incoming fall-through case is 'then'.
5586 * brfalse(left) elselabel
5587 * brfalse(right) elselabel */
5588 lower_logical(A_LOPG(ast), iflabp);
5589 lower_logical(A_ROPG(ast), iflabp);
5590 } else {
5591 /* The incoming fall-through case is 'else'.
5592 * brfalse(left) newlabel
5593 * brtrue(right) thenlabel
5594 * newlabel: */
5595 nlab.thenlabel = 0;
5596 nlab.elselabel = lower_lab();
5597 lower_logical(A_LOPG(ast), &nlab);
5598 /* second operand can fall through if true, branch around if false */
5599 lower_logical(A_ROPG(ast), iflabp);
5600 plower("oL", "LABEL", nlab.elselabel);
5601 lower_reinit();
5602 }
5603 break;
5604 case OP_LOR:
5605 if (iflabp->thenlabel == 0) {
5606 /* The incoming fall-through case is 'then'.
5607 * brtrue(left) newlabel
5608 * brfalse(right) elselabel
5609 * newlabel: */
5610 nlab.thenlabel = lower_lab();
5611 nlab.elselabel = 0;
5612 lower_logical(A_LOPG(ast), &nlab);
5613 /* second operand can fall through if true, branch around if false */
5614 lower_logical(A_ROPG(ast), iflabp);
5615 plower("oL", "LABEL", nlab.thenlabel);
5616 lower_reinit();
5617 } else {
5618 /* The incoming fall-through case is 'else'.
5619 * brtrue(left) thenlabel
5620 * brtrue(right) thenlabel */
5621 lower_logical(A_LOPG(ast), iflabp);
5622 lower_logical(A_ROPG(ast), iflabp);
5623 }
5624 break;
5625 case OP_LEQV:
5626 lower_expression(A_LOPG(ast));
5627 lower_expression(A_ROPG(ast));
5628 if (XBIT(125, 0x8))
5629 ilm = lower_bin_logical(ast, "UXLEQV");
5630 else
5631 ilm = lower_bin_logical(ast, "LEQV");
5632 if (iflabp->thenlabel) {
5633 plower("oiS", "BRT", ilm, iflabp->thenlabel);
5634 } else {
5635 plower("oiS", "BRF", ilm, iflabp->elselabel);
5636 }
5637 break;
5638 case OP_LNEQV:
5639 lower_expression(A_LOPG(ast));
5640 lower_expression(A_ROPG(ast));
5641 if (XBIT(125, 0x8))
5642 ilm = lower_bin_logical(ast, "UXLNEQV");
5643 else
5644 ilm = lower_bin_logical(ast, "LNEQV");
5645 if (iflabp->thenlabel) {
5646 plower("oiS", "BRT", ilm, iflabp->thenlabel);
5647 } else {
5648 plower("oiS", "BRF", ilm, iflabp->elselabel);
5649 }
5650 break;
5651 case OP_EQ:
5652 case OP_GE:
5653 case OP_GT:
5654 case OP_LE:
5655 case OP_LT:
5656 case OP_NE:
5657 lower_expression(ast);
5658 ilm = A_ILMG(ast);
5659 if (iflabp->thenlabel) {
5660 plower("oiS", "BRT", ilm, iflabp->thenlabel);
5661 } else {
5662 plower("oiS", "BRF", ilm, iflabp->elselabel);
5663 }
5664 break;
5665 default:
5666 lower_expression(ast);
5667 ilm = lower_logical_expr(ast);
5668 if (iflabp->thenlabel) {
5669 plower("oiS", "BRT", ilm, iflabp->thenlabel);
5670 } else {
5671 plower("oiS", "BRF", ilm, iflabp->elselabel);
5672 }
5673 break;
5674 }
5675 break;
5676
5677 case A_CMPLXC:
5678 lower_expression(ast);
5679 ilm = A_ILMG(ast);
5680 ilm2 = plower("oS", "ICON", lowersym.intzero);
5681 ilm2 = lower_conv_ilm(ast, ilm, DT_INT4, A_NDTYPEG(ast));
5682 ilm = plower("oii", ltyped("CMP", A_NDTYPEG(ast)), ilm, ilm2);
5683 if (iflabp->thenlabel) {
5684 plower("oiS", "BRT", ilm, iflabp->thenlabel);
5685 } else {
5686 plower("oiS", "BRF", ilm, iflabp->elselabel);
5687 }
5688 break;
5689
5690 case A_CNST:
5691 if (dtype <= 0) {
5692 ast_error("unrecognized data type", ast);
5693 break;
5694 }
5695 sptr = A_SPTRG(ast);
5696 lower_visit_symbol(sptr);
5697 switch (DTYG(dtype)) {
5698 case TY_BINT:
5699 case TY_SINT:
5700 case TY_INT:
5701 case TY_INT8:
5702 case TY_REAL:
5703 case TY_DBLE:
5704 case TY_CMPLX:
5705 case TY_DCMPLX:
5706 lower_expression(ast);
5707 ilm = A_ILMG(ast);
5708 ilm2 = plower("oS", "ICON", lowersym.intzero);
5709 ilm2 = lower_conv_ilm(ast, ilm, DT_INT4, A_NDTYPEG(ast));
5710 ilm = plower("oii", ltyped("CMP", A_NDTYPEG(ast)), ilm, ilm2);
5711 if (iflabp->thenlabel) {
5712 plower("oiS", "BRT", ilm, iflabp->thenlabel);
5713 } else {
5714 plower("oiS", "BRF", ilm, iflabp->elselabel);
5715 }
5716 break;
5717 case TY_BLOG:
5718 case TY_SLOG:
5719 case TY_LOG:
5720 case TY_LOG8:
5721 /* is it true or false? */
5722 if (CONVAL2G(A_SPTRG(ast)) == 0) {
5723 /* False: branch to false label or fall through */
5724 if (iflabp->elselabel) {
5725 plower("oS", "BR", iflabp->elselabel);
5726 }
5727 } else {
5728 /* True: branch to true label or fall through */
5729 if (iflabp->thenlabel) {
5730 plower("oS", "BR", iflabp->thenlabel);
5731 }
5732 }
5733 break;
5734 case TY_CHAR:
5735 case TY_NCHAR:
5736 ast_error("unrecognized char", ast);
5737 break;
5738 }
5739 break;
5740
5741 case A_CONV:
5742 lop = A_LOPG(ast);
5743 switch (A_DTYPEG(lop)) {
5744 case DT_LOG4:
5745 case DT_LOG8:
5746 lower_logical(lop, iflabp);
5747 break;
5748 default:
5749 lower_expression(ast);
5750 ilm = lower_logical_expr(ast);
5751 if (iflabp->thenlabel) {
5752 plower("oiS", "BRT", ilm, iflabp->thenlabel);
5753 } else {
5754 plower("oiS", "BRF", ilm, iflabp->elselabel);
5755 }
5756 }
5757 break;
5758
5759 case A_INTR:
5760 lower_expression(ast);
5761 ilm = lower_logical_expr(ast);
5762 if (iflabp->thenlabel) {
5763 plower("oiS", "BRT", ilm, iflabp->thenlabel);
5764 } else {
5765 plower("oiS", "BRF", ilm, iflabp->elselabel);
5766 }
5767 break;
5768
5769 case A_INIT:
5770 ast_error("unexpected AST type", ast);
5771 break;
5772
5773 case A_ID:
5774 case A_MEM: /* member */
5775 case A_SUBSCR:
5776 case A_FUNC:
5777 lower_expression(ast);
5778 ilm = lower_logical_expr(ast);
5779 if (iflabp->thenlabel) {
5780 plower("oiS", "BRT", ilm, iflabp->thenlabel);
5781 } else {
5782 plower("oiS", "BRF", ilm, iflabp->elselabel);
5783 }
5784 break;
5785
5786 case A_LABEL:
5787 lower_expression(ast);
5788 break;
5789
5790 case A_PAREN:
5791 lower_logical(A_LOPG(ast), iflabp);
5792 break;
5793
5794 case A_SUBSTR:
5795 lower_expression(ast);
5796 break;
5797
5798 case A_UNOP:
5799 switch (A_OPTYPEG(ast)) {
5800 case OP_LNOT:
5801 nlab.thenlabel = iflabp->elselabel;
5802 nlab.elselabel = iflabp->thenlabel;
5803 lower_logical(A_LOPG(ast), &nlab);
5804 break;
5805 default:
5806 lower_expression(ast);
5807 ilm = lower_logical_expr(ast);
5808 if (iflabp->thenlabel) {
5809 plower("oiS", "BRT", ilm, iflabp->thenlabel);
5810 } else {
5811 plower("oiS", "BRF", ilm, iflabp->elselabel);
5812 }
5813 break;
5814 }
5815 break;
5816
5817 /* ------------- unsupported AST types ------------- */
5818
5819 case A_ATOMIC:
5820 case A_BARRIER:
5821 case A_COMMENT:
5822 case A_COMSTR:
5823 case A_CRITICAL:
5824 case A_ELSEFORALL:
5825 case A_ELSEWHERE:
5826 case A_ENDATOMIC:
5827 case A_ENDCRITICAL:
5828 case A_ENDFORALL:
5829 case A_ENDMASTER:
5830 case A_ENDWHERE:
5831 case A_FORALL:
5832 case A_MASTER:
5833 case A_NOBARRIER:
5834 case A_TRIPLE:
5835 case A_WHERE:
5836 default:
5837 ast_error("bad ast optype in logical expression", ast);
5838 break;
5839 }
5840 } /* lower_logical */
5841
5842 /* Called for A_FUNC or A_INTR when no subscript checking should be done
5843 * on the arguments. Must be called during preorder traversal so we can
5844 * set lower_disable_subscr_chk before subscripting is evaluated.
5845 */
5846 static void
lower_no_subscr_chk(int ast,int * unused)5847 lower_no_subscr_chk(int ast, int *unused)
5848 {
5849 int cnt, argt, i;
5850 int save_disable_subscr_chk;
5851
5852 save_disable_subscr_chk = lower_disable_subscr_chk;
5853 lower_disable_subscr_chk = 1;
5854 ast_traverse((int)A_LOPG(ast), lower_check_ast, lower_ast, NULL);
5855 cnt = A_ARGCNTG(ast);
5856 argt = A_ARGSG(ast);
5857 for (i = 0; i < cnt; i++)
5858 /* watch for optional args */
5859 if (ARGT_ARG(argt, i) != 0)
5860 ast_traverse(ARGT_ARG(argt, i), lower_check_ast, lower_ast, NULL);
5861 lower_ast(ast, unused);
5862 lower_disable_subscr_chk = save_disable_subscr_chk;
5863 }
5864
5865 static LOGICAL
lower_check_ast(int ast,int * unused)5866 lower_check_ast(int ast, int *unused)
5867 {
5868 int argt, shape, i, ndim;
5869 int symfunc;
5870
5871 /* return TRUE to not recurse below here */
5872 switch (A_TYPEG(ast)) {
5873 case A_FUNC:
5874 symfunc = memsym_of_ast(A_LOPG(ast));
5875 if (strcmp(SYMNAME(symfunc), mkRteRtnNm(RTE_lena)) == 0) {
5876 /* Disable subscript checking for LEN */
5877 lower_no_subscr_chk(ast, unused);
5878 return TRUE;
5879 }
5880 break;
5881 case A_INTR:
5882 switch (A_OPTYPEG(ast)) {
5883 case I_LEN:
5884 /* Disable subscript checking for LEN */
5885 lower_no_subscr_chk(ast, unused);
5886 return TRUE;
5887 case I_SIZE:
5888 /* for the 'size' intrinsic, we use the shape, not the
5889 * arguments */
5890 lower_ast(ast, unused);
5891 return TRUE;
5892 case I_UBOUND:
5893 case I_LBOUND:
5894 /* use shape of first argument */
5895 argt = A_ARGSG(ast);
5896 ast_traverse(ARGT_ARG(argt, 1), lower_check_ast, lower_ast, NULL);
5897 shape = A_SHAPEG(ARGT_ARG(argt, 0));
5898 ndim = SHD_NDIM(shape);
5899 for (i = 0; i < ndim; ++i) {
5900 if (SHD_LWB(shape, i)) {
5901 ast_traverse(SHD_LWB(shape, i), lower_check_ast, lower_ast, NULL);
5902 }
5903 if (SHD_UPB(shape, i)) {
5904 ast_traverse(SHD_UPB(shape, i), lower_check_ast, lower_ast, NULL);
5905 }
5906 }
5907 lower_ast(ast, unused);
5908 return TRUE;
5909 }
5910 break;
5911 }
5912 return FALSE;
5913 } /* lower_check_ast */
5914
5915 /** \brief Use ast_traverse to lower the expression asts. */
5916 void
lower_expression(int ast)5917 lower_expression(int ast)
5918 {
5919 ast_traverse(ast, lower_check_ast, lower_ast, NULL);
5920 } /* lower_expression */
5921
5922 void
lower_reinit(void)5923 lower_reinit(void)
5924 {
5925 ast_revisit(lower_clear_opt, 0);
5926 ast_unvisit_norepl();
5927 ast_visit(1, 1);
5928 } /* lower_reinit */
5929
5930 void
lower_exp_finish(void)5931 lower_exp_finish(void)
5932 {
5933 if (intr_argsz > IARGS) {
5934 FREE(intrinsic_args);
5935 intrinsic_args = intr_argbf;
5936 intr_argsz = IARGS;
5937 }
5938 }
5939