← Back to branch summary

~ubuntu-branches/ubuntu/karmic/scilab/karmic

« back to all changes in this revision

Viewing changes to routines/f2c/src/gram.dcl

  • Committer: Bazaar Package Importer
  • Author(s): Torsten Werner
  • Date: 2002-03-21 16:57:43 UTC
  • Revision ID: james.westby@ubuntu.com-20020321165743-e9mv12c1tb1plztg
Tags: upstream-2.6
Import upstream version 2.6

Show diffs side-by-side

added added

removed removed

Lines of Context:
routines/f2c/src/gram.dcl
 
1
spec:     dcl
 
2
        | common
 
3
        | external
 
4
        | intrinsic
 
5
        | equivalence
 
6
        | data
 
7
        | implicit
 
8
        | namelist
 
9
        | SSAVE
 
10
                { NO66("SAVE statement");
 
11
                  saveall = YES; }
 
12
        | SSAVE savelist
 
13
                { NO66("SAVE statement"); }
 
14
        | SFORMAT
 
15
                { fmtstmt(thislabel); setfmt(thislabel); }
 
16
        | SPARAM in_dcl SLPAR paramlist SRPAR
 
17
                { NO66("PARAMETER statement"); }
 
18
        ;
 
19
 
 
20
dcl:      type opt_comma name in_dcl new_dcl dims lengspec
 
21
                { settype($3, $1, $7);
 
22
                  if(ndim>0) setbound($3,ndim,dims);
 
23
                }
 
24
        | dcl SCOMMA name dims lengspec
 
25
                { settype($3, $1, $5);
 
26
                  if(ndim>0) setbound($3,ndim,dims);
 
27
                }
 
28
        | dcl SSLASHD datainit vallist SSLASHD
 
29
                { if (new_dcl == 2) {
 
30
                        err("attempt to give DATA in type-declaration");
 
31
                        new_dcl = 1;
 
32
                        }
 
33
                }
 
34
        ;
 
35
 
 
36
new_dcl:        { new_dcl = 2; } ;
 
37
 
 
38
type:     typespec lengspec
 
39
                { varleng = $2; }
 
40
        ;
 
41
 
 
42
typespec:  typename
 
43
                { varleng = ($1<0 || ONEOF($1,M(TYLOGICAL)|M(TYLONG))
 
44
                                ? 0 : typesize[$1]);
 
45
                  vartype = $1; }
 
46
        ;
 
47
 
 
48
typename:    SINTEGER   { $$ = TYLONG; }
 
49
        | SREAL         { $$ = tyreal; }
 
50
        | SCOMPLEX      { ++complex_seen; $$ = tycomplex; }
 
51
        | SDOUBLE       { $$ = TYDREAL; }
 
52
        | SDCOMPLEX     { ++dcomplex_seen; NOEXT("DOUBLE COMPLEX statement"); $$ = TYDCOMPLEX; }
 
53
        | SLOGICAL      { $$ = TYLOGICAL; }
 
54
        | SCHARACTER    { NO66("CHARACTER statement"); $$ = TYCHAR; }
 
55
        | SUNDEFINED    { $$ = TYUNKNOWN; }
 
56
        | SDIMENSION    { $$ = TYUNKNOWN; }
 
57
        | SAUTOMATIC    { NOEXT("AUTOMATIC statement"); $$ = - STGAUTO; }
 
58
        | SSTATIC       { NOEXT("STATIC statement"); $$ = - STGBSS; }
 
59
        | SBYTE         { $$ = TYINT1; }
 
60
        ;
 
61
 
 
62
lengspec:
 
63
                { $$ = varleng; }
 
64
        | SSTAR intonlyon expr intonlyoff
 
65
                {
 
66
                expptr p;
 
67
                p = $3;
 
68
                NO66("length specification *n");
 
69
                if( ! ISICON(p) || p->constblock.Const.ci <= 0 )
 
70
                        {
 
71
                        $$ = 0;
 
72
                        dclerr("length must be a positive integer constant",
 
73
                                NPNULL);
 
74
                        }
 
75
                else {
 
76
                        if (vartype == TYCHAR)
 
77
                                $$ = p->constblock.Const.ci;
 
78
                        else switch((int)p->constblock.Const.ci) {
 
79
                                case 1: $$ = 1; break;
 
80
                                case 2: $$ = typesize[TYSHORT]; break;
 
81
                                case 4: $$ = typesize[TYLONG];  break;
 
82
                                case 8: $$ = typesize[TYDREAL]; break;
 
83
                                case 16: $$ = typesize[TYDCOMPLEX]; break;
 
84
                                default:
 
85
                                        dclerr("invalid length",NPNULL);
 
86
                                        $$ = varleng;
 
87
                                }
 
88
                        }
 
89
                }
 
90
        | SSTAR intonlyon SLPAR SSTAR SRPAR intonlyoff
 
91
                { NO66("length specification *(*)"); $$ = -1; }
 
92
        ;
 
93
 
 
94
common:   SCOMMON in_dcl var
 
95
                { incomm( $$ = comblock("") , $3 ); }
 
96
        | SCOMMON in_dcl comblock var
 
97
                { $$ = $3;  incomm($3, $4); }
 
98
        | common opt_comma comblock opt_comma var
 
99
                { $$ = $3;  incomm($3, $5); }
 
100
        | common SCOMMA var
 
101
                { incomm($1, $3); }
 
102
        ;
 
103
 
 
104
comblock:  SCONCAT
 
105
                { $$ = comblock(""); }
 
106
        | SSLASH SNAME SSLASH
 
107
                { $$ = comblock(token); }
 
108
        ;
 
109
 
 
110
external: SEXTERNAL in_dcl name
 
111
                { setext($3); }
 
112
        | external SCOMMA name
 
113
                { setext($3); }
 
114
        ;
 
115
 
 
116
intrinsic:  SINTRINSIC in_dcl name
 
117
                { NO66("INTRINSIC statement"); setintr($3); }
 
118
        | intrinsic SCOMMA name
 
119
                { setintr($3); }
 
120
        ;
 
121
 
 
122
equivalence:  SEQUIV in_dcl equivset
 
123
        | equivalence SCOMMA equivset
 
124
        ;
 
125
 
 
126
equivset:  SLPAR equivlist SRPAR
 
127
                {
 
128
                struct Equivblock *p;
 
129
                if(nequiv >= maxequiv)
 
130
                        many("equivalences", 'q', maxequiv);
 
131
                p  =  & eqvclass[nequiv++];
 
132
                p->eqvinit = NO;
 
133
                p->eqvbottom = 0;
 
134
                p->eqvtop = 0;
 
135
                p->equivs = $2;
 
136
                }
 
137
        ;
 
138
 
 
139
equivlist:  lhs
 
140
                { $$=ALLOC(Eqvchain);
 
141
                  $$->eqvitem.eqvlhs = primchk($1);
 
142
                }
 
143
        | equivlist SCOMMA lhs
 
144
                { $$=ALLOC(Eqvchain);
 
145
                  $$->eqvitem.eqvlhs = primchk($3);
 
146
                  $$->eqvnextp = $1;
 
147
                }
 
148
        ;
 
149
 
 
150
data:     SDATA in_data datalist
 
151
        | data opt_comma datalist
 
152
        ;
 
153
 
 
154
in_data:
 
155
                { if(parstate == OUTSIDE)
 
156
                        {
 
157
                        newproc();
 
158
                        startproc(ESNULL, CLMAIN);
 
159
                        }
 
160
                  if(parstate < INDATA)
 
161
                        {
 
162
                        enddcl();
 
163
                        parstate = INDATA;
 
164
                        datagripe = 1;
 
165
                        }
 
166
                }
 
167
        ;
 
168
 
 
169
datalist:  datainit datavarlist SSLASH datapop vallist SSLASH
 
170
                { ftnint junk;
 
171
                  if(nextdata(&junk) != NULL)
 
172
                        err("too few initializers");
 
173
                  frdata($2);
 
174
                  frrpl();
 
175
                }
 
176
        ;
 
177
 
 
178
datainit: /* nothing */ { frchain(&datastack); curdtp = 0; } ;
 
179
 
 
180
datapop: /* nothing */ { pop_datastack(); } ;
 
181
 
 
182
vallist:  { toomanyinit = NO; }  val
 
183
        | vallist SCOMMA val
 
184
        ;
 
185
 
 
186
val:      value
 
187
                { dataval(ENULL, $1); }
 
188
        | simple SSTAR value
 
189
                { dataval($1, $3); }
 
190
        ;
 
191
 
 
192
value:    simple
 
193
        | addop simple
 
194
                { if( $1==OPMINUS && ISCONST($2) )
 
195
                        consnegop((Constp)$2);
 
196
                  $$ = $2;
 
197
                }
 
198
        | complex_const
 
199
        ;
 
200
 
 
201
savelist: saveitem
 
202
        | savelist SCOMMA saveitem
 
203
        ;
 
204
 
 
205
saveitem: name
 
206
                { int k;
 
207
                  $1->vsave = YES;
 
208
                  k = $1->vstg;
 
209
                if( ! ONEOF(k, M(STGUNKNOWN)|M(STGBSS)|M(STGINIT)) )
 
210
                        dclerr("can only save static variables", $1);
 
211
                }
 
212
        | comblock
 
213
        ;
 
214
 
 
215
paramlist:  paramitem
 
216
        | paramlist SCOMMA paramitem
 
217
        ;
 
218
 
 
219
paramitem:  name SEQUALS expr
 
220
                { if($1->vclass == CLUNKNOWN)
 
221
                        make_param((struct Paramblock *)$1, $3);
 
222
                  else dclerr("cannot make into parameter", $1);
 
223
                }
 
224
        ;
 
225
 
 
226
var:      name dims
 
227
                { if(ndim>0) setbound($1, ndim, dims); }
 
228
        ;
 
229
 
 
230
datavar:          lhs
 
231
                { Namep np;
 
232
                  struct Primblock *pp = (struct Primblock *)$1;
 
233
                  int tt = $1->tag;
 
234
                  if (tt != TPRIM) {
 
235
                        if (tt == TCONST)
 
236
                                err("parameter in data statement");
 
237
                        else
 
238
                                erri("tag %d in data statement",tt);
 
239
                        $$ = 0;
 
240
                        err_lineno = lineno;
 
241
                        break;
 
242
                        }
 
243
                  np = pp -> namep;
 
244
                  vardcl(np);
 
245
                  if ((pp->fcharp || pp->lcharp)
 
246
                   && (np->vtype != TYCHAR || np->vdim))
 
247
                        sserr(np);
 
248
                  if(np->vstg == STGCOMMON)
 
249
                        extsymtab[np->vardesc.varno].extinit = YES;
 
250
                  else if(np->vstg==STGEQUIV)
 
251
                        eqvclass[np->vardesc.varno].eqvinit = YES;
 
252
                  else if(np->vstg!=STGINIT && np->vstg!=STGBSS) {
 
253
                        errstr(np->vstg == STGARG
 
254
                                ? "Dummy argument \"%.60s\" in data statement."
 
255
                                : "Cannot give data to \"%.75s\"",
 
256
                                np->fvarname);
 
257
                        $$ = 0;
 
258
                        err_lineno = lineno;
 
259
                        break;
 
260
                        }
 
261
                  $$ = mkchain((char *)$1, CHNULL);
 
262
                }
 
263
        | SLPAR datavarlist SCOMMA dospec SRPAR
 
264
                { chainp p; struct Impldoblock *q;
 
265
                pop_datastack();
 
266
                q = ALLOC(Impldoblock);
 
267
                q->tag = TIMPLDO;
 
268
                (q->varnp = (Namep) ($4->datap))->vimpldovar = 1;
 
269
                p = $4->nextp;
 
270
                if(p)  { q->implb = (expptr)(p->datap); p = p->nextp; }
 
271
                if(p)  { q->impub = (expptr)(p->datap); p = p->nextp; }
 
272
                if(p)  { q->impstep = (expptr)(p->datap); }
 
273
                frchain( & ($4) );
 
274
                $$ = mkchain((char *)q, CHNULL);
 
275
                q->datalist = hookup($2, $$);
 
276
                }
 
277
        ;
 
278
 
 
279
datavarlist: datavar
 
280
                { if (!datastack)
 
281
                        curdtp = 0;
 
282
                  datastack = mkchain((char *)curdtp, datastack);
 
283
                  curdtp = $1; curdtelt = 0;
 
284
                  }
 
285
        | datavarlist SCOMMA datavar
 
286
                { $$ = hookup($1, $3); }
 
287
        ;
 
288
 
 
289
dims:
 
290
                { ndim = 0; }
 
291
        | SLPAR dimlist SRPAR
 
292
        ;
 
293
 
 
294
dimlist:   { ndim = 0; }   dim
 
295
        | dimlist SCOMMA dim
 
296
        ;
 
297
 
 
298
dim:      ubound
 
299
                {
 
300
                  if(ndim == maxdim)
 
301
                        err("too many dimensions");
 
302
                  else if(ndim < maxdim)
 
303
                        { dims[ndim].lb = 0;
 
304
                          dims[ndim].ub = $1;
 
305
                        }
 
306
                  ++ndim;
 
307
                }
 
308
        | expr SCOLON ubound
 
309
                {
 
310
                  if(ndim == maxdim)
 
311
                        err("too many dimensions");
 
312
                  else if(ndim < maxdim)
 
313
                        { dims[ndim].lb = $1;
 
314
                          dims[ndim].ub = $3;
 
315
                        }
 
316
                  ++ndim;
 
317
                }
 
318
        ;
 
319
 
 
320
ubound:   SSTAR
 
321
                { $$ = 0; }
 
322
        | expr
 
323
        ;
 
324
 
 
325
labellist: label
 
326
                { nstars = 1; labarray[0] = $1; }
 
327
        | labellist SCOMMA label
 
328
                { if(nstars < maxlablist)  labarray[nstars++] = $3; }
 
329
        ;
 
330
 
 
331
label:    SICON
 
332
                { $$ = execlab( convci(toklen, token) ); }
 
333
        ;
 
334
 
 
335
implicit:  SIMPLICIT in_dcl implist
 
336
                { NO66("IMPLICIT statement"); }
 
337
        | implicit SCOMMA implist
 
338
        ;
 
339
 
 
340
implist:  imptype SLPAR letgroups SRPAR
 
341
        | imptype
 
342
                { if (vartype != TYUNKNOWN)
 
343
                        dclerr("-- expected letter range",NPNULL);
 
344
                  setimpl(vartype, varleng, 'a', 'z'); }
 
345
        ;
 
346
 
 
347
imptype:   { needkwd = 1; } type
 
348
                /* { vartype = $2; } */
 
349
        ;
 
350
 
 
351
letgroups: letgroup
 
352
        | letgroups SCOMMA letgroup
 
353
        ;
 
354
 
 
355
letgroup:  letter
 
356
                { setimpl(vartype, varleng, $1, $1); }
 
357
        | letter SMINUS letter
 
358
                { setimpl(vartype, varleng, $1, $3); }
 
359
        ;
 
360
 
 
361
letter:  SNAME
 
362
                { if(toklen!=1 || token[0]<'a' || token[0]>'z')
 
363
                        {
 
364
                        dclerr("implicit item must be single letter", NPNULL);
 
365
                        $$ = 0;
 
366
                        }
 
367
                  else $$ = token[0];
 
368
                }
 
369
        ;
 
370
 
 
371
namelist:       SNAMELIST
 
372
        | namelist namelistentry
 
373
        ;
 
374
 
 
375
namelistentry:  SSLASH name SSLASH namelistlist
 
376
                {
 
377
                if($2->vclass == CLUNKNOWN)
 
378
                        {
 
379
                        $2->vclass = CLNAMELIST;
 
380
                        $2->vtype = TYINT;
 
381
                        $2->vstg = STGBSS;
 
382
                        $2->varxptr.namelist = $4;
 
383
                        $2->vardesc.varno = ++lastvarno;
 
384
                        }
 
385
                else dclerr("cannot be a namelist name", $2);
 
386
                }
 
387
        ;
 
388
 
 
389
namelistlist:  name
 
390
                { $$ = mkchain((char *)$1, CHNULL); }
 
391
        | namelistlist SCOMMA name
 
392
                { $$ = hookup($1, mkchain((char *)$3, CHNULL)); }
 
393
        ;
 
394
 
 
395
in_dcl:
 
396
                { switch(parstate)
 
397
                        {
 
398
                        case OUTSIDE:   newproc();
 
399
                                        startproc(ESNULL, CLMAIN);
 
400
                        case INSIDE:    parstate = INDCL;
 
401
                        case INDCL:     break;
 
402
 
 
403
                        case INDATA:
 
404
                                if (datagripe) {
 
405
                                        errstr(
 
406
                                "Statement order error: declaration after DATA",
 
407
                                                CNULL);
 
408
                                        datagripe = 0;
 
409
                                        }
 
410
                                break;
 
411
 
 
412
                        default:
 
413
                                dclerr("declaration among executables", NPNULL);
 
414
                        }
 
415
                }
 
416
        ;