* Copyright (c) 1980 Regents of the University of California.
* All rights reserved. The Berkeley software License Agreement
* specifies the terms and conditions for redistribution.
static char sccsid
[] = "@(#)lex.c 5.1 (Berkeley) 6/7/85";
* Lexical scanner routines for the f77 compiler, pass 1, 4.2 BSD.
* University of Utah CS Dept modification history:
* Revision 1.2 84/10/27 02:20:09 donn
* Fixed bug where the input file and the name field of the include file
* structure shared -- when the input file name was freed, the include file
* name got stomped on, leading to peculiar error messages.
LOCAL
char *nextcd
= NULL
;
LOCAL
int lexstate
= NEWSTMT
;
LOCAL
char *send
= s
+20*66;
LOCAL
char *newname
= NULL
;
struct Inclfile
*inclnext
;
LOCAL
struct Inclfile
*inclp
= NULL
;
LOCAL
struct Keylist
{ char *keyname
; int keyval
; char notinf66
; } ;
LOCAL
struct Punctlist
{ char punchar
; int punval
; };
LOCAL
struct Fmtlist
{ char fmtchar
; int fmtval
; };
LOCAL
struct Dotlist
{ char *dotname
; int dotval
; };
LOCAL
struct Keylist
*keystart
[26], *keyend
[26];
/* throw away the rest of the current line */
*n
= (lastch
- nextch
) + 1;
register char *lastslash
, *s
;
inclp
->incllno
= thislin
;
inclp
->inclstno
= nxtstno
;
inclp
->incllinp
= copyn(inclp
->incllen
= endcd
-nextcd
, nextcd
);
if(++nincl
>= MAXINCLUDES
)
fatal("includes nested too deep");
else if(name
[0]=='/' || inclp
==NULL
)
for(s
= inclp
->inclname
; *s
; ++s
)
sprintf(temp
, "%s/%s", inclp
->inclname
, name
);
if( (fp
= fopen(temp
, "r")) == NULL
)
sprintf(temp
, "/usr/include/%s", name
);
infile
= inclp
->inclfp
= fp
;
fprintf(diagfile
, "Cannot open file %s", name
);
infname
= copys(inclp
->inclname
);
prevlin
= thislin
= inclp
->incllno
;
stno
= nxtstno
= inclp
->inclstno
;
free( (charptr
) (inclp
->incllinp
) );
case NEWSTMT
: /* need a new statement */
case FIRSTTOKEN
: /* first step on a statement */
case OTHERTOKEN
: /* return next token */
if( (stkey
==SLOGIF
|| stkey
==SELSEIF
) && parlev
==0 && tokno
>3)
if(stkey
==SASSIGN
&& tokno
==3 && nextch
<lastch
&&
nextch
[0]=='t' && nextch
[1]=='o')
fatali("impossible lexstate %d", lexstate
);
code
= getcd( nextcd
= s
);
err("illegal continuation card ignored");
nextcd
+66<=send
&& (code
= getcd(nextcd
))==STCONTINUE
;
if( (c
= getc(infile
)) == '&')
else if(c
=='c' || c
=='C' || c
=='*')
while( (c
= getc(infile
)) != '\n')
while (c
== BLANK
|| c
== '\t')
while (c
== BLANK
|| c
== '\t')
while (c
!= '"' && c
!= '\n')
newname
= (char *) ckalloc(len
);
/* a tab in columns 1-6 skips to column 7 */
for(p
=a
; p
<aend
&& (c
=getc(infile
)) != '\n' && c
!=EOF
; )
else { /* read body of line */
while( endcd
<bend
&& (c
=getc(infile
)) != '\n' && c
!=EOF
)
while( (c
=getc(infile
)) != '\n')
if( !isspace(a
[5]) && a
[5]!='0')
if( !isspace(*p
) ) goto initline
;
for(p
= b
; p
<endcd
; ++p
)
if( !isspace(*p
) ) goto initline
;
nxtstno
= 10*nxtstno
+ (*p
- '0');
err("nondigit in statement number field");
register char *i
, *j
, *j0
, *j1
, *prvstr
;
/* i is the next input character to be looked at
j is the next output character */
expcom
= 0; /* exposed ','s */
expeql
= 0; /* exposed equal signs */
for(i
=s
; i
<=lastch
; ++i
)
*j
= MYQUOTE
; /* special marker */
err("unbalanced quotes; closing quote supplied");
if(i
<lastch
&& i
[1]==quote
) ++i
;
else if(*i
=='\\' && i
<lastch
)
else if( (*i
=='h' || *i
=='H') && j
>prvstr
) /* test for Hollerith strings */
if( ! isdigit(j
[-1])) goto copychar
;
for(j0
=j
-2 ; j0
>j1
; -- j0
)
if( ! isdigit(*j0
) ) break;
if(j0
<= j1
) goto copychar
;
/* a hollerith must be preceded by a punctuation mark.
'*' is possible only as repetition factor in a data statement
not, in particular, in character*2h
if( !(*j0
=='*'&&s
[0]=='d') && *j0
!='/' && *j0
!='(' &&
*j0
!=',' && *j0
!='=' && *j0
!='.')
j0
[1] = MYQUOTE
; /* special marker */
else if(*i
== ')') --parlev
;
if(*i
== '=') expeql
= 1;
else if(*i
== ',') expcom
= 1;
copychar
: /*not a string or space -- copy, shifting case if necessary */
if(shiftcase
&& isupper(*i
))
err("unbalanced parentheses, statement skipped");
if(nextch
+2<=lastch
&& nextch
[0]=='i' && nextch
[1]=='f' && nextch
[2]=='(')
/* assignment or if statement -- look at character after balancing paren */
for(i
=nextch
+3 ; i
<=lastch
; ++i
)
else if(expeql
) /* may be an assignment */
if(expcom
&& nextch
<lastch
&&
nextch
[0]=='d' && nextch
[1]=='o')
/* otherwise search for keyword */
if(stkey
==SGOTO
&& lastch
>=nextch
)
else if(isalpha(nextch
[0]))
register struct Keylist
*pk
, *pend
;
if(! isalpha(nextch
[0]) )
for(pend
= keyend
[k
] ; pk
<=pend
; ++pk
)
while(*++i
==*++j
&& *i
!='\0')
if(*i
=='\0' && j
<=lastch
+1)
if(no66flag
&& pk
->notinf66
)
errstr("Not a Fortran 66 keyword: %s",
extern struct Keylist keys
[];
register struct Keylist
*p
;
for(p
= keys
; p
->keyname
; ++p
)
int havdot
, havexp
, havdbl
;
extern struct Punctlist puncts
[];
extern struct Fmtlist fmts
[];
extern struct Dotlist dots
[];
while(*nextch
!= MYQUOTE
)
for(pf = fmts; pf->fmtchar; ++pf)
if(*nextch == pf->fmtchar)
else if(pf->fmtval == SRPAR)
while(nextch<=lastch && isdigit(*nextch) )
if(nextch<=lastch && *nextch=='p')
(*nextch=='.' || isdigit(*nextch) || isalpha(*nextch) ))
/* Not a format statement */
for(pp
=puncts
; pp
->punchar
; ++pp
)
if(*nextch
== pp
->punchar
)
if( (*nextch
=='*' || *nextch
=='/') &&
nextch
<lastch
&& nextch
[1]==nextch
[0])
if(nextch
>= lastch
) goto badchar
;
else if(isdigit(nextch
[1])) goto numconst
;
for(pd
=dots
; (j
=pd
->dotname
) ; ++pd
)
for(i
=nextch
+1 ; i
<=lastch
; ++i
)
if( isalpha(*nextch
) || isdigit(*nextch
) )
if(inioctl
&& nextch
<=lastch
&& *nextch
=='=')
if(toklen
>8 && eqn(8,token
,"function") && isalpha(token
[8]) &&
nextch
<lastch
&& nextch
[0]=='(' &&
(nextch
[1]==')' | isalpha(nextch
[1])) )
sprintf(buff
, "name %s too long, truncated to %d",
if(toklen
==1 && *nextch
==MYQUOTE
)
err("bad bit identifier");
for(p
= token
; *nextch
!=MYQUOTE
; )
if ( *nextch
== BLANK
|| *nextch
== '\t')
*nextch
= tolower(*nextch
);
if (hextoi(*p
++ = *nextch
++) >= radix
)
err("invalid binary character");
return( radix
==16 ? SHEXCON
:
(radix
==8 ? SOCTCON
: SBITCON
) );
if( ! isdigit(*nextch
) ) goto badchar
;
for(n1
= nextch
; nextch
<=lastch
; ++nextch
)
else if(nextch
+2<=lastch
&& isalpha(nextch
[1])
else if( !intonly
&& (*nextch
=='d' || *nextch
=='e') )
if(nextch
[1]=='+' || nextch
[1]=='-')
if( (nextch
>= lastch
) || ! isdigit(*++nextch
) )
nextch
<=lastch
&& isdigit(*nextch
);
else if( ! isdigit(*nextch
) )
if(havdbl
) return(SDCON
);
if(havdot
|| havexp
) return(SRCON
);
/* KEYWORD AND SPECIAL CHARACTER TABLES
struct Punctlist puncts
[ ] =
LOCAL struct Fmtlist fmts[ ] =
LOCAL
struct Dotlist dots
[ ] =
LOCAL
struct Keylist keys
[ ] =
{ "automatic", SAUTOMATIC
, YES
},
{ "backspace", SBACKSPACE
},
{ "character", SCHARACTER
, YES
},
{ "close", SCLOSE
, YES
},
{ "continue", SCONTINUE
},
{ "dimension", SDIMENSION
},
{ "doubleprecision", SDOUBLE
},
{ "doublecomplex", SDCOMPLEX
, YES
},
{ "elseif", SELSEIF
, YES
},
{ "endif", SENDIF
, YES
},
{ "entry", SENTRY
, YES
},
{ "equivalence", SEQUIV
},
{ "external", SEXTERNAL
},
{ "function", SFUNCTION
},
{ "implicit", SIMPLICIT
, YES
},
{ "include", SINCLUDE
, YES
},
{ "inquire", SINQUIRE
, YES
},
{ "intrinsic", SINTRINSIC
, YES
},
{ "namelist", SNAMELIST
, YES
},
{ "none", SUNDEFINED
, YES
},
{ "parameter", SPARAM
, YES
},
{ "program", SPROGRAM
, YES
},
{ "punch", SPUNCH
, YES
},
{ "static", SSTATIC
, YES
},
{ "subroutine", SSUBROUTINE
},
{ "undefined", SUNDEFINED
, YES
},