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