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