lang/fortran/lib/libI77/wsfe.c

   1 /*write sequential formatted external*/
   2 #include "f2c.h"
   3 #include "fio.h"
   4 #include "fmt.h"
   5 extern int x_putc(),w_ed(),w_ned();
   6 extern int xw_end(),xw_rev(),x_wSL();
   7 extern int hiwater;
   8 integer s_wsfe(a) cilist *a;    /*start*/
   9 {       int n;
  10         if(!init) f_init();
  11         if(n=c_sfe(a)) return(n);
  12         reading=0;
  13         sequential=1;
  14         formatted=1;
  15         external=1;
  16         elist=a;
  17         hiwater = cursor=recpos=0;
  18         nonl = 0;
  19         scale=0;
  20         fmtbuf=a->cifmt;
  21         curunit = &units[a->ciunit];
  22         cf=curunit->ufd;
  23         if(pars_f(fmtbuf)<0) err(a->cierr,100,"startio");
  24         putn= x_putc;
  25         doed= w_ed;
  26         doned= w_ned;
  27         doend=xw_end;
  28         dorevert=xw_rev;
  29         donewrec=x_wSL;
  30         fmt_bg();
  31         cplus=0;
  32         cblank=curunit->ublnk;
  33         if(curunit->uwrt != 1 && nowwriting(curunit))
  34                 err(a->cierr,errno,"write start");
  35         return(0);
  36 }
  37 x_putc(c)
  38 {
  39         /* this uses \n as an indicator of record-end */
  40         if(c == '\n' && recpos < hiwater) {     /* fseek calls fflush, a loss */
  41 #ifndef NON_UNIX_STDIO
  42                 if(cf->_ptr + hiwater - recpos < buf_end(cf))
  43                         cf->_ptr += hiwater - recpos;
  44                 else
  45 #endif
  46                         (void) fseek(cf, (long)(hiwater - recpos), SEEK_CUR);
  47         }
  48         putc(c,cf);
  49         recpos++;
  50 }
  51 pr_put(c)
  52 {       static flag new = 1;
  53         recpos++;
  54         if(c=='\n')
  55         {       new=1;
  56                 putc(c,cf);
  57         }
  58         else if(new==1)
  59         {       new=0;
  60                 if(c=='0') putc('\n',cf);
  61                 else if(c=='1') putc('\f',cf);
  62         }
  63         else putc(c,cf);
  64 }
  65 x_wSL()
  66 {
  67         (*putn)('\n');
  68         recpos=0;
  69         cursor = 0;
  70         hiwater = 0;
  71         return(1);
  72 }
  73 xw_end()
  74 {
  75         if(nonl == 0)
  76                 (*putn)('\n');
  77         hiwater = recpos = cursor = 0;
  78         return(0);
  79 }
  80 xw_rev()
  81 {
  82         if(workdone) (*putn)('\n');
  83         hiwater = recpos = cursor = 0;
  84         return(workdone=0);
  85 }