1 /*
2 * Copyright (c) 1994-2019, NVIDIA CORPORATION. All rights reserved.
3 *
4 * Licensed under the Apache License, Version 2.0 (the "License");
5 * you may not use this file except in compliance with the License.
6 * You may obtain a copy of the License at
7 *
8 * http://www.apache.org/licenses/LICENSE-2.0
9 *
10 * Unless required by applicable law or agreed to in writing, software
11 * distributed under the License is distributed on an "AS IS" BASIS,
12 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13 * See the License for the specific language governing permissions and
14 * limitations under the License.
15 *
16 */
17
18 /**
19 \file
20 \brief Abstract syntax tree output module.
21 */
22
23 #include "gbldefs.h"
24 #include "global.h"
25 #include "error.h"
26 #include "symtab.h"
27 #include "symutl.h"
28 #include "dtypeutl.h"
29 #include "soc.h"
30 #include "semant.h"
31 #include "ast.h"
32 #include "pragma.h"
33 #include "gramtk.h"
34 #include "tokdf.h"
35 #include "dinit.h"
36 #include "rte.h"
37 #include "rtlRtns.h"
38
39 #define NO_PTR XBIT(49, 0x8000)
40 #define NO_CHARPTR XBIT(58, 0x1)
41 #define NO_DERIVEDPTR XBIT(58, 0x40000)
42
43 /* The only routine that writes to 'outfile' is write_next_line */
44 static FILE *outfile;
45 static int col = 0;
46 static int max_col = 72;
47
48 static int continuations = 0; /* number of continuation lines */
49
50 static int indent; /* number of indentation levels */
51
52 #define CARDB_SIZE 300 /* make it large enough */
53 static char lbuff[CARDB_SIZE];
54
55 #define MAX_FNAME_LEN 258
56 static LOGICAL ast_is_comment = FALSE;
57 static LOGICAL op_space = TRUE;
58
59 static LOGICAL altret_spec = FALSE; /* labels are alternate return specifiers */
60
61 typedef struct { /* simple queue decl. */
62 int first;
63 int last;
64 } _A_Q;
65
66 /* create queue of symbols specified in parameter statements; keep
67 * separate queues for combinations of ansi-/vax- style parameters
68 * and those with A_CNST/non-A_CNST asts.
69 * 'first' locates first in the queue and is 0 if the queue is empty;
70 * symbols are linked together using the SYMLK field; queue is terminated
71 * when the SYMLK field is zero. 'last' locates the last parameter in
72 * the queue.
73 */
74 static struct {
75 _A_Q q; /* queue for parameters with const ast's */
76 _A_Q q_e; /* queue for parameters with expr ast's */
77 } params, vx_params = {0};
78
79 typedef struct _qsym { /* for queuing syms whose decls are to be printed later*/
80 struct _qsym *next;
81 int sptr;
82 } QSYM;
83
84 static void print_ast(int ast); /* fwd decl */
85 static void print_ast_replaced(int, int, int);
86
87 static void init_line(void);
88 static void push_indent(void);
89 static void pop_indent(void);
90 static void print_uncoerced_const(int);
91 static void print_loc(int);
92 static void print_loc_of_sym(int);
93 static void print_refsym(int, int);
94 static void print_sname(int);
95 static void print_naked_id(int);
96 void deferred_to_pointer(void);
97 static int pr_chk_arr(int);
98 static void gen_bnd_assn(int);
99 static void gen_allocate(int, int);
100 static void gen_deallocate(int, int, int, int);
101 static void gen_nullify(int, int, int);
102 static void put_mem_string(int, char *);
103 static void put_string(char *);
104 static void put_fstring(char *);
105 static void put_char(char);
106 static void put_const(int);
107 static void put_int(INT);
108 static void put_intkind(INT, int);
109 static void put_int8(int);
110 static void put_logical(LOGICAL, int);
111 static void put_float(INT);
112 static void put_double(int);
113 static void char_to_text(int);
114 static void put_u_to_l(char *);
115 static void put_l_to_u(char *);
116 static void check_len(int);
117 static char *label_name(int);
118 static void print_header(int);
119 static void pghpf_entry(int);
120 static void put_call(int ast, int call, char *name, int check_ptrarg);
121
122 void
astout_init(void)123 astout_init(void)
124 {
125 if (XBIT(52, 0x20))
126 max_col = 132;
127 BZERO(¶ms, char, sizeof(params));
128 BZERO(&vx_params, char, sizeof(vx_params));
129 }
130
131 static void
init_line(void)132 init_line(void)
133 {
134 col = 0;
135 put_string(" "); /* 6 blanks */
136 }
137
138 #define INDENT_MAX 4
139 #define INDENT_STR " "
140
141 static void
push_indent(void)142 push_indent(void)
143 {
144 if (!ast_is_comment) {
145 indent++;
146 if (indent <= INDENT_MAX)
147 put_string(INDENT_STR);
148 }
149 }
150
151 static void
pop_indent(void)152 pop_indent(void)
153 {
154 if (!ast_is_comment) {
155 indent--;
156 if (indent < 0) {
157 interr("pop_indent:ident_level", indent, ERR_Warning);
158 indent = 0;
159 }
160 if (indent < INDENT_MAX)
161 col -= strlen(INDENT_STR);
162 }
163 }
164
165 static int
precedence(int ast)166 precedence(int ast)
167 {
168 /*
169 * Precedence Levels:
170 * 20 identifiers, function calls, parens, etc.; any 'term'
171 * 18 **
172 * 16 * /
173 * 14 + - (binary)
174 * 12 + - (unary)
175 * 10 relationals
176 * 8 .not.
177 * 6 .and.
178 * 4 .or.
179 * 2 .neqv. .eqv.
180 */
181 #define PREC_TERM 20
182 #define PREC_POW 18
183 #define PREC_MULT 16
184 #define PREC_ADD 14
185 #define PREC_NEG 12
186 #define PREC_REL 10
187 #define PREC_NOT 8
188 #define PREC_AND 6
189 #define PREC_OR 4
190 #define PREC_EQV 2
191
192 switch (A_TYPEG(ast)) {
193 case A_BINOP:
194 switch (A_OPTYPEG(ast)) {
195 case OP_ADD:
196 case OP_SUB:
197 return PREC_ADD;
198 case OP_MUL:
199 case OP_DIV:
200 return PREC_MULT;
201 case OP_XTOI:
202 case OP_XTOX:
203 return PREC_POW;
204 case OP_CAT:
205 return PREC_MULT;
206 case OP_LEQV:
207 case OP_LNEQV:
208 return PREC_EQV;
209 case OP_LOR:
210 return PREC_OR;
211 case OP_LAND:
212 case OP_SCAND:
213 return PREC_AND;
214 case OP_EQ:
215 case OP_GE:
216 case OP_GT:
217 case OP_LE:
218 case OP_LT:
219 case OP_NE:
220 return PREC_REL;
221 default:
222 break;
223 }
224 break;
225 case A_UNOP:
226 switch (A_OPTYPEG(ast)) {
227 case OP_ADD:
228 case OP_SUB:
229 return /* PREC_NEG */ PREC_ADD;
230 case OP_LNOT:
231 return PREC_NOT;
232 case OP_LOC:
233 case OP_REF:
234 case OP_VAL:
235 case OP_BYVAL:
236 break;
237 default:
238 break;
239 }
240 break;
241 case A_CONV:
242 return precedence((int)A_LOPG(ast));
243 default:
244 break;
245 }
246 return PREC_TERM;
247 }
248
249 static LOGICAL
negative_constant(int ast)250 negative_constant(int ast)
251 {
252 DBLINT64 inum1, inum2;
253 DBLE dnum1, dnum2;
254
255 if (A_TYPEG(ast) == A_CNST) {
256 int sptr;
257 sptr = A_SPTRG(ast);
258 switch (DTY(DTYPEG(sptr))) {
259 case TY_INT:
260 if (CONVAL2G(sptr) & 0x80000000)
261 return TRUE;
262 break;
263 case TY_REAL:
264 if (xfcmp(CONVAL2G(sptr), CONVAL2G(stb.flt0)) < 0)
265 return TRUE;
266 break;
267 case TY_DBLE:
268 dnum1[0] = CONVAL1G(sptr);
269 dnum1[1] = CONVAL2G(sptr);
270 dnum2[0] = CONVAL1G(stb.dbl0);
271 dnum2[1] = CONVAL2G(stb.dbl0);
272 if (xdcmp(dnum1, dnum2) < 0)
273 return TRUE;
274 break;
275 case TY_INT8:
276 inum1[0] = CONVAL1G(sptr);
277 inum1[1] = CONVAL2G(sptr);
278 inum2[0] = 0;
279 inum2[1] = 0;
280 if (cmp64(inum1, inum2) < 0)
281 return TRUE;
282 break;
283 default:
284 break;
285 }
286 }
287 return FALSE;
288 }
289
290 static int
left_precedence(int lop,int prec_op)291 left_precedence(int lop, int prec_op)
292 {
293 int prec_lop;
294 while (A_TYPEG(lop) == A_CONV)
295 lop = A_LOPG(lop);
296 if (negative_constant(lop))
297 /*
298 * a constant represents the highest precedence level since it's
299 * a term. Treating it as a term is a problem if a negative constant
300 * is the left operand of a binary operator; the precedence needs to
301 * be the precedence of a unary minus.
302 */
303 return PREC_ADD;
304
305 prec_lop = precedence(lop);
306 if (prec_op == PREC_POW && prec_lop == PREC_POW)
307 /* left operand of ** is also a **; since '**' is right
308 * associative, need to ensure that the left operand is
309 * parenthesized.
310 */
311 prec_lop--;
312 return prec_lop;
313 }
314
315 static int
right_precedence(int rop,int prec_op)316 right_precedence(int rop, int prec_op)
317 {
318 int prec_rop;
319
320 while (A_TYPEG(rop) == A_CONV)
321 rop = A_LOPG(rop);
322 if (negative_constant(rop))
323 /*
324 * a constant represents the highest precedence level since it's
325 * a term. Treating it as a term is a problem if a negative constant
326 * is the right operand of a binary operator; the precedence needs to
327 * be the precedence of a unary minus.
328 */
329 return PREC_ADD;
330
331 prec_rop = precedence(rop);
332 if (prec_op == PREC_POW && prec_rop == PREC_POW)
333 /* right operand of ** is also a **; since '**' is right
334 * associative, need to ensure that the right operand is
335 * not parenthesized.
336 */
337 prec_rop++;
338 return prec_rop;
339 }
340
341 static void
cuf_pragma(int ast)342 cuf_pragma(int ast)
343 {
344 lbuff[0] = '!';
345 lbuff[1] = '$';
346 lbuff[2] = 'c';
347 lbuff[3] = 'u';
348 lbuff[4] = 'f';
349 lbuff[5] = ' ';
350 } /* cuf_pragma */
351
352 static void
acc_pragma(int ast)353 acc_pragma(int ast)
354 {
355 lbuff[0] = '!';
356 lbuff[1] = '$';
357 lbuff[2] = 'a';
358 lbuff[3] = 'c';
359 lbuff[4] = 'c';
360 lbuff[5] = ' ';
361 } /* acc_pragma */
362
363 /* device type */
364 static void
acc_dtype(int ast)365 acc_dtype(int ast)
366 {
367 } /* acc_dtype */
368
369 static void
print_ast(int ast)370 print_ast(int ast)
371 {
372 char *o;
373 int atype;
374 int i, asd;
375 int astli;
376 int argt;
377 int cnt;
378 int lop, rop;
379 int prec_op, prec_lop;
380 int shape;
381 LOGICAL encl;
382 int linearize;
383 LOGICAL save_op_space;
384 LOGICAL commutable, nid;
385 FtnRtlEnum rtlRtn;
386 int sym, object;
387 int dtype;
388 int optype;
389 int save_dtype, save_comment;
390
391 switch (atype = A_TYPEG(ast)) {
392 case A_NULL:
393 break;
394 case A_ID:
395 print_refsym(A_SPTRG(ast), ast);
396 break;
397 case A_CNST:
398 put_const((int)A_SPTRG(ast));
399 break;
400 case A_LABEL:
401 if (altret_spec)
402 put_char('*');
403 put_string(label_name((int)A_SPTRG(ast)));
404 break;
405 case A_BINOP:
406 lop = A_LOPG(ast);
407 rop = A_ROPG(ast);
408 commutable = FALSE;
409 switch (A_OPTYPEG(ast)) {
410 case OP_ADD:
411 o = "+";
412 commutable = TRUE;
413 break;
414 case OP_SUB:
415 o = "-";
416 break;
417 case OP_MUL:
418 o = "*";
419 commutable = TRUE;
420 break;
421 case OP_DIV:
422 o = "/";
423 break;
424 case OP_XTOI:
425 case OP_XTOX:
426 o = "**";
427 break;
428 case OP_CAT:
429 o = "//";
430 break;
431 case OP_LEQV:
432 o = ".eqv.";
433 commutable = TRUE;
434 break;
435 case OP_LNEQV:
436 o = ".neqv.";
437 commutable = TRUE;
438 break;
439 case OP_LOR:
440 o = ".or.";
441 commutable = TRUE;
442 break;
443 case OP_LAND:
444 case OP_SCAND:
445 o = ".and.";
446 commutable = TRUE;
447 break;
448 case OP_EQ:
449 o = ".eq.";
450 break;
451 case OP_GE:
452 o = ".ge.";
453 break;
454 case OP_GT:
455 o = ".gt.";
456 break;
457 case OP_LE:
458 o = ".le.";
459 break;
460 case OP_LT:
461 o = ".lt.";
462 break;
463 case OP_NE:
464 o = ".ne.";
465 break;
466 default:
467 o = "<bop>";
468 break;
469 }
470 if (commutable && (precedence(lop) > precedence(rop)) && !ast_is_comment) {
471 int tmp;
472 tmp = lop;
473 lop = rop;
474 rop = tmp;
475 }
476 prec_op = precedence(ast);
477 encl = prec_op > left_precedence(lop, prec_op);
478 if (encl)
479 put_char('(');
480 print_ast(lop);
481 if (encl)
482 put_char(')');
483 if (op_space)
484 put_char(' ');
485 put_l_to_u(o);
486 if (op_space)
487 put_char(' ');
488 encl = prec_op >= right_precedence(rop, prec_op);
489 if (encl)
490 put_char('(');
491 print_ast(rop);
492 if (encl)
493 put_char(')');
494 break;
495 case A_UNOP:
496 lop = A_LOPG(ast);
497 prec_lop = precedence(lop);
498 encl = precedence(ast) >= prec_lop;
499 switch (A_OPTYPEG(ast)) {
500 case OP_ADD:
501 if (!encl && prec_lop != PREC_TERM)
502 o = "+ ";
503 else
504 o = "+";
505 break;
506 case OP_SUB:
507 if (negative_constant(lop))
508 encl = TRUE;
509 if (!encl && prec_lop != PREC_TERM)
510 o = "- ";
511 else
512 o = "-";
513 break;
514 case OP_LNOT:
515 o = ".not. ";
516 break;
517 case OP_LOC:
518 print_loc(lop);
519 return;
520 case OP_REF:
521 put_l_to_u("%ref(");
522 goto un_builtin;
523 case OP_BYVAL:
524 put_l_to_u("%byval(");
525 goto un_builtin;
526 case OP_VAL:
527 if (ast == astb.ptr0) {
528 put_string("pghpf_0(3)");
529 return;
530 }
531 if (ast == astb.ptr0c) {
532 put_string("pghpf_0c");
533 return;
534 }
535 put_l_to_u("%val(");
536 un_builtin:
537 print_ast(lop);
538 put_char(')');
539 return;
540 default:
541 o = "<uop>";
542 break;
543 }
544 put_l_to_u(o);
545 if (encl)
546 put_char('(');
547 print_ast(lop);
548 if (encl)
549 put_char(')');
550 break;
551 case A_CMPLXC:
552 put_char('(');
553 print_ast((int)A_LOPG(ast));
554 put_char(',');
555 print_ast((int)A_ROPG(ast));
556 put_char(')');
557 break;
558 case A_CONV:
559 print_ast((int)A_LOPG(ast));
560 break;
561 case A_PAREN:
562 put_char('(');
563 print_ast((int)A_LOPG(ast));
564 put_char(')');
565 break;
566 case A_MEM:
567 lop = (int)A_PARENTG(ast);
568 print_ast(lop);
569 dtype = A_DTYPEG(lop);
570 if (DTYG(dtype) == TY_DERIVED)
571 put_char('%');
572 else
573 put_char('.');
574 print_ast(A_MEMG(ast));
575 break;
576 case A_SUBSCR:
577 asd = A_ASDG(ast);
578 lop = A_LOPG(ast);
579 linearize = pr_chk_arr(lop);
580 if (ast_is_comment)
581 linearize = 0;
582 if (XBIT(70, 8))
583 linearize = 0;
584 put_char('(');
585 save_op_space = op_space;
586 op_space = FALSE;
587 if (linearize == 1) {
588 /* if the output is standard f77, need to linearize the
589 * subscripts for subscripting an allocatable array.
590 */
591 int asym, dsym;
592 int dtype;
593 ADSC *ad;
594 int ln, lw, up, stride;
595
596 asym = memsym_of_ast(lop);
597 dsym = DESCRG(asym);
598 dtype = DTYPEG(dsym);
599 if (DTY(dtype) != TY_ARRAY)
600 dtype = DTYPEG(asym);
601 ad = AD_DPTR(dtype);
602 dtype = DDTG(dtype); /* element type */
603 i = ASD_NDIM(asd) - 1;
604 lw = AD_LWAST(ad, i);
605 if (lw == 0)
606 lw = astb.i1;
607 ln = mk_binop(OP_SUB, (int)ASD_SUBS(asd, i), lw, astb.bnd.dtype);
608
609 for (i = i - 1; i >= 0; i--) {
610 lw = AD_LWAST(ad, i);
611 if (lw == 0)
612 lw = astb.bnd.one;
613 up = AD_UPAST(ad, i);
614 if (up == 0)
615 up = astb.bnd.one;
616 stride = mk_binop(OP_SUB, up, lw, astb.bnd.dtype);
617 stride = mk_binop(OP_ADD, stride, astb.bnd.one, astb.bnd.dtype);
618 ln = mk_binop(OP_MUL, ln, stride, astb.bnd.dtype);
619
620 /* + (j - bnd) --> + j - bnd */
621 ln = mk_binop(OP_ADD, ln, (int)ASD_SUBS(asd, i), astb.bnd.dtype);
622 ln = mk_binop(OP_SUB, ln, lw, astb.bnd.dtype);
623 }
624 if (NO_CHARPTR && DTY(dtype) == TY_CHAR) {
625 /* same as if the f77 output is not allowed to have pointers */
626 if (ln != astb.bnd.zero) {
627 print_ast(ln);
628 put_char('+');
629 }
630 if (PTROFFG(asym)) {
631 int offset;
632 offset = check_member(lop, mk_id(PTROFFG(asym)));
633 print_ast(offset);
634 } else if (MIDNUMG(asym)) {
635 int offset;
636 offset = check_member(lop, mk_id(MIDNUMG(asym)));
637 print_ast(offset);
638 } else {
639 put_int(1);
640 }
641 } else if (NO_DERIVEDPTR && DTY(dtype) == TY_DERIVED) {
642 /* same as if the f77 output is not allowed to have pointers */
643 if (ln != astb.bnd.zero) {
644 print_ast(ln);
645 put_char('+');
646 }
647 if (PTROFFG(asym))
648 put_string(SYMNAME(PTROFFG(asym)));
649 else if (MIDNUMG(asym))
650 put_string(SYMNAME(MIDNUMG(asym)));
651 else
652 put_int(1);
653 } else if (!NO_PTR) {
654 /* for f77 output with pointers, need to add '1' to offset
655 * the effect of the target compiler of subtracting 1 from
656 * the linearized subscript expression.
657 */
658 ln = mk_binop(OP_ADD, ln, astb.bnd.one, astb.bnd.dtype);
659 print_ast(ln);
660 } else {
661 /* for f77 output without pointers, add in the 'pointer offset';
662 * added at the end of the subscript expression since the
663 * expression could be 0 or a unary negate. Note that a 1 is
664 * unnecessary since the 'pointer offset' added to the array
665 * is the base address of the allocated array. The subscript
666 * expression is just an offset from the base address.
667 */
668 if (ln != astb.bnd.zero) {
669 print_ast(ln);
670 put_char('+');
671 }
672 if (PTROFFG(asym)) {
673 int offset;
674 offset = check_member(lop, mk_id(PTROFFG(asym)));
675 print_ast(offset);
676 } else if (MIDNUMG(asym)) {
677 int offset;
678 offset = check_member(lop, mk_id(MIDNUMG(asym)));
679 print_ast(offset);
680 } else {
681 put_int(1);
682 }
683 }
684 put_char(')');
685 op_space = save_op_space;
686 break;
687 } else if (linearize) {
688 /* POINTER or nonPOINTER object has static descriptor */
689 int asym;
690 int dtyp;
691 int lw, off, offset, str, acc1;
692 int nd;
693 LOGICAL no_mult;
694
695 asym = memsym_of_ast(lop);
696 dtyp = DTYPEG(asym);
697 nd = ASD_NDIM(asd);
698 no_mult = FALSE;
699 if (nd == 1 && !POINTERG(asym) &&
700 (!XBIT(58, 0x22) || NEWARGG(asym) == 0) /* not a remapped dummy */
701 && SCG(asym) != SC_DUMMY)
702 no_mult = TRUE;
703 off = 0;
704 if (no_mult) {
705 lw = ASD_SUBS(asd, 0);
706 acc1 = astb.bnd.zero;
707 if (XBIT(58, 0x22) && ADD_LWAST(dtyp, 0))
708 acc1 = mk_binop(OP_SUB, ADD_LWAST(dtyp, 0), astb.bnd.one,
709 astb.bnd.dtype);
710 lw = mk_binop(OP_SUB, lw, acc1, astb.bnd.dtype);
711 if (lw != astb.bnd.zero) {
712 print_ast(lw);
713 off = 1;
714 }
715 } else {
716 for (i = 0; i < nd; i++) {
717 lw = ASD_SUBS(asd, i);
718 acc1 = astb.bnd.zero;
719 if (XBIT(58, 0x22) && !POINTERG(asym) && ADD_LWAST(dtyp, i)) {
720 acc1 = mk_binop(OP_SUB, ADD_LWAST(dtyp, i), astb.bnd.one,
721 astb.bnd.dtype);
722 }
723 lw = mk_binop(OP_SUB, lw, acc1, astb.bnd.dtype);
724 str = check_member(lop, get_local_multiplier(linearize, i));
725 if (lw != astb.bnd.zero) {
726 if (off)
727 put_char('+');
728 if (lw != astb.bnd.one) {
729 prec_op = left_precedence(lw, PREC_MULT);
730 if (prec_op < PREC_MULT)
731 put_char('(');
732 print_ast(lw);
733 if (prec_op < PREC_MULT)
734 put_char(')');
735 put_char('*');
736 }
737 print_ast(str);
738 off = 1;
739 }
740 if (F77OUTPUT && XBIT(58, 0x22) && !POINTERG(asym) && NEWARGG(asym)) {
741 /* a remapped dummy array argument;
742 * have to also add section offset */
743 if (off)
744 put_char('+');
745 off = 1;
746 str = check_member(lop, get_section_offset(linearize, i));
747 print_ast(str);
748 }
749 }
750 }
751 if (off)
752 put_char('+');
753 offset = check_member(lop, get_xbase(linearize));
754 print_ast(offset);
755 if (!POINTERG(asym) && SCG(asym) == SC_DUMMY) {
756 put_char(')');
757 op_space = save_op_space;
758 break;
759 }
760
761 if (NO_PTR || (NO_CHARPTR && DTYG(DTYPEG(asym)) == TY_CHAR) ||
762 (NO_DERIVEDPTR && DTYG(DTYPEG(asym)) == TY_DERIVED)) {
763 put_char('+');
764 if (PTROFFG(asym)) {
765 offset = check_member(lop, mk_id(PTROFFG(asym)));
766 } else {
767 assert(MIDNUMG(asym),
768 "astout:linearize subscripts, midnum & ptroff 0", asym, 3);
769 offset = check_member(lop, mk_id(MIDNUMG(asym)));
770 }
771 print_ast(offset);
772 put_string("-1");
773 }
774
775 put_char(')');
776 op_space = save_op_space;
777 break;
778 }
779 for (i = 0; i < (int)ASD_NDIM(asd) - 1; i++) {
780 print_ast((int)ASD_SUBS(asd, i));
781 put_char(',');
782 }
783 print_ast((int)ASD_SUBS(asd, ASD_NDIM(asd) - 1));
784 put_char(')');
785 op_space = save_op_space;
786 break;
787 case A_SUBSTR:
788 print_ast((int)A_LOPG(ast));
789 put_char('(');
790 if (A_LEFTG(ast))
791 print_ast((int)A_LEFTG(ast));
792 put_char(':');
793 if (A_RIGHTG(ast))
794 print_ast((int)A_RIGHTG(ast));
795 put_char(')');
796 break;
797 case A_TRIPLE:
798 /* [lb]:[ub][:stride] */
799 if (A_LBDG(ast))
800 print_ast((int)A_LBDG(ast));
801 put_char(':');
802 if (A_UPBDG(ast))
803 print_ast((int)A_UPBDG(ast));
804 if (A_STRIDEG(ast)) {
805 put_char(':');
806 print_ast((int)A_STRIDEG(ast));
807 }
808 break;
809 case A_INTR:
810 optype = A_OPTYPEG(ast);
811 if (ast_is_comment) {
812 if (A_ISASSIGNLHSG(ast)) {
813 assert(optype == I_ALLOCATED, "unexpected ISASSIGNLHS", ast, ERR_Fatal);
814 put_call(ast, 0, "allocated_lhs", 0);
815 } else if (A_ISASSIGNLHS2G(ast)) {
816 assert(optype == I_ALLOCATED, "unexpected ISASSIGNLHS2", ast,
817 ERR_Fatal);
818 put_call(ast, 0, "allocated_lhs2", 0);
819 } else {
820 put_call(ast, 0, NULL, 0);
821 }
822 break;
823 }
824 if ((sym = EXTSYMG(intast_sym[optype]))) {
825 put_call(ast, 0, SYMNAME(sym), 0);
826 break;
827 }
828 switch (optype) {
829 case I_INT:
830 dtype = DDTG(A_DTYPEG(ast));
831 put_call(ast, 0, NULL, 0);
832 break;
833 case I_NINT:
834 save_dtype = A_DTYPEG(ast);
835 dtype = DDTG(save_dtype);
836 put_call(ast, 0, NULL, 0);
837 break;
838 case I_REAL:
839 save_dtype = A_DTYPEG(ast);
840 dtype = DDTG(save_dtype);
841 put_call(ast, 0, NULL, 0);
842 break;
843 case I_AINT:
844 case I_ANINT:
845 save_dtype = A_DTYPEG(ast);
846 dtype = DDTG(save_dtype);
847 argt = A_ARGSG(ast);
848 i = ARGT_ARG(argt, 0);
849 put_call(ast, 0, NULL, 0);
850 break;
851 case I_SIZE:
852 argt = A_ARGSG(ast);
853 shape = A_SHAPEG(ARGT_ARG(argt, 0));
854 cnt = SHD_NDIM(shape);
855 put_string(mkRteRtnNm(RTE_size));
856 put_char('(');
857 put_int((INT)cnt);
858 put_char(',');
859 print_ast((int)ARGT_ARG(argt, 1));
860 for (i = 0; i < cnt - 1; i++) {
861 put_char(',');
862 print_ast((int)SHD_LWB(shape, i));
863 put_char(',');
864 print_ast((int)SHD_UPB(shape, i));
865 put_char(',');
866 print_ast((int)SHD_STRIDE(shape, i));
867 }
868 put_char(',');
869 print_ast((int)SHD_LWB(shape, i));
870 put_char(',');
871 if (SHD_UPB(shape, i))
872 print_ast((int)SHD_UPB(shape, i));
873 else
874 print_ast(astb.ptr0);
875 put_char(',');
876 print_ast((int)SHD_STRIDE(shape, i));
877 put_char(')');
878 break;
879 case I_LBOUND:
880 case I_UBOUND:
881 argt = A_ARGSG(ast);
882 shape = A_SHAPEG(ARGT_ARG(argt, 0));
883 cnt = SHD_NDIM(shape);
884 if (optype == I_LBOUND)
885 put_string(mkRteRtnNm(RTE_lb));
886 else
887 put_string(mkRteRtnNm(RTE_ub));
888 put_char('(');
889 put_int((INT)cnt);
890 put_char(',');
891 print_ast((int)ARGT_ARG(argt, 1));
892 for (i = 0; i < cnt; i++) {
893 put_char(',');
894 print_ast((int)SHD_LWB(shape, i));
895 put_char(',');
896 if (SHD_UPB(shape, i))
897 print_ast((int)SHD_UPB(shape, i));
898 else
899 print_ast(astb.ptr0);
900 }
901 put_char(')');
902 break;
903 case I_CMPLX:
904 argt = A_ARGSG(ast);
905 if (ARGT_ARG(argt, 2) != 0 && ARGT_ARG(argt, 1) == 0) {
906 /* Kind arg, no second parameter, f90 output */
907 put_string("cmplx");
908 put_char('(');
909 print_ast(ARGT_ARG(argt, 0));
910 put_char(',');
911 put_string("kind");
912 put_char('=');
913 print_ast(ARGT_ARG(argt, 2));
914 put_char(')');
915 break;
916 }
917 save_dtype = A_DTYPEG(ast);
918 dtype = DDTG(save_dtype);
919 put_call(ast, 0, NULL, 0);
920 break;
921 case I_DIMAG:
922 /* since LOP may be aimag, force the name 'dimag' */
923 put_call(ast, 0, "dimag", 0);
924 break;
925 case I_INDEX:
926 if (A_ARGCNTG(ast) != 2) {
927 rtlRtn = RTE_indexa;
928 goto make_func_name;
929 }
930 put_call(ast, 0, NULL, 0);
931 break;
932 case I_CEILING:
933 case I_MODULO:
934 case I_FLOOR:
935 i = PNMPTRG(A_SPTRG(A_LOPG(ast))); /* locates "-<name>" */
936 put_call(ast, 0, stb.n_base + i + 1, 0);
937 break;
938 case I_ALLOCATED:
939 rtlRtn = RTE_allocated;
940 goto make_func_name;
941 case I_PRESENT:
942 put_call(ast, 0, NULL, 2);
943 break;
944 case I_ACHAR:
945 rtlRtn = RTE_achara;
946 goto make_func_name;
947 case I_EXPONENT:
948 argt = A_ARGSG(ast);
949 if (DTY(DDTG(A_DTYPEG(ARGT_ARG(argt, 0)))) == TY_REAL)
950 rtlRtn = RTE_expon;
951 else
952 rtlRtn = RTE_expond;
953 goto make_func_name;
954 case I_FRACTION:
955 if (DTY(DDTG(A_DTYPEG(ast))) == TY_REAL)
956 rtlRtn = RTE_frac;
957 else
958 rtlRtn = RTE_fracd;
959 goto make_func_name;
960 case I_IACHAR:
961 rtlRtn = RTE_iachara;
962 goto make_func_name;
963 case I_RRSPACING:
964 if (DTY(DDTG(A_DTYPEG(ast))) == TY_REAL)
965 rtlRtn = RTE_rrspacing;
966 else
967 rtlRtn = RTE_rrspacingd;
968 goto make_func_name;
969 case I_SPACING:
970 if (DTY(DDTG(A_DTYPEG(ast))) == TY_REAL)
971 rtlRtn = RTE_spacing;
972 else
973 rtlRtn = RTE_spacingd;
974 goto make_func_name;
975 case I_NEAREST:
976 if (DTY(DDTG(A_DTYPEG(ast))) == TY_REAL)
977 rtlRtn = RTE_nearest;
978 else
979 rtlRtn = RTE_nearestd;
980 goto make_func_name;
981 case I_SCALE:
982 if (DTY(DDTG(A_DTYPEG(ast))) == TY_REAL)
983 rtlRtn = RTE_scale;
984 else
985 rtlRtn = RTE_scaled;
986 goto make_func_name;
987 case I_SET_EXPONENT:
988 if (DTY(DDTG(A_DTYPEG(ast))) == TY_REAL)
989 rtlRtn = RTE_setexp;
990 else
991 rtlRtn = RTE_setexpd;
992 goto make_func_name;
993 case I_VERIFY:
994 argt = A_ARGSG(ast);
995 if (DTY(DDTG(A_DTYPEG(ARGT_ARG(argt, 0)))) == TY_CHAR)
996 rtlRtn = RTE_verifya;
997 else
998 rtlRtn = RTE_nverify;
999 goto make_func_name;
1000 case I_SCAN:
1001 argt = A_ARGSG(ast);
1002 if (DTY(DDTG(A_DTYPEG(ARGT_ARG(argt, 0)))) == TY_CHAR)
1003 rtlRtn = RTE_scana;
1004 else
1005 rtlRtn = RTE_nscan;
1006 goto make_func_name;
1007 case I_LEN_TRIM:
1008 argt = A_ARGSG(ast);
1009 if (DTY(DDTG(A_DTYPEG(ARGT_ARG(argt, 0)))) == TY_CHAR)
1010 rtlRtn = RTE_lentrima;
1011 else
1012 rtlRtn = RTE_nlentrim;
1013 goto make_func_name;
1014 case I_ILEN:
1015 rtlRtn = RTE_ilen;
1016 goto make_func_name;
1017 #ifdef I_LEADZ
1018 case I_LEADZ:
1019 /* Leadz, popcnt, and poppar are hpf_library and cray
1020 * intrinsics. If the target is a cray, the cray versions supersede
1021 * the hpf versions.
1022 */
1023 if (XBIT(49, 0x1040000)) {
1024 /* T3D/T3E or C90 Cray targets */
1025 put_call(ast, 0, NULL, 0);
1026 break;
1027 }
1028 rtlRtn = RTE_leadz;
1029 goto make_func_name;
1030 #endif
1031 #ifdef I_POPCNT
1032 case I_POPCNT:
1033 if (XBIT(49, 0x1040000)) {
1034 /* T3D/T3E or C90 Cray targets */
1035 put_call(ast, 0, NULL, 0);
1036 break;
1037 }
1038 rtlRtn = RTE_popcnt;
1039 goto make_func_name;
1040 #endif
1041 #ifdef I_POPPAR
1042 case I_POPPAR:
1043 if (XBIT(49, 0x1040000)) {
1044 /* T3D/T3E or C90 Cray targets */
1045 put_call(ast, 0, NULL, 0);
1046 break;
1047 }
1048 rtlRtn = RTE_poppar;
1049 /***** fall thru *****/
1050 #endif
1051 make_func_name:
1052 put_call(ast, 0, mkRteRtnNm(rtlRtn), 0);
1053 break;
1054 case I_RESHAPE:
1055 /* this only occurs if the output is F90 */
1056 argt = A_ARGSG(ast);
1057 put_string(mkRteRtnNm(RTE_reshape));
1058 put_char('(');
1059 print_ast((int)ARGT_ARG(argt, 0));
1060 put_char(',');
1061 print_ast((int)ARGT_ARG(argt, 1));
1062 if (ARGT_ARG(argt, 2)) {
1063 put_char(',');
1064 put_string("pad=");
1065 print_ast((int)ARGT_ARG(argt, 2));
1066 }
1067 if (ARGT_ARG(argt, 3)) {
1068 put_char(',');
1069 put_string("order=");
1070 print_ast((int)ARGT_ARG(argt, 3));
1071 }
1072 put_char(')');
1073 break;
1074 default:
1075 put_call(ast, 0, NULL, 0);
1076 break;
1077 }
1078 break;
1079 case A_ICALL:
1080 if (ast_is_comment) {
1081 put_call(ast, 1, NULL, 0);
1082 break;
1083 }
1084 switch (A_OPTYPEG(ast)) {
1085 case I_MVBITS:
1086 /* call mvbits(from, frompos, len, to, topos)
1087 * becomes
1088 * call RTE_mvbits(from, frompos, len, to, topos,
1089 * szfrom, szfrompos, szlen, sztopos)
1090 */
1091 put_l_to_u("call ");
1092 put_string(mkRteRtnNm(RTE_mvbits));
1093 put_char('(');
1094 argt = A_ARGSG(ast);
1095 for (i = 0; i <= 4; i++) {
1096 print_ast((int)ARGT_ARG(argt, i));
1097 put_char(',');
1098 }
1099 lop = ARGT_ARG(argt, 0); /* size of from/to */
1100 put_int(size_of(DDTG(A_DTYPEG(lop))));
1101 put_char(',');
1102
1103 lop = ARGT_ARG(argt, 1); /* size of frompos */
1104 put_int(size_of(DDTG(A_DTYPEG(lop))));
1105 put_char(',');
1106
1107 lop = ARGT_ARG(argt, 2); /* size of len */
1108 put_int(size_of(DDTG(A_DTYPEG(lop))));
1109 put_char(',');
1110
1111 lop = ARGT_ARG(argt, 4); /* size of topos */
1112 put_int(size_of(DDTG(A_DTYPEG(lop))));
1113
1114 put_char(')');
1115 break;
1116
1117 case I_NULLIFY:
1118 argt = A_ARGSG(ast);
1119 lop = ARGT_ARG(argt, 0);
1120 sym = find_pointer_variable(lop);
1121 gen_nullify(lop, sym, !NO_PTR && STYPEG(sym) == ST_MEMBER);
1122 break;
1123
1124 case I_PTR2_ASSIGN:
1125 argt = A_ARGSG(ast);
1126 cnt = A_ARGCNTG(ast);
1127 lop = ARGT_ARG(argt, 0); /* pointer */
1128 if (A_TYPEG(lop) == A_SUBSCR)
1129 lop = A_LOPG(lop);
1130 sym = find_pointer_variable(lop);
1131 put_l_to_u("call ");
1132 if (DTYG(DTYPEG(sym)) != TY_CHAR)
1133 rtlRtn = cnt == 5 ? RTE_ptr_assign : RTE_ptr_assignx;
1134 else
1135 rtlRtn = cnt == 5 ? RTE_ptr_assign_chara : RTE_ptr_assign_charxa;
1136 put_string(mkRteRtnNm(rtlRtn));
1137 put_char('(');
1138
1139 put_mem_string(lop, SYMNAME(sym));
1140 put_char(',');
1141
1142 lop = ARGT_ARG(argt, 1);
1143 sym = find_pointer_variable(lop);
1144 put_mem_string(lop, SYMNAME(sym)); /* static desciptor */
1145 put_char(',');
1146
1147 lop = ARGT_ARG(argt, 2); /* target */
1148 if (STYPEG(sym) != ST_VAR && A_TYPEG(lop) == A_SUBSCR && A_SHAPEG(lop))
1149 lop = A_LOPG(lop);
1150 print_ast(lop);
1151 put_char(',');
1152
1153 rop = ARGT_ARG(argt, 3); /* target's descriptor */
1154 print_ast(rop);
1155
1156 /* section flag and other datatype arguments */
1157 for (i = 4; i < cnt; ++i) {
1158 put_char(',');
1159 lop = ARGT_ARG(argt, i);
1160 print_ast(lop);
1161 }
1162 if (XBIT(70, 0x20)) {
1163 lop = ARGT_ARG(argt, 1); /* descriptor */
1164 sym = find_pointer_variable(lop);
1165 if (DESCARRAYG(sym) && STYPEG(sym) == ST_MEMBER) {
1166 int osym;
1167 osym = VARIANTG(sym);
1168 if (osym > NOSYM && STYPEG(osym) == ST_MEMBER) {
1169 put_char(',');
1170 print_ast_replaced(lop, sym, osym);
1171 osym = VARIANTG(osym);
1172 if (osym > NOSYM && STYPEG(osym) == ST_MEMBER) {
1173 put_char(',');
1174 print_ast_replaced(lop, sym, osym);
1175 }
1176 }
1177 }
1178 }
1179 put_char(')');
1180 break;
1181
1182 case I_PTR_COPYIN:
1183 /* astout needs to generate the call to copy a pointer in since
1184 * printing the ast of the dummy base will result in a subscript
1185 * reference which includes its offset. The argument needs to be
1186 * passed 'as is' (naked base).
1187 */
1188 argt = A_ARGSG(ast);
1189 sym = A_SPTRG(ARGT_ARG(argt, 3)); /* pointer */
1190 if (DTYG(DTYPEG(sym)) != TY_CHAR)
1191 rtlRtn = RTE_ptr_ina;
1192 else
1193 rtlRtn = RTE_ptr_in_chara;
1194 put_l_to_u("call ");
1195 put_string(mkRteRtnNm(rtlRtn));
1196 put_char('(');
1197 /*
1198 * call pghpf_ptr_in(rank, kind, len, db, dd, ab, ad)
1199 *
1200 * example: call pghpf_ptr_in(1,27,4,p,p$sd,p$bs,p$s0)
1201 *
1202 * argt 0: ast of rank (A_CNST)
1203 * argt 1: ast of kind (A_CNST)
1204 * argt 2: ast of len (A_CNST)
1205 * argt 3: ast of dummy base (A_ID) - naked base
1206 * argt 4: ast of dummy static descriptor (A_ID)
1207 * argt 5: ast of actual base (A_ID)
1208 * argt 6: ast of actual static_descriptor (A_ID)
1209 */
1210 i = 0;
1211 while (TRUE) {
1212 lop = ARGT_ARG(argt, i);
1213 if (i == 3)
1214 put_string(SYMNAME(sym));
1215 else
1216 print_ast(lop);
1217 i++;
1218 if (i >= 7)
1219 break;
1220 put_char(',');
1221 }
1222 if (XBIT(70, 0x20)) {
1223 if (MIDNUMG(sym)) {
1224 put_char(',');
1225 put_string(SYMNAME(MIDNUMG(sym)));
1226 }
1227 if (PTROFFG(sym)) {
1228 put_char(',');
1229 put_string(SYMNAME(PTROFFG(sym)));
1230 }
1231 }
1232 put_char(')');
1233 break;
1234
1235 case I_PTR_COPYOUT:
1236 /* astout needs to generate the call to copy a pointer out since
1237 * printing the ast of the dummy base will result in a subscript
1238 * reference which includes its offset. The argument needs to be
1239 * passed 'as is' (naked base).
1240 */
1241 argt = A_ARGSG(ast);
1242 sym = A_SPTRG(ARGT_ARG(argt, 0)); /* pointer */
1243 put_l_to_u("call ");
1244 if (DTYG(DTYPEG(sym)) != TY_CHAR)
1245 rtlRtn = RTE_ptr_out;
1246 else
1247 rtlRtn = RTE_ptr_out_chara;
1248 put_string(mkRteRtnNm(rtlRtn));
1249 put_char('(');
1250 /*
1251 * call pghpf_ptr_out(ab, ad, db, dd)
1252 *
1253 * example: call pghpf_ptr_out(p$bs, p$s0, p, p$sd)
1254 *
1255 * argt 0: ast of actual base (A_ID) - naked base
1256 * argt 1: ast of actual static descriptor (A_ID)
1257 * argt 2: ast of dummy base (A_ID)
1258 * argt 3: ast of dummy static_descriptor (A_ID)
1259 */
1260 i = 0;
1261 while (TRUE) {
1262 lop = ARGT_ARG(argt, i);
1263 if (i == 0)
1264 put_string(SYMNAME(sym));
1265 else
1266 print_ast(lop);
1267 i++;
1268 if (i >= 4)
1269 break;
1270 put_char(',');
1271 }
1272 if (XBIT(70, 0x20)) {
1273 if (MIDNUMG(sym)) {
1274 put_char(',');
1275 put_string(SYMNAME(MIDNUMG(sym)));
1276 }
1277 if (PTROFFG(sym)) {
1278 put_char(',');
1279 put_string(SYMNAME(PTROFFG(sym)));
1280 }
1281 }
1282 put_char(')');
1283 break;
1284 case I_COPYIN:
1285 /* print naked id as 5th argument */
1286 argt = A_ARGSG(ast);
1287 cnt = A_ARGCNTG(ast);
1288 put_l_to_u("call ");
1289 put_string(mkRteRtnNm(RTE_qopy_in));
1290 put_char('(');
1291 nid = FALSE;
1292 if (XBIT(57, 0x80)) {
1293 int arg2, arg4;
1294 arg2 = ARGT_ARG(argt, 2);
1295 arg4 = ARGT_ARG(argt, 4);
1296 if (arg2 == arg4) {
1297 nid = TRUE;
1298 } else if (A_TYPEG(arg2) == A_SUBSCR && A_LOPG(arg2) == arg4) {
1299 nid = TRUE;
1300 }
1301 }
1302 for (i = 0; i < cnt; ++i) {
1303 if (i)
1304 put_char(',');
1305 lop = ARGT_ARG(argt, i);
1306 if (nid && (i == 2 || i == 4)) {
1307 print_naked_id(lop);
1308 } else {
1309 print_ast(lop);
1310 }
1311 }
1312 put_char(')');
1313 break;
1314 case I_COPYOUT:
1315 /* print naked id as 1st argument */
1316 argt = A_ARGSG(ast);
1317 cnt = A_ARGCNTG(ast);
1318 put_l_to_u("call ");
1319 put_string(mkRteRtnNm(RTE_copy_out));
1320 put_char('(');
1321 nid = FALSE;
1322 if (XBIT(57, 0x80)) {
1323 int arg0, arg1;
1324 arg0 = ARGT_ARG(argt, 0);
1325 arg1 = ARGT_ARG(argt, 1);
1326 if (arg0 == arg1) {
1327 nid = TRUE;
1328 } else if (A_TYPEG(arg1) == A_SUBSCR && A_LOPG(arg1) == arg0) {
1329 nid = TRUE;
1330 }
1331 }
1332 for (i = 0; i < cnt; ++i) {
1333 if (i)
1334 put_char(',');
1335 lop = ARGT_ARG(argt, i);
1336 if (nid && (i == 0 || i == 1)) {
1337 print_naked_id(lop);
1338 } else {
1339 print_ast(lop);
1340 }
1341 }
1342 put_char(')');
1343 break;
1344
1345 default:
1346 put_call(ast, 1, NULL, 0);
1347 break;
1348 }
1349 break;
1350 case A_CALL:
1351 put_call(ast, 1, NULL, 1);
1352 break;
1353 case A_FUNC:
1354 put_call(ast, 0, NULL, 1);
1355 break;
1356 case A_ENTRY:
1357 put_l_to_u("entry ");
1358 print_header((int)A_SPTRG(ast));
1359 if (XBIT(49, 0x1000) && !ast_is_comment)
1360 pghpf_entry((int)A_SPTRG(ast));
1361 break;
1362 case A_ASN:
1363 print_ast((int)A_DESTG(ast));
1364 put_string(" = ");
1365 print_uncoerced_const((int)A_SRCG(ast));
1366 if (XBIT(49, 0x1000000) && !ast_is_comment) {
1367 int sptr = sym_of_ast(A_DESTG(ast));
1368 if (POINTERG(sptr) || TARGETG(sptr)) {
1369 /* ...for T3D/T3E targets, assignment through an F90-pointer
1370 * requires a SUPPRESS directive to suppress node compiler
1371 * optimizations. */
1372 strcpy(lbuff, "cdir$ suppress ");
1373 strcat(lbuff, SYMNAME(sptr));
1374 col = strlen(lbuff);
1375 }
1376 }
1377 break;
1378 case A_IF:
1379 put_l_to_u("if (");
1380 print_ast((int)A_IFEXPRG(ast));
1381 put_string(") ");
1382 print_ast((int)A_IFSTMTG(ast));
1383 break;
1384 case A_IFTHEN:
1385 put_l_to_u("if (");
1386 print_ast((int)A_IFEXPRG(ast));
1387 put_l_to_u(") then");
1388 push_indent();
1389 break;
1390 case A_ELSE:
1391 pop_indent();
1392 put_l_to_u(astb.atypes[atype]);
1393 push_indent();
1394 break;
1395 case A_ELSEIF:
1396 pop_indent();
1397 put_l_to_u("elseif (");
1398 print_ast((int)A_IFEXPRG(ast));
1399 put_l_to_u(") then");
1400 push_indent();
1401 break;
1402 case A_ENDIF:
1403 case A_ENDWHERE:
1404 case A_ENDFORALL:
1405 pop_indent();
1406 goto single_kwd;
1407 case A_AIF:
1408 put_l_to_u("if (");
1409 print_ast((int)A_IFEXPRG(ast));
1410 put_string(") ");
1411 print_ast((int)A_L1G(ast));
1412 put_char(',');
1413 print_ast((int)A_L2G(ast));
1414 put_char(',');
1415 print_ast((int)A_L3G(ast));
1416 break;
1417 case A_GOTO:
1418 put_l_to_u("goto ");
1419 print_ast((int)A_L1G(ast));
1420 break;
1421 case A_CGOTO:
1422 put_l_to_u("goto (");
1423 astli = A_LISTG(ast);
1424 while (TRUE) {
1425 print_ast((int)ASTLI_AST(astli));
1426 astli = ASTLI_NEXT(astli);
1427 if (astli == 0)
1428 break;
1429 put_char(',');
1430 }
1431 put_string(") ");
1432 print_ast((int)A_LOPG(ast));
1433 break;
1434 case A_AGOTO:
1435 put_l_to_u("goto ");
1436 print_ast((int)A_LOPG(ast));
1437 astli = A_LISTG(ast);
1438 if (astli) {
1439 put_string(" (");
1440 while (TRUE) {
1441 print_ast((int)ASTLI_AST(astli));
1442 astli = ASTLI_NEXT(astli);
1443 if (astli == 0)
1444 break;
1445 put_char(',');
1446 }
1447 put_char(')');
1448 }
1449 break;
1450 case A_ASNGOTO:
1451 lop = A_SRCG(ast);
1452 assert(A_TYPEG(lop) == A_LABEL, "print_ast, src A_ASNGOTO not label", lop,
1453 3);
1454 if ((i = FMTPTG(A_SPTRG(lop))) && !ast_is_comment) {
1455 print_ast((int)A_DESTG(ast));
1456 put_string(" = ");
1457 print_loc_of_sym(i);
1458 } else {
1459 put_l_to_u("assign ");
1460 print_ast((int)A_SRCG(ast));
1461 put_l_to_u(" to ");
1462 print_ast((int)A_DESTG(ast));
1463 }
1464 break;
1465 case A_DO:
1466 put_l_to_u("do ");
1467 if (A_DOLABG(ast)) {
1468 print_ast((int)A_DOLABG(ast));
1469 put_char(' ');
1470 }
1471 print_ast((int)A_DOVARG(ast));
1472 put_string(" = ");
1473 print_uncoerced_const((int)A_M1G(ast));
1474 put_string(", ");
1475 print_uncoerced_const((int)A_M2G(ast));
1476 if (A_M3G(ast) && A_M3G(ast) != astb.i1) {
1477 put_string(", ");
1478 print_uncoerced_const((int)A_M3G(ast));
1479 }
1480 push_indent(); /* BLOCKDO */
1481 break;
1482 case A_DOWHILE:
1483 put_l_to_u("do ");
1484 if (A_DOLABG(ast)) {
1485 print_ast((int)A_DOLABG(ast));
1486 put_char(' ');
1487 }
1488 put_l_to_u("while ");
1489 put_char('(');
1490 print_ast((int)A_IFEXPRG(ast));
1491 put_char(')');
1492 push_indent(); /* BLOCKDO */
1493 break;
1494 case A_ENDDO:
1495 pop_indent(); /* BLOCKDO */
1496 goto single_kwd;
1497 case A_CONTINUE:
1498 goto single_kwd;
1499 case A_END:
1500 if (ast_is_comment)
1501 goto single_kwd;
1502 if (gbl.rutype != RU_BDATA && XBIT(49, 0x1000)) {
1503 /* pghpf_function_exit() */
1504 put_l_to_u("call ");
1505 put_string(mkRteRtnNm(RTE_function_exit));
1506 put_string("()");
1507 }
1508 if (gbl.rutype == RU_PROG) {
1509 put_l_to_u("call ");
1510 put_string(mkRteRtnNm(RTE_exit));
1511 put_string("(0)");
1512 }
1513 if (gbl.internal == 1) {
1514 put_l_to_u("contains");
1515 break;
1516 }
1517 if (gbl.internal) {
1518 switch (gbl.rutype) {
1519 case RU_PROG:
1520 put_l_to_u("endprogram");
1521 break;
1522 case RU_SUBR:
1523 put_l_to_u("endsubroutine");
1524 break;
1525 case RU_FUNC:
1526 put_l_to_u("endfunction");
1527 break;
1528 default:
1529 put_l_to_u("end");
1530 break;
1531 }
1532 break;
1533 }
1534 goto single_kwd;
1535 case A_STOP:
1536 put_l_to_u("stop");
1537 goto stop_pause;
1538 case A_PAUSE:
1539 put_l_to_u("pause");
1540 stop_pause:
1541 if (A_LOPG(ast)) {
1542 put_char(' ');
1543 print_ast((int)A_LOPG(ast));
1544 }
1545 break;
1546 case A_RETURN:
1547 put_l_to_u("return");
1548 if (A_LOPG(ast)) {
1549 put_char(' ');
1550 print_ast((int)A_LOPG(ast));
1551 }
1552 break;
1553 case A_ALLOC:
1554 /* For standard f77 output, always generate calls to the
1555 * allocate/deallocate run-time routines. Otherwise, watch
1556 * for allocating allocatable arrays from a MODULE or
1557 * POINTERs; deallocate isn't necessary for MODULE allocatable
1558 * arrays if the output is pgftn since pgftn allows
1559 * deallocation of a pointer-based array. */
1560 if (!ast_is_comment) {
1561 object = A_SRCG(ast);
1562 if (A_TYPEG(object) == A_SUBSCR) {
1563 sym = find_pointer_variable(A_LOPG(object));
1564 } else {
1565 sym = find_pointer_variable(object);
1566 }
1567 if (!F90POINTERG(sym)) {
1568 if (A_TKNG(ast) == TK_ALLOCATE) {
1569 int array = 0;
1570 if (sym && DTY(DTYPEG(sym)) == TY_ARRAY) {
1571 array = 1;
1572 }
1573 if (F77OUTPUT || POINTERG(sym) ||
1574 (array && (MDALLOCG(sym) || PTROFFG(sym))) ||
1575 (!array && ADJLENG(sym))) {
1576 gen_allocate(object, (int)A_LOPG(ast));
1577 return;
1578 }
1579 } else {
1580 /* watch for deallocating a POINTER */
1581 if (STYPEG(sym) == ST_MEMBER) {
1582 gen_deallocate(object, (int)A_LOPG(ast), sym, !NO_PTR);
1583 return;
1584 }
1585 if (F77OUTPUT || (POINTERG(sym) || ADJLENG(sym))) {
1586 gen_deallocate(object, (int)A_LOPG(ast), sym, 0);
1587 return;
1588 }
1589 }
1590 }
1591 }
1592 put_u_to_l(tokname[A_TKNG(ast)]);
1593 put_char('(');
1594 print_ast((int)A_SRCG(ast));
1595 if (A_LOPG(ast)) {
1596 put_l_to_u(", stat=");
1597 print_ast((int)A_LOPG(ast));
1598 }
1599 if (A_DESTG(ast)) {
1600 put_l_to_u(", pinned=");
1601 print_ast((int)A_DESTG(ast));
1602 }
1603 if (A_M3G(ast)) {
1604 put_l_to_u(", errmsg=");
1605 print_ast((int)A_M3G(ast));
1606 }
1607 if (A_STARTG(ast)) {
1608 put_l_to_u(", source=");
1609 print_ast((int)A_STARTG(ast));
1610 }
1611 if (A_FIRSTALLOCG(ast))
1612 put_string(", firstalloc");
1613 if (A_DALLOCMEMG(ast))
1614 put_string(", dallocmem");
1615 if (A_DEVSRCG(ast)) {
1616 put_string(", devsrc=");
1617 print_ast(A_DEVSRCG(ast));
1618 }
1619 if (A_ALIGNG(ast)) {
1620 put_string(", align=");
1621 print_ast(A_ALIGNG(ast));
1622 }
1623 put_char(')');
1624 if (!ast_is_comment && A_TKNG(ast) == TK_DEALLOCATE) {
1625 int sptr, object = A_SRCG(ast);
1626 if (A_TYPEG(object) == A_ID) {
1627 sptr = A_SPTRG(object);
1628 if (MIDNUMG(sptr) && !CCSYMG(MIDNUMG(sptr))) {
1629 put_string(SYMNAME(MIDNUMG(sptr)));
1630 put_string(" = 0");
1631 }
1632 } else if (A_TYPEG(object) == A_MEM) {
1633 sptr = A_SPTRG(A_MEMG(object));
1634 if (MIDNUMG(sptr) && !CCSYMG(MIDNUMG(sptr))) {
1635 print_ast_replaced(object, sptr, MIDNUMG(sptr));
1636 put_string(" = 0");
1637 }
1638 }
1639 }
1640 break;
1641 case A_WHERE:
1642 put_l_to_u("where (");
1643 print_ast((int)A_IFEXPRG(ast));
1644 put_char(')');
1645 if (A_IFSTMTG(ast)) {
1646 print_ast((int)A_IFSTMTG(ast));
1647 break;
1648 }
1649 push_indent();
1650 break;
1651 case A_ELSEFORALL:
1652 pop_indent();
1653 put_l_to_u("elseforall");
1654 push_indent();
1655 break;
1656 case A_ELSEWHERE:
1657 pop_indent();
1658 put_l_to_u("elsewhere");
1659 push_indent();
1660 break;
1661 case A_FORALL:
1662 put_l_to_u("forall (");
1663 astli = A_LISTG(ast);
1664 while (TRUE) {
1665 put_string(SYMNAME(ASTLI_SPTR(astli)));
1666 put_char('=');
1667 print_ast((int)ASTLI_TRIPLE(astli));
1668 astli = ASTLI_NEXT(astli);
1669 if (astli == 0)
1670 break;
1671 put_string(", ");
1672 }
1673 if (A_IFEXPRG(ast)) {
1674 put_string(", ");
1675 print_ast((int)A_IFEXPRG(ast));
1676 }
1677 put_char(')');
1678 if (A_IFSTMTG(ast)) {
1679 put_char(' ');
1680 print_ast((int)A_IFSTMTG(ast));
1681 break;
1682 }
1683 push_indent();
1684 break;
1685 single_kwd:
1686 put_l_to_u(astb.atypes[atype]);
1687 break;
1688 case A_REDIM:
1689 if ((F77OUTPUT || PTROFFG(memsym_of_ast(A_SRCG(ast)))) && !ast_is_comment) {
1690 /* for standard f77 output, generate assign the values implied
1691 * by the explict shape to the array's bound temporaries.
1692 */
1693 gen_bnd_assn((int)A_SRCG(ast));
1694 return;
1695 }
1696 put_l_to_u("redimension ");
1697 print_ast((int)A_SRCG(ast));
1698 break;
1699 case A_COMMENT:
1700 save_comment = ast_is_comment;
1701 ast_is_comment = TRUE;
1702 lbuff[0] = '!';
1703 print_ast((int)A_LOPG(ast));
1704 ast_is_comment = save_comment;
1705 break;
1706 case A_COMSTR: {
1707 /* raw output -- watch for newlines */
1708 char ch;
1709
1710 o = COMSTR(ast);
1711 col = 0;
1712 while ((ch = *o++)) {
1713 if (ch == '\n') {
1714 col = 0;
1715 } else
1716 lbuff[col++] = ch;
1717 }
1718 } break;
1719 case A_REALIGN:
1720 put_string("realign ");
1721 print_ast((int)A_LOPG(ast));
1722 put_string(" with alndsc ");
1723 put_int((INT)A_DTYPEG(ast));
1724 break;
1725 case A_REDISTRIBUTE:
1726 put_string("redistribute ");
1727 print_ast((int)A_LOPG(ast));
1728 put_string(" with dstdsc ");
1729 put_int((INT)A_DTYPEG(ast));
1730 break;
1731 case A_HLOCALIZEBNDS:
1732 put_string("hlocalizebnds(");
1733 if (A_LOPG(ast))
1734 print_ast((int)A_LOPG(ast));
1735 put_char(',');
1736 if (A_ITRIPLEG(ast))
1737 print_ast((int)A_ITRIPLEG(ast));
1738 put_char(',');
1739 if (A_OTRIPLEG(ast))
1740 print_ast((int)A_OTRIPLEG(ast));
1741 put_char(',');
1742 if (A_DIMG(ast))
1743 print_ast((int)A_DIMG(ast));
1744 put_char(')');
1745 break;
1746 case A_HALLOBNDS:
1747 put_string("hallobnds(");
1748 if (A_LOPG(ast))
1749 print_ast((int)A_LOPG(ast));
1750 put_char(')');
1751 break;
1752 case A_HCYCLICLP:
1753 put_string("hcycliclp(");
1754 if (A_LOPG(ast))
1755 print_ast((int)A_LOPG(ast));
1756 put_char(',');
1757 if (A_ITRIPLEG(ast))
1758 print_ast((int)A_ITRIPLEG(ast));
1759 put_char(',');
1760 if (A_OTRIPLEG(ast))
1761 print_ast((int)A_OTRIPLEG(ast));
1762 put_char(',');
1763 if (A_OTRIPLE1G(ast))
1764 print_ast((int)A_OTRIPLE1G(ast));
1765 put_char(',');
1766 if (A_DIMG(ast))
1767 print_ast((int)A_DIMG(ast));
1768 put_char(')');
1769 break;
1770 case A_HOFFSET:
1771 sym = memsym_of_ast(A_LOPG(ast)); /* pointer-based object */
1772 if (NO_PTR || (NO_CHARPTR && DTYG(DTYPEG(sym)) == TY_CHAR) ||
1773 (NO_DERIVEDPTR && DTYG(DTYPEG(sym)) == TY_DERIVED)) {
1774 put_l_to_u("call ");
1775 put_string(mkRteRtnNm(RTE_ptr_offset));
1776 put_char('(');
1777 print_ast((int)A_DESTG(ast)); /* name of pointer or offset
1778 * variable */
1779 put_char(',');
1780 print_ast((int)A_ROPG(ast)); /* name of pointer variable */
1781 put_char(',');
1782 print_ast((int)A_LOPG(ast)); /* name of object */
1783 put_char(',');
1784 if (PTRVG(sym))
1785 i = DT_PTR;
1786 else
1787 i = DTYG(DTYPEG(sym));
1788 put_int((INT)ty_to_lib[i]); /* run-time 'kind' of object */
1789 put_char(')');
1790 }
1791 break;
1792 case A_HSECT:
1793 put_string("hsect(");
1794 if (A_LOPG(ast))
1795 print_ast((int)A_LOPG(ast));
1796 put_char(',');
1797 if (A_BVECTG(ast))
1798 print_ast((int)A_BVECTG(ast));
1799 put_char(')');
1800 break;
1801 case A_HCOPYSECT:
1802 put_string("hcopysect(");
1803 if (A_DESTG(ast))
1804 print_ast((int)A_DESTG(ast));
1805 put_char(',');
1806 if (A_SRCG(ast))
1807 print_ast((int)A_SRCG(ast));
1808 put_char(',');
1809 if (A_DDESCG(ast))
1810 print_ast((int)A_DDESCG(ast));
1811 put_char(',');
1812 if (A_SDESCG(ast))
1813 print_ast((int)A_SDESCG(ast));
1814 put_char(')');
1815 break;
1816 case A_HPERMUTESECT:
1817 put_string("hpermutesect(");
1818 if (A_DESTG(ast))
1819 print_ast((int)A_DESTG(ast));
1820 put_char(',');
1821 if (A_SRCG(ast))
1822 print_ast((int)A_SRCG(ast));
1823 put_char(',');
1824 if (A_DDESCG(ast))
1825 print_ast((int)A_DDESCG(ast));
1826 put_char(',');
1827 if (A_SDESCG(ast))
1828 print_ast((int)A_SDESCG(ast));
1829 put_char(',');
1830 if (A_BVECTG(ast))
1831 print_ast((int)A_BVECTG(ast));
1832 put_char(')');
1833 break;
1834 case A_HOVLPSHIFT:
1835 put_string("hovlpshift(");
1836 if (A_SRCG(ast))
1837 print_ast((int)A_SRCG(ast));
1838 put_char(',');
1839 if (A_SDESCG(ast))
1840 print_ast((int)A_SDESCG(ast));
1841 put_char(')');
1842 break;
1843 case A_HGETSCLR:
1844 put_string("hgetsclr(");
1845 if (A_DESTG(ast))
1846 print_ast((int)A_DESTG(ast));
1847 put_char(',');
1848 if (A_SRCG(ast))
1849 print_ast((int)A_SRCG(ast));
1850 if (A_LOPG(ast)) {
1851 put_char(',');
1852 print_ast((int)A_LOPG(ast));
1853 }
1854 put_char(')');
1855 break;
1856 case A_HGATHER:
1857 put_string("hgather(");
1858 goto hscat;
1859 case A_HSCATTER:
1860 put_string("hscatter(");
1861 hscat:
1862 if (A_VSUBG(ast))
1863 print_ast((int)A_VSUBG(ast));
1864 put_char(',');
1865 if (A_DESTG(ast))
1866 print_ast((int)A_DESTG(ast));
1867 put_char(',');
1868 if (A_SRCG(ast))
1869 print_ast((int)A_SRCG(ast));
1870 put_char(',');
1871 if (A_DDESCG(ast))
1872 print_ast((int)A_DDESCG(ast));
1873 put_char(',');
1874 if (A_SDESCG(ast))
1875 print_ast((int)A_SDESCG(ast));
1876 put_char(',');
1877 if (A_MDESCG(ast))
1878 print_ast((int)A_MDESCG(ast));
1879 put_char(',');
1880 if (A_BVECTG(ast))
1881 print_ast((int)A_BVECTG(ast));
1882 put_char(')');
1883 break;
1884 case A_HCSTART:
1885 put_string("hcstart(");
1886 if (A_LOPG(ast))
1887 print_ast((int)A_LOPG(ast));
1888 put_char(',');
1889 if (A_DESTG(ast))
1890 print_ast((int)A_DESTG(ast));
1891 put_char(',');
1892 if (A_SRCG(ast))
1893 print_ast((int)A_SRCG(ast));
1894 put_char(')');
1895 break;
1896 case A_HCFINISH:
1897 put_string("hcfinish(");
1898 goto hcfree;
1899 case A_HCFREE:
1900 put_string("hcfree(");
1901 hcfree:
1902 if (A_LOPG(ast))
1903 print_ast((int)A_LOPG(ast));
1904 put_char(')');
1905 break;
1906 case A_HOWNERPROC:
1907 put_string("hownerproc(");
1908 print_ast(A_LOPG(ast));
1909 if (A_DIMG(ast)) {
1910 put_char(',');
1911 print_ast(A_DIMG(ast));
1912 put_char(',');
1913 print_ast(A_M1G(ast));
1914 put_char(',');
1915 print_ast(A_M2G(ast));
1916 }
1917 put_char(')');
1918 break;
1919 case A_HLOCALOFFSET:
1920 put_string("hlocaloffset(");
1921 print_ast(A_LOPG(ast));
1922 put_char(')');
1923 break;
1924 case A_MASTER:
1925 lbuff[0] = '!';
1926 put_string("master");
1927 break;
1928 case A_ENDMASTER:
1929 lbuff[0] = '!';
1930 cnt = A_ARGCNTG(ast);
1931 put_string("end master");
1932 if (cnt) {
1933 save_comment = ast_is_comment;
1934 ast_is_comment = TRUE;
1935 put_string(", copy(");
1936 argt = A_ARGSG(ast);
1937 for (i = 0; i < cnt; ++i) {
1938 if (i)
1939 put_char(',');
1940 lop = ARGT_ARG(argt, i);
1941 print_ast(lop);
1942 }
1943 put_char(')');
1944 ast_is_comment = save_comment;
1945 }
1946 break;
1947 case A_CRITICAL:
1948 lbuff[0] = '!';
1949 put_string("critical");
1950 break;
1951 case A_ENDCRITICAL:
1952 lbuff[0] = '!';
1953 put_string("end critical");
1954 break;
1955 case A_ATOMIC:
1956 lbuff[0] = '!';
1957 put_string("atomic update ");
1958 goto ast_atomic_common;
1959 case A_ATOMICCAPTURE:
1960 lbuff[0] = '!';
1961 put_string("atomic capture ");
1962 goto ast_atomic_common;
1963 case A_ATOMICREAD:
1964 lbuff[0] = '!';
1965 put_string("atomic read ");
1966 goto ast_atomic_common;
1967 case A_ATOMICWRITE:
1968 lbuff[0] = '!';
1969 put_string("atomic write ");
1970 ast_atomic_common:
1971 if (A_LOPG(ast)) {
1972 save_comment = ast_is_comment;
1973 ast_is_comment = TRUE;
1974 print_ast(A_LOPG(ast));
1975 ast_is_comment = save_comment;
1976 }
1977 break;
1978 case A_ENDATOMIC:
1979 lbuff[0] = '!';
1980 put_string("end atomic ");
1981 break;
1982 case A_MP_ATOMIC:
1983 case A_MP_ENDATOMIC:
1984 break;
1985 case A_MP_ATOMICREAD:
1986 lbuff[0] = '!';
1987 if (A_SRCG(ast)) {
1988 put_string(" src:");
1989 print_ast(A_SRCG(ast));
1990 }
1991 break;
1992 case A_MP_ATOMICWRITE:
1993 lbuff[0] = '!';
1994 put_string(astb.atypes[atype]);
1995 if (A_LOPG(ast)) {
1996 put_char(',');
1997 put_string(" lop:");
1998 print_ast(A_LOPG(ast));
1999 }
2000 put_char(',');
2001 if (A_ROPG(ast)) {
2002 put_string(" rop:");
2003 print_ast(A_ROPG(ast));
2004 }
2005 if (A_MEM_ORDERG(ast)) {
2006 put_string(" mem_order(");
2007 print_ast(A_MEM_ORDERG(ast));
2008 put_string(")");
2009 }
2010 break;
2011 case A_MP_ATOMICUPDATE:
2012 case A_MP_ATOMICCAPTURE:
2013 lbuff[0] = '!';
2014 put_string(astb.atypes[atype]);
2015 if (A_LOPG(ast)) {
2016 put_string(" lop:");
2017 print_ast(A_LOPG(ast));
2018 }
2019 put_char(',');
2020 if (A_ROPG(ast)) {
2021 put_string(" rop:");
2022 print_ast(A_ROPG(ast));
2023 }
2024 put_char(',');
2025 if (A_MEM_ORDERG(ast)) {
2026 put_string(" mem_order(");
2027 print_ast(A_MEM_ORDERG(ast));
2028 put_string(")");
2029 }
2030 break;
2031
2032 case A_BARRIER:
2033 put_l_to_u("call ");
2034 put_string(mkRteRtnNm(RTE_barrier));
2035 put_string("()");
2036 break;
2037 case A_NOBARRIER:
2038 lbuff[0] = '!';
2039 put_string("no barrier");
2040 break;
2041 case A_MP_PARALLEL:
2042 lbuff[0] = '!';
2043 put_string(astb.atypes[atype]);
2044 if (A_IFPARG(ast)) {
2045 put_string(" if(");
2046 print_ast(A_IFPARG(ast));
2047 put_string(")");
2048 }
2049 if (A_NPARG(ast)) {
2050 put_string(" num_threads(");
2051 print_ast(A_NPARG(ast));
2052 put_string(")");
2053 }
2054 if (A_ENDLABG(ast)) {
2055 put_string(" endlab(");
2056 print_ast(A_ENDLABG(ast));
2057 put_string(")");
2058 }
2059 if (A_PROCBINDG(ast)) {
2060 put_string(" procbind(");
2061 print_ast(A_PROCBINDG(ast));
2062 put_string(")");
2063 }
2064 break;
2065 case A_MP_BMPSCOPE:
2066 lbuff[0] = '!';
2067 put_string(astb.atypes[atype]);
2068 if (A_STBLKG(ast)) {
2069 put_string(" st_block(");
2070 print_ast(A_STBLKG(ast));
2071 put_string(")");
2072 }
2073 break;
2074 case A_MP_TASK:
2075 lbuff[0] = '!';
2076 put_string(astb.atypes[atype]);
2077 if (A_IFPARG(ast)) {
2078 put_string(" if(");
2079 print_ast(A_IFPARG(ast));
2080 put_string(")");
2081 }
2082 if (A_FINALPARG(ast)) {
2083 put_string(" final(");
2084 print_ast(A_FINALPARG(ast));
2085 put_string(")");
2086 }
2087 if (A_PRIORITYG(ast)) {
2088 put_string(" priority(");
2089 print_ast(A_PRIORITYG(ast));
2090 put_string(")");
2091 }
2092 if (A_UNTIEDG(ast)) {
2093 put_string(",untied");
2094 }
2095 if (A_EXEIMMG(ast))
2096 put_string(",exeimm");
2097 if (A_ENDLABG(ast))
2098 print_ast(A_ENDLABG(ast));
2099 break;
2100 case A_MP_TASKLOOPREG:
2101 lbuff[0] = '!';
2102 put_string(astb.atypes[atype]);
2103 if (A_M1G(ast)) {
2104 put_string(" lb(");
2105 print_ast(A_M1G(ast));
2106 put_string(")");
2107 }
2108 if (A_M2G(ast)) {
2109 put_string(" ub(");
2110 print_ast(A_M2G(ast));
2111 put_string(")");
2112 }
2113 if (A_M3G(ast)) {
2114 put_string(" st(");
2115 print_ast(A_M3G(ast));
2116 put_string(")");
2117 }
2118 break;
2119 case A_MP_TASKLOOP:
2120 lbuff[0] = '!';
2121 put_string(astb.atypes[atype]);
2122 if (A_IFPARG(ast)) {
2123 put_string(" if(");
2124 print_ast(A_IFPARG(ast));
2125 put_string(")");
2126 }
2127 if (A_FINALPARG(ast)) {
2128 put_string(" final(");
2129 print_ast(A_FINALPARG(ast));
2130 put_string(")");
2131 }
2132 if (A_PRIORITYG(ast)) {
2133 put_string(" priority(");
2134 print_ast(A_PRIORITYG(ast));
2135 put_string(")");
2136 }
2137 if (A_UNTIEDG(ast)) {
2138 put_string(",untied");
2139 }
2140 if (A_NOGROUPG(ast)) {
2141 put_string(",nogroup");
2142 }
2143 if (A_GRAINSIZEG(ast)) {
2144 put_string(",grainsize");
2145 }
2146 if (A_NUM_TASKSG(ast)) {
2147 put_string(",num_tasks");
2148 }
2149 if (A_EXEIMMG(ast))
2150 put_string(",exeimm");
2151 if (A_ENDLABG(ast))
2152 print_ast(A_ENDLABG(ast));
2153 break;
2154 case A_MP_TASKFIRSTPRIV:
2155 lbuff[0] = '!';
2156 put_string(astb.atypes[atype]);
2157 if (A_LOPG(ast)) {
2158 put_string(" lop(");
2159 print_ast(A_LOPG(ast));
2160 put_string(")");
2161 }
2162 if (A_ROPG(ast)) {
2163 put_string(" rop(");
2164 print_ast(A_ROPG(ast));
2165 put_string(")");
2166 }
2167 break;
2168
2169 case A_MP_TARGET:
2170 case A_MP_TARGETDATA:
2171 case A_MP_TARGETEXITDATA:
2172 case A_MP_TARGETENTERDATA:
2173 case A_MP_TARGETUPDATE:
2174 lbuff[0] = '!';
2175 put_string(astb.atypes[atype]);
2176 if (A_IFPARG(ast)) {
2177 put_string(" if(");
2178 print_ast(A_IFPARG(ast));
2179 put_string(")");
2180 }
2181 break;
2182
2183 case A_MP_CANCEL:
2184 lbuff[0] = '!';
2185 put_string(astb.atypes[atype]);
2186 if (A_IFPARG(ast)) {
2187 put_string(" if(");
2188 print_ast(A_IFPARG(ast));
2189 put_string(")");
2190 }
2191 if (A_ENDLABG(ast)) {
2192 put_string(" endlab(");
2193 print_ast(A_ENDLABG(ast));
2194 put_string(")");
2195 }
2196 break;
2197 case A_MP_SECTIONS:
2198 case A_MP_CANCELLATIONPOINT:
2199 lbuff[0] = '!';
2200 put_string(astb.atypes[atype]);
2201 if (A_ENDLABG(ast)) {
2202 put_string(" endlab(");
2203 print_ast(A_ENDLABG(ast));
2204 put_string(")");
2205 }
2206 break;
2207 case A_MP_TASKREG:
2208 case A_MP_TASKDUP:
2209 case A_MP_ENDTARGET:
2210 case A_MP_ENDTARGETDATA:
2211 case A_MP_TEAMS:
2212 case A_MP_ENDTEAMS:
2213 case A_MP_DISTRIBUTE:
2214 case A_MP_ENDDISTRIBUTE:
2215 case A_MP_TASKGROUP:
2216 case A_MP_ETASKGROUP:
2217 case A_MP_ENDPARALLEL:
2218 case A_MP_BARRIER:
2219 case A_MP_ETASKDUP:
2220 case A_MP_TASKWAIT:
2221 case A_MP_TASKYIELD:
2222 case A_MP_ENDSECTIONS:
2223 case A_MP_SECTION:
2224 case A_MP_LSECTION:
2225 case A_MP_SINGLE:
2226 case A_MP_ENDSINGLE:
2227 case A_MP_MASTER:
2228 case A_MP_ENDMASTER:
2229 case A_MP_BCOPYIN:
2230 case A_MP_ECOPYIN:
2231 case A_MP_BCOPYPRIVATE:
2232 case A_MP_WORKSHARE:
2233 case A_MP_ENDWORKSHARE:
2234 case A_MP_BPDO:
2235 case A_MP_EPDO:
2236 case A_MP_BORDERED:
2237 case A_MP_EORDERED:
2238 case A_MP_ENDTASK:
2239 case A_MP_ETASKLOOP:
2240 case A_MP_EMPSCOPE:
2241 case A_MP_FLUSH:
2242 case A_MP_ETASKLOOPREG:
2243 lbuff[0] = '!';
2244 put_string(astb.atypes[atype]);
2245 break;
2246 case A_MP_TARGETLOOPTRIPCOUNT:
2247 put_string("target loop tripcount");
2248 break;
2249 case A_MP_MAP:
2250 put_string("map");
2251 break;
2252 case A_MP_EMAP:
2253 put_string("end map");
2254 break;
2255 case A_MP_BREDUCTION:
2256 put_string("begin reduction");
2257 break;
2258 case A_MP_EREDUCTION:
2259 put_string("end reduction");
2260 break;
2261 case A_MP_CRITICAL:
2262 case A_MP_ENDCRITICAL:
2263 lbuff[0] = '!';
2264 put_string(astb.atypes[atype]);
2265 if (A_MEMG(ast)) {
2266 put_char(' ');
2267 put_string(SYMNAME(A_MEMG(ast)));
2268 }
2269 break;
2270 case A_MP_PRE_TLS_COPY:
2271 lbuff[0] = '!';
2272 put_string("pre_tls_copy ");
2273 sym = A_SPTRG(ast);
2274 if (STYPEG(sym) == ST_CMBLK) {
2275 put_string("/");
2276 print_sname(sym);
2277 put_string("/");
2278 } else
2279 put_string(SYMNAME(sym));
2280 put_string(",size=");
2281 print_ast(A_ROPG(ast));
2282 break;
2283 case A_MP_COPYIN:
2284 lbuff[0] = '!';
2285 put_string("copyin ");
2286 sym = A_SPTRG(ast);
2287 if (STYPEG(sym) == ST_CMBLK) {
2288 put_string("/");
2289 print_sname(sym);
2290 put_string("/");
2291 } else
2292 put_string(SYMNAME(sym));
2293 put_string(",size=");
2294 print_ast(A_ROPG(ast));
2295 break;
2296 case A_MP_COPYPRIVATE:
2297 lbuff[0] = '!';
2298 put_string("copyprivate ");
2299 sym = A_SPTRG(ast);
2300 if (STYPEG(sym) == ST_CMBLK) {
2301 put_string("/");
2302 print_sname(sym);
2303 put_string("/");
2304 } else
2305 put_string(SYMNAME(sym));
2306 put_string(",size=");
2307 print_ast(A_ROPG(ast));
2308 break;
2309 case A_MP_PDO:
2310 lbuff[0] = '!';
2311 put_string("pdo");
2312 put_string(",sched=");
2313 put_intkind(A_SCHED_TYPEG(ast), DT_INT4);
2314 if (A_CHUNKG(ast)) {
2315 put_string(",chunk=");
2316 print_ast(A_CHUNKG(ast));
2317 }
2318 if (A_ORDEREDG(ast)) {
2319 put_string(",ordered");
2320 }
2321 if (A_ENDLABG(ast)) {
2322 print_ast(A_ENDLABG(ast));
2323 }
2324 A_TYPEP(ast, A_DO);
2325 print_ast(ast);
2326 A_TYPEP(ast, A_MP_PDO);
2327 break;
2328 case A_MP_ENDPDO:
2329 pop_indent(); /* BLOCKDO */
2330 lbuff[0] = '!';
2331 put_string("endpdo");
2332 break;
2333 case A_PREFETCH:
2334 lbuff[0] = '!';
2335 put_string("prefetch ");
2336 print_ast(A_LOPG(ast));
2337 break;
2338 case A_PRAGMA:
2339 lbuff[0] = '!';
2340 lbuff[1] = 'p';
2341 lbuff[2] = 'g';
2342 lbuff[3] = 'i';
2343 lbuff[4] = '$';
2344 switch (A_PRAGMASCOPEG(ast)) {
2345 case PR_NOSCOPE:
2346 lbuff[5] = ' ';
2347 break;
2348 case PR_GLOBAL:
2349 lbuff[5] = 'g';
2350 break;
2351 case PR_ROUTINE:
2352 lbuff[5] = 'r';
2353 break;
2354 case PR_LOOP:
2355 lbuff[5] = 'l';
2356 break;
2357 case PR_LINE:
2358 lbuff[5] = 'n';
2359 break;
2360 }
2361 switch (A_PRAGMATYPEG(ast)) {
2362 case PR_NONE:
2363 print_ast(A_LOPG(ast));
2364 break;
2365 case PR_INLININGON:
2366 put_string("inline on");
2367 break;
2368 case PR_INLININGOFF:
2369 put_string("inline off");
2370 break;
2371 case PR_ALWAYSINLINE:
2372 put_string("inline always");
2373 break;
2374 case PR_NEVERINLINE:
2375 put_string("inline never");
2376 break;
2377 case PR_ACCBEGINDIR:
2378 acc_pragma(ast);
2379 put_string("begindir");
2380 break;
2381 case PR_ACCIMPDATAREG:
2382 acc_pragma(ast);
2383 put_string("implicit data region");
2384 break;
2385 case PR_ACCIMPDATAREGX:
2386 acc_pragma(ast);
2387 put_string("implicit data region(necessary)");
2388 break;
2389 case PR_ACCDATAREG:
2390 acc_pragma(ast);
2391 put_string("data");
2392 break;
2393 case PR_ACCHOSTDATA:
2394 acc_pragma(ast);
2395 put_string("host_data");
2396 break;
2397 case PR_ACCSCALARREG:
2398 acc_pragma(ast);
2399 put_string("scalar region");
2400 break;
2401 case PR_ACCSERIAL:
2402 acc_pragma(ast);
2403 put_string("serial");
2404 break;
2405 case PR_ACCENDSERIAL:
2406 acc_pragma(ast);
2407 put_string("end serial");
2408 break;
2409 case PR_ACCEL:
2410 acc_pragma(ast);
2411 put_string("region");
2412 break;
2413 case PR_ENDACCEL:
2414 acc_pragma(ast);
2415 put_string("end region");
2416 break;
2417 case PR_ACCENTERDATA:
2418 acc_pragma(ast);
2419 put_string("enter data");
2420 break;
2421 case PR_ACCEXITDATA:
2422 acc_pragma(ast);
2423 put_string("exit data");
2424 break;
2425 case PR_ACCFINALEXITDATA:
2426 acc_pragma(ast);
2427 put_string("exit data finalize");
2428 break;
2429 case PR_ACCENDDATAREG:
2430 acc_pragma(ast);
2431 put_string("end data");
2432 break;
2433 case PR_ACCENDHOSTDATA:
2434 acc_pragma(ast);
2435 put_string("end host_data");
2436 break;
2437 case PR_ACCENDSCALARREG:
2438 acc_pragma(ast);
2439 put_string("end scalar region");
2440 break;
2441 case PR_ACCENDIMPDATAREG:
2442 acc_pragma(ast);
2443 put_string("end implicit data region(");
2444 put_int(A_PRAGMAVALG(ast));
2445 put_string(")");
2446 break;
2447 case PR_INLINEONLY:
2448 put_string("inline only");
2449 break;
2450 case PR_INLINETYPE:
2451 put_string("inline type");
2452 break;
2453 case PR_INLINEAS:
2454 put_string("inline as");
2455 break;
2456 case PR_INLINEALIGN:
2457 put_string("inline align");
2458 break;
2459 case PR_ACCUPDATE:
2460 acc_pragma(ast);
2461 put_string("update");
2462 break;
2463 case PR_PCASTCOMPARE:
2464 acc_pragma(ast);
2465 put_string("comp");
2466 break;
2467 case PR_ACCWAIT:
2468 acc_pragma(ast);
2469 put_string("wait");
2470 break;
2471 case PR_ACCNOWAIT:
2472 acc_pragma(ast);
2473 acc_dtype(ast);
2474 put_string("nowait");
2475 break;
2476 case PR_ACCKERNELS:
2477 acc_pragma(ast);
2478 put_string("kernels");
2479 break;
2480 case PR_ACCENDKERNELS:
2481 acc_pragma(ast);
2482 put_string("end kernels");
2483 break;
2484 case PR_ACCPARCONSTRUCT:
2485 acc_pragma(ast);
2486 put_string("parallel");
2487 break;
2488 case PR_ACCENDPARCONSTRUCT:
2489 acc_pragma(ast);
2490 put_string("end parallel");
2491 break;
2492 case PR_ACCINDEPENDENT:
2493 acc_pragma(ast);
2494 put_string("independent");
2495 break;
2496 case PR_ACCAUTO:
2497 acc_pragma(ast);
2498 put_string("auto");
2499 break;
2500 case PR_ACCREDUCTOP:
2501 acc_pragma(ast);
2502 put_string("reduction operator(");
2503 switch (A_PRAGMAVALG(ast)) {
2504 case PR_ACCREDUCT_OP_ADD:
2505 put_string("+");
2506 break;
2507 case PR_ACCREDUCT_OP_MUL:
2508 put_string("*");
2509 break;
2510 case PR_ACCREDUCT_OP_MAX:
2511 put_string("max");
2512 break;
2513 case PR_ACCREDUCT_OP_MIN:
2514 put_string("min");
2515 break;
2516 case PR_ACCREDUCT_OP_BITAND:
2517 put_string("iand");
2518 break;
2519 case PR_ACCREDUCT_OP_BITIOR:
2520 put_string("ior");
2521 break;
2522 case PR_ACCREDUCT_OP_BITEOR:
2523 put_string("ieor");
2524 break;
2525 case PR_ACCREDUCT_OP_LOGAND:
2526 put_string(".and.");
2527 break;
2528 case PR_ACCREDUCT_OP_LOGOR:
2529 put_string(".or.");
2530 break;
2531 case PR_ACCREDUCT_OP_EQV:
2532 put_string(".eqv.");
2533 break;
2534 case PR_ACCREDUCT_OP_NEQV:
2535 put_string(".neqv");
2536 break;
2537 default:
2538 put_string("[unknown operator]");
2539 break;
2540 }
2541 put_string(")");
2542 break;
2543 case PR_ACCCOLLAPSE:
2544 acc_pragma(ast);
2545 acc_dtype(ast);
2546 put_string("collapse(");
2547 put_int(A_PRAGMAVALG(ast));
2548 put_string(")");
2549 break;
2550 case PR_ACCFORCECOLLAPSE:
2551 acc_pragma(ast);
2552 acc_dtype(ast);
2553 put_string("collapse(force:");
2554 put_int(A_PRAGMAVALG(ast));
2555 put_string(")");
2556 break;
2557 case PR_ACCTILE:
2558 acc_pragma(ast);
2559 acc_dtype(ast);
2560 cnt = A_ARGCNTG(ast);
2561 argt = A_ARGSG(ast);
2562 put_string("tile(");
2563 for (i = 0; i < cnt; ++i) {
2564 int arg;
2565 arg = ARGT_ARG(argt, i);
2566 if (i)
2567 put_string(",");
2568 print_ast(arg);
2569 }
2570 put_string(")");
2571 break;
2572 case PR_ACCPRIVATE:
2573 case PR_ACCFIRSTPRIVATE:
2574 case PR_ACCCOPY:
2575 case PR_ACCCOPYIN:
2576 case PR_ACCCOPYOUT:
2577 case PR_ACCLOCAL:
2578 case PR_ACCCREATE:
2579 case PR_ACCNO_CREATE:
2580 case PR_ACCPRESENT:
2581 case PR_ACCPCOPY:
2582 case PR_ACCPCOPYIN:
2583 case PR_ACCPCOPYOUT:
2584 case PR_ACCPCREATE:
2585 case PR_ACCPDELETE:
2586 case PR_ACCDELETE:
2587 case PR_ACCDEVICEPTR:
2588 case PR_ACCATTACH:
2589 case PR_ACCDETACH:
2590 case PR_ACCMIRROR:
2591 case PR_ACCREFLECT:
2592 case PR_ACCUPDATEHOST:
2593 case PR_ACCUPDATEHOSTIFP:
2594 case PR_ACCUPDATESELF:
2595 case PR_ACCUPDATESELFIFP:
2596 case PR_ACCUPDATEDEVICE:
2597 case PR_ACCUPDATEDEVICEIFP:
2598 case PR_ACCCOMPARE:
2599 case PR_PGICOMPARE:
2600 case PR_KERNEL_NEST:
2601 case PR_KERNEL_GRID:
2602 case PR_KERNEL_BLOCK:
2603 case PR_KERNEL_STREAM:
2604 case PR_KERNEL_DEVICE:
2605 case PR_ACCASYNC:
2606 case PR_ACCREDUCTION:
2607 case PR_ACCNUMWORKERS:
2608 case PR_ACCNUMGANGS:
2609 case PR_ACCNUMGANGS2:
2610 case PR_ACCNUMGANGS3:
2611 case PR_ACCVLENGTH:
2612 case PR_ACCUSEDEVICE:
2613 case PR_ACCUSEDEVICEIFP:
2614 case PR_ACCDEVICERES:
2615 case PR_ACCLOOPPRIVATE:
2616 case PR_CUFLOOPPRIVATE:
2617 acc_pragma(ast);
2618 switch (A_PRAGMATYPEG(ast)) {
2619 case PR_ACCPRIVATE:
2620 put_string("private(");
2621 break;
2622 case PR_ACCFIRSTPRIVATE:
2623 put_string("firstprivate(");
2624 break;
2625 case PR_ACCCOPY:
2626 put_string("copy(");
2627 break;
2628 case PR_ACCCOPYIN:
2629 put_string("copyin(");
2630 break;
2631 case PR_ACCCOPYOUT:
2632 put_string("copyout(");
2633 break;
2634 case PR_ACCLOCAL:
2635 put_string("local(");
2636 break;
2637 case PR_ACCCREATE:
2638 put_string("create(");
2639 break;
2640 case PR_ACCNO_CREATE:
2641 put_string("no_create(");
2642 break;
2643 case PR_ACCDELETE:
2644 put_string("delete(");
2645 break;
2646 case PR_ACCPRESENT:
2647 put_string("present(");
2648 break;
2649 case PR_ACCPCOPY:
2650 put_string("pcopy(");
2651 break;
2652 case PR_ACCPCOPYIN:
2653 put_string("pcopyin(");
2654 break;
2655 case PR_ACCPCOPYOUT:
2656 put_string("pcopyout(");
2657 break;
2658 case PR_ACCPCREATE:
2659 put_string("pcreate(");
2660 break;
2661 case PR_ACCPDELETE:
2662 put_string("pdelete(");
2663 break;
2664 case PR_ACCDEVICEPTR:
2665 put_string("deviceptr(");
2666 break;
2667 case PR_ACCATTACH:
2668 put_string("attach(");
2669 break;
2670 case PR_ACCDETACH:
2671 put_string("detach(");
2672 break;
2673 case PR_ACCUPDATEHOST:
2674 put_string("update host(");
2675 break;
2676 case PR_ACCUPDATEHOSTIFP:
2677 put_string("update if_present host(");
2678 break;
2679 case PR_ACCUPDATESELF:
2680 put_string("update self(");
2681 break;
2682 case PR_ACCUPDATESELFIFP:
2683 put_string("update if_present self(");
2684 break;
2685 case PR_ACCUPDATEDEVICE:
2686 put_string("update device(");
2687 break;
2688 case PR_ACCUPDATEDEVICEIFP:
2689 put_string("update if_present device(");
2690 break;
2691 case PR_ACCCOMPARE:
2692 put_string("acc_compare(");
2693 break;
2694 case PR_PGICOMPARE:
2695 put_string("pgi_compare(");
2696 break;
2697 case PR_ACCMIRROR:
2698 put_string("mirror(");
2699 break;
2700 case PR_ACCREFLECT:
2701 put_string("reflect(");
2702 break;
2703 case PR_KERNEL_NEST:
2704 cuf_pragma(ast);
2705 put_string("donest(");
2706 break;
2707 case PR_KERNEL_GRID:
2708 cuf_pragma(ast);
2709 put_string("grid(");
2710 break;
2711 case PR_KERNEL_BLOCK:
2712 cuf_pragma(ast);
2713 put_string("block(");
2714 break;
2715 case PR_KERNEL_STREAM:
2716 cuf_pragma(ast);
2717 put_string("stream(");
2718 break;
2719 case PR_KERNEL_DEVICE:
2720 cuf_pragma(ast);
2721 put_string("device(");
2722 break;
2723 case PR_ACCASYNC:
2724 acc_dtype(ast);
2725 put_string("async(");
2726 break;
2727 case PR_ACCREDUCTION:
2728 put_string("reduction(");
2729 break;
2730 case PR_ACCNUMWORKERS:
2731 acc_dtype(ast);
2732 put_string("num_workers(");
2733 break;
2734 case PR_ACCNUMGANGS:
2735 acc_dtype(ast);
2736 put_string("num_gangs(");
2737 break;
2738 case PR_ACCNUMGANGS2:
2739 acc_dtype(ast);
2740 put_string("num_gangs(dim:2,");
2741 break;
2742 case PR_ACCNUMGANGS3:
2743 acc_dtype(ast);
2744 put_string("num_gangs(dim:3,");
2745 break;
2746 case PR_ACCVLENGTH:
2747 acc_dtype(ast);
2748 put_string("vector_length(");
2749 break;
2750 case PR_ACCUSEDEVICE:
2751 case PR_ACCUSEDEVICEIFP:
2752 put_string("use_device(");
2753 break;
2754 case PR_ACCDEVICERES:
2755 put_string("device_resident(");
2756 break;
2757 case PR_ACCLINK:
2758 put_string("link(");
2759 break;
2760 case PR_ACCLOOPPRIVATE:
2761 put_string("loopprivate(");
2762 break;
2763 case PR_CUFLOOPPRIVATE:
2764 cuf_pragma(ast);
2765 put_string("loopprivate(");
2766 break;
2767 }
2768 print_ast(A_LOPG(ast));
2769 if (A_ROPG(ast)) {
2770 put_string(",");
2771 print_ast(A_ROPG(ast));
2772 }
2773 put_string(")");
2774 switch (A_PRAGMATYPEG(ast)) {
2775 case PR_ACCUSEDEVICEIFP:
2776 case PR_ACCUPDATEHOSTIFP:
2777 case PR_ACCUPDATESELFIFP:
2778 case PR_ACCUPDATEDEVICEIFP:
2779 put_string(" if_present");
2780 break;
2781 default :
2782 break;
2783 }
2784 break;
2785 case PR_KERNELBEGIN:
2786 cuf_pragma(ast);
2787 put_string("begin");
2788 break;
2789 case PR_KERNELTILE:
2790 cuf_pragma(ast);
2791 put_string("tile");
2792 break;
2793 case PR_ACCVECTOR:
2794 acc_pragma(ast);
2795 acc_dtype(ast);
2796 put_string("loop vector");
2797 if (A_LOPG(ast)) {
2798 put_string("(");
2799 print_ast(A_LOPG(ast));
2800 put_string(")");
2801 }
2802 break;
2803 case PR_ACCWORKER:
2804 acc_pragma(ast);
2805 acc_dtype(ast);
2806 put_string("loop worker");
2807 if (A_LOPG(ast)) {
2808 put_string("(");
2809 print_ast(A_LOPG(ast));
2810 put_string(")");
2811 }
2812 break;
2813 case PR_ACCGANG:
2814 acc_pragma(ast);
2815 acc_dtype(ast);
2816 put_string("loop gang");
2817 if (A_LOPG(ast)) {
2818 put_string("(");
2819 print_ast(A_LOPG(ast));
2820 put_string(")");
2821 }
2822 break;
2823 case PR_ACCGANGDIM:
2824 acc_pragma(ast);
2825 acc_dtype(ast);
2826 put_string("loop gang");
2827 if (A_LOPG(ast)) {
2828 put_string("(dim:");
2829 print_ast(A_LOPG(ast));
2830 put_string(")");
2831 }
2832 break;
2833 case PR_ACCGANGCHUNK:
2834 acc_pragma(ast);
2835 acc_dtype(ast);
2836 put_string("loop gang");
2837 if (A_LOPG(ast)) {
2838 put_string("(static:");
2839 print_ast(A_LOPG(ast));
2840 put_string(")");
2841 }
2842 break;
2843 case PR_ACCPARALLEL:
2844 acc_pragma(ast);
2845 acc_dtype(ast);
2846 put_string("loop parallel");
2847 if (A_LOPG(ast)) {
2848 put_string("(");
2849 print_ast(A_LOPG(ast));
2850 put_string(")");
2851 }
2852 break;
2853 case PR_ACCSEQ:
2854 acc_pragma(ast);
2855 acc_dtype(ast);
2856 put_string("loop seq");
2857 if (A_LOPG(ast)) {
2858 put_string("(");
2859 print_ast(A_LOPG(ast));
2860 put_string(")");
2861 }
2862 break;
2863 case PR_ACCHOST:
2864 acc_pragma(ast);
2865 acc_dtype(ast);
2866 put_string("loop host");
2867 if (A_LOPG(ast)) {
2868 put_string("(");
2869 print_ast(A_LOPG(ast));
2870 put_string(")");
2871 }
2872 break;
2873 case PR_ACCIF:
2874 acc_pragma(ast);
2875 put_string("if");
2876 if (A_LOPG(ast)) {
2877 put_string("(");
2878 print_ast(A_LOPG(ast));
2879 put_string(")");
2880 }
2881 break;
2882 case PR_ACCUNROLL:
2883 acc_pragma(ast);
2884 acc_dtype(ast);
2885 put_string("loop unroll");
2886 if (A_LOPG(ast)) {
2887 put_string("(");
2888 print_ast(A_LOPG(ast));
2889 put_string(")");
2890 }
2891 break;
2892 case PR_ACCSEQUNROLL:
2893 acc_pragma(ast);
2894 acc_dtype(ast);
2895 put_string("loop sequnroll");
2896 if (A_LOPG(ast)) {
2897 put_string("(");
2898 print_ast(A_LOPG(ast));
2899 put_string(")");
2900 }
2901 break;
2902 case PR_ACCPARUNROLL:
2903 acc_pragma(ast);
2904 acc_dtype(ast);
2905 put_string("loop parunroll");
2906 if (A_LOPG(ast)) {
2907 put_string("(");
2908 print_ast(A_LOPG(ast));
2909 put_string(")");
2910 }
2911 break;
2912 case PR_ACCVECUNROLL:
2913 acc_pragma(ast);
2914 acc_dtype(ast);
2915 put_string("loop vecunroll");
2916 if (A_LOPG(ast)) {
2917 put_string("(");
2918 print_ast(A_LOPG(ast));
2919 put_string(")");
2920 }
2921 break;
2922 case PR_KERNEL:
2923 cuf_pragma(ast);
2924 put_string("kernel");
2925 break;
2926 case PR_ENDKERNEL:
2927 cuf_pragma(ast);
2928 put_string("end kernel");
2929 break;
2930 case PR_ACCELLP:
2931 acc_pragma(ast);
2932 put_string("loop");
2933 break;
2934 case PR_ACCKLOOP:
2935 acc_pragma(ast);
2936 put_string("(kernels) loop");
2937 break;
2938 case PR_ACCTKLOOP:
2939 acc_pragma(ast);
2940 put_string("(kernels-tight) loop");
2941 break;
2942 case PR_ACCPLOOP:
2943 acc_pragma(ast);
2944 put_string("(parallel) loop");
2945 break;
2946 case PR_ACCTPLOOP:
2947 acc_pragma(ast);
2948 put_string("(parallel-tight) loop");
2949 break;
2950 case PR_ACCSLOOP:
2951 acc_pragma(ast);
2952 put_string("(serial) loop");
2953 break;
2954 case PR_ACCTSLOOP:
2955 acc_pragma(ast);
2956 put_string("(serial-tight) loop");
2957 break;
2958 case PR_ACCWAITDIR:
2959 acc_pragma(ast);
2960 put_string("waitdir");
2961 break;
2962 case PR_ACCWAITARG:
2963 acc_pragma(ast);
2964 acc_dtype(ast);
2965 put_string("wait");
2966 if (A_LOPG(ast)) {
2967 put_string("(");
2968 print_ast(A_LOPG(ast));
2969 put_string(")");
2970 }
2971 break;
2972 case PR_ACCDEVICEID:
2973 acc_pragma(ast);
2974 acc_dtype(ast);
2975 put_string("deviceid");
2976 if (A_LOPG(ast)) {
2977 put_string("(");
2978 print_ast(A_LOPG(ast));
2979 put_string(")");
2980 }
2981 break;
2982 case PR_ACCCACHEDIR:
2983 acc_pragma(ast);
2984 put_string("cachedir");
2985 break;
2986 case PR_ACCCACHEREADONLY:
2987 acc_pragma(ast);
2988 put_string("cache-readonly");
2989 break;
2990 case PR_ACCCACHEARG:
2991 acc_pragma(ast);
2992 put_string("cache(");
2993 print_ast(A_LOPG(ast));
2994 put_string(")");
2995 break;
2996 case PR_ACCDEFNONE:
2997 acc_pragma(ast);
2998 put_string("default(none)");
2999 break;
3000 case PR_ACCDEFPRESENT:
3001 acc_pragma(ast);
3002 put_string("default(present)");
3003 break;
3004 default:
3005 put_string("pragmatype=");
3006 put_int(A_PRAGMATYPEG(ast));
3007 break;
3008 }
3009 break;
3010 default:
3011 put_string("ASTTYPE(");
3012 put_int(atype);
3013 put_string(")");
3014 }
3015 }
3016
3017 static void
put_call(int ast,int call,char * name,int check_ptrarg)3018 put_call(int ast, int call, char *name, int check_ptrarg)
3019 {
3020 int dpdsc, paramct, iface;
3021 int sptr, cnt, argt, arg, i, param, sdparam, sdi;
3022 LOGICAL anyoptional, do_naked_pointer, some;
3023 if (call) {
3024 put_l_to_u("call ");
3025 }
3026 if (name) {
3027 put_string(name);
3028 } else {
3029 print_ast(A_LOPG(ast));
3030 }
3031 put_char('(');
3032 sptr = procsym_of_ast(A_LOPG(ast));
3033 proc_arginfo(sptr, ¶mct, &dpdsc, &iface);
3034 cnt = A_ARGCNTG(ast);
3035 argt = A_ARGSG(ast);
3036 altret_spec = TRUE;
3037 anyoptional = FALSE;
3038 sdi = -1; /* section descriptor index */
3039 /* f77 output, no pointers allowed, subprogram has a pointer argument */
3040 if (check_ptrarg == 1 && F77OUTPUT && NO_PTR && !ast_is_comment &&
3041 PTRARGG(sptr) && dpdsc > 0 && paramct > 0) {
3042 do_naked_pointer = TRUE;
3043 } else {
3044 do_naked_pointer = FALSE;
3045 }
3046 arg = 0;
3047 some = FALSE;
3048 for (i = 0; i < cnt; ++i) {
3049 /* if there was a previous argument, put comma */
3050 arg = ARGT_ARG(argt, i);
3051 if (i >= paramct && dpdsc) {
3052 ++sdi;
3053 {
3054 /* move sdi up to next assumed-shape argument */
3055 while (sdi < paramct) {
3056 sdparam = aux.dpdsc_base[dpdsc + sdi];
3057 if (sdparam && DTY(DTYPEG(sdparam)) == TY_ARRAY &&
3058 ASSUMSHPG(sdparam)) {
3059 break;
3060 } else {
3061 ++sdi;
3062 }
3063 }
3064 }
3065 }
3066 /* separate all arguments with comma */
3067 if (ast_is_comment && i)
3068 put_char(',');
3069 if (arg != 0) {
3070 param = 0;
3071 /* is this a missing optional argument? */
3072 if (i < paramct && dpdsc) {
3073 param = aux.dpdsc_base[dpdsc + i];
3074 }
3075 if (param && OPTARGG(param) && (arg == astb.ptr0 || arg == astb.ptr0c)) {
3076 /* don't print the missing argument */
3077 anyoptional = TRUE;
3078 arg = 0; /* don't print next comma */
3079 } else {
3080 /* separate all arguments with comma, unless already printed above */
3081 if (some && !ast_is_comment)
3082 put_char(',');
3083 some = TRUE;
3084 if (anyoptional) { /* must use keyword form */
3085 if (param) {
3086 put_string(SYMNAME(param));
3087 put_string("=");
3088 } else if (sdi >= 0 && sdi < paramct) {
3089 static char sdname[120];
3090 int sdparam;
3091 sdparam = aux.dpdsc_base[dpdsc + sdi];
3092 strcpy(sdname, SYMNAME(sdparam));
3093 strcat(sdname, "$sd");
3094 put_string(sdname);
3095 put_string("=");
3096 } else {
3097 put_string("NOKEYWORD=");
3098 }
3099 }
3100 if (check_ptrarg == 2 ||
3101 (do_naked_pointer && i < paramct && POINTERG(param))) {
3102 print_naked_id(arg);
3103 } else {
3104 print_ast(arg);
3105 }
3106 }
3107 }
3108 }
3109 altret_spec = FALSE;
3110 put_char(')');
3111 } /* put_call */
3112
3113 static void
print_ast_replaced(int ast,int sym,int replacesym)3114 print_ast_replaced(int ast, int sym, int replacesym)
3115 {
3116 int astreplace;
3117 if (replacesym && STYPEG(replacesym) != ST_MEMBER) {
3118 put_string(SYMNAME(replacesym));
3119 } else {
3120 /* replace 'sym' in 'ast' by 'replacesym', then print it */
3121 switch (A_TYPEG(ast)) {
3122 case A_ID:
3123 case A_CNST:
3124 case A_LABEL:
3125 astreplace = ast;
3126 break;
3127 case A_MEM:
3128 astreplace = A_MEMG(ast);
3129 if (A_TYPEG(astreplace) != A_ID)
3130 astreplace = 0;
3131 break;
3132 case A_SUBSCR:
3133 astreplace = A_LOPG(ast);
3134 if (A_TYPEG(astreplace) == A_MEM) {
3135 astreplace = A_MEMG(astreplace);
3136 }
3137 if (A_TYPEG(astreplace) != A_ID)
3138 astreplace = 0;
3139 break;
3140 default:
3141 astreplace = 0;
3142 break;
3143 }
3144 if (astreplace) {
3145 if (A_SPTRG(astreplace) == sym) {
3146 A_SPTRP(astreplace, replacesym);
3147 } else {
3148 astreplace = 0;
3149 }
3150 }
3151 print_ast(ast);
3152 if (astreplace) {
3153 A_SPTRP(astreplace, sym);
3154 }
3155 }
3156 } /* print_ast_replaced */
3157
3158 static void
print_uncoerced_const(int ast)3159 print_uncoerced_const(int ast)
3160 {
3161 /*
3162 * Do not check the ALIAS field of the AST -- need to examine the actual
3163 * ast and not, for example, a convert ast which resolves to a constant.
3164 * Checking the ALIAS field of
3165 * rrr = 4habcd
3166 * will result in emitting the 'real' representation of the Hollerith
3167 * constant, which is not desired.
3168 *
3169 */
3170 if (A_TYPEG(ast) == A_CNST) {
3171 put_const(A_SPTRG(ast));
3172 return;
3173 }
3174 print_ast(ast);
3175 }
3176
3177 static void
print_loc(int ast)3178 print_loc(int ast)
3179 {
3180 if (A_TYPEG(ast) == A_ID) {
3181 print_loc_of_sym(A_SPTRG(ast));
3182 return;
3183 }
3184 if (ast_is_comment) {
3185 put_string("loc");
3186 } else {
3187 put_string(mkRteRtnNm(RTE_loc));
3188 }
3189 put_char('(');
3190 print_ast(ast);
3191 put_char(')');
3192 }
3193
3194 static void
print_loc_of_sym(int sym)3195 print_loc_of_sym(int sym)
3196 {
3197 if (SCG(sym) == SC_BASED && F77OUTPUT && !NO_PTR && MIDNUMG(sym) &&
3198 !ast_is_comment) {
3199 put_string(SYMNAME(MIDNUMG(sym)));
3200 return;
3201 }
3202 if (ast_is_comment) {
3203 put_string("loc");
3204 } else {
3205 put_string(mkRteRtnNm(RTE_loc));
3206 }
3207 put_char('(');
3208 print_refsym(sym, 0);
3209 put_char(')');
3210 }
3211
3212 static void
print_refsym(int sym,int ast)3213 print_refsym(int sym, int ast)
3214 {
3215 if (F77OUTPUT && !ast_is_comment && !F90POINTERG(sym) &&
3216 (ALLOCG(sym) || SCG(sym) == SC_BASED || /* allocatable symbol */
3217 (STYPEG(sym) == ST_MEMBER && ALIGNG(sym)))) { /*dist member*/
3218 /* pgftn-extensions not allowed: cray pointers not allowed,
3219 * or cray pointers are allowed but the objects can't be character
3220 * or derived type.
3221 */
3222 if (NO_PTR || /* no pointers */
3223 (NO_CHARPTR && DTYG(DTYPEG(sym)) == TY_CHAR) ||
3224 (NO_DERIVEDPTR && DTYG(DTYPEG(sym)) == TY_DERIVED)) {
3225 put_string(SYMNAME(sym));
3226 put_char('(');
3227 if (PTROFFG(sym)) {
3228 int offset;
3229 offset = check_member(ast, mk_id(PTROFFG(sym)));
3230 print_ast(offset);
3231 } else {
3232 int offset;
3233 offset = check_member(ast, mk_id(MIDNUMG(sym)));
3234 print_ast(offset);
3235 }
3236 put_char(')');
3237 return;
3238 }
3239 }
3240 print_sname(sym);
3241 if (DBGBIT(5, 0x40)) {
3242 char b[64];
3243 sprintf(b, "\\%d", sym);
3244 put_string(b);
3245 }
3246 }
3247
3248 static void
print_sname(int sym)3249 print_sname(int sym)
3250 {
3251 switch (STYPEG(sym)) {
3252 case ST_MEMBER:
3253 break;
3254 case ST_PROC:
3255 if (SCOPEG(sym) && STYPEG(SCOPEG(sym)) == ST_ALIAS && SCOPEG(SCOPEG(sym)) &&
3256 STYPEG(SCOPEG(SCOPEG(sym))) == ST_MODULE) {
3257 put_string(SYMNAME(SCOPEG(SCOPEG(sym))));
3258 put_string("::");
3259 break;
3260 }
3261 default:
3262 if (ENCLFUNCG(sym) && STYPEG(ENCLFUNCG(sym)) == ST_MODULE) {
3263 put_string(SYMNAME(ENCLFUNCG(sym)));
3264 put_string("::");
3265 }
3266 break;
3267 }
3268 switch (STYPEG(sym)) {
3269 case ST_UNKNOWN:
3270 case ST_IDENT:
3271 case ST_VAR:
3272 case ST_ARRAY:
3273 case ST_DESCRIPTOR:
3274 case ST_STRUCT:
3275 case ST_UNION:
3276 if (SCG(sym) == SC_PRIVATE)
3277 put_string("@");
3278 else if (SCG(sym) == SC_BASED && MIDNUMG(sym) &&
3279 SCG(MIDNUMG(sym)) == SC_PRIVATE)
3280 put_string("@");
3281 break;
3282 default:;
3283 }
3284 put_string(SYMNAME(sym));
3285 }
3286
3287 static void
print_naked_id(int ast)3288 print_naked_id(int ast)
3289 {
3290 if (A_TYPEG(ast) == A_ID) {
3291 int sym = A_SPTRG(ast);
3292 put_string(SYMNAME(sym));
3293 } else {
3294 print_ast(ast);
3295 }
3296 }
3297
3298 /** \brief Since the output is 'standard' f77, all allocatable (deferred-shape)
3299 arrays must be converted to pointer-based arrays. The symbol table
3300 is scanned to find allocatable arrays which do not have bound temporaries
3301 or associated pointer variables.
3302 */
3303 void
deferred_to_pointer(void)3304 deferred_to_pointer(void)
3305 {
3306 int sptr;
3307 int dtype;
3308 int numdim;
3309 int i;
3310 ADSC *ad;
3311
3312 for (sptr = stb.stg_avail - 1; sptr >= stb.firstusym; sptr--) {
3313 if (STYPEG(sptr) != ST_ARRAY || SCG(sptr) == SC_NONE)
3314 continue;
3315 if (IGNOREG(sptr)) /* ignore this symbol */
3316 continue;
3317 if (F90POINTERG(sptr))
3318 continue;
3319 dtype = DTYPEG(sptr);
3320 ad = AD_DPTR(dtype);
3321 if (!AD_DEFER(ad) && !AD_NOBOUNDS(ad))
3322 continue;
3323
3324 numdim = AD_NUMDIM(ad);
3325 if (!ALIGNG(sptr) && SDSCG(sptr) == 0)
3326 /* if the array has a static descriptor, then never change the
3327 * bounds.
3328 */
3329 for (i = 0; i < numdim; ++i) {
3330 int s;
3331 if (AD_LWAST(ad, i) == 0 || A_TYPEG(AD_LWAST(ad, i)) != A_ID) {
3332 AD_LWAST(ad, i) = mk_bnd_ast();
3333 if (SAVEG(sptr)) {
3334 s = A_SPTRG(AD_LWAST(ad, i));
3335 SCP(s, SC_STATIC);
3336 SAVEP(s, 1);
3337 }
3338 }
3339 if (AD_UPAST(ad, i) == 0 || A_TYPEG(AD_UPAST(ad, i)) != A_ID) {
3340 AD_UPAST(ad, i) = mk_bnd_ast();
3341 if (SAVEG(sptr)) {
3342 s = A_SPTRG(AD_UPAST(ad, i));
3343 SCP(s, SC_STATIC);
3344 SAVEP(s, 1);
3345 }
3346 }
3347 if (AD_EXTNTAST(ad, i) == 0 || A_TYPEG(AD_EXTNTAST(ad, i)) != A_ID) {
3348 AD_EXTNTAST(ad, i) = mk_bnd_ast();
3349 if (SAVEG(sptr)) {
3350 s = A_SPTRG(AD_EXTNTAST(ad, i));
3351 SCP(s, SC_STATIC);
3352 SAVEP(s, 1);
3353 }
3354 }
3355 }
3356 /* don't create pointer variable for sequential dummy */
3357 /* or caller remapping dummys */
3358 if (SCG(sptr) == SC_DUMMY) {
3359 if (SEQG(sptr))
3360 continue;
3361 if (XBIT(58, 0x20) && !POINTERG(sptr))
3362 continue;
3363 }
3364 ALLOCP(sptr, 1);
3365 if (MIDNUMG(sptr) == 0) {
3366 int stp;
3367 SCP(sptr, SC_BASED);
3368 stp = sym_get_ptr(sptr);
3369 MIDNUMP(sptr, stp);
3370 }
3371 if (SAVEG(sptr)) {
3372 if (!POINTERG(sptr)) {
3373 SAVEP(MIDNUMG(sptr), 1);
3374 }
3375 if (!NO_PTR)
3376 /* pointers allowed in output! */
3377 SAVEP(sptr, 0); /* based-object cannot be SAVEd */
3378 }
3379 }
3380 }
3381
3382 static void
pr_arr_name(int arr)3383 pr_arr_name(int arr)
3384 {
3385 int lop, sptr, dtype;
3386 if (A_TYPEG(arr) == A_ID) {
3387 sptr = A_SPTRG(arr);
3388 } else if (A_TYPEG(arr) == A_MEM) {
3389 lop = A_PARENTG(arr);
3390 print_ast(lop);
3391 dtype = A_DTYPEG(lop);
3392 if (DTYG(dtype) == TY_DERIVED) {
3393 put_char('%');
3394 } else {
3395 put_char('.');
3396 }
3397 sptr = A_SPTRG(A_MEMG(arr));
3398 }
3399 print_sname(sptr);
3400 } /* pr_arr_name */
3401
3402 /* a subscript ast is being processed. First, print the array ('arr') which
3403 * is being subscripted and then check the array to determine if its subscripts
3404 * must be linearized. Returns a non-zero value if the array's subscripts
3405 * must be linearized; 0, otherwise. The non-zero value is 1 for non-POINTER
3406 * arrays; if the array is a POINTER, then the non-zero value is the sym
3407 * pointer representing the POINTER's static descriptor.
3408 */
3409 static int
pr_chk_arr(int arr)3410 pr_chk_arr(int arr)
3411 {
3412 int sptr = 0;
3413 if (A_TYPEG(arr) == A_ID) {
3414 sptr = A_SPTRG(arr);
3415 } else if (A_TYPEG(arr) == A_MEM) {
3416 sptr = A_SPTRG(A_MEMG(arr));
3417 } else {
3418 print_ast(arr);
3419 return 0;
3420 }
3421 if (LNRZDG(sptr)) {
3422 /* linearize flag set */
3423 pr_arr_name(arr);
3424 if (SDSCG(sptr) && !NODESCG(sptr))
3425 return SDSCG(sptr);
3426 return 1;
3427 } else if (F77OUTPUT) {
3428 if (ALLOCG(sptr) ||
3429 (SCG(sptr) == SC_BASED &&
3430 (NO_PTR || (NO_CHARPTR && DTYG(DTYPEG(sptr)) == TY_CHAR) ||
3431 (NO_DERIVEDPTR && DTYG(DTYPEG(sptr)) == TY_DERIVED)))) {
3432 pr_arr_name(arr);
3433 if (SDSCG(sptr) && !NODESCG(sptr))
3434 return SDSCG(sptr);
3435 return 1;
3436 }
3437 } else if (ALLOCG(sptr) && SCG(sptr) == SC_BASED &&
3438 (MDALLOCG(sptr) || PTROFFG(sptr))) {
3439 /* linearize subscripts of an allocatable array which came from
3440 * a MODULE.
3441 */
3442 pr_arr_name(arr);
3443 if (SDSCG(sptr) && !NODESCG(sptr))
3444 return SDSCG(sptr);
3445 return 1;
3446 }
3447
3448 pr_arr_name(arr);
3449 return 0;
3450 }
3451
3452 /* 'sub' is a subscript ast, where the array is allocatable. If the output
3453 * is standard f77, will need to generate assigment statements which assign
3454 * to the array's bound temporaries their respective values. The values are
3455 * presented as 'triple' asts, representing the explicit shape of the array.
3456 * The bound temporaries are extracted from the LWAST and UPAST fields
3457 * of the array's descriptor (ADSC).
3458 */
3459 static void
gen_bnd_assn(int sub)3460 gen_bnd_assn(int sub)
3461 {
3462 int i, ndim;
3463 int asd;
3464 int asym, dsym;
3465 ADSC *ad;
3466 int triple;
3467 int dtyp;
3468
3469 if (A_TYPEG(sub) != A_SUBSCR) {
3470 return;
3471 }
3472 asd = A_ASDG(sub);
3473 ndim = ASD_NDIM(asd);
3474 asym = memsym_of_ast(A_LOPG(sub));
3475 dsym = DESCRG(asym);
3476 assert(dsym, "gen_bnd_assn: descr not found", asym, 4);
3477 dtyp = DDTG(DTYPEG(asym));
3478 dtyp = get_array_dtype(ndim, dtyp);
3479 DTYPEP(dsym, dtyp);
3480 ad = AD_DPTR(dtyp);
3481 assert(ndim == AD_NUMDIM(ad), "gen_bnd_assn:ndim not equal", asym, 3);
3482 for (i = 0; i < ndim; i++) {
3483 triple = ASD_SUBS(asd, i);
3484 if (A_TYPEG(triple) != A_TRIPLE) {
3485 return;
3486 }
3487 AD_LWAST(ad, i) = A_LBDG(triple);
3488 AD_UPAST(ad, i) = A_UPBDG(triple);
3489 AD_EXTNTAST(ad, i) = mk_extent(AD_LWAST(ad, i), AD_UPAST(ad, i), i);
3490 }
3491 }
3492
3493 static int
find_member_base(int dtype)3494 find_member_base(int dtype)
3495 {
3496 int basesptr, dty, mem;
3497 char *rtnNm = mkRteRtnNm(RTE_member_base);
3498 basesptr = lookupsymbol(rtnNm);
3499 if (basesptr == 0 || STYPEG(basesptr) != ST_CMBLK) {
3500 return NOSYM;
3501 }
3502 /* find the member base */
3503 dty = DDTG(dtype);
3504 for (mem = CMEMFG(basesptr); mem > NOSYM; mem = SYMLKG(mem)) {
3505 if (DDTG(DTYPEG(mem)) == dty)
3506 break;
3507 }
3508 return mem;
3509 } /* find_member_base */
3510
3511 /* If the output is 'standard' f77, need to convert the allocate of an
3512 * object to a call to a run-time routine. 'object' is the ast item
3513 * representing the object; 'stat' is the id ast, not present if 0, of the
3514 * allocate status variable. If 'object' is a subscript ast, the subscripts
3515 * are triples (represents the explicit shape of the allocate); prior to
3516 * calling the run-time routine, the values specified by the explicit
3517 * shape must be assigned to the array's bound temporaries. Otherwise, 'object'
3518 * is an id ast, whose symbol field is the array to be allocate.
3519 * Note that the object is a pointer-based array; the associated pointer
3520 * variable is assigned the pointer of the allocation.
3521 */
3522 static void
gen_allocate(int object,int stat)3523 gen_allocate(int object, int stat)
3524 {
3525 int i, ndim;
3526 int ast;
3527 int asd;
3528 int asym, dsym, dtype;
3529 ADSC *ad;
3530 int t;
3531 int nelem;
3532 int save_op_space;
3533 FtnRtlEnum rtlRtn;
3534 INT ty_val;
3535
3536 if (A_TYPEG(object) == A_SUBSCR) {
3537 asd = A_ASDG(object);
3538 ast = A_LOPG(object);
3539 asym = find_pointer_variable(ast);
3540 dtype = DTYPEG(asym);
3541 dsym = DESCRG(asym);
3542 if (dsym) {
3543 gen_bnd_assn(object);
3544 }
3545 ndim = ASD_NDIM(asd);
3546 nelem = astb.i1;
3547 for (i = 0; i < ndim; i++) {
3548 int lw, up, triple, lb, ub, extnt;
3549 triple = ASD_SUBS(asd, i);
3550 lw = A_LBDG(triple);
3551 if (lw == 0) {
3552 lw = astb.i1;
3553 }
3554 up = A_UPBDG(triple);
3555 if (up == 0) {
3556 up = astb.i1;
3557 }
3558 t = mk_binop(OP_SUB, up, lw, DT_INT);
3559 t = mk_binop(OP_ADD, t, astb.i1, DT_INT);
3560 nelem = mk_binop(OP_MUL, nelem, t, DT_INT);
3561 if (SDSCG(asym) == 0 && !ALIGNG(asym)) {
3562 lb = ADD_LWAST(dtype, i);
3563 if (lb && A_TYPEG(lb) == A_ID && lb != lw) {
3564 /* put out assignment */
3565 put_string(SYMNAME(A_SPTRG(lb)));
3566 put_string(" = ");
3567 print_ast(lw);
3568 }
3569 ub = ADD_UPAST(dtype, i);
3570 if (up && A_TYPEG(ub) == A_ID && ub != up) {
3571 /* put out assignment */
3572 put_string(SYMNAME(A_SPTRG(ub)));
3573 put_string(" = ");
3574 print_ast(up);
3575 }
3576 extnt = ADD_EXTNTAST(dtype, i);
3577 if (extnt && A_TYPEG(extnt) == A_ID) {
3578 /* put out assignment */
3579 put_string(SYMNAME(A_SPTRG(extnt)));
3580 put_string(" = ");
3581 print_ast(mk_extent_expr(lw, up));
3582 }
3583 }
3584 }
3585 } else {
3586 ast = object;
3587 asym = find_pointer_variable(object);
3588 if (STYPEG(asym) == ST_ARRAY) {
3589 ad = AD_DPTR(DTYPEG(asym));
3590 nelem = AD_NUMELM(ad);
3591 } else
3592 nelem = astb.i1;
3593 }
3594 put_l_to_u("call ");
3595 rtlRtn = !ALLOCG(asym) ? RTE_ptr_alloca : RTE_alloca;
3596 put_string(mkRteRtnNm(rtlRtn));
3597 put_char('(');
3598 save_op_space = op_space;
3599 op_space = FALSE;
3600 print_ast(nelem); /* nelem */
3601 put_char(',');
3602 t = DTYPEG(asym);
3603 t = DTYG(t);
3604 ty_val = ty_to_lib[t];
3605 put_int(ty_val); /* kind */
3606 put_char(',');
3607 print_ast(size_ast(asym, DDTG(DTYPEG(asym)))); /* item length */
3608 put_char(',');
3609 if (stat)
3610 print_ast(stat); /* stat */
3611 else
3612 print_ast(astb.ptr0); /* 'null' stat */
3613 put_char(',');
3614 if (NO_PTR && XBIT(70, 8) && STYPEG(asym) == ST_MEMBER) {
3615 int mem;
3616 if (!F90POINTERG(asym) && POINTERG(asym) && PTROFFG(asym) &&
3617 STYPEG(PTROFFG(asym)) == ST_MEMBER) {
3618 print_ast_replaced(ast, asym, MIDNUMG(asym));
3619 put_char(',');
3620 print_ast_replaced(ast, asym, PTROFFG(asym));
3621 } else {
3622 print_ast(astb.ptr0); /* null pointer */
3623 put_char(',');
3624 print_ast_replaced(ast, asym, MIDNUMG(asym));
3625 }
3626 put_char(',');
3627 mem = find_member_base(DTYPEG(asym));
3628 if (mem <= NOSYM) {
3629 put_mem_string(ast, SYMNAME(asym));
3630 } else {
3631 put_string(SYMNAME(mem));
3632 }
3633 } else if (NO_PTR || /* no pointers in output */
3634 (NO_CHARPTR && DTYG(DTYPEG(asym)) == TY_CHAR) ||
3635 (NO_DERIVEDPTR && DTYG(DTYPEG(asym)) == TY_DERIVED)) {
3636 if (PTROFFG(asym)) {
3637 print_ast_replaced(ast, asym, MIDNUMG(asym));
3638 put_char(',');
3639 print_ast_replaced(ast, asym, PTROFFG(asym));
3640 } else {
3641 print_ast(astb.ptr0); /* null pointer */
3642 put_char(',');
3643 print_ast_replaced(ast, asym, MIDNUMG(asym));
3644 }
3645 put_char(',');
3646 put_mem_string(ast, SYMNAME(asym));
3647 } else {
3648 print_ast_replaced(ast, asym, MIDNUMG(asym));
3649 put_char(',');
3650 print_ast(astb.ptr0); /* null offset */
3651 put_char(',');
3652 print_ast(astb.ptr0); /* null base */
3653 }
3654 put_char(')');
3655
3656 if (!F90POINTERG(asym) && POINTERG(asym) && DTY(DTYPEG(asym)) != TY_ARRAY) {
3657 /* assign the run-time type to the static descriptor created for
3658 * the scalar pointer.
3659 */
3660 print_ast_replaced(ast, asym, SDSCG(asym));
3661 put_string("(1) = ");
3662 put_int(ty_val); /* kind */
3663 }
3664
3665 op_space = save_op_space;
3666 }
3667
3668 /* If the output is 'standard' f77, need to convert the deallocate of an
3669 * object to a call to a run-time routine. 'object' is the id ast
3670 * representing the object; 'stat' is the id ast, not present if 0, of the
3671 * allocate status variable.
3672 * Note that the object is a pointer-based array; the associated pointer
3673 * variable is passed to the run-time routine.
3674 */
3675 static void
gen_deallocate(int object,int stat,int asym,int passptr)3676 gen_deallocate(int object, int stat, int asym, int passptr)
3677 {
3678 assert(A_TYPEG(object) == A_ID || A_TYPEG(object) == A_MEM,
3679 "gen_deallocate:exp.id ast", object, 3);
3680 put_l_to_u("call ");
3681 if (passptr && MIDNUMG(asym) == 0) {
3682 passptr = 0;
3683 }
3684 if (passptr) {
3685 put_string(mkRteRtnNm(RTE_deallocx));
3686 } else {
3687 put_string(mkRteRtnNm(RTE_dealloca));
3688 }
3689 put_char('(');
3690 if (stat)
3691 print_ast(stat);
3692 else
3693 print_ast(astb.ptr0);
3694 put_char(',');
3695 if (NO_PTR && XBIT(70, 8) && STYPEG(asym) == ST_MEMBER) {
3696 int mem;
3697 mem = find_member_base(DTYPEG(asym));
3698 if (mem <= NOSYM) {
3699 put_mem_string(object, SYMNAME(asym));
3700 } else {
3701 put_string(SYMNAME(mem));
3702 }
3703 put_char('(');
3704 if (!F90POINTERG(asym) && POINTERG(asym) && PTROFFG(asym) &&
3705 STYPEG(PTROFFG(asym)) == ST_MEMBER) {
3706 print_ast_replaced(object, asym, PTROFFG(asym));
3707 } else {
3708 print_ast_replaced(object, asym, MIDNUMG(asym));
3709 }
3710 put_char(')');
3711 } else if (NO_PTR || /* no pointers in output */
3712 (NO_CHARPTR && DTYG(DTYPEG(asym)) == TY_CHAR) ||
3713 (NO_DERIVEDPTR && DTYG(DTYPEG(asym)) == TY_DERIVED)) {
3714 put_mem_string(object, SYMNAME(asym));
3715 put_char('(');
3716 if (PTROFFG(asym))
3717 print_ast_replaced(object, asym, PTROFFG(asym));
3718 else
3719 print_ast_replaced(object, asym, MIDNUMG(asym));
3720 put_char(')');
3721 } else if (passptr) {
3722 put_mem_string(object, SYMNAME(MIDNUMG(asym)));
3723 } else {
3724 put_mem_string(object, SYMNAME(asym));
3725 }
3726 put_char(')');
3727 if (POINTERG(asym) || passptr) {
3728 if (!NO_PTR || !XBIT(70, 8) || STYPEG(asym) != ST_MEMBER)
3729 gen_nullify(object, asym, passptr);
3730 }
3731 }
3732
3733 static void
gen_nullify(int ast,int sym,int passptr)3734 gen_nullify(int ast, int sym, int passptr)
3735 {
3736 /* Pointer disassociation (statement):
3737 * nullify(pv)
3738 * call pghpf_nullify(pv, pv$sdsc)
3739 * pv: base.
3740 * pv$sdsc: pv's (new) static descriptor
3741 */
3742 FtnRtlEnum rtlRtn;
3743
3744 if (F90POINTERG(sym)) {
3745 put_l_to_u("nullify( ");
3746 put_mem_string(ast, SYMNAME(sym));
3747 put_char(')');
3748 return;
3749 }
3750 if (STYPEG(sym) == ST_MEMBER) {
3751 /* do the nullify in-line */
3752 if (MIDNUMG(sym)) {
3753 print_ast_replaced(ast, sym, MIDNUMG(sym));
3754 put_string(" = 0");
3755 }
3756 if (PTROFFG(sym)) {
3757 print_ast_replaced(ast, sym, PTROFFG(sym));
3758 put_string(" = 0");
3759 }
3760 if (SDSCG(sym)) {
3761 print_ast_replaced(ast, sym, SDSCG(sym));
3762 put_string("(1) = 0");
3763 }
3764 return;
3765 }
3766 put_l_to_u("call ");
3767 if (DTYG(DTYPEG(sym)) == TY_CHAR) {
3768 rtlRtn = RTE_nullify_chara;
3769 } else if (passptr) {
3770 rtlRtn = RTE_nullifyx;
3771 } else {
3772 rtlRtn = RTE_nullify;
3773 }
3774 put_string(mkRteRtnNm(rtlRtn));
3775 put_char('(');
3776
3777 if (passptr) {
3778 print_ast_replaced(ast, sym, MIDNUMG(sym));
3779 } else {
3780 put_mem_string(ast, SYMNAME(sym));
3781 }
3782 put_char(',');
3783
3784 print_ast_replaced(ast, sym, SDSCG(sym));
3785 if (XBIT(70, 0x20)) {
3786 if (MIDNUMG(sym)) {
3787 put_char(',');
3788 print_ast_replaced(ast, sym, MIDNUMG(sym));
3789 }
3790 if (PTROFFG(sym)) {
3791 put_char(',');
3792 print_ast_replaced(ast, sym, PTROFFG(sym));
3793 }
3794 }
3795 put_char(')');
3796 }
3797
3798 static void
put_string(char * str)3799 put_string(char *str)
3800 {
3801 int len;
3802
3803 len = strlen(str);
3804 check_len(len);
3805 strcpy(&lbuff[col], str);
3806 col += len;
3807 }
3808
3809 static void
put_mem_string(int ast,char * str)3810 put_mem_string(int ast, char *str)
3811 {
3812 if (A_TYPEG(ast) == A_MEM) {
3813 print_ast(A_PARENTG(ast));
3814 put_string("%");
3815 }
3816 put_string(str);
3817 }
3818
3819 static void
put_fstring(char * str)3820 put_fstring(char *str)
3821 {
3822 int len;
3823
3824 put_char('\'');
3825 /*
3826 * Can't use put_string() since may start 'str' on the next line leaving
3827 * 'spaces' after the quote.
3828 */
3829 len = strlen(str);
3830 while (len-- > 0)
3831 put_char(*str++);
3832 put_char('\'');
3833 }
3834
3835 static void
put_char(char ch)3836 put_char(char ch)
3837 {
3838 check_len(1);
3839 lbuff[col] = ch;
3840 col++;
3841 }
3842
3843 static void
put_const(int sptr)3844 put_const(int sptr)
3845 {
3846 int len; /* length of character string */
3847 char b[64];
3848 char *from;
3849 int c;
3850 int dtype;
3851 int sptr2;
3852
3853 dtype = DTYPEG(sptr);
3854 switch (DTY(dtype)) {
3855 case TY_WORD:
3856 sprintf(b, "z'%x'", CONVAL2G(sptr));
3857 put_l_to_u(b);
3858 return;
3859 case TY_DWORD:
3860 sprintf(b, "z'%x%08x'", CONVAL1G(sptr), CONVAL2G(sptr));
3861 put_l_to_u(b);
3862 return;
3863 case TY_BINT:
3864 case TY_SINT:
3865 case TY_INT:
3866 put_intkind(CONVAL2G(sptr), dtype);
3867 return;
3868 case TY_BLOG:
3869 case TY_SLOG:
3870 case TY_LOG:
3871 case TY_LOG8:
3872 put_logical(CONVAL2G(sptr), dtype);
3873 return;
3874 case TY_INT8:
3875 put_int8(sptr);
3876 return;
3877 case TY_REAL:
3878 if (NMPTRG(sptr)) {
3879 put_string(SYMNAME(sptr));
3880 return;
3881 }
3882 put_float(CONVAL2G(sptr));
3883 return;
3884
3885 case TY_DBLE:
3886 if (NMPTRG(sptr)) {
3887 put_string(SYMNAME(sptr));
3888 return;
3889 }
3890 put_double(sptr);
3891 return;
3892
3893 case TY_CMPLX:
3894 if (NMPTRG(sptr)) {
3895 put_string(SYMNAME(sptr));
3896 return;
3897 }
3898 put_char('(');
3899 put_float(CONVAL1G(sptr));
3900 put_char(',');
3901 put_float(CONVAL2G(sptr));
3902 put_char(')');
3903 return;
3904
3905 case TY_DCMPLX:
3906 if (NMPTRG(sptr)) {
3907 put_string(SYMNAME(sptr));
3908 return;
3909 }
3910 put_char('(');
3911 put_const((int)CONVAL1G(sptr));
3912 put_char(',');
3913 put_const((int)CONVAL2G(sptr));
3914 put_char(')');
3915 return;
3916
3917 case TY_HOLL:
3918 sptr2 = CONVAL1G(sptr);
3919 dtype = DTYPEG(sptr2);
3920 from = stb.n_base + CONVAL1G(sptr2);
3921 len = string_length(dtype);
3922 sprintf(b, "%d", len);
3923 put_string(b);
3924 b[0] = CONVAL2G(sptr); /* kind of hollerith - 'h', 'l', or 'r' */
3925 b[1] = '\0';
3926 put_l_to_u(b);
3927 while (len--) {
3928 c = *from++ & 0xff;
3929 put_char(c);
3930 }
3931 return;
3932
3933 case TY_NCHAR:
3934 sptr = CONVAL1G(sptr); /* sptr to char string constant */
3935 dtype = DTYPEG(sptr);
3936 put_l_to_u("nc");
3937 /*** fall thru ***/
3938 case TY_CHAR:
3939 from = stb.n_base + CONVAL1G(sptr);
3940 put_char('\'');
3941 len = string_length(dtype);
3942 while (len--)
3943 char_to_text(*from++);
3944 put_char('\'');
3945 return;
3946
3947 case TY_PTR:
3948 strcpy(b, "address constant");
3949 break;
3950
3951 default:
3952 strcpy(b, "bad_const_type");
3953 }
3954
3955 put_string(b);
3956 }
3957
3958 static void
put_int(INT val)3959 put_int(INT val)
3960 {
3961 char b[24];
3962 sprintf(b, "%d", val);
3963 put_string(b);
3964 }
3965
3966 static void
put_intkind(INT val,int dtype)3967 put_intkind(INT val, int dtype)
3968 {
3969 char b[30];
3970 INT vv;
3971 LOGICAL dokind;
3972 if (XBIT(57, 0x800)) {
3973 switch (DTY(dtype)) {
3974 case TY_BINT:
3975 vv = 0xffffff80;
3976 break;
3977 case TY_SINT:
3978 vv = 0xffff8000;
3979 break;
3980 case TY_INT:
3981 vv = 0x80000000;
3982 break;
3983 case TY_INT8:
3984 vv = 0;
3985 break;
3986 }
3987 }
3988 dokind = FALSE;
3989 if (DTY(DT_INT) != DTY(dtype)) {
3990 /* not default int - add _x to const */
3991 dokind = TRUE;
3992 }
3993 if (XBIT(57, 0x800) && val == vv) {
3994 sprintf(b, "%d", val + 1);
3995 if (dokind) {
3996 char *end;
3997 end = b + strlen(b);
3998 sprintf(end, "_%d", target_kind(dtype));
3999 }
4000 put_string("(");
4001 put_string(b);
4002 if (dokind) {
4003 sprintf(b, "-1_%d)", target_kind(dtype));
4004 } else {
4005 sprintf(b, "-1)");
4006 }
4007 put_string(b);
4008 } else {
4009 sprintf(b, "%d", val);
4010 if (dokind) {
4011 char *end;
4012 end = b + strlen(b);
4013 sprintf(end, "_%d", target_kind(dtype));
4014 }
4015 put_string(b);
4016 }
4017 }
4018
4019 static void
put_int8(int sptr)4020 put_int8(int sptr)
4021 {
4022 char b[30];
4023 INT num[2];
4024 LOGICAL dokind;
4025
4026 num[0] = CONVAL1G(sptr);
4027 num[1] = CONVAL2G(sptr);
4028 dokind = FALSE;
4029 if (DTY(DT_INT) != TY_INT8) {
4030 dokind = TRUE;
4031 }
4032 /* for most negative number, put out '(n-1)' */
4033 if (XBIT(57, 0x800) &&
4034 CONVAL1G(sptr) == (INT)(0x80000000) &&
4035 CONVAL2G(sptr) == 0) {
4036 num[1] = num[1] + 1;
4037 ui64toax(num, b, 22, 0, 10);
4038 if (dokind) {
4039 char *end;
4040 end = b + strlen(b);
4041 sprintf(end, "_%d", target_kind(DT_INT8));
4042 }
4043 put_string("(");
4044 put_string(b);
4045 if (dokind) {
4046 sprintf(b, "-1_%d)", target_kind(DT_INT8));
4047 } else {
4048 sprintf(b, "-1)");
4049 }
4050 put_string(b);
4051 } else {
4052 ui64toax(num, b, 22, 0, 10);
4053 if (dokind) {
4054 char *end;
4055 end = b + strlen(b);
4056 sprintf(end, "_%d", target_kind(DT_INT8));
4057 }
4058 put_string(b);
4059 }
4060 }
4061
4062 static void
put_logical(LOGICAL val,int dtype)4063 put_logical(LOGICAL val, int dtype)
4064 {
4065 char b[20];
4066 if (val & 1)
4067 sprintf(b, ".true.");
4068 else
4069 sprintf(b, ".false.");
4070 if (DTY(dtype) != DT_LOG) {
4071 char *bb;
4072 for (bb = b; *bb; ++bb)
4073 ;
4074 sprintf(bb, "_%d", target_kind(dtype));
4075 }
4076 put_string(b);
4077 }
4078
4079 static void
put_float(INT val)4080 put_float(INT val)
4081 {
4082 char b[64];
4083 char *start;
4084 char *end;
4085 int i;
4086 char *exp;
4087 int expw;
4088
4089 /* FIXME double cast is done to silence the warning, this needs to be
4090 * revisited! cprintf (our cprintf, not system routine) takes a pointer but
4091 * in this particular case uses is as an integer
4092 */
4093 cprintf(b, "%.10e", (INT *)((BIGINT)val));
4094 for (start = b; *start == ' '; start++) /* skip leading blanks */
4095 ;
4096 /* only leave the sign if it's '-' */
4097 if (*start == '+')
4098 start++;
4099
4100 /* locate beginning of exponent */
4101 exp = &b[strlen(b) - 1];
4102 expw = -1; /* width of exponent less 'E' and the sign */
4103 while (*exp != 'E' && *exp != 'e' && *exp != 'D' && *exp != 'd') {
4104 if (exp <= start) {
4105 /* output from cprintf is [-]INF */
4106 if (*start == '-')
4107 put_char('-');
4108 put_string("1e+39");
4109 return;
4110 }
4111 exp--;
4112 expw++;
4113 }
4114
4115 i = (exp - b) - 1; /* last decimal digit */
4116 /*
4117 * omit trailing 0's; don't omit digit after the decimal point.
4118 */
4119 while (b[i] == '0' && i > 3)
4120 i--;
4121 end = &b[i + 1];
4122 /* exp locates 'E' */
4123 *end++ = 'e';
4124 if (*++exp == '-') /* sign */
4125 *end++ = '-';
4126 if (expw == 2) {
4127 if (*++exp != '0')
4128 *end++ = *exp;
4129 *end++ = *++exp;
4130 } else {
4131 while (expw--)
4132 *end++ = *++exp;
4133 }
4134 if (DTY(DT_REAL) != TY_REAL) {
4135 /* f90 output */
4136 *end++ = '_';
4137 sprintf(end, "%d", target_kind(DT_REAL4));
4138 } else
4139 *end = '\0';
4140 put_string(start);
4141 }
4142
4143 static void
put_double(int sptr)4144 put_double(int sptr)
4145 {
4146 INT num[2];
4147 char b[64];
4148 char *start;
4149 char *end;
4150 char *exp;
4151 int expw;
4152 int i;
4153
4154 num[0] = CONVAL1G(sptr);
4155 num[1] = CONVAL2G(sptr);
4156
4157 /* warning: there may be 2 or digits in the exponent -- D<sign>dd or
4158 * D<sign>ddd.
4159 */
4160
4161 if (XBIT(49, 0x40000)) /* C90 */
4162 cprintf(b, "%.15ld", num);
4163 else
4164 cprintf(b, "%.17ld", num);
4165
4166 for (start = b; *start == ' '; start++) /* skip leading blanks */
4167 ;
4168 /* only leave the sign if it's '-' */
4169 if (*start == '+')
4170 start++;
4171
4172 /* locate beginning of exponent */
4173 exp = &b[strlen(b) - 1];
4174 expw = -1; /* width of exponent less 'D' and the sign */
4175 while (*exp != 'E' && *exp != 'e' && *exp != 'D' && *exp != 'd') {
4176 if (exp <= start) {
4177 /* output from cprintf is [-]INF */
4178 if (*start == '-')
4179 put_char('-');
4180 put_string("1d+309");
4181 return;
4182 }
4183 exp--;
4184 expw++;
4185 }
4186
4187 i = (exp - b) - 1; /* last decimal digit */
4188 /*
4189 * omit trailing 0's; don't omit digit after the decimal point.
4190 */
4191 while (b[i] == '0' && i > 3)
4192 i--;
4193 end = &b[i + 1];
4194 /* exp locates 'D' */
4195 if (DTY(DT_REAL) == TY_DBLE && XBIT(49, 0x800000))
4196 /* change 'd' to 'e' only if default real is double precision for
4197 * the cray systems.
4198 */
4199 *end++ = 'e';
4200 else
4201 *end++ = 'd';
4202 if (*++exp == '-') /* sign */
4203 *end++ = '-';
4204 if (expw == 2) {
4205 if (*++exp != '0')
4206 *end++ = *exp;
4207 *end++ = *++exp;
4208 } else {
4209 while (expw--)
4210 *end++ = *++exp;
4211 }
4212 *end = '\0';
4213 put_string(start);
4214 }
4215
4216 /*
4217 * emit a character with consideration given to the ', escape sequences,
4218 * unprintable characters, etc.
4219 */
4220 static void
char_to_text(int ch)4221 char_to_text(int ch)
4222 {
4223 int c;
4224 char b[8];
4225
4226 c = ch & 0xff;
4227 if (c == '\\' && !XBIT(124, 0x40)) {
4228 put_char('\\');
4229 put_char('\\');
4230 } else if (c == '\'') {
4231 put_char('\'');
4232 put_char('\'');
4233 } else if (c >= ' ' && c <= '~')
4234 put_char(c);
4235 else if (XBIT(52, 0x10)) {
4236 put_char(c);
4237 } else if (c == '\n') {
4238 put_char('\\');
4239 put_char('n');
4240 } else if (c == '\t') {
4241 put_char('\\');
4242 put_char('t');
4243 } else if (c == '\v') {
4244 put_char('\\');
4245 put_char('v');
4246 } else if (c == '\b') {
4247 put_char('\\');
4248 put_char('b');
4249 } else if (c == '\r') {
4250 put_char('\\');
4251 put_char('r');
4252 } else if (c == '\f') {
4253 put_char('\\');
4254 put_char('f');
4255 } else {
4256 /* Mask off 8 bits worth of unprintable character */
4257 sprintf(b, "\\%03o", c);
4258 put_string(b);
4259 }
4260 }
4261
4262 /* emit name when it's known to contain uppercase letters;
4263 * convert upper to lower if necessary.
4264 */
4265 static void
put_u_to_l(char * name)4266 put_u_to_l(char *name)
4267 {
4268 char ch;
4269
4270 if (flg.ucase)
4271 put_string(name);
4272 else {
4273 check_len(strlen(name));
4274 while ((ch = *name++)) {
4275 ch &= 0xff;
4276 if (isupper(ch))
4277 ch += 32;
4278 lbuff[col] = ch;
4279 col++;
4280 }
4281 }
4282 }
4283
4284 /* emit name when it's known to contain lowercase letters, e.g., keywords.
4285 * TBD - convert lower to upper if necessary.
4286 */
4287 static void
put_l_to_u(char * name)4288 put_l_to_u(char *name)
4289 {
4290 put_string(name);
4291 }
4292
4293 static int just_did_sharpline = 0;
4294
4295 static void
write_next_line(void)4296 write_next_line(void)
4297 {
4298 lbuff[col] = '\0';
4299 fprintf(outfile, "%s\n", lbuff);
4300 just_did_sharpline = 0;
4301 col = 0;
4302 }
4303
4304 static void
check_len(int len)4305 check_len(int len)
4306 {
4307 if ((len + col) > max_col) {
4308 write_next_line();
4309 ++continuations;
4310 }
4311 }
4312
4313 static char *
label_name(int lab)4314 label_name(int lab)
4315 {
4316 char *nm;
4317 char lbuff[8];
4318 static int lbavail = 99999;
4319
4320 nm = SYMNAME(lab);
4321 if (CCSYMG(lab)) {
4322 /* compiler-created label - ensure that its number doesn't conflict
4323 * with a user label.
4324 */
4325 int lb;
4326
4327 if (SYMLKG(lab))
4328 /* one is already created */
4329 lb = SYMLKG(lab);
4330 else {
4331 lbuff[0] = '.'; /* user label begins with '.L' */
4332 strcpy(&lbuff[1], nm + 1); /* copy 'L' followed by the digits */
4333 /*
4334 * search for a label which doesn't conflict.
4335 */
4336 while (TRUE) {
4337 if (lookupsym(lbuff, 7) == 0)
4338 break;
4339 sprintf(&lbuff[2], "%05d", lbavail--);
4340 }
4341 lb = getsym(lbuff, 7);
4342 STYPEP(lb, ST_LABEL);
4343 SYMLKP(lab, lb);
4344 }
4345 nm = SYMNAME(lb);
4346 }
4347 nm += 2; /* skip past .L */
4348 while (*nm == '0')
4349 nm++; /* skip over leading 0's */
4350 return nm;
4351 }
4352
4353 /* subp is the sptr of subprogram */
4354 static void
print_header(int subp)4355 print_header(int subp)
4356 {
4357 int dscptr;
4358 int arg;
4359 int i;
4360
4361 print_sname(subp);
4362 put_char('(');
4363 if ((i = PARAMCTG(subp))) {
4364 dscptr = DPDSCG(subp);
4365 while (TRUE) {
4366 arg = aux.dpdsc_base[dscptr];
4367 if (arg)
4368 put_string(SYMNAME(arg));
4369 else
4370 put_char('*'); /* alternate return specifier */
4371 if (--i == 0)
4372 break;
4373 put_char(',');
4374 dscptr++;
4375 }
4376 }
4377 put_char(')');
4378 }
4379
4380 /** \brief Add parameters in the order in which they were declared.
4381 */
4382 void
add_param(int sptr)4383 add_param(int sptr)
4384 {
4385 _A_Q *q;
4386
4387 if (sem.which_pass == 0)
4388 return;
4389 if (VAXG(sptr)) {
4390 if (A_TYPEG(CONVAL2G(sptr)) == A_CNST)
4391 q = &vx_params.q;
4392 else
4393 q = &vx_params.q_e;
4394 } else {
4395 if (A_TYPEG(CONVAL2G(sptr)) == A_CNST)
4396 q = ¶ms.q;
4397 else
4398 q = ¶ms.q_e;
4399 }
4400
4401 if (q->first == 0)
4402 q->first = sptr;
4403 else
4404 SYMLKP(q->last, sptr);
4405 q->last = sptr;
4406 SYMLKP(sptr, 0);
4407 ENDP(sptr, 0);
4408 }
4409
4410 /** \brief Since a separate list is created for each parameter combination of
4411 ansi-/vax- style and constant/non-constant ast, it is necessary to
4412 mark where in the list the contributions from a each parameter statement
4413 ends.
4414 */
4415 void
end_param(void)4416 end_param(void)
4417 {
4418 static _A_Q *q[] = {¶ms.q, ¶ms.q_e, &vx_params.q, &vx_params.q_e};
4419 int i;
4420
4421 for (i = 0; i < 4; i++) {
4422 if (q[i]->first)
4423 ENDP(q[i]->last, 1);
4424 }
4425 }
4426
4427 static void
pghpf_entry(int func)4428 pghpf_entry(int func)
4429 {
4430 INT fl;
4431
4432 if (!XBIT(49, 0x1000))
4433 return;
4434
4435 /* pghpf_function_entry(line,nlines,function,file) */
4436
4437 put_l_to_u("call ");
4438 put_string(mkRteRtnNm(RTE_function_entrya));
4439 put_char('(');
4440 fl = FUNCLINEG(func);
4441 put_int(fl);
4442 put_char(',');
4443 put_int(ENDLINEG(func) - fl + 1);
4444 put_char(',');
4445 put_fstring(SYMNAME(func));
4446 put_char(',');
4447 put_fstring(gbl.src_file);
4448 put_char(')');
4449 }
4450
4451 void
dbg_print_ast(int ast,FILE * fil)4452 dbg_print_ast(int ast, FILE *fil)
4453 {
4454 int save_max_col;
4455
4456 col = 0;
4457 if (fil == NULL)
4458 fil = stderr;
4459 outfile = fil;
4460 save_max_col = max_col;
4461 max_col = 299;
4462 init_line();
4463 indent = 0;
4464 ast_is_comment = TRUE;
4465 print_ast(ast);
4466 if (col != 0)
4467 write_next_line();
4468 ast_is_comment = FALSE;
4469 max_col = save_max_col;
4470 }
4471
4472 void
dbg_print_stmts(FILE * f)4473 dbg_print_stmts(FILE *f)
4474 {
4475 int std;
4476 int ast;
4477
4478 if (f == NULL)
4479 f = stderr;
4480 for (std = STD_NEXT(0); std; std = STD_NEXT(std)) {
4481 ast = STD_AST(std);
4482 dbg_print_ast(ast, f);
4483 }
4484 }
4485
4486 void
printast(int ast)4487 printast(int ast)
4488 {
4489 if (gbl.dbgfil == NULL) {
4490 outfile = stderr;
4491 } else {
4492 outfile = gbl.dbgfil;
4493 }
4494 indent = 0;
4495 col = 0;
4496 ast_is_comment = TRUE;
4497 print_ast(ast);
4498 lbuff[col] = '\0';
4499 fprintf(outfile, "%s", lbuff);
4500 ast_is_comment = FALSE;
4501 }
4502