home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / libf2c-0.000 / libf2c-0 / libf2c / libI77 / lread.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-01-14  |  11.1 KB  |  621 lines
  1. #include "f2c.h"
  2. #include "fio.h"
  3. #include "fmt.h"
  4. #include "lio.h"
  5. #include "ctype.h"
  6. #include "fp.h"
  7.  
  8. extern char *f__fmtbuf;
  9. #ifdef KR_headers
  10. extern double atof();
  11. extern char *malloc(), *realloc();
  12. int (*f__lioproc)(), (*l_getc)(), (*l_ungetc)();
  13. #else
  14. #undef abs
  15. #undef min
  16. #undef max
  17. #include "stdlib.h"
  18. int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint), (*l_getc)(void),
  19.     (*l_ungetc)(int,FILE*);
  20. #endif
  21. int l_eof;
  22.  
  23. #define isblnk(x) (f__ltab[x+1]&B)
  24. #define issep(x) (f__ltab[x+1]&SX)
  25. #define isapos(x) (f__ltab[x+1]&AX)
  26. #define isexp(x) (f__ltab[x+1]&EX)
  27. #define issign(x) (f__ltab[x+1]&SG)
  28. #define iswhit(x) (f__ltab[x+1]&WH)
  29. #define SX 1
  30. #define B 2
  31. #define AX 4
  32. #define EX 8
  33. #define SG 16
  34. #define WH 32
  35. char f__ltab[128+1] = {    /* offset one for EOF */
  36.     0,
  37.     0,0,AX,0,0,0,0,0,0,WH|B,SX|WH,0,0,0,0,0,
  38.     0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  39.     SX|B|WH,0,AX,0,0,0,0,AX,0,0,0,SG,SX,SG,0,SX,
  40.     0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  41.     0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
  42.     0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
  43.     AX,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
  44.     0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
  45. };
  46.  
  47. #ifdef ungetc
  48.  static int
  49. #ifdef KR_headers
  50. un_getc(x,f__cf) int x; FILE *f__cf;
  51. #else
  52. un_getc(int x, FILE *f__cf)
  53. #endif
  54. { return ungetc(x,f__cf); }
  55. #else
  56. #define un_getc ungetc
  57. #ifdef KR_headers
  58.  extern int ungetc();
  59. #else
  60. extern int ungetc(int, FILE*);    /* for systems with a buggy stdio.h */
  61. #endif
  62. #endif
  63.  
  64. t_getc(Void)
  65. {    int ch;
  66.     if(f__curunit->uend) return(EOF);
  67.     if((ch=getc(f__cf))!=EOF) return(ch);
  68.     if(feof(f__cf))
  69.         f__curunit->uend = l_eof = 1;
  70.     return(EOF);
  71. }
  72. integer e_rsle(Void)
  73. {
  74.     int ch;
  75.     if(f__curunit->uend) return(0);
  76.     while((ch=t_getc())!='\n' && ch!=EOF);
  77.     return(0);
  78. }
  79.  
  80. flag f__lquit;
  81. int f__lcount,f__ltype,nml_read;
  82. char *f__lchar;
  83. double f__lx,f__ly;
  84. #define ERR(x) if(n=(x)) return(n)
  85. #define GETC(x) (x=(*l_getc)())
  86. #define Ungetc(x,y) (*l_ungetc)(x,y)
  87.  
  88. #ifdef KR_headers
  89. l_R(poststar) int poststar;
  90. #else
  91. l_R(int poststar)
  92. #endif
  93. {
  94.     char s[FMAX+EXPMAXDIGS+4];
  95.     register int ch;
  96.     register char *sp, *spe, *sp1;
  97.     long e, exp;
  98.     int havenum, havestar, se;
  99.  
  100.     if (!poststar) {
  101.         if (f__lcount > 0)
  102.             return(0);
  103.         f__lcount = 1;
  104.         }
  105.     f__ltype = 0;
  106.     exp = 0;
  107.     havestar = 0;
  108. retry:
  109.     sp1 = sp = s;
  110.     spe = sp + FMAX;
  111.     havenum = 0;
  112.  
  113.     switch(GETC(ch)) {
  114.         case '-': *sp++ = ch; sp1++; spe++;
  115.         case '+':
  116.             GETC(ch);
  117.         }
  118.     while(ch == '0') {
  119.         ++havenum;
  120.         GETC(ch);
  121.         }
  122.     while(isdigit(ch)) {
  123.         if (sp < spe) *sp++ = ch;
  124.         else ++exp;
  125.         GETC(ch);
  126.         }
  127.     if (ch == '*' && !poststar) {
  128.         if (sp == sp1 || exp || *s == '-') {
  129.             errfl(f__elist->cierr,112,"bad repetition count");
  130.             }
  131.         poststar = havestar = 1;
  132.         *sp = 0;
  133.         f__lcount = atoi(s);
  134.         goto retry;
  135.         }
  136.     if (ch == '.') {
  137.         GETC(ch);
  138.         if (sp == sp1)
  139.             while(ch == '0') {
  140.                 ++havenum;
  141.                 --exp;
  142.                 GETC(ch);
  143.                 }
  144.         while(isdigit(ch)) {
  145.             if (sp < spe)
  146.                 { *sp++ = ch; --exp; }
  147.             GETC(ch);
  148.             }
  149.         }
  150.     havenum += sp - sp1;
  151.     se = 0;
  152.     if (issign(ch))
  153.         goto signonly;
  154.     if (havenum && isexp(ch)) {
  155.         GETC(ch);
  156.         if (issign(ch)) {
  157. signonly:
  158.             if (ch == '-') se = 1;
  159.             GETC(ch);
  160.             }
  161.         if (!isdigit(ch)) {
  162. bad:
  163.             errfl(f__elist->cierr,112,"exponent field");
  164.             }
  165.  
  166.         e = ch - '0';
  167.         while(isdigit(GETC(ch))) {
  168.             e = 10*e + ch - '0';
  169.             if (e > EXPMAX)
  170.                 goto bad;
  171.             }
  172.         if (se)
  173.             exp -= e;
  174.         else
  175.             exp += e;
  176.         }
  177.     (void) Ungetc(ch, f__cf);
  178.     if (sp > sp1) {
  179.         ++havenum;
  180.         while(*--sp == '0')
  181.             ++exp;
  182.         if (exp)
  183.             sprintf(sp+1, "e%ld", exp);
  184.         else
  185.             sp[1] = 0;
  186.         f__lx = atof(s);
  187.         }
  188.     else
  189.         f__lx = 0.;
  190.     if (havenum)
  191.         f__ltype = TYLONG;
  192.     else
  193.         switch(ch) {
  194.             case ',':
  195.             case '/':
  196.                 break;
  197.             default:
  198.                 if (havestar && ( ch == ' '
  199.                         ||ch == '\t'
  200.                         ||ch == '\n'))
  201.                     break;
  202.                 if (nml_read > 1) {
  203.                     f__lquit = 2;
  204.                     return 0;
  205.                     }
  206.                 errfl(f__elist->cierr,112,"invalid number");
  207.             }
  208.     return 0;
  209.     }
  210.  
  211.  static int
  212. #ifdef KR_headers
  213. rd_count(ch) register int ch;
  214. #else
  215. rd_count(register int ch)
  216. #endif
  217. {
  218.     if (ch < '0' || ch > '9')
  219.         return 1;
  220.     f__lcount = ch - '0';
  221.     while(GETC(ch) >= '0' && ch <= '9')
  222.         f__lcount = 10*f__lcount + ch - '0';
  223.     Ungetc(ch,f__cf);
  224.     return f__lcount <= 0;
  225.     }
  226.  
  227. l_C(Void)
  228. {    int ch, nml_save;
  229.     double lz;
  230.     if(f__lcount>0) return(0);
  231.     f__ltype=0;
  232.     GETC(ch);
  233.     if(ch!='(')
  234.     {
  235.         if (nml_read > 1 && (ch < '0' || ch > '9')) {
  236.             Ungetc(ch,f__cf);
  237.             f__lquit = 2;
  238.             return 0;
  239.             }
  240.         if (rd_count(ch))
  241.             if(!f__cf || !feof(f__cf))
  242.                 errfl(f__elist->cierr,112,"complex format");
  243.             else
  244.                 err(f__elist->cierr,(EOF),"lread");
  245.         if(GETC(ch)!='*')
  246.         {
  247.             if(!f__cf || !feof(f__cf))
  248.                 errfl(f__elist->cierr,112,"no star");
  249.             else
  250.                 err(f__elist->cierr,(EOF),"lread");
  251.         }
  252.         if(GETC(ch)!='(')
  253.         {    Ungetc(ch,f__cf);
  254.             return(0);
  255.         }
  256.     }
  257.     else
  258.         f__lcount = 1;
  259.     while(iswhit(GETC(ch)));
  260.     Ungetc(ch,f__cf);
  261.     nml_save = nml_read;
  262.     nml_read = 0;
  263.     if (ch = l_R(1))
  264.         return ch;
  265.     if (!f__ltype)
  266.         errfl(f__elist->cierr,112,"no real part");
  267.     lz = f__lx;
  268.     while(iswhit(GETC(ch)));
  269.     if(ch!=',')
  270.     {    (void) Ungetc(ch,f__cf);
  271.         errfl(f__elist->cierr,112,"no comma");
  272.     }
  273.     while(iswhit(GETC(ch)));
  274.     (void) Ungetc(ch,f__cf);
  275.     if (ch = l_R(1))
  276.         return ch;
  277.     if (!f__ltype)
  278.         errfl(f__elist->cierr,112,"no imaginary part");
  279.     while(iswhit(GETC(ch)));
  280.     if(ch!=')') errfl(f__elist->cierr,112,"no )");
  281.     f__ly = f__lx;
  282.     f__lx = lz;
  283.     nml_read = nml_save;
  284.     return(0);
  285. }
  286. l_L(Void)
  287. {
  288.     int ch;
  289.     if(f__lcount>0) return(0);
  290.     f__lcount = 1;
  291.     f__ltype=0;
  292.     GETC(ch);
  293.     if(isdigit(ch))
  294.     {
  295.         rd_count(ch);
  296.         if(GETC(ch)!='*')
  297.             if(!f__cf || !feof(f__cf))
  298.                 errfl(f__elist->cierr,112,"no star");
  299.             else
  300.                 err(f__elist->cierr,(EOF),"lread");
  301.         GETC(ch);
  302.     }
  303.     if(ch == '.') GETC(ch);
  304.     switch(ch)
  305.     {
  306.     case 't':
  307.     case 'T':
  308.         f__lx=1;
  309.         break;
  310.     case 'f':
  311.     case 'F':
  312.         f__lx=0;
  313.         break;
  314.     default:
  315.         if(isblnk(ch) || issep(ch) || ch==EOF)
  316.         {    (void) Ungetc(ch,f__cf);
  317.             return(0);
  318.         }
  319.         if (nml_read > 1) {
  320.             Ungetc(ch,f__cf);
  321.             f__lquit = 2;
  322.             return 0;
  323.             }
  324.         errfl(f__elist->cierr,112,"logical");
  325.     }
  326.     f__ltype=TYLONG;
  327.     while(!issep(GETC(ch)) && ch!=EOF);
  328.     (void) Ungetc(ch, f__cf);
  329.     return(0);
  330. }
  331. #define BUFSIZE    128
  332. l_CHAR(Void)
  333. {    int ch,size,i;
  334.     static char rafail[] = "realloc failure";
  335.     char quote,*p;
  336.     if(f__lcount>0) return(0);
  337.     f__ltype=0;
  338.     if(f__lchar!=NULL) free(f__lchar);
  339.     size=BUFSIZE;
  340.     p=f__lchar = (char *)malloc((unsigned int)size);
  341.     if(f__lchar == NULL)
  342.         errfl(f__elist->cierr,113,"no space");
  343.  
  344.     GETC(ch);
  345.     if(isdigit(ch)) {
  346.         /* allow Fortran 8x-style unquoted string...    */
  347.         /* either find a repetition count or the string    */
  348.         f__lcount = ch - '0';
  349.         *p++ = ch;
  350.         for(i = 1;;) {
  351.             switch(GETC(ch)) {
  352.                 case '*':
  353.                     if (f__lcount == 0) {
  354.                         f__lcount = 1;
  355.                         goto noquote;
  356.                         }
  357.                     p = f__lchar;
  358.                     goto have_lcount;
  359.                 case ',':
  360.                 case ' ':
  361.                 case '\t':
  362.                 case '\n':
  363.                 case '/':
  364.                     Ungetc(ch,f__cf);
  365.                     /* no break */
  366.                 case EOF:
  367.                     f__lcount = 1;
  368.                     f__ltype = TYCHAR;
  369.                     return *p = 0;
  370.                 }
  371.             if (!isdigit(ch)) {
  372.                 f__lcount = 1;
  373.                 goto noquote;
  374.                 }
  375.             *p++ = ch;
  376.             f__lcount = 10*f__lcount + ch - '0';
  377.             if (++i == size) {
  378.                 f__lchar = (char *)realloc(f__lchar,
  379.                     (unsigned int)(size += BUFSIZE));
  380.                 if(f__lchar == NULL)
  381.                     errfl(f__elist->cierr,113,rafail);
  382.                 p = f__lchar + i;
  383.                 }
  384.             }
  385.         }
  386.     else    (void) Ungetc(ch,f__cf);
  387.  have_lcount:
  388.     if(GETC(ch)=='\'' || ch=='"') quote=ch;
  389.     else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF)
  390.     {    (void) Ungetc(ch,f__cf);
  391.         return(0);
  392.     }
  393.     else {
  394.         /* Fortran 8x-style unquoted string */
  395.         *p++ = ch;
  396.         for(i = 1;;) {
  397.             switch(GETC(ch)) {
  398.                 case ',':
  399.                 case ' ':
  400.                 case '\t':
  401.                 case '\n':
  402.                 case '/':
  403.                     Ungetc(ch,f__cf);
  404.                     /* no break */
  405.                 case EOF:
  406.                     f__ltype = TYCHAR;
  407.                     return *p = 0;
  408.                 }
  409.  noquote:
  410.             *p++ = ch;
  411.             if (++i == size) {
  412.                 f__lchar = (char *)realloc(f__lchar,
  413.                     (unsigned int)(size += BUFSIZE));
  414.                 if(f__lchar == NULL)
  415.                     errfl(f__elist->cierr,113,rafail);
  416.                 p = f__lchar + i;
  417.                 }
  418.             }
  419.         }
  420.     f__ltype=TYCHAR;
  421.     for(i=0;;)
  422.     {    while(GETC(ch)!=quote && ch!='\n'
  423.             && ch!=EOF && ++i<size) *p++ = ch;
  424.         if(i==size)
  425.         {
  426.         newone:
  427.             f__lchar= (char *)realloc(f__lchar,
  428.                     (unsigned int)(size += BUFSIZE));
  429.             if(f__lchar == NULL)
  430.                 errfl(f__elist->cierr,113,rafail);
  431.             p=f__lchar+i-1;
  432.             *p++ = ch;
  433.         }
  434.         else if(ch==EOF) return(EOF);
  435.         else if(ch=='\n')
  436.         {    if(*(p-1) != '\\') continue;
  437.             i--;
  438.             p--;
  439.             if(++i<size) *p++ = ch;
  440.             else goto newone;
  441.         }
  442.         else if(GETC(ch)==quote)
  443.         {    if(++i<size) *p++ = ch;
  444.             else goto newone;
  445.         }
  446.         else
  447.         {    (void) Ungetc(ch,f__cf);
  448.             *p = 0;
  449.             return(0);
  450.         }
  451.     }
  452. }
  453. #ifdef KR_headers
  454. c_le(a) cilist *a;
  455. #else
  456. c_le(cilist *a)
  457. #endif
  458. {
  459.     f__fmtbuf="list io";
  460.     if(a->ciunit>=MXUNIT || a->ciunit<0)
  461.         err(a->cierr,101,"stler");
  462.     f__scale=f__recpos=0;
  463.     f__elist=a;
  464.     f__curunit = &f__units[a->ciunit];
  465.     if(f__curunit->ufd==NULL && fk_open(SEQ,FMT,a->ciunit))
  466.         err(a->cierr,102,"lio");
  467.     f__cf=f__curunit->ufd;
  468.     if(!f__curunit->ufmt) err(a->cierr,103,"lio")
  469.     return(0);
  470. }
  471. #ifdef KR_headers
  472. l_read(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
  473. #else
  474. l_read(ftnint *number, char *ptr, ftnlen len, ftnint type)
  475. #endif
  476. {
  477. #define Ptr ((flex *)ptr)
  478.     int i,n,ch;
  479.     doublereal *yy;
  480.     real *xx;
  481.     for(i=0;i<*number;i++)
  482.     {
  483.         if(f__lquit) return(0);
  484.         if(l_eof)
  485.             err(f__elist->ciend, EOF, "list in")
  486.         if(f__lcount == 0) {
  487.             f__ltype = 0;
  488.             for(;;)  {
  489.                 GETC(ch);
  490.                 switch(ch) {
  491.                 case EOF:
  492.                     goto loopend;
  493.                 case ' ':
  494.                 case '\t':
  495.                 case '\n':
  496.                     continue;
  497.                 case '/':
  498.                     f__lquit = 1;
  499.                     goto loopend;
  500.                 case ',':
  501.                     f__lcount = 1;
  502.                     goto loopend;
  503.                 default:
  504.                     (void) Ungetc(ch, f__cf);
  505.                     goto rddata;
  506.                 }
  507.             }
  508.         }
  509.     rddata:
  510.         switch((int)type)
  511.         {
  512.         case TYINT1:
  513.         case TYSHORT:
  514.         case TYLONG:
  515. #ifdef TYQUAD
  516.         case TYQUAD:
  517. #endif
  518.         case TYREAL:
  519.         case TYDREAL:
  520.             ERR(l_R(0));
  521.             break;
  522.         case TYCOMPLEX:
  523.         case TYDCOMPLEX:
  524.             ERR(l_C());
  525.             break;
  526.         case TYLOGICAL1:
  527.         case TYLOGICAL2:
  528.         case TYLOGICAL:
  529.             ERR(l_L());
  530.             break;
  531.         case TYCHAR:
  532.             ERR(l_CHAR());
  533.             break;
  534.         }
  535.     while (GETC(ch) == ' ' || ch == '\t');
  536.     if (ch != ',' || f__lcount > 1)
  537.         Ungetc(ch,f__cf);
  538.     loopend:
  539.         if(f__lquit) return(0);
  540.         if(f__cf) {
  541.             if (feof(f__cf))
  542.                 err(f__elist->ciend,(EOF),"list in")
  543.             else if(ferror(f__cf)) {
  544.                 clearerr(f__cf);
  545.                 errfl(f__elist->cierr,errno,"list in");
  546.                 }
  547.             }
  548.         if(f__ltype==0) goto bump;
  549.         switch((int)type)
  550.         {
  551.         case TYINT1:
  552.         case TYLOGICAL1:
  553.             Ptr->flchar = (char)f__lx;
  554.             break;
  555.         case TYLOGICAL2:
  556.         case TYSHORT:
  557.             Ptr->flshort = (short)f__lx;
  558.             break;
  559.         case TYLOGICAL:
  560.         case TYLONG:
  561.             Ptr->flint=f__lx;
  562.             break;
  563. #ifdef TYQUAD
  564.         case TYQUAD:
  565.             Ptr->fllongint = f__lx;
  566.             break;
  567. #endif
  568.         case TYREAL:
  569.             Ptr->flreal=f__lx;
  570.             break;
  571.         case TYDREAL:
  572.             Ptr->fldouble=f__lx;
  573.             break;
  574.         case TYCOMPLEX:
  575.             xx=(real *)ptr;
  576.             *xx++ = f__lx;
  577.             *xx = f__ly;
  578.             break;
  579.         case TYDCOMPLEX:
  580.             yy=(doublereal *)ptr;
  581.             *yy++ = f__lx;
  582.             *yy = f__ly;
  583.             break;
  584.         case TYCHAR:
  585.             b_char(f__lchar,ptr,len);
  586.             break;
  587.         }
  588.     bump:
  589.         if(f__lcount>0) f__lcount--;
  590.         ptr += len;
  591.         if (nml_read)
  592.             nml_read++;
  593.     }
  594.     return(0);
  595. #undef Ptr
  596. }
  597. #ifdef KR_headers
  598. integer s_rsle(a) cilist *a;
  599. #else
  600. integer s_rsle(cilist *a)
  601. #endif
  602. {
  603.     int n;
  604.  
  605.     if(!f__init) f_init();
  606.     if(n=c_le(a)) return(n);
  607.     f__reading=1;
  608.     f__external=1;
  609.     f__formatted=1;
  610.     f__lioproc = l_read;
  611.     f__lquit = 0;
  612.     f__lcount = 0;
  613.     l_eof = 0;
  614.     if(f__curunit->uwrt && f__nowreading(f__curunit))
  615.         err(a->cierr,errno,"read start");
  616.     l_getc = t_getc;
  617.     l_ungetc = un_getc;
  618.     f__doend = xrd_SL;
  619.     return(0);
  620. }
  621.