+++ /dev/null
-#include "config.h"
-#include "f2c.h"
-#include "fio.h"
-#include "fmt.h"
-
-extern icilist *f__svic;
-extern char *f__icptr;
-
- static int
-mv_cur(Void) /* shouldn't use fseek because it insists on calling fflush */
- /* instead we know too much about stdio */
-{
- int cursor = f__cursor;
- f__cursor = 0;
- if(f__external == 0) {
- if(cursor < 0) {
- if(f__hiwater < f__recpos)
- f__hiwater = f__recpos;
- f__recpos += cursor;
- f__icptr += cursor;
- if(f__recpos < 0)
- err(f__elist->cierr, 110, "left off");
- }
- else if(cursor > 0) {
- if(f__recpos + cursor >= f__svic->icirlen)
- err(f__elist->cierr, 110, "recend");
- if(f__hiwater <= f__recpos)
- for(; cursor > 0; cursor--)
- (*f__putn)(' ');
- else if(f__hiwater <= f__recpos + cursor) {
- cursor -= f__hiwater - f__recpos;
- f__icptr += f__hiwater - f__recpos;
- f__recpos = f__hiwater;
- for(; cursor > 0; cursor--)
- (*f__putn)(' ');
- }
- else {
- f__icptr += cursor;
- f__recpos += cursor;
- }
- }
- return(0);
- }
- if (cursor > 0) {
- if(f__hiwater <= f__recpos)
- for(;cursor>0;cursor--) (*f__putn)(' ');
- else if(f__hiwater <= f__recpos + cursor) {
- cursor -= f__hiwater - f__recpos;
- f__recpos = f__hiwater;
- for(; cursor > 0; cursor--)
- (*f__putn)(' ');
- }
- else {
- f__recpos += cursor;
- }
- }
- else if (cursor < 0)
- {
- if(cursor + f__recpos < 0)
- err(f__elist->cierr,110,"left off");
- if(f__hiwater < f__recpos)
- f__hiwater = f__recpos;
- f__recpos += cursor;
- }
- return(0);
-}
-
- static int
-#ifdef KR_headers
-wrt_Z(n,w,minlen,len) Uint *n; int w, minlen; ftnlen len;
-#else
-wrt_Z(Uint *n, int w, int minlen, ftnlen len)
-#endif
-{
- register char *s, *se;
- register int i, w1;
- static int one = 1;
- static char hex[] = "0123456789ABCDEF";
- s = (char *)n;
- --len;
- if (*(char *)&one) {
- /* little endian */
- se = s;
- s += len;
- i = -1;
- }
- else {
- se = s + len;
- i = 1;
- }
- for(;; s += i)
- if (s == se || *s)
- break;
- w1 = (i*(se-s) << 1) + 1;
- if (*s & 0xf0)
- w1++;
- if (w1 > w)
- for(i = 0; i < w; i++)
- (*f__putn)('*');
- else {
- if ((minlen -= w1) > 0)
- w1 += minlen;
- while(--w >= w1)
- (*f__putn)(' ');
- while(--minlen >= 0)
- (*f__putn)('0');
- if (!(*s & 0xf0)) {
- (*f__putn)(hex[*s & 0xf]);
- if (s == se)
- return 0;
- s += i;
- }
- for(;; s += i) {
- (*f__putn)(hex[*s >> 4 & 0xf]);
- (*f__putn)(hex[*s & 0xf]);
- if (s == se)
- break;
- }
- }
- return 0;
- }
-
- static int
-#ifdef KR_headers
-wrt_I(n,w,len, base) Uint *n; ftnlen len; register int base;
-#else
-wrt_I(Uint *n, int w, ftnlen len, register int base)
-#endif
-{ int ndigit,sign,spare,i;
- longint x;
- char *ans;
- if(len==sizeof(integer)) x=n->il;
- else if(len == sizeof(char)) x = n->ic;
-#ifdef Allow_TYQUAD
- else if (len == sizeof(longint)) x = n->ili;
-#endif
- else x=n->is;
- ans=f__icvt(x,&ndigit,&sign, base);
- spare=w-ndigit;
- if(sign || f__cplus) spare--;
- if(spare<0)
- for(i=0;i<w;i++) (*f__putn)('*');
- else
- { for(i=0;i<spare;i++) (*f__putn)(' ');
- if(sign) (*f__putn)('-');
- else if(f__cplus) (*f__putn)('+');
- for(i=0;i<ndigit;i++) (*f__putn)(*ans++);
- }
- return(0);
-}
- static int
-#ifdef KR_headers
-wrt_IM(n,w,m,len,base) Uint *n; ftnlen len; int base;
-#else
-wrt_IM(Uint *n, int w, int m, ftnlen len, int base)
-#endif
-{ int ndigit,sign,spare,i,xsign;
- longint x;
- char *ans;
- if(sizeof(integer)==len) x=n->il;
- else if(len == sizeof(char)) x = n->ic;
-#ifdef Allow_TYQUAD
- else if (len == sizeof(longint)) x = n->ili;
-#endif
- else x=n->is;
- ans=f__icvt(x,&ndigit,&sign, base);
- if(sign || f__cplus) xsign=1;
- else xsign=0;
- if(ndigit+xsign>w || m+xsign>w)
- { for(i=0;i<w;i++) (*f__putn)('*');
- return(0);
- }
- if(x==0 && m==0)
- { for(i=0;i<w;i++) (*f__putn)(' ');
- return(0);
- }
- if(ndigit>=m)
- spare=w-ndigit-xsign;
- else
- spare=w-m-xsign;
- for(i=0;i<spare;i++) (*f__putn)(' ');
- if(sign) (*f__putn)('-');
- else if(f__cplus) (*f__putn)('+');
- for(i=0;i<m-ndigit;i++) (*f__putn)('0');
- for(i=0;i<ndigit;i++) (*f__putn)(*ans++);
- return(0);
-}
- static int
-#ifdef KR_headers
-wrt_AP(s) char *s;
-#else
-wrt_AP(char *s)
-#endif
-{ char quote;
- int i;
-
- if(f__cursor && (i = mv_cur()))
- return i;
- quote = *s++;
- for(;*s;s++)
- { if(*s!=quote) (*f__putn)(*s);
- else if(*++s==quote) (*f__putn)(*s);
- else return(1);
- }
- return(1);
-}
- static int
-#ifdef KR_headers
-wrt_H(a,s) char *s;
-#else
-wrt_H(int a, char *s)
-#endif
-{
- int i;
-
- if(f__cursor && (i = mv_cur()))
- return i;
- while(a--) (*f__putn)(*s++);
- return(1);
-}
-#ifdef KR_headers
-wrt_L(n,len, sz) Uint *n; ftnlen sz;
-#else
-wrt_L(Uint *n, int len, ftnlen sz)
-#endif
-{ int i;
- long x;
- if(sizeof(long)==sz) x=n->il;
- else if(sz == sizeof(char)) x = n->ic;
- else x=n->is;
- for(i=0;i<len-1;i++)
- (*f__putn)(' ');
- if(x) (*f__putn)('T');
- else (*f__putn)('F');
- return(0);
-}
- static int
-#ifdef KR_headers
-wrt_A(p,len) char *p; ftnlen len;
-#else
-wrt_A(char *p, ftnlen len)
-#endif
-{
- while(len-- > 0) (*f__putn)(*p++);
- return(0);
-}
- static int
-#ifdef KR_headers
-wrt_AW(p,w,len) char * p; ftnlen len;
-#else
-wrt_AW(char * p, int w, ftnlen len)
-#endif
-{
- while(w>len)
- { w--;
- (*f__putn)(' ');
- }
- while(w-- > 0)
- (*f__putn)(*p++);
- return(0);
-}
-
- static int
-#ifdef KR_headers
-wrt_G(p,w,d,e,len) ufloat *p; ftnlen len;
-#else
-wrt_G(ufloat *p, int w, int d, int e, ftnlen len)
-#endif
-{ double up = 1,x;
- int i=0,oldscale,n,j;
- x = len==sizeof(real)?p->pf:p->pd;
- if(x < 0 ) x = -x;
- if(x<.1) {
- if (x != 0.)
- return(wrt_E(p,w,d,e,len));
- i = 1;
- goto have_i;
- }
- for(;i<=d;i++,up*=10)
- { if(x>=up) continue;
- have_i:
- oldscale = f__scale;
- f__scale = 0;
- if(e==0) n=4;
- else n=e+2;
- i=wrt_F(p,w-n,d-i,len);
- for(j=0;j<n;j++) (*f__putn)(' ');
- f__scale=oldscale;
- return(i);
- }
- return(wrt_E(p,w,d,e,len));
-}
-#ifdef KR_headers
-w_ed(p,ptr,len) struct syl *p; char *ptr; ftnlen len;
-#else
-w_ed(struct syl *p, char *ptr, ftnlen len)
-#endif
-{
- int i;
-
- if(f__cursor && (i = mv_cur()))
- return i;
- switch(p->op)
- {
- default:
- fprintf(stderr,"w_ed, unexpected code: %d\n", p->op);
- sig_die(f__fmtbuf, 1);
- case I: return(wrt_I((Uint *)ptr,p->p1,len, 10));
- case IM:
- return(wrt_IM((Uint *)ptr,p->p1,p->p2.i[0],len,10));
-
- /* O and OM don't work right for character, double, complex, */
- /* or doublecomplex, and they differ from Fortran 90 in */
- /* showing a minus sign for negative values. */
-
- case O: return(wrt_I((Uint *)ptr, p->p1, len, 8));
- case OM:
- return(wrt_IM((Uint *)ptr,p->p1,p->p2.i[0],len,8));
- case L: return(wrt_L((Uint *)ptr,p->p1, len));
- case A: return(wrt_A(ptr,len));
- case AW:
- return(wrt_AW(ptr,p->p1,len));
- case D:
- case E:
- case EE:
- return(wrt_E((ufloat *)ptr,p->p1,p->p2.i[0],p->p2.i[1],len));
- case G:
- case GE:
- return(wrt_G((ufloat *)ptr,p->p1,p->p2.i[0],p->p2.i[1],len));
- case F: return(wrt_F((ufloat *)ptr,p->p1,p->p2.i[0],len));
-
- /* Z and ZM assume 8-bit bytes. */
-
- case Z: return(wrt_Z((Uint *)ptr,p->p1,0,len));
- case ZM:
- return(wrt_Z((Uint *)ptr,p->p1,p->p2.i[0],len));
- }
-}
-#ifdef KR_headers
-w_ned(p) struct syl *p;
-#else
-w_ned(struct syl *p)
-#endif
-{
- switch(p->op)
- {
- default: fprintf(stderr,"w_ned, unexpected code: %d\n", p->op);
- sig_die(f__fmtbuf, 1);
- case SLASH:
- return((*f__donewrec)());
- case T: f__cursor = p->p1-f__recpos - 1;
- return(1);
- case TL: f__cursor -= p->p1;
- if(f__cursor < -f__recpos) /* TL1000, 1X */
- f__cursor = -f__recpos;
- return(1);
- case TR:
- case X:
- f__cursor += p->p1;
- return(1);
- case APOS:
- return(wrt_AP(p->p2.s));
- case H:
- return(wrt_H(p->p1,p->p2.s));
- }
-}
projects / msp430-gcc.git / blobdiff