| 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 | ; |