Commit | Line | Data |
---|---|---|
0d57d6f5 TL |
1 | %{ |
2 | #include "defs" | |
3 | ||
4 | static int nstars; | |
5 | static int ndim; | |
6 | static int vartype; | |
7 | static ftnint varleng; | |
8 | static struct { ptr lb, ub; } dims[8]; | |
9 | static struct labelblock *labarray[100]; | |
10 | static int lastwasbranch = NO; | |
11 | static int thiswasbranch = NO; | |
12 | ftnint convci(); | |
13 | double convcd(); | |
14 | struct addrblock *nextdata(), *mkbitcon(); | |
15 | struct constblock *mklogcon(), *mkaddcon(), *mkrealcon(); | |
16 | struct constblock *mkstrcon(), *mkcxcon(); | |
17 | struct listblock *mklist(); | |
18 | struct listblock *mklist(); | |
19 | struct impldoblock *mkiodo(); | |
20 | struct extsym *comblock(); | |
21 | ||
22 | %} | |
23 | ||
24 | /* Specify precedences and associativies. */ | |
25 | ||
26 | %left SCOMMA | |
27 | %nonassoc SCOLON | |
28 | %right SEQUALS | |
29 | %left SEQV SNEQV | |
30 | %left SOR | |
31 | %left SAND | |
32 | %left SNOT | |
33 | %nonassoc SLT SGT SLE SGE SEQ SNE | |
34 | %left SCONCAT | |
35 | %left SPLUS SMINUS | |
36 | %left SSTAR SSLASH | |
37 | %right SPOWER | |
38 | ||
39 | %% | |
40 | ||
41 | program: | |
42 | | program stat SEOS | |
43 | ; | |
44 | ||
45 | stat: thislabel entry | |
46 | { lastwasbranch = NO; } | |
47 | | thislabel spec | |
48 | | thislabel exec | |
49 | { if($1 && ($1->labelno==dorange)) | |
50 | enddo($1->labelno); | |
51 | if(lastwasbranch && thislabel==NULL) | |
52 | warn1("statement cannot be reached"); | |
53 | lastwasbranch = thiswasbranch; | |
54 | thiswasbranch = NO; | |
55 | } | |
56 | | thislabel SINCLUDE filename | |
57 | { doinclude( $3 ); } | |
58 | | thislabel SEND end_spec | |
59 | { lastwasbranch = NO; endproc(); } | |
60 | | thislabel SUNKNOWN | |
61 | { execerr("unclassifiable statement", 0); flline(); }; | |
62 | | error | |
63 | { flline(); needkwd = NO; inioctl = NO; | |
64 | yyerrok; yyclearin; } | |
65 | ; | |
66 | ||
67 | thislabel: SLABEL | |
68 | { | |
69 | if($1) | |
70 | { | |
71 | $$ = thislabel = mklabel( (ftnint) $1); | |
72 | if( ! headerdone ) | |
73 | puthead(); | |
74 | if(thislabel->labdefined) | |
75 | execerr("label %s already defined", | |
76 | convic(thislabel->stateno) ); | |
77 | else { | |
78 | if(thislabel->blklevel!=0 && thislabel->blklevel<blklevel | |
79 | && thislabel->labtype!=LABFORMAT) | |
80 | warn1("there is a branch to label %s from outside block", | |
81 | convic( (ftnint) (thislabel->stateno) ) ); | |
82 | thislabel->blklevel = blklevel; | |
83 | thislabel->labdefined = YES; | |
84 | if(thislabel->labtype != LABFORMAT) | |
85 | putlabel(thislabel->labelno); | |
86 | } | |
87 | } | |
88 | else $$ = thislabel = NULL; | |
89 | } | |
90 | ; | |
91 | ||
92 | entry: SPROGRAM new_proc progname | |
93 | { startproc($3, CLMAIN); } | |
94 | | SBLOCK new_proc progname | |
95 | { startproc($3, CLBLOCK); } | |
96 | | SSUBROUTINE new_proc entryname arglist | |
97 | { entrypt(CLPROC, TYSUBR, (ftnint) 0, $3, $4); } | |
98 | | SFUNCTION new_proc entryname arglist | |
99 | { entrypt(CLPROC, TYUNKNOWN, (ftnint) 0, $3, $4); } | |
100 | | type SFUNCTION new_proc entryname arglist | |
101 | { entrypt(CLPROC, $1, varleng, $4, $5); } | |
102 | | SENTRY entryname arglist | |
103 | { if(parstate==OUTSIDE || procclass==CLMAIN | |
104 | || procclass==CLBLOCK) | |
105 | execerr("misplaced entry statement", 0); | |
106 | entrypt(CLENTRY, 0, (ftnint) 0, $2, $3); | |
107 | } | |
108 | ; | |
109 | ||
110 | new_proc: | |
111 | { newproc(); } | |
112 | ; | |
113 | ||
114 | entryname: name | |
115 | { $$ = newentry($1); } | |
116 | ; | |
117 | ||
118 | name: SNAME | |
119 | { $$ = mkname(toklen, token); } | |
120 | ; | |
121 | ||
122 | progname: { $$ = NULL; } | |
123 | | entryname | |
124 | ; | |
125 | ||
126 | arglist: | |
127 | { $$ = 0; } | |
128 | | SLPAR SRPAR | |
129 | { $$ = 0; } | |
130 | | SLPAR args SRPAR | |
131 | {$$ = $2; } | |
132 | ; | |
133 | ||
134 | args: arg | |
135 | { $$ = ($1 ? mkchain($1,0) : 0 ); } | |
136 | | args SCOMMA arg | |
137 | { if($3) $1 = $$ = hookup($1, mkchain($3,0)); } | |
138 | ; | |
139 | ||
140 | arg: name | |
141 | { $1->vstg = STGARG; } | |
142 | | SSTAR | |
143 | { $$ = 0; substars = YES; } | |
144 | ; | |
145 | ||
146 | ||
147 | ||
148 | filename: SHOLLERITH | |
149 | { | |
150 | char *s; | |
151 | s = copyn(toklen+1, token); | |
152 | s[toklen] = '\0'; | |
153 | $$ = s; | |
154 | } | |
155 | ; |