![[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.