2.9BSD - /usr/src/lib/libI77/dofio.c

   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: }

Defined functions

Defined variables

Defined macros