00018 {
00019         static char buf[MAXINTLENGTH+1];
00020         register int i;
00021         ulongint uvalue;
00022 
00023         if(value > 0) {
00024                 uvalue = value;
00025                 *sign = 0;
00026                 }
00027         else if (value < 0) {
00028                 uvalue = -value;
00029                 *sign = 1;
00030                 }
00031         else {
00032                 *sign = 0;
00033                 *ndigit = 1;
00034                 buf[MAXINTLENGTH-1] = '0';
00035                 return &buf[MAXINTLENGTH-1];
00036                 }
00037         i = MAXINTLENGTH;
00038         do {
00039                 buf[--i] = (uvalue%base) + '0';
00040                 uvalue /= base;
00041                 }
00042                 while(uvalue > 0);
00043         *ndigit = MAXINTLENGTH - i;
00044         return &buf[i];
00045         }

00340 {
00341         f__parenlvl=f__revloc=f__pc=0;
00342         if(f_s(s,0) == NULL)
00343         {
00344                 return(-1);
00345         }
00346         return(0);
00347 }

00394 {       int ch;
00395         for(;f__cursor>0;f__cursor--) if((ch=(*f__getn)())<0) return(ch);
00396         if(f__cursor<0)
00397         {       if(f__recpos+f__cursor < 0) /*err(elist->cierr,110,"fmt")*/
00398                         f__cursor = -f__recpos; /* is this in the standard? */
00399                 if(f__external == 0) {
00400                         extern char *f__icptr;
00401                         f__icptr += f__cursor;
00402                 }
00403                 else if(f__curunit && f__curunit->useek)
00404                         (void) fseek(f__cf,(long) f__cursor,SEEK_CUR);
00405                 else
00406                         err(f__elist->cierr,106,"fmt");
00407                 f__recpos += f__cursor;
00408                 f__cursor=0;
00409         }
00410         switch(p->op)
00411         {
00412         default: fprintf(stderr,"rd_ed, unexpected code: %d\n", p->op);
00413                 sig_die(f__fmtbuf, 1);
00414         case IM:
00415         case I: ch = rd_I((Uint *)ptr,p->p1,len, 10);
00416                 break;
00417 
00418                 /* O and OM don't work right for character, double, complex, */
00419                 /* or doublecomplex, and they differ from Fortran 90 in */
00420                 /* showing a minus sign for negative values. */
00421 
00422         case OM:
00423         case O: ch = rd_I((Uint *)ptr, p->p1, len, 8);
00424                 break;
00425         case L: ch = rd_L((ftnint *)ptr,p->p1,len);
00426                 break;
00427         case A: ch = rd_A(ptr,len);
00428                 break;
00429         case AW:
00430                 ch = rd_AW(ptr,p->p1,len);
00431                 break;
00432         case E: case EE:
00433         case D:
00434         case G:
00435         case GE:
00436         case F: ch = rd_F((ufloat *)ptr,p->p1,p->p2,len);
00437                 break;
00438 
00439                 /* Z and ZM assume 8-bit bytes. */
00440 
00441         case ZM:
00442         case Z:
00443                 ch = rd_Z((Uint *)ptr, p->p1, len);
00444                 break;
00445         }
00446         if(ch == 0) return(ch);
00447         else if(ch == EOF) return(EOF);
00448         if (f__cf)
00449                 clearerr(f__cf);
00450         return(errno);
00451 }

00457 {
00458         switch(p->op)
00459         {
00460         default: fprintf(stderr,"rd_ned, unexpected code: %d\n", p->op);
00461                 sig_die(f__fmtbuf, 1);
00462         case APOS:
00463                 return(rd_POS(*(char **)&p->p2));
00464         case H: return(rd_H(p->p1,*(char **)&p->p2));
00465         case SLASH: return((*f__donewrec)());
00466         case TR:
00467         case X: f__cursor += p->p1;
00468                 return(1);
00469         case T: f__cursor=p->p1-f__recpos - 1;
00470                 return(1);
00471         case TL: f__cursor -= p->p1;
00472                 if(f__cursor < -f__recpos)      /* TL1000, 1X */
00473                         f__cursor = -f__recpos;
00474                 return(1);
00475         }
00476 }

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 }

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 }

00023 {
00024         char buf[FMAX+EXPMAXDIGS+4], *s, *se;
00025         int d1, delta, e1, i, sign, signspace;
00026         double dd;
00027 #ifdef WANT_LEAD_0
00028         int insert0 = 0;
00029 #endif
00030 #ifndef VAX
00031         int e0 = e;
00032 #endif
00033 
00034         if(e <= 0)
00035                 e = 2;
00036         if(f__scale) {
00037                 if(f__scale >= d + 2 || f__scale <= -d)
00038                         goto nogood;
00039                 }
00040         if(f__scale <= 0)
00041                 --d;
00042         if (len == sizeof(real))
00043                 dd = p->pf;
00044         else
00045                 dd = p->pd;
00046         if (dd < 0.) {
00047                 signspace = sign = 1;
00048                 dd = -dd;
00049                 }
00050         else {
00051                 sign = 0;
00052                 signspace = (int)f__cplus;
00053 #ifndef VAX
00054                 if (!dd)
00055                         dd = 0.;        /* avoid -0 */
00056 #endif
00057                 }
00058         delta = w - (2 /* for the . and the d adjustment above */
00059                         + 2 /* for the E+ */ + signspace + d + e);
00060 #ifdef WANT_LEAD_0
00061         if (f__scale <= 0 && delta > 0) {
00062                 delta--;
00063                 insert0 = 1;
00064                 }
00065         else
00066 #endif
00067         if (delta < 0) {
00068 nogood:
00069                 while(--w >= 0)
00070                         PUT('*');
00071                 return(0);
00072                 }
00073         if (f__scale < 0)
00074                 d += f__scale;
00075         if (d > FMAX) {
00076                 d1 = d - FMAX;
00077                 d = FMAX;
00078                 }
00079         else
00080                 d1 = 0;
00081         sprintf(buf,"%#.*E", d, dd);
00082 #ifndef VAX
00083         /* check for NaN, Infinity */
00084         if (!isdigit(buf[0])) {
00085                 switch(buf[0]) {
00086                         case 'n':
00087                         case 'N':
00088                                 signspace = 0;  /* no sign for NaNs */
00089                         }
00090                 delta = w - strlen(buf) - signspace;
00091                 if (delta < 0)
00092                         goto nogood;
00093                 while(--delta >= 0)
00094                         PUT(' ');
00095                 if (signspace)
00096                         PUT(sign ? '-' : '+');
00097                 for(s = buf; *s; s++)
00098                         PUT(*s);
00099                 return 0;
00100                 }
00101 #endif
00102         se = buf + d + 3;
00103 #ifdef GOOD_SPRINTF_EXPONENT /* When possible, exponent has 2 digits. */
00104         if (f__scale != 1 && dd)
00105                 sprintf(se, "%+.2d", atoi(se) + 1 - f__scale);
00106 #else
00107         if (dd)
00108                 sprintf(se, "%+.2d", atoi(se) + 1 - f__scale);
00109         else
00110                 strcpy(se, "+00");
00111 #endif
00112         s = ++se;
00113         if (e < 2) {
00114                 if (*s != '0')
00115                         goto nogood;
00116                 }
00117 #ifndef VAX
00118         /* accommodate 3 significant digits in exponent */
00119         if (s[2]) {
00120 #ifdef Pedantic
00121                 if (!e0 && !s[3])
00122                         for(s -= 2, e1 = 2; s[0] = s[1]; s++);
00123 
00124         /* Pedantic gives the behavior that Fortran 77 specifies,       */
00125         /* i.e., requires that E be specified for exponent fields       */
00126         /* of more than 3 digits.  With Pedantic undefined, we get      */
00127         /* the behavior that Cray displays -- you get a bigger          */
00128         /* exponent field if it fits.   */
00129 #else
00130                 if (!e0) {
00131                         for(s -= 2, e1 = 2; s[0] = s[1]; s++)
00132 #ifdef CRAY
00133                                 delta--;
00134                         if ((delta += 4) < 0)
00135                                 goto nogood
00136 #endif
00137                                 ;
00138                         }
00139 #endif
00140                 else if (e0 >= 0)
00141                         goto shift;
00142                 else
00143                         e1 = e;
00144                 }
00145         else
00146  shift:
00147 #endif
00148                 for(s += 2, e1 = 2; *s; ++e1, ++s)
00149                         if (e1 >= e)
00150                                 goto nogood;
00151         while(--delta >= 0)
00152                 PUT(' ');
00153         if (signspace)
00154                 PUT(sign ? '-' : '+');
00155         s = buf;
00156         i = f__scale;
00157         if (f__scale <= 0) {
00158 #ifdef WANT_LEAD_0
00159                 if (insert0)
00160                         PUT('0');
00161 #endif
00162                 PUT('.');
00163                 for(; i < 0; ++i)
00164                         PUT('0');
00165                 PUT(*s);
00166                 s += 2;
00167                 }
00168         else if (f__scale > 1) {
00169                 PUT(*s);
00170                 s += 2;
00171                 while(--i > 0)
00172                         PUT(*s++);
00173                 PUT('.');
00174                 }
00175         if (d1) {
00176                 se -= 2;
00177                 while(s < se) PUT(*s++);
00178                 se += 2;
00179                 do PUT('0'); while(--d1 > 0);
00180                 }
00181         while(s < se)
00182                 PUT(*s++);
00183         if (e < 2)
00184                 PUT(s[1]);
00185         else {
00186                 while(++e1 <= e)
00187                         PUT('0');
00188                 while(*s)
00189                         PUT(*s++);
00190                 }
00191         return 0;
00192         }

00199 {
00200         int d1, sign, n;
00201         double x;
00202         char *b, buf[MAXINTDIGS+MAXFRACDIGS+4], *s;
00203 
00204         x= (len==sizeof(real)?p->pf:p->pd);
00205         if (d < MAXFRACDIGS)
00206                 d1 = 0;
00207         else {
00208                 d1 = d - MAXFRACDIGS;
00209                 d = MAXFRACDIGS;
00210                 }
00211         if (x < 0.)
00212                 { x = -x; sign = 1; }
00213         else {
00214                 sign = 0;
00215 #ifndef VAX
00216                 if (!x)
00217                         x = 0.;
00218 #endif
00219                 }
00220 
00221         if (n = f__scale)
00222                 if (n > 0)
00223                         do x *= 10.; while(--n > 0);
00224                 else
00225                         do x *= 0.1; while(++n < 0);
00226 
00227 #ifdef USE_STRLEN
00228         sprintf(b = buf, "%#.*f", d, x);
00229         n = strlen(b) + d1;
00230 #else
00231         n = sprintf(b = buf, "%#.*f", d, x) + d1;
00232 #endif
00233 
00234 #ifndef WANT_LEAD_0
00235         if (buf[0] == '0' && d)
00236                 { ++b; --n; }
00237 #endif
00238         if (sign) {
00239                 /* check for all zeros */
00240                 for(s = b;;) {
00241                         while(*s == '0') s++;
00242                         switch(*s) {
00243                                 case '.':
00244                                         s++; continue;
00245                                 case 0:
00246                                         sign = 0;
00247                                 }
00248                         break;
00249                         }
00250                 }
00251         if (sign || f__cplus)
00252                 ++n;
00253         if (n > w) {
00254 #ifdef WANT_LEAD_0
00255                 if (buf[0] == '0' && --n == w)
00256                         ++b;
00257                 else
00258 #endif
00259                 {
00260                         while(--w >= 0)
00261                                 PUT('*');
00262                         return 0;
00263                         }
00264                 }
00265         for(w -= n; --w >= 0; )
00266                 PUT(' ');
00267         if (sign)
00268                 PUT('-');
00269         else if (f__cplus)
00270                 PUT('+');
00271         while(n = *b++)
00272                 PUT(n);
00273         while(--d1 >= 0)
00274                 PUT('0');
00275         return 0;
00276         }

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 }