1 /* 2 char id_wrtfmt[] = "@(#)wrtfmt.c 1.7"; 3 * 4 * formatted write routines 5 */ 6 7 #include "fio.h" 8 #include "format.h" 9 10 extern char *icvt(); 11 12 #define abs(x) (x<0?-x:x) 13 14 w_ed(p,ptr,len) char *ptr; struct syl *p; ftnlen len; 15 { int n; 16 if(cursor && (n=wr_mvcur())) return(n); 17 switch(p->op) 18 { 19 case I: 20 case IM: 21 return(wrt_IM(ptr,p->p1,p->p2,len)); 22 case L: 23 return(wrt_L(ptr,p->p1)); 24 case A: 25 p->p1 = len; /* cheap trick */ 26 case AW: 27 return(wrt_AW(ptr,p->p1,len)); 28 case D: 29 case DE: 30 return(wrt_E(ptr,p->p1,p->p2,p->p3,len,'d')); 31 case E: 32 case EE: 33 return(wrt_E(ptr,p->p1,p->p2,p->p3,len,'e')); 34 case G: 35 case GE: 36 return(wrt_G(ptr,p->p1,p->p2,p->p3,len)); 37 case F: 38 return(wrt_F(ptr,p->p1,p->p2,len)); 39 default: 40 return(errno=F_ERFMT); 41 } 42 } 43 44 w_ned(p,ptr) char *ptr; struct syl *p; 45 { 46 switch(p->op) 47 { 48 case SLASH: 49 return((*donewrec)()); 50 case T: 51 if(p->p1) cursor = p->p1 - recpos - 1; 52 #ifndef KOSHER 53 else cursor = 8*p->p2 - recpos%8; /* NOT STANDARD FORT */ 54 #endif 55 tab = YES; 56 return(OK); 57 case TL: 58 cursor -= p->p1; 59 if ((recpos + cursor) < 0) cursor = -recpos; /* ANSI req'd */ 60 tab = YES; 61 return(OK); 62 case TR: 63 case X: 64 cursor += p->p1; 65 /* tab = (p->op == TR); this would implement destructive X */ 66 tab = YES; 67 return(OK); 68 case APOS: 69 return(wrt_AP(p->p1)); 70 case H: 71 return(wrt_H(p->p1,p->p2)); 72 default: 73 return(errno=F_ERFMT); 74 } 75 } 76 77 wr_mvcur() 78 { int n; 79 if(tab) return((*dotab)()); 80 if (cursor < 0) return(errno=F_ERSEEK); 81 while(cursor--) PUT(' ') 82 return(cursor=0); 83 } 84 85 wrt_IM(ui,w,m,len) uint *ui; ftnlen len; 86 { int ndigit,sign,spare,i,xsign,n; 87 long x; 88 char *ans; 89 if(sizeof(short)==len) x=ui->is; 90 /* else if(len == sizeof(char)) x = ui->ic; */ 91 else x=ui->il; 92 if(x==0 && m==0) 93 { for(i=0;i<w;i++) PUT(' ') 94 return(OK); 95 } 96 ans=icvt(x,&ndigit,&sign); 97 if(sign || cplus) xsign=1; 98 else xsign=0; 99 if(ndigit+xsign>w || m+xsign>w) 100 { for(i=0;i<w;i++) PUT('*') 101 return(OK); 102 } 103 if(ndigit>=m) 104 spare=w-ndigit-xsign; 105 else 106 spare=w-m-xsign; 107 for(i=0;i<spare;i++) PUT(' ') 108 if(sign) PUT('-') 109 else if(cplus) PUT('+') 110 for(i=0;i<m-ndigit;i++) PUT('0') 111 for(i=0;i<ndigit;i++) PUT(*ans++) 112 return(OK); 113 } 114 115 wrt_AP(p) 116 { char *s,quote; 117 int n; 118 if(cursor && (n=wr_mvcur())) return(n); 119 s=(char *)p; 120 quote = *s++; 121 for(; *s; s++) 122 { if(*s!=quote) PUT(*s) 123 else if(*++s==quote) PUT(*s) 124 else return(OK); 125 } 126 return(OK); 127 } 128 129 wrt_H(a,b) 130 { char *s=(char *)b; 131 int n; 132 if(cursor && (n=wr_mvcur())) return(n); 133 while(a--) PUT(*s++) 134 return(OK); 135 } 136 137 wrt_L(l,len) ftnint *l; 138 { int i,n; 139 for(i=0;i<len-1;i++) PUT(' ') 140 if(*l) PUT('t') 141 else PUT('f') 142 return(OK); 143 } 144 145 wrt_AW(p,w,len) char * p; ftnlen len; 146 { int n; 147 while(w>len) 148 { w--; 149 PUT(' ') 150 } 151 while(w-- > 0) 152 PUT(*p++) 153 return(OK); 154 } 155 156 wrt_E(p,w,d,e,len,expch) ufloat *p; ftnlen len; char expch; 157 { char *s,ex[4]; 158 int dd,dp,sign,i,delta,pad,n; 159 char *ecvt(); 160 161 if((len==sizeof(float)?p->pf:p->pd)==0.0) 162 { 163 wrt_F(p,w-(e+2),d,len); 164 PUT(expch) 165 PUT('+') 166 /* for(i=0;i<(e-1);i++)PUT(' ') 167 deleted PUT('0') 168 */ 169 /* added */ for(i=0;i<e;i++) PUT('0') 170 return(OK); 171 } 172 if (scale > 0) { /* insane ANSI requirement */ 173 dd = d + 1; 174 d = dd - scale; 175 } else 176 dd = d + scale; 177 if (dd <= 0 || d < 0) goto E_badfield; 178 s=ecvt( (len==sizeof(float)?(double)p->pf:p->pd) ,dd,&dp,&sign); 179 delta = 3+e; 180 if(sign||cplus) delta++; 181 pad=w-(delta+d)-(scale>0? scale:0); 182 if(pad<0) { 183 E_badfield: 184 for(i=0;i<w;i++) PUT('*') 185 return(OK); 186 } 187 for(i=0;i<(pad-(scale<=0?1:0));i++) PUT(' ') 188 if(sign) PUT('-') 189 else if(cplus) PUT('+') 190 if(scale<=0 && pad) PUT('0') 191 if(scale<0 && scale > -d) 192 { 193 PUT('.') 194 for(i=0;i<-scale;i++) 195 PUT('0') 196 for(i=0;i<d+scale;i++) 197 PUT(*s++) 198 } 199 else 200 { 201 if(scale>0) 202 for(i=0;i<scale;i++) 203 PUT(*s++) 204 PUT('.') 205 for(i=0;i<d;i++) 206 PUT(*s++) 207 } 208 dp -= scale; 209 sprintf(ex,"%d",abs(dp)); 210 if((pad=strlen(ex))>e) 211 { if(pad>(++e)) 212 { PUT(expch) 213 for(i=0;i<e;i++) PUT('*') 214 return(OK); 215 } 216 } 217 else PUT(expch) 218 PUT(dp<0?'-':'+') 219 for(i=0;i<(e-pad);i++) PUT('0') /* was ' ' */ 220 s= &ex[0]; 221 while(*s) PUT(*s++) 222 return(OK); 223 } 224 225 wrt_G(p,w,d,e,len) ufloat *p; ftnlen len; 226 { double uplim = 1.0, x; 227 int i,oldscale,n,j,ne; 228 x=(len==sizeof(float)?(double)p->pf:p->pd); 229 i=d; 230 if(x==0.0) goto zero; 231 x = abs(x); 232 if(x>=0.1) 233 { 234 for(i=0; i<=d; i++, uplim*=10.0) 235 { if(x>=uplim) continue; 236 zero: oldscale=scale; 237 scale=0; 238 ne = e+2; 239 if(n = wrt_F(p,w-ne,d-i,len)) return(n); 240 for(j=0; j<ne; j++) PUT(' ') 241 scale=oldscale; 242 return(OK); 243 } 244 /* falling off the bottom implies E format */ 245 } 246 return(wrt_E(p,w,d,e,len,'e')); 247 } 248 249 wrt_F(p,w,d,len) ufloat *p; ftnlen len; 250 { int i,delta,dp,sign,n,nf; 251 double x; 252 char *s,*fcvt(); 253 x= (len==sizeof(float)?(double)p->pf:p->pd); 254 if(scale && x!=0.0) 255 { if(scale>0) 256 for(i=0;i<scale;i++) x*=10; 257 else for(i=0;i<-scale;i++) x/=10; 258 } 259 s=fcvt(x,d,&dp,&sign); 260 /* if(-dp>=d) sign=0; ?? */ 261 delta=1; 262 if(sign || cplus) delta++; 263 nf = w - (d + delta + (dp>0?dp:0)); 264 if(nf<0) 265 { 266 for(i=0;i<w;i++) PUT('*') 267 return(OK); 268 } 269 if(nf>0) for(i=0; i<(nf-(dp<=0?1:0)); i++) PUT(' ') 270 if(sign) PUT('-') 271 else if(cplus) PUT('+') 272 if(dp>0) for(i=0;i<dp;i++) PUT(*s++) 273 else if(nf>0) PUT('0') 274 PUT('.') 275 for(i=0; i< -dp && i<d; i++) PUT('0') 276 for(;i<d;i++) 277 { if(x==0.0 && !cblank) PUT(' ') /* exactly zero */ 278 else if(*s) PUT(*s++) 279 else PUT('0') 280 } 281 return(OK); 282 } 283