%{ #include "defs" #include "string_defs" #ifdef C_OVERLAY #define yyerror(x) {fprintf(diagfile, "Error on line %d of %s: %s\n", lineno, infname, x); nerr++;} #else #define yyerror(x) error(x, 0, 0, YYERR) #endif static int nstars; static int ndim; static int vartype; static ftnint varleng; static struct { ptr lb, ub; } dims[8]; static struct labelblock *labarray[MAXLABLIST]; static int lastwasbranch = NO; static int thiswasbranch = NO; extern ftnint yystno; extern flag intonly; ftnint convci(); double convcd(); struct addrblock *nextdata(), *mkbitcon(); struct constblock *mklogcon(), *mkaddcon(), *mkrealcon(); struct constblock *mkstrcon(), *mkcxcon(); struct listblock *mklist(); struct listblock *mklist(); struct impldoblock *mkiodo(); struct extsym *comblock(); %} /* Specify precedences and associativies. */ %left SCOMMA %nonassoc SCOLON %right SEQUALS %left SEQV SNEQV %left SOR %left SAND %left SNOT %nonassoc SLT SGT SLE SGE SEQ SNE %left SCONCAT %left SPLUS SMINUS %left SSTAR SSLASH %right SPOWER %% program: | program stat SEOS ; stat: thislabel entry { lastwasbranch = NO; } | thislabel spec | thislabel exec { if($1 && ($1->labelno==dorange)) enddo($1->labelno); if(lastwasbranch && thislabel==NULL) error("statement cannot be reached",0,0,WARN1); lastwasbranch = thiswasbranch; thiswasbranch = NO; } | thislabel SINCLUDE filename { doinclude( $3 ); } | thislabel SEND end_spec { lastwasbranch = NO; endproc(); } | thislabel SUNKNOWN { error("unclassifiable statement",0,0,EXECERR); flline(); }; | error { flline(); needkwd = NO; inioctl = NO; yyerrok; yyclearin; } ; thislabel: SLABEL { if(yystno != 0) { $$ = thislabel = mklabel(yystno); if( ! headerdone ) puthead(NULL, procclass); if(thislabel->labdefined) error("label %s already defined", convic(thislabel->stateno),0,EXECERR); else { if(thislabel->blklevel!=0 && thislabel->blklevellabtype!=LABFORMAT) error("there is a branch to label %s from outside block", convic( (ftnint) (thislabel->stateno) ),0,WARN1); thislabel->blklevel = blklevel; thislabel->labdefined = YES; if(thislabel->labtype != LABFORMAT) putlabel(thislabel->labelno); } } else $$ = thislabel = NULL; } ; entry: SPROGRAM new_proc progname { startproc($3, CLMAIN); } | SBLOCK new_proc progname { startproc($3, CLBLOCK); } | SSUBROUTINE new_proc entryname arglist { entrypt(CLPROC, TYSUBR, (ftnint) 0, $3, $4); } | SFUNCTION new_proc entryname arglist { entrypt(CLPROC, TYUNKNOWN, (ftnint) 0, $3, $4); } | type SFUNCTION new_proc entryname arglist { entrypt(CLPROC, $1, varleng, $4, $5); } | SENTRY entryname arglist { if(parstate==OUTSIDE || procclass==CLMAIN || procclass==CLBLOCK) error("misplaced entry statement", 0,0,EXECERR); entrypt(CLENTRY, 0, (ftnint) 0, $2, $3); } ; new_proc: { newproc(); } ; entryname: name { $$ = newentry($1); } ; name: SNAME { $$ = mkname(toklen, token); } ; progname: { $$ = NULL; } | entryname ; arglist: { $$ = 0; } | SLPAR SRPAR { $$ = 0; } | SLPAR args SRPAR {$$ = $2; } ; args: arg { $$ = ($1 ? mkchain($1,0) : 0 ); } | args SCOMMA arg { if($3) $1 = $$ = hookup($1, mkchain($3,0)); } ; arg: name { $1->vstg = STGARG; } | SSTAR { $$ = 0; substars = YES; } ; filename: SHOLLERITH { char *s; s = copyn(toklen+1, token); s[toklen] = '\0'; $$ = s; } ;