BSD 4_4 release

[unix-history] / usr / src / usr.bin / f77 / libI77 / rdfmt.c

/*-
* Copyright (c) 1980 The Regents of the University of California.
* All rights reserved.
*
* This module is believed to contain source code proprietary to AT&T.
* Use and redistribution is subject to the Berkeley Software License
* Agreement and your Software Agreement with AT&T (Western Electric).
*/

#ifndef lint
static char sccsid[] = "@(#)rdfmt.c     5.2 (Berkeley) 4/12/91";
#endif /* not lint */

/*
* formatted read routines
*/

#include "fio.h"
#include "format.h"

extern char *s_init;
extern int low_case[256];
extern int used_data;

rd_ed(p,ptr,len) char *ptr; struct syl *p; ftnlen len;
{       int n;
       if(cursor && (n=rd_mvcur())) return(n);
       switch(p->op)
       {
       case I:
       case IM:
               n = (rd_I(ptr,p->p1,len));
               break;
       case L:
               n = (rd_L(ptr,p->p1,len));
               break;
       case A:
               n = (rd_AW(ptr,len,len));
               break;
       case AW:
               n = (rd_AW(ptr,p->p1,len));
               break;
       case E:
       case EE:
       case D:
       case DE:
       case G:
       case GE:
       case F:
               n = (rd_F(ptr,p->p1,p->p2,len));
               break;
       default:
               return(errno=F_ERFMT);
       }
       if (n < 0)
       {
               if(feof(cf)) return(EOF);
               n = errno;
               clearerr(cf);
       }
       return(n);
}

rd_ned(p,ptr) char *ptr; struct syl *p;
{
       switch(p->op)
       {
#ifndef KOSHER
       case APOS:                                      /* NOT STANDARD F77 */
               return(rd_POS(&s_init[p->p1]));
       case H:                                         /* NOT STANDARD F77 */
               return(rd_H(p->p1,&s_init[p->p2]));
#endif
       case SLASH:
               return((*donewrec)());
       case TR:
       case X:
               cursor += p->p1;
               /* tab = (p->op==TR); This voids '..,tl6,1x,..' sequences */
               tab = YES;
               return(OK);
       case T:
               if(p->p1) cursor = p->p1 - recpos - 1;
#ifndef KOSHER
               else cursor = 8*p->p2 - recpos%8;       /* NOT STANDARD FORT */
#endif
               tab = YES;
               return(OK);
       case TL:
               cursor -= p->p1;
               if ((recpos + cursor) < 0) cursor = -recpos;    /* ANSI req'd */
               tab = YES;
               return(OK);
       default:
               return(errno=F_ERFMT);
       }
}

LOCAL
rd_mvcur()
{       int n;
       if(tab) return((*dotab)());
       if (cursor < 0) return(errno=F_ERSEEK);
       while(cursor--) if((n=(*getn)()) < 0) return(n);
       return(cursor=0);
}

LOCAL
rd_I(n,w,len) ftnlen len; uint *n;
{       long x=0;
       int i,sign=0,ch,c,sign_ok=YES;
       for(i=0;i<w;i++)
       {
               if((ch=(*getn)())<0) return(ch);
               switch(ch)
               {
               case ',': goto done;
               case '-': sign=1;               /* and fall thru */
               case '+': if(sign_ok == NO) return(errno=F_ERRICHR);
                         sign_ok = NO;
                         break;
               case ' ':
                       if(cblank) x *= radix;
                       break;
               case '\n':  if(cblank) {
                               x *= radix;
                               break;
                           } else {
                               goto done;
                           }
               default:
                       sign_ok = NO;
                       if( (c = ch-'0')>=0 && c<radix )
                       {       x = (x * radix) + c;
                               break;
                       }
                       else if( (c = low_case[ch]-'a'+10)>=0 && c<radix )
                       {       x = (x * radix) + c;
                               break;
                       }
                       return(errno=F_ERRICHR);
               }
       }
done:
       if(sign) x = -x;
       if(len==sizeof(short)) n->is=x;
       else n->il=x;
       return(OK);
}

LOCAL
rd_L(n,w,len) uint *n; ftnlen len;
{       int ch,i,v = -1, period=0;
       for(i=0;i<w;i++)
       {       if((ch=(*getn)()) < 0) return(ch);
               if((ch=low_case[ch])=='t' && v==-1) v=1;
               else if(ch=='f' && v==-1) v=0;
               else if(ch=='.' && !period) period++;
               else if(ch==' ' || ch=='\t') ;
               else if(ch==',') break;
               else if(v==-1) return(errno=F_ERLOGIF);
       }
       if(v==-1) return(errno=F_ERLOGIF);
       if(len==sizeof(short)) n->is=v;
       else n->il=v;
       return(OK);
}

LOCAL
rd_F(p,w,d,len) ftnlen len; ufloat *p;
{       double x,y;
       int i,sx,sz,ch,dot,ny,z,sawz,mode, sign_ok=YES;
       x=y=0;
       sawz=z=ny=dot=sx=sz=0;
       /* modes:       0 in initial blanks,
                       2 blanks plus sign
                       3 found a digit
        */
       mode = 0;

       for(i=0;i<w;)
       {       i++;
               if((ch=(*getn)())<0) return(ch);

               if(ch==' ') {   /* blank */
                       if(cblank && (mode==2)) x *= 10;
               } else if(ch<='9' && ch>='0') { /* digit */
                       mode = 2;
                       x=10*x+ch-'0';
               } else if(ch=='.') {
                       break;
               } else if(ch=='e' || ch=='d' || ch=='E' || ch=='D') {
                       goto exponent;
               } else if(ch=='+' || ch=='-') {
                       if(mode==0) {  /* sign before digits */
                               if(ch=='-') sx=1;
                               mode = 1;
                       } else if(mode==1) {  /* two signs before digits */
                               return(errno=F_ERRFCHR);
                       } else { /* sign after digits, weird but standard!
                                       means exponent without 'e' or 'd' */
                                   goto exponent;
                       }
               } else if(ch==',') {
                       goto done;
               } else if(ch=='\n') {
                       if(cblank && (mode==2)) x *= 10;
               } else {
                       return(errno=F_ERRFCHR);
               }
       }
       /* get here if out of characters to scan or found a period */
       if(ch=='.') dot=1;
       while(i<w)
       {       i++;
               if((ch=(*getn)())<0) return(ch);

               if(ch<='9' && ch>='0') {
                       y=10*y+ch-'0';
                       ny++;
               } else if(ch==' ' || ch=='\n') {
                       if(cblank) {
                               y*= 10;
                               ny++;
                       }
               } else if(ch==',') {
                       goto done;
               } else if(ch=='d' || ch=='e' || ch=='+' || ch=='-' || ch=='D' || ch=='E') {
                       break;
               } else {
                       return(errno=F_ERRFCHR);
               }
       }
       /*      now for the exponent.
        *      mode=3 means seen digit or sign of exponent.
        *      either out of characters to scan or 
        *              ch is '+', '-', 'd', or 'e'.
        */
exponent:
       if(ch=='-' || ch=='+') {
               if(ch=='-') sz=1;
               mode = 3;
       } else {
               mode = 2;
       }

       while(i<w)
       {       i++;
               sawz=1;
               if((ch=(*getn)())<0) return(ch);

               if(ch<='9' && ch>='0') {
                       mode = 3;
                       z=10*z+ch-'0';
               } else if(ch=='+' || ch=='-') {
                       if(mode==3 ) return(errno=F_ERRFCHR);
                       mode = 3;
                       if(ch=='-') sz=1;
               } else if(ch == ' ' || ch=='\n') {
                       if(cblank) z *=10;
               } else if(ch==',') {
                       break;
               } else {
                       return(errno=F_ERRFCHR);
               }
       }
done:
       if(!dot)
               for(i=0;i<d;i++) x /= 10;
       for(i=0;i<ny;i++) y /= 10;
       x=x+y;
       if(sz)
               for(i=0;i<z;i++) x /=10;
       else    for(i=0;i<z;i++) x *= 10;
       if(sx) x = -x;
       if(!sawz)
       {
               for(i=scale;i>0;i--) x /= 10;
               for(i=scale;i<0;i++) x *= 10;
       }
       if(len==sizeof(float)) p->pf=x;
       else p->pd=x;
       return(OK);
}

LOCAL
rd_AW(p,w,len) char *p; ftnlen len;
{       int i,ch;
       if(w >= len)
       {
               for(i=0;i<w-len;i++) GET(ch);
               for(i=0;i<len;i++)
               {       GET(ch);
                       *p++=VAL(ch);
               }
       }
       else
       {
               for(i=0;i<w;i++)
               {       GET(ch);
                       *p++=VAL(ch);
               }
               for(i=0;i<len-w;i++) *p++=' ';
       }
       return(OK);
}

/* THIS IS NOT ALLOWED IN THE NEW STANDARD 'CAUSE IT'S WEIRD */
LOCAL
rd_H(n,s) char *s;
{       int i,ch = 0;

       used_data = YES;
       for(i=0;i<n;i++)
       {       if (ch != '\n')
                       GET(ch);
               if (ch == '\n')
                       *s++ = ' ';
               else
                       *s++ = ch;
       }
       return(OK);
}

LOCAL
rd_POS(s) char *s;
{       char quote;
       int ch = 0;

       used_data = YES;
       quote = *s++;
       while(*s)
       {       if(*s==quote && *(s+1)!=quote)
                       break;
               if (ch != '\n')
                       GET(ch);
               if (ch == '\n')
                       *s++ = ' ';
               else
                       *s++ = ch;
       }
       return(OK);
}