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