libf2c/libI77/wrtfmt.c

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