lang/fortran/lib/libI77/wrtfmt.c

   1 #include "f2c.h"
   2 #include "fio.h"
   3 #include "fmt.h"
   4 extern int cursor;
   5 extern char *icvt(), *ecvt();
   6 int hiwater;
   7 icilist *svic;
   8 char *icptr;
   9 mv_cur()        /* shouldn't use fseek because it insists on calling fflush */
  10                 /* instead we know too much about stdio */
  11 {
  12         if(external == 0) {
  13                 if(cursor < 0) {
  14                         if(hiwater < recpos)
  15                                 hiwater = recpos;
  16                         recpos += cursor;
  17                         icptr += cursor;
  18                         cursor = 0;
  19                         if(recpos < 0)
  20                                 err(elist->cierr, 110, "left off");
  21                 }
  22                 else if(cursor > 0) {
  23                         if(recpos + cursor >= svic->icirlen)
  24                                 err(elist->cierr, 110, "recend");
  25                         if(hiwater <= recpos)
  26                                 for(; cursor > 0; cursor--)
  27                                         (*putn)(' ');
  28                         else if(hiwater <= recpos + cursor) {
  29                                 cursor -= hiwater - recpos;
  30                                 icptr += hiwater - recpos;
  31                                 recpos = hiwater;
  32                                 for(; cursor > 0; cursor--)
  33                                         (*putn)(' ');
  34                         }
  35                         else {
  36                                 icptr += cursor;
  37                                 recpos += cursor;
  38                         }
  39                         cursor = 0;
  40                 }
  41                 return(0);
  42         }
  43         if(cursor > 0) {
  44                 if(hiwater <= recpos)
  45                         for(;cursor>0;cursor--) (*putn)(' ');
  46                 else if(hiwater <= recpos + cursor) {
  47 #ifndef NON_UNIX_STDIO
  48                         if(cf->_ptr + hiwater - recpos < buf_end(cf))
  49                                 cf->_ptr += hiwater - recpos;
  50                         else
  51 #endif
  52                                 (void) fseek(cf, (long) (hiwater - recpos), SEEK_CUR);
  53                         cursor -= hiwater - recpos;
  54                         recpos = hiwater;
  55                         for(; cursor > 0; cursor--)
  56                                 (*putn)(' ');
  57                 }
  58                 else {
  59 #ifndef NON_UNIX_STDIO
  60                         if(cf->_ptr + cursor < buf_end(cf))
  61                                 cf->_ptr += cursor;
  62                         else
  63 #endif
  64                                 (void) fseek(cf, (long)cursor, SEEK_CUR);
  65                         recpos += cursor;
  66                 }
  67         }
  68         if(cursor<0)
  69         {
  70                 if(cursor+recpos<0) err(elist->cierr,110,"left off");
  71 #ifndef NON_UNIX_STDIO
  72                 if(cf->_ptr + cursor >= cf->_base)
  73                         cf->_ptr += cursor;
  74                 else
  75 #endif
  76                 if(curunit && curunit->useek)
  77                         (void) fseek(cf,(long)cursor,SEEK_CUR);
  78                 else
  79                         err(elist->cierr,106,"fmt");
  80                 if(hiwater < recpos)
  81                         hiwater = recpos;
  82                 recpos += cursor;
  83                 cursor=0;
  84         }
  85         return(0);
  86 }
  87 w_ed(p,ptr,len) char *ptr; struct syl *p; ftnlen len;
  88 {
  89         if(cursor && mv_cur()) return(mv_cur());
  90         switch(p->op)
  91         {
  92         default:
  93                 fprintf(stderr,"w_ed, unexpected code: %d\n", p->op);
  94                 sig_die(fmtbuf, 1);
  95         case I: return(wrt_I((uint *)ptr,p->p1,len, 10));
  96         case IM:
  97                 return(wrt_IM((uint *)ptr,p->p1,p->p2,len));
  98         case O: return(wrt_I((uint *)ptr, p->p1, len, 8));
  99         case L: return(wrt_L((uint *)ptr,p->p1, len));
 100         case A: return(wrt_A(ptr,len));
 101         case AW:
 102                 return(wrt_AW(ptr,p->p1,len));
 103         case D:
 104         case E:
 105         case EE:
 106                 return(wrt_E((ufloat *)ptr,p->p1,p->p2,p->p3,len));
 107         case G:
 108         case GE:
 109                 return(wrt_G((ufloat *)ptr,p->p1,p->p2,p->p3,len));
 110         case F: return(wrt_F((ufloat *)ptr,p->p1,p->p2,len));
 111         }
 112 }
 113 w_ned(p) struct syl *p;
 114 {
 115         switch(p->op)
 116         {
 117         default: fprintf(stderr,"w_ned, unexpected code: %d\n", p->op);
 118                 sig_die(fmtbuf, 1);
 119         case SLASH:
 120                 return((*donewrec)());
 121         case T: cursor = p->p1-recpos - 1;
 122                 return(1);
 123         case TL: cursor -= p->p1;
 124                 if(cursor < -recpos)    /* TL1000, 1X */
 125                         cursor = -recpos;
 126                 return(1);
 127         case TR:
 128         case X:
 129                 cursor += p->p1;
 130                 return(1);
 131         case APOS:
 132                 return(wrt_AP(*(char **)&p->p2));
 133         case H:
 134                 return(wrt_H(p->p1,*(char **)&p->p2));
 135         }
 136 }
 137 wrt_I(n,w,len, base) uint *n; ftnlen len; register int base;
 138 {       int ndigit,sign,spare,i;
 139         long x;
 140         char *ans;
 141         if(len==sizeof(integer)) x=n->il;
 142         else if(len == sizeof(char)) x = n->ic;
 143         else x=n->is;
 144         ans=icvt(x,&ndigit,&sign, base);
 145         spare=w-ndigit;
 146         if(sign || cplus) spare--;
 147         if(spare<0)
 148                 for(i=0;i<w;i++) (*putn)('*');
 149         else
 150         {       for(i=0;i<spare;i++) (*putn)(' ');
 151                 if(sign) (*putn)('-');
 152                 else if(cplus) (*putn)('+');
 153                 for(i=0;i<ndigit;i++) (*putn)(*ans++);
 154         }
 155         return(0);
 156 }
 157 wrt_IM(n,w,m,len) uint *n; ftnlen len;
 158 {       int ndigit,sign,spare,i,xsign;
 159         long x;
 160         char *ans;
 161         if(sizeof(integer)==len) x=n->il;
 162         else if(len == sizeof(char)) x = n->ic;
 163         else x=n->is;
 164         ans=icvt(x,&ndigit,&sign, 10);
 165         if(sign || cplus) xsign=1;
 166         else xsign=0;
 167         if(ndigit+xsign>w || m+xsign>w)
 168         {       for(i=0;i<w;i++) (*putn)('*');
 169                 return(0);
 170         }
 171         if(x==0 && m==0)
 172         {       for(i=0;i<w;i++) (*putn)(' ');
 173                 return(0);
 174         }
 175         if(ndigit>=m)
 176                 spare=w-ndigit-xsign;
 177         else
 178                 spare=w-m-xsign;
 179         for(i=0;i<spare;i++) (*putn)(' ');
 180         if(sign) (*putn)('-');
 181         else if(cplus) (*putn)('+');
 182         for(i=0;i<m-ndigit;i++) (*putn)('0');
 183         for(i=0;i<ndigit;i++) (*putn)(*ans++);
 184         return(0);
 185 }
 186 wrt_AP(s)
 187  char *s;
 188 {       char quote;
 189         if(cursor && mv_cur()) return(mv_cur());
 190         quote = *s++;
 191         for(;*s;s++)
 192         {       if(*s!=quote) (*putn)(*s);
 193                 else if(*++s==quote) (*putn)(*s);
 194                 else return(1);
 195         }
 196         return(1);
 197 }
 198 wrt_H(a,s)
 199  char *s;
 200 {
 201         if(cursor && mv_cur()) return(mv_cur());
 202         while(a--) (*putn)(*s++);
 203         return(1);
 204 }
 205 wrt_L(n,len, sz) uint *n; ftnlen sz;
 206 {       int i;
 207         long x;
 208         if(sizeof(integer)==sz) x=n->il;
 209         else if(sz == sizeof(char)) x = n->ic;
 210         else x=n->is;
 211         for(i=0;i<len-1;i++)
 212                 (*putn)(' ');
 213         if(x) (*putn)('T');
 214         else (*putn)('F');
 215         return(0);
 216 }
 217 wrt_A(p,len) char *p; ftnlen len;
 218 {
 219         while(len-- > 0) (*putn)(*p++);
 220         return(0);
 221 }
 222 wrt_AW(p,w,len) char * p; ftnlen len;
 223 {
 224         while(w>len)
 225         {       w--;
 226                 (*putn)(' ');
 227         }
 228         while(w-- > 0)
 229                 (*putn)(*p++);
 230         return(0);
 231 }
 232
 233 wrt_G(p,w,d,e,len) ufloat *p; ftnlen len;
 234 {       double up = 1,x;
 235         int i,oldscale=scale,n,j;
 236         x= len==sizeof(real)?p->pf:p->pd;
 237         if(x < 0 ) x = -x;
 238         if(x<.1) return(wrt_E(p,w,d,e,len));
 239         for(i=0;i<=d;i++,up*=10)
 240         {       if(x>=up) continue;
 241                 scale=0;
 242                 if(e==0) n=4;
 243                 else    n=e+2;
 244                 i=wrt_F(p,w-n,d-i,len);
 245                 for(j=0;j<n;j++) (*putn)(' ');
 246                 scale=oldscale;
 247                 return(i);
 248         }
 249         return(wrt_E(p,w,d,e,len));
 250 }