![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to gram.head CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / f2c|
Return to gram.head CVS log | Up to [Research Unix] / researchv10no / cmd / f2c |
1.1 root 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: ;
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.