LOCAL
char *nextcd
= NULL
;
LOCAL
int lexstate
= NEWSTMT
;
LOCAL
char *send
= s
+20*66;
struct inclfile
*inclnext
;
LOCAL
struct inclfile
*inclp
= NULL
;
LOCAL
struct keylist
{ char *keyname
; int keyval
; } ;
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;
inclp
->incllno
= thislin
;
inclp
->inclstno
= nxtstno
;
inclp
->incllinp
= copyn(inclp
->incllen
= endcd
-nextcd
, nextcd
);
if(++nincl
>= MAXINCLUDE
)
fatal("includes nested too deep");
infname
= inclp
->inclname
= name
;
infile
= inclp
->inclfp
= fp
;
fprintf(diagfile
, "Cannot open file %s", name
);
infname
= inclp
->inclname
;
prevlin
= thislin
= inclp
->incllno
;
stno
= nxtstno
= inclp
->inclstno
;
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) goto first
;
if(stkey
==SASSIGN
&& tokno
==3 && nextch
<lastch
&&
nextch
[0]=='t' && nextch
[1]=='o')
fatal1("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')
/* 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
)
*endcd
++ = (c
== '\t' ? BLANK
: c
);
while( (c
=getc(infile
)) != '\n')
if(a
[5]!=BLANK
&& a
[5]!='0')
if(*p
!= BLANK
) goto initline
;
for(p
= b
; p
<endcd
; ++p
)
if(*p
!= BLANK
) 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
)
if(*i
== BLANK
) continue;
*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 of BLANK -- 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')
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") &&
nextch
<lastch
&& *nextch
=='(')
err2("name %s too long, truncated to %d", token
, VL
);
if(toklen
==1 && *nextch
==MYQUOTE
)
err("bad bit identifier");
for(p
= token
; *nextch
!=MYQUOTE
; )
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(*nextch
=='d' || *nextch
=='e')
if(nextch
[1]=='+' || nextch
[1]=='-')
if( ! 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
[ ] =
"doubleprecision", SDOUBLE
,
"doublecomplex", SDCOMPLEX
,
"subroutine", SSUBROUTINE
,