1 /*-
2 * Copyright (c) 1980 The Regents of the University of California.
3 * All rights reserved.
4 *
5 * %sccs.include.proprietary.c%
6 */
7
8 #ifndef lint
9 static char sccsid[] = "@(#)conv.c 5.3 (Berkeley) 04/12/91";
10 #endif /* not lint */
11
12 /*
13 * conv.c
14 *
15 * Routines for type conversions, f77 compiler pass 1.
16 *
17 * University of Utah CS Dept modification history:
18 *
19 * $Log: conv.c,v $
20 * Revision 2.2 85/06/07 21:09:29 root
21 * Add copyright
22 *
23 * Revision 2.1 84/07/19 12:02:29 donn
24 * Changed comment headers for UofU.
25 *
26 * Revision 1.2 84/04/13 01:07:02 donn
27 * Fixed value of dminreal to be -1.7e38 + epsilon instead of -2.59e33, per
28 * Bob Corbett's approval.
29 *
30 */
31
32 #include "defs.h"
33 #include "conv.h"
34
35 int badvalue;
36
37
38 /* The following constants are used to check the limits of */
39 /* conversions. Dmaxword is the largest double precision */
40 /* number which can be converted to a two-byte integer */
41 /* without overflow. Dminword is the smallest double */
42 /* precision value which can be converted to a two-byte */
43 /* integer without overflow. Dmaxint and dminint are the */
44 /* analogous values for four-byte integers. */
45
46
47 LOCAL long dmaxword[] = { 0xfeff47ff, 0xffffffff };
48 LOCAL long dminword[] = { 0x00ffc800, 0xffffffff };
49
50 LOCAL long dmaxint[] = { 0xffff4fff, 0xfffffeff };
51 LOCAL long dminint[] = { 0x0000d000, 0xffff00ff };
52
53 LOCAL long dmaxreal[] = { 0xffff7fff, 0xffff7fff };
54 LOCAL long dminreal[] = { 0xffffffff, 0xffff7fff };
55
56
57
58 /* The routines which follow are used to convert */
59 /* constants into constants of other types. */
60
61 LOCAL char *
grabbits(len,cp)62 grabbits(len, cp)
63 int len;
64 Constp cp;
65 {
66
67 static char *toobig = "bit value too large";
68
69 register char *p;
70 register char *bits;
71 register int i;
72 register int k;
73 register int lenb;
74
75 bits = cp->constant.ccp;
76 lenb = cp->vleng->constblock.constant.ci;
77
78 p = (char *) ckalloc(len);
79
80 if (len >= lenb)
81 k = lenb;
82 else
83 {
84 k = len;
85 if ( badvalue == 0 )
86 {
87 #if (TARGET == PDP11 || TARGET == VAX)
88 i = len;
89 while ( i < lenb && bits[i] == 0 )
90 i++;
91 if (i < lenb)
92 badvalue = 1;
93 #else
94 i = lenb - len - 1;
95 while ( i >= 0 && bits[i] == 0)
96 i--;
97 if (i >= 0)
98 badvalue = 1;
99 #endif
100 if (badvalue)
101 warn(toobig);
102 }
103 }
104
105 #if (TARGET == PDP11 || TARGET == VAX)
106 i = 0;
107 while (i < k)
108 {
109 p[i] = bits[i];
110 i++;
111 }
112 #else
113 i = lenb;
114 while (k > 0)
115 p[--k] = bits[--i];
116 #endif
117
118 return (p);
119 }
120
121
122
123 LOCAL char *
grabbytes(len,cp)124 grabbytes(len, cp)
125 int len;
126 Constp cp;
127 {
128 register char *p;
129 register char *bytes;
130 register int i;
131 register int k;
132 register int lenb;
133
134 bytes = cp->constant.ccp;
135 lenb = cp->vleng->constblock.constant.ci;
136
137 p = (char *) ckalloc(len);
138
139 if (len >= lenb)
140 k = lenb;
141 else
142 k = len;
143
144 i = 0;
145 while (i < k)
146 {
147 p[i] = bytes[i];
148 i++;
149 }
150
151 while (i < len)
152 p[i++] = BLANK;
153
154 return (p);
155 }
156
157
158
159 LOCAL expptr
cshort(cp)160 cshort(cp)
161 Constp cp;
162 {
163 static char *toobig = "data value too large";
164 static char *reserved = "reserved operand assigned to an integer";
165 static char *compat1 = "logical datum assigned to an integer variable";
166 static char *compat2 = "character datum assigned to an integer variable";
167
168 register expptr p;
169 register short *shortp;
170 register ftnint value;
171 register long *rp;
172 register double *minp;
173 register double *maxp;
174 realvalue x;
175
176 switch (cp->vtype)
177 {
178 case TYBITSTR:
179 shortp = (short *) grabbits(2, cp);
180 p = (expptr) mkconst(TYSHORT);
181 p->constblock.constant.ci = *shortp;
182 free((char *) shortp);
183 break;
184
185 case TYSHORT:
186 p = (expptr) cpexpr(cp);
187 break;
188
189 case TYLONG:
190 value = cp->constant.ci;
191 if (value >= MINWORD && value <= MAXWORD)
192 {
193 p = (expptr) mkconst(TYSHORT);
194 p->constblock.constant.ci = value;
195 }
196 else
197 {
198 if (badvalue <= 1)
199 {
200 badvalue = 2;
201 err(toobig);
202 }
203 p = errnode();
204 }
205 break;
206
207 case TYREAL:
208 case TYDREAL:
209 case TYCOMPLEX:
210 case TYDCOMPLEX:
211 minp = (double *) dminword;
212 maxp = (double *) dmaxword;
213 rp = (long *) &(cp->constant.cd[0]);
214 x.q.word1 = rp[0];
215 x.q.word2 = rp[1];
216 if (x.f.sign == 1 && x.f.exp == 0)
217 {
218 if (badvalue <= 1)
219 {
220 badvalue = 2;
221 err(reserved);
222 }
223 p = errnode();
224 }
225 else if (x.d >= *minp && x.d <= *maxp)
226 {
227 p = (expptr) mkconst(TYSHORT);
228 p->constblock.constant.ci = x.d;
229 }
230 else
231 {
232 if (badvalue <= 1)
233 {
234 badvalue = 2;
235 err(toobig);
236 }
237 p = errnode();
238 }
239 break;
240
241 case TYLOGICAL:
242 if (badvalue <= 1)
243 {
244 badvalue = 2;
245 err(compat1);
246 }
247 p = errnode();
248 break;
249
250 case TYCHAR:
251 if ( !ftn66flag && badvalue == 0 )
252 {
253 badvalue = 1;
254 warn(compat2);
255 }
256
257 case TYHOLLERITH:
258 shortp = (short *) grabbytes(2, cp);
259 p = (expptr) mkconst(TYSHORT);
260 p->constblock.constant.ci = *shortp;
261 free((char *) shortp);
262 break;
263
264 case TYERROR:
265 p = errnode();
266 break;
267 }
268
269 return (p);
270 }
271
272
273
274 LOCAL expptr
clong(cp)275 clong(cp)
276 Constp cp;
277 {
278 static char *toobig = "data value too large";
279 static char *reserved = "reserved operand assigned to an integer";
280 static char *compat1 = "logical datum assigned to an integer variable";
281 static char *compat2 = "character datum assigned to an integer variable";
282
283 register expptr p;
284 register ftnint *longp;
285 register long *rp;
286 register double *minp;
287 register double *maxp;
288 realvalue x;
289
290 switch (cp->vtype)
291 {
292 case TYBITSTR:
293 longp = (ftnint *) grabbits(4, cp);
294 p = (expptr) mkconst(TYLONG);
295 p->constblock.constant.ci = *longp;
296 free((char *) longp);
297 break;
298
299 case TYSHORT:
300 p = (expptr) mkconst(TYLONG);
301 p->constblock.constant.ci = cp->constant.ci;
302 break;
303
304 case TYLONG:
305 p = (expptr) cpexpr(cp);
306 break;
307
308 case TYREAL:
309 case TYDREAL:
310 case TYCOMPLEX:
311 case TYDCOMPLEX:
312 minp = (double *) dminint;
313 maxp = (double *) dmaxint;
314 rp = (long *) &(cp->constant.cd[0]);
315 x.q.word1 = rp[0];
316 x.q.word2 = rp[1];
317 if (x.f.sign == 1 && x.f.exp == 0)
318 {
319 if (badvalue <= 1)
320 {
321 badvalue = 2;
322 err(reserved);
323 }
324 p = errnode();
325 }
326 else if (x.d >= *minp && x.d <= *maxp)
327 {
328 p = (expptr) mkconst(TYLONG);
329 p->constblock.constant.ci = x.d;
330 }
331 else
332 {
333 if (badvalue <= 1)
334 {
335 badvalue = 2;
336 err(toobig);
337 }
338 p = errnode();
339 }
340 break;
341
342 case TYLOGICAL:
343 if (badvalue <= 1)
344 {
345 badvalue = 2;
346 err(compat1);
347 }
348 p = errnode();
349 break;
350
351 case TYCHAR:
352 if ( !ftn66flag && badvalue == 0 )
353 {
354 badvalue = 1;
355 warn(compat2);
356 }
357
358 case TYHOLLERITH:
359 longp = (ftnint *) grabbytes(4, cp);
360 p = (expptr) mkconst(TYLONG);
361 p->constblock.constant.ci = *longp;
362 free((char *) longp);
363 break;
364
365 case TYERROR:
366 p = errnode();
367 break;
368 }
369
370 return (p);
371 }
372
373
374
375 LOCAL expptr
creal(cp)376 creal(cp)
377 Constp cp;
378 {
379 static char *toobig = "data value too large";
380 static char *compat1 = "logical datum assigned to a real variable";
381 static char *compat2 = "character datum assigned to a real variable";
382
383 register expptr p;
384 register long *longp;
385 register long *rp;
386 register double *minp;
387 register double *maxp;
388 realvalue x;
389 float y;
390
391 switch (cp->vtype)
392 {
393 case TYBITSTR:
394 longp = (long *) grabbits(4, cp);
395 p = (expptr) mkconst(TYREAL);
396 rp = (long *) &(p->constblock.constant.cd[0]);
397 rp[0] = *longp;
398 free((char *) longp);
399 break;
400
401 case TYSHORT:
402 case TYLONG:
403 p = (expptr) mkconst(TYREAL);
404 p->constblock.constant.cd[0] = cp->constant.ci;
405 break;
406
407 case TYREAL:
408 case TYDREAL:
409 case TYCOMPLEX:
410 case TYDCOMPLEX:
411 minp = (double *) dminreal;
412 maxp = (double *) dmaxreal;
413 rp = (long *) &(cp->constant.cd[0]);
414 x.q.word1 = rp[0];
415 x.q.word2 = rp[1];
416 if (x.f.sign == 1 && x.f.exp == 0)
417 {
418 p = (expptr) mkconst(TYREAL);
419 rp = (long *) &(p->constblock.constant.cd[0]);
420 rp[0] = x.q.word1;
421 }
422 else if (x.d >= *minp && x.d <= *maxp)
423 {
424 p = (expptr) mkconst(TYREAL);
425 y = x.d;
426 p->constblock.constant.cd[0] = y;
427 }
428 else
429 {
430 if (badvalue <= 1)
431 {
432 badvalue = 2;
433 err(toobig);
434 }
435 p = errnode();
436 }
437 break;
438
439 case TYLOGICAL:
440 if (badvalue <= 1)
441 {
442 badvalue = 2;
443 err(compat1);
444 }
445 p = errnode();
446 break;
447
448 case TYCHAR:
449 if ( !ftn66flag && badvalue == 0)
450 {
451 badvalue = 1;
452 warn(compat2);
453 }
454
455 case TYHOLLERITH:
456 longp = (long *) grabbytes(4, cp);
457 p = (expptr) mkconst(TYREAL);
458 rp = (long *) &(p->constblock.constant.cd[0]);
459 rp[0] = *longp;
460 free((char *) longp);
461 break;
462
463 case TYERROR:
464 p = errnode();
465 break;
466 }
467
468 return (p);
469 }
470
471
472
473 LOCAL expptr
cdreal(cp)474 cdreal(cp)
475 Constp cp;
476 {
477 static char *compat1 =
478 "logical datum assigned to a double precision variable";
479 static char *compat2 =
480 "character datum assigned to a double precision variable";
481
482 register expptr p;
483 register long *longp;
484 register long *rp;
485
486 switch (cp->vtype)
487 {
488 case TYBITSTR:
489 longp = (long *) grabbits(8, cp);
490 p = (expptr) mkconst(TYDREAL);
491 rp = (long *) &(p->constblock.constant.cd[0]);
492 rp[0] = longp[0];
493 rp[1] = longp[1];
494 free((char *) longp);
495 break;
496
497 case TYSHORT:
498 case TYLONG:
499 p = (expptr) mkconst(TYDREAL);
500 p->constblock.constant.cd[0] = cp->constant.ci;
501 break;
502
503 case TYREAL:
504 case TYDREAL:
505 case TYCOMPLEX:
506 case TYDCOMPLEX:
507 p = (expptr) mkconst(TYDREAL);
508 longp = (long *) &(cp->constant.cd[0]);
509 rp = (long *) &(p->constblock.constant.cd[0]);
510 rp[0] = longp[0];
511 rp[1] = longp[1];
512 break;
513
514 case TYLOGICAL:
515 if (badvalue <= 1)
516 {
517 badvalue = 2;
518 err(compat1);
519 }
520 p = errnode();
521 break;
522
523 case TYCHAR:
524 if ( !ftn66flag && badvalue == 0 )
525 {
526 badvalue = 1;
527 warn(compat2);
528 }
529
530 case TYHOLLERITH:
531 longp = (long *) grabbytes(8, cp);
532 p = (expptr) mkconst(TYDREAL);
533 rp = (long *) &(p->constblock.constant.cd[0]);
534 rp[0] = longp[0];
535 rp[1] = longp[1];
536 free((char *) longp);
537 break;
538
539 case TYERROR:
540 p = errnode();
541 break;
542 }
543
544 return (p);
545 }
546
547
548
549 LOCAL expptr
ccomplex(cp)550 ccomplex(cp)
551 Constp cp;
552 {
553 static char *toobig = "data value too large";
554 static char *compat1 = "logical datum assigned to a complex variable";
555 static char *compat2 = "character datum assigned to a complex variable";
556
557 register expptr p;
558 register long *longp;
559 register long *rp;
560 register double *minp;
561 register double *maxp;
562 realvalue re, im;
563 int overflow;
564 float x;
565
566 switch (cp->vtype)
567 {
568 case TYBITSTR:
569 longp = (long *) grabbits(8, cp);
570 p = (expptr) mkconst(TYCOMPLEX);
571 rp = (long *) &(p->constblock.constant.cd[0]);
572 rp[0] = longp[0];
573 rp[2] = longp[1];
574 free((char *) longp);
575 break;
576
577 case TYSHORT:
578 case TYLONG:
579 p = (expptr) mkconst(TYCOMPLEX);
580 p->constblock.constant.cd[0] = cp->constant.ci;
581 break;
582
583 case TYREAL:
584 case TYDREAL:
585 case TYCOMPLEX:
586 case TYDCOMPLEX:
587 overflow = 0;
588 minp = (double *) dminreal;
589 maxp = (double *) dmaxreal;
590 rp = (long *) &(cp->constant.cd[0]);
591 re.q.word1 = rp[0];
592 re.q.word2 = rp[1];
593 im.q.word1 = rp[2];
594 im.q.word2 = rp[3];
595 if (((re.f.sign == 0 || re.f.exp != 0) &&
596 (re.d < *minp || re.d > *maxp)) ||
597 ((im.f.sign == 0 || re.f.exp != 0) &&
598 (im.d < *minp || re.d > *maxp)))
599 {
600 if (badvalue <= 1)
601 {
602 badvalue = 2;
603 err(toobig);
604 }
605 p = errnode();
606 }
607 else
608 {
609 p = (expptr) mkconst(TYCOMPLEX);
610 if (re.f.sign == 1 && re.f.exp == 0)
611 re.q.word2 = 0;
612 else
613 {
614 x = re.d;
615 re.d = x;
616 }
617 if (im.f.sign == 1 && im.f.exp == 0)
618 im.q.word2 = 0;
619 else
620 {
621 x = im.d;
622 im.d = x;
623 }
624 rp = (long *) &(p->constblock.constant.cd[0]);
625 rp[0] = re.q.word1;
626 rp[1] = re.q.word2;
627 rp[2] = im.q.word1;
628 rp[3] = im.q.word2;
629 }
630 break;
631
632 case TYLOGICAL:
633 if (badvalue <= 1)
634 {
635 badvalue = 2;
636 err(compat1);
637 }
638 break;
639
640 case TYCHAR:
641 if ( !ftn66flag && badvalue == 0)
642 {
643 badvalue = 1;
644 warn(compat2);
645 }
646
647 case TYHOLLERITH:
648 longp = (long *) grabbytes(8, cp);
649 p = (expptr) mkconst(TYCOMPLEX);
650 rp = (long *) &(p->constblock.constant.cd[0]);
651 rp[0] = longp[0];
652 rp[2] = longp[1];
653 free((char *) longp);
654 break;
655
656 case TYERROR:
657 p = errnode();
658 break;
659 }
660
661 return (p);
662 }
663
664
665
666 LOCAL expptr
cdcomplex(cp)667 cdcomplex(cp)
668 Constp cp;
669 {
670 static char *compat1 = "logical datum assigned to a complex variable";
671 static char *compat2 = "character datum assigned to a complex variable";
672
673 register expptr p;
674 register long *longp;
675 register long *rp;
676
677 switch (cp->vtype)
678 {
679 case TYBITSTR:
680 longp = (long *) grabbits(16, cp);
681 p = (expptr) mkconst(TYDCOMPLEX);
682 rp = (long *) &(p->constblock.constant.cd[0]);
683 rp[0] = longp[0];
684 rp[1] = longp[1];
685 rp[2] = longp[2];
686 rp[3] = longp[3];
687 free((char *) longp);
688 break;
689
690 case TYSHORT:
691 case TYLONG:
692 p = (expptr) mkconst(TYDCOMPLEX);
693 p->constblock.constant.cd[0] = cp->constant.ci;
694 break;
695
696 case TYREAL:
697 case TYDREAL:
698 case TYCOMPLEX:
699 case TYDCOMPLEX:
700 p = (expptr) mkconst(TYDCOMPLEX);
701 longp = (long *) &(cp->constant.cd[0]);
702 rp = (long *) &(p->constblock.constant.cd[0]);
703 rp[0] = longp[0];
704 rp[1] = longp[1];
705 rp[2] = longp[2];
706 rp[3] = longp[3];
707 break;
708
709 case TYLOGICAL:
710 if (badvalue <= 1)
711 {
712 badvalue = 2;
713 err(compat1);
714 }
715 p = errnode();
716 break;
717
718 case TYCHAR:
719 if ( !ftn66flag && badvalue == 0 )
720 {
721 badvalue = 1;
722 warn(compat2);
723 }
724
725 case TYHOLLERITH:
726 longp = (long *) grabbytes(16, cp);
727 p = (expptr) mkconst(TYDCOMPLEX);
728 rp = (long *) &(p->constblock.constant.cd[0]);
729 rp[0] = longp[0];
730 rp[1] = longp[1];
731 rp[2] = longp[2];
732 rp[3] = longp[3];
733 free((char *) longp);
734 break;
735
736 case TYERROR:
737 p = errnode();
738 break;
739 }
740
741 return (p);
742 }
743
744
745
746 LOCAL expptr
clogical(cp)747 clogical(cp)
748 Constp cp;
749 {
750 static char *compat1 = "numeric datum assigned to a logical variable";
751 static char *compat2 = "character datum assigned to a logical variable";
752
753 register expptr p;
754 register long *longp;
755 register short *shortp;
756 register int size;
757
758 size = typesize[tylogical];
759
760 switch (cp->vtype)
761 {
762 case TYBITSTR:
763 p = (expptr) mkconst(tylogical);
764 if (tylogical == TYSHORT)
765 {
766 shortp = (short *) grabbits(size, cp);
767 p->constblock.constant.ci = (int) *shortp;
768 free((char *) shortp);
769 }
770 else
771 {
772 longp = (long *) grabbits(size, cp);
773 p->constblock.constant.ci = *longp;
774 free((char *) longp);
775 }
776 break;
777
778 case TYSHORT:
779 case TYLONG:
780 case TYREAL:
781 case TYDREAL:
782 case TYCOMPLEX:
783 case TYDCOMPLEX:
784 if (badvalue <= 1)
785 {
786 badvalue = 2;
787 err(compat1);
788 }
789 p = errnode();
790 break;
791
792 case TYLOGICAL:
793 p = (expptr) cpexpr(cp);
794 p->constblock.vtype = tylogical;
795 break;
796
797 case TYCHAR:
798 if ( !ftn66flag && badvalue == 0 )
799 {
800 badvalue = 1;
801 warn(compat2);
802 }
803
804 case TYHOLLERITH:
805 p = (expptr) mkconst(tylogical);
806 if (tylogical == TYSHORT)
807 {
808 shortp = (short *) grabbytes(size, cp);
809 p->constblock.constant.ci = (int) *shortp;
810 free((char *) shortp);
811 }
812 else
813 {
814 longp = (long *) grabbytes(4, cp);
815 p->constblock.constant.ci = *longp;
816 free((char *) longp);
817 }
818 break;
819
820 case TYERROR:
821 p = errnode();
822 break;
823 }
824
825 return (p);
826 }
827
828
829
830 LOCAL expptr
cchar(len,cp)831 cchar(len, cp)
832 int len;
833 Constp cp;
834 {
835 static char *compat1 = "numeric datum assigned to a character variable";
836 static char *compat2 = "logical datum assigned to a character variable";
837
838 register expptr p;
839 register char *value;
840
841 switch (cp->vtype)
842 {
843 case TYBITSTR:
844 value = grabbits(len, cp);
845 p = (expptr) mkstrcon(len, value);
846 free(value);
847 break;
848
849 case TYSHORT:
850 case TYLONG:
851 case TYREAL:
852 case TYDREAL:
853 case TYCOMPLEX:
854 case TYDCOMPLEX:
855 if (badvalue <= 1)
856 {
857 badvalue = 2;
858 err(compat1);
859 }
860 p = errnode();
861 break;
862
863 case TYLOGICAL:
864 if (badvalue <= 1)
865 {
866 badvalue = 2;
867 err(compat2);
868 }
869 p = errnode();
870 break;
871
872 case TYCHAR:
873 case TYHOLLERITH:
874 value = grabbytes(len, cp);
875 p = (expptr) mkstrcon(len, value);
876 free(value);
877 break;
878
879 case TYERROR:
880 p = errnode();
881 break;
882 }
883
884 return (p);
885 }
886
887
888
889 expptr
convconst(type,len,constant)890 convconst(type, len, constant)
891 int type;
892 int len;
893 Constp constant;
894 {
895 register expptr p;
896
897 switch (type)
898 {
899 case TYSHORT:
900 p = cshort(constant);
901 break;
902
903 case TYLONG:
904 p = clong(constant);
905 break;
906
907 case TYREAL:
908 p = creal(constant);
909 break;
910
911 case TYDREAL:
912 p = cdreal(constant);
913 break;
914
915 case TYCOMPLEX:
916 p = ccomplex(constant);
917 break;
918
919 case TYDCOMPLEX:
920 p = cdcomplex(constant);
921 break;
922
923 case TYLOGICAL:
924 p = clogical(constant);
925 break;
926
927 case TYCHAR:
928 p = cchar(len, constant);
929 break;
930
931 case TYERROR:
932 case TYUNKNOWN:
933 p = errnode();
934 break;
935
936 default:
937 badtype("convconst", type);
938 }
939
940 return (p);
941 }
942