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