1 /****************************************************************
2 Copyright 1990 by AT&T Bell Laboratories, Bellcore.
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.
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
22 ****************************************************************/
28 static int nstars; /* Number of labels in an
29 alternate return CALL */
33 static ftnint varleng;
34 static struct { expptr lb, ub; } dims[MAXDIM+1];
35 static struct Labelblock *labarray[MAXLABLIST]; /* Labels in an alternate
38 /* The next two variables are used to verify that each statement might be reached
39 during runtime. lastwasbranch is tested only in the defintion of the
42 int lastwasbranch = NO;
43 static int thiswasbranch = NO;
46 static chainp datastack;
47 extern long laststfcn, thisstno;
48 extern int can_include; /* for netlib */
52 expptr mklogcon(), mkaddcon(), mkrealcon(), mkstrcon(), mkbitcon();
54 struct Listblock *mklist();
55 struct Listblock *mklist();
56 struct Impldoblock *mkiodo();
58 #define ESNULL (Extsym *)0
59 #define NPNULL (Namep)0
60 #define LBNULL (struct Listblock *)0
61 extern void freetemps(), make_param();
65 chainp d0 = datastack;
67 curdtp = (chainp)d0->datap;
68 datastack = d0->nextp;
75 /* Specify precedences and associativities. */
84 struct Labelblock *labval;
85 struct Nameblock *namval;
86 struct Eqvchain *eqvval;
97 %nonassoc SLT SGT SLE SGE SEQ SNE
104 %type <labval> thislabel label assignlabel
105 %type <tagval> other inelt
106 %type <ival> type typespec typename dcl letter addop relop stop nameeq
107 %type <lval> lengspec
108 %type <charpval> filename
109 %type <chval> datavar datavarlist namelistlist funarglist funargs
110 %type <chval> dospec dospecw
111 %type <chval> callarglist arglist args exprlist inlist outlist out2 substring
112 %type <namval> name arg call var
113 %type <expval> lhs expr uexpr opt_expr fexpr unpar_fexpr
114 %type <expval> ubound simple value callarg complex_const simple_const bit_const
115 %type <extval> common comblock entryname progname
116 %type <eqvval> equivlist
124 stat: thislabel entry
126 /* stat: is the nonterminal for Fortran statements */
128 lastwasbranch = NO; }
131 { /* forbid further statement function definitions... */
132 if (parstate == INDATA && laststfcn != thisstno)
135 if($1 && ($1->labelno==dorange))
137 if(lastwasbranch && thislabel==NULL)
138 warn("statement cannot be reached");
139 lastwasbranch = thiswasbranch;
143 if($1->labtype == LABFORMAT)
144 err("label already that of a format");
146 $1->labtype = LABEXEC;
150 | thislabel SINCLUDE filename
154 fprintf(diagfile, "Cannot open file %s\n", $3);
158 | thislabel SEND end_spec
161 endproc(); /* lastwasbranch = NO; -- set in endproc() */
164 { extern void unclassifiable();
167 /* flline flushes the current line, ignoring the rest of the text there */
171 { flline(); needkwd = NO; inioctl = NO;
172 yyerrok; yyclearin; }
179 $$ = thislabel = mklabel(yystno);
181 if (procclass == CLUNKNOWN)
183 puthead(CNULL, procclass);
185 if(thislabel->labdefined)
186 execerr("label %s already defined",
187 convic(thislabel->stateno) );
189 if(thislabel->blklevel!=0 && thislabel->blklevel<blklevel
190 && thislabel->labtype!=LABFORMAT)
191 warn1("there is a branch to label %s from outside block",
192 convic( (ftnint) (thislabel->stateno) ) );
193 thislabel->blklevel = blklevel;
194 thislabel->labdefined = YES;
195 if(thislabel->labtype != LABFORMAT)
196 p1_label((long)(thislabel - labeltab));
199 else $$ = thislabel = NULL;
203 entry: SPROGRAM new_proc progname
204 {startproc($3, CLMAIN); }
205 | SPROGRAM new_proc progname progarglist
206 { warn("ignoring arguments to main program");
208 startproc($3, CLMAIN); }
209 | SBLOCK new_proc progname
210 { if($3) NO66("named BLOCKDATA");
211 startproc($3, CLBLOCK); }
212 | SSUBROUTINE new_proc entryname arglist
213 { entrypt(CLPROC, TYSUBR, (ftnint) 0, $3, $4); }
214 | SFUNCTION new_proc entryname arglist
215 { entrypt(CLPROC, TYUNKNOWN, (ftnint) 0, $3, $4); }
216 | type SFUNCTION new_proc entryname arglist
217 { entrypt(CLPROC, $1, varleng, $4, $5); }
218 | SENTRY entryname arglist
219 { if(parstate==OUTSIDE || procclass==CLMAIN
220 || procclass==CLBLOCK)
221 execerr("misplaced entry statement", CNULL);
222 entrypt(CLENTRY, 0, (ftnint) 0, $2, $3);
231 { $$ = newentry($1, 1); }
235 { $$ = mkname(token); }
238 progname: { $$ = NULL; }
244 | SLPAR progargs SRPAR
248 | progargs SCOMMA progarg
252 | SNAME SEQUALS SNAME
258 { NO66(" () argument list");
265 { $$ = ($1 ? mkchain((char *)$1,CHNULL) : CHNULL ); }
267 { if($3) $1 = $$ = mkchain((char *)$3, $1); }
271 { if($1->vstg!=STGUNKNOWN && $1->vstg!=STGARG)
272 dclerr("name declared as argument after use", $1);
276 { NO66("altenate return argument");
278 /* substars means that '*'ed formal parameters should be replaced.
279 This is used to specify alternate return labels; in theory, only
280 parameter slots which have '*' should accept the statement labels.
281 This compiler chooses to ignore the '*'s in the formal declaration, and
282 always return the proper value anyway.
284 This variable is only referred to in proc.c */
286 $$ = 0; substars = YES; }
294 s = copyn(toklen+1, token);