Return to rdfmt.c CVS log

Up to [Research Unix] / researchv10no / libI77

Annotation of researchv10no/libI77/rdfmt.c, revision 1.1

1.1     ! root        1: #include "f2c.h"
        !             2: #include "fio.h"
        !             3: #include "fmt.h"
        !             4: #include "fp.h"
        !             5: 
        !             6: extern int f__cursor;
        !             7: #ifdef KR_headers
        !             8: extern double atof();
        !             9: #else
        !            10: #undef abs
        !            11: #undef min
        !            12: #undef max
        !            13: #include "stdlib.h"
        !            14: #endif
        !            15: 
        !            16:  static int
        !            17: #ifdef KR_headers
        !            18: rd_Z(n,w,len) Uint *n; ftnlen len;
        !            19: #else
        !            20: rd_Z(Uint *n, int w, ftnlen len)
        !            21: #endif
        !            22: {
        !            23:        long x[9];
        !            24:        char *s, *s0, *s1, *se, *t;
        !            25:        int ch, i, w1, w2;
        !            26:        static char hex[256];
        !            27:        static int one = 1;
        !            28:        int bad = 0;
        !            29: 
        !            30:        if (!hex['0']) {
        !            31:                s = "0123456789";
        !            32:                while(ch = *s++)
        !            33:                        hex[ch] = ch - '0' + 1;
        !            34:                s = "ABCDEF";
        !            35:                while(ch = *s++)
        !            36:                        hex[ch] = hex[ch + 'a' - 'A'] = ch - 'A' + 11;
        !            37:                }
        !            38:        s = s0 = (char *)x;
        !            39:        s1 = (char *)&x[4];
        !            40:        se = (char *)&x[8];
        !            41:        if (len > 4*sizeof(long))
        !            42:                return errno = 117;
        !            43:        while (w) {
        !            44:                GET(ch);
        !            45:                if (ch==',' || ch=='\n')
        !            46:                        break;
        !            47:                w--;
        !            48:                if (ch > ' ') {
        !            49:                        if (!hex[ch & 0xff])
        !            50:                                bad++;
        !            51:                        *s++ = ch;
        !            52:                        if (s == se) {
        !            53:                                /* discard excess characters */
        !            54:                                for(t = s0, s = s1; t < s1;)
        !            55:                                        *t++ = *s++;
        !            56:                                s = s1;
        !            57:                                }
        !            58:                        }
        !            59:                }
        !            60:        if (bad)
        !            61:                return errno = 115;
        !            62:        w = (int)len;
        !            63:        w1 = s - s0;
        !            64:        w2 = w1+1 >> 1;
        !            65:        t = (char *)n;
        !            66:        if (*(char *)&one) {
        !            67:                /* little endian */
        !            68:                t += w - 1;
        !            69:                i = -1;
        !            70:                }
        !            71:        else
        !            72:                i = 1;
        !            73:        for(; w > w2; t += i, --w)
        !            74:                *t = 0;
        !            75:        if (!w)
        !            76:                return 0;
        !            77:        if (w < w2)
        !            78:                s0 = s - (w << 1);
        !            79:        else if (w1 & 1) {
        !            80:                *t = hex[*s0++ & 0xff] - 1;
        !            81:                if (!--w)
        !            82:                        return 0;
        !            83:                t += i;
        !            84:                }
        !            85:        do {
        !            86:                *t = hex[*s0 & 0xff]-1 << 4 | hex[s0[1] & 0xff]-1;
        !            87:                t += i;
        !            88:                s0 += 2;
        !            89:                }
        !            90:                while(--w);
        !            91:        return 0;
        !            92:        }
        !            93: 
        !            94:  static int
        !            95: #ifdef KR_headers
        !            96: rd_I(n,w,len, base) Uint *n; int w; ftnlen len; register int base;
        !            97: #else
        !            98: rd_I(Uint *n, int w, ftnlen len, register int base)
        !            99: #endif
        !           100: {      long x;
        !           101:        int sign,ch;
        !           102:        char s[84], *ps;
        !           103:        ps=s; x=0;
        !           104:        while (w)
        !           105:        {
        !           106:                GET(ch);
        !           107:                if (ch==',' || ch=='\n') break;
        !           108:                *ps=ch; ps++; w--;
        !           109:        }
        !           110:        *ps='\0';
        !           111:        ps=s;
        !           112:        while (*ps==' ') ps++;
        !           113:        if (*ps=='-') { sign=1; ps++; }
        !           114:        else { sign=0; if (*ps=='+') ps++; }
        !           115: loop:  while (*ps>='0' && *ps<='9') { x=x*base+(*ps-'0'); ps++; }
        !           116:        if (*ps==' ') {if (f__cblank) x *= base; ps++; goto loop;}
        !           117:        if(sign) x = -x;
        !           118:        if(len==sizeof(integer)) n->il=x;
        !           119:        else if(len == sizeof(char)) n->ic = (char)x;
        !           120: #ifdef Allow_TYQUAD
        !           121:        else if (len == sizeof(longint)) n->ili = x;
        !           122: #endif
        !           123:        else n->is = (short)x;
        !           124:        if (*ps) return(errno=115); else return(0);
        !           125: }
        !           126:  static int
        !           127: #ifdef KR_headers
        !           128: rd_L(n,w,len) ftnint *n; ftnlen len;
        !           129: #else
        !           130: rd_L(ftnint *n, int w, ftnlen len)
        !           131: #endif
        !           132: {      int ch, lv;
        !           133:        char s[84], *ps;
        !           134:        ps=s;
        !           135:        while (w) {
        !           136:                GET(ch);
        !           137:                if (ch==','||ch=='\n') break;
        !           138:                *ps=ch;
        !           139:                ps++; w--;
        !           140:                }
        !           141:        *ps='\0';
        !           142:        ps=s; while (*ps==' ') ps++;
        !           143:        if (*ps=='.') ps++;
        !           144:        if (*ps=='t' || *ps == 'T')
        !           145:                lv = 1;
        !           146:        else if (*ps == 'f' || *ps == 'F')
        !           147:                lv = 0;
        !           148:        else return(errno=116);
        !           149:        switch(len) {
        !           150:                case sizeof(char):      *(char *)n = (char)lv;   break;
        !           151:                case sizeof(short):     *(short *)n = (short)lv; break;
        !           152:                default:                *n = lv;
        !           153:                }
        !           154:        return 0;
        !           155: }
        !           156: 
        !           157: #include "ctype.h"
        !           158: 
        !           159:  static int
        !           160: #ifdef KR_headers
        !           161: rd_F(p, w, d, len) ufloat *p; ftnlen len;
        !           162: #else
        !           163: rd_F(ufloat *p, int w, int d, ftnlen len)
        !           164: #endif
        !           165: {
        !           166:        char s[FMAX+EXPMAXDIGS+4];
        !           167:        register int ch;
        !           168:        register char *sp, *spe, *sp1;
        !           169:        double x;
        !           170:        int scale1, se;
        !           171:        long e, exp;
        !           172: 
        !           173:        sp1 = sp = s;
        !           174:        spe = sp + FMAX;
        !           175:        exp = -d;
        !           176:        x = 0.;
        !           177: 
        !           178:        do {
        !           179:                GET(ch);
        !           180:                w--;
        !           181:                } while (ch == ' ' && w);
        !           182:        switch(ch) {
        !           183:                case '-': *sp++ = ch; sp1++; spe++;
        !           184:                case '+':
        !           185:                        if (!w) goto zero;
        !           186:                        --w;
        !           187:                        GET(ch);
        !           188:                }
        !           189:        while(ch == ' ') {
        !           190: blankdrop:
        !           191:                if (!w--) goto zero; GET(ch); }
        !           192:        while(ch == '0')
        !           193:                { if (!w--) goto zero; GET(ch); }
        !           194:        if (ch == ' ' && f__cblank)
        !           195:                goto blankdrop;
        !           196:        scale1 = f__scale;
        !           197:        while(isdigit(ch)) {
        !           198: digloop1:
        !           199:                if (sp < spe) *sp++ = ch;
        !           200:                else ++exp;
        !           201: digloop1e:
        !           202:                if (!w--) goto done;
        !           203:                GET(ch);
        !           204:                }
        !           205:        if (ch == ' ') {
        !           206:                if (f__cblank)
        !           207:                        { ch = '0'; goto digloop1; }
        !           208:                goto digloop1e;
        !           209:                }
        !           210:        if (ch == '.') {
        !           211:                exp += d;
        !           212:                if (!w--) goto done;
        !           213:                GET(ch);
        !           214:                if (sp == sp1) { /* no digits yet */
        !           215:                        while(ch == '0') {
        !           216: skip01:
        !           217:                                --exp;
        !           218: skip0:
        !           219:                                if (!w--) goto done;
        !           220:                                GET(ch);
        !           221:                                }
        !           222:                        if (ch == ' ') {
        !           223:                                if (f__cblank) goto skip01;
        !           224:                                goto skip0;
        !           225:                                }
        !           226:                        }
        !           227:                while(isdigit(ch)) {
        !           228: digloop2:
        !           229:                        if (sp < spe)
        !           230:                                { *sp++ = ch; --exp; }
        !           231: digloop2e:
        !           232:                        if (!w--) goto done;
        !           233:                        GET(ch);
        !           234:                        }
        !           235:                if (ch == ' ') {
        !           236:                        if (f__cblank)
        !           237:                                { ch = '0'; goto digloop2; }
        !           238:                        goto digloop2e;
        !           239:                        }
        !           240:                }
        !           241:        switch(ch) {
        !           242:          default:
        !           243:                break;
        !           244:          case '-': se = 1; goto signonly;
        !           245:          case '+': se = 0; goto signonly;
        !           246:          case 'e':
        !           247:          case 'E':
        !           248:          case 'd':
        !           249:          case 'D':
        !           250:                if (!w--)
        !           251:                        goto bad;
        !           252:                GET(ch);
        !           253:                while(ch == ' ') {
        !           254:                        if (!w--)
        !           255:                                goto bad;
        !           256:                        GET(ch);
        !           257:                        }
        !           258:                se = 0;
        !           259:                switch(ch) {
        !           260:                  case '-': se = 1;
        !           261:                  case '+':
        !           262: signonly:
        !           263:                        if (!w--)
        !           264:                                goto bad;
        !           265:                        GET(ch);
        !           266:                        }
        !           267:                while(ch == ' ') {
        !           268:                        if (!w--)
        !           269:                                goto bad;
        !           270:                        GET(ch);
        !           271:                        }
        !           272:                if (!isdigit(ch))
        !           273:                        goto bad;
        !           274: 
        !           275:                e = ch - '0';
        !           276:                for(;;) {
        !           277:                        if (!w--)
        !           278:                                { ch = '\n'; break; }
        !           279:                        GET(ch);
        !           280:                        if (!isdigit(ch)) {
        !           281:                                if (ch == ' ') {
        !           282:                                        if (f__cblank)
        !           283:                                                ch = '0';
        !           284:                                        else continue;
        !           285:                                        }
        !           286:                                else
        !           287:                                        break;
        !           288:                                }
        !           289:                        e = 10*e + ch - '0';
        !           290:                        if (e > EXPMAX && sp > sp1)
        !           291:                                goto bad;
        !           292:                        }
        !           293:                if (se)
        !           294:                        exp -= e;
        !           295:                else
        !           296:                        exp += e;
        !           297:                scale1 = 0;
        !           298:                }
        !           299:        switch(ch) {
        !           300:          case '\n':
        !           301:          case ',':
        !           302:                break;
        !           303:          default:
        !           304: bad:
        !           305:                return (errno = 115);
        !           306:                }
        !           307: done:
        !           308:        if (sp > sp1) {
        !           309:                while(*--sp == '0')
        !           310:                        ++exp;
        !           311:                if (exp -= scale1)
        !           312:                        sprintf(sp+1, "e%ld", exp);
        !           313:                else
        !           314:                        sp[1] = 0;
        !           315:                x = atof(s);
        !           316:                }
        !           317: zero:
        !           318:        if (len == sizeof(real))
        !           319:                p->pf = x;
        !           320:        else
        !           321:                p->pd = x;
        !           322:        return(0);
        !           323:        }
        !           324: 
        !           325: 
        !           326:  static int
        !           327: #ifdef KR_headers
        !           328: rd_A(p,len) char *p; ftnlen len;
        !           329: #else
        !           330: rd_A(char *p, ftnlen len)
        !           331: #endif
        !           332: {      int i,ch;
        !           333:        for(i=0;i<len;i++)
        !           334:        {       GET(ch);
        !           335:                *p++=VAL(ch);
        !           336:        }
        !           337:        return(0);
        !           338: }
        !           339:  static int
        !           340: #ifdef KR_headers
        !           341: rd_AW(p,w,len) char *p; ftnlen len;
        !           342: #else
        !           343: rd_AW(char *p, int w, ftnlen len)
        !           344: #endif
        !           345: {      int i,ch;
        !           346:        if(w>=len)
        !           347:        {       for(i=0;i<w-len;i++)
        !           348:                        GET(ch);
        !           349:                for(i=0;i<len;i++)
        !           350:                {       GET(ch);
        !           351:                        *p++=VAL(ch);
        !           352:                }
        !           353:                return(0);
        !           354:        }
        !           355:        for(i=0;i<w;i++)
        !           356:        {       GET(ch);
        !           357:                *p++=VAL(ch);
        !           358:        }
        !           359:        for(i=0;i<len-w;i++) *p++=' ';
        !           360:        return(0);
        !           361: }
        !           362:  static int
        !           363: #ifdef KR_headers
        !           364: rd_H(n,s) char *s;
        !           365: #else
        !           366: rd_H(int n, char *s)
        !           367: #endif
        !           368: {      int i,ch;
        !           369:        for(i=0;i<n;i++)
        !           370:                if((ch=(*f__getn)())<0) return(ch);
        !           371:                else *s++ = ch=='\n'?' ':ch;
        !           372:        return(1);
        !           373: }
        !           374:  static int
        !           375: #ifdef KR_headers
        !           376: rd_POS(s) char *s;
        !           377: #else
        !           378: rd_POS(char *s)
        !           379: #endif
        !           380: {      char quote;
        !           381:        int ch;
        !           382:        quote= *s++;
        !           383:        for(;*s;s++)
        !           384:                if(*s==quote && *(s+1)!=quote) break;
        !           385:                else if((ch=(*f__getn)())<0) return(ch);
        !           386:                else *s = ch=='\n'?' ':ch;
        !           387:        return(1);
        !           388: }
        !           389: #ifdef KR_headers
        !           390: rd_ed(p,ptr,len) struct f__syl *p; char *ptr; ftnlen len;
        !           391: #else
        !           392: rd_ed(struct f__syl *p, char *ptr, ftnlen len)
        !           393: #endif
        !           394: {      int ch;
        !           395:        for(;f__cursor>0;f__cursor--) if((ch=(*f__getn)())<0) return(ch);
        !           396:        if(f__cursor<0)
        !           397:        {       if(f__recpos+f__cursor < 0) /*err(elist->cierr,110,"fmt")*/
        !           398:                        f__cursor = -f__recpos; /* is this in the standard? */
        !           399:                if(f__external == 0) {
        !           400:                        extern char *f__icptr;
        !           401:                        f__icptr += f__cursor;
        !           402:                }
        !           403:                else if(f__curunit && f__curunit->useek)
        !           404:                        (void) fseek(f__cf,(long) f__cursor,SEEK_CUR);
        !           405:                else
        !           406:                        err(f__elist->cierr,106,"fmt");
        !           407:                f__recpos += f__cursor;
        !           408:                f__cursor=0;
        !           409:        }
        !           410:        switch(p->op)
        !           411:        {
        !           412:        default: fprintf(stderr,"rd_ed, unexpected code: %d\n", p->op);
        !           413:                sig_die(f__fmtbuf, 1);
        !           414:        case IM:
        !           415:        case I: ch = rd_I((Uint *)ptr,p->p1,len, 10);
        !           416:                break;
        !           417: 
        !           418:                /* O and OM don't work right for character, double, complex, */
        !           419:                /* or doublecomplex, and they differ from Fortran 90 in */
        !           420:                /* showing a minus sign for negative values. */
        !           421: 
        !           422:        case OM:
        !           423:        case O: ch = rd_I((Uint *)ptr, p->p1, len, 8);
        !           424:                break;
        !           425:        case L: ch = rd_L((ftnint *)ptr,p->p1,len);
        !           426:                break;
        !           427:        case A: ch = rd_A(ptr,len);
        !           428:                break;
        !           429:        case AW:
        !           430:                ch = rd_AW(ptr,p->p1,len);
        !           431:                break;
        !           432:        case E: case EE:
        !           433:        case D:
        !           434:        case G:
        !           435:        case GE:
        !           436:        case F: ch = rd_F((ufloat *)ptr,p->p1,p->p2,len);
        !           437:                break;
        !           438: 
        !           439:                /* Z and ZM assume 8-bit bytes. */
        !           440: 
        !           441:        case ZM:
        !           442:        case Z:
        !           443:                ch = rd_Z((Uint *)ptr, p->p1, len);
        !           444:                break;
        !           445:        }
        !           446:        if(ch == 0) return(ch);
        !           447:        else if(ch == EOF) return(EOF);
        !           448:        if (f__cf)
        !           449:                clearerr(f__cf);
        !           450:        return(errno);
        !           451: }
        !           452: #ifdef KR_headers
        !           453: rd_ned(p) struct f__syl *p;
        !           454: #else
        !           455: rd_ned(struct f__syl *p)
        !           456: #endif
        !           457: {
        !           458:        switch(p->op)
        !           459:        {
        !           460:        default: fprintf(stderr,"rd_ned, unexpected code: %d\n", p->op);
        !           461:                sig_die(f__fmtbuf, 1);
        !           462:        case APOS:
        !           463:                return(rd_POS(*(char **)&p->p2));
        !           464:        case H: return(rd_H(p->p1,*(char **)&p->p2));
        !           465:        case SLASH: return((*f__donewrec)());
        !           466:        case TR:
        !           467:        case X: f__cursor += p->p1;
        !           468:                return(1);
        !           469:        case T: f__cursor=p->p1-f__recpos - 1;
        !           470:                return(1);
        !           471:        case TL: f__cursor -= p->p1;
        !           472:                if(f__cursor < -f__recpos)      /* TL1000, 1X */
        !           473:                        f__cursor = -f__recpos;
        !           474:                return(1);
        !           475:        }
        !           476: }

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.