external/bsd/pcc/dist/pcc-libs/libI77/lio.c

   1 /*      $Id: lio.c,v 1.1.1.1 2008/08/24 05:34:47 gmcgarry Exp $ */
   2 /*
   3  * Copyright(C) Caldera International Inc. 2001-2002. All rights reserved.
   4  *
   5  * Redistribution and use in source and binary forms, with or without
   6  * modification, are permitted provided that the following conditions
   7  * are met:
   8  *
   9  * Redistributions of source code and documentation must retain the above
  10  * copyright notice, this list of conditions and the following disclaimer.
  11  * Redistributions in binary form must reproduce the above copyright
  12  * notice, this list of conditionsand the following disclaimer in the
  13  * documentation and/or other materials provided with the distribution.
  14  * All advertising materials mentioning features or use of this software
  15  * must display the following acknowledgement:
  16  *      This product includes software developed or owned by Caldera
  17  *      International, Inc.
  18  * Neither the name of Caldera International, Inc. nor the names of other
  19  * contributors may be used to endorse or promote products derived from
  20  * this software without specific prior written permission.
  21  *
  22  * USE OF THE SOFTWARE PROVIDED FOR UNDER THIS LICENSE BY CALDERA
  23  * INTERNATIONAL, INC. AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR
  24  * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  25  * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
  26  * DISCLAIMED.  IN NO EVENT SHALL CALDERA INTERNATIONAL, INC. BE LIABLE
  27  * FOR ANY DIRECT, INDIRECT INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  28  * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
  29  * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  30  * HOWEVER CAUSED AND ON ANY THEORY OFLIABILITY, WHETHER IN CONTRACT,
  31  * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING
  32  * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
  33  * POSSIBILITY OF SUCH DAMAGE.
  34  */
  35 #include <string.h>
  36
  37 #include "fio.h"
  38 #include "fmt.h"
  39 #include "lio.h"
  40
  41 static int l_write(ftnint *number, flex *ptr,ftnlen len, ftnint type);
  42 static int t_putc(int);
  43 void lwrt_I(ftnint n);
  44 void lwrt_L(ftnint n);
  45 void lwrt_A(char *p, ftnlen len);
  46 void lwrt_F(double n);
  47 void lwrt_C(double a,double b);
  48
  49 int
  50 s_wsle(cilist *a)
  51 {
  52         int n;
  53         if(!init) f_init();
  54         if((n=c_le(a,WRITE))) return(n);
  55         reading=0;
  56         external=1;
  57         formatted=1;
  58         putn = t_putc;
  59         lioproc = l_write;
  60         if(!curunit->uwrt)
  61                 return(nowwriting(curunit));
  62         else    return(0);
  63 }
  64
  65 int
  66 e_wsle()
  67 {
  68         t_putc('\n');
  69         recpos=0;
  70         return(0);
  71 }
  72
  73 int
  74 t_putc(c)
  75 {
  76         recpos++;
  77         putc(c,cf);
  78         return 0;
  79 }
  80
  81 void
  82 lwrt_I(ftnint n)
  83 {
  84         char buf[LINTW],*p;
  85         sprintf(buf," %ld",(long)n);
  86         if(recpos+strlen(buf)>=LINE)
  87         {       t_putc('\n');
  88                 recpos=0;
  89         }
  90         for(p=buf;*p;t_putc(*p++));
  91 }
  92
  93 void
  94 lwrt_L(ftnint n)
  95 {
  96         if(recpos+LLOGW>=LINE)
  97         {       t_putc('\n');
  98                 recpos=0;
  99         }
 100         wrt_L(&n,LLOGW);
 101 }
 102
 103 void
 104 lwrt_A(char *p, ftnlen len)
 105 {
 106         int i;
 107         if(recpos+len>=LINE)
 108         {
 109                 t_putc('\n');
 110                 recpos=0;
 111         }
 112         t_putc(' ');
 113         for(i=0;i<len;i++) t_putc(*p++);
 114 }
 115
 116 void
 117 lwrt_F(double n)
 118 {
 119         ufloat uf;
 120
 121         uf.pd = n;
 122         if(LLOW<=n && n<LHIGH)
 123         {
 124                 if(recpos+LFW>=LINE)
 125                 {
 126                         t_putc('\n');
 127                         recpos=0;
 128                 }
 129                 scale=0;
 130                 wrt_F(&uf,LFW,LFD,(ftnlen)sizeof(uf));
 131         }
 132         else
 133         {
 134                 if(recpos+LEW>=LINE)
 135                 {       t_putc('\n');
 136                         recpos=0;
 137                 }
 138                 wrt_E(&uf,LEW,LED,LEE,(ftnlen)sizeof(uf));
 139         }
 140 }
 141
 142 void
 143 lwrt_C(double a,double b)
 144 {
 145         if(recpos+2*LFW+3>=LINE)
 146         {       t_putc('\n');
 147                 recpos=0;
 148         }
 149         t_putc(' ');
 150         t_putc('(');
 151         lwrt_F(a);
 152         lwrt_F(b);
 153         t_putc(')');
 154 }
 155
 156 int
 157 l_write(ftnint *number, flex *ptr,ftnlen len, ftnint type)
 158 {
 159         int i;
 160         ftnint x;
 161         double y,z;
 162         float *xx;
 163         double *yy;
 164         for(i=0;i< *number; i++)
 165         {
 166                 switch((int)type)
 167                 {
 168                 default: fatal(204,"unknown type in lio");
 169                 case TYSHORT: x=ptr->flshort;
 170                         goto xint;
 171                 case TYLONG: x=ptr->flint;
 172                 xint: lwrt_I(x);
 173                         break;
 174                 case TYREAL: y=ptr->flreal;
 175                         goto xfloat;
 176                 case TYDREAL: y=ptr->fldouble;
 177                 xfloat: lwrt_F(y);
 178                         break;
 179                 case TYCOMPLEX: xx= &(ptr->flreal);
 180                         y = *xx++;
 181                         z = *xx;
 182                         goto xcomplex;
 183                 case TYDCOMPLEX: yy = &(ptr->fldouble);
 184                         y= *yy++;
 185                         z = *yy;
 186                 xcomplex: lwrt_C(y,z);
 187                         break;
 188                 case TYLOGICAL: lwrt_L(ptr->flint);
 189                         break;
 190                 case TYCHAR: lwrt_A((char *)ptr,len);
 191                         break;
 192                 }
 193                 ptr = (flex *)((char *)ptr + len); /* XXX ??? */
 194         }
 195         return(0);
 196 }