← Back to branch summary

~ubuntu-branches/ubuntu/trusty/libf2c2/trusty

« back to all changes in this revision

Viewing changes to libI77/rsne.c

  • Committer: Bazaar Package Importer
  • Author(s): Alan Bain
  • Date: 2008-05-19 22:50:54 UTC
  • mfrom: (2.1.4 intrepid)
  • Revision ID: james.westby@ubuntu.com-20080519225054-jlymia0wdvvfq7dg
Tags: 20061008-4
Remove CVS directory left in source package

Show diffs side-by-side

added added

removed removed

Lines of Context:
libI77/rsne.c
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 int n_nlcache;
33
 
 static hashentry **zot;
34
 
 static int colonseen;
35
 
 extern ftnlen f__typesize[];
36
 
 
37
 
 extern flag f__lquit;
38
 
 extern int f__lcount, nml_read;
39
 
 extern int t_getc(Void);
40
 
 
41
 
#ifdef KR_headers
42
 
 extern char *malloc(), *memset();
43
 
 
44
 
#ifdef ungetc
45
 
 static int
46
 
un_getc(x,f__cf) int x; FILE *f__cf;
47
 
{ return ungetc(x,f__cf); }
48
 
#else
49
 
#define un_getc ungetc
50
 
 extern int ungetc();
51
 
#endif
52
 
 
53
 
#else
54
 
#undef abs
55
 
#undef min
56
 
#undef max
57
 
#include "stdlib.h"
58
 
#include "string.h"
59
 
#ifdef __cplusplus
60
 
extern "C" {
61
 
#endif
62
 
 
63
 
#ifdef ungetc
64
 
 static int
65
 
un_getc(int x, FILE *f__cf)
66
 
{ return ungetc(x,f__cf); }
67
 
#else
68
 
#define un_getc ungetc
69
 
extern int ungetc(int, FILE*);  /* for systems with a buggy stdio.h */
70
 
#endif
71
 
#endif
72
 
 
73
 
 static Vardesc *
74
 
#ifdef KR_headers
75
 
hash(ht, s) hashtab *ht; register char *s;
76
 
#else
77
 
hash(hashtab *ht, register char *s)
78
 
#endif
79
 
{
80
 
        register int c, x;
81
 
        register hashentry *h;
82
 
        char *s0 = s;
83
 
 
84
 
        for(x = 0; c = *s++; x = x & 0x4000 ? ((x << 1) & 0x7fff) + 1 : x << 1)
85
 
                x += c;
86
 
        for(h = *(zot = ht->tab + x % ht->htsize); h; h = h->next)
87
 
                if (!strcmp(s0, h->name))
88
 
                        return h->vd;
89
 
        return 0;
90
 
        }
91
 
 
92
 
 hashtab *
93
 
#ifdef KR_headers
94
 
mk_hashtab(nl) Namelist *nl;
95
 
#else
96
 
mk_hashtab(Namelist *nl)
97
 
#endif
98
 
{
99
 
        int nht, nv;
100
 
        hashtab *ht;
101
 
        Vardesc *v, **vd, **vde;
102
 
        hashentry *he;
103
 
 
104
 
        hashtab **x, **x0, *y;
105
 
        for(x = &nl_cache; y = *x; x0 = x, x = &y->next)
106
 
                if (nl == y->nl)
107
 
                        return y;
108
 
        if (n_nlcache >= MAX_NL_CACHE) {
109
 
                /* discard least recently used namelist hash table */
110
 
                y = *x0;
111
 
                free((char *)y->next);
112
 
                y->next = 0;
113
 
                }
114
 
        else
115
 
                n_nlcache++;
116
 
        nv = nl->nvars;
117
 
        if (nv >= 0x4000)
118
 
                nht = 0x7fff;
119
 
        else {
120
 
                for(nht = 1; nht < nv; nht <<= 1);
121
 
                nht += nht - 1;
122
 
                }
123
 
        ht = (hashtab *)malloc(sizeof(hashtab) + (nht-1)*sizeof(hashentry *)
124
 
                                + nv*sizeof(hashentry));
125
 
        if (!ht)
126
 
                return 0;
127
 
        he = (hashentry *)&ht->tab[nht];
128
 
        ht->nl = nl;
129
 
        ht->htsize = nht;
130
 
        ht->next = nl_cache;
131
 
        nl_cache = ht;
132
 
        memset((char *)ht->tab, 0, nht*sizeof(hashentry *));
133
 
        vd = nl->vars;
134
 
        vde = vd + nv;
135
 
        while(vd < vde) {
136
 
                v = *vd++;
137
 
                if (!hash(ht, v->name)) {
138
 
                        he->next = *zot;
139
 
                        *zot = he;
140
 
                        he->name = v->name;
141
 
                        he->vd = v;
142
 
                        he++;
143
 
                        }
144
 
                }
145
 
        return ht;
146
 
        }
147
 
 
148
 
static char Alpha[256], Alphanum[256];
149
 
 
150
 
 static VOID
151
 
nl_init(Void) {
152
 
        register char *s;
153
 
        register int c;
154
 
 
155
 
        if(!f__init)
156
 
                f_init();
157
 
        for(s = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; c = *s++; )
158
 
                Alpha[c]
159
 
                = Alphanum[c]
160
 
                = Alpha[c + 'a' - 'A']
161
 
                = Alphanum[c + 'a' - 'A']
162
 
                = c;
163
 
        for(s = "0123456789_"; c = *s++; )
164
 
                Alphanum[c] = c;
165
 
        }
166
 
 
167
 
#define GETC(x) (x=(*l_getc)())
168
 
#define Ungetc(x,y) (*l_ungetc)(x,y)
169
 
 
170
 
 static int
171
 
#ifdef KR_headers
172
 
getname(s, slen) register char *s; int slen;
173
 
#else
174
 
getname(register char *s, int slen)
175
 
#endif
176
 
{
177
 
        register char *se = s + slen - 1;
178
 
        register int ch;
179
 
 
180
 
        GETC(ch);
181
 
        if (!(*s++ = Alpha[ch & 0xff])) {
182
 
                if (ch != EOF)
183
 
                        ch = 115;
184
 
                errfl(f__elist->cierr, ch, "namelist read");
185
 
                }
186
 
        while(*s = Alphanum[GETC(ch) & 0xff])
187
 
                if (s < se)
188
 
                        s++;
189
 
        if (ch == EOF)
190
 
                err(f__elist->cierr, EOF, "namelist read");
191
 
        if (ch > ' ')
192
 
                Ungetc(ch,f__cf);
193
 
        return *s = 0;
194
 
        }
195
 
 
196
 
 static int
197
 
#ifdef KR_headers
198
 
getnum(chp, val) int *chp; ftnlen *val;
199
 
#else
200
 
getnum(int *chp, ftnlen *val)
201
 
#endif
202
 
{
203
 
        register int ch, sign;
204
 
        register ftnlen x;
205
 
 
206
 
        while(GETC(ch) <= ' ' && ch >= 0);
207
 
        if (ch == '-') {
208
 
                sign = 1;
209
 
                GETC(ch);
210
 
                }
211
 
        else {
212
 
                sign = 0;
213
 
                if (ch == '+')
214
 
                        GETC(ch);
215
 
                }
216
 
        x = ch - '0';
217
 
        if (x < 0 || x > 9)
218
 
                return 115;
219
 
        while(GETC(ch) >= '0' && ch <= '9')
220
 
                x = 10*x + ch - '0';
221
 
        while(ch <= ' ' && ch >= 0)
222
 
                GETC(ch);
223
 
        if (ch == EOF)
224
 
                return EOF;
225
 
        *val = sign ? -x : x;
226
 
        *chp = ch;
227
 
        return 0;
228
 
        }
229
 
 
230
 
 static int
231
 
#ifdef KR_headers
232
 
getdimen(chp, d, delta, extent, x1)
233
 
 int *chp; dimen *d; ftnlen delta, extent, *x1;
234
 
#else
235
 
getdimen(int *chp, dimen *d, ftnlen delta, ftnlen extent, ftnlen *x1)
236
 
#endif
237
 
{
238
 
        register int k;
239
 
        ftnlen x2, x3;
240
 
 
241
 
        if (k = getnum(chp, x1))
242
 
                return k;
243
 
        x3 = 1;
244
 
        if (*chp == ':') {
245
 
                if (k = getnum(chp, &x2))
246
 
                        return k;
247
 
                x2 -= *x1;
248
 
                if (*chp == ':') {
249
 
                        if (k = getnum(chp, &x3))
250
 
                                return k;
251
 
                        if (!x3)
252
 
                                return 123;
253
 
                        x2 /= x3;
254
 
                        colonseen = 1;
255
 
                        }
256
 
                if (x2 < 0 || x2 >= extent)
257
 
                        return 123;
258
 
                d->extent = x2 + 1;
259
 
                }
260
 
        else
261
 
                d->extent = 1;
262
 
        d->curval = 0;
263
 
        d->delta = delta;
264
 
        d->stride = x3;
265
 
        return 0;
266
 
        }
267
 
 
268
 
#ifndef No_Namelist_Questions
269
 
 static Void
270
 
#ifdef KR_headers
271
 
print_ne(a) cilist *a;
272
 
#else
273
 
print_ne(cilist *a)
274
 
#endif
275
 
{
276
 
        flag intext = f__external;
277
 
        int rpsave = f__recpos;
278
 
        FILE *cfsave = f__cf;
279
 
        unit *usave = f__curunit;
280
 
        cilist t;
281
 
        t = *a;
282
 
        t.ciunit = 6;
283
 
        s_wsne(&t);
284
 
        fflush(f__cf);
285
 
        f__external = intext;
286
 
        f__reading = 1;
287
 
        f__recpos = rpsave;
288
 
        f__cf = cfsave;
289
 
        f__curunit = usave;
290
 
        f__elist = a;
291
 
        }
292
 
#endif
293
 
 
294
 
 static char where0[] = "namelist read start ";
295
 
 
296
 
 int
297
 
#ifdef KR_headers
298
 
x_rsne(a) cilist *a;
299
 
#else
300
 
x_rsne(cilist *a)
301
 
#endif
302
 
{
303
 
        int ch, got1, k, n, nd, quote, readall;
304
 
        Namelist *nl;
305
 
        static char where[] = "namelist read";
306
 
        char buf[64];
307
 
        hashtab *ht;
308
 
        Vardesc *v;
309
 
        dimen *dn, *dn0, *dn1;
310
 
        ftnlen *dims, *dims1;
311
 
        ftnlen b, b0, b1, ex, no, nomax, size, span;
312
 
        ftnint no1, no2, type;
313
 
        char *vaddr;
314
 
        long iva, ivae;
315
 
        dimen dimens[MAXDIM], substr;
316
 
 
317
 
        if (!Alpha['a'])
318
 
                nl_init();
319
 
        f__reading=1;
320
 
        f__formatted=1;
321
 
        got1 = 0;
322
 
 top:
323
 
        for(;;) switch(GETC(ch)) {
324
 
                case EOF:
325
 
 eof:
326
 
                        err(a->ciend,(EOF),where0);
327
 
                case '&':
328
 
                case '$':
329
 
                        goto have_amp;
330
 
#ifndef No_Namelist_Questions
331
 
                case '?':
332
 
                        print_ne(a);
333
 
                        continue;
334
 
#endif
335
 
                default:
336
 
                        if (ch <= ' ' && ch >= 0)
337
 
                                continue;
338
 
#ifndef No_Namelist_Comments
339
 
                        while(GETC(ch) != '\n')
340
 
                                if (ch == EOF)
341
 
                                        goto eof;
342
 
#else
343
 
                        errfl(a->cierr, 115, where0);
344
 
#endif
345
 
                }
346
 
 have_amp:
347
 
        if (ch = getname(buf,sizeof(buf)))
348
 
                return ch;
349
 
        nl = (Namelist *)a->cifmt;
350
 
        if (strcmp(buf, nl->name))
351
 
#ifdef No_Bad_Namelist_Skip
352
 
                errfl(a->cierr, 118, where0);
353
 
#else
354
 
        {
355
 
                fprintf(stderr,
356
 
                        "Skipping namelist \"%s\": seeking namelist \"%s\".\n",
357
 
                        buf, nl->name);
358
 
                fflush(stderr);
359
 
                for(;;) switch(GETC(ch)) {
360
 
                        case EOF:
361
 
                                err(a->ciend, EOF, where0);
362
 
                        case '/':
363
 
                        case '&':
364
 
                        case '$':
365
 
                                if (f__external)
366
 
                                        e_rsle();
367
 
                                else
368
 
                                        z_rnew();
369
 
                                goto top;
370
 
                        case '"':
371
 
                        case '\'':
372
 
                                quote = ch;
373
 
 more_quoted:
374
 
                                while(GETC(ch) != quote)
375
 
                                        if (ch == EOF)
376
 
                                                err(a->ciend, EOF, where0);
377
 
                                if (GETC(ch) == quote)
378
 
                                        goto more_quoted;
379
 
                                Ungetc(ch,f__cf);
380
 
                        default:
381
 
                                continue;
382
 
                        }
383
 
                }
384
 
#endif
385
 
        ht = mk_hashtab(nl);
386
 
        if (!ht)
387
 
                errfl(f__elist->cierr, 113, where0);
388
 
        for(;;) {
389
 
                for(;;) switch(GETC(ch)) {
390
 
                        case EOF:
391
 
                                if (got1)
392
 
                                        return 0;
393
 
                                err(a->ciend, EOF, where0);
394
 
                        case '/':
395
 
                        case '$':
396
 
                        case '&':
397
 
                                return 0;
398
 
                        default:
399
 
                                if (ch <= ' ' && ch >= 0 || ch == ',')
400
 
                                        continue;
401
 
                                Ungetc(ch,f__cf);
402
 
                                if (ch = getname(buf,sizeof(buf)))
403
 
                                        return ch;
404
 
                                goto havename;
405
 
                        }
406
 
 havename:
407
 
                v = hash(ht,buf);
408
 
                if (!v)
409
 
                        errfl(a->cierr, 119, where);
410
 
                while(GETC(ch) <= ' ' && ch >= 0);
411
 
                vaddr = v->addr;
412
 
                type = v->type;
413
 
                if (type < 0) {
414
 
                        size = -type;
415
 
                        type = TYCHAR;
416
 
                        }
417
 
                else
418
 
                        size = f__typesize[type];
419
 
                ivae = size;
420
 
                iva = readall = 0;
421
 
                if (ch == '(' /*)*/ ) {
422
 
                        dn = dimens;
423
 
                        if (!(dims = v->dims)) {
424
 
                                if (type != TYCHAR)
425
 
                                        errfl(a->cierr, 122, where);
426
 
                                if (k = getdimen(&ch, dn, (ftnlen)size,
427
 
                                                (ftnlen)size, &b))
428
 
                                        errfl(a->cierr, k, where);
429
 
                                if (ch != ')')
430
 
                                        errfl(a->cierr, 115, where);
431
 
                                b1 = dn->extent;
432
 
                                if (--b < 0 || b + b1 > size)
433
 
                                        return 124;
434
 
                                iva += b;
435
 
                                size = b1;
436
 
                                while(GETC(ch) <= ' ' && ch >= 0);
437
 
                                goto scalar;
438
 
                                }
439
 
                        nd = (int)dims[0];
440
 
                        nomax = span = dims[1];
441
 
                        ivae = iva + size*nomax;
442
 
                        colonseen = 0;
443
 
                        if (k = getdimen(&ch, dn, size, nomax, &b))
444
 
                                errfl(a->cierr, k, where);
445
 
                        no = dn->extent;
446
 
                        b0 = dims[2];
447
 
                        dims1 = dims += 3;
448
 
                        ex = 1;
449
 
                        for(n = 1; n++ < nd; dims++) {
450
 
                                if (ch != ',')
451
 
                                        errfl(a->cierr, 115, where);
452
 
                                dn1 = dn + 1;
453
 
                                span /= *dims;
454
 
                                if (k = getdimen(&ch, dn1, dn->delta**dims,
455
 
                                                span, &b1))
456
 
                                        errfl(a->cierr, k, where);
457
 
                                ex *= *dims;
458
 
                                b += b1*ex;
459
 
                                no *= dn1->extent;
460
 
                                dn = dn1;
461
 
                                }
462
 
                        if (ch != ')')
463
 
                                errfl(a->cierr, 115, where);
464
 
                        readall = 1 - colonseen;
465
 
                        b -= b0;
466
 
                        if (b < 0 || b >= nomax)
467
 
                                errfl(a->cierr, 125, where);
468
 
                        iva += size * b;
469
 
                        dims = dims1;
470
 
                        while(GETC(ch) <= ' ' && ch >= 0);
471
 
                        no1 = 1;
472
 
                        dn0 = dimens;
473
 
                        if (type == TYCHAR && ch == '(' /*)*/) {
474
 
                                if (k = getdimen(&ch, &substr, size, size, &b))
475
 
                                        errfl(a->cierr, k, where);
476
 
                                if (ch != ')')
477
 
                                        errfl(a->cierr, 115, where);
478
 
                                b1 = substr.extent;
479
 
                                if (--b < 0 || b + b1 > size)
480
 
                                        return 124;
481
 
                                iva += b;
482
 
                                b0 = size;
483
 
                                size = b1;
484
 
                                while(GETC(ch) <= ' ' && ch >= 0);
485
 
                                if (b1 < b0)
486
 
                                        goto delta_adj;
487
 
                                }
488
 
                        if (readall)
489
 
                                goto delta_adj;
490
 
                        for(; dn0 < dn; dn0++) {
491
 
                                if (dn0->extent != *dims++ || dn0->stride != 1)
492
 
                                        break;
493
 
                                no1 *= dn0->extent;
494
 
                                }
495
 
                        if (dn0 == dimens && dimens[0].stride == 1) {
496
 
                                no1 = dimens[0].extent;
497
 
                                dn0++;
498
 
                                }
499
 
 delta_adj:
500
 
                        ex = 0;
501
 
                        for(dn1 = dn0; dn1 <= dn; dn1++)
502
 
                                ex += (dn1->extent-1)
503
 
                                        * (dn1->delta *= dn1->stride);
504
 
                        for(dn1 = dn; dn1 > dn0; dn1--) {
505
 
                                ex -= (dn1->extent - 1) * dn1->delta;
506
 
                                dn1->delta -= ex;
507
 
                                }
508
 
                        }
509
 
                else if (dims = v->dims) {
510
 
                        no = no1 = dims[1];
511
 
                        ivae = iva + no*size;
512
 
                        }
513
 
                else
514
 
 scalar:
515
 
                        no = no1 = 1;
516
 
                if (ch != '=')
517
 
                        errfl(a->cierr, 115, where);
518
 
                got1 = nml_read = 1;
519
 
                f__lcount = 0;
520
 
         readloop:
521
 
                for(;;) {
522
 
                        if (iva >= ivae || iva < 0) {
523
 
                                f__lquit = 1;
524
 
                                goto mustend;
525
 
                                }
526
 
                        else if (iva + no1*size > ivae)
527
 
                                no1 = (ivae - iva)/size;
528
 
                        f__lquit = 0;
529
 
                        if (k = l_read(&no1, vaddr + iva, size, type))
530
 
                                return k;
531
 
                        if (f__lquit == 1)
532
 
                                return 0;
533
 
                        if (readall) {
534
 
                                iva += dn0->delta;
535
 
                                if (f__lcount > 0) {
536
 
                                        no2 = (ivae - iva)/size;
537
 
                                        if (no2 > f__lcount)
538
 
                                                no2 = f__lcount;
539
 
                                        if (k = l_read(&no2, vaddr + iva,
540
 
                                                        size, type))
541
 
                                                return k;
542
 
                                        iva += no2 * dn0->delta;
543
 
                                        }
544
 
                                }
545
 
 mustend:
546
 
                        GETC(ch);
547
 
                        if (readall)
548
 
                                if (iva >= ivae)
549
 
                                        readall = 0;
550
 
                                else for(;;) {
551
 
                                        switch(ch) {
552
 
                                                case ' ':
553
 
                                                case '\t':
554
 
                                                case '\n':
555
 
                                                        GETC(ch);
556
 
                                                        continue;
557
 
                                                }
558
 
                                        break;
559
 
                                        }
560
 
                        if (ch == '/' || ch == '$' || ch == '&') {
561
 
                                f__lquit = 1;
562
 
                                return 0;
563
 
                                }
564
 
                        else if (f__lquit) {
565
 
                                while(ch <= ' ' && ch >= 0)
566
 
                                        GETC(ch);
567
 
                                Ungetc(ch,f__cf);
568
 
                                if (!Alpha[ch & 0xff] && ch >= 0)
569
 
                                        errfl(a->cierr, 125, where);
570
 
                                break;
571
 
                                }
572
 
                        Ungetc(ch,f__cf);
573
 
                        if (readall && !Alpha[ch & 0xff])
574
 
                                goto readloop;
575
 
                        if ((no -= no1) <= 0)
576
 
                                break;
577
 
                        for(dn1 = dn0; dn1 <= dn; dn1++) {
578
 
                                if (++dn1->curval < dn1->extent) {
579
 
                                        iva += dn1->delta;
580
 
                                        goto readloop;
581
 
                                        }
582
 
                                dn1->curval = 0;
583
 
                                }
584
 
                        break;
585
 
                        }
586
 
                }
587
 
        }
588
 
 
589
 
 integer
590
 
#ifdef KR_headers
591
 
s_rsne(a) cilist *a;
592
 
#else
593
 
s_rsne(cilist *a)
594
 
#endif
595
 
{
596
 
        extern int l_eof;
597
 
        int n;
598
 
 
599
 
        f__external=1;
600
 
        l_eof = 0;
601
 
        if(n = c_le(a))
602
 
                return n;
603
 
        if(f__curunit->uwrt && f__nowreading(f__curunit))
604
 
                err(a->cierr,errno,where0);
605
 
        l_getc = t_getc;
606
 
        l_ungetc = un_getc;
607
 
        f__doend = xrd_SL;
608
 
        n = x_rsne(a);
609
 
        nml_read = 0;
610
 
        if (n)
611
 
                return n;
612
 
        return e_rsle();
613
 
        }
614
 
#ifdef __cplusplus
615
 
}
616
 
#endif