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