1 /*
2 * Copyright (c) 1993-2019, NVIDIA CORPORATION. All rights reserved.
3 *
4 * Licensed under the Apache License, Version 2.0 (the "License");
5 * you may not use this file except in compliance with the License.
6 * You may obtain a copy of the License at
7 *
8 * http://www.apache.org/licenses/LICENSE-2.0
9 *
10 * Unless required by applicable law or agreed to in writing, software
11 * distributed under the License is distributed on an "AS IS" BASIS,
12 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13 * See the License for the specific language governing permissions and
14 * limitations under the License.
15 *
16 */
17
18 /** \file
19 * \brief data type utility functions.
20 */
21
22 #include "dtypeutl.h"
23 #include "machar.h"
24 #include "machardf.h"
25 #include "symfun.h"
26
27 static int size_sym = 0;
28 /* The no_data_components() function and its supporting predicate functions
29 * are mirrored from the front end */
30 struct visit_list {
31 DTYPE dtype;
32 bool is_active;
33 struct visit_list *next;
34 };
35
36 static struct visit_list *
visit_list_scan(struct visit_list * list,DTYPE dtype)37 visit_list_scan(struct visit_list *list, DTYPE dtype)
38 {
39 for (; list; list = list->next) {
40 if (list->dtype == dtype)
41 break;
42 }
43 return list;
44 }
45
46 static void
visit_list_push(struct visit_list ** list,DTYPE dtype)47 visit_list_push(struct visit_list **list, DTYPE dtype)
48 {
49 struct visit_list *newlist;
50 NEW(newlist, struct visit_list, 1);
51 newlist->dtype = dtype;
52 newlist->is_active = true;
53 newlist->next = *list;
54 *list = newlist;
55 }
56
57 static void
visit_list_free(struct visit_list ** list)58 visit_list_free(struct visit_list **list)
59 {
60 struct visit_list *p;
61 while ((p = *list)) {
62 *list = p->next;
63 FREE(p);
64 }
65 }
66
67 static bool is_recursive(int sptr, struct visit_list **visited);
68 typedef bool (*stm_predicate_t)(int member_sptr, struct visit_list **visited);
69
70 static TY_KIND
get_ty_kind(DTYPE dtype)71 get_ty_kind(DTYPE dtype)
72 {
73 #ifndef __cplusplus
74 assert(DTyValidRange(dtype), "bad dtype", dtype, ERR_Severe);
75 #endif
76 return DTY(dtype);
77 }
78
79 bool
is_array_dtype(DTYPE dtype)80 is_array_dtype(DTYPE dtype)
81 {
82 return dtype > DT_NONE && get_ty_kind(dtype) == TY_ARRAY;
83 }
84
85 DTYPE
array_element_dtype(DTYPE dtype)86 array_element_dtype(DTYPE dtype)
87 {
88 return is_array_dtype(dtype) ? DTySeqTyElement(dtype) : dtype;
89 }
90
91 static bool
is_container_dtype(DTYPE dtype)92 is_container_dtype(DTYPE dtype)
93 {
94 if (dtype > 0) {
95 if (is_array_dtype(dtype))
96 dtype = array_element_dtype(dtype);
97 switch (DTYG(dtype)) {
98 case TY_STRUCT:
99 case TY_UNION:
100 return true;
101 }
102 }
103 return false;
104 }
105
106 static bool
search_type_members(DTYPE dtype,stm_predicate_t predicate,struct visit_list ** visited)107 search_type_members(DTYPE dtype, stm_predicate_t predicate,
108 struct visit_list **visited)
109 {
110 bool result = false;
111
112 if (is_array_dtype(dtype))
113 dtype = array_element_dtype(dtype);
114 if (is_container_dtype(dtype)) {
115 SPTR member_sptr = DTyAlgTyMember(dtype);
116 struct visit_list *active = visit_list_scan(*visited, dtype);
117
118 if (active) {
119 return predicate == is_recursive && active->is_active;
120 }
121
122 visit_list_push(visited, dtype);
123 active = *visited;
124
125 /* Traverse the members of the derived type. */
126 while (member_sptr > NOSYM && !(result = predicate(member_sptr, visited))) {
127 member_sptr = SYMLKG(member_sptr);
128 }
129
130 /* The scan of this data type is complete. Leave it on the visited
131 * list to forestall another failed pass later.
132 */
133 active->is_active = false;
134 }
135 return result;
136 }
137
138 bool
is_empty_typedef(DTYPE dtype)139 is_empty_typedef(DTYPE dtype)
140 {
141 int mem;
142 if (DTY(dtype) != TY_UNION && DTY(dtype) != TY_STRUCT) {
143 return false;
144 }
145 mem = DTyAlgTyMember(dtype);
146 return (mem <= NOSYM);
147 }
148
149 static bool
is_recursive(int sptr,struct visit_list ** visited)150 is_recursive(int sptr, struct visit_list **visited)
151 {
152 return (sptr > NOSYM) &&
153 search_type_members(DTYPEG(sptr), is_recursive, visited);
154 }
155
156 /** For the derived type in dtype: Returns true if dtype is empty or
157 * if it does not contain any data components (i.e., a derived type with
158 * type bound procedures returns false). Otherwise, returns false.
159 */
160 static bool
no_data_components_recursive(DTYPE dtype,struct visit_list ** visited)161 no_data_components_recursive(DTYPE dtype, struct visit_list **visited)
162 {
163 int mem;
164 struct visit_list *active = visit_list_scan(*visited, dtype);
165
166 if (DTY(dtype) == TY_ARRAY)
167 dtype = DTySeqTyElement(dtype);
168
169 if (is_empty_typedef(dtype)) {
170 return true;
171 }
172 if (DTY(dtype) != TY_UNION && DTY(dtype) != TY_STRUCT) {
173 return false;
174 }
175 if (active) {
176 return active->is_active;
177 }
178
179 visit_list_push(visited, dtype);
180 active = *visited;
181
182 for (mem = DTyAlgTyMember(dtype); mem > NOSYM; mem = SYMLKG(mem)) {
183 /* if member has derived type datatype, then need to recursively check
184 it's possible that it is empty type, such as abstract type.
185 */
186 if (DTY(DTYPEG(mem)) == TY_STRUCT) {
187 if (!no_data_components_recursive(DTYPEG(mem), visited)) {
188 active->is_active = false;
189 return false;
190 }
191 } else if (!CLASSG(mem) || !TBPLNKG(mem)) {
192 active->is_active = false;
193 return false;
194 }
195 }
196 return true;
197 }
198
199 bool
no_data_components(DTYPE dtype)200 no_data_components(DTYPE dtype)
201 {
202 struct visit_list *visited = NULL;
203 bool result = no_data_components_recursive(dtype, &visited);
204 visit_list_free(&visited);
205 return result;
206 }
207
208 static int nosize_ok = 0;
209
210 static ISZ_T
_size_of(DTYPE dtype)211 _size_of(DTYPE dtype)
212 {
213 INT d;
214 ADSC *ad;
215 ISZ_T val, nelems, sz;
216
217 assert(DTyValidRange(dtype), "size_of:bad dtype", dtype, ERR_Severe);
218
219 switch (DTY(dtype)) {
220 case TY_WORD:
221 case TY_DWORD:
222 case TY_LOG:
223 case TY_INT:
224 case TY_UINT:
225 case TY_FLOAT:
226 case TY_PTR:
227 case TY_SLOG:
228 case TY_SINT:
229 case TY_USINT:
230 case TY_BINT:
231 case TY_UBINT:
232 case TY_BLOG:
233 case TY_DBLE:
234 case TY_QUAD:
235 case TY_CMPLX:
236 case TY_DCMPLX:
237 case TY_INT8:
238 case TY_UINT8:
239 case TY_LOG8:
240 case TY_128:
241 case TY_256:
242 case TY_512:
243 case TY_INT128:
244 case TY_UINT128:
245 case TY_LOG128:
246 case TY_FLOAT128:
247 case TY_CMPLX128:
248 return dtypeinfo[DTY(dtype)].size;
249
250 case TY_HOLL:
251 case TY_CHAR:
252 if (dtype == DT_ASSCHAR) {
253 if (nosize_ok)
254 return -1;
255 interr("size_of: attempt to size assumed size character", 0, ERR_Severe);
256 }
257 if (dtype == DT_DEFERCHAR) {
258 if (nosize_ok)
259 return -1;
260 interr("size_of: attempt to size deferred size character", 0, ERR_Severe);
261 }
262 return DTyCharLength(dtype);
263
264 case TY_NCHAR:
265 if (dtype == DT_ASSCHAR) {
266 if (nosize_ok)
267 return -1;
268 interr("size_of: attempt to size assumed size character", 0, ERR_Severe);
269 }
270 if (dtype == DT_DEFERCHAR) {
271 if (nosize_ok)
272 return -1;
273 interr("size_of: attempt to size deferred size character", 0, ERR_Severe);
274 }
275 return 2 * DTyCharLength(dtype);
276
277 case TY_ARRAY:
278 if ((d = DTyArrayDesc(dtype)) <= 0) {
279 if (nosize_ok)
280 return -1;
281 interr("size_of: no ad", (int)d, ERR_Severe);
282 return size_of(DTySeqTyElement(dtype));
283 }
284 ad = AD_DPTR(dtype);
285 d = AD_NUMELM(ad);
286 if (d == 0 || STYPEG(d) != ST_CONST) {
287 /* illegal use of adjustable or assumed-size array:
288 should have been caught in semant. */
289 /* errsev(50); */
290 if (XBIT(68, 0x1))
291 d = AD_NUMELM(ad) = stb.k1;
292 else
293 d = AD_NUMELM(ad) = stb.i1;
294 }
295 nelems = ad_val_of(d);
296 sz = size_of(DTySeqTyElement(dtype));
297 val = nelems * sz;
298 if (size_sym && (val < nelems || val < sz) && nelems && sz) {
299 return -1;
300 }
301 return val;
302
303 case TY_STRUCT:
304 case TY_UNION:
305 if (DTyAlgTySize(dtype) < 0)
306 {
307 if (nosize_ok)
308 return -1;
309 errsev(S_0151_Empty_STRUCTURE_UNION_or_MAP);
310 return 4;
311 } else
312 return DTyAlgTySize(dtype);
313 case TY_VECT:
314 d = DTyVecLength(dtype);
315 if (d == 3)
316 d = 4;
317 return d * size_of(DTySeqTyElement(dtype));
318
319 default:
320 interr("size_of: bad dtype ", DTY(dtype), ERR_Severe);
321 return 1;
322 }
323 }
324
325 ISZ_T
size_of(DTYPE dtype)326 size_of(DTYPE dtype)
327 {
328 return _size_of(dtype);
329 }
330
331 ISZ_T
zsize_of(DTYPE dtype)332 zsize_of(DTYPE dtype)
333 {
334 ISZ_T d;
335 nosize_ok = 1;
336 d = _size_of(dtype);
337 nosize_ok = 0;
338 return d;
339 }
340
341 ISZ_T
size_of_sym(SPTR sym)342 size_of_sym(SPTR sym)
343 {
344 ISZ_T sz;
345
346 size_sym = sym;
347 sz = size_of(DTYPEG(sym));
348 size_sym = 0;
349 if (sz < 0) {
350 error((enum error_code)219, ERR_Severe, gbl.lineno, SYMNAME(sym), NULL);
351 sz = 1;
352 }
353 return sz;
354 }
355
356 /** \brief Return the length, in stb.dt.stg_base words, of each type of datatype
357 * entry
358 */
359 int
dlen(TY_KIND dty)360 dlen(TY_KIND dty)
361 {
362 switch (dty) {
363 case TY_ANY:
364 case TY_BINT:
365 case TY_UBINT:
366 case TY_BLOG:
367 case TY_CMPLX:
368 case TY_DBLE:
369 case TY_DCMPLX:
370 case TY_DWORD:
371 case TY_HOLL:
372 case TY_INT:
373 case TY_INT8:
374 case TY_LOG:
375 case TY_LOG8:
376 case TY_NONE:
377 case TY_NUMERIC:
378 case TY_QUAD:
379 case TY_REAL:
380 case TY_SINT:
381 case TY_SLOG:
382 case TY_UINT:
383 case TY_UINT8:
384 case TY_USINT:
385 case TY_WORD:
386 case TY_128:
387 case TY_256:
388 case TY_512:
389 case TY_INT128:
390 case TY_UINT128:
391 case TY_LOG128:
392 case TY_FLOAT128:
393 case TY_CMPLX128:
394 return 1;
395 case TY_CHAR:
396 case TY_NCHAR:
397 case TY_PTR:
398 return 2;
399 case TY_ARRAY:
400 case TY_PFUNC:
401 case TY_VECT:
402 return 3;
403 case TY_STRUCT:
404 case TY_UNION:
405 return 6;
406 case TY_PARAM:
407 return 4;
408 case TY_PROC:
409 return 6;
410 default:
411 return 1;
412 }
413 } /* dlen */
414
415 static bool constrained = true; /* assume aligning within an aggregate */
416
417 int
alignment(DTYPE dtype)418 alignment(DTYPE dtype)
419 {
420 TY_KIND ty;
421 int align_bits;
422
423 switch (ty = DTY(dtype)) {
424 case TY_DWORD:
425 case TY_DBLE:
426 case TY_DCMPLX:
427 if (constrained && !flg.dalign)
428 return dtypeinfo[TY_INT].align;
429 return dtypeinfo[ty].align;
430 case TY_QUAD:
431 case TY_WORD:
432 case TY_HOLL:
433 case TY_BINT:
434 case TY_UBINT:
435 case TY_SINT:
436 case TY_USINT:
437 case TY_INT:
438 case TY_UINT:
439 case TY_REAL:
440 case TY_CMPLX:
441 case TY_BLOG:
442 case TY_SLOG:
443 case TY_LOG:
444 case TY_CHAR:
445 case TY_NCHAR:
446 case TY_PTR:
447 case TY_128:
448 case TY_256:
449 case TY_512:
450 case TY_INT128:
451 case TY_UINT128:
452 case TY_LOG128:
453 case TY_FLOAT128:
454 case TY_CMPLX128:
455 return dtypeinfo[ty].align;
456 case TY_INT8:
457 case TY_UINT8:
458 case TY_LOG8:
459 if (constrained && (!flg.dalign || XBIT(119, 0x100000)))
460 return dtypeinfo[TY_INT].align;
461 return dtypeinfo[ty].align;
462
463 case TY_ARRAY:
464 align_bits = alignment(DTySeqTyElement(dtype));
465 return align_bits;
466 case TY_VECT:
467 return alignment(DTySeqTyElement(dtype));
468
469 case TY_STRUCT:
470 case TY_UNION:
471 return DTyAlgTyAlign(dtype);
472
473 default:
474 interr("alignment: bad dtype ", ty, ERR_Severe);
475 return 0;
476 }
477 }
478
479 /** Align on the most strict boundary for a data type -- used whenever we want
480 * to align unconstrained (top-level) objects such as simple local, static,
481 * and external variables. The alignment of struct of union variables
482 * is just the most strict alignment determined by alignment() of its
483 * members. The alignment of arrays is just the aligmnent of required for
484 * its element type.
485 */
486 int
align_unconstrained(DTYPE dtype)487 align_unconstrained(DTYPE dtype)
488 {
489 int a;
490
491 constrained = false;
492 a = alignment(dtype);
493 constrained = true;
494 return a;
495 }
496
497 int
alignment_sym(SPTR sym)498 alignment_sym(SPTR sym)
499 {
500 if (QALNG(sym))
501 return dtypeinfo[TY_DBLE].align;
502 return alignment(DTYPEG(sym));
503 }
504
505 int
align_of(DTYPE dtype)506 align_of(DTYPE dtype)
507 {
508 return alignment(dtype) + 1;
509 }
510
511 #define CHARTABSIZE 40
512 static int chartab[CHARTABSIZE];
513
514 /** Data structure to hold TY_CHAR entries: linked list off of
515 * array chartab; entries that are equal module CHARTABSIZE are
516 * linked. Relative pointers (integers) are used.
517 */
518 typedef struct chartab {
519 int next;
520 DTYPE dtype;
521 } CHARTAB;
522
523 static int chartabavail;
524 static int chartabsize;
525 static CHARTAB *chartabbase;
526
527 void
init_chartab(void)528 init_chartab(void)
529 {
530 int i, ctb;
531
532 for (i = 0; i < CHARTABSIZE; ++i)
533 chartab[i] = 0;
534 if (chartabbase == 0) {
535 /* allocate new */
536 chartabsize = CHARTABSIZE;
537 NEW(chartabbase, struct chartab, chartabsize);
538 }
539 ctb = 1;
540 chartabbase[0].next = 0;
541 chartabbase[0].dtype = DT_NONE;
542 /* Enter character*1 predefined data type */
543 chartab[1] = ctb;
544 chartabbase[ctb].next = 0;
545 chartabbase[ctb].dtype = DT_CHAR;
546 ++ctb;
547 /* Enter ncharacter*1 predefined data type */
548 chartabbase[ctb - 1].next = ctb;
549 chartabbase[ctb].next = 0;
550 chartabbase[ctb].dtype = DT_NCHAR;
551 ++ctb;
552 chartabavail = ctb;
553 }
554
555 void
Save_Chartab(FILE * fil)556 Save_Chartab(FILE *fil)
557 {
558 int nw;
559 nw = fwrite((void *)&chartab, sizeof(int), CHARTABSIZE, fil);
560 if (nw != CHARTABSIZE) {
561 error(S_0155_OP1_OP2, ERR_Fatal, 0, "Error writing temp file:", "chartabhead");
562 exit(1);
563 }
564 nw = fwrite((void *)&chartabavail, sizeof(int), 1, fil);
565 if (nw != 1) {
566 error(S_0155_OP1_OP2, ERR_Fatal, 0, "Error writing temp file:", "chartabavl");
567 exit(1);
568 }
569 nw = fwrite((void *)chartabbase, sizeof(struct chartab), chartabavail, fil);
570 if (nw != chartabavail) {
571 error(S_0155_OP1_OP2, ERR_Fatal, 0, "Error writing temp file:", "chartabavl");
572 exit(1);
573 }
574 } /* Save_Chartab */
575
576 void
Restore_Chartab(FILE * fil)577 Restore_Chartab(FILE *fil)
578 {
579 int nw;
580 nw = fread((void *)&chartab, sizeof(int), CHARTABSIZE, fil);
581 if (nw != CHARTABSIZE) {
582 error(S_0155_OP1_OP2, ERR_Fatal, 0, "Error reading temp file:", "chartabhead");
583 exit(1);
584 }
585 nw = fread((void *)&chartabavail, sizeof(int), 1, fil);
586 if (nw != 1) {
587 error(S_0155_OP1_OP2, ERR_Fatal, 0, "Error reading temp file:", "chartabavl");
588 exit(1);
589 }
590 NEED(chartabavail, chartabbase, struct chartab, chartabsize,
591 chartabavail + 1000);
592 nw = fread((void *)chartabbase, sizeof(struct chartab), chartabavail, fil);
593 if (nw != chartabavail) {
594 error(S_0155_OP1_OP2, ERR_Fatal, 0, "Error reading temp file:", "chartabavl");
595 exit(1);
596 }
597 } /* Restore_Chartab */
598
599 DTYPE
get_type(int n,TY_KIND v1,int v2)600 get_type(int n, TY_KIND v1, int v2)
601 {
602 int i, j;
603 DTYPE dtype = (DTYPE)stb.dt.stg_avail;
604
605 /* if we want TY_CHAR find one if it exists */
606 if (v1 == TY_CHAR || v1 == TY_NCHAR)
607 {
608 if (v2 < 0)
609 v2 = 0;
610 i = v2 % CHARTABSIZE;
611 if (chartab[i]) {
612 /* check list for this length */
613 for (j = chartab[i]; j != 0; j = chartabbase[j].next) {
614 DTYPE k = chartabbase[j].dtype;
615 if (DTyCharLength(k) == v2 && /* same length */
616 DTY(k) == v1 /*TY_CHAR vs TY_NCHAR*/) {
617 dtype = chartabbase[j].dtype;
618 return dtype;
619 }
620 }
621 }
622 /* not found */
623 NEED(chartabavail + n, chartabbase, struct chartab, chartabsize,
624 chartabsize + CHARTABSIZE);
625 chartabbase[chartabavail].dtype = dtype;
626 chartabbase[chartabavail].next = chartab[i];
627 chartab[i] = chartabavail++;
628 }
629
630 dtype = (DTYPE)STG_NEXT_SIZE(stb.dt, n); // FIXME
631 DTySet(dtype, v1);
632 DTySetFst(dtype, v2);
633 return dtype;
634 }
635
636 #define _VP 3
637 #define _FP ((4 * sizeof(int) + sizeof(char *)) / sizeof(int))
638
639 /** \brief Create a dtype record for an array of rank numdim including its
640 * array descriptor.
641 *
642 * The layout of an array descriptor is:
643 * <pre>
644 * int numdim; --+
645 * int scheck; |
646 * int zbase; +-- 5 ints (fixed part)
647 * int sdsc; |
648 * ILM_T *ilmp; --+ watch out if pointers are 8 bytes.
649 * struct {
650 * int mlpyr; --+
651 * int lwbd; +-- 3 ints (variable part)
652 * int upbd; --+
653 * } b[numdim];
654 * int numlem; --+-- 1 int after variable part.
655 * </pre>
656 *
657 * Any change in the size of the structure requires a change to one or both
658 * of the macros _FP and _VP. Also the size assertion in symtab.c needs
659 * to be changed.
660 */
661 static void
get_aux_arrdsc(DTYPE dtype,int numdim)662 get_aux_arrdsc(DTYPE dtype, int numdim)
663 {
664 ADSC *ad;
665 int numints;
666
667 struct getpointeralign { /* see if 8 byte pointers require 8 byte alignmnt*/
668 char *ilmp;
669 char c;
670 };
671 #define ALIGNSIZE \
672 ((sizeof(struct getpointeralign) - sizeof(char *) - 1) / sizeof(int))
673 /* ALIGNSIZE is pad bytes / sizeof(int) expect 0 or 1 */
674
675 DTySetArrayDesc(dtype, aux.arrdsc_avl);
676 numints = (_FP + 1) + (_VP * numdim);
677 numints = ALIGN(numints, ALIGNSIZE);
678 aux.arrdsc_avl += numints;
679
680 NEED(aux.arrdsc_avl, aux.arrdsc_base, int, aux.arrdsc_size,
681 aux.arrdsc_avl + 240);
682 ad = AD_DPTR(dtype);
683 BZERO(ad, int, numints);
684 AD_NUMDIM(ad) = numdim;
685 }
686
687 DTYPE
get_array_dtype(int numdim,DTYPE eltype)688 get_array_dtype(int numdim, DTYPE eltype)
689 {
690 DTYPE dtype = get_type(3, TY_ARRAY, eltype);
691 get_aux_arrdsc(dtype, numdim);
692 return dtype;
693 }
694
695 DTYPE
get_vector_dtype(DTYPE dtype,int n)696 get_vector_dtype(DTYPE dtype, int n)
697 {
698 DTYPE vecdt = (DTYPE)aux.vtypes[DTY(dtype)][n - 1]; // FIXME
699 if (!vecdt) {
700 vecdt = get_type(3, TY_VECT, dtype);
701 DTySetVecLength(vecdt, n);
702 aux.vtypes[DTY(dtype)][n - 1] = vecdt;
703 }
704 return vecdt;
705 }
706
707 bool
cmpat_func(DTYPE d1,DTYPE d2)708 cmpat_func(DTYPE d1, DTYPE d2)
709 {
710 int fv1, fv2;
711
712 if (d1 == d2)
713 return true;
714 fv1 = dtypeinfo[DTY(d1)].fval;
715 assert(fv1 >= 0, "cmpat_func1:bad dtype", d1, ERR_Severe);
716 fv2 = dtypeinfo[DTY(d2)].fval;
717 assert(fv2 >= 0, "cmpat_func2:bad dtype", d2, ERR_Severe);
718 return (fv1 == fv2);
719 }
720
721 void
getdtype(DTYPE dtype,char * ptr)722 getdtype(DTYPE dtype, char *ptr)
723 {
724 int i;
725 ADSC *ad;
726 int numdim;
727 char *p;
728 char temp[100];
729
730 p = ptr;
731 *p = 0;
732 for (; dtype != 0 && p - ptr <= 70; dtype = DTySeqTyElement(dtype)) {
733 if (dtype <= 0 || dtype >= stb.dt.stg_avail || DTY(dtype) <= 0 ||
734 DTY(dtype) > TY_MAX) {
735 interr("getdtype: bad dtype", dtype, ERR_Severe);
736 strcpy(p, "????");
737 break;
738 }
739 strcpy(p, stb.tynames[DTY(dtype)]);
740 p += strlen(p);
741
742 switch (DTY(dtype)) {
743 case TY_STRUCT:
744 case TY_UNION: {
745 SPTR tag = DTyAlgTyTag(dtype);
746 if (tag) {
747 #if DEBUG
748 assert(tag > NOSYM, "getdtype: bad tag", dtype, ERR_Severe);
749 #endif
750 sprintf(p, "/%s/", SYMNAME(tag));
751 p += strlen(p);
752 }
753 } return;
754
755 case TY_ARRAY:
756 *p++ = ' ';
757 *p++ = '(';
758 if (DTyArrayDesc(dtype) != 0) {
759 ad = AD_DPTR(dtype);
760 numdim = AD_NUMDIM(ad);
761 if (numdim < 1 || numdim > 7) {
762 interr("getdtype:bad numdim", 0, ERR_Informational);
763 numdim = 0;
764 }
765 for (i = 0; i < numdim; i++) {
766 sprintf(p, "%s:", getprint(AD_LWBD(ad, i)));
767 p += strlen(p);
768 sprintf(p, "%s", getprint(AD_UPBD(ad, i)));
769 p += strlen(p);
770 if (i != numdim - 1)
771 *p++ = ',';
772 }
773 }
774 strcpy(p, ") of ");
775 p += 5;
776 break;
777
778 case TY_PTR:
779 break;
780
781 case TY_CHAR:
782 case TY_NCHAR:
783 if (dtype != DT_ASSCHAR && dtype != DT_ASSNCHAR)
784 sprintf(p, "*%d", (int)DTyCharLength(dtype));
785 else
786 sprintf(p, "*(*)");
787 return;
788 case TY_VECT:
789 snprintf(temp, sizeof(temp), "%ld ", DTyVecLength(dtype));
790 strcat(p, temp);
791 break;
792
793 default:
794 return;
795 }
796 }
797
798 }
799
800 /** Compute total number of elements in this array - if a dimension is
801 * not known, estimate. We assume that we already know that dtype
802 * is an array reference (either an array or a pointer to an array)
803 */
804 ISZ_T
extent_of(DTYPE dtype)805 extent_of(DTYPE dtype)
806 {
807 #define DEFAULT_DIM_SIZE 127
808
809 int i;
810 ADSC *ad;
811 int numdim;
812 ISZ_T dim_size;
813 ISZ_T size = 1;
814
815 for (; dtype != 0; dtype = DTySeqTyElement(dtype)) {
816 if (dtype <= 0 || dtype >= stb.dt.stg_avail || DTY(dtype) <= 0 ||
817 DTY(dtype) > TY_MAX) {
818 interr("getdtype: bad dtype", dtype, ERR_Severe);
819 break;
820 }
821
822 switch (DTY(dtype)) {
823
824 case TY_ARRAY:
825 if (DTyArrayDesc(dtype) != 0) {
826 ad = AD_DPTR(dtype);
827 numdim = AD_NUMDIM(ad);
828 if (numdim < 1 || numdim > 7) {
829 interr("extent_of: bad numdim", 0, ERR_Informational);
830 numdim = 0;
831 }
832 for (i = 0; i < numdim; i++) {
833 if (STYPEG(AD_LWBD(ad, i)) != ST_CONST || AD_UPBD(ad, i) == 0 ||
834 STYPEG(AD_UPBD(ad, i)) != ST_CONST)
835 dim_size = DEFAULT_DIM_SIZE;
836 else
837 dim_size =
838 ad_val_of(AD_UPBD(ad, i)) - ad_val_of(AD_LWBD(ad, i)) + 1;
839 size *= dim_size;
840 }
841 }
842 break;
843
844 default:
845 return size;
846 }
847 }
848
849 return size;
850 }
851
852 ISZ_T
ad_val_of(int sym)853 ad_val_of(int sym)
854 {
855 if (XBIT(68, 0x1))
856 return get_isz_cval(sym);
857 return CONVAL2G(sym);
858 }
859
860 int
get_bnd_con(ISZ_T v)861 get_bnd_con(ISZ_T v)
862 {
863 INT num[2];
864
865 if (XBIT(68, 0x1)) {
866 ISZ_2_INT64(v, num);
867 return getcon(num, DT_INT8);
868 }
869 num[0] = 0;
870 num[1] = v;
871 return getcon(num, DT_INT);
872 }
873
874 ISZ_T
get_bnd_cval(int con)875 get_bnd_cval(int con)
876 {
877 INT int64[2];
878 ISZ_T isz;
879
880 if (con == 0)
881 return 0;
882 #if DEBUG
883 assert(STYPEG(con) == ST_CONST, "get_bnd_cval-not ST_CONST", con, ERR_unused);
884 assert(DT_ISINT(DTYPEG(con)), "get_bnd_cval-not int const", con, ERR_unused);
885 #endif
886 int64[0] = CONVAL1G(con);
887 int64[1] = CONVAL2G(con);
888 INT64_2_ISZ(int64, isz);
889 return isz;
890 }
891
892 static int
_dmp_dent(DTYPE dtypeind,FILE * outfile)893 _dmp_dent(DTYPE dtypeind, FILE *outfile)
894 {
895 char buf[256];
896 int retval;
897 ADSC *ad;
898 int numdim;
899 int i;
900 int paramct, dpdsc;
901
902 if (outfile == 0)
903 outfile = stderr;
904
905 if (dtypeind < 1 || dtypeind >= stb.dt.stg_avail) {
906 fprintf(outfile, "dtype index (%d) out of range in dmp_dent\n", dtypeind);
907 return 0;
908 }
909 buf[0] = '\0';
910 fprintf(outfile, " %5d ", dtypeind);
911 switch (DTY(dtypeind)) {
912 case TY_WORD:
913 case TY_DWORD:
914 case TY_HOLL:
915 case TY_BINT:
916 case TY_UBINT:
917 case TY_SINT:
918 case TY_USINT:
919 case TY_INT:
920 case TY_UINT:
921 case TY_REAL:
922 case TY_DBLE:
923 case TY_QUAD:
924 case TY_CMPLX:
925 case TY_DCMPLX:
926 case TY_BLOG:
927 case TY_SLOG:
928 case TY_LOG:
929 case TY_NUMERIC:
930 case TY_ANY:
931 case TY_INT8:
932 case TY_UINT8:
933 case TY_LOG8:
934 case TY_128:
935 case TY_256:
936 case TY_512:
937 case TY_INT128:
938 case TY_UINT128:
939 case TY_LOG128:
940 case TY_FLOAT128:
941 case TY_CMPLX128:
942 retval = 1;
943 break;
944 case TY_CHAR:
945 case TY_NCHAR:
946 retval = 2;
947 break;
948 case TY_PTR:
949 fprintf(outfile, "ptr dtype=%5d\n", DTySeqTyElement(dtypeind));
950 retval = 2;
951 break;
952 case TY_ARRAY:
953 retval = 3;
954 fprintf(outfile, "array dtype=%5d desc =%9" ISZ_PF "d\n",
955 DTySeqTyElement(dtypeind), DTyArrayDesc(dtypeind));
956 if (!DTyArrayDesc(dtypeind)) {
957 fprintf(outfile, "(No array desc)\n");
958 break;
959 }
960 ad = AD_DPTR(dtypeind);
961 numdim = AD_NUMDIM(ad);
962 if (numdim < 1 || numdim > 7) {
963 interr("dmp_dent:bad numdim", 0, ERR_Informational);
964 numdim = 0;
965 }
966 fprintf(outfile,
967 "numdim: %d scheck: %d zbase: %d numelm: %d sdsc: %d\n",
968 numdim, AD_SCHECK(ad), AD_ZBASE(ad), AD_NUMELM(ad), AD_SDSC(ad));
969 for (i = 0; i < numdim; i++)
970 fprintf(outfile, "%1d: mlpyr: %d lwbd: %d upbd: %d\n", i + 1,
971 AD_MLPYR(ad, i), AD_LWBD(ad, i), AD_UPBD(ad, i));
972 break;
973 case TY_STRUCT:
974 case TY_UNION:
975 fprintf(outfile, "%s sptr =%5d size =%5" ISZ_PF "d",
976 stb.tynames[DTY(dtypeind)], DTyAlgTyMember(dtypeind),
977 DTyAlgTySize(dtypeind));
978 fprintf(outfile, " tag=%5d align=%3" ISZ_PF "d",
979 DTyAlgTyTag(dtypeind), DTyAlgTyAlign(dtypeind));
980 fprintf(outfile, " ict=%p\n",
981 get_getitem_p(DTyAlgTyInitCon(dtypeind)));
982 retval = 6;
983 break;
984 case TY_PROC:
985 paramct = DTyParamCount(dtypeind);
986 dpdsc = DTyParamDesc(dtypeind);
987 fprintf(outfile,
988 "proc dtype=%5ld interface=%5ld paramct=%3d dpdsc=%5d"
989 " fval=%5ld\n", DTyReturnType(dtypeind), DTyInterface(dtypeind),
990 paramct, dpdsc, DTyFuncVal(dtypeind));
991 for (i = 0; i < paramct; i++) {
992 fprintf(outfile, " arg %d: %d\n", i + 1, aux.dpdsc_base[dpdsc + i]);
993 }
994 retval = 6;
995 break;
996 case TY_VECT:
997 fprintf(outfile, "vect dtype=%3d n =%2" ISZ_PF "d\n ",
998 DTySeqTyElement(dtypeind), DTyVecLength(dtypeind));
999 retval = 3;
1000 break;
1001 case TY_PFUNC:
1002 fprintf(outfile, "proto funct dtype=%3d params=%3d\n ",
1003 DTyReturnType(dtypeind), DTyParamList(dtypeind));
1004 retval = 3;
1005 break;
1006 case TY_PARAM:
1007 fprintf(outfile, "param dtype = %3d sptr =%3d next=%3d\n",
1008 DTyArgType(dtypeind), DTyArgSym(dtypeind),
1009 DTyArgNext(dtypeind));
1010 retval = 4;
1011 dtypeind = DT_NONE;
1012 break;
1013 default:
1014 interr("dmp_dent: unknown dtype", (int)DTY(dtypeind), ERR_Severe);
1015 /* function param thing ?? */
1016 fprintf(outfile, "???? %5d\n", (int)DTY(dtypeind));
1017 retval = 1;
1018 dtypeind = DT_NONE;
1019 break;
1020 }
1021 if (dtypeind) {
1022 getdtype(dtypeind, buf);
1023 fprintf(outfile, "%s\n", buf);
1024 }
1025 return retval;
1026 }
1027
1028 int
dmp_dent(DTYPE dtypeind)1029 dmp_dent(DTYPE dtypeind)
1030 {
1031 return _dmp_dent(dtypeind, gbl.dbgfil);
1032 }
1033
1034 void
dmp_dtype(void)1035 dmp_dtype(void)
1036 {
1037 int i;
1038
1039 fprintf(gbl.dbgfil, "\n------------------------\nDTYPE DUMP:\n");
1040 fprintf(gbl.dbgfil, "\ndt_base: %p dt_size: %d dt_avail: %d\n\n",
1041 (void *)stb.dt.stg_base, stb.dt.stg_size, stb.dt.stg_avail);
1042 i = 1;
1043 fprintf(gbl.dbgfil, "index dtype\n");
1044 while (i < stb.dt.stg_avail) {
1045 i += dmp_dent((DTYPE)i);
1046 }
1047 fprintf(gbl.dbgfil, "\n------------------------\n");
1048 }
1049
1050 int
Scale_Of(DTYPE dtype,ISZ_T * size)1051 Scale_Of(DTYPE dtype, ISZ_T *size)
1052 {
1053 TY_KIND d;
1054 int tmp;
1055 int scale;
1056 ISZ_T tmpsiz;
1057
1058 assert(DTyValidRange(dtype), "Scale_Of:bad dtype", dtype, ERR_Severe);
1059
1060 switch ((d = DTY(dtype))) {
1061 case TY_WORD:
1062 case TY_DWORD:
1063 case TY_LOG:
1064 case TY_INT:
1065 case TY_UINT:
1066 case TY_FLOAT:
1067 case TY_PTR:
1068 case TY_SLOG:
1069 case TY_SINT:
1070 case TY_USINT:
1071 case TY_BINT:
1072 case TY_UBINT:
1073 case TY_BLOG:
1074 case TY_DBLE:
1075 case TY_CMPLX:
1076 case TY_DCMPLX:
1077 case TY_INT8:
1078 case TY_UINT8:
1079 case TY_LOG8:
1080 case TY_128:
1081 case TY_256:
1082 case TY_512:
1083 case TY_INT128:
1084 case TY_UINT128:
1085 case TY_LOG128:
1086 case TY_FLOAT128:
1087 case TY_CMPLX128:
1088 scale = dtypeinfo[d].scale;
1089 *size = (unsigned)dtypeinfo[d].size >> scale;
1090 return scale;
1091
1092 case TY_HOLL:
1093 case TY_CHAR:
1094 if (dtype == DT_ASSCHAR)
1095 interr("Scale_Of: attempt to size assumed size character", 0, ERR_Severe);
1096 *size = DTyCharLength(dtype);
1097 return 0;
1098
1099 case TY_NCHAR:
1100 if (dtype == DT_ASSNCHAR)
1101 interr("Scale_Of: attempt to size assumed size ncharacter", 0, ERR_Severe);
1102 *size = 2 * DTyCharLength(dtype);
1103 return 0;
1104
1105 case TY_ARRAY: {
1106 ISZ_T d = DTyArrayDesc(dtype);
1107 if (d <= 0) {
1108 interr("Scale_Of: no ad", d, ERR_Severe);
1109 d = 1;
1110 DTySetArrayDesc(dtype, d);
1111 }
1112 tmp = Scale_Of(DTySeqTyElement(dtype), &tmpsiz);
1113 *size = d * tmpsiz;
1114 } return tmp;
1115
1116 case TY_STRUCT:
1117 case TY_UNION:
1118 if (DTyAlgTySize(dtype) < 0)
1119 {
1120 interr("Scale_Of: 0 size struct", 0, ERR_Severe);
1121 *size = 4;
1122 } else {
1123 *size = DTyAlgTySize(dtype);
1124 }
1125 return 0;
1126
1127 case TY_VECT: {
1128 ISZ_T d = DTyVecLength(dtype);
1129 if (d == 3)
1130 d = 4;
1131 tmp = Scale_Of(DTySeqTyElement(dtype), &tmpsiz);
1132 *size = d * tmpsiz;
1133 } return tmp;
1134
1135 default:
1136 interr("Scale_Of: bad dtype ", DTY(dtype), ERR_Severe);
1137 *size = 1;
1138 return 0;
1139 }
1140 }
1141
1142 int
scale_of(DTYPE dtype,INT * size)1143 scale_of(DTYPE dtype, INT *size)
1144 {
1145 int scale;
1146 ISZ_T tmpsiz;
1147
1148 scale = Scale_Of(dtype, &tmpsiz);
1149 *size = tmpsiz;
1150 return scale;
1151 }
1152
1153 int
fval_of(DTYPE dtype)1154 fval_of(DTYPE dtype)
1155 {
1156 int fv;
1157
1158 assert(DTyValidRange(dtype), "fval_of:bad dtype", dtype, ERR_Severe);
1159
1160 fv = dtypeinfo[DTY(dtype)].fval & 0x3;
1161 assert(fv <= 1, "fval_of: bad dtype, dt is", dtype, ERR_Severe);
1162 return fv;
1163 }
1164
1165 #define SS2 0x8e
1166 #define SS3 0x8f
1167
1168 int
kanji_len(unsigned char * p,int len)1169 kanji_len(unsigned char *p, int len)
1170 {
1171 int count = 0;
1172 int val;
1173
1174 while (len > 0) {
1175 val = *p;
1176 count++;
1177 if ((val & 0x80) == 0 || len <= 1) /* ASCII */
1178 len--, p++;
1179 else if (val == SS2) /* JIS 8-bit character */
1180 len -= 2, p += 2;
1181 else if (val == SS3 && len >= 3) /* Graphic Character */
1182 len -= 3, p += 3;
1183 else /* Kanji */
1184 len -= 2, p += 2;
1185 }
1186
1187 return count;
1188 }
1189
1190 int
kanji_char(unsigned char * p,int len,int * bytes)1191 kanji_char(unsigned char *p, int len, int *bytes)
1192 {
1193 int val = *p;
1194
1195 if ((val & 0x80) == 0 || len <= 1) /* ASCII */
1196 *bytes = 1;
1197 else if (val == SS2) /* JIS 8-bit character */
1198 *bytes = 2, val = *(p + 1);
1199 else if (val == SS3 && len >= 3) /* Graphic Character */
1200 *bytes = 3, val = ((*(p + 1) << 8) | (*(p + 2) & 0x7F));
1201 else /* Kanji */
1202 *bytes = 2, val = ((val << 8) | *(p + 1));
1203
1204 return val;
1205 }
1206
1207 int
kanji_prefix(unsigned char * p,int newlen,int len)1208 kanji_prefix(unsigned char *p, int newlen, int len)
1209 {
1210 unsigned char *begin;
1211 int bytes;
1212
1213 begin = p;
1214 while (newlen-- > 0) {
1215 (void)kanji_char(p, len, &bytes);
1216 p += bytes;
1217 len -= bytes;
1218 }
1219
1220 return (p - begin);
1221 }
1222
1223