diff options
Diffstat (limited to 'gnu/lib/libf2c/libI77/lwrite.c')
| -rw-r--r-- | gnu/lib/libf2c/libI77/lwrite.c | 277 |
1 files changed, 0 insertions, 277 deletions
diff --git a/gnu/lib/libf2c/libI77/lwrite.c b/gnu/lib/libf2c/libI77/lwrite.c deleted file mode 100644 index b910ab19872..00000000000 --- a/gnu/lib/libf2c/libI77/lwrite.c +++ /dev/null @@ -1,277 +0,0 @@ -#include "f2c.h" -#include "fio.h" -#include "fmt.h" -#include "lio.h" - -ftnint L_len; -int f__Aquote; - -static void -donewrec (void) -{ - if (f__recpos) - (*f__donewrec) (); -} - -static void -lwrt_I (longint n) -{ - 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++); -} -static void -lwrt_L (ftnint n, ftnlen len) -{ - if (f__recpos + LLOGW >= L_len) - donewrec (); - wrt_L ((Uint *) & n, LLOGW, len); -} -static void -lwrt_A (char *p, ftnlen len) -{ - 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 -#ifndef OMIT_BLANK_CC - || !f__recpos -#endif - ) - PUT (' '); - if (a) - { - PUT ('\''); - while (p < pe) - { - if (*p == '\'') - PUT ('\''); - PUT (*p++); - } - PUT ('\''); - } - else - while (p < pe) - PUT (*p++); -} - -static int -l_g (char *buf, double n) -{ -#ifdef Old_list_output - doublereal absn; - char *fmt; - - absn = n; - if (absn < 0) - absn = -absn; - fmt = LLOW <= absn && absn < LHIGH ? LFFMT : LEFMT; -#ifdef USE_STRLEN - sprintf (buf, fmt, n); - return strlen (buf); -#else - return sprintf (buf, fmt, n); -#endif - -#else - 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) - { -#ifndef WANT_LEAD_0 - case '0': - while (b[0] = b[1]) - b++; - break; -#endif - 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; -#endif -} - -static void -l_put (register char *s) -{ - register void (*pn) (int) = f__putn; - register int c; - - while ((c = *s++)) - (*pn) (c); -} - -static void -lwrt_F (double n) -{ - char buf[LEFBL]; - - if (f__recpos + l_g (buf, n) >= L_len) - donewrec (); - l_put (buf); -} -static void -lwrt_C (double a, double b) -{ - 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 (); -#ifdef OMIT_BLANK_CC - else -#endif - PUT (' '); - PUT ('('); - l_put (ba); - PUT (','); - if (f__recpos + bl >= L_len) - { - (*f__donewrec) (); -#ifndef OMIT_BLANK_CC - PUT (' '); -#endif - } - l_put (bb); - PUT (')'); -} - -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++) - { - 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; -#ifdef Allow_TYQUAD - 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; - } - return (0); -} |