Return to conv.c CVS log

Up to [CSRG BSD Unix] / 42BSD / usr.bin / f77 / src / f77pass1

Annotation of 42BSD/usr.bin/f77/src/f77pass1/conv.c, revision 1.1

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.