summaryrefslogtreecommitdiff
path: root/Build/source/utils/pmx/pmx-2.6.18/libf2c/wrtfmt.c
diff options
context:
space:
mode:
Diffstat (limited to 'Build/source/utils/pmx/pmx-2.6.18/libf2c/wrtfmt.c')
-rw-r--r--Build/source/utils/pmx/pmx-2.6.18/libf2c/wrtfmt.c377
1 files changed, 377 insertions, 0 deletions
diff --git a/Build/source/utils/pmx/pmx-2.6.18/libf2c/wrtfmt.c b/Build/source/utils/pmx/pmx-2.6.18/libf2c/wrtfmt.c
new file mode 100644
index 00000000000..a970db95910
--- /dev/null
+++ b/Build/source/utils/pmx/pmx-2.6.18/libf2c/wrtfmt.c
@@ -0,0 +1,377 @@
+#include "f2c.h"
+#include "fio.h"
+#include "fmt.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+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);
+}
+
+ int
+#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));
+}
+
+ int
+#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));
+ }
+}
+
+ int
+#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));
+ }
+}
+#ifdef __cplusplus
+}
+#endif
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-03 17:32:38 +0000