Category : C Source Code
Archive   : F2CSRC.ZIP
Filename : RSNE.C

 
Output of file : RSNE.C contained in archive : F2CSRC.ZIP
#include "f2c.h"
#include "fio.h"
#include "lio.h"

#define MAX_NL_CACHE 3 /* maximum number of namelist hash tables to cache */
#define MAXDIM 20 /* maximum number of subscripts */

#ifdef MSDOS
extern char *malloc();
#else
extern char *malloc(), *memset();
#endif

struct dimen {
ftnlen extent;
ftnlen curval;
ftnlen delta;
ftnlen stride;
};
typedef struct dimen dimen;

struct hashentry {
struct hashentry *next;
char *name;
Vardesc *vd;
};
typedef struct hashentry hashentry;

struct hashtab {
struct hashtab *next;
Namelist *nl;
int htsize;
hashentry *tab[1];
};
typedef struct hashtab hashtab;

static hashtab *nl_cache;
static n_nlcache;
static hashentry **zot;
extern ftnlen typesize[];

extern flag lquit;
extern int lcount;
extern int (*l_getc)(), (*l_ungetc)(), t_getc(), ungetc();

static Vardesc *
hash(ht, s)
hashtab *ht;
register char *s;
{
register int c, x;
register hashentry *h;
char *s0 = s;

for(x = 0; c = *s++; x = x & 0x4000 ? ((x << 1) & 0x7fff) + 1 : x << 1)
x += c;
for(h = *(zot = ht->tab + x % ht->htsize); h; h = h->next)
if (!strcmp(s0, h->name))
return h->vd;
return 0;
}

hashtab *
mk_hashtab(nl)
Namelist *nl;
{
int nht, nv;
hashtab *ht;
Vardesc *v, **vd, **vde;
hashentry *he;

hashtab **x, **x0, *y;
for(x = &nl_cache; y = *x; x0 = x, x = &y->next)
if (nl == y->nl)
return y;
if (n_nlcache >= MAX_NL_CACHE) {
/* discard least recently used namelist hash table */
y = *x0;
free((char *)y->next);
y->next = 0;
}
else
n_nlcache++;
nv = nl->nvars;
if (nv >= 0x4000)
nht = 0x7fff;
else {
for(nht = 1; nht < nv; nht <<= 1);
nht += nht - 1;
}
ht = (hashtab *)malloc(sizeof(hashtab) + (nht-1)*sizeof(hashentry *)
+ nv*sizeof(hashentry));
if (!ht)
return 0;
he = (hashentry *)&ht->tab[nht];
ht->nl = nl;
ht->htsize = nht;
ht->next = nl_cache;
nl_cache = ht;
memset((char *)ht->tab, 0, nht*sizeof(hashentry *));
vd = nl->vars;
vde = vd + nv;
while(vd < vde) {
v = *vd++;
if (!hash(ht, v->name)) {
he->next = *zot;
*zot = he;
he->name = v->name;
he->vd = v;
he++;
}
}
return ht;
}

static char Alpha[256], Alphanum[256];

static void
nl_init() {
register char *s;
register int c;

if(!init)
f_init();
for(s = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; c = *s++; )
Alpha[c]
= Alphanum[c]
= Alpha[c + 'a' - 'A']
= Alphanum[c + 'a' - 'A']
= c;
for(s = "0123456789_"; c = *s++; )
Alphanum[c] = c;
}

#define GETC(x) (x=(*l_getc)())
#define Ungetc(x,y) (*l_ungetc)(x,y)

static int
getname(s, slen)
register char *s;
int slen;
{
register char *se = s + slen - 1;
register int ch;

GETC(ch);
if (!(*s++ = Alpha[ch & 0xff])) {
if (ch != EOF)
ch = 115;
err(elist->cierr, ch, "namelist read");
}
while(*s = Alphanum[GETC(ch) & 0xff])
if (s < se)
s++;
if (ch == EOF)
err(elist->cierr, ch == EOF ? -1 : 115, "namelist read");
if (ch > ' ')
Ungetc(ch,cf);
return *s = 0;
}

static int
getnum(chp, val)
int *chp;
ftnlen *val;
{
register int ch, sign;
register ftnlen x;

while(GETC(ch) <= ' ' && ch >= 0);
if (ch == '-') {
sign = 1;
GETC(ch);
}
else {
sign = 0;
if (ch == '+')
GETC(ch);
}
x = ch - '0';
if (x < 0 || x > 9)
return 115;
while(GETC(ch) >= '0' && ch <= '9')
x = 10*x + ch - '0';
while(ch <= ' ' && ch >= 0)
GETC(ch);
if (ch == EOF)
return EOF;
*val = sign ? -x : x;
*chp = ch;
return 0;
}

static int
getdimen(chp, d, delta, extent, x1)
int *chp;
dimen *d;
ftnlen delta, extent, *x1;
{
register int k;
ftnlen x2, x3;

if (k = getnum(chp, x1))
return k;
x3 = 1;
if (*chp == ':') {
if (k = getnum(chp, &x2))
return k;
x2 -= *x1;
if (*chp == ':') {
if (k = getnum(chp, &x3))
return k;
if (!x3)
return 123;
x2 /= x3;
}
if (x2 < 0 || x2 >= extent)
return 123;
d->extent = x2 + 1;
}
else
d->extent = 1;
d->curval = 0;
d->delta = delta;
d->stride = x3;
return 0;
}

static char where0[] = "namelist read start ";

x_rsne(a)
cilist *a;
{
int ch, got1, k, n, nd;
Namelist *nl;
static char where[] = "namelist read";
char buf[64];
hashtab *ht;
Vardesc *v;
dimen *dn, *dn0, *dn1;
ftnlen *dims, *dims1;
ftnlen b, b0, b1, ex, no, no1, nomax, size, span;
ftnint type;
char *vaddr;
long iva, ivae;
dimen dimens[MAXDIM], substr;

if (!Alpha['a'])
nl_init();
reading=1;
formatted=1;
lquit = 0;
lcount = 0;
got1 = 0;
for(;;) switch(GETC(ch)) {
case EOF:
err(a->ciend,(EOF),where0);
case '&':
case '$':
goto have_amp;
default:
if (ch <= ' ' && ch >= 0)
continue;
err(a->cierr, 115, where0);
}
have_amp:
if (ch = getname(buf,sizeof(buf)))
return ch;
nl = (Namelist *)a->cifmt;
if (strcmp(buf, nl->name))
err(a->cierr, 118, where0);
ht = mk_hashtab(nl);
if (!ht)
err(elist->cierr, 113, where0);
for(;;) {
for(;;) switch(GETC(ch)) {
case EOF:
if (got1)
return 0;
err(a->ciend,(EOF),where0);
case '/':
case '$':
return 0;
default:
if (ch <= ' ' && ch >= 0 || ch == ',')
continue;
Ungetc(ch,cf);
if (ch = getname(buf,sizeof(buf)))
return ch;
goto havename;
}
havename:
v = hash(ht,buf);
if (!v)
err(a->cierr, 119, where);
while(GETC(ch) <= ' ' && ch >= 0);
vaddr = v->addr;
type = v->type;
if (type < 0) {
size = -type;
type = TYCHAR;
}
else
size = typesize[type];
ivae = size;
iva = 0;
if (ch == '(' /*)*/ ) {
dn = dimens;
if (!(dims = v->dims)) {
if (type != TYCHAR)
err(a->cierr, 122, where);
if (k = getdimen(&ch, dn, (ftnlen)size,
(ftnlen)size, &b))
err(a->cierr, k, where);
if (ch != ')')
err(a->cierr, 115, where);
b1 = dn->extent;
if (--b < 0 || b + b1 > size)
return 124;
iva += b;
size = b1;
while(GETC(ch) <= ' ' && ch >= 0);
goto scalar;
}
nd = dims[0];
nomax = span = dims[1];
ivae = iva + size*nomax;
if (k = getdimen(&ch, dn, size, nomax, &b))
err(a->cierr, k, where);
no = dn->extent;
b0 = dims[2];
dims1 = dims += 3;
ex = 1;
for(n = 1; n++ < nd; dims++) {
if (ch != ',')
err(a->cierr, 115, where);
dn1 = dn + 1;
span /= *dims;
if (k = getdimen(&ch, dn1, dn->delta**dims,
span, &b1))
err(a->cierr, k, where);
ex *= *dims;
b += b1*ex;
no *= dn1->extent;
dn = dn1;
}
if (ch != ')')
err(a->cierr, 115, where);
b -= b0;
if (b < 0 || b >= nomax)
err(a->cierr, 125, where);
iva += size * b;
dims = dims1;
while(GETC(ch) <= ' ' && ch >= 0);
no1 = 1;
dn0 = dimens;
if (type == TYCHAR && ch == '(' /*)*/) {
if (k = getdimen(&ch, &substr, size, size, &b))
err(a->cierr, k, where);
if (ch != ')')
err(a->cierr, 115, where);
b1 = substr.extent;
if (--b < 0 || b + b1 > size)
return 124;
iva += b;
b0 = size;
size = b1;
while(GETC(ch) <= ' ' && ch >= 0);
if (b1 < b0)
goto delta_adj;
}
for(; dn0 < dn; dn0++) {
if (dn0->extent != *dims++ || dn0->stride != 1)
break;
no1 *= dn0->extent;
}
if (dn0 == dimens && dimens[0].stride == 1) {
no1 = dimens[0].extent;
dn0++;
}
delta_adj:
ex = 0;
for(dn1 = dn0; dn1 <= dn; dn1++)
ex += (dn1->extent-1)
* (dn1->delta *= dn1->stride);
for(dn1 = dn; dn1 > dn0; dn1--) {
ex -= (dn1->extent - 1) * dn1->delta;
dn1->delta -= ex;
}
}
else if (dims = v->dims) {
no = no1 = dims[1];
ivae = iva + no*size;
}
else
scalar:
no = no1 = 1;
if (ch != '=')
err(a->cierr, 115, where);
got1 = 1;
readloop:
for(;;) {
if (iva >= ivae || iva < 0)
goto mustend;
else if (iva + no1*size > ivae) {
no1 = (ivae - iva)/size;
l_read(&no1, vaddr + iva, size, type);
mustend:
if (GETC(ch) == '/' || ch == '$')
lquit = 1;
else
err(a->cierr, 125, where);
}
else
l_read(&no1, vaddr + iva, size, type);
if (lquit)
return 0;
if ((no -= no1) <= 0)
break;
for(dn1 = dn0; dn1 <= dn; dn1++) {
if (++dn1->curval < dn1->extent) {
iva += dn1->delta;
goto readloop;
}
dn1->curval = 0;
}
break;
}
}
}

integer
s_rsne(a)
cilist *a;
{
int n;
extern integer e_rsle();
external=1;
if(n = c_le(a))
return n;
if(curunit->uwrt && nowreading(curunit))
err(a->cierr,errno,where0);
l_getc = t_getc;
l_ungetc = ungetc;
if (n = x_rsne(a))
return n;
return e_rsle();
}


  3 Responses to “Category : C Source Code
Archive   : F2CSRC.ZIP
Filename : RSNE.C

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/