12487Sdlw /* 2*2585Sdlw char id_dofio[] = "@(#)dofio.c 1.2"; 32487Sdlw * 42487Sdlw * fortran format executer 52487Sdlw */ 62487Sdlw 72487Sdlw #include "fio.h" 8*2585Sdlw #include "format.h" 92487Sdlw 102487Sdlw #define DO(x) if(n=x) err(n>0?errflag:endflag,n,dfio) 112487Sdlw #define STKSZ 10 122487Sdlw int cnt[STKSZ],ret[STKSZ],cp,rp; 132487Sdlw char *dfio = "dofio"; 142487Sdlw 152487Sdlw en_fio() 162487Sdlw { ftnint one=1; 172487Sdlw return(do_fio(&one,NULL,0l)); 182487Sdlw } 192487Sdlw 202487Sdlw do_fio(number,ptr,len) ftnint *number; ftnlen len; char *ptr; 212487Sdlw { struct syl *p; 222487Sdlw int n,i,more; 232487Sdlw more = *number; 242487Sdlw for(;;) 252487Sdlw switch(type_f((p= &syl[pc])->op)) 262487Sdlw { 272487Sdlw case NED: 282487Sdlw DO((*doned)(p,ptr)) 292487Sdlw pc++; 302487Sdlw break; 312487Sdlw case ED: 322487Sdlw if(ptr==NULL) 332487Sdlw { DO((*doend)('\n')) 342487Sdlw return(OK); 352487Sdlw } 362487Sdlw if(cnt[cp]<=0) 372487Sdlw { cp--; 382487Sdlw pc++; 392487Sdlw break; 402487Sdlw } 412487Sdlw if(!more) return(OK); 422487Sdlw DO((*doed)(p,ptr,len)) 432487Sdlw cnt[cp]--; 442487Sdlw ptr += len; 452487Sdlw more--; 462487Sdlw break; 472487Sdlw case STACK: /* repeat count */ 48*2585Sdlw if(++cp==STKSZ) err(errflag,F_ERFMT,"too many nested ()") 492487Sdlw cnt[cp]=p->p1; 502487Sdlw pc++; 512487Sdlw break; 522487Sdlw case RET: /* open paren */ 53*2585Sdlw if(++rp==STKSZ) err(errflag,F_ERFMT,"too many nested ()") 542487Sdlw ret[rp]=p->p1; 552487Sdlw pc++; 562487Sdlw break; 572487Sdlw case GOTO: /* close paren */ 582487Sdlw if(--cnt[cp]<=0) 592487Sdlw { cp--; 602487Sdlw rp--; 612487Sdlw pc++; 622487Sdlw } 632487Sdlw else pc = ret[rp--] + 1; 642487Sdlw break; 652487Sdlw case REVERT: /* end of format */ 662487Sdlw if(ptr==NULL) 672487Sdlw { DO((*doend)('\n')) 682487Sdlw return(OK); 692487Sdlw } 702487Sdlw if(!more) return(OK); 712487Sdlw rp=cp=0; 722487Sdlw pc = p->p1; 732487Sdlw DO((*dorevert)()) 742487Sdlw break; 752487Sdlw case COLON: 762487Sdlw #ifndef KOSHER 772487Sdlw case DOLAR: /*** NOT STANDARD FORTRAN ***/ 782487Sdlw #endif 792487Sdlw if (ptr == NULL) 802487Sdlw { DO((*doend)((char)p->p1)) 812487Sdlw return(OK); 822487Sdlw } 832487Sdlw if (!more) return(OK); 842487Sdlw pc++; 852487Sdlw break; 862487Sdlw #ifndef KOSHER 872487Sdlw case SU: /*** NOT STANDARD FORTRAN ***/ 882487Sdlw #endif 892487Sdlw case SS: 902487Sdlw case SP: 912487Sdlw case S: cplus = p->p1; 922487Sdlw signit = p->p2; 932487Sdlw pc++; 942487Sdlw break; 952487Sdlw case P: 962487Sdlw scale = p->p1; 972487Sdlw pc++; 982487Sdlw break; 992487Sdlw #ifndef KOSHER 1002487Sdlw case R: /*** NOT STANDARD FORTRAN ***/ 1012487Sdlw radix = p->p1; 1022487Sdlw pc++; 1032487Sdlw break; 1042487Sdlw #endif 1052487Sdlw case BN: 1062487Sdlw case BZ: 1072487Sdlw cblank = p->p1; 1082487Sdlw pc++; 1092487Sdlw break; 1102487Sdlw default: 111*2585Sdlw err(errflag,F_ERFMT,"impossible code") 1122487Sdlw } 1132487Sdlw } 1142487Sdlw 1152487Sdlw fmt_bg() 1162487Sdlw { 1172487Sdlw cp=rp=pc=cursor=0; 1182487Sdlw cnt[0]=ret[0]=0; 1192487Sdlw } 1202487Sdlw 1212487Sdlw type_f(n) 1222487Sdlw { 1232487Sdlw #ifdef DEBUG 1242487Sdlw fprintf(stderr," pc=%d, cnt[%d]=%d, ret[%d]=%d, op=%d\n", 1252487Sdlw pc,cp,cnt[cp],rp,ret[rp],n); /*for debug*/ 1262487Sdlw #endif 1272487Sdlw switch(n) 1282487Sdlw { 1292487Sdlw case X: /* non-editing specifications */ 1302487Sdlw case SLASH: 1312487Sdlw case APOS: case H: 1322487Sdlw case T: case TL: case TR: 1332487Sdlw return(NED); 1342487Sdlw 1352487Sdlw case F: /* editing conversions */ 1362487Sdlw case I: case IM: 1372487Sdlw case A: case AW: 1382487Sdlw case L: 1392487Sdlw case E: case EE: case D: case DE: 1402487Sdlw case G: case GE: 1412487Sdlw return(ED); 1422487Sdlw 1432487Sdlw default: return(n); 1442487Sdlw } 1452487Sdlw } 146