libf2c/libI77/wrtfmt.c

   1 #include "f2c.h"
   2 #include "fio.h"
   3 #include "fmt.h"
   4
   5 extern icilist *f__svic;
   6 extern char *f__icptr;
   7
   8  static int
   9 mv_cur(Void)    /* shouldn't use fseek because it insists on calling fflush */
  10                 /* instead we know too much about stdio */
  11 {
  12         int cursor = f__cursor;
  13         f__cursor = 0;
  14         if(f__external == 0) {
  15                 if(cursor < 0) {
  16                         if(f__hiwater < f__recpos)
  17                                 f__hiwater = f__recpos;
  18                         f__recpos += cursor;
  19                         f__icptr += cursor;
  20                         if(f__recpos < 0)
  21                                 err(f__elist->cierr, 110, "left off");
  22                 }
  23                 else if(cursor > 0) {
  24                         if(f__recpos + cursor >= f__svic->icirlen)
  25                                 err(f__elist->cierr, 110, "recend");
  26                         if(f__hiwater <= f__recpos)
  27                                 for(; cursor > 0; cursor--)
  28                                         (*f__putn)(' ');
  29                         else if(f__hiwater <= f__recpos + cursor) {
  30                                 cursor -= f__hiwater - f__recpos;
  31                                 f__icptr += f__hiwater - f__recpos;
  32                                 f__recpos = f__hiwater;
  33                                 for(; cursor > 0; cursor--)
  34                                         (*f__putn)(' ');
  35                         }
  36                         else {
  37                                 f__icptr += cursor;
  38                                 f__recpos += cursor;
  39                         }
  40                 }
  41                 return(0);
  42         }
  43         if(cursor > 0) {
  44                 if(f__hiwater <= f__recpos)
  45                         for(;cursor>0;cursor--) (*f__putn)(' ');
  46                 else if(f__hiwater <= f__recpos + cursor) {
  47 #if ! defined (NON_UNIX_STDIO) && ! defined (MISSING_FILE_ELEMS)
  48                         if(f__cf->_ptr + f__hiwater - f__recpos < buf_end(f__cf))
  49                                 f__cf->_ptr += f__hiwater - f__recpos;
  50                         else
  51 #endif
  52                                 (void) fseek(f__cf, (long) (f__hiwater - f__recpos), SEEK_CUR);
  53                         cursor -= f__hiwater - f__recpos;
  54                         f__recpos = f__hiwater;
  55                         for(; cursor > 0; cursor--)
  56                                 (*f__putn)(' ');
  57                 }
  58                 else {
  59 #if ! defined (NON_UNIX_STDIO) && ! defined (MISSING_FILE_ELEMS)
  60                         if(f__cf->_ptr + cursor < buf_end(f__cf))
  61                                 f__cf->_ptr += cursor;
  62                         else
  63 #endif
  64                                 (void) fseek(f__cf, (long)cursor, SEEK_CUR);
  65                         f__recpos += cursor;
  66                 }
  67         }
  68         if(cursor<0)
  69         {
  70                 if(cursor+f__recpos<0) err(f__elist->cierr,110,"left off");
  71 #if ! defined (NON_UNIX_STDIO) && ! defined (MISSING_FILE_ELEMS)
  72                 if(f__cf->_ptr + cursor >= f__cf->_base)
  73                         f__cf->_ptr += cursor;
  74                 else
  75 #endif
  76                 if(f__curunit && f__curunit->useek)
  77                         (void) fseek(f__cf,(long)cursor,SEEK_CUR);
  78                 else
  79                         err(f__elist->cierr,106,"fmt");
  80                 if(f__hiwater < f__recpos)
  81                         f__hiwater = f__recpos;
  82                 f__recpos += cursor;
  83         }
  84         return(0);
  85 }
  86
  87  static int
  88 #ifdef KR_headers
  89 wrt_Z(n,w,minlen,len) Uint *n; int w, minlen; ftnlen len;
  90 #else
  91 wrt_Z(Uint *n, int w, int minlen, ftnlen len)
  92 #endif
  93 {
  94         register char *s, *se;
  95         register int i, w1;
  96         static int one = 1;
  97         static char hex[] = "0123456789ABCDEF";
  98         s = (char *)n;
  99         --len;
 100         if (*(char *)&one) {
 101                 /* little endian */
 102                 se = s;
 103                 s += len;
 104                 i = -1;
 105                 }
 106         else {
 107                 se = s + len;
 108                 i = 1;
 109                 }
 110         for(;; s += i)
 111                 if (s == se || *s)
 112                         break;
 113         w1 = (i*(se-s) << 1) + 1;
 114         if (*s & 0xf0)
 115                 w1++;
 116         if (w1 > w)
 117                 for(i = 0; i < w; i++)
 118                         (*f__putn)('*');
 119         else {
 120                 if ((minlen -= w1) > 0)
 121                         w1 += minlen;
 122                 while(--w >= w1)
 123                         (*f__putn)(' ');
 124                 while(--minlen >= 0)
 125                         (*f__putn)('0');
 126                 if (!(*s & 0xf0)) {
 127                         (*f__putn)(hex[*s & 0xf]);
 128                         if (s == se)
 129                                 return 0;
 130                         s += i;
 131                         }
 132                 for(;; s += i) {
 133                         (*f__putn)(hex[*s >> 4 & 0xf]);
 134                         (*f__putn)(hex[*s & 0xf]);
 135                         if (s == se)
 136                                 break;
 137                         }
 138                 }
 139         return 0;
 140         }
 141
 142  static int
 143 #ifdef KR_headers
 144 wrt_I(n,w,len, base) Uint *n; ftnlen len; register int base;
 145 #else
 146 wrt_I(Uint *n, int w, ftnlen len, register int base)
 147 #endif
 148 {       int ndigit,sign,spare,i;
 149         longint x;
 150         char *ans;
 151         if(len==sizeof(integer)) x=n->il;
 152         else if(len == sizeof(char)) x = n->ic;
 153 #ifdef Allow_TYQUAD
 154         else if (len == sizeof(longint)) x = n->ili;
 155 #endif
 156         else x=n->is;
 157         ans=f__icvt(x,&ndigit,&sign, base);
 158         spare=w-ndigit;
 159         if(sign || f__cplus) spare--;
 160         if(spare<0)
 161                 for(i=0;i<w;i++) (*f__putn)('*');
 162         else
 163         {       for(i=0;i<spare;i++) (*f__putn)(' ');
 164                 if(sign) (*f__putn)('-');
 165                 else if(f__cplus) (*f__putn)('+');
 166                 for(i=0;i<ndigit;i++) (*f__putn)(*ans++);
 167         }
 168         return(0);
 169 }
 170  static int
 171 #ifdef KR_headers
 172 wrt_IM(n,w,m,len,base) Uint *n; ftnlen len; int base;
 173 #else
 174 wrt_IM(Uint *n, int w, int m, ftnlen len, int base)
 175 #endif
 176 {       int ndigit,sign,spare,i,xsign;
 177         longint x;
 178         char *ans;
 179         if(sizeof(integer)==len) x=n->il;
 180         else if(len == sizeof(char)) x = n->ic;
 181 #ifdef Allow_TYQUAD
 182         else if (len == sizeof(longint)) x = n->ili;
 183 #endif
 184         else x=n->is;
 185         ans=f__icvt(x,&ndigit,&sign, base);
 186         if(sign || f__cplus) xsign=1;
 187         else xsign=0;
 188         if(ndigit+xsign>w || m+xsign>w)
 189         {       for(i=0;i<w;i++) (*f__putn)('*');
 190                 return(0);
 191         }
 192         if(x==0 && m==0)
 193         {       for(i=0;i<w;i++) (*f__putn)(' ');
 194                 return(0);
 195         }
 196         if(ndigit>=m)
 197                 spare=w-ndigit-xsign;
 198         else
 199                 spare=w-m-xsign;
 200         for(i=0;i<spare;i++) (*f__putn)(' ');
 201         if(sign) (*f__putn)('-');
 202         else if(f__cplus) (*f__putn)('+');
 203         for(i=0;i<m-ndigit;i++) (*f__putn)('0');
 204         for(i=0;i<ndigit;i++) (*f__putn)(*ans++);
 205         return(0);
 206 }
 207  static int
 208 #ifdef KR_headers
 209 wrt_AP(s) char *s;
 210 #else
 211 wrt_AP(char *s)
 212 #endif
 213 {       char quote;
 214         int i;
 215
 216         if(f__cursor && (i = mv_cur()))
 217                 return i;
 218         quote = *s++;
 219         for(;*s;s++)
 220         {       if(*s!=quote) (*f__putn)(*s);
 221                 else if(*++s==quote) (*f__putn)(*s);
 222                 else return(1);
 223         }
 224         return(1);
 225 }
 226  static int
 227 #ifdef KR_headers
 228 wrt_H(a,s) char *s;
 229 #else
 230 wrt_H(int a, char *s)
 231 #endif
 232 {
 233         int i;
 234
 235         if(f__cursor && (i = mv_cur()))
 236                 return i;
 237         while(a--) (*f__putn)(*s++);
 238         return(1);
 239 }
 240 #ifdef KR_headers
 241 wrt_L(n,len, sz) Uint *n; ftnlen sz;
 242 #else
 243 wrt_L(Uint *n, int len, ftnlen sz)
 244 #endif
 245 {       int i;
 246         long x;
 247         if(sizeof(long)==sz) x=n->il;
 248         else if(sz == sizeof(char)) x = n->ic;
 249         else x=n->is;
 250         for(i=0;i<len-1;i++)
 251                 (*f__putn)(' ');
 252         if(x) (*f__putn)('T');
 253         else (*f__putn)('F');
 254         return(0);
 255 }
 256  static int
 257 #ifdef KR_headers
 258 wrt_A(p,len) char *p; ftnlen len;
 259 #else
 260 wrt_A(char *p, ftnlen len)
 261 #endif
 262 {
 263         while(len-- > 0) (*f__putn)(*p++);
 264         return(0);
 265 }
 266  static int
 267 #ifdef KR_headers
 268 wrt_AW(p,w,len) char * p; ftnlen len;
 269 #else
 270 wrt_AW(char * p, int w, ftnlen len)
 271 #endif
 272 {
 273         while(w>len)
 274         {       w--;
 275                 (*f__putn)(' ');
 276         }
 277         while(w-- > 0)
 278                 (*f__putn)(*p++);
 279         return(0);
 280 }
 281
 282  static int
 283 #ifdef KR_headers
 284 wrt_G(p,w,d,e,len) ufloat *p; ftnlen len;
 285 #else
 286 wrt_G(ufloat *p, int w, int d, int e, ftnlen len)
 287 #endif
 288 {       double up = 1,x;
 289         int i=0,oldscale,n,j;
 290         x = len==sizeof(real)?p->pf:p->pd;
 291         if(x < 0 ) x = -x;
 292         if(x<.1) {
 293                 if (x != 0.)
 294                         return(wrt_E(p,w,d,e,len));
 295                 i = 1;
 296                 goto have_i;
 297                 }
 298         for(;i<=d;i++,up*=10)
 299         {       if(x>=up) continue;
 300  have_i:
 301                 oldscale = f__scale;
 302                 f__scale = 0;
 303                 if(e==0) n=4;
 304                 else    n=e+2;
 305                 i=wrt_F(p,w-n,d-i,len);
 306                 for(j=0;j<n;j++) (*f__putn)(' ');
 307                 f__scale=oldscale;
 308                 return(i);
 309         }
 310         return(wrt_E(p,w,d,e,len));
 311 }
 312 #ifdef KR_headers
 313 w_ed(p,ptr,len) struct syl *p; char *ptr; ftnlen len;
 314 #else
 315 w_ed(struct syl *p, char *ptr, ftnlen len)
 316 #endif
 317 {
 318         int i;
 319
 320         if(f__cursor && (i = mv_cur()))
 321                 return i;
 322         switch(p->op)
 323         {
 324         default:
 325                 fprintf(stderr,"w_ed, unexpected code: %d\n", p->op);
 326                 sig_die(f__fmtbuf, 1);
 327         case I: return(wrt_I((Uint *)ptr,p->p1,len, 10));
 328         case IM:
 329                 return(wrt_IM((Uint *)ptr,p->p1,p->p2.i[0],len,10));
 330
 331                 /* O and OM don't work right for character, double, complex, */
 332                 /* or doublecomplex, and they differ from Fortran 90 in */
 333                 /* showing a minus sign for negative values. */
 334
 335         case O: return(wrt_I((Uint *)ptr, p->p1, len, 8));
 336         case OM:
 337                 return(wrt_IM((Uint *)ptr,p->p1,p->p2.i[0],len,8));
 338         case L: return(wrt_L((Uint *)ptr,p->p1, len));
 339         case A: return(wrt_A(ptr,len));
 340         case AW:
 341                 return(wrt_AW(ptr,p->p1,len));
 342         case D:
 343         case E:
 344         case EE:
 345                 return(wrt_E((ufloat *)ptr,p->p1,p->p2.i[0],p->p2.i[1],len));
 346         case G:
 347         case GE:
 348                 return(wrt_G((ufloat *)ptr,p->p1,p->p2.i[0],p->p2.i[1],len));
 349         case F: return(wrt_F((ufloat *)ptr,p->p1,p->p2.i[0],len));
 350
 351                 /* Z and ZM assume 8-bit bytes. */
 352
 353         case Z: return(wrt_Z((Uint *)ptr,p->p1,0,len));
 354         case ZM:
 355                 return(wrt_Z((Uint *)ptr,p->p1,p->p2.i[0],len));
 356         }
 357 }
 358 #ifdef KR_headers
 359 w_ned(p) struct syl *p;
 360 #else
 361 w_ned(struct syl *p)
 362 #endif
 363 {
 364         switch(p->op)
 365         {
 366         default: fprintf(stderr,"w_ned, unexpected code: %d\n", p->op);
 367                 sig_die(f__fmtbuf, 1);
 368         case SLASH:
 369                 return((*f__donewrec)());
 370         case T: f__cursor = p->p1-f__recpos - 1;
 371                 return(1);
 372         case TL: f__cursor -= p->p1;
 373                 if(f__cursor < -f__recpos)      /* TL1000, 1X */
 374                         f__cursor = -f__recpos;
 375                 return(1);
 376         case TR:
 377         case X:
 378                 f__cursor += p->p1;
 379                 return(1);
 380         case APOS:
 381                 return(wrt_AP(p->p2.s));
 382         case H:
 383                 return(wrt_H(p->p1,p->p2.s));
 384         }
 385 }