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