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