ec5e5221c7eaea1eee923f1a81f0d5c1b0a5520c
* Copyright (c) 1980 Regents of the University of California.
* All rights reserved. The Berkeley software License Agreement
* specifies the terms and conditions for redistribution.
#define isdigit(x) (x>='0' && x<='9')
#define isspace(s) (s==' ')
#define skip(s) while(isspace(*s)) s++
LOCAL
struct syl syl_vec
[SYLMX
];
LOCAL
int parenlvl
,revloc
;
char *f_s(), *f_list(), *i_tem(), *gt_num(), *ap_end();
/* first time, initialize low_case[] */
for(i
= 0; i
<256; i
++) low_case
[i
]=i
;
for(i
= 'A'; i
<='Z'; i
++) low_case
[i
]=i
-'A'+'a';
s_ptr
= (short *) fmtbuf
;
if( *s_ptr
== FMT_COMP
) {
/* already compiled - copy value of pc */
/* get address of the format */
fmtbuf
= s_init
= (char *) *(l_ptr
+1);
/* point syl_ptr to the compiled format */
syl_ptr
= (struct syl
*) (l_ptr
+ 2);
return((f_s(fmtbuf
,0)==FMTERR
)? ERROR
: OK
);
char *f_s(s
,curloc
) char *s
;
if(parenlvl
++ ==1) revloc
=curloc
;
op_gen(RET
,curloc
,0,0,s
);
if((s
=f_list(s
))==FMTERR
)
if((s
=i_tem(s
))==FMTERR
) return(FMTERR
);
op_gen(REVERT
,revloc
,0,0,s
);
if ((n
=ne_d(s
,&t
))==FMTOK
)
if ((n
=e_d(s
,&t
))==FMTOK
)
if (n
== 0) { fmtptr
= s
; return(FMTERR
); }
curloc
= op_gen(STACK
,n
,0,0,s
);
{ int n
,x
,sign
=0,pp1
,pp2
;
case ':': op_gen(COLON
,(int)('\n'),0,0,s
); break;
case '$': op_gen(DOLAR
,(int)('\0'),0,0,s
); break; /*** NOT STANDARD FORTRAN ***/
case 'n': s
++; op_gen(BNZ
,0,0,0,s
); break;
case 'z': s
++; op_gen(BNZ
,1,0,0,s
); break;
default: op_gen(B
,0,0,0,s
); break; /*** NOT STANDARD FORTRAN ***/
default: fmtptr
= s
; return(FMTUNKN
);
case 'p': s
++; x
=SP
; pp1
=1; pp2
=1; break;
case 'u': s
++; x
=SU
; pp1
=0; pp2
=0; break; /*** NOT STANDARD FORTRAN ***/
case 's': s
++; x
=SS
; pp1
=0; pp2
=1; break;
default: x
=S
; pp1
=0; pp2
=1; break;
case '/': op_gen(SLASH
,0,0,0,s
); break;
case '-': sign
=1; /* OUTRAGEOUS CODING */
case '+': s
++; /* OUTRAGEOUS CODING */
case '0': case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9':
case 'p': if(sign
) n
= -n
; op_gen(P
,n
,0,0,s
); break;
case 'r': if(n
<=1) /*** NOT STANDARD FORTRAN ***/
{ fmtptr
= --s
; return(FMTERR
); }
op_gen(R
,n
,0,0,s
); break;
case 't': op_gen(T
,0,n
,0,s
); break; /* NOT STANDARD FORT */
case 'x': op_gen(X
,n
,0,0,s
); break;
case 'h': op_gen(H
,n
,(s
+1)-s_init
,0,s
);
default: fmtptr
= s
; return(FMTUNKN
);
case '\'': op_gen(APOS
,s
-s_init
,0,0,s
);
case 'l': s
++; x
=TL
; break;
case 'r': s
++; x
=TR
; break;
if(isdigit(*(s
+1))) {s
=gt_num(s
+1,&n
); s
--;}
else { fmtptr
= s
; return(FMTERR
); }
else n
= 0; /* NOT STANDARD FORTRAN, should be error */
case 'x': op_gen(X
,1,0,0,s
); break;
case 'p': op_gen(P
,0,0,0,s
); break;
case 'r': op_gen(R
,10,1,0,s
); break; /*** NOT STANDARD FORTRAN ***/
default: fmtptr
= s
; return(FMTUNKN
);
{ int n
,w
,d
,e
,x
=0, rep_count
;
if (rep_count
== 0) goto ed_err
;
|| *s
== '.' /*** '.' is NOT STANDARD FORTRAN ***/
if (e
==0 || e
>127 || d
>127 ) goto ed_err
;
if(c
=='e') n
=EE
; else if(c
=='d') n
=DE
; else n
=GE
;
op_gen(n
,w
,d
+ (e
<<8),rep_count
,s
);
if(c
=='e') n
=E
; else if(c
=='d') n
=D
; else n
=G
;
op_gen(n
,w
,d
,rep_count
,s
);
op_gen(L
,w
,0,rep_count
,s
);
if (w
==0) op_gen(A
,0,0,rep_count
,s
);
op_gen(AW
,w
,0,rep_count
,s
);
op_gen(A
,0,0,rep_count
,s
);
op_gen(F
,w
,d
,rep_count
,s
);
case 'o': /*** octal format - NOT STANDARD FORTRAN ***/
case 'z': /*** hex format - NOT STANDARD FORTRAN ***/
op_gen(R
,8,1,rep_count
,s
);
op_gen(R
,16,1,rep_count
,s
);
op_gen(x
,w
,d
,rep_count
,s
);
if (c
== 'o' || c
== 'z')
op_gen(R
,10,1,rep_count
,s
);
op_gen(a
,b
,c
,rep
,s
) char *s
;
{ struct syl
*p
= &syl_ptr
[pc
];
fatal(F_ERFMT
,"format too complex");
if( b
>32767 || c
>32767 || rep
>32767 )
fatal("field width or repeat count too large");
fprintf(stderr
,"%3d opgen: %d %d %d %d %c\n",
pc
,a
,b
,c
,rep
,*s
==GLITCH
?'"':*s
); /* for debug */
char *gt_num(s
,n
) char *s
; int *n
;
while(isdigit(*s
) || isspace(*s
))
if(*s
==quote
&& *++s
!=quote
) return(s
);
fatal(F_ERFMT
,"bad string");