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