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