diff options
Diffstat (limited to 'contrib/libf2c/libI77/lwrite.c')
| -rw-r--r-- | contrib/libf2c/libI77/lwrite.c | 277 |
1 files changed, 277 insertions, 0 deletions
diff --git a/contrib/libf2c/libI77/lwrite.c b/contrib/libf2c/libI77/lwrite.c new file mode 100644 index 0000000..b910ab1 --- /dev/null +++ b/contrib/libf2c/libI77/lwrite.c @@ -0,0 +1,277 @@ +#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); +} |
