Return to fmt.c CVS log

Up to [CSRG BSD Unix] / 43BSD / usr.lib / libI77

Annotation of 43BSD/usr.lib/libI77/fmt.c, revision 1.1

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:  *     @(#)fmt.c       5.1     6/7/85
        !             7:  */
        !             8: 
        !             9: /*
        !            10:  * fortran format parser
        !            11:  */
        !            12: 
        !            13: #include "fio.h"
        !            14: #include "format.h"
        !            15: 
        !            16: #define isdigit(x)     (x>='0' && x<='9')
        !            17: #define isspace(s)     (s==' ')
        !            18: #define skip(s)                while(isspace(*s)) s++
        !            19: 
        !            20: #ifdef interdata
        !            21: #define SYLMX 300
        !            22: #endif
        !            23: 
        !            24: #ifdef pdp11
        !            25: #define SYLMX 300
        !            26: #endif
        !            27: 
        !            28: #ifdef vax
        !            29: #define SYLMX 300
        !            30: #endif
        !            31: 
        !            32: LOCAL struct syl syl_vec[SYLMX];
        !            33: struct syl *syl_ptr;
        !            34: LOCAL int parenlvl,revloc;
        !            35: int low_case[256];
        !            36: short pc;
        !            37: char *f_s(), *f_list(), *i_tem(), *gt_num(), *ap_end();
        !            38: char *s_init;
        !            39: 
        !            40: pars_f()
        !            41: {
        !            42:        short *s_ptr;
        !            43:        long  *l_ptr;
        !            44:        int i;
        !            45: 
        !            46:        /* first time, initialize low_case[] */
        !            47:        if( low_case[1] == 0 ) {
        !            48:            for(i = 0; i<256; i++) low_case[i]=i;
        !            49:            for(i = 'A'; i<='Z'; i++) low_case[i]=i-'A'+'a';
        !            50:        }
        !            51: 
        !            52:        parenlvl=revloc=pc=0;
        !            53: 
        !            54:        s_ptr = (short *) fmtbuf;
        !            55:        if( *s_ptr == FMT_COMP ) {
        !            56:                /* already compiled - copy value of pc */
        !            57:                pc = *(s_ptr+1);
        !            58:                /* get address of the format */
        !            59:                l_ptr = (long *) fmtbuf;
        !            60:                fmtbuf = s_init = (char *) *(l_ptr+1);
        !            61:                /* point syl_ptr to the compiled format */
        !            62:                syl_ptr = (struct syl *) (l_ptr + 2);
        !            63:                return(OK);
        !            64:        } else {
        !            65:                syl_ptr = syl_vec;
        !            66:                s_init = fmtbuf;
        !            67:                return((f_s(fmtbuf,0)==FMTERR)? ERROR : OK);
        !            68:        }
        !            69: }
        !            70: 
        !            71: LOCAL
        !            72: char *f_s(s,curloc) char *s;
        !            73: {
        !            74:        skip(s);
        !            75:        if(*s++!='(')
        !            76:        {
        !            77:                fmtptr = s;
        !            78:                return(FMTERR);
        !            79:        }
        !            80:        if(parenlvl++ ==1) revloc=curloc;
        !            81:        op_gen(RET,curloc,0,0,s);
        !            82:        if((s=f_list(s))==FMTERR)
        !            83:        {
        !            84:                return(FMTERR);
        !            85:        }
        !            86:        skip(s);
        !            87:        return(s);
        !            88: }
        !            89: 
        !            90: LOCAL
        !            91: char *f_list(s) char *s;
        !            92: {
        !            93:        while (*s)
        !            94:        {       skip(s);
        !            95:                if((s=i_tem(s))==FMTERR) return(FMTERR);
        !            96:                skip(s);
        !            97:                if(*s==',') s++;
        !            98:                else if(*s==')')
        !            99:                {       if(--parenlvl==0)
        !           100:                                op_gen(REVERT,revloc,0,0,s);
        !           101:                        else
        !           102:                                op_gen(GOTO,0,0,0,s);
        !           103:                        return(++s);
        !           104:                }
        !           105:        }
        !           106:        fmtptr = s;
        !           107:        return(FMTERR);
        !           108: }
        !           109: 
        !           110: LOCAL
        !           111: char *i_tem(s) char *s;
        !           112: {      char *t;
        !           113:        int n,curloc;
        !           114:        if(*s==')') return(s);
        !           115:        if ((n=ne_d(s,&t))==FMTOK)
        !           116:                return(t);
        !           117:        else if (n==FMTERR)
        !           118:                return(FMTERR);
        !           119:        if ((n=e_d(s,&t))==FMTOK)
        !           120:                return(t);
        !           121:        else if (n==FMTERR)
        !           122:                return(FMTERR);
        !           123:        s=gt_num(s,&n);
        !           124:        if (n == 0) { fmtptr = s; return(FMTERR); }
        !           125:        curloc = op_gen(STACK,n,0,0,s);
        !           126:        return(f_s(s,curloc));
        !           127: }
        !           128: 
        !           129: LOCAL
        !           130: ne_d(s,p) char *s,**p;
        !           131: {      int n,x,sign=0,pp1,pp2;
        !           132:        switch(low_case[*s])
        !           133:        {
        !           134:        case ':': op_gen(COLON,(int)('\n'),0,0,s); break;
        !           135: #ifndef KOSHER
        !           136:        case '$': op_gen(DOLAR,(int)('\0'),0,0,s); break;  /*** NOT STANDARD FORTRAN ***/
        !           137: #endif
        !           138:        case 'b':
        !           139:                switch(low_case[*(s+1)])
        !           140:                {
        !           141:                        case 'n': s++; op_gen(BNZ,0,0,0,s); break;
        !           142:                        case 'z': s++; op_gen(BNZ,1,0,0,s); break;
        !           143: #ifndef KOSHER
        !           144:                        default: op_gen(B,0,0,0,s); break;  /*** NOT STANDARD FORTRAN ***/
        !           145: #else
        !           146:                        default: fmtptr = s; return(FMTUNKN);
        !           147: #endif
        !           148:                }
        !           149:                break;
        !           150:        case 's':
        !           151:                switch(low_case[*(s+1)])
        !           152:                {
        !           153:                        case 'p': s++; x=SP; pp1=1; pp2=1; break;
        !           154: #ifndef KOSHER
        !           155:                        case 'u': s++; x=SU; pp1=0; pp2=0; break;  /*** NOT STANDARD FORTRAN ***/
        !           156: #endif
        !           157:                        case 's': s++; x=SS; pp1=0; pp2=1; break;
        !           158:                        default:  x=S; pp1=0; pp2=1; break;
        !           159:                }
        !           160:                op_gen(x,pp1,pp2,0,s);
        !           161:                break;
        !           162:        case '/': op_gen(SLASH,0,0,0,s); break;
        !           163: 
        !           164:        case '-': sign=1;       /* OUTRAGEOUS CODING */
        !           165:        case '+': s++;          /* OUTRAGEOUS CODING */
        !           166:        case '0': case '1': case '2': case '3': case '4':
        !           167:        case '5': case '6': case '7': case '8': case '9':
        !           168:                s=gt_num(s,&n);
        !           169:                switch(low_case[*s])
        !           170:                {
        !           171:                case 'p': if(sign) n= -n; op_gen(P,n,0,0,s); break;
        !           172: #ifndef KOSHER
        !           173:                case 'r': if(n<=1)              /*** NOT STANDARD FORTRAN ***/
        !           174:                        {       fmtptr = --s; return(FMTERR); }
        !           175:                        op_gen(R,n,0,0,s); break;
        !           176:                case 't': op_gen(T,0,n,0,s); break;     /* NOT STANDARD FORT */
        !           177: #endif
        !           178:                case 'x': op_gen(X,n,0,0,s); break;
        !           179:                case 'h': op_gen(H,n,(s+1)-s_init,0,s);
        !           180:                        s+=n;
        !           181:                        break;
        !           182:                default: fmtptr = s; return(FMTUNKN);
        !           183:                }
        !           184:                break;
        !           185:        case GLITCH:
        !           186:        case '"':
        !           187:        case '\'': op_gen(APOS,s-s_init,0,0,s);
        !           188:                *p = ap_end(s);
        !           189:                return(FMTOK);
        !           190:        case 't':
        !           191:                switch(low_case[*(s+1)])
        !           192:                {
        !           193:                        case 'l': s++; x=TL; break;
        !           194:                        case 'r': s++; x=TR; break;
        !           195:                        default:  x=T; break;
        !           196:                }
        !           197:                if(isdigit(*(s+1))) {s=gt_num(s+1,&n); s--;}
        !           198: #ifdef KOSHER
        !           199:                else { fmtptr = s; return(FMTERR); }
        !           200: #else
        !           201:                else n = 0;     /* NOT STANDARD FORTRAN, should be error */
        !           202: #endif
        !           203:                op_gen(x,n,1,0,s);
        !           204:                break;
        !           205:        case 'x': op_gen(X,1,0,0,s); break;
        !           206:        case 'p': op_gen(P,0,0,0,s); break;
        !           207: #ifndef KOSHER
        !           208:        case 'r': op_gen(R,10,1,0,s); break;  /*** NOT STANDARD FORTRAN ***/
        !           209: #endif
        !           210: 
        !           211:        default: fmtptr = s; return(FMTUNKN);
        !           212:        }
        !           213:        s++;
        !           214:        *p=s;
        !           215:        return(FMTOK);
        !           216: }
        !           217: 
        !           218: LOCAL
        !           219: e_d(s,p) char *s,**p;
        !           220: {      int n,w,d,e,x=0, rep_count;
        !           221:        char *sv=s;
        !           222:        char c;
        !           223:        s=gt_num(s,&rep_count);
        !           224:        if (rep_count == 0) goto ed_err;
        !           225:        c = low_case[*s]; s++;
        !           226:        switch(c)
        !           227:        {
        !           228:        case 'd':
        !           229:        case 'e':
        !           230:        case 'g':
        !           231:                s = gt_num(s, &w);
        !           232:                if (w==0) goto ed_err;
        !           233:                if(*s=='.')
        !           234:                {       s++;
        !           235:                        s=gt_num(s,&d);
        !           236:                }
        !           237:                else d=0;
        !           238:                if(low_case[*s] == 'e'
        !           239: #ifndef KOSHER
        !           240:                || *s == '.'             /*** '.' is NOT STANDARD FORTRAN ***/
        !           241: #endif
        !           242:                )
        !           243:                {       s++;
        !           244:                        s=gt_num(s,&e);
        !           245:                        if (e==0 || e>127 || d>127 ) goto ed_err;
        !           246:                        if(c=='e') n=EE; else if(c=='d') n=DE; else n=GE;
        !           247:                        op_gen(n,w,d + (e<<8),rep_count,s);
        !           248:                }
        !           249:                else
        !           250:                {
        !           251:                        if(c=='e') n=E; else if(c=='d') n=D; else n=G;
        !           252:                        op_gen(n,w,d,rep_count,s);
        !           253:                }
        !           254:                break;
        !           255:        case 'l':
        !           256:                s = gt_num(s, &w);
        !           257:                if (w==0) goto ed_err;
        !           258:                op_gen(L,w,0,rep_count,s);
        !           259:                break;
        !           260:        case 'a':
        !           261:                skip(s);
        !           262:                if(isdigit(*s))
        !           263:                {       s=gt_num(s,&w);
        !           264: #ifdef KOSHER
        !           265:                        if (w==0) goto ed_err;
        !           266: #else
        !           267:                        if (w==0) op_gen(A,0,0,rep_count,s);
        !           268:                        else
        !           269: #endif
        !           270:                        op_gen(AW,w,0,rep_count,s);
        !           271:                        break;
        !           272:                }
        !           273:                op_gen(A,0,0,rep_count,s);
        !           274:                break;
        !           275:        case 'f':
        !           276:                s = gt_num(s, &w);
        !           277:                if (w==0) goto ed_err;
        !           278:                if(*s=='.')
        !           279:                {       s++;
        !           280:                        s=gt_num(s,&d);
        !           281:                }
        !           282:                else d=0;
        !           283:                op_gen(F,w,d,rep_count,s);
        !           284:                break;
        !           285: #ifndef        KOSHER
        !           286:        case 'o':       /*** octal format - NOT STANDARD FORTRAN ***/
        !           287:        case 'z':       /*** hex   format - NOT STANDARD FORTRAN ***/
        !           288: #endif
        !           289:        case 'i':
        !           290:                s = gt_num(s, &w);
        !           291:                if (w==0) goto ed_err;
        !           292:                if(*s =='.')
        !           293:                {
        !           294:                        s++;
        !           295:                        s=gt_num(s,&d);
        !           296:                        x = IM;
        !           297:                }
        !           298:                else
        !           299:                {       d = 1;
        !           300:                        x = I;
        !           301:                }
        !           302: #ifndef KOSHER
        !           303:                if (c == 'o')
        !           304:                        op_gen(R,8,1,rep_count,s);
        !           305:                else if (c == 'z')
        !           306:                        op_gen(R,16,1,rep_count,s);
        !           307: #endif
        !           308:                op_gen(x,w,d,rep_count,s);
        !           309: #ifndef KOSHER
        !           310:                if (c == 'o' || c == 'z')
        !           311:                        op_gen(R,10,1,rep_count,s);
        !           312: #endif
        !           313:                break;
        !           314:        default:
        !           315:                *p = sv;
        !           316:                fmtptr = s;
        !           317:                return(FMTUNKN);
        !           318:        }
        !           319:        *p = s;
        !           320:        return(FMTOK);
        !           321: ed_err:
        !           322:        fmtptr = --s;
        !           323:        return(FMTERR);
        !           324: }
        !           325: 
        !           326: LOCAL
        !           327: op_gen(a,b,c,rep,s) char *s;
        !           328: {      struct syl *p= &syl_ptr[pc];
        !           329:        if(pc>=SYLMX)
        !           330:        {       fmtptr = s;
        !           331:                fatal(F_ERFMT,"format too complex");
        !           332:        }
        !           333:        if( b>32767 || c>32767 || rep>32767 )
        !           334:        {       fmtptr = s;
        !           335:                fatal("field width or repeat count too large");
        !           336:        }
        !           337: #ifdef DEBUG
        !           338:        fprintf(stderr,"%3d opgen: %d %d %d %d %c\n",
        !           339:                pc,a,b,c,rep,*s==GLITCH?'"':*s); /* for debug */
        !           340: #endif
        !           341:        p->op=a;
        !           342:        p->p1=b;
        !           343:        p->p2=c;
        !           344:        p->rpcnt=rep;
        !           345:        return(pc++);
        !           346: }
        !           347: 
        !           348: LOCAL
        !           349: char *gt_num(s,n) char *s; int *n;
        !           350: {      int m=0,a_digit=NO;
        !           351:        skip(s);
        !           352:        while(isdigit(*s) || isspace(*s))
        !           353:        {
        !           354:                if (isdigit(*s))
        !           355:                {
        !           356:                        m = 10*m + (*s)-'0';
        !           357:                        a_digit = YES;
        !           358:                }
        !           359:                s++;
        !           360:        }
        !           361:        if(a_digit) *n=m;
        !           362:        else *n=1;
        !           363:        return(s);
        !           364: }
        !           365: 
        !           366: LOCAL
        !           367: char *ap_end(s) char *s;
        !           368: {
        !           369:        char quote;
        !           370:        quote = *s++;
        !           371:        for(;*s;s++)
        !           372:        {
        !           373:                if(*s==quote && *++s!=quote) return(s);
        !           374:        }
        !           375:        fmtptr = s;
        !           376:        fatal(F_ERFMT,"bad string");
        !           377: }

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