/*- * 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); }