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