home *** CD-ROM | disk | FTP | other *** search
/ minnie.tuhs.org / unixen.tar / unixen / PDP-11 / Trees / V7 / usr / src / libI77 / lread.c < prev    next >
Encoding:
C/C++ Source or Header  |  1979-05-03  |  6.9 KB  |  402 lines
  1. #include "fio.h"
  2. #include "fmt.h"
  3. #include "lio.h"
  4. #include "ctype.h"
  5. extern char *fmtbuf;
  6. int (*lioproc)();
  7.  
  8. #define isblnk(x) (ltab[x+1]&B)
  9. #define issep(x) (ltab[x+1]&SX)
  10. #define isapos(x) (ltab[x+1]&AX)
  11. #define isexp(x) (ltab[x+1]&EX)
  12. #define issign(x) (ltab[x+1]&SG)
  13. #define SX 1
  14. #define B 2
  15. #define AX 4
  16. #define EX 8
  17. #define SG 16
  18. char ltab[128+1]    /* offset one for EOF */
  19. {    0,
  20.     0,0,AX,0,0,0,0,0,0,0,B,0,0,0,0,0,
  21.     0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  22.     SX|B,0,AX,0,0,0,0,0,0,0,0,SG,SX,SG,0,SX,
  23.     0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  24.     0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
  25.     AX,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  26.     0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
  27.     0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
  28. };
  29.  
  30. int l_first;
  31. t_getc()
  32. {    int ch;
  33.     if(curunit->uend) return(EOF);
  34.     if((ch=getc(cf))!=EOF) return(ch);
  35.     if(feof(cf)) curunit->uend = 1;
  36.     return(EOF);
  37. }
  38. e_rsle()
  39. {
  40.     int ch;
  41.     if(curunit->uend) return(0);
  42.     while((ch=t_getc())!='\n' && ch!=EOF);
  43.     return(0);
  44. }
  45.  
  46. flag lquit;
  47. int lcount,ltype;
  48. char *lchar;
  49. double lx,ly;
  50. #define ERR(x) if(n=(x)) return(n)
  51. #define GETC(x) (x=t_getc())
  52.  
  53. l_read(number,ptr,len,type) ftnint *number,type; flex *ptr; ftnlen len;
  54. {    int i,n,ch;
  55.     double *yy;
  56.     float *xx;
  57.     for(i=0;i<*number;i++)
  58.     {
  59.         if(curunit->uend) err(elist->ciend, EOF, "list in")
  60.         if(l_first)
  61.         {    l_first=0;
  62.             for(GETC(ch);isblnk(ch);GETC(ch));
  63.             ungetc(ch,cf);
  64.         }
  65.         else if(lcount==0)
  66.         {    ERR(t_sep());
  67.             if(lquit) return(0);
  68.         }
  69.         switch((int)type)
  70.         {
  71.         case TYSHORT:
  72.         case TYLONG:
  73.         case TYREAL:
  74.         case TYDREAL:
  75.             ERR(l_R());
  76.             break;
  77.         case TYCOMPLEX:
  78.         case TYDCOMPLEX:
  79.             ERR(l_C());
  80.             break;
  81.         case TYLOGICAL:
  82.             ERR(l_L());
  83.             break;
  84.         case TYCHAR:
  85.             ERR(l_CHAR());
  86.             break;
  87.         }
  88.         if(lquit) return(0);
  89.         if(feof(cf)) err(elist->ciend,(EOF),"list in")
  90.         else if(ferror(cf))
  91.         {    clearerr(cf);
  92.             err(elist->cierr,errno,"list in")
  93.         }
  94.         if(ltype==NULL) goto bump;
  95.         switch((int)type)
  96.         {
  97.         case TYSHORT:
  98.             ptr->flshort=lx;
  99.             break;
  100.         case TYLOGICAL:
  101.         case TYLONG:
  102.             ptr->flint=lx;
  103.             break;
  104.         case TYREAL:
  105.             ptr->flreal=lx;
  106.             break;
  107.         case TYDREAL:
  108.             ptr->fldouble=lx;
  109.             break;
  110.         case TYCOMPLEX:
  111.             xx=(float *)ptr;
  112.             *xx++ = lx;
  113.             *xx = ly;
  114.             break;
  115.         case TYDCOMPLEX:
  116.             yy=(double *)ptr;
  117.             *yy++ = lx;
  118.             *yy = ly;
  119.             break;
  120.         case TYCHAR:
  121.             b_char(lchar,(char *)ptr,len);
  122.             break;
  123.         }
  124.     bump:
  125.         if(lcount>0) lcount--;
  126.         ptr = (char *)ptr + len;
  127.     }
  128.     return(0);
  129. }
  130. l_R()
  131. {    double a,b,c,d;
  132.     int i,ch,sign=0,da,db,dc;
  133.     a=b=c=d=0;
  134.     da=db=dc=0;
  135.     if(lcount>0) return(0);
  136.     ltype=NULL;
  137.     for(GETC(ch);isblnk(ch);GETC(ch));
  138.     if(ch==',')
  139.     {    lcount=1;
  140.         return(0);
  141.     }
  142.     if(ch=='/')
  143.     {    lquit=1;
  144.         return(0);
  145.     }
  146.     ungetc(ch,cf);
  147.     da=rd_int(&a);
  148.     if(da== -1) sign=da;
  149.     if(GETC(ch)!='*')
  150.     {    ungetc(ch,cf);
  151.         db=1;
  152.         b=a;
  153.         a=1;
  154.     }
  155.     else
  156.         db=rd_int(&b);
  157.     if(GETC(ch)!='.')
  158.     {    dc=c=0;
  159.         ungetc(ch,cf);
  160.     }
  161.     else    dc=rd_int(&c);
  162.     if(isexp(GETC(ch))) db=rd_int(&d);
  163.     else if(issign(ch))
  164.     {    ungetc(ch, cf);
  165.         db = rd_int(&d);
  166.     }
  167.     else
  168.     {    ungetc(ch,cf);
  169.         d=0;
  170.     }
  171.     lcount=a;
  172.     if(!db && !dc)
  173.         return(0);
  174.     if(db && b<0)
  175.     {    sign=1;
  176.         b = -b;
  177.     }
  178.     for(i=0;i<dc;i++) c/=10;
  179.     b=b+c;
  180.     for(i=0;i<d;i++) b *= 10;
  181.     for(i=0;i< -d;i++) b /= 10;
  182.     if(sign) b = -b;
  183.     ltype=TYLONG;
  184.     lx=b;
  185.     return(0);
  186. }
  187. rd_int(x) double *x;
  188. {    int ch,sign=0,i;
  189.     double y;
  190.     i=0;
  191.     y=0;
  192.     if(GETC(ch)=='-') sign = -1;
  193.     else if(ch=='+') sign=0;
  194.     else ungetc(ch,cf);
  195.     while(isdigit(GETC(ch)))
  196.     {    i++;
  197.         y=10*y+ch-'0';
  198.     }
  199.     ungetc(ch,cf);
  200.     if(sign) y = -y;
  201.     *x = y;
  202.     return(y!=0?i:sign);
  203. }
  204. l_C()
  205. {    int ch;
  206.     if(lcount>0) return(0);
  207.     ltype=NULL;
  208.     for(GETC(ch);isblnk(ch);GETC(ch));
  209.     if(ch==',')
  210.     {    lcount=1;
  211.         return(0);
  212.     }
  213.     if(ch=='/')
  214.     {    lquit=1;
  215.         return(0);
  216.     }
  217.     if(ch!='(')
  218.     {    if(fscanf(cf,"%d",&lcount)!=1)
  219.             if(!feof(cf)) err(elist->cierr,112,"no rep")
  220.             else err(elist->cierr,(EOF),"lread");
  221.         if(GETC(ch)!='*')
  222.         {    ungetc(ch,cf);
  223.             if(!feof(cf)) err(elist->cierr,112,"no star")
  224.             else err(elist->cierr,(EOF),"lread");
  225.         }
  226.         if(GETC(ch)!='(')
  227.         {    ungetc(ch,cf);
  228.             return(0);
  229.         }
  230.     }
  231.     lcount = 1;
  232.     ltype=TYLONG;
  233.     fscanf(cf,"%lf",&lx);
  234.     while(isblnk(GETC(ch)));
  235.     if(ch!=',')
  236.     {    ungetc(ch,cf);
  237.         err(elist->cierr,112,"no comma");
  238.     }
  239.     while(isblnk(GETC(ch)));
  240.     ungetc(ch,cf);
  241.     fscanf(cf,"%lf",&ly);
  242.     while(isblnk(GETC(ch)));
  243.     if(ch!=')') err(elist->cierr,112,"no )");
  244.     while(isblnk(GETC(ch)));
  245.     ungetc(ch,cf);
  246.     return(0);
  247. }
  248. l_L()
  249. {
  250.     int ch;
  251.     if(lcount>0) return(0);
  252.     ltype=NULL;
  253.     while(isblnk(GETC(ch)));
  254.     if(ch==',')
  255.     {    lcount=1;
  256.         return(0);
  257.     }
  258.     if(ch=='/')
  259.     {    lquit=1;
  260.         return(0);
  261.     }
  262.     if(isdigit(ch))
  263.     {    ungetc(ch,cf);
  264.         fscanf(cf,"%d",&lcount);
  265.         if(GETC(ch)!='*')
  266.             if(!feof(cf)) err(elist->cierr,112,"no star")
  267.             else err(elist->cierr,(EOF),"lread");
  268.     }
  269.     else    ungetc(ch,cf);
  270.     if(GETC(ch)=='.') GETC(ch);
  271.     switch(ch)
  272.     {
  273.     case 't':
  274.     case 'T':
  275.         lx=1;
  276.         break;
  277.     case 'f':
  278.     case 'F':
  279.         lx=0;
  280.         break;
  281.     default:
  282.         if(isblnk(ch) || issep(ch) || ch==EOF)
  283.         {    ungetc(ch,cf);
  284.             return(0);
  285.         }
  286.         else    err(elist->cierr,112,"logical");
  287.     }
  288.     ltype=TYLONG;
  289.     while(!issep(GETC(ch)) && ch!='\n' && ch!=EOF);
  290.     return(0);
  291. }
  292. #define BUFSIZE    128
  293. l_CHAR()
  294. {    int ch,size,i;
  295.     char quote,*p;
  296.     if(lcount>0) return(0);
  297.     ltype=NULL;
  298.  
  299.     while(isblnk(GETC(ch)));
  300.     if(ch==',')
  301.     {    lcount=1;
  302.         return(0);
  303.     }
  304.     if(ch=='/')
  305.     {    lquit=1;
  306.         return(0);
  307.     }
  308.     if(isdigit(ch))
  309.     {    ungetc(ch,cf);
  310.         fscanf(cf,"%d",&lcount);
  311.         if(GETC(ch)!='*') err(elist->cierr,112,"no star");
  312.     }
  313.     else    ungetc(ch,cf);
  314.     if(GETC(ch)=='\'' || ch=='"') quote=ch;
  315.     else if(isblnk(ch) || issep(ch) || ch==EOF)
  316.     {    ungetc(ch,cf);
  317.         return(0);
  318.     }
  319.     else err(elist->cierr,112,"no quote");
  320.     ltype=TYCHAR;
  321.     if(lchar!=NULL) free(lchar);
  322.     size=BUFSIZE;
  323.     p=lchar=(char *)malloc(size);
  324.     if(lchar==NULL) err(elist->cierr,113,"no space");
  325.     for(i=0;;)
  326.     {    while(GETC(ch)!=quote && ch!='\n'
  327.             && ch!=EOF && ++i<size) *p++ = ch;
  328.         if(i==size)
  329.         {
  330.         newone:
  331.             lchar=(char *)realloc(lchar, size += BUFSIZE);
  332.             p=lchar+i-1;
  333.             *p++ = ch;
  334.         }
  335.         else if(ch==EOF) return(EOF);
  336.         else if(ch=='\n')
  337.         {    if(*(p-1) != '\\') continue;
  338.             i--;
  339.             p--;
  340.             if(++i<size) *p++ = ch;
  341.             else goto newone;
  342.         }
  343.         else if(GETC(ch)==quote)
  344.         {    if(++i<size) *p++ = ch;
  345.             else goto newone;
  346.         }
  347.         else
  348.         {    ungetc(ch,cf);
  349.             *p++ = 0;
  350.             return(0);
  351.         }
  352.     }
  353. }
  354. s_rsle(a) cilist *a;
  355. {
  356.     int n;
  357.     if(!init) f_init();
  358.     if(n=c_le(a,READ)) return(n);
  359.     reading=1;
  360.     external=1;
  361.     formatted=1;
  362.     l_first=1;
  363.     lioproc = l_read;
  364.     lcount = 0;
  365.     if(curunit->uwrt)
  366.         return(nowreading(curunit));
  367.     else    return(0);
  368. }
  369. t_sep()
  370. {
  371.     int ch;
  372.     for(GETC(ch);isblnk(ch);GETC(ch));
  373.     if(ch == EOF)
  374.         if(feof(cf)) return(EOF);
  375.         else return(errno);
  376.     if(ch=='/')
  377.     {    lquit=1;
  378.         return(0);
  379.     }
  380.     if(ch==',') for(GETC(ch);isblnk(ch);GETC(ch));
  381.     ungetc(ch,cf);
  382.     return(0);
  383. }
  384. c_le(a,flag) cilist *a;
  385. {
  386.     fmtbuf="list io";
  387.     if(a->ciunit>=MXUNIT || a->ciunit<0)
  388.         err(a->cierr,101,"stler");
  389.     scale=recpos=0;
  390.     elist=a;
  391.     curunit = &units[a->ciunit];
  392.     if(curunit->ufd==NULL && fk_open(flag,SEQ,FMT,a->ciunit))
  393.         err(a->cierr,102,"lio");
  394.     cf=curunit->ufd;
  395.     if(!curunit->ufmt) err(a->cierr,103,"lio")
  396.     return(0);
  397. }
  398. do_lio(type,number,ptr,len) ftnint *number,*type; flex *ptr; ftnlen len;
  399. {
  400.     return((*lioproc)(number,ptr,len,*type));
  401. }
  402.