%{ # include "defs" #ifdef SDB # include <a.out.h> char *stabline(); # ifdef UCBVAXASM char *stabdline(); # endif # ifndef N_SO # include <stab.h> # endif #endif static int nstars; static int ndim; static int vartype; static ftnint varleng; static struct { expptr lb, ub; } dims[MAXDIM+1]; static struct Labelblock *labarray[MAXLABLIST]; static int lastwasbranch = NO; static int thiswasbranch = NO; static int hadcomma; extern ftnint yystno; extern flag intonly; static chainp datastack; extern long laststfcn, thisstno; ftnint convci(); double convcd(); Addrp nextdata(); expptr mklogcon(), mkaddcon(), mkrealcon(), mkstrcon(), mkbitcon(); expptr mkcxcon(); struct Listblock *mklist(); struct Listblock *mklist(); struct Impldoblock *mkiodo(); struct Extsym *comblock(); static void pop_datastack() { chainp d0 = datastack; if (d0->datap && !(bugwarn & 2)) { if (bugwarn) warnb("old f77 incorrectly parsed this data statement"); curdtp = (chainp)d0->datap; } datastack = d0->nextp; d0->nextp = 0; frchain(&d0); } %} /* Specify precedences and associativities. */ %union { int ival; char *charpval; chainp chval; tagptr tagval; expptr expval; struct Labelblock *labval; struct Nameblock *namval; struct Eqvchain *eqvval; struct Extsym *extval; } %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 %start program %type <labval> thislabel label assignlabel %type <tagval> other inelt %type <ival> lengspec type typespec typename dcl letter addop relop stop nameeq %type <charpval> filename %type <chval> datavar datavarlist namelistlist funarglist funargs dospec %type <chval> callarglist arglist args exprlist inlist outlist out2 substring %type <namval> name arg call var %type <expval> lhs expr uexpr opt_expr fexpr unpar_fexpr %type <expval> ubound simple value callarg complex_const simple_const bit_const %type <extval> common comblock entryname progname %type <eqvval> equivlist %% program: | program stat SEOS ; stat: thislabel entry { lastwasbranch = NO; } | thislabel spec | thislabel exec { /* forbid further statement function definitions... */ if (parstate == INDATA && laststfcn != thisstno && !(bugwarn & 2)) parstate = INEXEC; thisstno++; if($1 && ($1->labelno==dorange)) enddo($1->labelno); if(lastwasbranch && thislabel==NULL) warn("statement cannot be reached"); lastwasbranch = thiswasbranch; thiswasbranch = NO; if($1) { if($1->labtype == LABFORMAT) err("label already that of a format"); else $1->labtype = LABEXEC; } } | thislabel SINCLUDE filename { doinclude( $3 ); } | thislabel SEND end_spec { lastwasbranch = NO; endproc(); } | thislabel SUNKNOWN { execerr("unclassifiable statement", CNULL); flline(); }; | error { flline(); needkwd = NO; inioctl = NO; yyerrok; yyclearin; } ; thislabel: SLABEL { #ifdef SDB if( sdbflag && parstate >= INDATA ) { # ifdef UCBVAXASM p2pass( stabdline(N_SLINE, lineno) ); # else char buff[10]; sprintf(buff,"LL%d", ++dbglabel); p2pass( stabline(0, N_SLINE, lineno, buff) ); p2pi("LL%d:\n", dbglabel); # endif } #endif if(yystno != 0) { $$ = thislabel = mklabel(yystno); if( ! headerdone ) puthead(CNULL, procclass); if(thislabel->labdefined) execerr("label %s already defined", convic(thislabel->stateno) ); else { if(thislabel->blklevel!=0 && thislabel->blklevel<blklevel && thislabel->labtype!=LABFORMAT) warn1("there is a branch to label %s from outside block", convic( (ftnint) (thislabel->stateno) ) ); 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 { if($3) NO66("named BLOCKDATA"); 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) execerr("misplaced entry statement", CNULL); 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 { NO66(" () argument list"); $$ = 0; } | SLPAR args SRPAR {$$ = $2; } ; args: arg { $$ = ($1 ? mkchain($1,CHNULL) : CHNULL ); } | args SCOMMA arg { if($3) $1 = $$ = hookup($1, mkchain($3,CHNULL)); } ; arg: name { if($1->vstg!=STGUNKNOWN && $1->vstg!=STGARG) dclerr("name declared as argument after use", $1); $1->vstg = STGARG; } | SSTAR { NO66("altenate return argument"); $$ = 0; substars = YES; } ; filename: SHOLLERITH { char *s; s = copyn(toklen+1, token); s[toklen] = '\0'; $$ = s; } ;