1*47943Sbostic /*-
2*47943Sbostic * Copyright (c) 1980 The Regents of the University of California.
3*47943Sbostic * All rights reserved.
42508Sdlw *
5*47943Sbostic * %sccs.include.proprietary.c%
623075Skre */
723075Skre
8*47943Sbostic #ifndef lint
9*47943Sbostic static char sccsid[] = "@(#)fmt.c 5.4 (Berkeley) 04/12/91";
10*47943Sbostic #endif /* not lint */
11*47943Sbostic
1223075Skre /*
132508Sdlw * fortran format parser
142508Sdlw */
152508Sdlw
162508Sdlw #include "fio.h"
172591Sdlw #include "format.h"
182508Sdlw
192508Sdlw #define isdigit(x) (x>='0' && x<='9')
202508Sdlw #define isspace(s) (s==' ')
212508Sdlw #define skip(s) while(isspace(*s)) s++
222508Sdlw
232508Sdlw #ifdef interdata
242508Sdlw #define SYLMX 300
252508Sdlw #endif
262508Sdlw
272508Sdlw #ifdef pdp11
282508Sdlw #define SYLMX 300
292508Sdlw #endif
302508Sdlw
312508Sdlw #ifdef vax
322508Sdlw #define SYLMX 300
332508Sdlw #endif
342508Sdlw
3529908Smckusick #ifdef tahoe
3629908Smckusick #define SYLMX 300
3729908Smckusick #endif
3829908Smckusick
3941870Sbostic #ifdef hp300
4041870Sbostic #define SYLMX 300
4141870Sbostic #endif
4241870Sbostic
4320984Slibs LOCAL struct syl syl_vec[SYLMX];
4417967Slibs struct syl *syl_ptr;
4520984Slibs LOCAL int parenlvl,revloc;
4620984Slibs int low_case[256];
4717967Slibs short pc;
482508Sdlw char *f_s(), *f_list(), *i_tem(), *gt_num(), *ap_end();
4917967Slibs char *s_init;
502508Sdlw
pars_f()5117967Slibs pars_f()
522508Sdlw {
5317967Slibs short *s_ptr;
5417967Slibs long *l_ptr;
5517979Slibs int i;
5617967Slibs
5717979Slibs /* first time, initialize low_case[] */
5817979Slibs if( low_case[1] == 0 ) {
5917979Slibs for(i = 0; i<256; i++) low_case[i]=i;
6017979Slibs for(i = 'A'; i<='Z'; i++) low_case[i]=i-'A'+'a';
6117979Slibs }
6217979Slibs
632508Sdlw parenlvl=revloc=pc=0;
6417979Slibs
6517967Slibs s_ptr = (short *) fmtbuf;
6617967Slibs if( *s_ptr == FMT_COMP ) {
6717967Slibs /* already compiled - copy value of pc */
6817967Slibs pc = *(s_ptr+1);
6917967Slibs /* get address of the format */
7017967Slibs l_ptr = (long *) fmtbuf;
7117967Slibs fmtbuf = s_init = (char *) *(l_ptr+1);
7217967Slibs /* point syl_ptr to the compiled format */
7317967Slibs syl_ptr = (struct syl *) (l_ptr + 2);
7417967Slibs return(OK);
7517967Slibs } else {
7617967Slibs syl_ptr = syl_vec;
7717967Slibs s_init = fmtbuf;
7817967Slibs return((f_s(fmtbuf,0)==FMTERR)? ERROR : OK);
7917967Slibs }
802508Sdlw }
812508Sdlw
8220984Slibs LOCAL
f_s(s,curloc)832508Sdlw char *f_s(s,curloc) char *s;
842508Sdlw {
852508Sdlw skip(s);
862508Sdlw if(*s++!='(')
872508Sdlw {
882508Sdlw fmtptr = s;
892508Sdlw return(FMTERR);
902508Sdlw }
912508Sdlw if(parenlvl++ ==1) revloc=curloc;
922508Sdlw op_gen(RET,curloc,0,0,s);
932508Sdlw if((s=f_list(s))==FMTERR)
942508Sdlw {
952508Sdlw return(FMTERR);
962508Sdlw }
972508Sdlw skip(s);
982508Sdlw return(s);
992508Sdlw }
1002508Sdlw
10120984Slibs LOCAL
f_list(s)1022508Sdlw char *f_list(s) char *s;
1032508Sdlw {
1042508Sdlw while (*s)
1052508Sdlw { skip(s);
1062508Sdlw if((s=i_tem(s))==FMTERR) return(FMTERR);
1072508Sdlw skip(s);
1082508Sdlw if(*s==',') s++;
1092508Sdlw else if(*s==')')
1102508Sdlw { if(--parenlvl==0)
1112508Sdlw op_gen(REVERT,revloc,0,0,s);
11216597Sralph else
11316597Sralph op_gen(GOTO,0,0,0,s);
1142508Sdlw return(++s);
1152508Sdlw }
1162508Sdlw }
1172508Sdlw fmtptr = s;
1182508Sdlw return(FMTERR);
1192508Sdlw }
1202508Sdlw
12120984Slibs LOCAL
i_tem(s)1222508Sdlw char *i_tem(s) char *s;
1232508Sdlw { char *t;
1242508Sdlw int n,curloc;
1252508Sdlw if(*s==')') return(s);
12616597Sralph if ((n=ne_d(s,&t))==FMTOK)
12716597Sralph return(t);
12816597Sralph else if (n==FMTERR)
12916597Sralph return(FMTERR);
13016597Sralph if ((n=e_d(s,&t))==FMTOK)
13116597Sralph return(t);
13216597Sralph else if (n==FMTERR)
13316597Sralph return(FMTERR);
1342508Sdlw s=gt_num(s,&n);
13516597Sralph if (n == 0) { fmtptr = s; return(FMTERR); }
1362508Sdlw curloc = op_gen(STACK,n,0,0,s);
1372508Sdlw return(f_s(s,curloc));
1382508Sdlw }
1392508Sdlw
14020984Slibs LOCAL
ne_d(s,p)1412508Sdlw ne_d(s,p) char *s,**p;
1422508Sdlw { int n,x,sign=0,pp1,pp2;
14317979Slibs switch(low_case[*s])
1442508Sdlw {
1452508Sdlw case ':': op_gen(COLON,(int)('\n'),0,0,s); break;
1462508Sdlw #ifndef KOSHER
1472508Sdlw case '$': op_gen(DOLAR,(int)('\0'),0,0,s); break; /*** NOT STANDARD FORTRAN ***/
1482508Sdlw #endif
1492508Sdlw case 'b':
15017979Slibs switch(low_case[*(s+1)])
1512508Sdlw {
15217876Sdlw case 'n': s++; op_gen(BNZ,0,0,0,s); break;
15317876Sdlw case 'z': s++; op_gen(BNZ,1,0,0,s); break;
15417876Sdlw #ifndef KOSHER
15517876Sdlw default: op_gen(B,0,0,0,s); break; /*** NOT STANDARD FORTRAN ***/
15617876Sdlw #else
15717876Sdlw default: fmtptr = s; return(FMTUNKN);
15817876Sdlw #endif
1592508Sdlw }
1602508Sdlw break;
1612508Sdlw case 's':
16217979Slibs switch(low_case[*(s+1)])
1632508Sdlw {
1642508Sdlw case 'p': s++; x=SP; pp1=1; pp2=1; break;
1652508Sdlw #ifndef KOSHER
1662508Sdlw case 'u': s++; x=SU; pp1=0; pp2=0; break; /*** NOT STANDARD FORTRAN ***/
1672508Sdlw #endif
1682508Sdlw case 's': s++; x=SS; pp1=0; pp2=1; break;
1692508Sdlw default: x=S; pp1=0; pp2=1; break;
1702508Sdlw }
1712508Sdlw op_gen(x,pp1,pp2,0,s);
1722508Sdlw break;
1732508Sdlw case '/': op_gen(SLASH,0,0,0,s); break;
17412231Sdlw
17512231Sdlw case '-': sign=1; /* OUTRAGEOUS CODING */
17612231Sdlw case '+': s++; /* OUTRAGEOUS CODING */
1772508Sdlw case '0': case '1': case '2': case '3': case '4':
1782508Sdlw case '5': case '6': case '7': case '8': case '9':
1792508Sdlw s=gt_num(s,&n);
18017979Slibs switch(low_case[*s])
1812508Sdlw {
1822508Sdlw case 'p': if(sign) n= -n; op_gen(P,n,0,0,s); break;
1832508Sdlw #ifndef KOSHER
1842508Sdlw case 'r': if(n<=1) /*** NOT STANDARD FORTRAN ***/
18516597Sralph { fmtptr = --s; return(FMTERR); }
1862508Sdlw op_gen(R,n,0,0,s); break;
1872508Sdlw case 't': op_gen(T,0,n,0,s); break; /* NOT STANDARD FORT */
1882508Sdlw #endif
1892508Sdlw case 'x': op_gen(X,n,0,0,s); break;
19017967Slibs case 'h': op_gen(H,n,(s+1)-s_init,0,s);
1912508Sdlw s+=n;
1922508Sdlw break;
19316597Sralph default: fmtptr = s; return(FMTUNKN);
1942508Sdlw }
1952508Sdlw break;
1962508Sdlw case GLITCH:
1972508Sdlw case '"':
19817967Slibs case '\'': op_gen(APOS,s-s_init,0,0,s);
1992508Sdlw *p = ap_end(s);
2002508Sdlw return(FMTOK);
2012508Sdlw case 't':
20217979Slibs switch(low_case[*(s+1)])
2032508Sdlw {
2042508Sdlw case 'l': s++; x=TL; break;
2052508Sdlw case 'r': s++; x=TR; break;
2062508Sdlw default: x=T; break;
2072508Sdlw }
2082508Sdlw if(isdigit(*(s+1))) {s=gt_num(s+1,&n); s--;}
20916597Sralph #ifdef KOSHER
21016597Sralph else { fmtptr = s; return(FMTERR); }
21116597Sralph #else
2122508Sdlw else n = 0; /* NOT STANDARD FORTRAN, should be error */
2132508Sdlw #endif
2142508Sdlw op_gen(x,n,1,0,s);
2152508Sdlw break;
2162508Sdlw case 'x': op_gen(X,1,0,0,s); break;
2172508Sdlw case 'p': op_gen(P,0,0,0,s); break;
2182508Sdlw #ifndef KOSHER
2192508Sdlw case 'r': op_gen(R,10,1,0,s); break; /*** NOT STANDARD FORTRAN ***/
2202508Sdlw #endif
2212508Sdlw
22216597Sralph default: fmtptr = s; return(FMTUNKN);
2232508Sdlw }
2242508Sdlw s++;
2252508Sdlw *p=s;
2262508Sdlw return(FMTOK);
2272508Sdlw }
2282508Sdlw
22920984Slibs LOCAL
e_d(s,p)2302508Sdlw e_d(s,p) char *s,**p;
23117967Slibs { int n,w,d,e,x=0, rep_count;
2322508Sdlw char *sv=s;
2332508Sdlw char c;
23417967Slibs s=gt_num(s,&rep_count);
23517967Slibs if (rep_count == 0) goto ed_err;
23617979Slibs c = low_case[*s]; s++;
2372508Sdlw switch(c)
2382508Sdlw {
2392508Sdlw case 'd':
2402508Sdlw case 'e':
2412508Sdlw case 'g':
2422508Sdlw s = gt_num(s, &w);
24316597Sralph if (w==0) goto ed_err;
2442508Sdlw if(*s=='.')
2452508Sdlw { s++;
2462508Sdlw s=gt_num(s,&d);
2472508Sdlw }
2482508Sdlw else d=0;
24917979Slibs if(low_case[*s] == 'e'
2502508Sdlw #ifndef KOSHER
2512508Sdlw || *s == '.' /*** '.' is NOT STANDARD FORTRAN ***/
2522508Sdlw #endif
2532508Sdlw )
2542508Sdlw { s++;
2552508Sdlw s=gt_num(s,&e);
25617967Slibs if (e==0 || e>127 || d>127 ) goto ed_err;
2572508Sdlw if(c=='e') n=EE; else if(c=='d') n=DE; else n=GE;
25817967Slibs op_gen(n,w,d + (e<<8),rep_count,s);
2592508Sdlw }
2602508Sdlw else
26117967Slibs {
2622508Sdlw if(c=='e') n=E; else if(c=='d') n=D; else n=G;
26317967Slibs op_gen(n,w,d,rep_count,s);
2642508Sdlw }
2652508Sdlw break;
2662508Sdlw case 'l':
2672508Sdlw s = gt_num(s, &w);
26816597Sralph if (w==0) goto ed_err;
26917967Slibs op_gen(L,w,0,rep_count,s);
2702508Sdlw break;
2712508Sdlw case 'a':
2722508Sdlw skip(s);
27316597Sralph if(isdigit(*s))
2742508Sdlw { s=gt_num(s,&w);
27516597Sralph #ifdef KOSHER
27616597Sralph if (w==0) goto ed_err;
27716597Sralph #else
27817967Slibs if (w==0) op_gen(A,0,0,rep_count,s);
27916597Sralph else
28016597Sralph #endif
28117967Slibs op_gen(AW,w,0,rep_count,s);
2822508Sdlw break;
2832508Sdlw }
28417967Slibs op_gen(A,0,0,rep_count,s);
2852508Sdlw break;
2862508Sdlw case 'f':
2872508Sdlw s = gt_num(s, &w);
28816597Sralph if (w==0) goto ed_err;
2892508Sdlw if(*s=='.')
2902508Sdlw { s++;
2912508Sdlw s=gt_num(s,&d);
2922508Sdlw }
2932508Sdlw else d=0;
29417967Slibs op_gen(F,w,d,rep_count,s);
2952508Sdlw break;
29616597Sralph #ifndef KOSHER
29716597Sralph case 'o': /*** octal format - NOT STANDARD FORTRAN ***/
29816597Sralph case 'z': /*** hex format - NOT STANDARD FORTRAN ***/
29916597Sralph #endif
3002508Sdlw case 'i':
3012508Sdlw s = gt_num(s, &w);
30216597Sralph if (w==0) goto ed_err;
3032508Sdlw if(*s =='.')
3042508Sdlw {
3052508Sdlw s++;
3062508Sdlw s=gt_num(s,&d);
3072508Sdlw x = IM;
3082508Sdlw }
3092508Sdlw else
3102508Sdlw { d = 1;
3112508Sdlw x = I;
3122508Sdlw }
31316597Sralph #ifndef KOSHER
31416597Sralph if (c == 'o')
31517967Slibs op_gen(R,8,1,rep_count,s);
31616597Sralph else if (c == 'z')
31717967Slibs op_gen(R,16,1,rep_count,s);
31816597Sralph #endif
31917967Slibs op_gen(x,w,d,rep_count,s);
32016597Sralph #ifndef KOSHER
32116597Sralph if (c == 'o' || c == 'z')
32217967Slibs op_gen(R,10,1,rep_count,s);
32316597Sralph #endif
3242508Sdlw break;
3252508Sdlw default:
3262508Sdlw *p = sv;
3272508Sdlw fmtptr = s;
32816597Sralph return(FMTUNKN);
3292508Sdlw }
3302508Sdlw *p = s;
3312508Sdlw return(FMTOK);
33216597Sralph ed_err:
33316597Sralph fmtptr = --s;
33416597Sralph return(FMTERR);
3352508Sdlw }
3362508Sdlw
33720984Slibs LOCAL
op_gen(a,b,c,rep,s)33817967Slibs op_gen(a,b,c,rep,s) char *s;
33917967Slibs { struct syl *p= &syl_ptr[pc];
3402508Sdlw if(pc>=SYLMX)
3412508Sdlw { fmtptr = s;
3422591Sdlw fatal(F_ERFMT,"format too complex");
3432508Sdlw }
34417967Slibs if( b>32767 || c>32767 || rep>32767 )
34517967Slibs { fmtptr = s;
34617967Slibs fatal("field width or repeat count too large");
34717967Slibs }
3482508Sdlw #ifdef DEBUG
3492508Sdlw fprintf(stderr,"%3d opgen: %d %d %d %d %c\n",
35017967Slibs pc,a,b,c,rep,*s==GLITCH?'"':*s); /* for debug */
3512508Sdlw #endif
3522508Sdlw p->op=a;
3532508Sdlw p->p1=b;
3542508Sdlw p->p2=c;
35517967Slibs p->rpcnt=rep;
3562508Sdlw return(pc++);
3572508Sdlw }
3582508Sdlw
35920984Slibs LOCAL
gt_num(s,n)3602508Sdlw char *gt_num(s,n) char *s; int *n;
3612508Sdlw { int m=0,a_digit=NO;
3622508Sdlw skip(s);
3632508Sdlw while(isdigit(*s) || isspace(*s))
3642508Sdlw {
3652508Sdlw if (isdigit(*s))
3662508Sdlw {
3672508Sdlw m = 10*m + (*s)-'0';
3682508Sdlw a_digit = YES;
3692508Sdlw }
3702508Sdlw s++;
3712508Sdlw }
3722508Sdlw if(a_digit) *n=m;
3732508Sdlw else *n=1;
3742508Sdlw return(s);
3752508Sdlw }
3762508Sdlw
37720984Slibs LOCAL
ap_end(s)3782508Sdlw char *ap_end(s) char *s;
3792508Sdlw {
3802508Sdlw char quote;
3812508Sdlw quote = *s++;
3822508Sdlw for(;*s;s++)
3832508Sdlw {
3842508Sdlw if(*s==quote && *++s!=quote) return(s);
3852508Sdlw }
3862508Sdlw fmtptr = s;
3872591Sdlw fatal(F_ERFMT,"bad string");
3882508Sdlw }
389