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