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