external/bsd/pcc/dist/pcc-libs/libI77/lread.c

   1 /*      $Id: lread.c,v 1.1.1.1 2008/08/24 05:34:47 gmcgarry Exp $       */
   2 /*
   3  * Copyright(C) Caldera International Inc. 2001-2002. All rights reserved.
   4  *
   5  * Redistribution and use in source and binary forms, with or without
   6  * modification, are permitted provided that the following conditions
   7  * are met:
   8  *
   9  * Redistributions of source code and documentation must retain the above
  10  * copyright notice, this list of conditions and the following disclaimer.
  11  * Redistributions in binary form must reproduce the above copyright
  12  * notice, this list of conditionsand the following disclaimer in the
  13  * documentation and/or other materials provided with the distribution.
  14  * All advertising materials mentioning features or use of this software
  15  * must display the following acknowledgement:
  16  *      This product includes software developed or owned by Caldera
  17  *      International, Inc.
  18  * Neither the name of Caldera International, Inc. nor the names of other
  19  * contributors may be used to endorse or promote products derived from
  20  * this software without specific prior written permission.
  21  *
  22  * USE OF THE SOFTWARE PROVIDED FOR UNDER THIS LICENSE BY CALDERA
  23  * INTERNATIONAL, INC. AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR
  24  * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  25  * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
  26  * DISCLAIMED.  IN NO EVENT SHALL CALDERA INTERNATIONAL, INC. BE LIABLE
  27  * FOR ANY DIRECT, INDIRECT INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  28  * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
  29  * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  30  * HOWEVER CAUSED AND ON ANY THEORY OFLIABILITY, WHETHER IN CONTRACT,
  31  * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING
  32  * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
  33  * POSSIBILITY OF SUCH DAMAGE.
  34  */
  35 #include <stdlib.h>
  36
  37 #include "fio.h"
  38 #include "fmt.h"
  39 #include "lio.h"
  40 #include "ctype.h"
  41
  42 extern char *fmtbuf;
  43 int (*lioproc)(ftnint *number,flex *ptr,ftnlen len,ftnint type);
  44
  45 static int rd_int(double *x);
  46 int l_R(void);
  47 int l_C(void);
  48 int l_L(void);
  49 int l_CHAR(void);
  50 int t_getc(void);
  51 int t_sep(void);
  52
  53 #define isblnk(x) (ltab[x+1]&B)
  54 #define issep(x) (ltab[x+1]&SX)
  55 #define isapos(x) (ltab[x+1]&AX)
  56 #define isexp(x) (ltab[x+1]&EX)
  57 #define SX 1
  58 #define B 2
  59 #define AX 4
  60 #define EX 8
  61 char ltab[128+1] =      /* offset one for EOF */
  62 {       0,
  63         0,0,AX,0,0,0,0,0,0,0,B,0,0,0,0,0,
  64         0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  65         SX|B,0,AX,0,0,0,0,0,0,0,0,0,SX,0,0,SX,
  66         0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  67         0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
  68         AX,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  69         0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
  70         0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
  71 };
  72
  73 int l_first;
  74
  75 int
  76 t_getc()
  77 {       int ch;
  78         if(curunit->uend) return(EOF);
  79         if((ch=getc(cf))!=EOF) return(ch);
  80         if(feof(cf)) curunit->uend = 1;
  81         return(EOF);
  82 }
  83
  84 int
  85 e_rsle()
  86 {
  87         int ch;
  88         if(curunit->uend) return(0);
  89         while((ch=t_getc())!='\n' && ch!=EOF);
  90         return(0);
  91 }
  92
  93 flag lquit;
  94 int lcount,ltype;
  95 char *lchar;
  96 double lx,ly;
  97 #define ERR(x) if((n=(x))) return(n)
  98 #define GETC(x) ((x=t_getc()))
  99
 100 static int
 101 l_read(ftnint *number,flex *ptr,ftnlen len,ftnint type)
 102 {       int i,n,ch;
 103         double *yy;
 104         float *xx;
 105         for(i=0;i<*number;i++)
 106         {
 107                 if(curunit->uend) err(elist->ciend, EOF, "list in")
 108                 if(l_first)
 109                 {       l_first=0;
 110                         for(GETC(ch);isblnk(ch);GETC(ch));
 111                         ungetc(ch,cf);
 112                 }
 113                 else if(lcount==0)
 114                 {       ERR(t_sep());
 115                         if(lquit) return(0);
 116                 }
 117                 switch((int)type)
 118                 {
 119                 case TYSHORT:
 120                 case TYLONG:
 121                 case TYREAL:
 122                 case TYDREAL:
 123                         ERR(l_R());
 124                         break;
 125                 case TYCOMPLEX:
 126                 case TYDCOMPLEX:
 127                         ERR(l_C());
 128                         break;
 129                 case TYLOGICAL:
 130                         ERR(l_L());
 131                         break;
 132                 case TYCHAR:
 133                         ERR(l_CHAR());
 134                         break;
 135                 }
 136                 if(lquit) return(0);
 137                 if(feof(cf)) err(elist->ciend,(EOF),"list in")
 138                 else if(ferror(cf))
 139                 {       clearerr(cf);
 140                         err(elist->cierr,errno,"list in")
 141                 }
 142                 if(ltype==0) goto bump;
 143                 switch((int)type)
 144                 {
 145                 case TYSHORT:
 146                         ptr->flshort=lx;
 147                         break;
 148                 case TYLOGICAL:
 149                 case TYLONG:
 150                         ptr->flint=lx;
 151                         break;
 152                 case TYREAL:
 153                         ptr->flreal=lx;
 154                         break;
 155                 case TYDREAL:
 156                         ptr->fldouble=lx;
 157                         break;
 158                 case TYCOMPLEX:
 159                         xx=(float *)ptr;
 160                         *xx++ = lx;
 161                         *xx = ly;
 162                         break;
 163                 case TYDCOMPLEX:
 164                         yy=(double *)ptr;
 165                         *yy++ = lx;
 166                         *yy = ly;
 167                         break;
 168                 case TYCHAR:
 169                         b_char(lchar,(char *)ptr,len);
 170                         break;
 171                 }
 172         bump:
 173                 if(lcount>0) lcount--;
 174                 ptr = (flex *)((char *)ptr + len);
 175         }
 176         return(0);
 177 }
 178
 179 int
 180 l_R()
 181 {       double a,b,c,d;
 182         int i,ch,sign=0,da,db,dc;
 183         a=b=c=d=0;
 184         da=db=dc=0;
 185         if(lcount>0) return(0);
 186         ltype=0;
 187         for(GETC(ch);isblnk(ch);GETC(ch));
 188         if(ch==',')
 189         {       lcount=1;
 190                 return(0);
 191         }
 192         if(ch=='/')
 193         {       lquit=1;
 194                 return(0);
 195         }
 196         ungetc(ch,cf);
 197         da=rd_int(&a);
 198         if(da== -1) sign=da;
 199         if(GETC(ch)!='*')
 200         {       ungetc(ch,cf);
 201                 db=1;
 202                 b=a;
 203                 a=1;
 204         }
 205         else
 206                 db=rd_int(&b);
 207         if(GETC(ch)!='.')
 208         {       dc=c=0;
 209                 ungetc(ch,cf);
 210         }
 211         else    dc=rd_int(&c);
 212         if(isexp(GETC(ch))) db=rd_int(&d);
 213         else
 214         {       ungetc(ch,cf);
 215                 d=0;
 216         }
 217         lcount=a;
 218         if(!db && !dc)
 219                 return(0);
 220         if(db && b<0)
 221         {       sign=1;
 222                 b = -b;
 223         }
 224         for(i=0;i<dc;i++) c/=10;
 225         b=b+c;
 226         for(i=0;i<d;i++) b *= 10;
 227         for(i=0;i< -d;i++) b /= 10;
 228         if(sign) b = -b;
 229         ltype=TYLONG;
 230         lx=b;
 231         return(0);
 232 }
 233
 234 int
 235 rd_int(double *x)
 236 {       int ch,sign=0,i;
 237         double y;
 238         i=0;
 239         y=0;
 240         if(GETC(ch)=='-') sign = -1;
 241         else if(ch=='+') sign=0;
 242         else ungetc(ch,cf);
 243         while(isdigit(GETC(ch)))
 244         {       i++;
 245                 y=10*y+ch-'0';
 246         }
 247         ungetc(ch,cf);
 248         if(sign) y = -y;
 249         *x = y;
 250         return(y!=0?i:sign);
 251 }
 252
 253 int
 254 l_C()
 255 {       int ch;
 256         if(lcount>0) return(0);
 257         ltype=0;
 258         for(GETC(ch);isblnk(ch);GETC(ch));
 259         if(ch==',')
 260         {       lcount=1;
 261                 return(0);
 262         }
 263         if(ch=='/')
 264         {       lquit=1;
 265                 return(0);
 266         }
 267         if(ch!='(')
 268         {       if(fscanf(cf,"%d",&lcount)!=1) {
 269                         if(!feof(cf)) err(elist->cierr,112,"no rep")
 270                         else err(elist->cierr,(EOF),"lread");
 271                 }
 272                 if(GETC(ch)!='*')
 273                 {       ungetc(ch,cf);
 274                         if(!feof(cf)) err(elist->cierr,112,"no star")
 275                         else err(elist->cierr,(EOF),"lread");
 276                 }
 277                 if(GETC(ch)!='(')
 278                 {       ungetc(ch,cf);
 279                         return(0);
 280                 }
 281         }
 282         lcount = 1;
 283         ltype=TYLONG;
 284         fscanf(cf,"%lf",&lx);
 285         while(isblnk(GETC(ch)));
 286         if(ch!=',')
 287         {       ungetc(ch,cf);
 288                 err(elist->cierr,112,"no comma");
 289         }
 290         while(isblnk(GETC(ch)));
 291         ungetc(ch,cf);
 292         fscanf(cf,"%lf",&ly);
 293         while(isblnk(GETC(ch)));
 294         if(ch!=')') err(elist->cierr,112,"no )");
 295         while(isblnk(GETC(ch)));
 296         ungetc(ch,cf);
 297         return(0);
 298 }
 299
 300 int
 301 l_L()
 302 {
 303         int ch;
 304         if(lcount>0) return(0);
 305         ltype=0;
 306         while(isblnk(GETC(ch)));
 307         if(ch==',')
 308         {       lcount=1;
 309                 return(0);
 310         }
 311         if(ch=='/')
 312         {       lquit=1;
 313                 return(0);
 314         }
 315         if(isdigit(ch))
 316         {       ungetc(ch,cf);
 317                 fscanf(cf,"%d",&lcount);
 318                 if(GETC(ch)!='*') {
 319                         if(!feof(cf)) err(elist->cierr,112,"no star")
 320                         else err(elist->cierr,(EOF),"lread");
 321                 }
 322         }
 323         else    ungetc(ch,cf);
 324         if(GETC(ch)=='.') GETC(ch);
 325         switch(ch)
 326         {
 327         case 't':
 328         case 'T':
 329                 lx=1;
 330                 break;
 331         case 'f':
 332         case 'F':
 333                 lx=0;
 334                 break;
 335         default:
 336                 if(isblnk(ch) || issep(ch) || ch==EOF)
 337                 {       ungetc(ch,cf);
 338                         return(0);
 339                 }
 340                 else    err(elist->cierr,112,"logical");
 341         }
 342         ltype=TYLONG;
 343         while(!issep(GETC(ch)) && ch!='\n' && ch!=EOF);
 344         return(0);
 345 }
 346 #define BUFSIZE 128
 347
 348 int
 349 l_CHAR()
 350 {       int ch,size,i;
 351         char quote,*p;
 352         if(lcount>0) return(0);
 353         ltype=0;
 354
 355         while(isblnk(GETC(ch)));
 356         if(ch==',')
 357         {       lcount=1;
 358                 return(0);
 359         }
 360         if(ch=='/')
 361         {       lquit=1;
 362                 return(0);
 363         }
 364         if(isdigit(ch))
 365         {       ungetc(ch,cf);
 366                 fscanf(cf,"%d",&lcount);
 367                 if(GETC(ch)!='*') err(elist->cierr,112,"no star");
 368         }
 369         else    ungetc(ch,cf);
 370         if(GETC(ch)=='\'' || ch=='"') quote=ch;
 371         else if(isblnk(ch) || issep(ch) || ch==EOF)
 372         {       ungetc(ch,cf);
 373                 return(0);
 374         }
 375         else err(elist->cierr,112,"no quote");
 376         ltype=TYCHAR;
 377         if(lchar!=NULL) free(lchar);
 378         size=BUFSIZE;
 379         p=lchar=(char *)malloc(size);
 380         if(lchar==NULL) err(elist->cierr,113,"no space");
 381         for(i=0;;)
 382         {       while(GETC(ch)!=quote && ch!='\n'
 383                         && ch!=EOF && ++i<size) *p++ = ch;
 384                 if(i==size)
 385                 {
 386                 newone:
 387                         lchar=(char *)realloc(lchar, size += BUFSIZE);
 388                         p=lchar+i-1;
 389                         *p++ = ch;
 390                 }
 391                 else if(ch==EOF) return(EOF);
 392                 else if(ch=='\n')
 393                 {       if(*(p-1) != '\\') continue;
 394                         i--;
 395                         p--;
 396                         if(++i<size) *p++ = ch;
 397                         else goto newone;
 398                 }
 399                 else if(GETC(ch)==quote)
 400                 {       if(++i<size) *p++ = ch;
 401                         else goto newone;
 402                 }
 403                 else
 404                 {       ungetc(ch,cf);
 405                         *p++ = 0;
 406                         return(0);
 407                 }
 408         }
 409 }
 410
 411 int
 412 s_rsle(cilist *a)
 413 {
 414         int n;
 415         if(!init) f_init();
 416         if((n=c_le(a,READ))) return(n);
 417         reading=1;
 418         external=1;
 419         formatted=1;
 420         l_first=1;
 421         lioproc = l_read;
 422         lcount = 0;
 423         if(curunit->uwrt)
 424                 return(nowreading(curunit));
 425         else    return(0);
 426 }
 427
 428 int
 429 t_sep()
 430 {
 431         int ch;
 432         for(GETC(ch);isblnk(ch);GETC(ch));
 433         if(ch == EOF) {
 434                 if(feof(cf)) return(EOF);
 435                 else return(errno);
 436         }
 437         if(ch=='/') {
 438                 lquit=1;
 439                 return(0);
 440         }
 441         if(ch==',') for(GETC(ch);isblnk(ch);GETC(ch));
 442         ungetc(ch,cf);
 443         return(0);
 444 }
 445
 446 int
 447 c_le(cilist *a, int flag)
 448 {
 449         fmtbuf="list io";
 450         if(a->ciunit>=MXUNIT || a->ciunit<0)
 451                 err(a->cierr,101,"stler");
 452         scale=recpos=0;
 453         elist=a;
 454         curunit = &units[a->ciunit];
 455         if(curunit->ufd==NULL && fk_open(flag,SEQ,FMT,a->ciunit))
 456                 err(a->cierr,102,"lio");
 457         cf=curunit->ufd;
 458         if(!curunit->ufmt) err(a->cierr,103,"lio")
 459         return(0);
 460 }
 461
 462 int
 463 do_lio(ftnint *type,ftnint *number,flex *ptr,ftnlen len)
 464 {
 465         return((*lioproc)(number,ptr,len,*type));
 466 }