← Back to branch summary

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

« back to all changes in this revision

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

  • 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.head
 
1
/****************************************************************
 
2
Copyright 1990, 1993 by AT&T Bell Laboratories, Bellcore.
 
3
 
 
4
Permission to use, copy, modify, and distribute this software
 
5
and its documentation for any purpose and without fee is hereby
 
6
granted, provided that the above copyright notice appear in all
 
7
copies and that both that the copyright notice and this
 
8
permission notice and warranty disclaimer appear in supporting
 
9
documentation, and that the names of AT&T Bell Laboratories or
 
10
Bellcore or any of their entities not be used in advertising or
 
11
publicity pertaining to distribution of the software without
 
12
specific, written prior permission.
 
13
 
 
14
AT&T and Bellcore disclaim all warranties with regard to this
 
15
software, including all implied warranties of merchantability
 
16
and fitness.  In no event shall AT&T or Bellcore be liable for
 
17
any special, indirect or consequential damages or any damages
 
18
whatsoever resulting from loss of use, data or profits, whether
 
19
in an action of contract, negligence or other tortious action,
 
20
arising out of or in connection with the use or performance of
 
21
this software.
 
22
****************************************************************/
 
23
 
 
24
%{
 
25
#include "defs.h"
 
26
#include "p1defs.h"
 
27
 
 
28
static int nstars;                      /* Number of labels in an
 
29
                                           alternate return CALL */
 
30
static int datagripe;
 
31
static int ndim;
 
32
static int vartype;
 
33
int new_dcl;
 
34
static ftnint varleng;
 
35
static struct Dims dims[MAXDIM+1];
 
36
extern struct Labelblock **labarray;    /* Labels in an alternate
 
37
                                                   return CALL */
 
38
extern int maxlablist;
 
39
 
 
40
/* The next two variables are used to verify that each statement might be reached
 
41
   during runtime.   lastwasbranch   is tested only in the defintion of the
 
42
   stat:   nonterminal. */
 
43
 
 
44
int lastwasbranch = NO;
 
45
static int thiswasbranch = NO;
 
46
extern ftnint yystno;
 
47
extern flag intonly;
 
48
static chainp datastack;
 
49
extern long laststfcn, thisstno;
 
50
extern int can_include; /* for netlib */
 
51
extern struct Primblock *primchk Argdcl((expptr));
 
52
 
 
53
#define ESNULL (Extsym *)0
 
54
#define NPNULL (Namep)0
 
55
#define LBNULL (struct Listblock *)0
 
56
 
 
57
 static void
 
58
pop_datastack(Void) {
 
59
        chainp d0 = datastack;
 
60
        if (d0->datap)
 
61
                curdtp = (chainp)d0->datap;
 
62
        datastack = d0->nextp;
 
63
        d0->nextp = 0;
 
64
        frchain(&d0);
 
65
        }
 
66
 
 
67
%}
 
68
 
 
69
/* Specify precedences and associativities. */
 
70
 
 
71
%union  {
 
72
        int ival;
 
73
        ftnint lval;
 
74
        char *charpval;
 
75
        chainp chval;
 
76
        tagptr tagval;
 
77
        expptr expval;
 
78
        struct Labelblock *labval;
 
79
        struct Nameblock *namval;
 
80
        struct Eqvchain *eqvval;
 
81
        Extsym *extval;
 
82
        }
 
83
 
 
84
%left SCOMMA
 
85
%nonassoc SCOLON
 
86
%right SEQUALS
 
87
%left SEQV SNEQV
 
88
%left SOR
 
89
%left SAND
 
90
%left SNOT
 
91
%nonassoc SLT SGT SLE SGE SEQ SNE
 
92
%left SCONCAT
 
93
%left SPLUS SMINUS
 
94
%left SSTAR SSLASH
 
95
%right SPOWER
 
96
 
 
97
%start program
 
98
%type <labval> thislabel label assignlabel
 
99
%type <tagval> other inelt
 
100
%type <ival> type typespec typename dcl letter addop relop stop nameeq
 
101
%type <lval> lengspec
 
102
%type <charpval> filename
 
103
%type <chval> datavar datavarlist namelistlist funarglist funargs
 
104
%type <chval> dospec dospecw
 
105
%type <chval> callarglist arglist args exprlist inlist outlist out2 substring
 
106
%type <namval> name arg call var
 
107
%type <expval> lhs expr uexpr opt_expr fexpr unpar_fexpr
 
108
%type <expval> ubound simple value callarg complex_const simple_const bit_const
 
109
%type <extval> common comblock entryname progname
 
110
%type <eqvval> equivlist
 
111
 
 
112
%%
 
113
 
 
114
program:
 
115
        | program stat SEOS
 
116
        ;
 
117
 
 
118
stat:     thislabel  entry
 
119
                {
 
120
/* stat:   is the nonterminal for Fortran statements */
 
121
 
 
122
                  lastwasbranch = NO; }
 
123
        | thislabel  spec
 
124
        | thislabel  exec
 
125
                { /* forbid further statement function definitions... */
 
126
                  if (parstate == INDATA && laststfcn != thisstno)
 
127
                        parstate = INEXEC;
 
128
                  thisstno++;
 
129
                  if($1 && ($1->labelno==dorange))
 
130
                        enddo($1->labelno);
 
131
                  if(lastwasbranch && thislabel==NULL)
 
132
                        warn("statement cannot be reached");
 
133
                  lastwasbranch = thiswasbranch;
 
134
                  thiswasbranch = NO;
 
135
                  if($1)
 
136
                        {
 
137
                        if($1->labtype == LABFORMAT)
 
138
                                err("label already that of a format");
 
139
                        else
 
140
                                $1->labtype = LABEXEC;
 
141
                        }
 
142
                  freetemps();
 
143
                }
 
144
        | thislabel SINCLUDE filename
 
145
                { if (can_include)
 
146
                        doinclude( $3 );
 
147
                  else {
 
148
                        fprintf(diagfile, "Cannot open file %s\n", $3);
 
149
                        done(1);
 
150
                        }
 
151
                }
 
152
        | thislabel  SEND  end_spec
 
153
                { if ($1)
 
154
                        lastwasbranch = NO;
 
155
                  endproc(); /* lastwasbranch = NO; -- set in endproc() */
 
156
                }
 
157
        | thislabel SUNKNOWN
 
158
                { unclassifiable();
 
159
 
 
160
/* flline flushes the current line, ignoring the rest of the text there */
 
161
 
 
162
                  flline(); }
 
163
        | error
 
164
                { flline();  needkwd = NO;  inioctl = NO;
 
165
                  yyerrok; yyclearin; }
 
166
        ;
 
167
 
 
168
thislabel:  SLABEL
 
169
                {
 
170
                if(yystno != 0)
 
171
                        {
 
172
                        $$ = thislabel =  mklabel(yystno);
 
173
                        if( ! headerdone ) {
 
174
                                if (procclass == CLUNKNOWN)
 
175
                                        procclass = CLMAIN;
 
176
                                puthead(CNULL, procclass);
 
177
                                }
 
178
                        if(thislabel->labdefined)
 
179
                                execerr("label %s already defined",
 
180
                                        convic(thislabel->stateno) );
 
181
                        else    {
 
182
                                if(thislabel->blklevel!=0 && thislabel->blklevel<blklevel
 
183
                                    && thislabel->labtype!=LABFORMAT)
 
184
                                        warn1("there is a branch to label %s from outside block",
 
185
                                              convic( (ftnint) (thislabel->stateno) ) );
 
186
                                thislabel->blklevel = blklevel;
 
187
                                thislabel->labdefined = YES;
 
188
                                if(thislabel->labtype != LABFORMAT)
 
189
                                        p1_label((long)(thislabel - labeltab));
 
190
                                }
 
191
                        }
 
192
                else    $$ = thislabel = NULL;
 
193
                }
 
194
        ;
 
195
 
 
196
entry:    SPROGRAM new_proc progname
 
197
                   {startproc($3, CLMAIN); }
 
198
        | SPROGRAM new_proc progname progarglist
 
199
                   {    warn("ignoring arguments to main program");
 
200
                        /* hashclear(); */
 
201
                        startproc($3, CLMAIN); }
 
202
        | SBLOCK new_proc progname
 
203
                { if($3) NO66("named BLOCKDATA");
 
204
                  startproc($3, CLBLOCK); }
 
205
        | SSUBROUTINE new_proc entryname arglist
 
206
                { entrypt(CLPROC, TYSUBR, (ftnint) 0,  $3, $4); }
 
207
        | SFUNCTION new_proc entryname arglist
 
208
                { entrypt(CLPROC, TYUNKNOWN, (ftnint) 0, $3, $4); }
 
209
        | type SFUNCTION new_proc entryname arglist
 
210
                { entrypt(CLPROC, $1, varleng, $4, $5); }
 
211
        | SENTRY entryname arglist
 
212
                 { if(parstate==OUTSIDE || procclass==CLMAIN
 
213
                        || procclass==CLBLOCK)
 
214
                                execerr("misplaced entry statement", CNULL);
 
215
                  entrypt(CLENTRY, 0, (ftnint) 0, $2, $3);
 
216
                }
 
217
        ;
 
218
 
 
219
new_proc:
 
220
                { newproc(); }
 
221
        ;
 
222
 
 
223
entryname:  name
 
224
                { $$ = newentry($1, 1); }
 
225
        ;
 
226
 
 
227
name:     SNAME
 
228
                { $$ = mkname(token); }
 
229
        ;
 
230
 
 
231
progname:               { $$ = NULL; }
 
232
        | entryname
 
233
        ;
 
234
 
 
235
progarglist:
 
236
          SLPAR SRPAR
 
237
        | SLPAR progargs SRPAR
 
238
        ;
 
239
 
 
240
progargs: progarg
 
241
        | progargs SCOMMA progarg
 
242
        ;
 
243
 
 
244
progarg:  SNAME
 
245
        | SNAME SEQUALS SNAME
 
246
        ;
 
247
 
 
248
arglist:
 
249
                { $$ = 0; }
 
250
        | SLPAR SRPAR
 
251
                { NO66(" () argument list");
 
252
                  $$ = 0; }
 
253
        | SLPAR args SRPAR
 
254
                {$$ = $2; }
 
255
        ;
 
256
 
 
257
args:     arg
 
258
                { $$ = ($1 ? mkchain((char *)$1,CHNULL) : CHNULL ); }
 
259
        | args SCOMMA arg
 
260
                { if($3) $1 = $$ = mkchain((char *)$3, $1); }
 
261
        ;
 
262
 
 
263
arg:      name
 
264
                { if($1->vstg!=STGUNKNOWN && $1->vstg!=STGARG)
 
265
                        dclerr("name declared as argument after use", $1);
 
266
                  $1->vstg = STGARG;
 
267
                }
 
268
        | SSTAR
 
269
                { NO66("altenate return argument");
 
270
 
 
271
/* substars   means that '*'ed formal parameters should be replaced.
 
272
   This is used to specify alternate return labels; in theory, only
 
273
   parameter slots which have '*' should accept the statement labels.
 
274
   This compiler chooses to ignore the '*'s in the formal declaration, and
 
275
   always return the proper value anyway.
 
276
 
 
277
   This variable is only referred to in   proc.c   */
 
278
 
 
279
                  $$ = 0;  substars = YES; }
 
280
        ;
 
281
 
 
282
 
 
283
 
 
284
filename:   SHOLLERITH
 
285
                {
 
286
                char *s;
 
287
                s = copyn(toklen+1, token);
 
288
                s[toklen] = '\0';
 
289
                $$ = s;
 
290
                }
 
291
        ;