4.3BSD - /usr/src/usr.bin/f77/src/f77pass1/conv.c

   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: }

Defined functions

Defined variables