# 2.11BSD#431 - /usr/src/usr.lib/libI77/fmt.c

##### Functions

    ap_end            X
    e_d               X
    f_list            X
    f_s               X
    gt_num            X
    i_tem             X
    ne_d              X
    op_gen            X
    pars_f            X

##### Variables

    low_case          X
    parenlvl          X
    pc                X
    revloc            X
    s_init            X
    syl_ptr           X
    syl_vec           X

##### Macros

    SYLMX             X
    isdigit           X
    isspace           X
    skip              X

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

#### Defined functions

ap_end defined in line 366; used 2 times

- in line 37, 188

e_d defined in line 218; used 1 times

- in line 119

f_list defined in line 90; used 2 times

- in line 37, 82

f_s defined in line 71; used 3 times

- in line 37, 67, 126

gt_num defined in line 348; used 14 times

- in line 37, 123, 168, 197, 223, 231-235(2), 244, 256, 263, 276-280(2), 290-295(2)

i_tem defined in line 110; used 2 times

- in line 37, 95

ne_d defined in line 129; used 1 times

- in line 115

op_gen defined in line 326; used 32 times

- in line 81, 100-102(2), 125, 134-144(5), 160-162(2), 171-179(5), 187, 203-208(4), 247-252(2), 258, 267-273(3), 283, 304-311(4)

pars_f defined in line 40; used 8 times

- in /usr/src/usr.lib/libI77/rdfe.c line 31
- in /usr/src/usr.lib/libI77/rfi.c line 36, 47
- in /usr/src/usr.lib/libI77/rsfe.c line 32
- in /usr/src/usr.lib/libI77/wdfe.c line 32
- in /usr/src/usr.lib/libI77/wfi.c line 36, 47
- in /usr/src/usr.lib/libI77/wsfe.c line 37

#### Defined variables

low_case defined in line 35; used 12 times

- in line 47-49(3), 132, 139, 151, 169, 191, 225, 238
- in /usr/src/usr.lib/libI77/rdfmt.c line 132, 151

parenlvl defined in line 34; used 3 times

- in line 52, 80, 99

pc defined in line 36; used 6 times

- in line 52-57(2), 328-329(2), 339, 345

revloc defined in line 34; used 3 times

- in line 52, 80, 100

s_init defined in line 38; used 8 times

- in line 60, 66, 179, 187
- in /usr/src/usr.lib/libI77/rdfmt.c line 65-67(2)
- in /usr/src/usr.lib/libI77/wrtfmt.c line 79-81(2)

syl_ptr defined in line 33; used 3 times

- in line 62-65(2), 328

syl_vec defined in line 32; used 1 times

- in line 65

#### Defined macros

SYLMX defined in line 29; used 2 times

- in line 32, 329

isdigit defined in line 16; used 4 times

- in line 197, 262, 352-354(2)

isspace defined in line 17; used 2 times

- in line 18, 352

skip defined in line 18; used 6 times

- in line 74, 86, 94-96(2), 261, 351

Last modified: 1987-02-18 Generated: 2016-12-26 | Generated by src2html V0.67 page hit count: 1327 |