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 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 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 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 159 dof_err(n) 160 { 161 if( reading==YES && external==YES && sequential==YES) donewrec(); 162 return(errno=n); 163 } 164