00001 #include "f2c.h"
00002 #include "fio.h"
00003 #include "fmt.h"
00004 
00005 extern icilist *f__svic;
00006 extern char *f__icptr;
00007 
00008  static int
00009 mv_cur(Void)    /* shouldn't use fseek because it insists on calling fflush */
00010                 /* instead we know too much about stdio */
00011 {
00012         int cursor = f__cursor;
00013         f__cursor = 0;
00014         if(f__external == 0) {
00015                 if(cursor < 0) {
00016                         if(f__hiwater < f__recpos)
00017                                 f__hiwater = f__recpos;
00018                         f__recpos += cursor;
00019                         f__icptr += cursor;
00020                         if(f__recpos < 0)
00021                                 err(f__elist->cierr, 110, "left off");
00022                 }
00023                 else if(cursor > 0) {
00024                         if(f__recpos + cursor >= f__svic->icirlen)
00025                                 err(f__elist->cierr, 110, "recend");
00026                         if(f__hiwater <= f__recpos)
00027                                 for(; cursor > 0; cursor--)
00028                                         (*f__putn)(' ');
00029                         else if(f__hiwater <= f__recpos + cursor) {
00030                                 cursor -= f__hiwater - f__recpos;
00031                                 f__icptr += f__hiwater - f__recpos;
00032                                 f__recpos = f__hiwater;
00033                                 for(; cursor > 0; cursor--)
00034                                         (*f__putn)(' ');
00035                         }
00036                         else {
00037                                 f__icptr += cursor;
00038                                 f__recpos += cursor;
00039                         }
00040                 }
00041                 return(0);
00042         }
00043         if(cursor > 0) {
00044                 if(f__hiwater <= f__recpos)
00045                         for(;cursor>0;cursor--) (*f__putn)(' ');
00046                 else if(f__hiwater <= f__recpos + cursor) {
00047 #ifndef NON_UNIX_STDIO
00048                         if(f__cf->_ptr + f__hiwater - f__recpos < buf_end(f__cf))
00049                                 f__cf->_ptr += f__hiwater - f__recpos;
00050                         else
00051 #endif
00052                                 (void) fseek(f__cf, (long) (f__hiwater - f__recpos), SEEK_CUR);
00053                         cursor -= f__hiwater - f__recpos;
00054                         f__recpos = f__hiwater;
00055                         for(; cursor > 0; cursor--)
00056                                 (*f__putn)(' ');
00057                 }
00058                 else {
00059 #ifndef NON_UNIX_STDIO
00060                         if(f__cf->_ptr + cursor < buf_end(f__cf))
00061                                 f__cf->_ptr += cursor;
00062                         else
00063 #endif
00064                                 (void) fseek(f__cf, (long)cursor, SEEK_CUR);
00065                         f__recpos += cursor;
00066                 }
00067         }
00068         if(cursor<0)
00069         {
00070                 if(cursor+f__recpos<0) err(f__elist->cierr,110,"left off");
00071 #ifndef NON_UNIX_STDIO
00072                 if(f__cf->_ptr + cursor >= f__cf->_base)
00073                         f__cf->_ptr += cursor;
00074                 else
00075 #endif
00076                 if(f__curunit && f__curunit->useek)
00077                         (void) fseek(f__cf,(long)cursor,SEEK_CUR);
00078                 else
00079                         err(f__elist->cierr,106,"fmt");
00080                 if(f__hiwater < f__recpos)
00081                         f__hiwater = f__recpos;
00082                 f__recpos += cursor;
00083         }
00084         return(0);
00085 }
00086 
00087  static int
00088 #ifdef KR_headers
00089 wrt_Z(n,w,minlen,len) Uint *n; int w, minlen; ftnlen len;
00090 #else
00091 wrt_Z(Uint *n, int w, int minlen, ftnlen len)
00092 #endif
00093 {
00094         register char *s, *se;
00095         register i, w1;
00096         static int one = 1;
00097         static char hex[] = "0123456789ABCDEF";
00098         s = (char *)n;
00099         --len;
00100         if (*(char *)&one) {
00101                 /* little endian */
00102                 se = s;
00103                 s += len;
00104                 i = -1;
00105                 }
00106         else {
00107                 se = s + len;
00108                 i = 1;
00109                 }
00110         for(;; s += i)
00111                 if (s == se || *s)
00112                         break;
00113         w1 = (i*(se-s) << 1) + 1;
00114         if (*s & 0xf0)
00115                 w1++;
00116         if (w1 > w)
00117                 for(i = 0; i < w; i++)
00118                         (*f__putn)('*');
00119         else {
00120                 if ((minlen -= w1) > 0)
00121                         w1 += minlen;
00122                 while(--w >= w1)
00123                         (*f__putn)(' ');
00124                 while(--minlen >= 0)
00125                         (*f__putn)('0');
00126                 if (!(*s & 0xf0)) {
00127                         (*f__putn)(hex[*s & 0xf]);
00128                         if (s == se)
00129                                 return 0;
00130                         s += i;
00131                         }
00132                 for(;; s += i) {
00133                         (*f__putn)(hex[*s >> 4 & 0xf]);
00134                         (*f__putn)(hex[*s & 0xf]);
00135                         if (s == se)
00136                                 break;
00137                         }
00138                 }
00139         return 0;
00140         }
00141 
00142  static int
00143 #ifdef KR_headers
00144 wrt_I(n,w,len, base) Uint *n; ftnlen len; register int base;
00145 #else
00146 wrt_I(Uint *n, int w, ftnlen len, register int base)
00147 #endif
00148 {       int ndigit,sign,spare,i;
00149         longint x;
00150         char *ans;
00151         if(len==sizeof(integer)) x=n->il;
00152         else if(len == sizeof(char)) x = n->ic;
00153 #ifdef Allow_TYQUAD
00154         else if (len == sizeof(longint)) x = n->ili;
00155 #endif
00156         else x=n->is;
00157         ans=f__icvt(x,&ndigit,&sign, base);
00158         spare=w-ndigit;
00159         if(sign || f__cplus) spare--;
00160         if(spare<0)
00161                 for(i=0;i<w;i++) (*f__putn)('*');
00162         else
00163         {       for(i=0;i<spare;i++) (*f__putn)(' ');
00164                 if(sign) (*f__putn)('-');
00165                 else if(f__cplus) (*f__putn)('+');
00166                 for(i=0;i<ndigit;i++) (*f__putn)(*ans++);
00167         }
00168         return(0);
00169 }
00170  static int
00171 #ifdef KR_headers
00172 wrt_IM(n,w,m,len,base) Uint *n; ftnlen len; int base;
00173 #else
00174 wrt_IM(Uint *n, int w, int m, ftnlen len, int base)
00175 #endif
00176 {       int ndigit,sign,spare,i,xsign;
00177         longint x;
00178         char *ans;
00179         if(sizeof(integer)==len) x=n->il;
00180         else if(len == sizeof(char)) x = n->ic;
00181 #ifdef Allow_TYQUAD
00182         else if (len == sizeof(longint)) x = n->ili;
00183 #endif
00184         else x=n->is;
00185         ans=f__icvt(x,&ndigit,&sign, base);
00186         if(sign || f__cplus) xsign=1;
00187         else xsign=0;
00188         if(ndigit+xsign>w || m+xsign>w)
00189         {       for(i=0;i<w;i++) (*f__putn)('*');
00190                 return(0);
00191         }
00192         if(x==0 && m==0)
00193         {       for(i=0;i<w;i++) (*f__putn)(' ');
00194                 return(0);
00195         }
00196         if(ndigit>=m)
00197                 spare=w-ndigit-xsign;
00198         else
00199                 spare=w-m-xsign;
00200         for(i=0;i<spare;i++) (*f__putn)(' ');
00201         if(sign) (*f__putn)('-');
00202         else if(f__cplus) (*f__putn)('+');
00203         for(i=0;i<m-ndigit;i++) (*f__putn)('0');
00204         for(i=0;i<ndigit;i++) (*f__putn)(*ans++);
00205         return(0);
00206 }
00207  static int
00208 #ifdef KR_headers
00209 wrt_AP(s) char *s;
00210 #else
00211 wrt_AP(char *s)
00212 #endif
00213 {       char quote;
00214         int i;
00215 
00216         if(f__cursor && (i = mv_cur()))
00217                 return i;
00218         quote = *s++;
00219         for(;*s;s++)
00220         {       if(*s!=quote) (*f__putn)(*s);
00221                 else if(*++s==quote) (*f__putn)(*s);
00222                 else return(1);
00223         }
00224         return(1);
00225 }
00226  static int
00227 #ifdef KR_headers
00228 wrt_H(a,s) char *s;
00229 #else
00230 wrt_H(int a, char *s)
00231 #endif
00232 {
00233         int i;
00234 
00235         if(f__cursor && (i = mv_cur()))
00236                 return i;
00237         while(a--) (*f__putn)(*s++);
00238         return(1);
00239 }
00240 #ifdef KR_headers
00241 wrt_L(n,len, sz) Uint *n; ftnlen sz;
00242 #else
00243 wrt_L(Uint *n, int len, ftnlen sz)
00244 #endif
00245 {       int i;
00246         long x;
00247         if(sizeof(long)==sz) x=n->il;
00248         else if(sz == sizeof(char)) x = n->ic;
00249         else x=n->is;
00250         for(i=0;i<len-1;i++)
00251                 (*f__putn)(' ');
00252         if(x) (*f__putn)('T');
00253         else (*f__putn)('F');
00254         return(0);
00255 }
00256  static int
00257 #ifdef KR_headers
00258 wrt_A(p,len) char *p; ftnlen len;
00259 #else
00260 wrt_A(char *p, ftnlen len)
00261 #endif
00262 {
00263         while(len-- > 0) (*f__putn)(*p++);
00264         return(0);
00265 }
00266  static int
00267 #ifdef KR_headers
00268 wrt_AW(p,w,len) char * p; ftnlen len;
00269 #else
00270 wrt_AW(char * p, int w, ftnlen len)
00271 #endif
00272 {
00273         while(w>len)
00274         {       w--;
00275                 (*f__putn)(' ');
00276         }
00277         while(w-- > 0)
00278                 (*f__putn)(*p++);
00279         return(0);
00280 }
00281 
00282  static int
00283 #ifdef KR_headers
00284 wrt_G(p,w,d,e,len) ufloat *p; ftnlen len;
00285 #else
00286 wrt_G(ufloat *p, int w, int d, int e, ftnlen len)
00287 #endif
00288 {       double up = 1,x;
00289         int i=0,oldscale,n,j;
00290         x = len==sizeof(real)?p->pf:p->pd;
00291         if(x < 0 ) x = -x;
00292         if(x<.1) {
00293                 if (x != 0.)
00294                         return(wrt_E(p,w,d,e,len));
00295 #ifdef WANT_LEAD_0
00296                 i = 1;
00297 #endif
00298                 goto have_i;
00299                 }
00300         for(;i<=d;i++,up*=10)
00301         {       if(x>=up) continue;
00302  have_i:
00303                 oldscale = f__scale;
00304                 f__scale = 0;
00305                 if(e==0) n=4;
00306                 else    n=e+2;
00307                 i=wrt_F(p,w-n,d-i,len);
00308                 for(j=0;j<n;j++) (*f__putn)(' ');
00309                 f__scale=oldscale;
00310                 return(i);
00311         }
00312         return(wrt_E(p,w,d,e,len));
00313 }
00314 #ifdef KR_headers
00315 w_ed(p,ptr,len) struct syl *p; char *ptr; ftnlen len;
00316 #else
00317 w_ed(struct syl *p, char *ptr, ftnlen len)
00318 #endif
00319 {
00320         int i;
00321 
00322         if(f__cursor && (i = mv_cur()))
00323                 return i;
00324         switch(p->op)
00325         {
00326         default:
00327                 fprintf(stderr,"w_ed, unexpected code: %d\n", p->op);
00328                 sig_die(f__fmtbuf, 1);
00329         case I: return(wrt_I((Uint *)ptr,p->p1,len, 10));
00330         case IM:
00331                 return(wrt_IM((Uint *)ptr,p->p1,p->p2,len,10));
00332 
00333                 /* O and OM don't work right for character, double, complex, */
00334                 /* or doublecomplex, and they differ from Fortran 90 in */
00335                 /* showing a minus sign for negative values. */
00336 
00337         case O: return(wrt_I((Uint *)ptr, p->p1, len, 8));
00338         case OM:
00339                 return(wrt_IM((Uint *)ptr,p->p1,p->p2,len,8));
00340         case L: return(wrt_L((Uint *)ptr,p->p1, len));
00341         case A: return(wrt_A(ptr,len));
00342         case AW:
00343                 return(wrt_AW(ptr,p->p1,len));
00344         case D:
00345         case E:
00346         case EE:
00347                 return(wrt_E((ufloat *)ptr,p->p1,p->p2,p->p3,len));
00348         case G:
00349         case GE:
00350                 return(wrt_G((ufloat *)ptr,p->p1,p->p2,p->p3,len));
00351         case F: return(wrt_F((ufloat *)ptr,p->p1,p->p2,len));
00352 
00353                 /* Z and ZM assume 8-bit bytes. */
00354 
00355         case Z: return(wrt_Z((Uint *)ptr,p->p1,0,len));
00356         case ZM:
00357                 return(wrt_Z((Uint *)ptr,p->p1,p->p2,len));
00358         }
00359 }
00360 #ifdef KR_headers
00361 w_ned(p) struct syl *p;
00362 #else
00363 w_ned(struct syl *p)
00364 #endif
00365 {
00366         switch(p->op)
00367         {
00368         default: fprintf(stderr,"w_ned, unexpected code: %d\n", p->op);
00369                 sig_die(f__fmtbuf, 1);
00370         case SLASH:
00371                 return((*f__donewrec)());
00372         case T: f__cursor = p->p1-f__recpos - 1;
00373                 return(1);
00374         case TL: f__cursor -= p->p1;
00375                 if(f__cursor < -f__recpos)      /* TL1000, 1X */
00376                         f__cursor = -f__recpos;
00377                 return(1);
00378         case TR:
00379         case X:
00380                 f__cursor += p->p1;
00381                 return(1);
00382         case APOS:
00383                 return(wrt_AP(*(char **)&p->p2));
00384         case H:
00385                 return(wrt_H(p->p1,*(char **)&p->p2));
00386         }
00387 }