| 1 | %{ |
| 2 | # include "defs" |
| 3 | |
| 4 | #ifdef SDB |
| 5 | # include <a.out.h> |
| 6 | char *stabline(); |
| 7 | # ifdef UCBVAXASM |
| 8 | char *stabdline(); |
| 9 | # endif |
| 10 | |
| 11 | # ifndef N_SO |
| 12 | # include <stab.h> |
| 13 | # endif |
| 14 | #endif |
| 15 | |
| 16 | static int nstars; |
| 17 | static int ndim; |
| 18 | static int vartype; |
| 19 | static ftnint varleng; |
| 20 | static struct { expptr lb, ub; } dims[MAXDIM+1]; |
| 21 | static struct Labelblock *labarray[MAXLABLIST]; |
| 22 | static int lastwasbranch = NO; |
| 23 | static int thiswasbranch = NO; |
| 24 | extern ftnint yystno; |
| 25 | extern flag intonly; |
| 26 | |
| 27 | ftnint convci(); |
| 28 | double convcd(); |
| 29 | Addrp nextdata(); |
| 30 | expptr mklogcon(), mkaddcon(), mkrealcon(), mkstrcon(), mkbitcon(); |
| 31 | expptr mkcxcon(); |
| 32 | struct Listblock *mklist(); |
| 33 | struct Listblock *mklist(); |
| 34 | struct Impldoblock *mkiodo(); |
| 35 | struct Extsym *comblock(); |
| 36 | |
| 37 | %} |
| 38 | |
| 39 | /* Specify precedences and associativities. */ |
| 40 | |
| 41 | %union { |
| 42 | int ival; |
| 43 | char *charpval; |
| 44 | chainp chval; |
| 45 | tagptr tagval; |
| 46 | expptr expval; |
| 47 | struct Labelblock *labval; |
| 48 | struct Nameblock *namval; |
| 49 | struct Eqvchain *eqvval; |
| 50 | struct Extsym *extval; |
| 51 | } |
| 52 | |
| 53 | %left SCOMMA |
| 54 | %nonassoc SCOLON |
| 55 | %right SEQUALS |
| 56 | %left SEQV SNEQV |
| 57 | %left SOR |
| 58 | %left SAND |
| 59 | %left SNOT |
| 60 | %nonassoc SLT SGT SLE SGE SEQ SNE |
| 61 | %left SCONCAT |
| 62 | %left SPLUS SMINUS |
| 63 | %left SSTAR SSLASH |
| 64 | %right SPOWER |
| 65 | |
| 66 | %start program |
| 67 | %type <labval> thislabel label assignlabel |
| 68 | %type <tagval> other inelt |
| 69 | %type <ival> lengspec type typespec typename dcl letter addop relop stop nameeq |
| 70 | %type <charpval> filename |
| 71 | %type <chval> datavar datavarlist namelistlist funarglist funargs dospec |
| 72 | %type <chval> callarglist arglist args exprlist inlist outlist out2 substring |
| 73 | %type <namval> name arg call var |
| 74 | %type <expval> lhs expr uexpr opt_expr fexpr unpar_fexpr |
| 75 | %type <expval> ubound simple value callarg complex_const simple_const bit_const |
| 76 | %type <extval> common comblock entryname progname |
| 77 | %type <eqvval> equivlist |
| 78 | |
| 79 | %% |
| 80 | |
| 81 | program: |
| 82 | | program stat SEOS |
| 83 | ; |
| 84 | |
| 85 | stat: thislabel entry |
| 86 | { lastwasbranch = NO; } |
| 87 | | thislabel spec |
| 88 | | thislabel exec |
| 89 | { if($1 && ($1->labelno==dorange)) |
| 90 | enddo($1->labelno); |
| 91 | if(lastwasbranch && thislabel==NULL) |
| 92 | warn("statement cannot be reached"); |
| 93 | lastwasbranch = thiswasbranch; |
| 94 | thiswasbranch = NO; |
| 95 | if($1) |
| 96 | { |
| 97 | if($1->labtype == LABFORMAT) |
| 98 | err("label already that of a format"); |
| 99 | else |
| 100 | $1->labtype = LABEXEC; |
| 101 | } |
| 102 | } |
| 103 | | thislabel SINCLUDE filename |
| 104 | { doinclude( $3 ); } |
| 105 | | thislabel SEND end_spec |
| 106 | { lastwasbranch = NO; endproc(); } |
| 107 | | thislabel SUNKNOWN |
| 108 | { execerr("unclassifiable statement", CNULL); flline(); }; |
| 109 | | error |
| 110 | { flline(); needkwd = NO; inioctl = NO; |
| 111 | yyerrok; yyclearin; } |
| 112 | ; |
| 113 | |
| 114 | thislabel: SLABEL |
| 115 | { |
| 116 | #ifdef SDB |
| 117 | char buff[10]; |
| 118 | if( sdbflag ) |
| 119 | { |
| 120 | # ifdef UCBVAXASM |
| 121 | p2pass( stabdline(N_SLINE, lineno) ); |
| 122 | # else |
| 123 | sprintf(buff,"LL%d", ++dbglabel); |
| 124 | p2pass( stabline(0, N_SLINE, lineno, buff) ); |
| 125 | p2pi("LL%d:\n", dbglabel); |
| 126 | # endif |
| 127 | } |
| 128 | #endif |
| 129 | |
| 130 | if(yystno != 0) |
| 131 | { |
| 132 | $$ = thislabel = mklabel(yystno); |
| 133 | if( ! headerdone ) |
| 134 | puthead(CNULL, procclass); |
| 135 | if(thislabel->labdefined) |
| 136 | execerr("label %s already defined", |
| 137 | convic(thislabel->stateno) ); |
| 138 | else { |
| 139 | if(thislabel->blklevel!=0 && thislabel->blklevel<blklevel |
| 140 | && thislabel->labtype!=LABFORMAT) |
| 141 | warn1("there is a branch to label %s from outside block", |
| 142 | convic( (ftnint) (thislabel->stateno) ) ); |
| 143 | thislabel->blklevel = blklevel; |
| 144 | thislabel->labdefined = YES; |
| 145 | if(thislabel->labtype != LABFORMAT) |
| 146 | putlabel(thislabel->labelno); |
| 147 | } |
| 148 | } |
| 149 | else $$ = thislabel = NULL; |
| 150 | } |
| 151 | ; |
| 152 | |
| 153 | entry: SPROGRAM new_proc progname |
| 154 | {startproc($3, CLMAIN); } |
| 155 | | SBLOCK new_proc progname |
| 156 | { if($3) NO66("named BLOCKDATA"); |
| 157 | startproc($3, CLBLOCK); } |
| 158 | | SSUBROUTINE new_proc entryname arglist |
| 159 | { entrypt(CLPROC, TYSUBR, (ftnint) 0, $3, $4); } |
| 160 | | SFUNCTION new_proc entryname arglist |
| 161 | { entrypt(CLPROC, TYUNKNOWN, (ftnint) 0, $3, $4); } |
| 162 | | type SFUNCTION new_proc entryname arglist |
| 163 | { entrypt(CLPROC, $1, varleng, $4, $5); } |
| 164 | | SENTRY entryname arglist |
| 165 | { if(parstate==OUTSIDE || procclass==CLMAIN |
| 166 | || procclass==CLBLOCK) |
| 167 | execerr("misplaced entry statement", CNULL); |
| 168 | entrypt(CLENTRY, 0, (ftnint) 0, $2, $3); |
| 169 | } |
| 170 | ; |
| 171 | |
| 172 | new_proc: |
| 173 | { newproc(); } |
| 174 | ; |
| 175 | |
| 176 | entryname: name |
| 177 | { $$ = newentry($1); } |
| 178 | ; |
| 179 | |
| 180 | name: SNAME |
| 181 | { $$ = mkname(toklen, token); } |
| 182 | ; |
| 183 | |
| 184 | progname: { $$ = NULL; } |
| 185 | | entryname |
| 186 | ; |
| 187 | |
| 188 | arglist: |
| 189 | { $$ = 0; } |
| 190 | | SLPAR SRPAR |
| 191 | { NO66(" () argument list"); |
| 192 | $$ = 0; } |
| 193 | | SLPAR args SRPAR |
| 194 | {$$ = $2; } |
| 195 | ; |
| 196 | |
| 197 | args: arg |
| 198 | { $$ = ($1 ? mkchain($1,CHNULL) : CHNULL ); } |
| 199 | | args SCOMMA arg |
| 200 | { if($3) $1 = $$ = hookup($1, mkchain($3,CHNULL)); } |
| 201 | ; |
| 202 | |
| 203 | arg: name |
| 204 | { if($1->vstg!=STGUNKNOWN && $1->vstg!=STGARG) |
| 205 | dclerr("name declared as argument after use", $1); |
| 206 | $1->vstg = STGARG; |
| 207 | } |
| 208 | | SSTAR |
| 209 | { NO66("altenate return argument"); |
| 210 | $$ = 0; substars = YES; } |
| 211 | ; |
| 212 | |
| 213 | |
| 214 | |
| 215 | filename: SHOLLERITH |
| 216 | { |
| 217 | char *s; |
| 218 | s = copyn(toklen+1, token); |
| 219 | s[toklen] = '\0'; |
| 220 | $$ = s; |
| 221 | } |
| 222 | ; |