home *** CD-ROM | disk | FTP | other *** search
/ Amiga MA Magazine 1998 #6 / amigamamagazinepolishissue1998.iso / coders / f2c / i77lib / lread.c < prev    next >
C/C++ Source or Header  |  2000-06-22  |  11KB  |  595 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.         l_eof = f__curunit->uend = 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.             err(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.             err(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.                 err(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.                 err(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.                 err(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.         err(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.         err(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.         err(f__elist->cierr,112,"no imaginary part");
  276.     while(iswhit(GETC(ch)));
  277.     if(ch!=')') err(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.                 err(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    err(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=malloc((unsigned int)size);
  332.     if(f__lchar==NULL) err(f__elist->cierr,113,"no space");
  333.  
  334.     GETC(ch);
  335.     if(isdigit(ch)) {
  336.         /* allow Fortran 8x-style unquoted string...    */
  337.         /* either find a repetition count or the string    */
  338.         f__lcount = ch - '0';
  339.         *p++ = ch;
  340.         for(i = 1;;) {
  341.             switch(GETC(ch)) {
  342.                 case '*':
  343.                     if (f__lcount == 0) {
  344.                         f__lcount = 1;
  345.                         goto noquote;
  346.                         }
  347.                     p = f__lchar;
  348.                     goto have_lcount;
  349.                 case ',':
  350.                 case ' ':
  351.                 case '\t':
  352.                 case '\n':
  353.                 case '/':
  354.                     Ungetc(ch,f__cf);
  355.                     /* no break */
  356.                 case EOF:
  357.                     f__lcount = 1;
  358.                     f__ltype = TYCHAR;
  359.                     return *p = 0;
  360.                 }
  361.             if (!isdigit(ch)) {
  362.                 f__lcount = 1;
  363.                 goto noquote;
  364.                 }
  365.             *p++ = ch;
  366.             f__lcount = 10*f__lcount + ch - '0';
  367.             if (++i == size) {
  368.                 f__lchar = realloc(f__lchar,
  369.                     (unsigned int)(size += BUFSIZE));
  370.                 p = f__lchar + i;
  371.                 }
  372.             }
  373.         }
  374.     else    (void) Ungetc(ch,f__cf);
  375.  have_lcount:
  376.     if(GETC(ch)=='\'' || ch=='"') quote=ch;
  377.     else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF)
  378.     {    (void) Ungetc(ch,f__cf);
  379.         return(0);
  380.     }
  381.     else {
  382.         /* Fortran 8x-style unquoted string */
  383.         *p++ = ch;
  384.         for(i = 1;;) {
  385.             switch(GETC(ch)) {
  386.                 case ',':
  387.                 case ' ':
  388.                 case '\t':
  389.                 case '\n':
  390.                 case '/':
  391.                     Ungetc(ch,f__cf);
  392.                     /* no break */
  393.                 case EOF:
  394.                     f__ltype = TYCHAR;
  395.                     return *p = 0;
  396.                 }
  397.  noquote:
  398.             *p++ = ch;
  399.             if (++i == size) {
  400.                 f__lchar = realloc(f__lchar,
  401.                     (unsigned int)(size += BUFSIZE));
  402.                 p = f__lchar + i;
  403.                 }
  404.             }
  405.         }
  406.     f__ltype=TYCHAR;
  407.     for(i=0;;)
  408.     {    while(GETC(ch)!=quote && ch!='\n'
  409.             && ch!=EOF && ++i<size) *p++ = ch;
  410.         if(i==size)
  411.         {
  412.         newone:
  413.             f__lchar= realloc(f__lchar, (unsigned int)(size += BUFSIZE));
  414.             p=f__lchar+i-1;
  415.             *p++ = ch;
  416.         }
  417.         else if(ch==EOF) return(EOF);
  418.         else if(ch=='\n')
  419.         {    if(*(p-1) != '\\') continue;
  420.             i--;
  421.             p--;
  422.             if(++i<size) *p++ = ch;
  423.             else goto newone;
  424.         }
  425.         else if(GETC(ch)==quote)
  426.         {    if(++i<size) *p++ = ch;
  427.             else goto newone;
  428.         }
  429.         else
  430.         {    (void) Ungetc(ch,f__cf);
  431.             *p = 0;
  432.             return(0);
  433.         }
  434.     }
  435. }
  436. #ifdef KR_headers
  437. c_le(a) cilist *a;
  438. #else
  439. c_le(cilist *a)
  440. #endif
  441. {
  442.     f__fmtbuf="list io";
  443.     if(a->ciunit>=MXUNIT || a->ciunit<0)
  444.         err(a->cierr,101,"stler");
  445.     f__scale=f__recpos=0;
  446.     f__elist=a;
  447.     f__curunit = &f__units[a->ciunit];
  448.     if(f__curunit->ufd==NULL && fk_open(SEQ,FMT,a->ciunit))
  449.         err(a->cierr,102,"lio");
  450.     f__cf=f__curunit->ufd;
  451.     if(!f__curunit->ufmt) err(a->cierr,103,"lio")
  452.     return(0);
  453. }
  454. #ifdef KR_headers
  455. l_read(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
  456. #else
  457. l_read(ftnint *number, char *ptr, ftnlen len, ftnint type)
  458. #endif
  459. {
  460. #define Ptr ((flex *)ptr)
  461.     int i,n,ch;
  462.     doublereal *yy;
  463.     real *xx;
  464.     for(i=0;i<*number;i++)
  465.     {
  466.         if(f__lquit) return(0);
  467.         if(l_eof)
  468.             err(f__elist->ciend, EOF, "list in")
  469.         if(f__lcount == 0) {
  470.             f__ltype = 0;
  471.             for(;;)  {
  472.                 GETC(ch);
  473.                 switch(ch) {
  474.                 case EOF:
  475.                     goto loopend;
  476.                 case ' ':
  477.                 case '\t':
  478.                 case '\n':
  479.                     continue;
  480.                 case '/':
  481.                     f__lquit = 1;
  482.                     goto loopend;
  483.                 case ',':
  484.                     f__lcount = 1;
  485.                     goto loopend;
  486.                 default:
  487.                     (void) Ungetc(ch, f__cf);
  488.                     goto rddata;
  489.                 }
  490.             }
  491.         }
  492.     rddata:
  493.         switch((int)type)
  494.         {
  495.         case TYINT1:
  496.         case TYSHORT:
  497.         case TYLONG:
  498.         case TYREAL:
  499.         case TYDREAL:
  500.             ERR(l_R(0));
  501.             break;
  502.         case TYCOMPLEX:
  503.         case TYDCOMPLEX:
  504.             ERR(l_C());
  505.             break;
  506.         case TYLOGICAL1:
  507.         case TYLOGICAL2:
  508.         case TYLOGICAL:
  509.             ERR(l_L());
  510.             break;
  511.         case TYCHAR:
  512.             ERR(l_CHAR());
  513.             break;
  514.         }
  515.     while (GETC(ch) == ' ' || ch == '\t');
  516.     if (ch != ',' || f__lcount > 1)
  517.         Ungetc(ch,f__cf);
  518.     loopend:
  519.         if(f__lquit) return(0);
  520.         if(f__cf) {
  521.             if (feof(f__cf))
  522.                 err(f__elist->ciend,(EOF),"list in")
  523.             else if(ferror(f__cf)) {
  524.                 clearerr(f__cf);
  525.                 err(f__elist->cierr,errno,"list in")
  526.                 }
  527.             }
  528.         if(f__ltype==0) goto bump;
  529.         switch((int)type)
  530.         {
  531.         case TYINT1:
  532.         case TYLOGICAL1:
  533.             Ptr->flchar = f__lx;
  534.             break;
  535.         case TYLOGICAL2:
  536.         case TYSHORT:
  537.             Ptr->flshort=f__lx;
  538.             break;
  539.         case TYLOGICAL:
  540.         case TYLONG:
  541.             Ptr->flint=f__lx;
  542.             break;
  543.         case TYREAL:
  544.             Ptr->flreal=f__lx;
  545.             break;
  546.         case TYDREAL:
  547.             Ptr->fldouble=f__lx;
  548.             break;
  549.         case TYCOMPLEX:
  550.             xx=(real *)ptr;
  551.             *xx++ = f__lx;
  552.             *xx = f__ly;
  553.             break;
  554.         case TYDCOMPLEX:
  555.             yy=(doublereal *)ptr;
  556.             *yy++ = f__lx;
  557.             *yy = f__ly;
  558.             break;
  559.         case TYCHAR:
  560.             b_char(f__lchar,ptr,len);
  561.             break;
  562.         }
  563.     bump:
  564.         if(f__lcount>0) f__lcount--;
  565.         ptr += len;
  566.         if (nml_read)
  567.             nml_read++;
  568.     }
  569.     return(0);
  570. #undef Ptr
  571. }
  572. #ifdef KR_headers
  573. integer s_rsle(a) cilist *a;
  574. #else
  575. integer s_rsle(cilist *a)
  576. #endif
  577. {
  578.     int n;
  579.  
  580.     if(!f__init) f_init();
  581.     if(n=c_le(a)) return(n);
  582.     f__reading=1;
  583.     f__external=1;
  584.     f__formatted=1;
  585.     f__lioproc = l_read;
  586.     f__lquit = 0;
  587.     f__lcount = 0;
  588.     l_eof = 0;
  589.     if(f__curunit->uwrt && f__nowreading(f__curunit))
  590.         err(a->cierr,errno,"read start");
  591.     l_getc = t_getc;
  592.     l_ungetc = un_getc;
  593.     return(0);
  594. }
  595.