summaryrefslogtreecommitdiffstats
path: root/contrib/libf2c/libI77/lwrite.c
diff options
context:
space:
mode:
Diffstat (limited to 'contrib/libf2c/libI77/lwrite.c')
-rw-r--r--contrib/libf2c/libI77/lwrite.c469
1 files changed, 222 insertions, 247 deletions
diff --git a/contrib/libf2c/libI77/lwrite.c b/contrib/libf2c/libI77/lwrite.c
index bf209f4..b910ab1 100644
--- a/contrib/libf2c/libI77/lwrite.c
+++ b/contrib/libf2c/libI77/lwrite.c
@@ -6,297 +6,272 @@
ftnint L_len;
int f__Aquote;
- static VOID
-donewrec(Void)
+static void
+donewrec (void)
{
- if (f__recpos)
- (*f__donewrec)();
- }
+ if (f__recpos)
+ (*f__donewrec) ();
+}
- static VOID
-#ifdef KR_headers
-lwrt_I(n) longint n;
-#else
-lwrt_I(longint n)
-#endif
+static void
+lwrt_I (longint n)
{
- char *p;
- int ndigit, sign;
+ char *p;
+ int ndigit, sign;
- p = f__icvt(n, &ndigit, &sign, 10);
- if(f__recpos + ndigit >= L_len)
- donewrec();
- PUT(' ');
- if (sign)
- PUT('-');
- while(*p)
- PUT(*p++);
+ p = f__icvt (n, &ndigit, &sign, 10);
+ if (f__recpos + ndigit >= L_len)
+ donewrec ();
+ PUT (' ');
+ if (sign)
+ PUT ('-');
+ while (*p)
+ PUT (*p++);
}
- static VOID
-#ifdef KR_headers
-lwrt_L(n, len) ftnint n; ftnlen len;
-#else
-lwrt_L(ftnint n, ftnlen len)
-#endif
+static void
+lwrt_L (ftnint n, ftnlen len)
{
- if(f__recpos+LLOGW>=L_len)
- donewrec();
- wrt_L((Uint *)&n,LLOGW, len);
+ if (f__recpos + LLOGW >= L_len)
+ donewrec ();
+ wrt_L ((Uint *) & n, LLOGW, len);
}
- static VOID
-#ifdef KR_headers
-lwrt_A(p,len) char *p; ftnlen len;
-#else
-lwrt_A(char *p, ftnlen len)
-#endif
+static void
+lwrt_A (char *p, ftnlen len)
{
- int a;
- char *p1, *pe;
+ int a;
+ char *p1, *pe;
- a = 0;
- pe = p + len;
- if (f__Aquote) {
- a = 3;
- if (len > 1 && p[len-1] == ' ') {
- while(--len > 1 && p[len-1] == ' ');
- pe = p + len;
- }
- p1 = p;
- while(p1 < pe)
- if (*p1++ == '\'')
- a++;
- }
- if(f__recpos+len+a >= L_len)
- donewrec();
- if (a
+ a = 0;
+ pe = p + len;
+ if (f__Aquote)
+ {
+ a = 3;
+ if (len > 1 && p[len - 1] == ' ')
+ {
+ while (--len > 1 && p[len - 1] == ' ');
+ pe = p + len;
+ }
+ p1 = p;
+ while (p1 < pe)
+ if (*p1++ == '\'')
+ a++;
+ }
+ if (f__recpos + len + a >= L_len)
+ donewrec ();
+ if (a
#ifndef OMIT_BLANK_CC
- || !f__recpos
+ || !f__recpos
#endif
- )
- PUT(' ');
- if (a) {
- PUT('\'');
- while(p < pe) {
- if (*p == '\'')
- PUT('\'');
- PUT(*p++);
- }
- PUT('\'');
- }
- else
- while(p < pe)
- PUT(*p++);
+ )
+ PUT (' ');
+ if (a)
+ {
+ PUT ('\'');
+ while (p < pe)
+ {
+ if (*p == '\'')
+ PUT ('\'');
+ PUT (*p++);
+ }
+ PUT ('\'');
+ }
+ else
+ while (p < pe)
+ PUT (*p++);
}
- static int
-#ifdef KR_headers
-l_g(buf, n) char *buf; double n;
-#else
-l_g(char *buf, double n)
-#endif
+static int
+l_g (char *buf, double n)
{
#ifdef Old_list_output
- doublereal absn;
- char *fmt;
+ doublereal absn;
+ char *fmt;
- absn = n;
- if (absn < 0)
- absn = -absn;
- fmt = LLOW <= absn && absn < LHIGH ? LFFMT : LEFMT;
+ absn = n;
+ if (absn < 0)
+ absn = -absn;
+ fmt = LLOW <= absn && absn < LHIGH ? LFFMT : LEFMT;
#ifdef USE_STRLEN
- sprintf(buf, fmt, n);
- return strlen(buf);
+ sprintf (buf, fmt, n);
+ return strlen (buf);
#else
- return sprintf(buf, fmt, n);
+ return sprintf (buf, fmt, n);
#endif
#else
- register char *b, c, c1;
+ register char *b, c, c1;
- b = buf;
- *b++ = ' ';
- if (n < 0) {
- *b++ = '-';
- n = -n;
- }
- else
- *b++ = ' ';
- if (n == 0) {
- *b++ = '0';
- *b++ = '.';
- *b = 0;
- goto f__ret;
- }
- sprintf(b, LGFMT, n);
- switch(*b) {
+ b = buf;
+ *b++ = ' ';
+ if (n < 0)
+ {
+ *b++ = '-';
+ n = -n;
+ }
+ else
+ *b++ = ' ';
+ if (n == 0)
+ {
+ *b++ = '0';
+ *b++ = '.';
+ *b = 0;
+ goto f__ret;
+ }
+ sprintf (b, LGFMT, n);
+ switch (*b)
+ {
#ifndef WANT_LEAD_0
- case '0':
- while(b[0] = b[1])
- b++;
- break;
+ case '0':
+ while (b[0] = b[1])
+ b++;
+ break;
#endif
- case 'i':
- case 'I':
- /* Infinity */
- case 'n':
- case 'N':
- /* NaN */
- while(*++b);
- break;
+ case 'i':
+ case 'I':
+ /* Infinity */
+ case 'n':
+ case 'N':
+ /* NaN */
+ while (*++b);
+ break;
- default:
- /* Fortran 77 insists on having a decimal point... */
- for(;; b++)
- switch(*b) {
- case 0:
- *b++ = '.';
- *b = 0;
- goto f__ret;
- case '.':
- while(*++b);
- goto f__ret;
- case 'E':
- for(c1 = '.', c = 'E'; *b = c1;
- c1 = c, c = *++b);
- goto f__ret;
- }
- }
- f__ret:
- return b - buf;
+ default:
+ /* Fortran 77 insists on having a decimal point... */
+ for (;; b++)
+ switch (*b)
+ {
+ case 0:
+ *b++ = '.';
+ *b = 0;
+ goto f__ret;
+ case '.':
+ while (*++b);
+ goto f__ret;
+ case 'E':
+ for (c1 = '.', c = 'E'; (*b = c1); c1 = c, c = *++b);
+ goto f__ret;
+ }
+ }
+f__ret:
+ return b - buf;
#endif
- }
+}
- static VOID
-#ifdef KR_headers
-l_put(s) register char *s;
-#else
-l_put(register char *s)
-#endif
+static void
+l_put (register char *s)
{
-#ifdef KR_headers
- register void (*pn)() = f__putn;
-#else
- register void (*pn)(int) = f__putn;
-#endif
- register int c;
+ register void (*pn) (int) = f__putn;
+ register int c;
- while(c = *s++)
- (*pn)(c);
- }
+ while ((c = *s++))
+ (*pn) (c);
+}
- static VOID
-#ifdef KR_headers
-lwrt_F(n) double n;
-#else
-lwrt_F(double n)
-#endif
+static void
+lwrt_F (double n)
{
- char buf[LEFBL];
+ char buf[LEFBL];
- if(f__recpos + l_g(buf,n) >= L_len)
- donewrec();
- l_put(buf);
+ if (f__recpos + l_g (buf, n) >= L_len)
+ donewrec ();
+ l_put (buf);
}
- static VOID
-#ifdef KR_headers
-lwrt_C(a,b) double a,b;
-#else
-lwrt_C(double a, double b)
-#endif
+static void
+lwrt_C (double a, double b)
{
- char *ba, *bb, bufa[LEFBL], bufb[LEFBL];
- int al, bl;
+ char *ba, *bb, bufa[LEFBL], bufb[LEFBL];
+ int al, bl;
- al = l_g(bufa, a);
- for(ba = bufa; *ba == ' '; ba++)
- --al;
- bl = l_g(bufb, b) + 1; /* intentionally high by 1 */
- for(bb = bufb; *bb == ' '; bb++)
- --bl;
- if(f__recpos + al + bl + 3 >= L_len)
- donewrec();
+ al = l_g (bufa, a);
+ for (ba = bufa; *ba == ' '; ba++)
+ --al;
+ bl = l_g (bufb, b) + 1; /* intentionally high by 1 */
+ for (bb = bufb; *bb == ' '; bb++)
+ --bl;
+ if (f__recpos + al + bl + 3 >= L_len)
+ donewrec ();
#ifdef OMIT_BLANK_CC
- else
+ else
#endif
- PUT(' ');
- PUT('(');
- l_put(ba);
- PUT(',');
- if (f__recpos + bl >= L_len) {
- (*f__donewrec)();
+ PUT (' ');
+ PUT ('(');
+ l_put (ba);
+ PUT (',');
+ if (f__recpos + bl >= L_len)
+ {
+ (*f__donewrec) ();
#ifndef OMIT_BLANK_CC
- PUT(' ');
+ PUT (' ');
#endif
- }
- l_put(bb);
- PUT(')');
+ }
+ l_put (bb);
+ PUT (')');
}
-#ifdef KR_headers
-l_write(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
-#else
-l_write(ftnint *number, char *ptr, ftnlen len, ftnint type)
-#endif
+
+int
+l_write (ftnint * number, char *ptr, ftnlen len, ftnint type)
{
#define Ptr ((flex *)ptr)
- int i;
- longint x;
- double y,z;
- real *xx;
- doublereal *yy;
- for(i=0;i< *number; i++)
+ int i;
+ longint x;
+ double y, z;
+ real *xx;
+ doublereal *yy;
+ for (i = 0; i < *number; i++)
+ {
+ switch ((int) type)
{
- switch((int)type)
- {
- default: f__fatal(204,"unknown type in lio");
- case TYINT1:
- x = Ptr->flchar;
- goto xint;
- case TYSHORT:
- x=Ptr->flshort;
- goto xint;
+ default:
+ f__fatal (204, "unknown type in lio");
+ case TYINT1:
+ x = Ptr->flchar;
+ goto xint;
+ case TYSHORT:
+ x = Ptr->flshort;
+ goto xint;
#ifdef Allow_TYQUAD
- case TYQUAD:
- x = Ptr->fllongint;
- goto xint;
+ case TYQUAD:
+ x = Ptr->fllongint;
+ goto xint;
#endif
- case TYLONG:
- x=Ptr->flint;
- xint: lwrt_I(x);
- break;
- case TYREAL:
- y=Ptr->flreal;
- goto xfloat;
- case TYDREAL:
- y=Ptr->fldouble;
- xfloat: lwrt_F(y);
- break;
- case TYCOMPLEX:
- xx= &Ptr->flreal;
- y = *xx++;
- z = *xx;
- goto xcomplex;
- case TYDCOMPLEX:
- yy = &Ptr->fldouble;
- y= *yy++;
- z = *yy;
- xcomplex:
- lwrt_C(y,z);
- break;
- case TYLOGICAL1:
- x = Ptr->flchar;
- goto xlog;
- case TYLOGICAL2:
- x = Ptr->flshort;
- goto xlog;
- case TYLOGICAL:
- x = Ptr->flint;
- xlog: lwrt_L(Ptr->flint, len);
- break;
- case TYCHAR:
- lwrt_A(ptr,len);
- break;
- }
- ptr += len;
+ case TYLONG:
+ x = Ptr->flint;
+ xint:lwrt_I (x);
+ break;
+ case TYREAL:
+ y = Ptr->flreal;
+ goto xfloat;
+ case TYDREAL:
+ y = Ptr->fldouble;
+ xfloat:lwrt_F (y);
+ break;
+ case TYCOMPLEX:
+ xx = &Ptr->flreal;
+ y = *xx++;
+ z = *xx;
+ goto xcomplex;
+ case TYDCOMPLEX:
+ yy = &Ptr->fldouble;
+ y = *yy++;
+ z = *yy;
+ xcomplex:
+ lwrt_C (y, z);
+ break;
+ case TYLOGICAL1:
+ x = Ptr->flchar;
+ goto xlog;
+ case TYLOGICAL2:
+ x = Ptr->flshort;
+ goto xlog;
+ case TYLOGICAL:
+ x = Ptr->flint;
+ xlog:lwrt_L (Ptr->flint, len);
+ break;
+ case TYCHAR:
+ lwrt_A (ptr, len);
+ break;
}
- return(0);
+ ptr += len;
+ }
+ return (0);
}
OpenPOWER on IntegriCloud