fortran语法.c

语言的语法,格式严紧,对于处理yacc,lex有帮助!

X { "ENDIF", ENDIF, 0 }, 
X { "END", END, 0 }, 
X { "ENTRY", ENTRY, 0 }, 
X { "EQUIVALENCE", EQUIVALENCE, 0 }, 
X { "EXTERNAL", EXTERNAL, 0 }, 
X { "FORMAT", FORMAT, 0 }, 
X { "FUNCTION", FUNCTION, 0 }, 
X { "GOTO", GOTO, 0 }, 
X { "IF",  IF, 0 }, 
X { "IMPLICIT", IMPLICIT, 0 }, 
X { "INTRINSIC", INTRINSIC, 0 }, 
X { "PROGRAM", PROGRAM, 0 }, 
X { "RETURN", RETURN, 0 }, 
X { "REWIND", REWIND, 0 }, 
X { "SAVE", SAVE, 0 }, 
X { "STOP", STOP, 0 }, 
X { "SUBROUTINE", SUBROUTINE, 0 }, 
X { "THEN", THEN, 0 }, 
X NULL 
X}; 
X 
X/* type declarators */ 
Xkwdtab tab_type[] = { 
X { "DOUBLEPRECISION", TYPE, MTYPE(REAL, 8), }, 
X { "REAL*8", TYPE, MTYPE(REAL, 8), }, 
X { "REAL*4", TYPE, MTYPE(REAL, 4), }, 
X { "REAL", TYPE, MTYPE(REAL, 4), }, 
X 
X { "INTEGER*4", TYPE, MTYPE(INTEGER, 4), }, 
X { "INTEGER", TYPE, MTYPE(INTEGER, 4), }, 
X 
X 
X { "LOGICAL*4", TYPE, MTYPE(LOGICAL, 4), }, 
X { "LOGICAL", TYPE, MTYPE(LOGICAL, 4), }, 
X 
X 
X { "DOUBLECOMPLEX", TYPE, MTYPE(COMPLEX, 16), }, 
X { "COMPLEX*16", TYPE, MTYPE(COMPLEX, 16), }, 
X { "COMPLEX*8", TYPE, MTYPE(COMPLEX, 8), }, 
X { "COMPLEX", TYPE, MTYPE(COMPLEX, 4), }, 
X 
X 
X { "CHARACTER", TYPE, MTYPE(CHAR, 1), }, 
X NULL 
X}; 
X 
X/* normal tokens */ 
Xkwdtab tab_toks[] = { 
X { "+", PLUS, 0 }, 
X { "-", MINUS, 0 }, 
X { "(", OP, 0 }, 
X { ")", CP, 0 }, 
X { "**", POW, 0 }, 
X { "*", STAR, 0 }, 
X { "//", CAT, 0 }, 
X { "/", DIV, 0 }, 
X { ",", CM, 0 }, 
X { "=", EQ, 0 }, 
X { ":", COLON, 0 }, 
X { ".NOT.", NOT, 0 }, 
X { ".AND.", AND, 0 }, 
X { ".OR.", OR, 0 }, 
X { ".EQV.", EQV, 0 }, 
X { ".NEQV.", EQV, 1 }, 
X { ".EQ.", RELOP, rel_eq }, 
X { ".NE.", RELOP, rel_ne }, 
X { ".LT.", RELOP, rel_lt }, 
X { ".LE.", RELOP, rel_le }, 
X { ".GT.", RELOP, rel_gt }, 
X { ".GE.", RELOP, rel_ge }, 
X { ".TRUE.", CONST, 1 }, 
X { ".FALSE.", CONST, 0 }, 
X NULL 
X}; 
X 
X 
X/* call this before parsing a statement */ 
X/* returns 1 if there's a statement to parse */ 
X/* also checks the statement type and sets the context appropriately */ 
Xlex0() 
X{ 
X if(!rdstmt()) 
X  return 0; /* EOF */ 
X scp = stmtbuf; 
X if(prescan()) 
X  context = cxt_norm; 
X else 
X  context = cxt_stmt; 
X return 1; 
X} 
X 
X/* look to see if the next thing is a recognized keyword */ 
Xint 
Xkeyscan(tab) 
Xregister kwdtab *tab; 
X{ 
X while(tab->kwd) { 
X  int len = strlen(tab->kwd); 
X 
X  if(!strncmp(scp, tab->kwd, len)) { 
X   scp += len; /* skip over this */ 
X   if(tab->ktok == CONST) { /* hack */ 
X    yylval.uuexp.c.t = MTYPE(LOGICAL, 4); 
X    yylval.uuexp.c.u.l = tab->klex; 
X   } else 
X   yylval.uuint = tab->klex; 
X   return tab->ktok; 
X  } 
X  tab++; 
X } 
X return 0; 
X} /* keyscan */ 
X 
X/* After all this setup, the lexer is quite simple.  It looks for the 
longest 
X   keyword legal in the current context or, failing that, for a number or 
X   name.  The various contexts are mostly set in the parser; the lexer 
resets 
X   the context to normal (name, number, or special character token) after 
X   each token. */ 
X 
Xyylex() 
X { 
X int c; 
X 
X if(!*scp) 
X  return 0; /* end of statement */ 
X 
X switch(context) { 
X case cxt_stmt: 
X  c = keyscan(tab_type); 
X  if(c) 
X   break; 
X  c = keyscan(tab_stmt); 
X  if(c) 
X   break; 
X  goto normal; /* look for normal token */ 
X default: 
X  yyerror("Mystery context"); 
X  context = cxt_norm; 
X case cxt_norm: 
X case cxt_do: 
Xnormal: 
X  c = keyscan(tab_toks); 
X  if(c) 
X   break; /* found something */ 
X  /* check for literal string */ 
X  if(*scp == '\'') { 
X   char *str; 
X 
X   c = CONST; 
X   scp++; 
X   str = string_tab[*scp++ - '0']; 
X   yylval.uuexp.c.t = MTYPE(CHAR, strlen(str)); 
X   yylval.uuexp.c.u.c = str; 
X   break; 
X  } 
X 
X  /* must be a number or name */ 
X  if(isalpha(*scp)) { 
X   char *ocp = yylval.uuexp.n.name; 
X 
X   yylval.uuexp.n.t = 0; 
X   while(isalnum(*scp)) { 
X    *ocp = *scp; 
X    ocp++; 
X    scp++; 
X   } 
X   *ocp = 0; 
X   c = NAME; 
X   break; 
X  } else { /* constant */ 
X   int dotseen = 0, expseen = 0; 
X   int mytype = MTYPE(INTEGER, 4); 
X   char *sbp; 
X   char sbuf[50]; 
X 
X   if(!isdigit(*scp) && *scp != '.') { 
X    yyerror("Unknown character"); 
X    c = 0; 
X    break; 
X   } 
X   sbp = sbuf; 
X   for(;;) { 
X    if(isdigit(*scp)) { 
X     *sbp++ = *scp++; 
X     continue; 
X    } 
X    if(!dotseen && *scp == '.') { 
X     dotseen++; 
X     mytype = MTYPE(REAL, 4); 
X     *sbp++ = *scp++; 
X     continue; 
X    } 
X    if(!expseen && context != cxt_do 
X     && (*scp == 'D' || *scp == 'E')) { 
X     expseen++; 
X     dotseen++; 
X     if(*scp == 'D') 
X      mytype = MTYPE(REAL, 8); 
X     else 
X      mytype = MTYPE(REAL, 4); 
X     *sbp++ = 'E'; 
X     scp++; 
X     if(*scp == '+') 
X      scp++; 
X     else if(*scp == '-') 
X      *sbp++ = *scp++; 
X     continue; 
X    } 
X    break;  /* end of number */ 
X   } /* for */ 
X   *sbp = 0; 
X   yylval.uuexp.c.t = mytype; 
X   if(mytype == MTYPE(INTEGER, 4)) 
X    yylval.uuexp.c.u.l = atol(sbuf); 
X   else 
X    yylval.uuexp.c.u.d = atof(sbuf); 
X   c = CONST; 
X   break; 
X  } /* name/const */ 
X } /* switch */ 
X context = cxt_norm; 
X return c; 
X} /* yylex */ 
X 
X/* call this to clean up after lexing a statement */ 
X/* It frees the entries in the string table, and emits the statement number 
X   for the next statement if there is one. 
X  */ 
Xlex1() 
X{ 
X while(string_tabp > string_tab) 
X  free(*--string_tabp); 
X if(next_stno) 
X  emit(1, next_stno); 
X} 
SHAR_EOF 
chmod 0644 ftnlex.c || echo "restore of ftnlex.c fails" 
fi 
if test -f fparse.y; then echo "File fparse.y exists"; else 
echo "x - extracting fparse.y (Text)" 
sed 's/^X//' << 'SHAR_EOF' > fparse.y && 
X/************************************************************************* 
X*                                                                        * 
X*     Fortran 77 Subset Parser - November 1988                           * 
X*     Copyright 1988 - John R. Levine.  All rights reserved.             * 
X*     Permission is hereby granted to make copies in modified or         * 
X*     unmodified form so long as this copyright notice is preserved      * 
X*     and such copies are not made for direct commercial advantage.      * 
X*                                                                        * 
X*     Any other use such as incorporation in whole or in part in a       * 
X*     product offered for sale requires separate permission.             * 
X*                                                                        * 
X*     John R. Levine                                                     * 
X*     P.O. Box 349                                                       * 
X*     Cambridge MA 02238-0349                                            * 
X*                                                                        * 
X*     Internet/uucp: [e-mail]    MCI Mail:  103-7498              * 
X*                                                                        * 
X*************************************************************************/ 
X 
X 
X%{ 
X#include "ftn.h" 
X%} 
X%union { 
X expr uuexp; 
X long uulong; 
X int uuint; 
X type uutype; 
X} 
X/* generic tokens */ 
X%token PLUS MINUS OP CP STAR POW DIV CAT CM EQ COLON 
X%token NOT AND OR 
X%token <uuint> RELOP EQV 
X%token <uuexp> NAME CONST ICON RCON LCON CCON 
X 
X/* a zillion keywords */ 
X%token IF THEN ELSE ELSEIF ENDIF DO GOTO ASSIGN TO CONTINUE STOP 
X%token <uuint> RDWR 
X%token OPEN CLOSE BACKSPACE REWIND ENDFILE FORMAT 
X%token PROGRAM FUNCTION SUBROUTINE ENTRY END CALL RETURN 
X%token <uutype> TYPE DIMENSION 
X%token COMMON EQUIVALENCE EXTERNAL PARAMETER INTRINSIC IMPLICIT 
X%token SAVE DATA 
X 
X%left EQV 
X%left OR 
X%left AND 
X%nonassoc NOT 
X%nonassoc RELOP 
X%left CAT 
X%left PLUS MINUS 
X%left STAR DIV 
X%right POW 
X%nonassoc UMINUS 
X 
X%type <uutype> opttype 
X 
X%% 
X 
Xstatement: s { emit(0); } 
X ; 
X 
Xs:  PROGRAM NAME 
X ; 
X 
Xs:  opttype FUNCTION NAME { emit(FUNCTION, $1, $3.n.name); } 
X   OP funargs CP 
X ; 
X 
Xopttype: /* empty */ { $$ = 0; } 
X | TYPE 
X ; 
X 
Xfunargs: funarg 
X | funargs CM funarg 
X ; 
X 
Xfunarg:  NAME { emit(NAME, $1.n.name); } 
X | STAR { emit(STAR); } 
X ; 
X 
Xs:  ENTRY NAME 
X | ENTRY NAME OP funargs CP 
X ; 
X 
Xs:  SUBROUTINE NAME { emit(SUBROUTINE, $2.n.name); } 
X | SUBROUTINE NAME { emit(SUBROUTINE, $2.n.name); } 
X   OP funargs CP 
X ; 
X 
X/* we give dimension and explicit type statements the same syntax here 
X   because I'm lazy.  This allows e.g. 
X    DIMENSION FOO 
X   which is easier to kick out semantically 
X */ 
X 
Xs:  DIMENSION { emit(TYPE, 0); } arydcllist 
X | TYPE { emit(TYPE, $1); } arydcllist 
X ; 
X 
Xarydcllist: arydcl 
X | arydcllist CM arydcl 
X ; 
X 
Xarydcl:  NAME { emit(NAME, $1.n.name); } OP dclsublist CP 
X  { emit(CP); } 
X | NAME { emit(NAME, $1.n.name); emit(CP); } 
X ; 
X 
Xdclsublist: dclsub 
X | dclsublist CM { emit(CP); } dclsub 
X ; 
X 
Xdclsub:  exp 
X | exp COLON { emit(COLON); } exp 
X | STAR 
X | exp COLON STAR { emit(COLON); emit(STAR); } 
X ; 
X 
Xs:  COMMON { emit(COMMON); } commonlist 
X ; 
X 
Xcommonlist: arydcl 
X | commonlist CM arydcl 
X | blockname 
X | commonlist optcomma blockname 
X ; 
X 
Xoptcomma: CM 
X | /* nothing */ 
X ; 
X 
X/* note here that the // for blank common looks a lot like the catenation 
X   operator.  Fortunately, there's no semantic ambiguity */ 
X 
Xblockname: DIV NAME DIV { emit(TO, $2.n.name); } 
X | CAT { emit(TO, ""); } /* blank common */ 
X ; 
X 
Xs:  EQUIVALENCE quivlist 
X ; 
X 
Xquivlist: quiv 
X | quivlist CM quiv 
X ; 
X 
Xquiv:  OP arydcllist CP 
X ; 
X 
Xs:  IMPLICIT impllist 
X ; 
X 
Ximpllist: impldcl 
X | impllist CM impldcl 
X ; 
X 
Ximpldcl: TYPE OP implletlist CP 
X ; 
X 
Ximplletlist: impllet 
X | implletlist CM impllet 
X ; 
X 
X/* the NAMEs here actually have to be single letters, but it's easier to 
X   sort this out semantically than to make the parser only allow single 
X   letters for this one case */ 
X 
Ximpllet: NAME 
X | NAME MINUS NAME 
X ; 
X 
Xexp:  NAME { emit(NAME, $1.n.name); } 
X | CONST { 
X   switch(TYTYPE($1.c.t)) { 
X   case TY_INTEGER: 
X    emit(ICON, $1.c.u.l); break; 
X   case TY_REAL: 
X    emit(RCON, $1.c.u.d); break; 
X   case TY_LOGICAL: 
X    emit(ICON, $1.c.u.l); break;