home *** CD-ROM | disk | FTP | other *** search
/ Turbo Toolbox / Turbo_Toolbox.iso / sharew / f_2_c / libi77 / rsne.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-06-11  |  8.7 KB  |  449 lines
  1. #include "f2c.h"
  2. #include "fio.h"
  3. #include "lio.h"
  4.  
  5. #define MAX_NL_CACHE 3    /* maximum number of namelist hash tables to cache */
  6. #define MAXDIM 20    /* maximum number of subscripts */
  7.  
  8. #ifdef MSDOS
  9. extern char *malloc();
  10. #else
  11. extern char *malloc(), *memset();
  12. #endif
  13.  
  14.  struct dimen {
  15.     ftnlen extent;
  16.     ftnlen curval;
  17.     ftnlen delta;
  18.     ftnlen stride;
  19.     };
  20.  typedef struct dimen dimen;
  21.  
  22.  struct hashentry {
  23.     struct hashentry *next;
  24.     char *name;
  25.     Vardesc *vd;
  26.     };
  27.  typedef struct hashentry hashentry;
  28.  
  29.  struct hashtab {
  30.     struct hashtab *next;
  31.     Namelist *nl;
  32.     int htsize;
  33.     hashentry *tab[1];
  34.     };
  35.  typedef struct hashtab hashtab;
  36.  
  37.  static hashtab *nl_cache;
  38.  static n_nlcache;
  39.  static hashentry **zot;
  40.  extern ftnlen typesize[];
  41.  
  42.  extern flag lquit;
  43.  extern int lcount;
  44.  extern int (*l_getc)(), (*l_ungetc)(), t_getc(), ungetc();
  45.  
  46.  static Vardesc *
  47. hash(ht, s)
  48.  hashtab *ht;
  49.  register char *s;
  50. {
  51.     register int c, x;
  52.     register hashentry *h;
  53.     char *s0 = s;
  54.  
  55.     for(x = 0; c = *s++; x = x & 0x4000 ? ((x << 1) & 0x7fff) + 1 : x << 1)
  56.         x += c;
  57.     for(h = *(zot = ht->tab + x % ht->htsize); h; h = h->next)
  58.         if (!strcmp(s0, h->name))
  59.             return h->vd;
  60.     return 0;
  61.     }
  62.  
  63.  hashtab *
  64. mk_hashtab(nl)
  65.  Namelist *nl;
  66. {
  67.     int nht, nv;
  68.     hashtab *ht;
  69.     Vardesc *v, **vd, **vde;
  70.     hashentry *he;
  71.  
  72.     hashtab **x, **x0, *y;
  73.     for(x = &nl_cache; y = *x; x0 = x, x = &y->next)
  74.         if (nl == y->nl)
  75.             return y;
  76.     if (n_nlcache >= MAX_NL_CACHE) {
  77.         /* discard least recently used namelist hash table */
  78.         y = *x0;
  79.         free((char *)y->next);
  80.         y->next = 0;
  81.         }
  82.     else
  83.         n_nlcache++;
  84.     nv = nl->nvars;
  85.     if (nv >= 0x4000)
  86.         nht = 0x7fff;
  87.     else {
  88.         for(nht = 1; nht < nv; nht <<= 1);
  89.         nht += nht - 1;
  90.         }
  91.     ht = (hashtab *)malloc(sizeof(hashtab) + (nht-1)*sizeof(hashentry *)
  92.                 + nv*sizeof(hashentry));
  93.     if (!ht)
  94.         return 0;
  95.     he = (hashentry *)&ht->tab[nht];
  96.     ht->nl = nl;
  97.     ht->htsize = nht;
  98.     ht->next = nl_cache;
  99.     nl_cache = ht;
  100.     memset((char *)ht->tab, 0, nht*sizeof(hashentry *));
  101.     vd = nl->vars;
  102.     vde = vd + nv;
  103.     while(vd < vde) {
  104.         v = *vd++;
  105.         if (!hash(ht, v->name)) {
  106.             he->next = *zot;
  107.             *zot = he;
  108.             he->name = v->name;
  109.             he->vd = v;
  110.             he++;
  111.             }
  112.         }
  113.     return ht;
  114.     }
  115.  
  116. static char Alpha[256], Alphanum[256];
  117.  
  118.  static void
  119. nl_init() {
  120.     register char *s;
  121.     register int c;
  122.  
  123.     if(!init)
  124.         f_init();
  125.     for(s = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; c = *s++; )
  126.         Alpha[c]
  127.         = Alphanum[c]
  128.         = Alpha[c + 'a' - 'A']
  129.         = Alphanum[c + 'a' - 'A']
  130.         = c;
  131.     for(s = "0123456789_"; c = *s++; )
  132.         Alphanum[c] = c;
  133.     }
  134.  
  135. #define GETC(x) (x=(*l_getc)())
  136. #define Ungetc(x,y) (*l_ungetc)(x,y)
  137.  
  138.  static int
  139. getname(s, slen)
  140.  register char *s;
  141.  int slen;
  142. {
  143.     register char *se = s + slen - 1;
  144.     register int ch;
  145.  
  146.     GETC(ch);
  147.     if (!(*s++ = Alpha[ch & 0xff])) {
  148.         if (ch != EOF)
  149.             ch = 115;
  150.         err(elist->cierr, ch, "namelist read");
  151.         }
  152.     while(*s = Alphanum[GETC(ch) & 0xff])
  153.         if (s < se)
  154.             s++;
  155.     if (ch == EOF)
  156.         err(elist->cierr, ch == EOF ? -1 : 115, "namelist read");
  157.     if (ch > ' ')
  158.         Ungetc(ch,cf);
  159.     return *s = 0;
  160.     }
  161.  
  162.  static int
  163. getnum(chp, val)
  164.  int *chp;
  165.  ftnlen *val;
  166. {
  167.     register int ch, sign;
  168.     register ftnlen x;
  169.  
  170.     while(GETC(ch) <= ' ' && ch >= 0);
  171.     if (ch == '-') {
  172.         sign = 1;
  173.         GETC(ch);
  174.         }
  175.     else {
  176.         sign = 0;
  177.         if (ch == '+')
  178.             GETC(ch);
  179.         }
  180.     x = ch - '0';
  181.     if (x < 0 || x > 9)
  182.         return 115;
  183.     while(GETC(ch) >= '0' && ch <= '9')
  184.         x = 10*x + ch - '0';
  185.     while(ch <= ' ' && ch >= 0)
  186.         GETC(ch);
  187.     if (ch == EOF)
  188.         return EOF;
  189.     *val = sign ? -x : x;
  190.     *chp = ch;
  191.     return 0;
  192.     }
  193.  
  194.  static int
  195. getdimen(chp, d, delta, extent, x1)
  196.  int *chp;
  197.  dimen *d;
  198.  ftnlen delta, extent, *x1;
  199. {
  200.     register int k;
  201.     ftnlen x2, x3;
  202.  
  203.     if (k = getnum(chp, x1))
  204.         return k;
  205.     x3 = 1;
  206.     if (*chp == ':') {
  207.         if (k = getnum(chp, &x2))
  208.             return k;
  209.         x2 -= *x1;
  210.         if (*chp == ':') {
  211.             if (k = getnum(chp, &x3))
  212.                 return k;
  213.             if (!x3)
  214.                 return 123;
  215.             x2 /= x3;
  216.             }
  217.         if (x2 < 0 || x2 >= extent)
  218.             return 123;
  219.         d->extent = x2 + 1;
  220.         }
  221.     else
  222.         d->extent = 1;
  223.     d->curval = 0;
  224.     d->delta = delta;
  225.     d->stride = x3;
  226.     return 0;
  227.     }
  228.  
  229.  static char where0[] = "namelist read start ";
  230.  
  231. x_rsne(a)
  232.  cilist *a;
  233. {
  234.     int ch, got1, k, n, nd;
  235.     Namelist *nl;
  236.     static char where[] = "namelist read";
  237.     char buf[64];
  238.     hashtab *ht;
  239.     Vardesc *v;
  240.     dimen *dn, *dn0, *dn1;
  241.     ftnlen *dims, *dims1;
  242.     ftnlen b, b0, b1, ex, no, no1, nomax, size, span;
  243.     ftnint type;
  244.     char *vaddr;
  245.     long iva, ivae;
  246.     dimen dimens[MAXDIM], substr;
  247.  
  248.     if (!Alpha['a'])
  249.         nl_init();
  250.     reading=1;
  251.     formatted=1;
  252.     lquit = 0;
  253.     lcount = 0;
  254.     got1 = 0;
  255.     for(;;) switch(GETC(ch)) {
  256.         case EOF:
  257.             err(a->ciend,(EOF),where0);
  258.         case '&':
  259.         case '$':
  260.             goto have_amp;
  261.         default:
  262.             if (ch <= ' ' && ch >= 0)
  263.                 continue;
  264.             err(a->cierr, 115, where0);
  265.         }
  266.  have_amp:
  267.     if (ch = getname(buf,sizeof(buf)))
  268.         return ch;
  269.     nl = (Namelist *)a->cifmt;
  270.     if (strcmp(buf, nl->name))
  271.         err(a->cierr, 118, where0);
  272.     ht = mk_hashtab(nl);
  273.     if (!ht)
  274.         err(elist->cierr, 113, where0);
  275.     for(;;) {
  276.         for(;;) switch(GETC(ch)) {
  277.             case EOF:
  278.                 if (got1)
  279.                     return 0;
  280.                 err(a->ciend,(EOF),where0);
  281.             case '/':
  282.             case '$':
  283.                 return 0;
  284.             default:
  285.                 if (ch <= ' ' && ch >= 0 || ch == ',')
  286.                     continue;
  287.                 Ungetc(ch,cf);
  288.                 if (ch = getname(buf,sizeof(buf)))
  289.                     return ch;
  290.                 goto havename;
  291.             }
  292.  havename:
  293.         v = hash(ht,buf);
  294.         if (!v)
  295.             err(a->cierr, 119, where);
  296.         while(GETC(ch) <= ' ' && ch >= 0);
  297.         vaddr = v->addr;
  298.         type = v->type;
  299.         if (type < 0) {
  300.             size = -type;
  301.             type = TYCHAR;
  302.             }
  303.         else
  304.             size = typesize[type];
  305.         ivae = size;
  306.         iva = 0;
  307.         if (ch == '(' /*)*/ ) {
  308.             dn = dimens;
  309.             if (!(dims = v->dims)) {
  310.                 if (type != TYCHAR)
  311.                     err(a->cierr, 122, where);
  312.                 if (k = getdimen(&ch, dn, (ftnlen)size,
  313.                         (ftnlen)size, &b))
  314.                     err(a->cierr, k, where);
  315.                 if (ch != ')')
  316.                     err(a->cierr, 115, where);
  317.                 b1 = dn->extent;
  318.                 if (--b < 0 || b + b1 > size)
  319.                     return 124;
  320.                 iva += b;
  321.                 size = b1;
  322.                 while(GETC(ch) <= ' ' && ch >= 0);
  323.                 goto scalar;
  324.                 }
  325.             nd = dims[0];
  326.             nomax = span = dims[1];
  327.             ivae = iva + size*nomax;
  328.             if (k = getdimen(&ch, dn, size, nomax, &b))
  329.                 err(a->cierr, k, where);
  330.             no = dn->extent;
  331.             b0 = dims[2];
  332.             dims1 = dims += 3;
  333.             ex = 1;
  334.             for(n = 1; n++ < nd; dims++) {
  335.                 if (ch != ',')
  336.                     err(a->cierr, 115, where);
  337.                 dn1 = dn + 1;
  338.                 span /= *dims;
  339.                 if (k = getdimen(&ch, dn1, dn->delta**dims,
  340.                         span, &b1))
  341.                     err(a->cierr, k, where);
  342.                 ex *= *dims;
  343.                 b += b1*ex;
  344.                 no *= dn1->extent;
  345.                 dn = dn1;
  346.                 }
  347.             if (ch != ')')
  348.                 err(a->cierr, 115, where);
  349.             b -= b0;
  350.             if (b < 0 || b >= nomax)
  351.                 err(a->cierr, 125, where);
  352.             iva += size * b;
  353.             dims = dims1;
  354.             while(GETC(ch) <= ' ' && ch >= 0);
  355.             no1 = 1;
  356.             dn0 = dimens;
  357.             if (type == TYCHAR && ch == '(' /*)*/) {
  358.                 if (k = getdimen(&ch, &substr, size, size, &b))
  359.                     err(a->cierr, k, where);
  360.                 if (ch != ')')
  361.                     err(a->cierr, 115, where);
  362.                 b1 = substr.extent;
  363.                 if (--b < 0 || b + b1 > size)
  364.                     return 124;
  365.                 iva += b;
  366.                 b0 = size;
  367.                 size = b1;
  368.                 while(GETC(ch) <= ' ' && ch >= 0);
  369.                 if (b1 < b0)
  370.                     goto delta_adj;
  371.                 }
  372.             for(; dn0 < dn; dn0++) {
  373.                 if (dn0->extent != *dims++ || dn0->stride != 1)
  374.                     break;
  375.                 no1 *= dn0->extent;
  376.                 }
  377.             if (dn0 == dimens && dimens[0].stride == 1) {
  378.                 no1 = dimens[0].extent;
  379.                 dn0++;
  380.                 }
  381.  delta_adj:
  382.             ex = 0;
  383.             for(dn1 = dn0; dn1 <= dn; dn1++)
  384.                 ex += (dn1->extent-1)
  385.                     * (dn1->delta *= dn1->stride);
  386.             for(dn1 = dn; dn1 > dn0; dn1--) {
  387.                 ex -= (dn1->extent - 1) * dn1->delta;
  388.                 dn1->delta -= ex;
  389.                 }
  390.             }
  391.         else if (dims = v->dims) {
  392.             no = no1 = dims[1];
  393.             ivae = iva + no*size;
  394.             }
  395.         else
  396.  scalar:
  397.             no = no1 = 1;
  398.         if (ch != '=')
  399.             err(a->cierr, 115, where);
  400.         got1 = 1;
  401.      readloop:
  402.         for(;;) {
  403.             if (iva >= ivae || iva < 0)
  404.                 goto mustend;
  405.             else if (iva + no1*size > ivae) {
  406.                 no1 = (ivae - iva)/size;
  407.                 l_read(&no1, vaddr + iva, size, type);
  408.  mustend:
  409.                 if (GETC(ch) == '/' || ch == '$')
  410.                     lquit = 1;
  411.                 else
  412.                     err(a->cierr, 125, where);
  413.                 }
  414.             else
  415.                 l_read(&no1, vaddr + iva, size, type);
  416.             if (lquit)
  417.                 return 0;
  418.             if ((no -= no1) <= 0)
  419.                 break;
  420.             for(dn1 = dn0; dn1 <= dn; dn1++) {
  421.                 if (++dn1->curval < dn1->extent) {
  422.                     iva += dn1->delta;
  423.                     goto readloop;
  424.                     }
  425.                 dn1->curval = 0;
  426.                 }
  427.             break;
  428.             }
  429.         }
  430.     }
  431.  
  432.  integer
  433. s_rsne(a)
  434.  cilist *a;
  435. {
  436.     int n;
  437.     extern integer e_rsle();
  438.     external=1;
  439.     if(n = c_le(a))
  440.         return n;
  441.     if(curunit->uwrt && nowreading(curunit))
  442.         err(a->cierr,errno,where0);
  443.     l_getc = t_getc;
  444.     l_ungetc = ungetc;
  445.     if (n = x_rsne(a))
  446.         return n;
  447.     return e_rsle();
  448.     }
  449.