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