1/*-
2 * Copyright (c) 1980 The Regents of the University of California.
3 * All rights reserved.
4 *
5 * %sccs.include.proprietary.c%
6 *
7 *	@(#)gram.head	5.2 (Berkeley) 04/12/91
8 */
9
10/*
11 * gram.head
12 *
13 * First part of the f77 grammar, f77 compiler pass 1.
14 *
15 * University of Utah CS Dept modification history:
16 *
17 * $Log:	gram.head,v $
18 * Revision 3.2  84/11/06  17:40:52  donn
19 * Fixed bug with redundant labels causing errors when they appear on (e.g.)
20 * PROGRAM statements.
21 *
22 * Revision 3.1  84/10/13  00:22:16  donn
23 * Merged Jerry Berkman's version into mine.
24 *
25 * Revision 2.2  84/08/04  21:13:02  donn
26 * Moved some code out of gram.head into gram.exec in accordance with
27 * Jerry Berkman's fixes to make ASSIGNs work right.
28 *
29 * Revision 2.1  84/07/19  12:03:20  donn
30 * Changed comment headers for UofU.
31 *
32 * Revision 1.2  84/03/23  22:43:06  donn
33 * The subroutine argument temporary fixes from Bob Corbett didn't take into
34 * account the fact that the code generator collects all the assignments to
35 * temporaries at the start of a statement -- hence the temporaries need to
36 * be initialized once per statement instead of once per call.
37 *
38 */
39
40%{
41#	include "defs.h"
42#	include "data.h"
43
44#ifdef SDB
45#	include <a.out.h>
46
47#	ifndef N_SO
48#		include <stab.h>
49#	endif
50#endif
51
52static int equivlisterr;
53static int do_name_err;
54static int nstars;
55static int ndim;
56static int vartype;
57static ftnint varleng;
58static struct { expptr lb, ub; } dims[MAXDIM+1];
59static struct Labelblock *labarray[MAXLABLIST];
60static int lastwasbranch = NO;
61static int thiswasbranch = NO;
62extern ftnint yystno;
63extern flag intonly;
64
65ftnint convci();
66double convcd();
67expptr mklogcon(), mkaddcon(), mkrealcon(), mkstrcon(), mkbitcon();
68expptr mkcxcon();
69struct Listblock *mklist();
70struct Listblock *mklist();
71struct Impldoblock *mkiodo();
72struct Extsym *comblock();
73
74%}
75
76/* Specify precedences and associativities. */
77
78%union	{
79	int ival;
80	char *charpval;
81	chainp chval;
82	tagptr tagval;
83	expptr expval;
84	struct Labelblock *labval;
85	struct Nameblock *namval;
86	struct Eqvchain *eqvval;
87	struct Extsym *extval;
88	union  Vexpr *vexpval;
89	struct ValList *drvals;
90	struct Vlist *dvals;
91	union  Delt *deltp;
92	struct Rpair *rpairp;
93	struct Elist *elistp;
94	}
95
96%left SCOMMA
97%nonassoc SCOLON
98%right SEQUALS
99%left SEQV SNEQV
100%left SOR
101%left SAND
102%left SNOT
103%nonassoc SLT SGT SLE SGE SEQ SNE
104%left SCONCAT
105%left SPLUS SMINUS
106%left SSTAR SSLASH
107%right SPOWER
108
109%start program
110%type <labval> thislabel label assignlabel
111%type <tagval> other inelt
112%type <ival> lengspec type typespec typename dcl letter addop relop stop nameeq
113%type <charpval> filename
114%type <chval> namelistlist funarglist funargs dospec
115%type <chval> callarglist arglist args exprlist inlist outlist out2 substring
116%type <namval> name arg call var entryname progname
117%type <expval> lhs expr uexpr opt_expr fexpr unpar_fexpr
118%type <expval> ubound callarg complex_const simple_const
119%type <extval> common comblock
120%type <eqvval> equivlist
121%type <expval> datavalue real_const unsignedreal bit_const
122%type <vexpval> unsignedint int_const
123%type <vexpval> dataname
124%type <vexpval> iconprimary iconfactor iconterm iconexpr opticonexpr
125%type <drvals>	datarval datarvals
126%type <dvals>	iconexprlist datasubs
127%type <deltp>	dataelt dataimplieddo datalval
128%type <rpairp>	datarange
129%type <elistp>	dlist datalvals
130
131%%
132
133program:
134	| program stat SEOS
135	;
136
137stat:	  thislabel  entry
138		{ lastwasbranch = NO; }
139	| thislabel  spec
140	| thislabel  exec
141		{ if($1 && ($1->labelno==dorange))
142			enddo($1->labelno);
143		  if(lastwasbranch && thislabel==NULL)
144			warn("statement cannot be reached");
145		  lastwasbranch = thiswasbranch;
146		  thiswasbranch = NO;
147		  if($1)
148			{
149			if($1->labtype == LABFORMAT)
150				err("label already that of a format");
151			else
152				$1->labtype = LABEXEC;
153			}
154		  if(!optimflag)
155			{
156			argtemplist = hookup(argtemplist, activearglist);
157			activearglist = CHNULL;
158			}
159		}
160	| thislabel SINCLUDE filename
161		{ doinclude( $3 ); }
162	| thislabel  SEND  end_spec
163		{ lastwasbranch = NO;  endproc(); }
164	| thislabel SUNKNOWN
165		{ execerr("unclassifiable statement", CNULL);  flline(); };
166	| error
167		{ flline();  needkwd = NO;  inioctl = NO;
168		  yyerrok; yyclearin; }
169	;
170
171thislabel:  SLABEL
172		{
173#ifdef SDB
174		if( sdbflag )
175			{
176			linenostab(lineno);
177			}
178#endif
179
180		if(yystno != 0)
181			{
182			$$ = thislabel =  mklabel(yystno);
183			if(thislabel->labdefined)
184				execerr("label %s already defined",
185					convic(thislabel->stateno) );
186			else	{
187				if(thislabel->blklevel!=0 && thislabel->blklevel<blklevel
188				    && thislabel->labtype!=LABFORMAT)
189					warn1("there is a branch to label %s from outside block",
190					      convic( (ftnint) (thislabel->stateno) ) );
191				thislabel->blklevel = blklevel;
192				thislabel->labdefined = YES;
193				}
194			}
195		else    $$ = thislabel = NULL;
196		}
197	;
198
199entry:	  SPROGRAM new_proc progname
200		   {startproc($3, CLMAIN); }
201	| SBLOCK new_proc progname
202		{ if($3) NO66("named BLOCKDATA");
203		  startproc($3, CLBLOCK); }
204	| SSUBROUTINE new_proc entryname arglist
205		{ entrypt(CLPROC, TYSUBR, (ftnint) 0,  $3, $4); }
206	| SFUNCTION new_proc entryname arglist
207		{ entrypt(CLPROC, TYUNKNOWN, (ftnint) 0, $3, $4); }
208	| type SFUNCTION new_proc entryname arglist
209		{ entrypt(CLPROC, $1, varleng, $4, $5); }
210	| SENTRY entryname arglist
211		{ if(parstate==OUTSIDE || procclass==CLMAIN
212			|| procclass==CLBLOCK)
213				execerr("misplaced entry statement", CNULL);
214			entrypt(CLENTRY, 0, (ftnint) 0, $2, $3);
215		}
216	;
217
218new_proc:
219		{ newproc(); }
220	;
221
222entryname:  name
223	;
224
225name:	  SNAME
226		{ $$ = mkname(toklen, token); }
227	;
228
229progname:		{ $$ = NULL; }
230	| entryname
231	;
232
233arglist:
234		{ $$ = 0; }
235	| SLPAR SRPAR
236		{ NO66(" () argument list");
237		  $$ = 0; }
238	| SLPAR args SRPAR
239		{$$ = $2; }
240	;
241
242args:	  arg
243		{ $$ = ($1 ? mkchain($1,CHNULL) : CHNULL ); }
244	| args SCOMMA arg
245		{ if($3) $1 = $$ = hookup($1, mkchain($3,CHNULL)); }
246	;
247
248arg:	  name
249		{ if(($1->vstg!=STGUNKNOWN && $1->vstg!=STGARG)
250				|| ($1->vclass == CLPARAM) ) {
251			dclerr("name declared as argument after use", $1);
252			$$ = NULL;
253		  } else
254			$1->vstg = STGARG;
255		}
256	| SSTAR
257		{ NO66("altenate return argument");
258		  $$ = 0;  substars = YES; }
259	;
260
261
262
263filename:   SHOLLERITH
264		{
265		char *s;
266		s = copyn(toklen+1, token);
267		s[toklen] = '\0';
268		$$ = s;
269		}
270	;
271