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