xref: /original-bsd/usr.bin/f77/libI77/dofio.c (revision f3455753)
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