contrib/gcc-3.4/libf2c/libI77/lwrite.c

   1 #include "f2c.h"
   2 #include "fio.h"
   3 #include "fmt.h"
   4 #include "lio.h"
   5
   6 ftnint L_len;
   7 int f__Aquote;
   8
   9 static void
  10 donewrec (void)
  11 {
  12   if (f__recpos)
  13     (*f__donewrec) ();
  14 }
  15
  16 static void
  17 lwrt_I (longint n)
  18 {
  19   char *p;
  20   int ndigit, sign;
  21
  22   p = f__icvt (n, &ndigit, &sign, 10);
  23   if (f__recpos + ndigit >= L_len)
  24     donewrec ();
  25   PUT (' ');
  26   if (sign)
  27     PUT ('-');
  28   while (*p)
  29     PUT (*p++);
  30 }
  31 static void
  32 lwrt_L (ftnint n, ftnlen len)
  33 {
  34   if (f__recpos + LLOGW >= L_len)
  35     donewrec ();
  36   wrt_L ((Uint *) & n, LLOGW, len);
  37 }
  38 static void
  39 lwrt_A (char *p, ftnlen len)
  40 {
  41   int a;
  42   char *p1, *pe;
  43
  44   a = 0;
  45   pe = p + len;
  46   if (f__Aquote)
  47     {
  48       a = 3;
  49       if (len > 1 && p[len - 1] == ' ')
  50         {
  51           while (--len > 1 && p[len - 1] == ' ');
  52           pe = p + len;
  53         }
  54       p1 = p;
  55       while (p1 < pe)
  56         if (*p1++ == '\'')
  57           a++;
  58     }
  59   if (f__recpos + len + a >= L_len)
  60     donewrec ();
  61   if (a
  62 #ifndef OMIT_BLANK_CC
  63       || !f__recpos
  64 #endif
  65     )
  66     PUT (' ');
  67   if (a)
  68     {
  69       PUT ('\'');
  70       while (p < pe)
  71         {
  72           if (*p == '\'')
  73             PUT ('\'');
  74           PUT (*p++);
  75         }
  76       PUT ('\'');
  77     }
  78   else
  79     while (p < pe)
  80       PUT (*p++);
  81 }
  82
  83 static int
  84 l_g (char *buf, double n)
  85 {
  86 #ifdef Old_list_output
  87   doublereal absn;
  88   char *fmt;
  89
  90   absn = n;
  91   if (absn < 0)
  92     absn = -absn;
  93   fmt = LLOW <= absn && absn < LHIGH ? LFFMT : LEFMT;
  94 #ifdef USE_STRLEN
  95   sprintf (buf, fmt, n);
  96   return strlen (buf);
  97 #else
  98   return sprintf (buf, fmt, n);
  99 #endif
 100
 101 #else
 102   register char *b, c, c1;
 103
 104   b = buf;
 105   *b++ = ' ';
 106   if (n < 0)
 107     {
 108       *b++ = '-';
 109       n = -n;
 110     }
 111   else
 112     *b++ = ' ';
 113   if (n == 0)
 114     {
 115       *b++ = '0';
 116       *b++ = '.';
 117       *b = 0;
 118       goto f__ret;
 119     }
 120   sprintf (b, LGFMT, n);
 121   switch (*b)
 122     {
 123 #ifndef WANT_LEAD_0
 124     case '0':
 125       while (b[0] = b[1])
 126         b++;
 127       break;
 128 #endif
 129     case 'i':
 130     case 'I':
 131       /* Infinity */
 132     case 'n':
 133     case 'N':
 134       /* NaN */
 135       while (*++b);
 136       break;
 137
 138     default:
 139       /* Fortran 77 insists on having a decimal point... */
 140       for (;; b++)
 141         switch (*b)
 142           {
 143           case 0:
 144             *b++ = '.';
 145             *b = 0;
 146             goto f__ret;
 147           case '.':
 148             while (*++b);
 149             goto f__ret;
 150           case 'E':
 151             for (c1 = '.', c = 'E'; (*b = c1); c1 = c, c = *++b);
 152             goto f__ret;
 153           }
 154     }
 155 f__ret:
 156   return b - buf;
 157 #endif
 158 }
 159
 160 static void
 161 l_put (register char *s)
 162 {
 163   register void (*pn) (int) = f__putn;
 164   register int c;
 165
 166   while ((c = *s++))
 167     (*pn) (c);
 168 }
 169
 170 static void
 171 lwrt_F (double n)
 172 {
 173   char buf[LEFBL];
 174
 175   if (f__recpos + l_g (buf, n) >= L_len)
 176     donewrec ();
 177   l_put (buf);
 178 }
 179 static void
 180 lwrt_C (double a, double b)
 181 {
 182   char *ba, *bb, bufa[LEFBL], bufb[LEFBL];
 183   int al, bl;
 184
 185   al = l_g (bufa, a);
 186   for (ba = bufa; *ba == ' '; ba++)
 187     --al;
 188   bl = l_g (bufb, b) + 1;       /* intentionally high by 1 */
 189   for (bb = bufb; *bb == ' '; bb++)
 190     --bl;
 191   if (f__recpos + al + bl + 3 >= L_len)
 192     donewrec ();
 193 #ifdef OMIT_BLANK_CC
 194   else
 195 #endif
 196     PUT (' ');
 197   PUT ('(');
 198   l_put (ba);
 199   PUT (',');
 200   if (f__recpos + bl >= L_len)
 201     {
 202       (*f__donewrec) ();
 203 #ifndef OMIT_BLANK_CC
 204       PUT (' ');
 205 #endif
 206     }
 207   l_put (bb);
 208   PUT (')');
 209 }
 210
 211 int
 212 l_write (ftnint * number, char *ptr, ftnlen len, ftnint type)
 213 {
 214 #define Ptr ((flex *)ptr)
 215   int i;
 216   longint x;
 217   double y, z;
 218   real *xx;
 219   doublereal *yy;
 220   for (i = 0; i < *number; i++)
 221     {
 222       switch ((int) type)
 223         {
 224         default:
 225           f__fatal (204, "unknown type in lio");
 226         case TYINT1:
 227           x = Ptr->flchar;
 228           goto xint;
 229         case TYSHORT:
 230           x = Ptr->flshort;
 231           goto xint;
 232 #ifdef Allow_TYQUAD
 233         case TYQUAD:
 234           x = Ptr->fllongint;
 235           goto xint;
 236 #endif
 237         case TYLONG:
 238           x = Ptr->flint;
 239         xint:lwrt_I (x);
 240           break;
 241         case TYREAL:
 242           y = Ptr->flreal;
 243           goto xfloat;
 244         case TYDREAL:
 245           y = Ptr->fldouble;
 246         xfloat:lwrt_F (y);
 247           break;
 248         case TYCOMPLEX:
 249           xx = &Ptr->flreal;
 250           y = *xx++;
 251           z = *xx;
 252           goto xcomplex;
 253         case TYDCOMPLEX:
 254           yy = &Ptr->fldouble;
 255           y = *yy++;
 256           z = *yy;
 257         xcomplex:
 258           lwrt_C (y, z);
 259           break;
 260         case TYLOGICAL1:
 261           x = Ptr->flchar;
 262           goto xlog;
 263         case TYLOGICAL2:
 264           x = Ptr->flshort;
 265           goto xlog;
 266         case TYLOGICAL:
 267           x = Ptr->flint;
 268         xlog:lwrt_L (Ptr->flint, len);
 269           break;
 270         case TYCHAR:
 271           lwrt_A (ptr, len);
 272           break;
 273         }
 274       ptr += len;
 275     }
 276   return (0);
 277 }