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 Fortran data type utility functions.
21 */
22
23 #include "gbldefs.h"
24 #include "global.h"
25 #include "error.h"
26 #include "symtab.h"
27 #include "dtypeutl.h"
28 #include "machar.h"
29 #include "machardf.h"
30 #include "ast.h"
31 #include "rte.h"
32 #include "symutl.h"
33
34 static TY_KIND get_ty_kind(DTYPE);
35 static LOGICAL get_kind_set_parm(int, DTYPE, int *);
36 static int get_len_set_parm(int, DTYPE, int *);
37 static DTYPE get_iso_derivedtype(DTYPE);
38 static DTYPE get_cuf_derivedtype(DTYPE);
39 static int ic_strcmp(char *str, char *pattern);
40
41 static int size_sym = 0;
42
43 char *
target_name(DTYPE dtype)44 target_name(DTYPE dtype)
45 {
46 TY_KIND ty = get_ty_kind(dtype);
47 switch (ty) {
48 case TY_DCMPLX:
49 if (XBIT(57, 0x200)) {
50 return "complex*16";
51 }
52 /* else fall through */
53 case TY_LOG:
54 case TY_INT:
55 case TY_FLOAT:
56 case TY_SLOG:
57 case TY_SINT:
58 case TY_BINT:
59 case TY_BLOG:
60 case TY_DBLE:
61 case TY_QUAD:
62 case TY_CMPLX:
63 case TY_QCMPLX:
64 case TY_INT8:
65 case TY_LOG8:
66 case TY_CHAR:
67 case TY_NCHAR:
68 return dtypeinfo[ty].target_type;
69
70 default:
71 interr("target_name: bad dtype ", ty, 3);
72 return "";
73 }
74 }
75
76 int
target_kind(DTYPE dtype)77 target_kind(DTYPE dtype)
78 {
79 TY_KIND ty = get_ty_kind(dtype);
80 switch (ty) {
81 case TY_LOG:
82 case TY_INT:
83 case TY_FLOAT:
84 case TY_SLOG:
85 case TY_SINT:
86 case TY_BINT:
87 case TY_BLOG:
88 case TY_DBLE:
89 case TY_QUAD:
90 case TY_CMPLX:
91 case TY_DCMPLX:
92 case TY_QCMPLX:
93 case TY_INT8:
94 case TY_LOG8:
95 case TY_CHAR:
96 case TY_NCHAR:
97 return dtypeinfo[ty].target_kind;
98
99 default:
100 interr("target_kind: bad dtype ", ty, 3);
101 return 0;
102 }
103 }
104
105 ISZ_T
size_of(DTYPE dtype)106 size_of(DTYPE dtype)
107 {
108 ISZ_T d, nelems, sz;
109 INT clen;
110 ADSC *ad;
111
112 TY_KIND ty = get_ty_kind(dtype);
113 switch (ty) {
114 case TY_WORD:
115 case TY_DWORD:
116 case TY_LOG:
117 case TY_INT:
118 case TY_FLOAT:
119 case TY_PTR:
120 case TY_SLOG:
121 case TY_SINT:
122 case TY_BINT:
123 case TY_BLOG:
124 case TY_DBLE:
125 case TY_QUAD:
126 case TY_CMPLX:
127 case TY_DCMPLX:
128 case TY_QCMPLX:
129 case TY_INT8:
130 case TY_LOG8:
131 return dtypeinfo[ty].size;
132
133 case TY_HOLL:
134 /* treat like default integer type */
135 return dtypeinfo[DTY(DT_INT)].size;
136
137 case TY_CHAR:
138 if (dtype == DT_ASSCHAR || dtype == DT_DEFERCHAR)
139 interr("size_of: attempt to get size of assumed size character", 0, 3);
140 clen = string_length(dtype);
141 return clen;
142
143 case TY_NCHAR:
144 if (dtype == DT_ASSNCHAR || dtype == DT_DEFERNCHAR)
145 interr("size_of: attempt to get size of assumed size ncharacter", 0, 3);
146 clen = string_length(dtype);
147 return 2 * clen;
148
149 case TY_ARRAY:
150 if ((d = DTY(dtype + 2)) <= 0) {
151 interr("size_of: no array descriptor", (int)d, 3);
152 return size_of((int)DTY(dtype + 1));
153 }
154 ad = AD_DPTR(dtype);
155 if (AD_DEFER(ad)) {
156 return dtypeinfo[DTY(DT_PTR)].size;
157 }
158 if (AD_NUMELM(ad) == 0) {
159 /* illegal use of adjustable or assumed-size array:
160 should have been caught in semant. */
161 /* errsev(50); */
162 if (XBIT(68, 0x1)) {
163 AD_NUMELM(ad) = astb.k1;
164 d = stb.i1;
165 } else {
166 AD_NUMELM(ad) = astb.i1;
167 d = stb.i1;
168 }
169 } else {
170 switch (A_TYPEG(AD_NUMELM(ad))) {
171 case A_BINOP:
172 case A_UNOP:
173 /* FS#20474: Occurs with length type parameters. Treat as
174 * as if AD_DEFER(ad) is set (see case above).
175 * This also avoids an ICE from call to sym_of_ast() below.
176 */
177 return dtypeinfo[DTY(DT_PTR)].size;
178 }
179 d = AD_NUMELM(ad);
180 if (A_TYPEG(d) == A_INTR) {
181 switch (A_OPTYPEG(d)) {
182 case I_INT1:
183 case I_INT2:
184 case I_INT4:
185 case I_INT8:
186 case I_INT:
187 /* FS#22205: This can occur with -mcmodel=medium */
188 d = A_ARGSG(d);
189 break;
190 default:
191 interr("size_of: unexpected intrinsic optype ", A_OPTYPEG(d), 3);
192 }
193 }
194 d = sym_of_ast(d);
195 if (d == stb.i0 || STYPEG(d) != ST_CONST) {
196 /* illegal use of adjustable or assumed-size array:
197 should have been caught in semant. */
198 /* errsev(50); */
199 AD_NUMELM(ad) = astb.i1;
200 d = stb.i1;
201 }
202 if (XBIT(68, 0x1) && d == stb.k0) {
203 AD_NUMELM(ad) = astb.k1;
204 d = stb.k1;
205 }
206 }
207 if (XBIT(68, 0x1)) {
208 INT num[2];
209 num[0] = CONVAL1G(d);
210 num[1] = CONVAL2G(d);
211 INT64_2_ISZ(num, d);
212 } else
213 d = CONVAL2G(d);
214 nelems = d;
215 sz = size_of((int)DTY(dtype + 1));
216 d = d * sz;
217 if (size_sym && (d < nelems || d < sz) && nelems && sz) {
218 return -1;
219 }
220 return d;
221
222 case TY_STRUCT:
223 case TY_UNION:
224 case TY_DERIVED:
225 if (DTY(dtype + 1) == 0) {
226 errsev(151);
227 return 4;
228 } else
229 return DTY(dtype + 2);
230
231 default:
232 interr("size_of: bad dtype ", ty, 3);
233 return 1;
234 }
235 }
236
237 /** \brief Return length of constant char string data type */
238 int
string_length(DTYPE dtype)239 string_length(DTYPE dtype)
240 {
241 int clen;
242 switch (DTY(dtype)) {
243 case TY_CHAR:
244 case TY_NCHAR:
245 break;
246 default:
247 interr("string length applied to nonstring datatype", dtype, 2);
248 return 1;
249 }
250 clen = DTY(dtype + 1); /* get length ast */
251 clen = A_ALIASG(clen); /* get constant alias */
252 clen = A_SPTRG(clen); /* get constant symbol */
253 clen = CONVAL2G(clen); /* get constant value */
254 if (clen < 0)
255 return 0;
256 return clen;
257 }
258
259 /*
260 * A framework for recursively scanning derived types and their members
261 * with pluggable predicates follows. The results are not cached,
262 * but probably could be. This code is used below to replace a series
263 * of functions that used boilerplate to implement their own variant
264 * frameworks.
265 */
266
267 /* Visitation lists record the datatypes that have been visited and
268 * whether those visits remain active.
269 */
270 struct visit_list {
271 DTYPE dtype;
272 LOGICAL is_active;
273 struct visit_list *next;
274 };
275
276 static struct visit_list *
visit_list_scan(struct visit_list * list,DTYPE dtype)277 visit_list_scan(struct visit_list *list, DTYPE dtype)
278 {
279 for (; list; list = list->next) {
280 if (list->dtype == dtype)
281 break;
282 }
283 return list;
284 }
285
286 static void
visit_list_push(struct visit_list ** list,DTYPE dtype)287 visit_list_push(struct visit_list **list, DTYPE dtype)
288 {
289 struct visit_list *newlist;
290 NEW(newlist, struct visit_list, 1);
291 newlist->dtype = dtype;
292 newlist->is_active = TRUE;
293 newlist->next = *list;
294 *list = newlist;
295 }
296
297 static void
visit_list_free(struct visit_list ** list)298 visit_list_free(struct visit_list **list)
299 {
300 struct visit_list *p;
301 while ((p = *list)) {
302 *list = p->next;
303 FREE(p);
304 }
305 }
306
307 static LOGICAL
is_container_dtype(DTYPE dtype)308 is_container_dtype(DTYPE dtype)
309 {
310 if (dtype > 0) {
311 if (is_array_dtype(dtype))
312 dtype = array_element_dtype(dtype);
313 switch (DTYG(dtype)) {
314 case TY_DERIVED:
315 case TY_STRUCT:
316 case TY_UNION:
317 return TRUE;
318 }
319 }
320 return FALSE;
321 }
322
323 /* Forward declare is_recursive() here so that search_type_members()
324 * below can identify it as a special case.
325 */
326 static LOGICAL is_recursive(int sptr, struct visit_list **visited);
327
328 typedef LOGICAL (*stm_predicate_t)(int member_sptr,
329 struct visit_list **visited);
330
331 /* search_type_members() is a potentially recursive scanner of
332 * derived types that applies a given predicate function against the
333 * component members. Returns TRUE if any application of the predicate
334 * is satisfied. The predicate function can (and usually does) indirectly
335 * recursively call search_type_members() to scan the types of
336 * members, but it has the option to recurse conditionally or not at all.
337 */
338 static LOGICAL
search_type_members(DTYPE dtype,stm_predicate_t predicate,struct visit_list ** visited)339 search_type_members(DTYPE dtype, stm_predicate_t predicate,
340 struct visit_list **visited)
341 {
342 LOGICAL result = FALSE;
343
344 if (is_array_dtype(dtype))
345 dtype = array_element_dtype(dtype);
346 if (is_container_dtype(dtype)) {
347 int member_sptr = DTY(dtype + 1);
348 struct visit_list *active = visit_list_scan(*visited, dtype);
349
350 if (active) {
351 /* This dtype has already been scanned or is in process.
352 * Cut off the scan, and return FALSE unless the search
353 * is for recursive types and we've just found one.
354 */
355 return predicate == is_recursive && active->is_active;
356 }
357
358 visit_list_push(visited, dtype);
359 active = *visited;
360
361 /* Traverse the members of the derived type. */
362 while (member_sptr > NOSYM && !(result = predicate(member_sptr, visited))) {
363 member_sptr = SYMLKG(member_sptr);
364 }
365
366 /* The scan of this data type is complete. Leave it on the visited
367 * list to forestall another failed pass later.
368 */
369 active->is_active = FALSE;
370 }
371 return result;
372 }
373
374 /* Wraps a call to search_type_members() above with the construction
375 * and destruction of its visitation list.
376 */
377 static LOGICAL
search_type_members_wrapped(DTYPE dtype,stm_predicate_t predicate)378 search_type_members_wrapped(DTYPE dtype, stm_predicate_t predicate)
379 {
380 struct visit_list *visited = NULL;
381 LOGICAL result = search_type_members(dtype, predicate, &visited);
382 visit_list_free(&visited);
383 return result;
384 }
385
386 /* Driver for predicates that use search_type_members(); it sets up and
387 * tears down the visitation list that search_type_members() uses.
388 * N.B. this function will succeed if the supplied predicate is true on
389 * the initial symbol table index, even if it's not a component.
390 */
391 static LOGICAL
test_sym_and_components(int sptr,stm_predicate_t predicate)392 test_sym_and_components(int sptr, stm_predicate_t predicate)
393 {
394 struct visit_list *visited = NULL;
395 LOGICAL result = predicate(sptr, &visited);
396 visit_list_free(&visited);
397 return result;
398 }
399
400 static LOGICAL
test_sym_components_only(int sptr,stm_predicate_t predicate)401 test_sym_components_only(int sptr, stm_predicate_t predicate)
402 {
403 return sptr > NOSYM && search_type_members_wrapped(DTYPEG(sptr), predicate);
404 }
405
406 /** \brief Check for special case of empty typedef which has a size of 0
407 but one member of type DT_NONE to indicate that the type is
408 empty and not incomplete, a forward reference, etc.
409 */
410 LOGICAL
is_empty_typedef(DTYPE dtype)411 is_empty_typedef(DTYPE dtype)
412 {
413 SPTR sptr;
414 if (dtype) {
415 if (is_array_dtype(dtype))
416 dtype = array_element_dtype(dtype);
417 switch (DTY(dtype)) {
418 case TY_DERIVED:
419 case TY_UNION:
420 case TY_STRUCT:
421 for (sptr = DTY(dtype + 1); sptr > NOSYM;
422 sptr = SYMLKG(sptr)) {
423 /* Type parameters are not data components. Skip type parameters. */
424 if (SETKINDG(sptr) || LENPARMG(sptr)) {
425 continue;
426 }
427 return FALSE;
428 }
429 return TRUE;
430 }
431 }
432 return FALSE;
433 }
434
435 static LOGICAL
is_recursive_dtype(int sptr,struct visit_list ** visited)436 is_recursive_dtype(int sptr, struct visit_list **visited)
437 {
438 return sptr > NOSYM &&
439 search_type_members(sptr, is_recursive_dtype, visited);
440 }
441
442 /* N.B., no_data_components_recursive() will only ever be true for
443 * data types that are containers, so types like INTEGER will map to FALSE.
444 */
445 static bool
no_data_components_recursive(DTYPE dtype,stm_predicate_t predicate,struct visit_list ** visited)446 no_data_components_recursive(DTYPE dtype, stm_predicate_t predicate, struct visit_list **visited)
447 {
448 /* For the derived type in dtype: Returns true if dtype is empty or
449 * if it does not contain any data components (i.e., a derived type with
450 * type bound procedures returns false). Otherwise, returns false.
451 */
452 int mem_sptr;
453 struct visit_list *active;
454 if (is_array_dtype(dtype))
455 dtype = array_element_dtype(dtype);
456 active = visit_list_scan(*visited, dtype);
457 if (is_empty_typedef(dtype))
458 return TRUE;
459 if (!is_container_dtype(dtype))
460 return FALSE;
461 if (active) {
462 /* This dtype has already been scanned or is in process.
463 * Cut off the scan, and return FALSE unless the search
464 * is for recursive types and we've just found one.
465 */
466 return predicate == is_recursive_dtype && active->is_active;
467 }
468
469 visit_list_push(visited, dtype);
470 active = *visited;
471
472 for (mem_sptr = DTY(dtype + 1); mem_sptr > NOSYM;
473 mem_sptr = SYMLKG(mem_sptr)) {
474 if (DTYG(DTYPEG(mem_sptr)) == TY_DERIVED) {
475 if (!no_data_components_recursive(DTYPEG(mem_sptr), is_recursive_dtype, visited)) {
476 active->is_active = FALSE;
477 return FALSE;
478 }
479 } else if (!CLASSG(mem_sptr) || !BINDG(mem_sptr) || !VTABLEG(mem_sptr)) {
480 active->is_active = FALSE;
481 return FALSE;
482 }
483 }
484 return TRUE;
485 }
486
487 /* Wrapper to no_data_components_recursive() to detect cycles. */
488 LOGICAL
no_data_components(DTYPE dtype)489 no_data_components(DTYPE dtype)
490 {
491 struct visit_list *visited = NULL;
492 LOGICAL result = no_data_components_recursive(dtype, is_recursive_dtype, &visited);
493 visit_list_free(&visited);
494 return result;
495 }
496
497 /** \brief Return the size of this variable, taking into account
498 such things like whether the variable is a pointer */
499 ISZ_T
size_of_var(int sptr)500 size_of_var(int sptr)
501 {
502 DTYPE dtype;
503 ISZ_T sz;
504
505 if (is_tbp_or_final(sptr)) {
506 return 0; /* type bound procedure */
507 }
508 dtype = DTYPEG(sptr);
509
510 if (POINTERG(sptr) || ALLOCG(sptr)) {
511 if (DTY(dtype) == TY_ARRAY) {
512 /* array pointer, size of pointer+offset+descriptor */
513 /* pointer is a pointer, offset and descriptor are DT_INT */
514 int rank = ADD_NUMDIM(dtype);
515 int descsize = get_descriptor_len(rank);
516 return dtypeinfo[TY_PTR].size +
517 (descsize + 1) * dtypeinfo[DTY(stb.dt_int)].size;
518 }
519 /* scalar pointer, size of pointer */
520 return dtypeinfo[TY_PTR].size;
521 }
522 /* not a pointer, just return the size of the type of the variable */
523 if (STYPEG(sptr) == ST_PLIST) {
524 sz = PLLENG(sptr) * size_of(dtype);
525 return sz;
526 }
527
528 /* normal size of */
529 size_sym = sptr;
530 sz = size_of(dtype);
531 if (sz < 0) {
532 error(219, 3, gbl.lineno, SYMNAME(sptr), NULL);
533 sz = 1;
534 }
535 size_sym = 0;
536 return sz;
537 } /* size_of_var */
538
539 INT
size_ast(int sptr,DTYPE dtype)540 size_ast(int sptr, DTYPE dtype)
541 {
542 INT d, len, clen, mlpyr = 1;
543 ISZ_T val1;
544 TY_KIND ty = get_ty_kind(dtype);
545
546 switch (ty) {
547 case TY_WORD:
548 case TY_DWORD:
549 case TY_LOG:
550 case TY_INT:
551 case TY_FLOAT:
552 case TY_PTR:
553 case TY_SLOG:
554 case TY_SINT:
555 case TY_BINT:
556 case TY_BLOG:
557 case TY_DBLE:
558 case TY_QUAD:
559 case TY_CMPLX:
560 case TY_DCMPLX:
561 case TY_QCMPLX:
562 case TY_INT8:
563 case TY_LOG8:
564 return mk_isz_cval(dtypeinfo[ty].size, astb.bnd.dtype);
565
566 case TY_HOLL:
567 /* treat like default integer type */
568 return mk_isz_cval(dtypeinfo[DTY(DT_INT)].size, astb.bnd.dtype);
569
570 case TY_NCHAR:
571 mlpyr = 2;
572 case TY_CHAR:
573 if (dtype == DT_ASSCHAR || dtype == DT_DEFERCHAR
574 || dtype == DT_ASSNCHAR || dtype == DT_DEFERNCHAR
575 ) {
576 if (dtype == DT_ASSCHAR || dtype == DT_DEFERCHAR
577 || dtype == DT_ASSNCHAR || dtype == DT_DEFERNCHAR
578 ) {
579 clen = ast_intr(I_LEN, astb.bnd.dtype, 1, mk_id(sptr));
580 } else {
581 clen = DTY(dtype+1);
582 }
583 } else if (ADJLENG(sptr) && !F90POINTERG(sptr)) {
584 /* don't add CVLEN for local automatic character */
585 clen = CVLENG(sptr);
586 if (clen == 0) {
587 clen = sym_get_scalar(SYMNAME(sptr), "len", astb.bnd.dtype);
588 CVLENP(sptr, clen);
589 if (SCG(sptr) == SC_DUMMY)
590 CCSYMP(clen, 1);
591 }
592 clen = mk_id(clen);
593 } else {
594 clen = DTY(dtype + 1);
595 if (A_ALIASG(clen)) {
596 clen = A_ALIASG(clen);
597 clen = A_SPTRG(clen);
598 clen = CONVAL2G(clen);
599 return mk_isz_cval(mlpyr * clen, astb.bnd.dtype);
600 }
601 clen = mk_convert(clen, astb.bnd.dtype);
602 }
603 if (mlpyr != 1) {
604 len = mk_isz_cval(mlpyr, astb.bnd.dtype);
605 clen = mk_binop(OP_MUL, len, clen, astb.bnd.dtype);
606 }
607 return clen;
608
609 case TY_ARRAY:
610 len = size_ast(sptr, DTY(dtype + 1));
611 if (DTY(dtype + 2) <= 0) {
612 interr("size_ast: no array descriptor", dtype, 3);
613 return len;
614 }
615 if (ADD_DEFER(dtype)) {
616 return mk_isz_cval(dtypeinfo[DTY(DT_PTR)].size, astb.bnd.dtype);
617 }
618 if (ADD_NUMELM(dtype) == 0) {
619 /* illegal use of adjustable or assumed-size array:
620 should have been caught in semant. */
621 /* errsev(50); */
622 ADD_NUMELM(dtype) = astb.bnd.one;
623 d = stb.i1;
624 } else {
625 d = sym_of_ast(ADD_NUMELM(dtype));
626 if (d == stb.i0 || STYPEG(d) != ST_CONST) {
627 /* illegal use of adjustable or assumed-size array:
628 should have been caught in semant. */
629 /* errsev(50); */
630 ADD_NUMELM(dtype) = astb.bnd.one;
631 d = stb.i1;
632 }
633 }
634 val1 = ad_val_of(d);
635 if (A_TYPEG(len) == A_CNST) {
636 int dd;
637 ISZ_T val2;
638
639 dd = sym_of_ast(len);
640 if (STYPEG(dd) != ST_CONST) {
641 dd = stb.i1;
642 }
643 val2 = ad_val_of(dd);
644 return mk_isz_cval(val1 * val2, astb.bnd.dtype);
645 }
646 d = mk_cval(val1, astb.bnd.dtype);
647 return mk_binop(OP_MUL, d, len, astb.bnd.dtype);
648
649 case TY_STRUCT:
650 case TY_UNION:
651 case TY_DERIVED:
652 if (DTY(dtype + 2) <= 0 && (!CLASSG(sptr) || !DTY(dtype + 1)) &&
653 !has_tbp_or_final(dtype) && !UNLPOLYG(DTY(dtype + 3))) {
654 return mk_isz_cval(4, astb.bnd.dtype);
655 } else {
656 return mk_isz_cval(DTY(dtype + 2), astb.bnd.dtype);
657 }
658
659 default:
660 interr("size_ast: bad dtype", ty, 3);
661 return mk_isz_cval(1, astb.bnd.dtype);
662 }
663 }
664
665 /** \brief Like size_ast(), but pass an AST, allowing for member references */
666 INT
size_ast_of(int ast,DTYPE dtype)667 size_ast_of(int ast, DTYPE dtype)
668 {
669 INT d, len, clen, mlpyr = 1, sptr = 0, concat;
670 ISZ_T val;
671 TY_KIND ty = get_ty_kind(dtype);
672
673 switch (ty) {
674 case TY_WORD:
675 case TY_DWORD:
676 case TY_LOG:
677 case TY_INT:
678 case TY_FLOAT:
679 case TY_PTR:
680 case TY_SLOG:
681 case TY_SINT:
682 case TY_BINT:
683 case TY_BLOG:
684 case TY_DBLE:
685 case TY_QUAD:
686 case TY_CMPLX:
687 case TY_DCMPLX:
688 case TY_QCMPLX:
689 case TY_INT8:
690 case TY_LOG8:
691 return mk_isz_cval(dtypeinfo[ty].size, astb.bnd.dtype);
692
693 case TY_HOLL:
694 /* treat like default integer type */
695 return mk_isz_cval(dtypeinfo[DTY(DT_INT)].size, astb.bnd.dtype);
696
697 case TY_NCHAR:
698 mlpyr = 2;
699 case TY_CHAR:
700 concat = 0;
701 if (ast) {
702 if (A_TYPEG(ast) == A_SUBSTR)
703 ast = A_LOPG(ast);
704 if (A_TYPEG(ast) == A_SUBSCR)
705 ast = A_LOPG(ast);
706 if (A_TYPEG(ast) == A_FUNC)
707 ast = A_LOPG(ast);
708 if (A_TYPEG(ast) == A_CNST) {
709 sptr = A_SPTRG(ast);
710 } else if (A_TYPEG(ast) == A_ID) {
711 sptr = A_SPTRG(ast);
712 } else if (A_TYPEG(ast) == A_MEM) {
713 sptr = A_SPTRG(A_MEMG(ast));
714 } else if (A_TYPEG(ast) == A_BINOP && A_OPTYPEG(ast) == OP_CAT) {
715 sptr = 0;
716 concat = 1;
717 } else {
718 interr("size_ast_of: unexpected ast type", A_TYPEG(ast), 3);
719 sptr = 0;
720 }
721 } else {
722 sptr = 0;
723 }
724 if (sptr && (dtype == DT_ASSCHAR || dtype == DT_DEFERCHAR
725 || dtype == DT_ASSNCHAR || dtype == DT_DEFERNCHAR
726 )) {
727 clen = ast_intr(I_LEN, astb.bnd.dtype, 1, ast);
728 } else if (sptr && ADJLENG(sptr) && !F90POINTERG(sptr)) {
729 /* don't add CVLEN for local automatic character */
730 clen = CVLENG(sptr);
731 if (clen == 0) {
732 clen = sym_get_scalar(SYMNAME(sptr), "len", astb.bnd.dtype);
733 CVLENP(sptr, clen);
734 if (SCG(sptr) == SC_DUMMY)
735 CCSYMP(clen, 1);
736 }
737 clen = mk_id(clen);
738 } else {
739 clen = DTY(dtype + 1);
740 if (clen == 0 && concat) {
741 /* get the length of the concatenation operands */
742 int lsize, rsize;
743 lsize = size_ast_of(A_LOPG(ast), A_DTYPEG(A_LOPG(ast)));
744 rsize = size_ast_of(A_ROPG(ast), A_DTYPEG(A_ROPG(ast)));
745 return mk_binop(OP_ADD, lsize, rsize, astb.bnd.dtype);
746 }
747 if (A_ALIASG(clen)) {
748 clen = A_ALIASG(clen);
749 clen = A_SPTRG(clen);
750 clen = CONVAL2G(clen);
751 return mk_isz_cval(mlpyr * clen, astb.bnd.dtype);
752 }
753 clen = mk_convert(clen, astb.bnd.dtype);
754 clen =
755 ast_intr(I_MAX, astb.bnd.dtype, 2, clen, mk_cval(0, astb.bnd.dtype));
756 }
757 if (mlpyr != 1) {
758 len = mk_cval(mlpyr, astb.bnd.dtype);
759 clen = mk_binop(OP_MUL, len, clen, astb.bnd.dtype);
760 }
761 return clen;
762
763 case TY_ARRAY:
764 len = size_ast_of(ast, DTY(dtype + 1));
765 if (DTY(dtype + 2) <= 0) {
766 interr("size_ast_of: no array descriptor", dtype, 3);
767 return len;
768 }
769 if (ADD_DEFER(dtype)) {
770 return mk_cval(dtypeinfo[DTY(DT_PTR)].size, DT_INT);
771 }
772 if (ADD_NUMELM(dtype) == 0) {
773 /* illegal use of adjustable or assumed-size array:
774 should have been caught in semant. */
775 /* errsev(50); */
776 ADD_NUMELM(dtype) = astb.bnd.one;
777 d = stb.i1;
778 } else {
779 d = sym_of_ast(ADD_NUMELM(dtype));
780 if (d == stb.i0 || STYPEG(d) != ST_CONST) {
781 /* illegal use of adjustable or assumed-size array:
782 should have been caught in semant. */
783 /* errsev(50); */
784 ADD_NUMELM(dtype) = astb.bnd.one;
785 d = stb.i1;
786 }
787 }
788 val = ad_val_of(d);
789 if (A_TYPEG(len) == A_CNST) {
790 int dd;
791 ISZ_T val2;
792 dd = sym_of_ast(len);
793 if (STYPEG(dd) != ST_CONST) {
794 dd = stb.i1;
795 }
796 val2 = ad_val_of(dd);
797 return mk_isz_cval(val * val2, astb.bnd.dtype);
798 }
799 d = mk_isz_cval(d, astb.bnd.dtype);
800 return mk_binop(OP_MUL, d, len, astb.bnd.dtype);
801
802 case TY_STRUCT:
803 case TY_UNION:
804 case TY_DERIVED:
805 if (!sptr)
806 sptr = DTY(dtype + 1);
807 if (DTY(dtype + 2) <= 0 && !UNLPOLYG(DTY(dtype+3)) &&
808 (!CLASSG(sptr) || !DTY(dtype + 1))) {
809 errsev(151);
810 return mk_isz_cval(4, astb.bnd.dtype);
811 } else {
812 return mk_isz_cval(DTY(dtype + 2), astb.bnd.dtype);
813 }
814
815 default:
816 interr("size_ast_of: bad dtype", ty, 3);
817 return mk_isz_cval(1, astb.bnd.dtype);
818 }
819 } /* size_ast_of */
820
821 INT
string_expr_length(int ast)822 string_expr_length(int ast)
823 {
824 int len, al, ar;
825 DTYPE dt_int;
826 int sym, iface;
827 /* must be constant reference, symbol reference, or concatenation */
828 if (ast <= 0)
829 return astb.i0;
830 dt_int = DT_INT;
831 switch (A_TYPEG(ast)) {
832 case A_ID:
833 case A_CNST:
834 case A_MEM:
835 return size_ast_of(ast, DDTG(A_DTYPEG(ast)));
836 case A_SUBSTR:
837 if (A_DTYPEG(A_LEFTG(ast)) == DT_INT8)
838 dt_int = DT_INT8;
839 else if (A_DTYPEG(A_RIGHTG(ast)) == DT_INT8)
840 dt_int = DT_INT8;
841 if (A_RIGHTG(ast)) {
842 if (A_LEFTG(ast) == 0) {
843 len = A_RIGHTG(ast);
844 } else {
845 int l1;
846 l1 = mk_binop(OP_SUB, A_LEFTG(ast), astb.i1, dt_int);
847 len = mk_binop(OP_SUB, A_RIGHTG(ast), l1, dt_int);
848 }
849 } else {
850 if (A_LEFTG(ast) == 0) {
851 return string_expr_length(A_LOPG(ast));
852 } else {
853 int l1, l2;
854 l1 = mk_binop(OP_SUB, A_LEFTG(ast), astb.i1, dt_int);
855 l2 = string_expr_length(A_LOPG(ast));
856 len = mk_binop(OP_SUB, l2, l1, dt_int);
857 }
858 }
859 if (A_ALIASG(len)) {
860 int cvlen;
861 cvlen = get_int_cval(A_SPTRG(len));
862 if (cvlen < 0)
863 len = mk_cval(0, DT_INT4);
864 } else if (dt_int != DT_INT8)
865 len = ast_intr(I_MAX, DT_INT4, 2, len, mk_cval(0, DT_INT4));
866 else
867 len = ast_intr(I_MAX, DT_INT8, 2, len, mk_cval(0, DT_INT8));
868 return len;
869 case A_SUBSCR:
870 /* subscripted reference, just get the length of the symbol */
871 return string_expr_length(A_LOPG(ast));
872 case A_PAREN:
873 case A_CONV:
874 return string_expr_length(A_LOPG(ast));
875 case A_BINOP:
876 if (A_OPTYPEG(ast) != OP_CAT) {
877 interr("string_expr_length: operator not concatenation", A_OPTYPEG(ast),
878 3);
879 return astb.i0;
880 }
881 al = string_expr_length(A_LOPG(ast));
882 ar = string_expr_length(A_ROPG(ast));
883 if (A_DTYPEG(al) == DT_INT8)
884 dt_int = DT_INT8;
885 else if (A_DTYPEG(ar) == DT_INT8)
886 dt_int = DT_INT8;
887 len = mk_binop(OP_ADD, al, ar, dt_int);
888 return ast_intr(I_MAX, dt_int, 2, len, mk_cval(0, dt_int));
889 case A_FUNC:
890 /* FS#21600: need to get the interface from the A_FUNC ast. */
891 sym = procsym_of_ast(A_LOPG(ast));
892 iface = 0;
893 proc_arginfo(sym, NULL, NULL, &iface);
894 return string_expr_length(mk_id(iface));
895 case A_INTR:
896 switch (A_OPTYPEG(ast)) {
897 case I_TRIM:
898 return ast_intr(I_LEN_TRIM, astb.bnd.dtype, 1, ARGT_ARG(A_ARGSG(ast), 0));
899 case I_RESHAPE:
900 return ast_intr(I_LEN, astb.bnd.dtype, 1, ARGT_ARG(A_ARGSG(ast), 0));
901 case I_ACHAR:
902 case I_CHAR:
903 return ast_intr(I_INT, astb.bnd.dtype, 1, ARGT_ARG(A_ARGSG(ast), 0));
904 }
905 /* else fall thru */
906 default:
907 interr("string_expr_length: ast not string op", A_TYPEG(ast), 3);
908 return astb.i0;
909 }
910 } /* string_expr_length */
911
912 /** \brief Change \p dtype from assumed-length to length of \p ast */
913 DTYPE
adjust_ch_length(DTYPE dtype,int ast)914 adjust_ch_length(DTYPE dtype, int ast)
915 {
916 int len;
917 /* if 'dtype' is assumed-length character, create a new
918 * datatype with same character type, but with length equal
919 * to length of the expression ast 'ast' */
920 dtype = DDTG(dtype);
921 if (dtype != DT_ASSNCHAR && dtype != DT_ASSCHAR && dtype != DT_DEFERNCHAR &&
922 dtype != DT_DEFERCHAR) {
923 return dtype;
924 }
925 len = string_expr_length(ast);
926 if (len) {
927 dtype = get_type(2, DTY(dtype), len);
928 }
929 return dtype;
930 } /* adjust_ch_length */
931
932 /** \brief Fix array and char dtypes.
933
934 Given datatype \p dtype and symbol \p sptr, return a datatype
935 equivalent to the given datatype, but with any array bounds
936 filled in from the symbol's array bounds, and char length
937 filled in from the symbol's char length, using
938 calls to LBOUND, UBOUND, or LEN, as necessary.
939 */
940 DTYPE
fix_dtype(int sptr,DTYPE dtype)941 fix_dtype(int sptr, DTYPE dtype)
942 {
943 DTYPE elemdt;
944 int sym;
945 TY_KIND ty = get_ty_kind(dtype);
946
947 if (sptr <= NOSYM)
948 return dtype;
949
950 switch (ty) {
951 case TY_WORD:
952 case TY_DWORD:
953 case TY_LOG:
954 case TY_INT:
955 case TY_FLOAT:
956 case TY_PTR:
957 case TY_SLOG:
958 case TY_SINT:
959 case TY_BINT:
960 case TY_BLOG:
961 case TY_DBLE:
962 case TY_QUAD:
963 case TY_CMPLX:
964 case TY_DCMPLX:
965 case TY_QCMPLX:
966 case TY_INT8:
967 case TY_LOG8:
968 case TY_HOLL:
969 case TY_STRUCT:
970 case TY_UNION:
971 case TY_DERIVED:
972 return dtype;
973
974 case TY_NCHAR:
975 case TY_CHAR:
976 if (dtype == DT_ASSCHAR || dtype == DT_DEFERCHAR
977 || dtype == DT_ASSNCHAR || dtype == DT_DEFERNCHAR
978 ) {
979 int clen = ast_intr(I_LEN, astb.bnd.dtype, 1, mk_id(sptr));
980 return get_type(2, ty, clen);
981 }
982 if (ADJLENG(sptr) && !F90POINTERG(sptr)) {
983 /* don't add CVLEN for local automatic character */
984 int cvlen;
985 int clen = CVLENG(sptr);
986 if (clen == 0) {
987 clen = sym_get_scalar(SYMNAME(sptr), "len", DT_INT);
988 CVLENP(sptr, clen);
989 if (SCG(sptr) == SC_DUMMY)
990 CCSYMP(clen, 1);
991 }
992 cvlen = CVLENG(sptr);
993 clen = mk_id(clen);
994 clen = ast_intr(I_MAX, DTYPEG(cvlen), 2, clen, mk_cval(0, DTYPEG(cvlen)));
995 return get_type(2, ty, clen);
996 }
997 return dtype;
998
999 case TY_ARRAY:
1000 if (DTY(dtype + 2) <= 0) {
1001 interr("fix_dtype: no array descriptor", dtype, 3);
1002 return dtype;
1003 }
1004 elemdt = fix_dtype(sptr, DTY(dtype + 1));
1005 sym = mk_id(sptr);
1006 if (ADD_ASSUMSHP(dtype) == 1) {
1007 /* get bounds from that of sptr */
1008 int ndim = ADD_NUMDIM(dtype);
1009 DTYPE dt = get_array_dtype(ndim, elemdt);
1010 int i;
1011 for (i = 0; i < ndim; ++i) {
1012 int lw, up, ext;
1013 ADD_MLPYR(dt, i) = 0;
1014 ADD_LWBD(dt, i) = ADD_LWBD(dtype, i);
1015 ADD_LWAST(dt, i) = ADD_LWAST(dtype, i);
1016 up = ADD_UPBD(dtype, i);
1017 if (up == 0) {
1018 up = ast_intr(I_UBOUND, DT_INT, 2, sym, i + 1);
1019 ADD_UPBD(dt, i) = up;
1020 ADD_UPAST(dt, i) = up;
1021 } else {
1022 ADD_UPBD(dt, i) = ADD_UPBD(dtype, i);
1023 ADD_UPAST(dt, i) = ADD_UPAST(dtype, i);
1024 }
1025 ext = mk_extent(ADD_LWAST(dt, i), ADD_UPAST(dtype, i), i);
1026 ADD_EXTNTAST(dt, i) = ext;
1027 }
1028 ADD_NUMELM(dt) = 0;
1029 ADD_ZBASE(dt) = 0;
1030 return dt;
1031 }
1032 if (elemdt != DTY(dtype + 1)) {
1033 /* same array bounds, different subtype */
1034 int ndim = ADD_NUMDIM(dtype);
1035 DTYPE dt = get_array_dtype(ndim, elemdt);
1036 int i;
1037 for (i = 0; i < ndim; ++i) {
1038 ADD_MLPYR(dt, i) = ADD_MLPYR(dtype, i);
1039 ADD_LWBD(dt, i) = ADD_LWBD(dtype, i);
1040 ADD_UPBD(dt, i) = ADD_UPBD(dtype, i);
1041 ADD_LWAST(dt, i) = ADD_LWAST(dtype, i);
1042 ADD_UPAST(dt, i) = ADD_UPAST(dtype, i);
1043 ADD_EXTNTAST(dt, i) = ADD_EXTNTAST(dtype, i);
1044 }
1045 ADD_NUMELM(dt) = ADD_NUMELM(dtype);
1046 ADD_ZBASE(dt) = ADD_ZBASE(dtype);
1047 return dt;
1048 }
1049 return dtype;
1050
1051 default:
1052 interr("fix_dtype: bad dtype", dtype * 1000 + ty, 3);
1053 return dtype;
1054 }
1055 } /* fix_dtype */
1056
1057 ISZ_T
extent_of(DTYPE dtype)1058 extent_of(DTYPE dtype)
1059 {
1060 ISZ_T d;
1061 ADSC *ad;
1062 int numelem;
1063
1064 #if DEBUG
1065 assert(DTY(dtype) == TY_ARRAY, "extent_of, expected TY_ARRAY", dtype, 3);
1066 #endif
1067 if ((d = DTY(dtype + 2)) <= 0) {
1068 interr("extent_of: no array descriptor", (int)d, 3);
1069 return 0;
1070 }
1071 ad = AD_DPTR(dtype);
1072 numelem = AD_NUMELM(ad);
1073 if (numelem == 0)
1074 return 0;
1075 if (A_ALIASG(numelem) == 0)
1076 return 0;
1077 d = sym_of_ast(AD_NUMELM(ad));
1078 if (d == stb.i0 || STYPEG(d) != ST_CONST)
1079 return 0;
1080 d = CONVAL2G(d);
1081 return d;
1082 }
1083
1084 DTYPE
dtype_with_shape(DTYPE dtype,int shape)1085 dtype_with_shape(DTYPE dtype, int shape)
1086 {
1087 int ndim, i, last_mp, last_mp_const;
1088 ISZ_T last_mp_val;
1089 DTYPE dtyper;
1090 /* if the shape is scalar, either return the old scalar datatype
1091 * or the base type if the old datatype was an array */
1092 if (shape == 0 || SHD_NDIM(shape) == 0) {
1093 if (DTY(dtype) == TY_ARRAY) {
1094 return DTY(dtype + 1);
1095 } else {
1096 return dtype;
1097 }
1098 }
1099 /* if the datatype is an array and the shape has dimensions,
1100 * and the dimensionality and sizes match, no need to change */
1101 ndim = SHD_NDIM(shape);
1102 if (DTY(dtype) == TY_ARRAY) {
1103 if (ADD_NUMDIM(dtype) == ndim) {
1104 /* check the upper/lower bounds */
1105 for (i = 0; i < ndim; ++i) {
1106 /* skip if the stride is not one */
1107 if (SHD_STRIDE(shape, i) != astb.bnd.one)
1108 return dtype;
1109 if (SHD_LWB(shape, i) != ADD_LWAST(dtype, i))
1110 break;
1111 if (SHD_UPB(shape, i) != ADD_UPAST(dtype, i))
1112 break;
1113 }
1114 if (i == ndim) {
1115 /* all bounds matched */
1116 return dtype;
1117 }
1118 }
1119 }
1120 /* must make a new datatype */
1121 dtyper = get_array_dtype(ndim, DT_NONE);
1122 if (DTY(dtype) == TY_ARRAY) {
1123 /* copy base type */
1124 DTY(dtyper + 1) = DTY(dtype + 1);
1125 } else {
1126 /* make this the new base type */
1127 DTY(dtyper + 1) = dtype;
1128 }
1129 last_mp_const = 1;
1130 last_mp_val = 1;
1131 last_mp = astb.bnd.one;
1132 for (i = 0; i < ndim; ++i) {
1133 int lb, ub;
1134 ISZ_T lbval, ubval;
1135 ADD_LWAST(dtyper, i) = ADD_LWBD(dtyper, i) = SHD_LWB(shape, i);
1136 ADD_UPAST(dtyper, i) = ADD_UPBD(dtyper, i) = SHD_UPB(shape, i);
1137 ADD_EXTNTAST(dtyper, i) =
1138 mk_extent(ADD_LWAST(dtyper, i), ADD_UPAST(dtyper, i), i);
1139 ADD_MLPYR(dtyper, i) = last_mp;
1140 lb = ADD_LWAST(dtyper, i);
1141 if (!A_ALIASG(lb)) {
1142 lb = -1;
1143 } else {
1144 lb = A_ALIASG(lb);
1145 lbval = ad_val_of(A_SPTRG(lb));
1146 }
1147 ub = ADD_UPAST(dtyper, i);
1148 if (!A_ALIASG(ub)) {
1149 ub = -1;
1150 } else {
1151 ub = A_ALIASG(ub);
1152 ubval = ad_val_of(A_SPTRG(ub));
1153 }
1154 if (last_mp_const && lb > 0 && ub > 0) {
1155 last_mp_val = (last_mp_val) * (ubval - lbval + 1);
1156 last_mp = mk_isz_cval(last_mp_val, astb.bnd.dtype);
1157 } else {
1158 last_mp_const = 0;
1159 last_mp = mk_bnd_ast();
1160 }
1161 }
1162
1163 ADD_NUMELM(dtyper) = last_mp;
1164 ADD_ZBASE(dtyper) = mk_bnd_ast();
1165 return dtyper;
1166 } /* dtype_with_shape */
1167
1168 ISZ_T
ad_val_of(int sym)1169 ad_val_of(int sym)
1170 {
1171 if (XBIT(68, 0x1)) {
1172 INT num[2];
1173 ISZ_T v;
1174 num[0] = CONVAL1G(sym);
1175 num[1] = CONVAL2G(sym);
1176 INT64_2_ISZ(num, v);
1177 return v;
1178 }
1179 return CONVAL2G(sym);
1180 }
1181
1182 /** \brief Create a constant sym entry which reflects the type of an array
1183 bound/extent.
1184 */
1185 int
get_bnd_con(ISZ_T v)1186 get_bnd_con(ISZ_T v)
1187 {
1188 INT num[2];
1189
1190 if (XBIT(68, 0x1)) {
1191 ISZ_2_INT64(v, num);
1192 return getcon(num, DT_INT8);
1193 }
1194 num[0] = 0;
1195 num[1] = v;
1196 return getcon(num, DT_INT);
1197 }
1198
1199 int
alignment(DTYPE dtype)1200 alignment(DTYPE dtype)
1201 {
1202 TY_KIND ty = get_ty_kind(dtype);
1203 int align_val;
1204
1205 switch (ty) {
1206 case TY_DWORD:
1207 case TY_DBLE:
1208 case TY_DCMPLX:
1209 case TY_QCMPLX:
1210 if (!flg.dalign)
1211 return dtypeinfo[TY_INT].align;
1212 case TY_QUAD:
1213 case TY_WORD:
1214 case TY_HOLL:
1215 case TY_BINT:
1216 case TY_SINT:
1217 case TY_INT:
1218 case TY_REAL:
1219 case TY_CMPLX:
1220 case TY_BLOG:
1221 case TY_SLOG:
1222 case TY_LOG:
1223 case TY_CHAR:
1224 case TY_NCHAR:
1225 case TY_PTR:
1226 return dtypeinfo[ty].align;
1227 case TY_INT8:
1228 case TY_LOG8:
1229 if (!flg.dalign || XBIT(119, 0x100000))
1230 return dtypeinfo[TY_INT].align;
1231 return dtypeinfo[ty].align;
1232
1233 case TY_ARRAY:
1234 align_val = alignment((int)DTY(dtype + 1));
1235 return align_val;
1236
1237 case TY_STRUCT:
1238 case TY_UNION:
1239 case TY_DERIVED:
1240 return DTY(dtype + 4);
1241
1242 default:
1243 interr("alignment: bad dtype ", ty, 3);
1244 return 0;
1245 }
1246 }
1247
1248 /** \brief Like alignment(), but takes into account whether the var is a pointer
1249 */
1250 int
alignment_of_var(int sptr)1251 alignment_of_var(int sptr)
1252 {
1253 DTYPE dtype = DTYPEG(sptr);
1254 int align;
1255
1256 if (POINTERG(sptr) || ALLOCG(sptr)) {
1257 align = dtypeinfo[TY_PTR].align;
1258 } else {
1259 align = alignment(dtype);
1260 }
1261 #ifdef QALNG
1262 if (QALNG(sptr)) {
1263 int ta;
1264 ta = dtypeinfo[TY_QUAD].align;
1265 if (align < ta)
1266 align = ta;
1267 }
1268 #endif
1269 #ifdef PDALN_IS_DEFAULT
1270 if (!PDALN_IS_DEFAULT(sptr)) {
1271 /* PDALNG==3 means align to 2^3==8 byte address, align == 7 */
1272 int ta = (1 << PDALNG(sptr)) - 1;
1273 if (align < ta)
1274 align = ta;
1275 }
1276 #endif
1277 return align;
1278 } /* alignment_of_var */
1279
1280 int
bits_in(DTYPE dtype)1281 bits_in(DTYPE dtype)
1282 {
1283 TY_KIND ty = get_ty_kind(dtype);
1284
1285 switch (ty) {
1286 case TY_WORD:
1287 case TY_DWORD:
1288 case TY_HOLL:
1289 case TY_BINT:
1290 case TY_SINT:
1291 case TY_INT:
1292 case TY_REAL:
1293 case TY_DBLE:
1294 case TY_QUAD:
1295 case TY_CMPLX:
1296 case TY_DCMPLX:
1297 case TY_QCMPLX:
1298 case TY_BLOG:
1299 case TY_SLOG:
1300 case TY_LOG:
1301 case TY_CHAR:
1302 case TY_NCHAR:
1303 case TY_INT8:
1304 case TY_LOG8:
1305 case TY_PTR:
1306 return dtypeinfo[ty].bits;
1307
1308 default:
1309 interr("bits_in: bad type ", ty, 3);
1310 return 0;
1311 }
1312 }
1313
1314 /*---------------------------------------------------------*/
1315
1316 /*
1317 * Data structure to hold TY_CHAR entries: linked list off of
1318 * array chartab; entries that are equal module CHARTABSIZE are
1319 * linked. Relative pointers (integers) are used.
1320 */
1321 #define CHARTABSIZE 40
1322 static int chartab[CHARTABSIZE];
1323 struct chartab {
1324 int next;
1325 DTYPE dtype;
1326 };
1327 static int chartabavail, chartabsize;
1328 static struct chartab *chartabbase = 0;
1329
1330 void
init_chartab(void)1331 init_chartab(void)
1332 {
1333 int i;
1334
1335 for (i = 0; i < CHARTABSIZE; ++i)
1336 chartab[i] = 0;
1337 if (chartabbase == 0) {
1338 /* allocate new */
1339 chartabsize = CHARTABSIZE;
1340 NEW(chartabbase, struct chartab, chartabsize);
1341 }
1342 chartabavail = 1;
1343 chartabbase[0].next = 0;
1344 chartabbase[0].dtype = 0;
1345
1346 rehost_machar(flg.x[45]);
1347
1348 if (XBIT(52, 1)) {
1349 /* complex must be double-aligned */
1350 dtypeinfo[TY_CMPLX].align = dtypeinfo[TY_DBLE].align;
1351 }
1352 }
1353
1354 void
fini_chartab()1355 fini_chartab()
1356 {
1357 FREE(chartabbase);
1358 chartabsize = 0;
1359 chartabavail = 0;
1360 } /* fini_chartab */
1361
1362 /** Find or allocate a slot in dtype array for the new datatype. For strings,
1363 * check if the data type is already present.
1364 *
1365 * \param n number of datatype entries we want to occupy
1366 * \param v1 data type
1367 * \param v2 second value, meaning depends on data type, for strings it is
1368 * the length, for pointers - target type, etc
1369 */
1370 DTYPE
get_type(int n,TY_KIND v1,int v2)1371 get_type(int n, TY_KIND v1, int v2)
1372 {
1373 int i, j;
1374 DTYPE dtype = 0;
1375 LOGICAL is_nchar = FALSE;
1376 is_nchar = (v1 == TY_NCHAR);
1377
1378 /* For a string try to find a matching type first */
1379 if (v1 == TY_CHAR || is_nchar) {
1380 if (v2 < 0 || v2 >= astb.stg_avail) {
1381 interr("char string length is wrong.", v2, 2);
1382 v2 = astb.i1;
1383 }
1384 i = v2 % CHARTABSIZE;
1385 if (chartab[i]) {
1386 /* check list for this length */
1387 for (j = chartab[i]; j != 0; j = chartabbase[j].next) {
1388 int k = chartabbase[j].dtype;
1389 if (DTY(k + 1) == v2 && /* same length */
1390 DTY(k) == v1 /*TY_CHAR vs TY_NCHAR*/) {
1391 dtype = chartabbase[j].dtype;
1392 goto found;
1393 }
1394 }
1395 }
1396 if (v2 == astb.i1) {
1397 if (v1 == TY_CHAR) {
1398 dtype = DT_CHAR;
1399 } else if (v1 == TY_NCHAR) {
1400 dtype = DT_NCHAR;
1401 }
1402 }
1403 }
1404 if (dtype == 0) {
1405 dtype = STG_NEXT_SIZE(stb.dt, n);
1406 DTY(dtype) = v1;
1407 DTY(dtype + 1) = v2;
1408 if (v1 == TY_CHAR || is_nchar) {
1409 /* not found */
1410 NEED(chartabavail + n, chartabbase, struct chartab, chartabsize,
1411 chartabsize + CHARTABSIZE);
1412 chartabbase[chartabavail].dtype = dtype;
1413 chartabbase[chartabavail].next = chartab[i];
1414 chartab[i] = chartabavail++;
1415 }
1416 }
1417 found:
1418 return dtype;
1419 }
1420
1421 /** \brief Return true if the data types for two functions are compatible.
1422
1423 Two functions are compatible if a single local variable can be
1424 used to hold their return values and therefore implying that the
1425 same return mechanism can be used for the functions.
1426 */
1427 LOGICAL
cmpat_func(DTYPE d1,DTYPE d2)1428 cmpat_func(DTYPE d1, DTYPE d2)
1429 {
1430 if (d1 == d2) {
1431 return TRUE;
1432 } else {
1433 int fv1 = dtypeinfo[DTY(d1)].fval;
1434 int fv2 = dtypeinfo[DTY(d2)].fval;
1435 assert(fv1 >= 0, "cmpat_func1: bad dtype", d1, 3);
1436 assert(fv2 >= 0, "cmpat_func2: bad dtype", d2, 3);
1437 return fv1 == fv2;
1438 }
1439 }
1440
1441 /** \brief Return TRUE if the scalar data types of an actual argument matches
1442 the formal with respect to the type & kind rules.
1443 */
1444 LOGICAL
tk_match_arg(int formal_dt,int actual_dt,LOGICAL flag)1445 tk_match_arg(int formal_dt, int actual_dt, LOGICAL flag)
1446 {
1447 int f_len;
1448 int a_len;
1449 LOGICAL unk = FALSE;
1450 int f_dt = DDTG(formal_dt);
1451 int a_dt = DDTG(actual_dt);
1452
1453 if (DTY(f_dt) == TY_CHAR) {
1454 if (DTY(a_dt) != TY_CHAR)
1455 return FALSE;
1456 /*
1457 * if formal is not assumed length, the length of the formal must be
1458 * be less than or equal to the length of the actual.
1459 */
1460 if (f_dt != DT_ASSCHAR && a_dt != DT_ASSCHAR && f_dt != DT_DEFERCHAR &&
1461 a_dt != DT_DEFERCHAR) {
1462 f_len = DTY(f_dt + 1);
1463 if (!A_ALIASG(f_len)) {
1464 f_len = 0;
1465 } else {
1466 f_len = A_ALIASG(f_len);
1467 f_len = A_SPTRG(f_len);
1468 f_len = CONVAL2G(f_len);
1469 }
1470 a_len = DTY(a_dt + 1);
1471 if (!A_ALIASG(a_len)) {
1472 a_len = 0;
1473 unk = TRUE;
1474 } else {
1475 a_len = A_ALIASG(a_len);
1476 a_len = A_SPTRG(a_len);
1477 a_len = CONVAL2G(a_len);
1478 }
1479 if (DTY(formal_dt) == TY_ARRAY) {
1480 int f_nelems = extent_of(formal_dt);
1481 int a_nelems;
1482 if (DTY(actual_dt) == TY_ARRAY)
1483 a_nelems = extent_of(actual_dt);
1484 else
1485 a_nelems = 1;
1486 if (f_nelems && a_nelems && f_len && a_len) {
1487 if (f_nelems * f_len > a_nelems * a_len)
1488 return FALSE;
1489 }
1490 } else if (!unk && f_len > a_len)
1491 return FALSE;
1492 }
1493 }
1494 else if (DTY(f_dt) == TY_NCHAR) {
1495 if (DTY(a_dt) != TY_NCHAR)
1496 return FALSE;
1497 f_len = DTY(f_dt + 1);
1498 if (!A_ALIASG(f_len)) {
1499 f_len = 0;
1500 unk = TRUE;
1501 } else {
1502 f_len = A_ALIASG(f_len);
1503 f_len = A_SPTRG(f_len);
1504 f_len = CONVAL2G(f_len);
1505 }
1506 a_len = DTY(a_dt + 1);
1507 if (!A_ALIASG(a_len)) {
1508 a_len = 0;
1509 } else {
1510 a_len = A_ALIASG(a_len);
1511 a_len = A_SPTRG(a_len);
1512 a_len = CONVAL2G(a_len);
1513 }
1514 if (f_dt != DT_ASSNCHAR && f_dt != DT_DEFERNCHAR) {
1515 if (!unk && f_len > a_len)
1516 return FALSE;
1517 }
1518 }
1519 else if (!eq_dtype2(f_dt, a_dt, flag)) {
1520 return FALSE;
1521 }
1522
1523 return TRUE;
1524 }
1525
1526 #if defined(PARENTG)
1527 LOGICAL
extends_type(int tg1,int tg2)1528 extends_type(int tg1, int tg2)
1529 {
1530 /* Returns true if derived type tag tg2 extends derived type tag tg1 */
1531 int sptr;
1532
1533 if (!tg2 || !tg1 || DTY(DTYPEG(tg1)) != TY_DERIVED ||
1534 DTY(DTYPEG(tg2)) != TY_DERIVED)
1535 return FALSE;
1536 if (strcmp(SYMNAME(tg1), SYMNAME(tg2)) == 0)
1537 return TRUE;
1538 sptr = DTY(DTYPEG(tg2) + 1);
1539 if (PARENTG(sptr))
1540 return extends_type(tg1, sptr);
1541 return FALSE;
1542 }
1543
1544 static LOGICAL
same_parameterized_dt(DTYPE d1,DTYPE d2)1545 same_parameterized_dt(DTYPE d1, DTYPE d2)
1546 {
1547
1548 /* Used in conjunction with same_dtype().
1549 * Returns TRUE if both d1 and d2 are the same
1550 * parameterized derived type
1551 */
1552 int base_type1, base_type2, mem1, mem2, val1, val2;
1553 int mem_dtype1, mem_dtype2;
1554 int rslt;
1555
1556 if (d1 == d2)
1557 return TRUE;
1558 if (DTY(d1) == TY_DERIVED && DTY(d2) == TY_DERIVED) {
1559 base_type1 = BASETYPEG(DTY(d1 + 3));
1560 base_type2 = BASETYPEG(DTY(d2 + 3));
1561 if (!base_type1)
1562 base_type1 = d1;
1563 if (!base_type2)
1564 base_type2 = d2;
1565 if (base_type1 && base_type2 && base_type1 == base_type2) {
1566 for (mem1 = DTY(d1 + 1), mem2 = DTY(d2 + 1); mem1 > NOSYM && mem2 > NOSYM;
1567 mem1 = SYMLKG(mem1), mem2 = SYMLKG(mem2)) {
1568 if (PARENTG(mem1)) {
1569 if (!PARENTG(mem2)) {
1570 return FALSE;
1571 }
1572 rslt = same_parameterized_dt(DTYPEG(mem1), DTYPEG(mem2));
1573 if (!rslt)
1574 return FALSE;
1575 } else if (PARENTG(mem2)) {
1576 return FALSE;
1577 }
1578 if (!SETKINDG(mem1) && !USEKINDG(mem1) && KINDG(mem1) &&
1579 PARMINITG(mem1)) {
1580 val1 = PARMINITG(mem1);
1581 } else if (SETKINDG(mem1) && !USEKINDG(mem1) && KINDG(mem1)) {
1582 if (LENPARMG(mem1)) {
1583 val1 = chk_kind_parm_set_expr(LENG(mem1), 0);
1584 if (val1 > 0 && A_TYPEG(val1) == A_CNST) {
1585 val1 = CONVAL2G(A_SPTRG(val1));
1586 } else {
1587 continue;
1588 }
1589 } else {
1590 val1 = KINDG(mem1);
1591 }
1592 } else {
1593 val1 = 0;
1594 }
1595 if (!SETKINDG(mem2) && !USEKINDG(mem2) && KINDG(mem2) &&
1596 PARMINITG(mem2)) {
1597 val2 = PARMINITG(mem2);
1598 } else if (SETKINDG(mem2) && !USEKINDG(mem2) && KINDG(mem2)) {
1599 if (LENPARMG(mem2)) {
1600 val2 = chk_kind_parm_set_expr(LENG(mem2), 0);
1601 if (val2 > 0 && A_TYPEG(val2) == A_CNST) {
1602 val2 = CONVAL2G(A_SPTRG(val2));
1603 } else {
1604 continue;
1605 }
1606 } else {
1607 val2 = KINDG(mem2);
1608 }
1609 } else {
1610 val2 = 0;
1611 }
1612 if (val1 != val2) {
1613 return FALSE;
1614 }
1615 }
1616 return TRUE;
1617 }
1618 }
1619 return FALSE;
1620 }
1621 #endif
1622
1623 /** \brief In the presence of modules and interface blocks, it's possible that
1624 two
1625 identical derived types are not represented by the same data type record.
1626 If this occurs, eq_dtype() will check the types of the members.
1627 */
1628 LOGICAL
eq_dtype2(DTYPE d1,DTYPE d2,LOGICAL flag)1629 eq_dtype2(DTYPE d1, DTYPE d2, LOGICAL flag)
1630 {
1631 int s1, s2;
1632 int tg1, tg2;
1633
1634 if (d1 == d2)
1635 return TRUE;
1636 if (DTY(d1) != DTY(d2))
1637 return FALSE;
1638 switch (DTY(d1)) {
1639 case TY_ARRAY:
1640 /* check rank and element type */
1641 if (ADD_NUMDIM(d1) != ADD_NUMDIM(d2))
1642 return FALSE;
1643 return (eq_dtype2((int)DTY(d1 + 1), (int)DTY(d2 + 1), flag));
1644
1645 case TY_DERIVED:
1646 tg1 = DTY(d1 + 3);
1647 tg2 = DTY(d2 + 3);
1648 if (tg1 == tg2)
1649 /* tags are the same => equal types */
1650 return TRUE;
1651 #if defined(PARENTG)
1652 if (flag && extends_type(tg1, tg2)) /* type extension */
1653 return TRUE;
1654 #endif
1655 if (same_parameterized_dt(d1, d2))
1656 return TRUE;
1657 if (strcmp(SYMNAME(tg1), SYMNAME(tg2)) != 0)
1658 return FALSE;
1659
1660 if (VISITG(tg1) && VISITG(tg2)) {
1661 /* have a self-referential derived type */
1662 return TRUE;
1663 }
1664 if (VISITG(tg1) || VISITG(tg2)) {
1665 return FALSE;
1666 }
1667 VISITP(tg1, 1);
1668 VISITP(tg2, 1);
1669 /* traverse the members */
1670 for (s1 = DTY(d1 + 1), s2 = DTY(d2 + 1); s1 > NOSYM && s2 > NOSYM;
1671 s1 = SYMLKG(s1), s2 = SYMLKG(s2)) {
1672 if (HCCSYMG(s1) && HCCSYMG(s2)) {
1673 } else if (HCCSYMG(s1) || HCCSYMG(s2)) {
1674 break; /* return FALSE; */
1675 } else if (strcmp(SYMNAME(s1), SYMNAME(s2)) != 0)
1676 break; /* return FALSE; */
1677 /* if one member is private, both must be */
1678 if (PRIVATEG(s1) != PRIVATEG(s2))
1679 break; /* return FALSE; */
1680 /* member types are different => different types */
1681 if (!eq_dtype2(DTYPEG(s1), DTYPEG(s2), flag))
1682 break; /* return FALSE; */
1683 }
1684 VISITP(tg1, 0);
1685 VISITP(tg2, 0);
1686 /* more members in either record? */
1687 if (s2 > NOSYM || s1 > NOSYM)
1688 return FALSE;
1689 return TRUE;
1690
1691 case TY_CHAR:
1692 case TY_NCHAR:
1693 /* compare lengths */
1694 if (DTY(d1 + 1) == DTY(d2 + 1))
1695 return TRUE;
1696 break;
1697
1698 case TY_PTR:
1699 if (DTY(DTY(d1 + 1)) == TY_PROC) {
1700 return eq_dtype2(DTY(d1 + 1), DTY(d2 + 1), flag);
1701 }
1702 break;
1703 case TY_PROC:
1704 if ((DTY(d1 + 2) && (DTY(d1 + 2) == DTY(d2 + 2))) ||
1705 (cmp_interfaces(DTY(d1 + 2), DTY(d2 + 2), TRUE))) {
1706 /* identical interfaces */
1707 return TRUE;
1708 }
1709 if (!DTY(d1 + 2) && !DTY(d1 + 2)) {
1710 /* no interfaces; check result dtypes */
1711 return eq_dtype2(DTY(d1 + 1), DTY(d2 + 1), flag);
1712 }
1713 break;
1714 default:
1715 break;
1716 }
1717 return FALSE;
1718 }
1719
1720 LOGICAL
eq_dtype(DTYPE d1,DTYPE d2)1721 eq_dtype(DTYPE d1, DTYPE d2)
1722 {
1723 return eq_dtype2(d1, d2, FALSE);
1724 }
1725
1726 /** \brief Check to see if two types are extensions from the same ancestor */
1727 LOGICAL
same_ancestor(DTYPE dtype1,DTYPE dtype2)1728 same_ancestor(DTYPE dtype1, DTYPE dtype2)
1729 {
1730 int mem1, mem2;
1731 int next_dtype1, next_dtype2;
1732
1733 if (DTY(dtype1) == TY_ARRAY)
1734 dtype1 = DTY(dtype1 + 1);
1735
1736 if (DTY(dtype2) == TY_ARRAY)
1737 dtype2 = DTY(dtype2 + 1);
1738
1739 if (DTY(dtype1) != TY_DERIVED || DTY(dtype2) != TY_DERIVED)
1740 return FALSE;
1741
1742 if (eq_dtype2(dtype1, dtype2, 1) || eq_dtype2(dtype2, dtype1, 1))
1743 return TRUE;
1744
1745 mem1 = DTY(dtype1 + 1);
1746 mem2 = DTY(dtype2 + 1);
1747
1748 if (PARENTG(mem1))
1749 next_dtype1 = DTYPEG(mem1);
1750 else
1751 next_dtype1 = dtype1;
1752
1753 if (PARENTG(mem2))
1754 next_dtype2 = DTYPEG(mem2);
1755 else
1756 next_dtype2 = dtype2;
1757
1758 if (dtype1 == next_dtype1 && dtype2 == next_dtype2)
1759 return FALSE;
1760
1761 return same_ancestor(next_dtype1, next_dtype2);
1762 }
1763
1764 /*
1765 * These data type tests use search_type_members() above, so they're
1766 * each written in terms of (1) a predicate function to be applied to the
1767 * component members of a symbol's derived type and (2) a wrapper that
1768 * applies test_sym_and_components() to that predicate function.
1769 */
1770
1771 static LOGICAL
is_recursive(int sptr,struct visit_list ** visited)1772 is_recursive(int sptr, struct visit_list **visited)
1773 {
1774 return sptr > NOSYM &&
1775 search_type_members(DTYPEG(sptr), is_recursive, visited);
1776 }
1777
1778 LOGICAL
has_recursive_component(int sptr)1779 has_recursive_component(int sptr)
1780 {
1781 return test_sym_and_components(sptr, is_recursive);
1782 }
1783
1784 static LOGICAL
is_finalized(int sptr,struct visit_list ** visited)1785 is_finalized(int sptr, struct visit_list **visited)
1786 {
1787 return sptr > NOSYM &&
1788 ((STYPEG(sptr) == ST_MEMBER &&
1789 (FINALG(sptr) != 0 || FINALIZEDG(sptr))) ||
1790 search_type_members(DTYPEG(sptr), is_finalized, visited));
1791 }
1792
1793 LOGICAL
has_finalized_component(SPTR sptr)1794 has_finalized_component(SPTR sptr)
1795 {
1796 return test_sym_components_only(sptr, is_finalized);
1797 }
1798
1799 static LOGICAL
is_impure_finalizer(int sptr,struct visit_list ** visited)1800 is_impure_finalizer(int sptr, struct visit_list **visited)
1801 {
1802 return sptr > NOSYM &&
1803 ((STYPEG(sptr) == ST_MEMBER &&
1804 FINALG(sptr) && is_impure(VTABLEG(sptr))) ||
1805 search_type_members(DTYPEG(sptr), is_impure_finalizer, visited));
1806 }
1807
1808 LOGICAL
has_impure_finalizer(SPTR sptr)1809 has_impure_finalizer(SPTR sptr)
1810 {
1811 return test_sym_and_components(sptr, is_impure_finalizer);
1812 }
1813
1814 static LOGICAL
is_layout_desc(SPTR sptr,struct visit_list ** visited)1815 is_layout_desc(SPTR sptr, struct visit_list **visited)
1816 {
1817 return sptr > NOSYM && ((/* STYPEG(sptr) == ST_MEMBER && */
1818 (POINTERG(sptr) || ALLOCATTRG(sptr) ||
1819 DTYG(DTYPEG(sptr)) ==
1820 TY_PTR /* procedure pointer */ ||
1821 (/* PARENTG(sptr) -- why only parents? why not
1822 other components? && */
1823 search_type_members(DTYPEG(sptr), is_layout_desc,
1824 visited)))) ||
1825 has_finalized_component(sptr) ||
1826 has_recursive_component(sptr) ||
1827 is_or_has_derived_allo(sptr));
1828 }
1829
1830 LOGICAL
has_layout_desc(SPTR sptr)1831 has_layout_desc(SPTR sptr)
1832 {
1833 return test_sym_components_only(sptr, is_layout_desc);
1834 }
1835
1836 static LOGICAL
is_poly(SPTR sptr,struct visit_list ** visited)1837 is_poly(SPTR sptr, struct visit_list **visited)
1838 {
1839 return sptr > NOSYM && ((CLASSG(sptr) && !is_tbp_or_final(sptr)) ||
1840 search_type_members(DTYPEG(sptr), is_poly, visited));
1841 }
1842
1843 LOGICAL
is_or_has_poly(SPTR sptr)1844 is_or_has_poly(SPTR sptr)
1845 {
1846 return test_sym_and_components(sptr, is_poly);
1847 }
1848
1849 static LOGICAL
is_derived_type_allo(SPTR sptr,struct visit_list ** visited)1850 is_derived_type_allo(SPTR sptr, struct visit_list **visited)
1851 {
1852 return sptr > NOSYM &&
1853 ((ALLOCATTRG(sptr) && is_container_dtype(DTYPEG(sptr))) ||
1854 search_type_members(DTYPEG(sptr), is_derived_type_allo, visited));
1855 }
1856
1857 LOGICAL
is_or_has_derived_allo(SPTR sptr)1858 is_or_has_derived_allo(SPTR sptr)
1859 {
1860 return test_sym_and_components(sptr, is_derived_type_allo);
1861 }
1862
1863 /** \brief Similar to eq_dtype(), except all scalar integer types are compatible
1864 with
1865 each other, all scalar logical types are compatible with each other, all
1866 character types are compatible with each other.
1867 */
1868 LOGICAL
cmpat_dtype(DTYPE d1,DTYPE d2)1869 cmpat_dtype(DTYPE d1, DTYPE d2)
1870 {
1871 int s1, s2;
1872
1873 if (d1 == d2)
1874 return TRUE;
1875 if (DTY(d1) != DTY(d2)) {
1876 /* check for any logical first since logical types also have the
1877 * _TY_INT attribute.
1878 */
1879 if (DT_ISLOG(d1) && DT_ISLOG(d2))
1880 return TRUE;
1881 if (DT_ISINT(d1) && DT_ISINT(d2))
1882 return TRUE;
1883 return FALSE;
1884 }
1885 if (DTY(d1) == TY_CHAR || DTY(d1) == TY_NCHAR)
1886 return TRUE;
1887 return eq_dtype(d1, d2);
1888 }
1889
1890 /** \brief Similar to compat_dtype(), except all scalar integer types are
1891 compatible with each other, all scalar logical types are compatible
1892 with each other, all character types are compatible with each other.
1893 Also, array extents are checked.
1894 */
1895 LOGICAL
cmpat_dtype_with_size(DTYPE d1,DTYPE d2)1896 cmpat_dtype_with_size(DTYPE d1, DTYPE d2)
1897 {
1898 int s1, s2, i, n;
1899
1900 if (is_iso_cptr(d1)) {
1901 d1 = DTYPEG(DTY(d1 + 1));
1902 }
1903 if (is_iso_cptr(d2)) {
1904 d2 = DTYPEG(DTY(d2 + 1));
1905 }
1906
1907 if (d1 == d2)
1908 return TRUE;
1909 if (d1 <= 0 || d2 <= 0)
1910 return FALSE;
1911 if (DTY(d1) != DTY(d2)) {
1912 /* check for any logical first since logical types also have the
1913 * _TY_INT attribute.
1914 */
1915 if (DT_ISLOG(d1) && DT_ISLOG(d2))
1916 return TRUE;
1917 if (DT_ISNUMERIC(d2) && DT_ISNUMERIC(d1))
1918 return TRUE;
1919 /* allow array of blah to match with scalar blah */
1920 if (DTY(d1) == TY_ARRAY && cmpat_dtype_with_size(DTY(d1 + 1), d2))
1921 return TRUE;
1922 if (DTY(d2) == TY_ARRAY && cmpat_dtype_with_size(d1, DTY(d2 + 1)))
1923 return TRUE;
1924 return FALSE;
1925 }
1926 /* here, DTY(d1) == DTY(d2) */
1927 if (DTY(d1) == TY_CHAR || DTY(d1) == TY_NCHAR)
1928 return TRUE;
1929 switch (DTY(d1)) {
1930 case TY_ARRAY:
1931 /* check rank, extents and element type */
1932 if (ADD_NUMDIM(d1) != ADD_NUMDIM(d2))
1933 return FALSE;
1934 n = ADD_NUMDIM(d1);
1935 for (i = 0; i < n; ++i) {
1936 /* check bounds */
1937 int l1, l2, u1, u2, e1, e2;
1938 l1 = ADD_LWBD(d1, i);
1939 u1 = ADD_UPBD(d1, i);
1940 l2 = ADD_LWBD(d2, i);
1941 u2 = ADD_UPBD(d2, i);
1942 /* if not constant upper bound, give up */
1943 if (!u1 || !A_ALIASG(u1))
1944 continue;
1945 if (A_DTYPEG(u1) != DT_INT4)
1946 continue;
1947 e1 = get_int_cval(A_SPTRG(u1));
1948 if (l1) {
1949 if (!A_ALIASG(l1))
1950 continue;
1951 if (A_DTYPEG(l1) != DT_INT4)
1952 continue;
1953 e1 -= get_int_cval(A_SPTRG(l1)) - 1;
1954 }
1955 if (!u2 || !A_ALIASG(u2))
1956 continue;
1957 if (A_DTYPEG(u2) != DT_INT4)
1958 continue;
1959 e2 = get_int_cval(A_SPTRG(u2));
1960 if (l2) {
1961 if (!A_ALIASG(l2))
1962 continue;
1963 if (A_DTYPEG(l2) != DT_INT4)
1964 continue;
1965 e2 -= get_int_cval(A_SPTRG(l2)) - 1;
1966 }
1967 /* different extents */
1968 if (e1 != e2)
1969 return FALSE;
1970 }
1971 return cmpat_dtype_with_size(DTY(d1 + 1), DTY(d2 + 1));
1972
1973 case TY_DERIVED:
1974 /* tags are the same => equal types */
1975 if (DTY(d1 + 3) == DTY(d2 + 3))
1976 return TRUE;
1977 /* traverse the members */
1978 for (s1 = DTY(d1 + 1), s2 = DTY(d2 + 1); s1 > NOSYM && s2 > NOSYM;
1979 s1 = SYMLKG(s1), s2 = SYMLKG(s2)) {
1980 /* member types are different => different types */
1981 if (!cmpat_dtype_with_size(DTYPEG(s1), DTYPEG(s2)))
1982 return FALSE;
1983 if (PRIVATEG(s1) != PRIVATEG(s2))
1984 return FALSE;
1985 }
1986 /* more members in either record? */
1987 if (s2 > NOSYM || s1 > NOSYM)
1988 return FALSE;
1989 return TRUE;
1990
1991 case TY_CHAR:
1992 case TY_NCHAR:
1993 return TRUE;
1994 default:
1995 break;
1996 }
1997 return FALSE;
1998 }
1999
2000 /** \brief Similar to eq_dtype(), except types must match exactly,
2001 and derived types must be SEQUENCE and match in name also.
2002 Also, array extents are checked.
2003 */
2004 LOGICAL
same_dtype(DTYPE d1,DTYPE d2)2005 same_dtype(DTYPE d1, DTYPE d2)
2006 {
2007 int s1, s2, i, n;
2008 int tg1, tg2;
2009
2010 if (d1 == d2)
2011 return TRUE;
2012 if (d1 <= 0 || d2 <= 0)
2013 return FALSE;
2014 if (DTY(d1) != DTY(d2))
2015 return FALSE;
2016 /* here, DTY(d1) == DTY(d2) */
2017 switch (DTY(d1)) {
2018 case TY_ARRAY:
2019 /* check rank, extents and element type */
2020 if (ADD_NUMDIM(d1) != ADD_NUMDIM(d2))
2021 return FALSE;
2022 n = ADD_NUMDIM(d1);
2023 for (i = 0; i < n; ++i) {
2024 /* check bounds */
2025 int l1, l2, u1, u2, e1, e2;
2026 l1 = ADD_LWBD(d1, i);
2027 u1 = ADD_UPBD(d1, i);
2028 l2 = ADD_LWBD(d2, i);
2029 u2 = ADD_UPBD(d2, i);
2030 /* if not constant upper bound, give up */
2031 if (!u1 || !A_ALIASG(u1))
2032 continue;
2033 if (A_DTYPEG(u1) != DT_INT4)
2034 continue;
2035 e1 = get_int_cval(A_SPTRG(u1));
2036 if (l1) {
2037 if (!A_ALIASG(l1))
2038 continue;
2039 if (A_DTYPEG(l1) != DT_INT4)
2040 continue;
2041 e1 -= get_int_cval(A_SPTRG(l1)) - 1;
2042 }
2043 if (!u2 || !A_ALIASG(u2))
2044 continue;
2045 if (A_DTYPEG(u2) != DT_INT4)
2046 continue;
2047 e2 = get_int_cval(A_SPTRG(u2));
2048 if (l2) {
2049 if (!A_ALIASG(l2))
2050 continue;
2051 if (A_DTYPEG(l2) != DT_INT4)
2052 continue;
2053 e2 -= get_int_cval(A_SPTRG(l2)) - 1;
2054 }
2055 /* different extents */
2056 if (e1 != e2)
2057 return FALSE;
2058 }
2059 return same_dtype(DTY(d1 + 1), DTY(d2 + 1));
2060
2061 case TY_DERIVED:
2062 /* tags are the same => equal types */
2063 tg1 = DTY(d1 + 3);
2064 tg2 = DTY(d2 + 3);
2065 if (tg1 == tg2)
2066 return TRUE;
2067 /* both must be SEQUENCE or both must be BIND(C) */
2068 if ((SEQG(tg1) && SEQG(tg2)) || (CFUNCG(tg1) && CFUNCG(tg2)))
2069 ;
2070 else if (same_parameterized_dt(d1, d2))
2071 return TRUE;
2072 else {
2073 return FALSE;
2074 }
2075 if (VISITG(tg1) && VISITG(tg2)) {
2076 /* have a self-referential derived type */
2077 return TRUE;
2078 }
2079 if (VISITG(tg1) || VISITG(tg2)) {
2080 return FALSE;
2081 }
2082 VISITP(tg1, 1);
2083 VISITP(tg2, 1);
2084 /* traverse the members */
2085 for (s1 = DTY(d1 + 1), s2 = DTY(d2 + 1); s1 > NOSYM && s2 > NOSYM;
2086 s1 = SYMLKG(s1), s2 = SYMLKG(s2)) {
2087 /* neither member can be PRIVATE */
2088 if (PRIVATEG(s1) || PRIVATEG(s2))
2089 break; /* return FALSE; */
2090 /* member types are different => different types */
2091 if (!same_dtype(DTYPEG(s1), DTYPEG(s2)))
2092 break; /* return FALSE; */
2093 }
2094 VISITP(tg1, 0);
2095 VISITP(tg2, 0);
2096 /* more members in either record? */
2097 if (s2 > NOSYM || s1 > NOSYM)
2098 return FALSE;
2099 return TRUE;
2100
2101 case TY_CHAR:
2102 case TY_NCHAR:
2103 /* compare lengths */
2104 if (DTY(d1 + 1) == DTY(d2 + 1))
2105 return TRUE;
2106 break;
2107
2108 default:
2109 break;
2110 }
2111 return FALSE;
2112 }
2113
2114 static int
priority(int op)2115 priority(int op)
2116 {
2117 switch (op) {
2118 case OP_CMP:
2119 case OP_AIF:
2120 case OP_FUNC:
2121 case OP_CON:
2122 case OP_LOG:
2123 /* I don't know what these are, anyway */
2124 return 0;
2125 /* missing priority 110 is for user-defined binary operators */
2126 case OP_LEQV:
2127 case OP_LNEQV:
2128 return 20;
2129 case OP_LOR:
2130 return 30;
2131 case OP_LAND:
2132 return 40;
2133 case OP_LNOT:
2134 return 50;
2135 case OP_EQ:
2136 case OP_GE:
2137 case OP_GT:
2138 case OP_LE:
2139 case OP_LT:
2140 case OP_NE:
2141 return 60;
2142 case OP_CAT:
2143 return 70;
2144 case OP_NEG:
2145 case OP_ADD:
2146 case OP_SUB:
2147 return 80;
2148 case OP_MUL:
2149 case OP_DIV:
2150 return 90;
2151 case OP_XTOI:
2152 case OP_XTOX:
2153 return 101; /* right associative */
2154 /* missing priority 110 is for user-defined unary operators */
2155 case OP_LD:
2156 case OP_ST:
2157 case OP_LOC:
2158 case OP_REF:
2159 case OP_VAL:
2160 case OP_BYVAL:
2161 case OP_SCAND:
2162 return 120;
2163 }
2164 interr("priority. Unexpected op", op, 2);
2165 return 0;
2166 } /* priority */
2167
2168 static int
leftparens(int ast,int astleft)2169 leftparens(int ast, int astleft)
2170 {
2171 int prio, prioleft;
2172 if (A_TYPEG(ast) != A_BINOP && A_TYPEG(ast) != A_UNOP) {
2173 return FALSE;
2174 }
2175 if (A_TYPEG(astleft) != A_BINOP && A_TYPEG(astleft) != A_UNOP) {
2176 return FALSE;
2177 }
2178 prio = priority(A_OPTYPEG(ast));
2179 prioleft = priority(A_OPTYPEG(astleft));
2180 if (prio < prioleft)
2181 return FALSE;
2182 if (prioleft < prio)
2183 return TRUE;
2184 /* if the same priority, check if the operator is right-associative */
2185 if (prio & 0x1)
2186 return TRUE;
2187 return FALSE;
2188 } /* leftparens */
2189
2190 static int
rightparens(int ast,int astright)2191 rightparens(int ast, int astright)
2192 {
2193 int prio, prioright;
2194 if (A_TYPEG(ast) != A_BINOP && A_TYPEG(ast) != A_UNOP) {
2195 return FALSE;
2196 }
2197 if (A_TYPEG(astright) != A_BINOP && A_TYPEG(astright) != A_UNOP) {
2198 return FALSE;
2199 }
2200 prio = priority(A_OPTYPEG(ast));
2201 prioright = priority(A_OPTYPEG(astright));
2202 if (prio < prioright)
2203 return FALSE;
2204 if (prioright < prio)
2205 return TRUE;
2206 /* if the same priority, check if the operator is right-associative */
2207 if (prio & 0x1)
2208 return FALSE;
2209 return TRUE;
2210 } /* rightparens */
2211
2212 static void
getop(int op,char * string)2213 getop(int op, char *string)
2214 {
2215 char *s;
2216 switch (op) {
2217 case OP_CMP:
2218 s = ".cmp.";
2219 break;
2220 case OP_AIF:
2221 s = ".aif.";
2222 break;
2223 case OP_FUNC:
2224 s = ".func.";
2225 break;
2226 case OP_CON:
2227 s = ".con.";
2228 break;
2229 case OP_LOG:
2230 s = ".aif.";
2231 break;
2232 case OP_LEQV:
2233 s = ".eqv.";
2234 break;
2235 case OP_LNEQV:
2236 s = ".neqv.";
2237 break;
2238 case OP_LOR:
2239 s = ".or.";
2240 break;
2241 case OP_LAND:
2242 s = ".and.";
2243 break;
2244 case OP_LNOT:
2245 s = ".not.";
2246 break;
2247 case OP_EQ:
2248 s = ".eq.";
2249 break;
2250 case OP_GE:
2251 s = ".ge.";
2252 break;
2253 case OP_GT:
2254 s = ".gt.";
2255 break;
2256 case OP_LE:
2257 s = ".le.";
2258 break;
2259 case OP_LT:
2260 s = ".lt.";
2261 break;
2262 case OP_NE:
2263 s = ".ne.";
2264 break;
2265 case OP_CAT:
2266 s = "//";
2267 break;
2268 case OP_NEG:
2269 s = "-";
2270 break;
2271 case OP_ADD:
2272 s = "+";
2273 break;
2274 case OP_SUB:
2275 s = "-";
2276 break;
2277 case OP_MUL:
2278 s = "*";
2279 break;
2280 case OP_DIV:
2281 s = "/";
2282 break;
2283 case OP_XTOI:
2284 s = "**";
2285 break;
2286 case OP_XTOX:
2287 s = "**";
2288 break;
2289 case OP_LD:
2290 s = ".load.";
2291 break;
2292 case OP_ST:
2293 s = ".store.";
2294 break;
2295 case OP_LOC:
2296 s = ".loc.";
2297 break;
2298 case OP_REF:
2299 s = ".ref.";
2300 break;
2301 case OP_VAL:
2302 s = ".val.";
2303 break;
2304 case OP_BYVAL:
2305 s = "(byval)";
2306 break;
2307 case OP_SCAND:
2308 s = ".scand.";
2309 break;
2310 default:
2311 s = ".??.";
2312 break;
2313 }
2314 strcat(string, s);
2315 } /* getop */
2316
2317 /** \brief Given an AST and a string pointer, append a printable representation
2318 of the AST expression onto the string */
2319 void
getast(int ast,char * string)2320 getast(int ast, char *string)
2321 {
2322 int asd, ndim, i, lp, rp;
2323 switch (A_TYPEG(ast)) {
2324 case A_ID:
2325 case A_LABEL:
2326 case A_ENTRY:
2327 case A_CNST:
2328 strcat(string, getprint(sym_of_ast(ast)));
2329 if (DBGBIT(5, 0x40) && A_TYPEG(ast) == A_ID) {
2330 char b[64];
2331 sprintf(b, "\\%d", sym_of_ast(ast));
2332 strcat(string, b);
2333 }
2334 break;
2335 case A_SUBSCR:
2336 /*strcat( string, getprint(sym_of_ast(ast)) );*/
2337 getast((int)A_LOPG(ast), string);
2338 strcat(string, "(");
2339 asd = A_ASDG(ast);
2340 ndim = ASD_NDIM(asd);
2341 for (i = 0; i < ndim; ++i) {
2342 if (i)
2343 strcat(string, ",");
2344 getast((int)ASD_SUBS(asd, i), string);
2345 }
2346 strcat(string, ")");
2347 break;
2348 case A_MEM:
2349 getast((int)A_PARENTG(ast), string);
2350 strcat(string, "%");
2351 getast((int)A_MEMG(ast), string);
2352 break;
2353 case A_BINOP:
2354 lp = rp = 0;
2355 if (leftparens(ast, A_LOPG(ast))) {
2356 strcat(string, "(");
2357 lp = 1;
2358 }
2359 getast((int)A_LOPG(ast), string);
2360 if (lp)
2361 strcat(string, ")");
2362 getop(A_OPTYPEG(ast), string);
2363 if (rightparens(ast, A_ROPG(ast))) {
2364 strcat(string, "(");
2365 rp = 1;
2366 }
2367 getast((int)A_ROPG(ast), string);
2368 if (rp)
2369 strcat(string, ")");
2370 break;
2371 case A_UNOP:
2372 rp = 0;
2373 getop(A_OPTYPEG(ast), string);
2374 if (rightparens(ast, A_LOPG(ast))) {
2375 strcat(string, "(");
2376 rp = 1;
2377 }
2378 getast((int)A_LOPG(ast), string);
2379 if (rp)
2380 strcat(string, ")");
2381 break;
2382 case A_PAREN:
2383 strcat(string, "(");
2384 getast((int)A_LOPG(ast), string);
2385 strcat(string, ")");
2386 break;
2387 case A_CONV:
2388 strcat(string, "conv(");
2389 getast((int)A_LOPG(ast), string);
2390 strcat(string, ")");
2391 break;
2392 case A_CMPLXC:
2393 strcat(string, "(");
2394 getast((int)A_LOPG(ast), string);
2395 strcat(string, ",");
2396 getast((int)A_ROPG(ast), string);
2397 strcat(string, ")");
2398 break;
2399 default:
2400 strcat(string, "??");
2401 break;
2402 } /* switch */
2403 } /* getast */
2404
2405 /** \brief Check if ast is deferred-length character */
2406 bool
is_deferlenchar_ast(int ast)2407 is_deferlenchar_ast(int ast)
2408 {
2409 DTYPE dt;
2410 SPTR sym = 0;
2411
2412 dt = DDTG(A_DTYPEG(ast));
2413 if (DTY(dt) != TY_CHAR && DTY(dt) != TY_NCHAR) {
2414 return false;
2415 }
2416
2417 if (dt == DT_ASSCHAR || dt == DT_ASSNCHAR) {
2418 return false;
2419 } else if (dt == DT_DEFERCHAR || dt == DT_DEFERNCHAR) {
2420 return true;
2421 }
2422
2423 if (ast_is_sym(ast)) {
2424 sym = memsym_of_ast(ast);
2425 }
2426
2427 /* adjustable length character */
2428 if ((sym > NOSYM) && ADJLENG(sym)) {
2429 return false;
2430 }
2431
2432 if (DTY(A_DTYPEG(ast)) == TY_ARRAY) {
2433 if (ADD_DEFER(A_DTYPEG(ast))) {
2434 dt = DTY(DDTG(A_DTYPEG(ast)) + 1);
2435 if (A_TYPEG(dt) != A_CNST) {
2436 return true;
2437 }
2438 }
2439 }
2440 return false;
2441 }
2442
2443 /** \brief Check if dtype is deferred-length character */
2444 bool
is_deferlenchar_dtype(DTYPE dtype)2445 is_deferlenchar_dtype(DTYPE dtype)
2446 {
2447 DTYPE dt;
2448
2449 dt = DDTG(dtype);
2450 if (DTY(dt) != TY_CHAR && DTY(dt) != TY_NCHAR) {
2451 return false;
2452 }
2453
2454 if (dt == DT_DEFERCHAR || dt == DT_DEFERNCHAR) {
2455 return true;
2456 }
2457 dt = DTY(dt+1);
2458 if (DTY(dtype) == TY_ARRAY) {
2459 if (!ADD_DEFER(dtype)) {
2460 return false;
2461 }
2462 }
2463
2464 if (A_TYPEG(dt) == A_ID) {
2465 /* i.e. character(len=newlen) */
2466 if (ASSNG(A_SPTRG(dt))) {
2467 return true;
2468 }
2469 } else if (A_TYPEG(dt) == A_SUBSCR) {
2470 /* i.e. character(len=newlen(1)) */
2471 if (ASSNG(memsym_of_ast(dt))) {
2472 return true;
2473 }
2474 }
2475
2476 /* i.e. character(len=len(a)) */
2477 if ((A_TYPEG(dt) == A_FUNC || A_TYPEG(dt) == A_INTR)
2478 && is_deferlenchar_ast(ARGT_ARG(A_ARGSG(dt), 0))) {
2479 return true;
2480 }
2481 return false;
2482 }
2483
2484
2485 /** \brief Put into the character array pointed to by ptr, the print
2486 representation
2487 of dtype.
2488 */
2489 void
getdtype(DTYPE dtype,char * ptr)2490 getdtype(DTYPE dtype, char *ptr)
2491 {
2492 int i;
2493 ADSC *ad;
2494 int numdim;
2495 char *p;
2496
2497 p = ptr;
2498 *p = 0;
2499 for (; dtype != 0 && p - ptr <= 150; dtype = DTY(dtype + 1)) {
2500 if (dtype <= 0 || dtype >= stb.dt.stg_avail) {
2501 sprintf(p, "bad dtype(%d)", dtype);
2502 break;
2503 }
2504 if (DTY(dtype) <= 0 || DTY(dtype) > TY_MAX) {
2505 sprintf(p, "bad dtype(%d[%d])", dtype, (int)DTY(dtype));
2506 break;
2507 }
2508 strcpy(p, stb.tynames[DTY(dtype)]);
2509 p += strlen(p);
2510
2511 switch (DTY(dtype)) {
2512 case TY_STRUCT:
2513 case TY_UNION:
2514 case TY_DERIVED:
2515 i = DTY(dtype + 3);
2516 if (i) {
2517 if (i <= NOSYM || i >= stb.stg_avail) {
2518 sprintf(p, "/bad tag=%d/", i);
2519 } else {
2520 sprintf(p, "/%s/", SYMNAME(i));
2521 }
2522 p += strlen(p);
2523 }
2524 return;
2525
2526 case TY_ARRAY:
2527 if (DTY(dtype + 2) == 0) {
2528 *p++ = ' ';
2529 *p++ = '(';
2530 } else {
2531 ad = AD_DPTR(dtype);
2532 numdim = AD_NUMDIM(ad);
2533 if (numdim < 1 || numdim > 7) {
2534 sprintf(p, "ndim=%d", numdim);
2535 numdim = 0;
2536 p += strlen(p);
2537 }
2538 if (AD_DEFER(ad)) {
2539 strcpy(p, " deferred");
2540 p += strlen(p);
2541 }
2542 if (AD_ASSUMSHP(ad) == 1) {
2543 strcpy(p, " assumedshape");
2544 p += strlen(p);
2545 }
2546 if (AD_ASSUMSHP(ad) == 2) {
2547 strcpy(p, " wasassumedshape");
2548 p += strlen(p);
2549 }
2550 if (AD_ADJARR(ad)) {
2551 strcpy(p, " adjustable");
2552 p += strlen(p);
2553 }
2554 if (AD_ASSUMSZ(ad)) {
2555 strcpy(p, " assumedsize");
2556 p += strlen(p);
2557 }
2558 if (AD_NOBOUNDS(ad)) {
2559 strcpy(p, " nobounds");
2560 p += strlen(p);
2561 }
2562 *p++ = ' ';
2563 *p++ = '(';
2564 for (i = 0; i < numdim; i++) {
2565 if (i)
2566 *p++ = ',';
2567 if (AD_LWAST(ad, i)) {
2568 *p = '\0';
2569 getast(AD_LWAST(ad, i), p);
2570 p += strlen(p);
2571 if (AD_LWBD(ad, i) != AD_LWAST(ad, i)) {
2572 *p++ = '[';
2573 if (AD_LWBD(ad, i)) {
2574 *p = '\0';
2575 getast(AD_LWBD(ad, i), p);
2576 p += strlen(p);
2577 }
2578 *p++ = ']';
2579 }
2580 *p++ = ':';
2581 } else if (AD_LWBD(ad, i)) {
2582 *p++ = '[';
2583 *p = '\0';
2584 getast(AD_LWBD(ad, i), p);
2585 p += strlen(p);
2586 *p++ = ']';
2587 *p++ = ':';
2588 }
2589 if (AD_UPAST(ad, i)) {
2590 *p = '\0';
2591 getast(AD_UPAST(ad, i), p);
2592 p += strlen(p);
2593 } else {
2594 *p++ = '*';
2595 }
2596 if (AD_UPBD(ad, i) != AD_UPAST(ad, i)) {
2597 *p++ = '[';
2598 if (AD_UPBD(ad, i)) {
2599 *p = '\0';
2600 getast(AD_UPBD(ad, i), p);
2601 p += strlen(p);
2602 }
2603 *p++ = ']';
2604 }
2605 }
2606 }
2607 strcpy(p, ") of ");
2608 p += 5;
2609 break;
2610
2611 case TY_PTR:
2612 *p++ = ' ';
2613 break;
2614
2615 case TY_CHAR:
2616 case TY_NCHAR:
2617 if (dtype == DT_ASSCHAR || dtype == DT_ASSNCHAR)
2618 sprintf(p, "*(*)");
2619 else if (dtype == DT_DEFERCHAR || dtype == DT_DEFERNCHAR) {
2620 sprintf(p, "*(:)");
2621 } else {
2622 sprintf(p, "*");
2623 p += strlen(p);
2624 *p = '\0';
2625 getast(DTY(dtype + 1), p);
2626 }
2627 return;
2628
2629 default:
2630 return;
2631 }
2632 }
2633 }
2634
2635 void
dmp_dtype(void)2636 dmp_dtype(void)
2637 {
2638 int i;
2639
2640 fprintf(gbl.dbgfil, "\n------------------------\nDTYPE DUMP:\n");
2641 fprintf(gbl.dbgfil, "\ndt_base: %lx dt_size: %d dt_avail: %d\n\n",
2642 (long)(stb.dt.stg_base), stb.dt.stg_size, stb.dt.stg_avail);
2643 i = 1;
2644 fprintf(gbl.dbgfil, "index dtype\n");
2645 while (i < stb.dt.stg_avail) {
2646 i += dmp_dent(i);
2647 }
2648 fprintf(gbl.dbgfil, "\n------------------------\n");
2649 }
2650
2651 int
dlen(int ty)2652 dlen(int ty)
2653 {
2654 switch (ty) {
2655 case TY_NONE:
2656 case TY_WORD:
2657 case TY_DWORD:
2658 case TY_HOLL:
2659 case TY_BINT:
2660 case TY_SINT:
2661 case TY_INT:
2662 case TY_INT8:
2663 case TY_REAL:
2664 case TY_DBLE:
2665 case TY_QUAD:
2666 case TY_CMPLX:
2667 case TY_DCMPLX:
2668 case TY_QCMPLX:
2669 case TY_BLOG:
2670 case TY_SLOG:
2671 case TY_LOG:
2672 case TY_LOG8:
2673 case TY_NUMERIC:
2674 case TY_ANY:
2675 case TY_128:
2676 case TY_256:
2677 case TY_512:
2678 case TY_INT128:
2679 case TY_LOG128:
2680 case TY_FLOAT128:
2681 case TY_CMPLX128:
2682 return 1;
2683
2684 case TY_CHAR:
2685 case TY_NCHAR:
2686 case TY_PTR:
2687 return 2;
2688
2689 case TY_STRUCT:
2690 case TY_UNION:
2691 case TY_DERIVED:
2692 return 6;
2693
2694 case TY_ARRAY:
2695 return 3;
2696
2697 case TY_PROC:
2698 return 6;
2699
2700 default:
2701 return 1;
2702 }
2703 } /* dlen */
2704
2705 int
_dmp_dent(DTYPE dtypeind,FILE * outfile)2706 _dmp_dent(DTYPE dtypeind, FILE *outfile)
2707 {
2708 char buf[1024];
2709 int retval;
2710 ADSC *ad;
2711 int numdim;
2712 int i;
2713 int paramct, dpdsc;
2714
2715 if (outfile == NULL)
2716 outfile = stderr;
2717
2718 if (dtypeind < 1 || dtypeind >= stb.dt.stg_avail) {
2719 fprintf(outfile, "dtype index (%d) out of range in dmp_dent\n", dtypeind);
2720 return 1;
2721 }
2722 buf[0] = '\0';
2723 fprintf(outfile, " %5d ", dtypeind);
2724 switch (DTY(dtypeind)) {
2725 case TY_WORD:
2726 case TY_DWORD:
2727 case TY_HOLL:
2728 case TY_BINT:
2729 case TY_SINT:
2730 case TY_INT:
2731 case TY_REAL:
2732 case TY_DBLE:
2733 case TY_QUAD:
2734 case TY_CMPLX:
2735 case TY_DCMPLX:
2736 case TY_QCMPLX:
2737 case TY_BLOG:
2738 case TY_SLOG:
2739 case TY_LOG:
2740 case TY_NUMERIC:
2741 case TY_ANY:
2742 case TY_INT8:
2743 case TY_LOG8:
2744 case TY_128:
2745 case TY_256:
2746 case TY_512:
2747 case TY_INT128:
2748 case TY_LOG128:
2749 case TY_FLOAT128:
2750 case TY_CMPLX128:
2751 retval = 1;
2752 break;
2753
2754 case TY_CHAR:
2755 case TY_NCHAR:
2756 retval = 2;
2757 break;
2758
2759 case TY_PTR:
2760 fprintf(outfile, "ptr dtype=%5d\n ", (int)DTY(dtypeind + 1));
2761 retval = 2;
2762 break;
2763
2764 case TY_ARRAY:
2765 retval = 3;
2766 fprintf(outfile, "array dtype=%5d desc =%" ISZ_PF "d\n",
2767 (int)DTY(dtypeind + 1), DTY(dtypeind + 2));
2768 if (DTY(dtypeind + 2) == 0) {
2769 fprintf(outfile, " (No array desc)\n ");
2770 break;
2771 }
2772 ad = AD_DPTR(dtypeind);
2773 numdim = AD_NUMDIM(ad);
2774 fprintf(outfile,
2775 " numdim:%d defer:%d adjarr:%d assumz:%d nobounds:%d",
2776 numdim, AD_DEFER(ad), AD_ADJARR(ad), AD_ASSUMSZ(ad),
2777 AD_NOBOUNDS(ad));
2778 fprintf(outfile, " assumshp:%d\n", AD_ASSUMSHP(ad));
2779 fprintf(outfile, " zbase: %d numelm: %d\n", AD_ZBASE(ad),
2780 AD_NUMELM(ad));
2781 if (numdim < 1 || numdim > 7)
2782 numdim = 0;
2783 for (i = 0; i < numdim; i++)
2784 fprintf(outfile, " %1d: mlpyr: %d lwbd: %d upbd: %d"
2785 " lwast: %d upast: %d extntast: %d\n",
2786 i + 1, AD_MLPYR(ad, i), AD_LWBD(ad, i), AD_UPBD(ad, i),
2787 AD_LWAST(ad, i), AD_UPAST(ad, i), AD_EXTNTAST(ad, i));
2788 break;
2789 case TY_STRUCT:
2790 case TY_UNION:
2791 case TY_DERIVED:
2792 fprintf(outfile, "%s sptr =%5d size =%" ISZ_PF "d",
2793 stb.tynames[DTY(dtypeind)], (int)DTY(dtypeind + 1),
2794 DTY(dtypeind + 2));
2795 fprintf(outfile, " tag=%5d align=%3d", (int)DTY(dtypeind + 3),
2796 (int)DTY(dtypeind + 4));
2797 fprintf(outfile, " ict=%08lx\n ",
2798 (long)(get_getitem_p(DTY(dtypeind + 5))));
2799 retval = 6;
2800 break;
2801 case TY_PROC:
2802 paramct = DTY(dtypeind + 3);
2803 dpdsc = DTY(dtypeind + 4);
2804 fprintf(outfile, "proc dtype=%5" BIGIPFSZ "d interface=%5" BIGIPFSZ
2805 "d paramct=%3d"
2806 " dpdsc=%5d fval=%5" BIGIPFSZ "d\n",
2807 DTY(dtypeind + 1), DTY(dtypeind + 2), paramct, dpdsc,
2808 DTY(dtypeind + 5));
2809 for (i = 0; i < paramct; i++) {
2810 fprintf(outfile, " arg %d: %d\n", i + 1, aux.dpdsc_base[dpdsc + i]);
2811 }
2812 retval = 6;
2813 break;
2814 default:
2815 /* function param thing ?? */
2816 fprintf(outfile, "???? %5d\n", (int)DTY(dtypeind));
2817 retval = 1;
2818 dtypeind = 0;
2819 break;
2820 }
2821 if (dtypeind) {
2822 getdtype(dtypeind, buf);
2823 fprintf(outfile, "%s\n", buf);
2824 }
2825 return retval;
2826 }
2827
2828 int
dmp_dent(DTYPE dtypeind)2829 dmp_dent(DTYPE dtypeind)
2830 {
2831
2832 FILE *outfile;
2833 if (gbl.dbgfil == NULL) {
2834 outfile = stderr;
2835 } else {
2836 outfile = gbl.dbgfil;
2837 }
2838 return _dmp_dent(dtypeind, outfile);
2839 }
2840
2841 void
pr_dent(DTYPE dt,FILE * f)2842 pr_dent(DTYPE dt, FILE *f)
2843 {
2844 int ss;
2845 if (f == NULL)
2846 f = stderr;
2847 if (dt < 1 || dt >= stb.dt.stg_avail) {
2848 fprintf(f, "dtype index (%d) out of range in pr_dent\n", dt);
2849 return;
2850 }
2851 _dmp_dent(dt, f);
2852 switch (DTY(dt)) {
2853 case TY_PTR:
2854 pr_dent(DTY(dt + 1), f);
2855 break;
2856 case TY_DERIVED:
2857 for (ss = DTY(dt + 1); ss > NOSYM; ss = SYMLKG(ss)) {
2858 fprintf(f, " +++++ MEMBER %d(%s)\n", ss, SYMNAME(ss));
2859 pr_dent(DTYPEG(ss), f);
2860 }
2861 default:
2862 break;
2863 }
2864 }
2865
2866 #if DEBUG
2867 static void
dumpdtype(DTYPE dtype)2868 dumpdtype(DTYPE dtype)
2869 {
2870 dmp_dent(dtype);
2871 } /* dumpdtype */
2872 #endif
2873
2874 /** \brief Compute the size of a data type.
2875
2876 This machine dependent routine computes the size of a data type
2877 in terms of two quantities:
2878 - size - number of elements in the data type (returned thru size).
2879 - scale - number of bytes in each element, expressed as a power
2880 of two (the return value of scale_of).
2881
2882 This routine will be used to take advantage of the machines that
2883 have the ability to add a scaled expression (multiplied by a power
2884 of two) to an address. This is particularly useful for incrementing
2885 a pointer variable and array subscripting.
2886
2887 Note that for those machines that do not have this feature, scale_of
2888 returns a scale of 0 and size_of for size.
2889 */
2890 int
scale_of(DTYPE dtype,INT * size)2891 scale_of(DTYPE dtype, INT *size)
2892 {
2893 INT d;
2894 int tmp;
2895 int scale, clen;
2896 INT tmpsiz;
2897 TY_KIND ty = get_ty_kind(dtype);
2898
2899 switch (ty) {
2900 case TY_WORD:
2901 case TY_DWORD:
2902 case TY_LOG:
2903 case TY_INT:
2904 case TY_FLOAT:
2905 case TY_PTR:
2906 case TY_SLOG:
2907 case TY_SINT:
2908 case TY_BINT:
2909 case TY_BLOG:
2910 case TY_DBLE:
2911 case TY_CMPLX:
2912 case TY_DCMPLX:
2913 case TY_QCMPLX:
2914 case TY_INT8:
2915 case TY_LOG8:
2916 scale = dtypeinfo[ty].scale;
2917 *size = (unsigned)dtypeinfo[ty].size >> scale;
2918 return scale;
2919
2920 case TY_HOLL:
2921 case TY_CHAR:
2922 if (dtype == DT_ASSCHAR || dtype == DT_DEFERCHAR)
2923 interr("scale_of: attempt to size assumed size character", 0, 3);
2924 clen = string_length(dtype);
2925 *size = clen;
2926 return 0;
2927
2928 case TY_NCHAR:
2929 if (dtype == DT_ASSNCHAR || dtype == DT_DEFERNCHAR)
2930 interr("scale_of: attempt to size assumed size ncharacter", 0, 3);
2931 clen = string_length(dtype);
2932 *size = 2 * clen;
2933 return 0;
2934
2935 case TY_ARRAY:
2936 if ((d = DTY(dtype + 2)) <= 0) {
2937 interr("scale_of: no array descriptor", (int)d, 3);
2938 d = DTY(dtype + 2) = 1;
2939 }
2940 tmp = scale_of((int)DTY(dtype + 1), &tmpsiz);
2941 *size = d * tmpsiz;
2942 return tmp;
2943
2944 case TY_STRUCT:
2945 case TY_UNION:
2946 case TY_DERIVED:
2947 if (DTY(dtype + 2) <= 0) {
2948 interr("scale_of: 0 size struct", 0, 3);
2949 *size = 4;
2950 return 0;
2951 } else {
2952 *size = DTY(dtype + 2);
2953 return 0;
2954 }
2955
2956 default:
2957 interr("scale_of: bad dtype", ty, 3);
2958 *size = 1;
2959 return 0;
2960 }
2961 }
2962
2963 /** \brief Return 0 if reg, 1 if mem. */
2964 int
fval_of(DTYPE dtype)2965 fval_of(DTYPE dtype)
2966 {
2967 TY_KIND ty = get_ty_kind(dtype);
2968 int fv = dtypeinfo[ty].fval & 0x3;
2969 assert(fv <= 1, "fval_of: bad dtype, dt is", dtype, 3);
2970 return fv;
2971 }
2972
2973 static TY_KIND
get_ty_kind(DTYPE dtype)2974 get_ty_kind(DTYPE dtype)
2975 {
2976 assert(dtype > 0 && dtype < stb.dt.stg_avail, "bad dtype", dtype, ERR_Severe);
2977 return DTY(dtype);
2978 }
2979
2980 #define SS2 0x8e
2981 #define SS3 0x8f
2982
2983 /** \brief Return number of kanji characters
2984 \param p character string
2985 \param len length in bytes of \p p
2986 */
2987 int
kanji_len(unsigned char * p,int len)2988 kanji_len(unsigned char *p, int len)
2989 {
2990 int count = 0;
2991 int val;
2992
2993 while (len > 0) {
2994 val = *p;
2995 count++;
2996 if ((val & 0x80) == 0 || len <= 1) /* ASCII */
2997 len--, p++;
2998 else if (val == SS2) /* JIS 8-bit character */
2999 len -= 2, p += 2;
3000 else if (val == SS3 && len >= 3) /* Graphic Character */
3001 len -= 3, p += 3;
3002 else /* Kanji */
3003 len -= 2, p += 2;
3004 }
3005
3006 return count;
3007 }
3008
3009 /** \brief Extract necessary bytes from character string in order to return
3010 integer (16-bit) representation of one kanji char.
3011 \param p ptr to EUC string
3012 \param len number of bytes in \p p
3013 \param bytes return number of EUC bytes used up
3014 */
3015 int
kanji_char(unsigned char * p,int len,int * bytes)3016 kanji_char(unsigned char *p, int len, int *bytes)
3017 {
3018 int val = *p;
3019
3020 if ((val & 0x80) == 0 || len <= 1) /* ASCII */
3021 *bytes = 1;
3022 else if (val == SS2) /* JIS 8-bit character */
3023 *bytes = 2, val = *(p + 1);
3024 else if (val == SS3 && len >= 3) /* Graphic Character */
3025 *bytes = 3, val = ((*(p + 1) << 8) | (*(p + 2) & 0x7F));
3026 else /* Kanji */
3027 *bytes = 2, val = ((val << 8) | *(p + 1));
3028
3029 return val;
3030 }
3031
3032 /** \brief Return number of bytes required for newlen chars.
3033 \param p ptr to EUC string
3034 \param newlen number of kanji chars required from string prefix
3035 \param len total number of bytes in string
3036 */
3037 int
kanji_prefix(unsigned char * p,int newlen,int len)3038 kanji_prefix(unsigned char *p, int newlen, int len)
3039 {
3040 unsigned char *begin;
3041 int bytes;
3042
3043 begin = p;
3044 while (newlen-- > 0) {
3045 (void)kanji_char(p, len, &bytes);
3046 p += bytes;
3047 len -= bytes;
3048 }
3049
3050 return (p - begin);
3051 }
3052
3053 #define _FP 4
3054 #define _VP 6
3055 /** \brief Create a dtype record for an array of rank numdim including its array
3056 descriptor.
3057 \param numdim number of dimensions
3058 \param eltype data type of the array element
3059
3060 The layout of an array descriptor is:
3061 <pre>
3062 int numdim; --+
3063 int zbase; |
3064 UINT16 *ilmp; |
3065 char defer; +-- 4 ints (fixed part)
3066 char adjarr; |
3067 char assumsz; |
3068 char pad; --+
3069 struct {
3070 int mlpyr; --+
3071 int lwbd; |
3072 int upbd; +-- 6 ints (variable part)
3073 int lwast; |
3074 int upast; |
3075 int exntnast;-+
3076 } b[numdim];
3077 int numelm; --+-- 1 int
3078 </pre>
3079 Any change in the size of the structure requires a change to one or both
3080 of the macros _FP and _VP. Also the size assertion in symtab.c needs
3081 to be changed.
3082 */
3083 DTYPE
get_array_dtype(int numdim,DTYPE eltype)3084 get_array_dtype(int numdim, DTYPE eltype)
3085 {
3086 DTYPE dtype;
3087
3088 dtype = get_type(3, TY_ARRAY, eltype);
3089 get_aux_arrdsc(dtype, numdim);
3090
3091 return dtype;
3092 }
3093
3094 void
get_aux_arrdsc(DTYPE dtype,int numdim)3095 get_aux_arrdsc(DTYPE dtype, int numdim)
3096 {
3097 ADSC *ad;
3098
3099 DTY(dtype + 2) = aux.arrdsc_avl;
3100 aux.arrdsc_avl += (_FP + 1) + (_VP * numdim);
3101 NEED(aux.arrdsc_avl, aux.arrdsc_base, int, aux.arrdsc_size,
3102 aux.arrdsc_avl + 240);
3103 ad = AD_DPTR(dtype);
3104 BZERO(ad, int, (_FP + 1) + _VP * numdim);
3105 AD_NUMDIM(ad) = numdim;
3106 }
3107
3108 /** \brief Duplicate a dtype array record and its array descriptor.
3109 */
3110 DTYPE
dup_array_dtype(DTYPE o_dt)3111 dup_array_dtype(DTYPE o_dt)
3112 {
3113 ADSC *ad;
3114 ADSC *o_ad = AD_DPTR(o_dt);
3115 int numdim = AD_NUMDIM(o_ad);
3116 DTYPE dtype = get_type(3, TY_ARRAY, DT_NONE);
3117
3118 DTY(dtype + 2) = aux.arrdsc_avl;
3119 aux.arrdsc_avl += (_FP + 1) + (_VP * numdim);
3120 NEED(aux.arrdsc_avl, aux.arrdsc_base, int, aux.arrdsc_size,
3121 aux.arrdsc_avl + 240);
3122 o_ad = AD_DPTR(o_dt); /* recreate pointer after possible realloc */
3123 ad = AD_DPTR(dtype);
3124
3125 BCOPY(ad, o_ad, int, (_FP + 1) + _VP * numdim);
3126
3127 /* make it the same element type; the caller may change the type */
3128 DTY(dtype + 1) = DTY(o_dt + 1);
3129 return dtype;
3130 }
3131
3132 /** \brief Duplicate a dtype array record and its array descriptor, excluding a
3133 dimension.
3134 \param o_dt old array dtype
3135 \param elem_dt element dtype
3136 \param astdim ast of dimension to be excluded
3137 \param after std after which code is produced to create the bounds
3138 descriptor (if dim is not a constant)
3139 */
3140 DTYPE
reduc_rank_dtype(DTYPE o_dt,DTYPE elem_dt,int astdim,int after)3141 reduc_rank_dtype(DTYPE o_dt, DTYPE elem_dt, int astdim, int after)
3142 {
3143 DTYPE dtype;
3144 int numdim;
3145 int o_numdim;
3146 int dim;
3147 ADSC *o_ad;
3148 ADSC *ad;
3149 int i, j;
3150
3151 o_ad = AD_DPTR(o_dt);
3152 o_numdim = AD_NUMDIM(o_ad);
3153 numdim = o_numdim - 1;
3154 if (numdim <= 0)
3155 return DTY(o_dt + 1);
3156
3157 dtype = get_type(3, TY_ARRAY, elem_dt);
3158 DTY(dtype + 2) = aux.arrdsc_avl;
3159 aux.arrdsc_avl += (_FP + 1) + (_VP * numdim);
3160 NEED(aux.arrdsc_avl, aux.arrdsc_base, int, aux.arrdsc_size,
3161 aux.arrdsc_avl + 240);
3162 o_ad = AD_DPTR(o_dt); /* recreate pointer after possible realloc */
3163 ad = AD_DPTR(dtype);
3164 if (A_ALIASG(astdim) == 0) {
3165 error(422, 3, gbl.lineno, NULL, NULL);
3166 dim = 1;
3167 /* TBD insert code after 'after' to compute bound excluding dim
3168 at run-time */
3169 } else {
3170 /* dim is a constant */
3171
3172 dim = CONVAL2G(A_SPTRG(A_ALIASG(astdim)));
3173 if (dim < 1 || dim > o_numdim) {
3174 error(423, 3, gbl.lineno, NULL, NULL);
3175 dim = 1;
3176 }
3177 }
3178 ad = AD_DPTR(dtype);
3179 BZERO(ad, int, (_FP + 1) + _VP * numdim);
3180 j = 0;
3181 for (i = 0; i < o_numdim; i++)
3182 if (i != dim - 1) {
3183 AD_LWBD(ad, j) = AD_LWBD(o_ad, i);
3184 AD_UPBD(ad, j) = AD_UPBD(o_ad, i);
3185 AD_LWAST(ad, j) = AD_LWAST(o_ad, i);
3186 AD_UPAST(ad, j) = AD_UPAST(o_ad, i);
3187 AD_EXTNTAST(ad, j) = AD_EXTNTAST(o_ad, i);
3188 j++;
3189 }
3190 AD_NUMDIM(ad) = numdim;
3191
3192 return dtype;
3193 }
3194
3195 /** \brief Return number of dimensions of array dtype */
3196 int
rank_of(DTYPE dtype)3197 rank_of(DTYPE dtype)
3198 {
3199
3200 #if DEBUG
3201 assert(dtype != DT_NONE, "rank_of:DT_NONE", dtype, 2);
3202 #endif
3203 if (DTY(dtype) != TY_ARRAY) {
3204 /* must be scalar */;
3205 return 0;
3206 }
3207 if (DTY(dtype + 2) == 0) {
3208 interr("rank_of: no array descriptor", dtype, 2);
3209 return 1;
3210 }
3211 return AD_NUMDIM(AD_DPTR(dtype));
3212 }
3213
3214 /** \brief Return number of dimensions of symbol sptr */
3215 int
rank_of_sym(int sptr)3216 rank_of_sym(int sptr)
3217 {
3218 return rank_of((int)DTYPEG(sptr));
3219 }
3220
3221 /** \brief Return AST representing the lower bound of array dtype for
3222 dimension dim (dim is relative to 0).
3223 */
3224 int
lbound_of(DTYPE dtype,int dim)3225 lbound_of(DTYPE dtype, int dim)
3226 {
3227 int rank;
3228 ADSC *ad;
3229 int ast;
3230
3231 #if DEBUG
3232 assert(DTY(dtype) == TY_ARRAY, "lbound_of: not array", dtype, 0);
3233 assert(DTY(dtype + 2), "lbound_of: no arrdsc", dtype, 0);
3234 #endif
3235
3236 rank = rank_of(dtype);
3237 #if DEBUG
3238 assert(dim >= 0 && dim < rank, "lbound_of: illegal dimension", dim, 0);
3239 #endif
3240
3241 ad = AD_DPTR(dtype);
3242
3243 ast = AD_LWAST(ad, dim);
3244
3245 if (AD_ASSUMSHP(ad) == 1) {
3246 int lwb1;
3247 lwb1 = AD_LWBD(ad, dim);
3248 if (A_TYPEG(lwb1) == A_CNST)
3249 ast = lwb1;
3250 }
3251 if (ast == 0)
3252 ast = astb.bnd.one;
3253 return ast;
3254 }
3255
3256 /** \brief Return AST representing the lower bound of array symbol for
3257 dimension dim (dim is relative to 0).
3258 */
3259 int
lbound_of_sym(int sptr,int dim)3260 lbound_of_sym(int sptr, int dim)
3261 {
3262 return lbound_of((int)DTYPEG(sptr), dim);
3263 }
3264
3265 /** \brief Return AST representing the upper bound of array dtype for
3266 dimension dim (dim is relative to 0).
3267 */
3268 int
ubound_of(DTYPE dtype,int dim)3269 ubound_of(DTYPE dtype, int dim)
3270 {
3271 int rank;
3272 ADSC *ad;
3273 int ast;
3274
3275 #if DEBUG
3276 assert(DTY(dtype) == TY_ARRAY, "ubound_of: not array", dtype, 0);
3277 assert(DTY(dtype + 2), "ubound_of: no arrdsc", dtype, 0);
3278 #endif
3279
3280 rank = rank_of(dtype);
3281 #if DEBUG
3282 assert(dim >= 0 && dim < rank, "ubound_of: illegal dimension", dim, 0);
3283 #endif
3284
3285 ad = AD_DPTR(dtype);
3286
3287 ast = AD_UPAST(ad, dim);
3288 if (ast == 0) {
3289 interr("ubound_of: *dim", dtype, 3);
3290 ast = astb.bnd.one;
3291 }
3292 return ast;
3293 }
3294
3295 /** \brief Return AST representing the upper bound of array symbol for
3296 dimension dim (dim is relative to 0).
3297 */
3298 int
ubound_of_sym(int sptr,int dim)3299 ubound_of_sym(int sptr, int dim)
3300 {
3301 return ubound_of((int)DTYPEG(sptr), dim);
3302 }
3303
3304 /** \brief Return true if the data types for two arrays are conformable
3305 (have the same shape). Shape is defined to be the rank and
3306 the extents of each dimension.
3307 */
3308 LOGICAL
conformable(DTYPE d1,DTYPE d2)3309 conformable(DTYPE d1, DTYPE d2)
3310 {
3311 int ndim;
3312 int i;
3313 int bnd;
3314 INT lb1, lb2;
3315 INT ub1, ub2;
3316 ADSC *ad1, *ad2;
3317
3318 ad1 = AD_DPTR(d1);
3319 ad2 = AD_DPTR(d2);
3320 ndim = AD_NUMDIM(ad1);
3321 if (ndim != AD_NUMDIM(ad2))
3322 return FALSE;
3323
3324 for (i = 0; i < ndim; i++) {
3325 bnd = AD_LWAST(ad1, i);
3326 if (bnd) {
3327 bnd = A_ALIASG(bnd);
3328 if (bnd == 0)
3329 continue; /* nonconstant bound => skip this dimension */
3330 lb1 = get_int_cval(A_SPTRG(bnd));
3331 } else {
3332 lb1 = 1; /* no lower bound => 1 */
3333 }
3334
3335 bnd = AD_UPAST(ad1, i);
3336 if (bnd) {
3337 bnd = A_ALIASG(bnd);
3338 if (bnd == 0)
3339 continue; /* nonconstant bound => skip this dimension */
3340 ub1 = get_int_cval(A_SPTRG(bnd));
3341 } else {
3342 continue; /* no upper bound => skip this dimension */
3343 }
3344
3345 bnd = AD_LWAST(ad2, i);
3346 if (bnd) {
3347 bnd = A_ALIASG(bnd);
3348 if (bnd == 0)
3349 continue; /* nonconstant bound => skip this dimension */
3350 lb2 = get_int_cval(A_SPTRG(bnd));
3351 } else {
3352 lb2 = 1; /* no lower bound => 1 */
3353 }
3354
3355 bnd = AD_UPAST(ad2, i);
3356 if (bnd) {
3357 bnd = A_ALIASG(bnd);
3358 if (bnd == 0)
3359 continue; /* nonconstant bound => skip this dimension */
3360 ub2 = get_int_cval(A_SPTRG(bnd));
3361 } else {
3362 continue; /* no upper bound => skip this dimension */
3363 }
3364
3365 /* upper and lower bounds in this dimension are constants */
3366
3367 if ((ub1 - lb1) != (ub2 - lb2))
3368 return FALSE;
3369 }
3370
3371 return TRUE;
3372 }
3373
3374 /* Define mapping from compiler ty entries to type values used by the library */
3375
3376 typedef enum {
3377 __NONE = 0, /* type of an absent optional argument */
3378 __SHORT = 1, /* C signed short */
3379 __USHORT = 2, /* C unsigned short */
3380 __INT = 3, /* C signed int */
3381 __UINT = 4, /* C unsigned int */
3382 __LONG = 5, /* C signed long int */
3383 __ULONG = 6, /* C unsigned long int */
3384 __FLOAT = 7, /* C float */
3385 __DOUBLE = 8, /* C double */
3386 __CPLX = 9, /* F complex*8 (2x real*4) */
3387 __DCPLX = 10, /* F complex*16 (2x real*8) */
3388 __CHAR = 11, /* C signed char */
3389 __UCHAR = 12, /* C unsigned char */
3390 __LONGDOUBLE = 13, /* C long double */
3391 __STR = 14, /* F character */
3392 __LONGLONG = 15, /* C long long */
3393 __ULONGLONG = 16, /* C unsigned long long */
3394 __BLOG = 17, /* F logical*1 */
3395 __SLOG = 18, /* F logical*2 */
3396 __LOG = 19, /* F logical*4 */
3397 __LOG8 = 20, /* F logical*8 */
3398 __WORD = 21, /* F typeless */
3399 __DWORD = 22, /* F double typeless */
3400 __NCHAR = 23, /* F ncharacter - kanji */
3401
3402 /* new fortran data types */
3403 __INT2 = 24, /* F integer*2 */
3404 __INT4 = 25, /* F integer*4, integer */
3405 __INT8 = 26, /* F integer*8 */
3406 __REAL2 = 45, /* F real*2, half */
3407 __REAL4 = 27, /* F real*4, real */
3408 __REAL8 = 28, /* F real*8, double precision */
3409 __REAL16 = 29, /* F real*16 */
3410 __CPLX32 = 30, /* F complex*32 (2x real*16) */
3411 __WORD16 = 31, /* F quad typeless */
3412 __INT1 = 32, /* F byte (integer*1) */
3413 __DERIVED = 33, /* F90 derived type */
3414
3415 /* run-time descriptor types */
3416
3417 __PROC = 34, /* processors descriptor */
3418 __DESC = 35, /* template/array/section descriptor */
3419 __SKED = 36, /* communication schedule */
3420
3421 /* more new fortran data types */
3422
3423 __M128 = 37, /* 128-bit type */
3424 __M256 = 38, /* 256-bit type */
3425 __INT16 = 39, /* F integer(16) */
3426 __LOG16 = 40, /* F logical(16) */
3427 __QREAL16 = 41, /* F real(16) */
3428 __QCPLX32 = 42, /* F complex(32) */
3429 __POLY = 43, /* F polymorphic variable */
3430 __PROCPTR = 44, /* F procedure pointer descriptor */
3431
3432 /* number of data types */
3433 __NTYPES = 46 /* MUST BE LAST */
3434
3435 } _pghpf_type;
3436
3437 int ty_to_lib[] = {
3438 __NONE, /* TY_NONE */
3439 __WORD, /* TY_WORD */
3440 __DWORD, /* TY_DWORD */
3441 __NONE, /* TY_HOLL */
3442 __INT1, /* TY_BINT */
3443 __INT2, /* TY_SINT */
3444 __INT4, /* TY_INT */
3445 __INT8, /* TY_INT8 */
3446 __REAL2, /* TY_HALF */
3447 __REAL4, /* TY_REAL */
3448 __REAL8, /* TY_DBLE */
3449 __REAL16, /* TY_QUAD */
3450 __CPLX, /* TY_HCMPLX */
3451 __CPLX, /* TY_CMPLX */
3452 __DCPLX, /* TY_DCMPLX */
3453 __CPLX32, /* TY_QCMPLX */
3454 __BLOG, /* TY_BLOG */
3455 __SLOG, /* TY_SLOG */
3456 __LOG, /* TY_LOG */
3457 __LOG8, /* TY_LOG8 */
3458 __STR, /* TY_CHAR */
3459 __NCHAR, /* TY_NCHAR */
3460 __NONE, /* TY_PTR */
3461 __NONE, /* TY_ARRAY */
3462 __NONE, /* TY_STRUCT */
3463 __NONE, /* TY_UNION */
3464 __DERIVED, /* TY_DERIVED */
3465 __NONE, /* TY_NUMERIC */
3466 __NONE, /* TY_ANY */
3467 __NONE, /* TY_PROC */
3468 __M128, /* TY_128 */
3469 __M256, /* TY_256 */
3470 __NONE, /* TY_512 */
3471 __INT16, /* TY_INT128 */
3472 __LOG16, /* TY_LOG128 */
3473 __QREAL16, /* TY_FLOAT128 */
3474 __QCPLX32, /* TY_CMPLX128 */
3475 };
3476
3477 static int ty_to_base_ty[] = {
3478 TY_NONE, /* TY_NONE */
3479 TY_WORD, /* TY_WORD */
3480 TY_DWORD, /* TY_DWORD */
3481 TY_HOLL, /* TY_HOLL */
3482 TY_INT, /* TY_BINT */
3483 TY_INT, /* TY_SINT */
3484 TY_INT, /* TY_INT */
3485 TY_INT, /* TY_INT8 */
3486 TY_REAL, /* TY_HALF */
3487 TY_REAL, /* TY_REAL */
3488 TY_REAL, /* TY_DBLE */
3489 TY_REAL, /* TY_QUAD */
3490 TY_CMPLX, /* TY_HCMPLX */
3491 TY_CMPLX, /* TY_CMPLX */
3492 TY_CMPLX, /* TY_DCMPLX */
3493 TY_CMPLX, /* TY_QCMPLX */
3494 TY_LOG, /* TY_BLOG */
3495 TY_LOG, /* TY_SLOG */
3496 TY_LOG, /* TY_LOG */
3497 TY_LOG, /* TY_LOG8 */
3498 TY_CHAR, /* TY_CHAR */
3499 TY_CHAR, /* TY_NCHAR */
3500 TY_PTR, /* TY_PTR */
3501 TY_ARRAY, /* TY_ARRAY */
3502 TY_STRUCT, /* TY_STRUCT */
3503 TY_UNION, /* TY_UNION */
3504 TY_DERIVED, /* TY_DERIVED */
3505 TY_NUMERIC, /* TY_NUMERIC */
3506 TY_ANY, /* TY_ANY */
3507 TY_PROC, /* TY_PROC */
3508 TY_128, /* TY_128 */
3509 TY_256, /* TY_256 */
3510 TY_512, /* TY_512 */
3511 TY_INT, /* TY_INT128 */
3512 TY_LOG, /* TY_LOG128 */
3513 TY_REAL, /* TY_FLOAT128 */
3514 TY_CMPLX, /* TY_CMPLX128 */
3515 };
3516
3517 #if TY_MAX != 36
3518 #error \
3519 "Need to edit dtypeutl.c to add new TY_... data types to ty_to_lib and ty_to_base_ty"
3520 #endif
3521
3522 /** \brief Map compiler's DT_ values to the values expected by the run-time. */
3523 int
dtype_to_arg(DTYPE dtype)3524 dtype_to_arg(DTYPE dtype)
3525 {
3526 return ty_to_lib[DTY(dtype)];
3527 }
3528
3529 /** \brief For intrinsic types, return same value as the KIND intrinsic */
3530 int
kind_of(DTYPE d1)3531 kind_of(DTYPE d1)
3532 {
3533 int ty1;
3534 int k;
3535
3536 ty1 = DTY(d1);
3537 if (ty1 < 0 || ty1 >= TY_MAX)
3538 return 0;
3539 if (!TY_ISBASIC(ty1))
3540 return 0;
3541 switch (ty1) {
3542 case TY_CHAR:
3543 k = 1;
3544 break;
3545 case TY_NCHAR:
3546 k = 2;
3547 break;
3548 case TY_CMPLX:
3549 case TY_DCMPLX:
3550 case TY_QCMPLX:
3551 k = size_of(d1) / 2;
3552 break;
3553 default:
3554 k = size_of(d1);
3555 break;
3556 }
3557 return k;
3558 }
3559
3560 LOGICAL
same_type_different_kind(DTYPE d1,DTYPE d2)3561 same_type_different_kind(DTYPE d1, DTYPE d2)
3562 {
3563 int ty1, ty2;
3564 ty1 = DTY(d1);
3565 ty2 = DTY(d2);
3566 if (ty1 < 0 || ty2 < 0 || ty1 >= TY_MAX || ty2 >= TY_MAX)
3567 return FALSE;
3568 if (ty_to_base_ty[ty1] == ty_to_base_ty[ty2])
3569 return TRUE;
3570 return FALSE;
3571 } /* same_type_different_kind */
3572
3573 LOGICAL
different_type_same_kind(DTYPE d1,DTYPE d2)3574 different_type_same_kind(DTYPE d1, DTYPE d2)
3575 {
3576 int ty1, ty2;
3577 int k1, k2;
3578 ty1 = DTY(d1);
3579 ty2 = DTY(d2);
3580 if (ty1 < 0 || ty2 < 0 || ty1 >= TY_MAX || ty2 >= TY_MAX)
3581 return FALSE;
3582 /* at least the TYs must be different */
3583 if (ty1 == ty2)
3584 return FALSE;
3585 k1 = kind_of(d1);
3586 k2 = kind_of(d2);
3587 if (k1 != k2)
3588 return FALSE;
3589 return TRUE;
3590 } /* different_type_same_kind */
3591
3592 #define RW_FD(b, s, n) \
3593 { \
3594 nw = (*p_rw)((char *)b, sizeof(s), n, fd); \
3595 if (nw != (n)) \
3596 error(10, 40, 0, "(state file)", CNULL); \
3597 }
3598
3599 void
rw_dtype_state(int (* p_rw)(void *,size_t,size_t,FILE *),FILE * fd)3600 rw_dtype_state(int (*p_rw)(void *, size_t, size_t, FILE *), FILE *fd)
3601 {
3602 int nw;
3603
3604 RW_FD(&stb.dt.stg_avail, stb.dt.stg_avail, 1);
3605 RW_FD(&stb.dt.stg_cleared, stb.dt.stg_cleared, 1);
3606 RW_FD(stb.dt.stg_base, ISZ_T, stb.dt.stg_avail);
3607 RW_FD(chartab, chartab, 1);
3608 RW_FD(&chartabavail, chartabavail, 1);
3609 RW_FD(chartabbase, struct chartab, chartabavail);
3610 }
3611
3612 /* Predicate: is dtype is a derived type with type bound procedures? */
3613 static LOGICAL
is_tbp_component(int sptr,struct visit_list ** visited)3614 is_tbp_component(int sptr, struct visit_list **visited)
3615 {
3616 return sptr > NOSYM &&
3617 (is_tbp(sptr) ||
3618 (/* PARENTG(sptr) && */
3619 search_type_members(DTYPEG(sptr), is_tbp_component, visited)));
3620 }
3621
3622 LOGICAL
has_tbp(DTYPE dtype)3623 has_tbp(DTYPE dtype)
3624 {
3625 return search_type_members_wrapped(dtype, is_tbp_component);
3626 }
3627
3628 /* Predicate: is dtype is a derived type with type bound/final procedures? */
3629 static LOGICAL
is_tbp_or_final_component(int sptr,struct visit_list ** visited)3630 is_tbp_or_final_component(int sptr, struct visit_list **visited)
3631 {
3632 return sptr > NOSYM &&
3633 (is_tbp_or_final(sptr) ||
3634 (/* PARENTG(sptr) && */
3635 search_type_members(DTYPEG(sptr), is_tbp_or_final_component,
3636 visited)));
3637 }
3638
3639 LOGICAL
has_tbp_or_final(DTYPE dtype)3640 has_tbp_or_final(DTYPE dtype)
3641 {
3642 return search_type_members_wrapped(dtype, is_tbp_or_final_component);
3643 }
3644
3645 int
chk_kind_parm_set_expr(int ast,DTYPE dtype)3646 chk_kind_parm_set_expr(int ast, DTYPE dtype)
3647 {
3648 int sptr, rslt, newast1, newast2, i, val;
3649
3650 switch (A_TYPEG(ast)) {
3651 case A_INTR:
3652 switch (A_OPTYPEG(ast)) {
3653 case I_INT1:
3654 case I_INT2:
3655 case I_INT4:
3656 case I_INT8:
3657 case I_INT:
3658 i = A_ARGSG(ast);
3659 newast1 = chk_kind_parm_set_expr(ARGT_ARG(i, 0), dtype);
3660 return newast1 < 0 ? -1 : newast1;
3661 }
3662 break;
3663 case A_CNST:
3664 break;
3665 case A_ID:
3666 if (dtype == 0)
3667 break;
3668 sptr = A_SPTRG(ast);
3669 if (get_kind_set_parm(sptr, dtype, &val)) {
3670 return mk_cval1(val, DT_INT);
3671 }
3672 val = 0;
3673 i = get_len_set_parm(sptr, dtype, &val);
3674 if (i || val) {
3675 if (val && A_TYPEG(val) == A_ID) {
3676 return ast;
3677 } else if (val) {
3678 return chk_kind_parm_set_expr(val, dtype);
3679 } else {
3680 return mk_cval1(i, DT_INT);
3681 }
3682 } else {
3683 return -1;
3684 }
3685 break;
3686 case A_UNOP:
3687 newast1 = chk_kind_parm_set_expr(A_LOPG(ast), dtype);
3688 if (newast1 < 0)
3689 return -1;
3690 A_LOPP(ast, newast1);
3691 break;
3692 case A_BINOP:
3693 newast1 = chk_kind_parm_set_expr(A_LOPG(ast), dtype);
3694 if (newast1 < 0)
3695 return -1;
3696 newast2 = chk_kind_parm_set_expr(A_ROPG(ast), dtype);
3697 if (newast2 < 0)
3698 return -1;
3699 A_LOPP(ast, newast1);
3700 A_ROPP(ast, newast2);
3701
3702 if (A_TYPEG(newast1) == A_CNST && A_TYPEG(newast2) == A_CNST) {
3703 i = const_fold(A_OPTYPEG(ast), CONVAL2G(A_SPTRG(newast1)),
3704 CONVAL2G(A_SPTRG(newast2)), A_DTYPEG(ast));
3705 ast = mk_cval1(i, DT_INT);
3706 }
3707 break;
3708 default:
3709 return -1;
3710 }
3711
3712 return ast;
3713 }
3714
3715 static LOGICAL
get_kind_set_parm(int sptr,DTYPE dtype,int * val)3716 get_kind_set_parm(int sptr, DTYPE dtype, int *val)
3717 {
3718 int mem;
3719
3720 if (DTY(dtype) != TY_DERIVED)
3721 return FALSE;
3722
3723 for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
3724 if (PARENTG(mem)) {
3725 if (get_kind_set_parm(sptr, DTYPEG(mem), val)) {
3726 return TRUE;
3727 }
3728 }
3729 if (!LENPARMG(mem) && SETKINDG(mem) && !USEKINDG(mem) && KINDG(mem) &&
3730 strcmp(SYMNAME(mem), SYMNAME(sptr)) == 0) {
3731 *val = KINDG(mem);
3732 return TRUE;
3733 }
3734 }
3735
3736 return FALSE;
3737 }
3738
3739 static int
get_len_set_parm(int sptr,DTYPE dtype,int * val)3740 get_len_set_parm(int sptr, DTYPE dtype, int *val)
3741 {
3742 int rslt, tag, parent, mem;
3743
3744 if (DTY(dtype) != TY_DERIVED)
3745 return 0;
3746
3747 for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
3748 if (PARENTG(mem)) {
3749 rslt = get_len_set_parm(sptr, DTYPEG(mem), val);
3750 if (rslt)
3751 return rslt;
3752 }
3753 if (LENPARMG(mem) && SETKINDG(mem) && !USEKINDG(mem) && KINDG(mem) &&
3754 strcmp(SYMNAME(mem), SYMNAME(sptr)) == 0) {
3755 *val = LENG(mem);
3756 return KINDG(mem);
3757 }
3758 }
3759
3760 return 0;
3761 }
3762
3763 /** \brief Compute size and alignment of struct and union types and their
3764 * members.
3765 */
3766 void
chkstruct(DTYPE dtype)3767 chkstruct(DTYPE dtype)
3768 {
3769 int m, m_prev = NOSYM, m_next = NOSYM;
3770 ISZ_T symlk;
3771
3772 if (DTY(dtype) == TY_STRUCT || DTY(dtype) == TY_DERIVED) {
3773 int offset = 0; /* byte offset from beginning of struct */
3774 int maxa = 0; /* maximum alignment req'd by any member */
3775 int distmem = 0; /* any distributed members? */
3776 int ptrmem = 0; /* any pointer members? */
3777
3778 for (m = DTY(dtype + 1); m != NOSYM; m_prev = m, m = symlk) {
3779 int oldoffset, a;
3780 symlk = SYMLKG(m);
3781 m_next = symlk;
3782 if (DTYPEG(m) == DT_NONE) {
3783 continue; /* Occurs w/ empty typedef */
3784 }
3785 if (is_tbp_or_final(m)) {
3786 /* skip tbp */
3787 continue;
3788 }
3789 a = alignment_of_var(m);
3790 offset = ALIGN(offset, a);
3791 oldoffset = offset;
3792 ADDRESSP(m, offset);
3793 if (DTY(DTYPEG(m)) == TY_ARRAY
3794 && !MIDNUMG(m) && !ADJARRG(m) && !POINTERG(m)
3795 && !RUNTIMEG(m)) {
3796 if (extent_of(DTYPEG(m)) != 0)
3797 offset += size_of_var(m);
3798 } else
3799 offset += size_of_var(m);
3800 /* if this is a pointer member, and the next member
3801 * is the actual pointer, let the pointer/offset/descriptor
3802 * overlap */
3803 if ((POINTERG(m) || ALLOCG(m) || ADJARRG(m) || RUNTIMEG(m)) &&
3804 MIDNUMG(m) == symlk)
3805 offset = oldoffset;
3806 if (POINTERG(m))
3807 ptrmem = 1;
3808 if (a > maxa)
3809 maxa = a;
3810 PSMEMP(m, m);
3811 if (ALIGNG(m) || DISTG(m)) {
3812 distmem = 1;
3813 } else {
3814 DTYPE d = DTYPEG(m);
3815 if (DTY(d) == TY_DERIVED) {
3816 int tag = DTY(d + 3);
3817 if (tag) {
3818 if (DISTMEMG(tag))
3819 distmem = 1;
3820 if (POINTERG(tag))
3821 ptrmem = 1;
3822 }
3823 }
3824 }
3825 }
3826 /* compute final size and alignment of struct: */
3827
3828 DTY(dtype + 2) = ALIGN(offset, maxa);
3829 if (distmem && DTY(dtype + 3)) {
3830 DISTMEMP(DTY(dtype + 3), 1);
3831 }
3832 DTY(dtype + 4) = maxa;
3833 if (ptrmem && DTY(dtype + 3)) {
3834 POINTERP(DTY(dtype + 3), 1);
3835 }
3836 } else {
3837 /*
3838 * Size and alignment of a union are the maximum of the sizes and
3839 * alignments of its members:
3840 */
3841 int maxa = 0;
3842 ISZ_T size = 1;
3843 assert(DTY(dtype) == TY_UNION && DTY(dtype + 1), "chkstruct:bad dt", dtype,
3844 3);
3845 for (m = DTY(dtype + 1); m != NOSYM; m_prev = m, m = symlk) {
3846 symlk = SYMLKG(m);
3847 m_next = symlk;
3848 ISZ_T s = size_of_var(m);
3849 int a = alignment_of_var(m);
3850 if (s > size)
3851 size = s;
3852 if (a > maxa)
3853 maxa = a;
3854 }
3855 DTY(dtype + 2) = ALIGN(size, maxa);
3856 DTY(dtype + 4) = maxa;
3857 }
3858 }
3859
3860 /* Return the dtype if this derived type was defined in iso_c_bind_decl
3861 Return 0 otherwise.
3862 Differentiate c_ptr and c_funptr from possible user defined
3863 derived types.
3864 NOTE:
3865 We still need to mark these symbols as compiler generated to
3866 that the user could define his own iso_c_bind_decl that would
3867 not conflict with this
3868 */
3869
3870 DTYPE
is_iso_cptr(DTYPE d_dtype)3871 is_iso_cptr(DTYPE d_dtype)
3872 {
3873 return get_iso_derivedtype(d_dtype);
3874 }
3875
3876 LOGICAL
is_iso_c_ptr(DTYPE d_dtype)3877 is_iso_c_ptr(DTYPE d_dtype)
3878 {
3879 DTYPE dtype = get_iso_derivedtype(d_dtype);
3880 return dtype && ic_strcmp(SYMNAME(DTY(dtype + 3)), "c_ptr") == 0;
3881 }
3882
3883 LOGICAL
is_iso_c_funptr(DTYPE d_dtype)3884 is_iso_c_funptr(DTYPE d_dtype)
3885 {
3886 DTYPE dtype = get_iso_derivedtype(d_dtype);
3887 return dtype && ic_strcmp(SYMNAME(DTY(dtype + 3)), "c_funptr") == 0;
3888 }
3889
3890 static DTYPE
get_iso_derivedtype(DTYPE d_dtype)3891 get_iso_derivedtype(DTYPE d_dtype)
3892 {
3893 int check_mod;
3894 DTYPE dtype = d_dtype;
3895 int mod = lookupsymbol("iso_c_binding");
3896
3897 if (mod == 0)
3898 return 0;
3899
3900 /* yes to array of c_ptrs */
3901 if (DTY(dtype) == TY_ARRAY)
3902 dtype = DTY(dtype + 1);
3903
3904 if (DTY(dtype) == TY_DERIVED && DTY(dtype + 3))
3905 check_mod = DTY(dtype + 3); /* tag */
3906 else
3907 check_mod = 0;
3908
3909 if (gbl.internal > 1) {
3910 /* If a contained subprogram has USEd iso_c_binding, a temporary,
3911 * incomplete symbol table entry may have been generated. Find the
3912 * correct (complete) one.
3913 */
3914 for (; mod && STYPEG(mod) != ST_MODULE; mod = HASHLKG(mod)) {
3915 if (strcmp(SYMNAME(mod), "iso_c_binding") == 0 &&
3916 STYPEG(mod) == ST_MODULE) {
3917 break;
3918 }
3919 }
3920 }
3921
3922 if (check_mod <= 0 || ENCLFUNCG(check_mod) <= 0)
3923 return 0;
3924
3925 if (ENCLFUNCG(check_mod) == mod) {
3926 ISOCTYPEP(check_mod, 1);
3927 return dtype;
3928 }
3929
3930 return 0;
3931 }
3932
3933 LOGICAL
is_cuf_c_devptr(DTYPE d_dtype)3934 is_cuf_c_devptr(DTYPE d_dtype)
3935 {
3936 DTYPE dtype = get_cuf_derivedtype(d_dtype);
3937 return dtype && ic_strcmp(SYMNAME(DTY(dtype + 3)), "c_devptr") == 0;
3938 }
3939
3940 static DTYPE
get_cuf_derivedtype(DTYPE d_dtype)3941 get_cuf_derivedtype(DTYPE d_dtype)
3942 {
3943 int check_mod;
3944 DTYPE dtype = d_dtype;
3945 int mod = lookupsymbol("pgi_acc_common");
3946 if (mod == 0 || STYPEG(mod) == ST_UNKNOWN)
3947 mod = lookupsymbol("cudafor");
3948 if (mod == 0 || STYPEG(mod) == ST_UNKNOWN)
3949 mod = lookupsymbol("cudafor_la");
3950 if (mod == 0 || STYPEG(mod) == ST_UNKNOWN)
3951 return 0;
3952
3953 /* yes to array of c_ptrs */
3954 if (DTY(dtype) == TY_ARRAY)
3955 dtype = DTY(dtype + 1);
3956 if (DTY(dtype) == TY_DERIVED && DTY(dtype + 3))
3957 check_mod = DTY(dtype + 3); /* tag */
3958 else
3959 check_mod = 0;
3960 if (check_mod <= 0 || ENCLFUNCG(check_mod) <= 0)
3961 return 0;
3962 if (ENCLFUNCG(check_mod) == mod)
3963 return dtype;
3964 return 0;
3965 }
3966
3967 DTYPE
get_iso_ptrtype(char * name)3968 get_iso_ptrtype(char *name)
3969 {
3970 int s, sptr;
3971 int mod;
3972 int check_mod;
3973
3974 mod = lookupsymbol("iso_c_binding");
3975 if (mod == 0)
3976 return 0;
3977
3978 s = getsymbol(name);
3979 for (sptr = first_hash(s); sptr; sptr = HASHLKG(sptr)) {
3980 if (NMPTRG(sptr) != NMPTRG(s))
3981 continue;
3982 if (STYPEG(sptr) != ST_TYPEDEF)
3983 continue;
3984 check_mod = DTY(DTYPEG(sptr) + 3); /* tag */
3985 if ((check_mod <= 0) || (ENCLFUNCG(check_mod) <= 0))
3986 continue;
3987 if (ENCLFUNCG(check_mod) == mod) {
3988 return DTYPEG(sptr);
3989 }
3990 }
3991 return DT_NONE;
3992 }
3993
3994 DTYPE
get_iso_c_ptr(void)3995 get_iso_c_ptr(void)
3996 {
3997 return get_iso_ptrtype("c_ptr");
3998 }
3999
4000 /* FIXME: create common utility that can be shared with sem_strcmp */
4001 /** \brief Compare \a str and \a pattern like strcmp() but ignoring the case of
4002 str.
4003 \a pattern is all lower case.
4004 */
4005 static int
ic_strcmp(char * str,char * pattern)4006 ic_strcmp(char *str, char *pattern)
4007 {
4008 char *p1, *p2;
4009 int ch;
4010
4011 p1 = str;
4012 p2 = pattern;
4013 do {
4014 ch = *p1;
4015 if (ch >= 'A' && ch <= 'Z')
4016 ch += ('a' - 'A'); /* to lower case */
4017 if (ch != *p2)
4018 return (ch - *p2);
4019 if (ch == '\0')
4020 return 0;
4021 p1++;
4022 p2++;
4023 } while (1);
4024 }
4025
4026 LOGICAL
is_array_dtype(DTYPE dtype)4027 is_array_dtype(DTYPE dtype)
4028 {
4029 return dtype > DT_NONE && get_ty_kind(dtype) == TY_ARRAY;
4030 }
4031
4032 DTYPE
array_element_dtype(DTYPE dtype)4033 array_element_dtype(DTYPE dtype)
4034 {
4035 return is_array_dtype(dtype) ? DTY(dtype + 1) : DT_NONE;
4036 }
4037
4038 LOGICAL
is_dtype_runtime_length_char(DTYPE dtype)4039 is_dtype_runtime_length_char(DTYPE dtype)
4040 {
4041 if (is_array_dtype(dtype))
4042 dtype = array_element_dtype(dtype);
4043 return dtype > DT_NONE &&
4044 DT_ISCHAR(dtype) &&
4045 string_length(dtype) == 0;
4046 }
4047
4048 LOGICAL
is_dtype_unlimited_polymorphic(DTYPE dtype)4049 is_dtype_unlimited_polymorphic(DTYPE dtype)
4050 {
4051 if (is_array_dtype(dtype))
4052 dtype = array_element_dtype(dtype);
4053 return dtype > DT_NONE &&
4054 DTY(dtype) == TY_DERIVED &&
4055 UNLPOLYG(DTY(dtype + 3 /*tag*/));
4056 }
4057
4058 /** \brief Test if a data type index corresponds with a procedure pointer
4059 * \param dtype data type index to check
4060 */
4061 LOGICAL
is_procedure_ptr_dtype(DTYPE dtype)4062 is_procedure_ptr_dtype(DTYPE dtype)
4063 {
4064 return ((dtype > DT_NONE) && (get_ty_kind(dtype) == TY_PTR) &&
4065 is_procedure_dtype(DTY(dtype + 1)));
4066 }
4067
4068 /** \brief Get return type from a procedure pointer dtype
4069 * \param dtype data type index for procedure pointer
4070 */
4071 DTYPE
proc_ptr_result_dtype(DTYPE dtype)4072 proc_ptr_result_dtype(DTYPE dtype)
4073 {
4074 return is_procedure_ptr_dtype(dtype) ? DTY(DTY(dtype + 1) + 1) : DT_NONE;
4075 }
4076
4077 /** \brief Set return type for a procedure pointer
4078 * \param ptr_dtype data type index for the procedure pointer
4079 * \param result_dtype data type index for the return type
4080 */
4081 void
set_proc_ptr_result_dtype(DTYPE ptr_dtype,DTYPE result_dtype)4082 set_proc_ptr_result_dtype(DTYPE ptr_dtype, DTYPE result_dtype)
4083 {
4084 assert(is_procedure_ptr_dtype(ptr_dtype), "type is not a procedure pointer",
4085 ptr_dtype, 3);
4086
4087 set_proc_result_dtype(DTY(ptr_dtype + 1), result_dtype);
4088 }
4089
4090 /** \brief Set paramter count for a procedure pointer type
4091 * \param ptr_dtype data type index for the procedure pointer
4092 * \param param_count paramter count to set
4093 */
4094 void
set_proc_ptr_param_count_dtype(DTYPE ptr_dtype,int param_count)4095 set_proc_ptr_param_count_dtype(DTYPE ptr_dtype, int param_count)
4096 {
4097 assert(is_procedure_ptr_dtype(ptr_dtype), "type is not a procedure pointer",
4098 ptr_dtype, 3);
4099
4100 set_proc_param_count_dtype(DTY(ptr_dtype + 1), param_count);
4101 }
4102
4103 /** \brief Test if a data type index corresponds with a procedure
4104 * \param dtype data type index to check
4105 */
4106 LOGICAL
is_procedure_dtype(DTYPE dtype)4107 is_procedure_dtype(DTYPE dtype)
4108 {
4109 return dtype > DT_NONE && get_ty_kind(dtype) == TY_PROC;
4110 }
4111
4112 /** \brief Set return type for a procedure type
4113 * \param proc_dtype data type index for the procedure type
4114 * \param result_dtype data type index for the return type
4115 */
4116 void
set_proc_result_dtype(DTYPE proc_dtype,DTYPE result_dtype)4117 set_proc_result_dtype(DTYPE proc_dtype, DTYPE result_dtype)
4118 {
4119 assert(is_procedure_dtype(proc_dtype), "type is not a procedure", proc_dtype,
4120 3);
4121
4122 DTY(proc_dtype + 1) = result_dtype;
4123 }
4124
4125 /** \brief Set paramter count for a procedure type
4126 * \param proc_dtype data type index for the procedure type
4127 * \param param_count paramter count to set
4128 */
4129 void
set_proc_param_count_dtype(DTYPE proc_dtype,int param_count)4130 set_proc_param_count_dtype(DTYPE proc_dtype, int param_count)
4131 {
4132 assert(is_procedure_dtype(proc_dtype), "type is not a procedure", proc_dtype,
4133 3);
4134
4135 DTY(proc_dtype + 3) = param_count;
4136 }
4137
4138 static int
get_struct_dtype_field(DTYPE dtype,int offset,int default_result)4139 get_struct_dtype_field(DTYPE dtype, int offset, int default_result)
4140 {
4141 if (is_array_dtype(dtype))
4142 dtype = array_element_dtype(dtype);
4143 if (dtype > DT_NONE) {
4144 switch (get_ty_kind(dtype)) {
4145 case TY_STRUCT:
4146 case TY_UNION:
4147 case TY_DERIVED:
4148 return DTY(dtype + offset);
4149 default:
4150 break;
4151 }
4152 }
4153 return default_result;
4154 }
4155
4156 SPTR
get_struct_tag_sptr(DTYPE dtype)4157 get_struct_tag_sptr(DTYPE dtype)
4158 {
4159 return get_struct_dtype_field(dtype, 3 /* tag */, 0);
4160 }
4161
4162 SPTR
get_struct_members(DTYPE dtype)4163 get_struct_members(DTYPE dtype)
4164 {
4165 return get_struct_dtype_field(dtype, 1 /* members */, 0);
4166 }
4167
4168 int
get_struct_initialization_tree(DTYPE dtype)4169 get_struct_initialization_tree(DTYPE dtype)
4170 {
4171 return get_struct_dtype_field(dtype, 5 /* i.c.t. */, 0);
4172 }
4173
4174 LOGICAL
is_unresolved_parameterized_dtype(DTYPE dtype)4175 is_unresolved_parameterized_dtype(DTYPE dtype)
4176 {
4177 SPTR tag;
4178 if (is_array_dtype(dtype))
4179 dtype = array_element_dtype(dtype);
4180 tag = get_struct_tag_sptr(dtype);
4181 if (tag > NOSYM) {
4182 SPTR member;
4183 if (BASETYPEG(tag) > DT_NONE)
4184 return FALSE; /* the BASETYPE here means the original p.d.t. */
4185 for (member = get_struct_members(dtype);
4186 member > NOSYM; member = SYMLKG(member)) {
4187 if (!USEKINDG(member) && !SETKINDG(member) && KINDG(member) != 0)
4188 return TRUE;
4189 }
4190 }
4191 return FALSE;
4192 }
4193
4194 /* Correct TYPE IS(CHARACTER(LEN=*)) to TYPE IS(CHARACTER(LEN=:))
4195 * so that semant3 can create a pointer or allocatable for construct
4196 * association.
4197 */
4198 DTYPE
change_assumed_char_to_deferred(DTYPE dtype)4199 change_assumed_char_to_deferred(DTYPE dtype)
4200 {
4201 switch (dtype) {
4202 case DT_ASSCHAR:
4203 return DT_DEFERCHAR;
4204 case DT_ASSNCHAR:
4205 return DT_DEFERNCHAR;
4206 default:
4207 return dtype;
4208 }
4209 }
4210