Commit | Line | Data |
---|---|---|
f1525c23 WH |
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 | ||
52 | ftnint convci(); | |
53 | Addrp nextdata(); | |
54 | expptr mklogcon(), mkaddcon(), mkrealcon(), mkstrcon(), mkbitcon(); | |
55 | expptr mkcxcon(); | |
56 | struct Listblock *mklist(); | |
57 | struct Listblock *mklist(); | |
58 | struct Impldoblock *mkiodo(); | |
59 | Extsym *comblock(); | |
60 | #define ESNULL (Extsym *)0 | |
61 | #define NPNULL (Namep)0 | |
62 | #define LBNULL (struct Listblock *)0 | |
63 | extern void freetemps(), make_param(); | |
64 | ||
65 | static void | |
66 | pop_datastack() { | |
67 | chainp d0 = datastack; | |
68 | if (d0->datap) | |
69 | curdtp = (chainp)d0->datap; | |
70 | datastack = d0->nextp; | |
71 | d0->nextp = 0; | |
72 | frchain(&d0); | |
73 | } | |
74 | ||
75 | %} | |
76 | ||
77 | /* Specify precedences and associativities. */ | |
78 | ||
79 | %union { | |
80 | int ival; | |
81 | ftnint lval; | |
82 | char *charpval; | |
83 | chainp chval; | |
84 | tagptr tagval; | |
85 | expptr expval; | |
86 | struct Labelblock *labval; | |
87 | struct Nameblock *namval; | |
88 | struct Eqvchain *eqvval; | |
89 | Extsym *extval; | |
90 | } | |
91 | ||
92 | %left SCOMMA | |
93 | %nonassoc SCOLON | |
94 | %right SEQUALS | |
95 | %left SEQV SNEQV | |
96 | %left SOR | |
97 | %left SAND | |
98 | %left SNOT | |
99 | %nonassoc SLT SGT SLE SGE SEQ SNE | |
100 | %left SCONCAT | |
101 | %left SPLUS SMINUS | |
102 | %left SSTAR SSLASH | |
103 | %right SPOWER | |
104 | ||
105 | %start program | |
106 | %type <labval> thislabel label assignlabel | |
107 | %type <tagval> other inelt | |
108 | %type <ival> type typespec typename dcl letter addop relop stop nameeq | |
109 | %type <lval> lengspec | |
110 | %type <charpval> filename | |
111 | %type <chval> datavar datavarlist namelistlist funarglist funargs | |
112 | %type <chval> dospec dospecw | |
113 | %type <chval> callarglist arglist args exprlist inlist outlist out2 substring | |
114 | %type <namval> name arg call var | |
115 | %type <expval> lhs expr uexpr opt_expr fexpr unpar_fexpr | |
116 | %type <expval> ubound simple value callarg complex_const simple_const bit_const | |
117 | %type <extval> common comblock entryname progname | |
118 | %type <eqvval> equivlist | |
119 | ||
120 | %% | |
121 | ||
122 | program: | |
123 | | program stat SEOS | |
124 | ; | |
125 | ||
126 | stat: thislabel entry | |
127 | { | |
128 | /* stat: is the nonterminal for Fortran statements */ | |
129 | ||
130 | lastwasbranch = NO; } | |
131 | | thislabel spec | |
132 | | thislabel exec | |
133 | { /* forbid further statement function definitions... */ | |
134 | if (parstate == INDATA && laststfcn != thisstno) | |
135 | parstate = INEXEC; | |
136 | thisstno++; | |
137 | if($1 && ($1->labelno==dorange)) | |
138 | enddo($1->labelno); | |
139 | if(lastwasbranch && thislabel==NULL) | |
140 | warn("statement cannot be reached"); | |
141 | lastwasbranch = thiswasbranch; | |
142 | thiswasbranch = NO; | |
143 | if($1) | |
144 | { | |
145 | if($1->labtype == LABFORMAT) | |
146 | err("label already that of a format"); | |
147 | else | |
148 | $1->labtype = LABEXEC; | |
149 | } | |
150 | freetemps(); | |
151 | } | |
152 | | thislabel SINCLUDE filename | |
153 | { if (can_include) | |
154 | doinclude( $3 ); | |
155 | else { | |
156 | fprintf(diagfile, "Cannot open file %s\n", $3); | |
157 | done(1); | |
158 | } | |
159 | } | |
160 | | thislabel SEND end_spec | |
161 | { if ($1) | |
162 | lastwasbranch = NO; | |
163 | endproc(); /* lastwasbranch = NO; -- set in endproc() */ | |
164 | } | |
165 | | thislabel SUNKNOWN | |
166 | { extern void unclassifiable(); | |
167 | unclassifiable(); | |
168 | ||
169 | /* flline flushes the current line, ignoring the rest of the text there */ | |
170 | ||
171 | flline(); } | |
172 | | error | |
173 | { flline(); needkwd = NO; inioctl = NO; | |
174 | yyerrok; yyclearin; } | |
175 | ; | |
176 | ||
177 | thislabel: SLABEL | |
178 | { | |
179 | if(yystno != 0) | |
180 | { | |
181 | $$ = thislabel = mklabel(yystno); | |
182 | if( ! headerdone ) { | |
183 | if (procclass == CLUNKNOWN) | |
184 | procclass = CLMAIN; | |
185 | puthead(CNULL, procclass); | |
186 | } | |
187 | if(thislabel->labdefined) | |
188 | execerr("label %s already defined", | |
189 | convic(thislabel->stateno) ); | |
190 | else { | |
191 | if(thislabel->blklevel!=0 && thislabel->blklevel<blklevel | |
192 | && thislabel->labtype!=LABFORMAT) | |
193 | warn1("there is a branch to label %s from outside block", | |
194 | convic( (ftnint) (thislabel->stateno) ) ); | |
195 | thislabel->blklevel = blklevel; | |
196 | thislabel->labdefined = YES; | |
197 | if(thislabel->labtype != LABFORMAT) | |
198 | p1_label((long)(thislabel - labeltab)); | |
199 | } | |
200 | } | |
201 | else $$ = thislabel = NULL; | |
202 | } | |
203 | ; | |
204 | ||
205 | entry: SPROGRAM new_proc progname | |
206 | {startproc($3, CLMAIN); } | |
207 | | SPROGRAM new_proc progname progarglist | |
208 | { warn("ignoring arguments to main program"); | |
209 | /* hashclear(); */ | |
210 | startproc($3, CLMAIN); } | |
211 | | SBLOCK new_proc progname | |
212 | { if($3) NO66("named BLOCKDATA"); | |
213 | startproc($3, CLBLOCK); } | |
214 | | SSUBROUTINE new_proc entryname arglist | |
215 | { entrypt(CLPROC, TYSUBR, (ftnint) 0, $3, $4); } | |
216 | | SFUNCTION new_proc entryname arglist | |
217 | { entrypt(CLPROC, TYUNKNOWN, (ftnint) 0, $3, $4); } | |
218 | | type SFUNCTION new_proc entryname arglist | |
219 | { entrypt(CLPROC, $1, varleng, $4, $5); } | |
220 | | SENTRY entryname arglist | |
221 | { if(parstate==OUTSIDE || procclass==CLMAIN | |
222 | || procclass==CLBLOCK) | |
223 | execerr("misplaced entry statement", CNULL); | |
224 | entrypt(CLENTRY, 0, (ftnint) 0, $2, $3); | |
225 | } | |
226 | ; | |
227 | ||
228 | new_proc: | |
229 | { newproc(); } | |
230 | ; | |
231 | ||
232 | entryname: name | |
233 | { $$ = newentry($1, 1); } | |
234 | ; | |
235 | ||
236 | name: SNAME | |
237 | { $$ = mkname(token); } | |
238 | ; | |
239 | ||
240 | progname: { $$ = NULL; } | |
241 | | entryname | |
242 | ; | |
243 | ||
244 | progarglist: | |
245 | SLPAR SRPAR | |
246 | | SLPAR progargs SRPAR | |
247 | ; | |
248 | ||
249 | progargs: progarg | |
250 | | progargs SCOMMA progarg | |
251 | ; | |
252 | ||
253 | progarg: SNAME | |
254 | | SNAME SEQUALS SNAME | |
255 | ; | |
256 | ||
257 | arglist: | |
258 | { $$ = 0; } | |
259 | | SLPAR SRPAR | |
260 | { NO66(" () argument list"); | |
261 | $$ = 0; } | |
262 | | SLPAR args SRPAR | |
263 | {$$ = $2; } | |
264 | ; | |
265 | ||
266 | args: arg | |
267 | { $$ = ($1 ? mkchain((char *)$1,CHNULL) : CHNULL ); } | |
268 | | args SCOMMA arg | |
269 | { if($3) $1 = $$ = mkchain((char *)$3, $1); } | |
270 | ; | |
271 | ||
272 | arg: name | |
273 | { if($1->vstg!=STGUNKNOWN && $1->vstg!=STGARG) | |
274 | dclerr("name declared as argument after use", $1); | |
275 | $1->vstg = STGARG; | |
276 | } | |
277 | | SSTAR | |
278 | { NO66("altenate return argument"); | |
279 | ||
280 | /* substars means that '*'ed formal parameters should be replaced. | |
281 | This is used to specify alternate return labels; in theory, only | |
282 | parameter slots which have '*' should accept the statement labels. | |
283 | This compiler chooses to ignore the '*'s in the formal declaration, and | |
284 | always return the proper value anyway. | |
285 | ||
286 | This variable is only referred to in proc.c */ | |
287 | ||
288 | $$ = 0; substars = YES; } | |
289 | ; | |
290 | ||
291 | ||
292 | ||
293 | filename: SHOLLERITH | |
294 | { | |
295 | char *s; | |
296 | s = copyn(toklen+1, token); | |
297 | s[toklen] = '\0'; | |
298 | $$ = s; | |
299 | } | |
300 | ; |