1 /*-
2 * Copyright (c) 1980 The Regents of the University of California.
3 * All rights reserved.
4 *
5 * %sccs.include.proprietary.c%
6 */
7
8 #ifndef lint
9 static char sccsid[] = "@(#)dofio.c 5.3 (Berkeley) 04/12/91";
10 #endif /* not lint */
11
12 /*
13 * fortran format executer
14 */
15
16 #include "fio.h"
17 #include "format.h"
18
19 #define DO(x) if(n=x) err(n>0?errflag:endflag,n,dfio)
20 #define DO_F(x) if(n=x) err_f(n>0?errflag:endflag,n,dfio)
21 #define err_f(f,n,s) {if(f) return(dof_err(n)); else fatal(n,s);}
22 #define STKSZ 10
23 LOCAL int cnt[STKSZ],ret[STKSZ],cp,rp;
24 LOCAL char *dfio = "dofio";
25 int used_data;
26
en_fio()27 en_fio()
28 { ftnint one=1;
29 return(do_fio(&one,NULL,0L));
30 }
31
32 /* OP_TYPE_TAB is defined in format.h,
33 it is NED for X,SLASH,APOS,H,TL,TR,T
34 ED for I,IM,F,E,EE,D,DE,G,GE,L,A,AW
35 and returns op for other values
36 */
37 LOCAL int optypes[] = OP_TYPE_TAB;
38 LOCAL int rep_count, in_mid;
39
do_fio(number,ptr,len)40 do_fio(number,ptr,len) ftnint *number; ftnlen len; char *ptr;
41 { struct syl *p;
42 int n,i,more,optype;
43 more = *number;
44 for(;;) {
45 if( (optype = ((p= &syl_ptr[pc])->op)) > LAST_TERM )
46 err_f(errflag,F_ERFMT,"impossible code");
47 #ifdef DEBUG
48 fprintf(stderr," pc=%d, cnt[%d]=%d, ret[%d]=%d, op=%d\n",
49 pc,cp,cnt[cp],rp,ret[rp],optype); /*for debug*/
50 #endif
51 switch(optypes[optype])
52 {
53 case NED:
54 DO_F((*doned)(p,ptr))
55 pc++;
56 break;
57 case ED:
58 if(in_mid == NO) rep_count = p->rpcnt;
59 in_mid = YES;
60 while (rep_count > 0 ) {
61 if(ptr==NULL)
62 { DO((*doend)('\n'))
63 return(OK);
64 }
65 if(!more) return(OK);
66 used_data = YES;
67 DO_F((*doed)(p,ptr,len))
68 ptr += len;
69 more--;
70 rep_count--;
71 }
72 pc++;
73 in_mid = NO;
74 break;
75 case STACK: /* repeat count */
76 if(++cp==STKSZ) err_f(errflag,F_ERFMT,"too many nested ()")
77 cnt[cp]=p->p1;
78 pc++;
79 break;
80 case RET: /* open paren */
81 if(++rp==STKSZ) err_f(errflag,F_ERFMT,"too many nested ()")
82 ret[rp]=p->p1;
83 pc++;
84 break;
85 case GOTO: /* close paren */
86 if(--cnt[cp]<=0)
87 { cp--;
88 rp--;
89 pc++;
90 }
91 else pc = ret[rp--] + 1;
92 break;
93 case REVERT: /* end of format */
94 if(ptr==NULL)
95 { DO((*doend)('\n'))
96 return(OK);
97 }
98 if(!more) return(OK);
99 if( used_data == NO ) err_f(errflag,F_ERFMT,"\nNo more editing terms in format");
100 used_data = NO;
101 rp=cp=0;
102 pc = p->p1;
103 DO((*dorevert)())
104 break;
105 case COLON:
106 #ifndef KOSHER
107 case DOLAR: /*** NOT STANDARD FORTRAN ***/
108 #endif
109 if (ptr == NULL)
110 { DO((*doend)((char)p->p1))
111 return(OK);
112 }
113 if (!more) return(OK);
114 pc++;
115 break;
116 #ifndef KOSHER
117 case SU: /*** NOT STANDARD FORTRAN ***/
118 #endif
119 case SS:
120 case SP:
121 case S: cplus = p->p1;
122 signit = p->p2;
123 pc++;
124 break;
125 case P:
126 scale = p->p1;
127 pc++;
128 break;
129 #ifndef KOSHER
130 case R: /*** NOT STANDARD FORTRAN ***/
131 radix = p->p1;
132 pc++;
133 break;
134 case B: /*** NOT STANDARD FORTRAN ***/
135 if (external) cblank = curunit->ublnk;
136 else cblank = 0; /* blank = 'NULL' */
137 pc++;
138 break;
139 #endif
140 case BNZ:
141 cblank = p->p1;
142 pc++;
143 break;
144 default:
145 err_f(errflag,F_ERFMT,"impossible code")
146 }
147 }
148 }
149
fmt_bg()150 fmt_bg()
151 {
152 in_mid = NO;
153 cp=rp=pc=cursor=0;
154 cnt[0]=ret[0]=0;
155 used_data = NO;
156 }
157
158 LOCAL
dof_err(n)159 dof_err(n)
160 {
161 if( reading==YES && external==YES && sequential==YES) donewrec();
162 return(errno=n);
163 }
164