← Back to branch summary

~ubuntu-branches/ubuntu/trusty/libf2c2/trusty

« back to all changes in this revision

Viewing changes to lwrite.c

  • Committer: Bazaar Package Importer
  • Author(s): Alan Bain
  • Date: 2008-05-19 22:50:54 UTC
  • mfrom: (2.1.4 intrepid)
  • Revision ID: james.westby@ubuntu.com-20080519225054-jlymia0wdvvfq7dg
Tags: 20061008-4
Remove CVS directory left in source package

Show diffs side-by-side

added added

removed removed

Lines of Context:
lwrite.c
 
1
#include "f2c.h"
 
2
#include "fio.h"
 
3
#include "fmt.h"
 
4
#include "lio.h"
 
5
#ifdef __cplusplus
 
6
extern "C" {
 
7
#endif
 
8
 
 
9
ftnint L_len;
 
10
int f__Aquote;
 
11
 
 
12
 static VOID
 
13
donewrec(Void)
 
14
{
 
15
        if (f__recpos)
 
16
                (*f__donewrec)();
 
17
        }
 
18
 
 
19
 static VOID
 
20
#ifdef KR_headers
 
21
lwrt_I(n) longint n;
 
22
#else
 
23
lwrt_I(longint n)
 
24
#endif
 
25
{
 
26
        char *p;
 
27
        int ndigit, sign;
 
28
 
 
29
        p = f__icvt(n, &ndigit, &sign, 10);
 
30
        if(f__recpos + ndigit >= L_len)
 
31
                donewrec();
 
32
        PUT(' ');
 
33
        if (sign)
 
34
                PUT('-');
 
35
        while(*p)
 
36
                PUT(*p++);
 
37
}
 
38
 static VOID
 
39
#ifdef KR_headers
 
40
lwrt_L(n, len) ftnint n; ftnlen len;
 
41
#else
 
42
lwrt_L(ftnint n, ftnlen len)
 
43
#endif
 
44
{
 
45
        if(f__recpos+LLOGW>=L_len)
 
46
                donewrec();
 
47
        wrt_L((Uint *)&n,LLOGW, len);
 
48
}
 
49
 static VOID
 
50
#ifdef KR_headers
 
51
lwrt_A(p,len) char *p; ftnlen len;
 
52
#else
 
53
lwrt_A(char *p, ftnlen len)
 
54
#endif
 
55
{
 
56
        int a;
 
57
        char *p1, *pe;
 
58
 
 
59
        a = 0;
 
60
        pe = p + len;
 
61
        if (f__Aquote) {
 
62
                a = 3;
 
63
                if (len > 1 && p[len-1] == ' ') {
 
64
                        while(--len > 1 && p[len-1] == ' ');
 
65
                        pe = p + len;
 
66
                        }
 
67
                p1 = p;
 
68
                while(p1 < pe)
 
69
                        if (*p1++ == '\'')
 
70
                                a++;
 
71
                }
 
72
        if(f__recpos+len+a >= L_len)
 
73
                donewrec();
 
74
        if (a
 
75
#ifndef OMIT_BLANK_CC
 
76
                || !f__recpos
 
77
#endif
 
78
                )
 
79
                PUT(' ');
 
80
        if (a) {
 
81
                PUT('\'');
 
82
                while(p < pe) {
 
83
                        if (*p == '\'')
 
84
                                PUT('\'');
 
85
                        PUT(*p++);
 
86
                        }
 
87
                PUT('\'');
 
88
                }
 
89
        else
 
90
                while(p < pe)
 
91
                        PUT(*p++);
 
92
}
 
93
 
 
94
 static int
 
95
#ifdef KR_headers
 
96
l_g(buf, n) char *buf; double n;
 
97
#else
 
98
l_g(char *buf, double n)
 
99
#endif
 
100
{
 
101
#ifdef Old_list_output
 
102
        doublereal absn;
 
103
        char *fmt;
 
104
 
 
105
        absn = n;
 
106
        if (absn < 0)
 
107
                absn = -absn;
 
108
        fmt = LLOW <= absn && absn < LHIGH ? LFFMT : LEFMT;
 
109
#ifdef USE_STRLEN
 
110
        sprintf(buf, fmt, n);
 
111
        return strlen(buf);
 
112
#else
 
113
        return sprintf(buf, fmt, n);
 
114
#endif
 
115
 
 
116
#else
 
117
        register char *b, c, c1;
 
118
 
 
119
        b = buf;
 
120
        *b++ = ' ';
 
121
        if (n < 0) {
 
122
                *b++ = '-';
 
123
                n = -n;
 
124
                }
 
125
        else
 
126
                *b++ = ' ';
 
127
        if (n == 0) {
 
128
#ifdef SIGNED_ZEROS
 
129
                if (signbit_f2c(&n))
 
130
                        *b++ = '-';
 
131
#endif
 
132
                *b++ = '0';
 
133
                *b++ = '.';
 
134
                *b = 0;
 
135
                goto f__ret;
 
136
                }
 
137
        sprintf(b, LGFMT, n);
 
138
        switch(*b) {
 
139
#ifndef WANT_LEAD_0
 
140
                case '0':
 
141
                        while(b[0] = b[1])
 
142
                                b++;
 
143
                        break;
 
144
#endif
 
145
                case 'i':
 
146
                case 'I':
 
147
                        /* Infinity */
 
148
                case 'n':
 
149
                case 'N':
 
150
                        /* NaN */
 
151
                        while(*++b);
 
152
                        break;
 
153
 
 
154
                default:
 
155
        /* Fortran 77 insists on having a decimal point... */
 
156
                    for(;; b++)
 
157
                        switch(*b) {
 
158
                        case 0:
 
159
                                *b++ = '.';
 
160
                                *b = 0;
 
161
                                goto f__ret;
 
162
                        case '.':
 
163
                                while(*++b);
 
164
                                goto f__ret;
 
165
                        case 'E':
 
166
                                for(c1 = '.', c = 'E';  *b = c1;
 
167
                                        c1 = c, c = *++b);
 
168
                                goto f__ret;
 
169
                        }
 
170
                }
 
171
 f__ret:
 
172
        return b - buf;
 
173
#endif
 
174
        }
 
175
 
 
176
 static VOID
 
177
#ifdef KR_headers
 
178
l_put(s) register char *s;
 
179
#else
 
180
l_put(register char *s)
 
181
#endif
 
182
{
 
183
#ifdef KR_headers
 
184
        register void (*pn)() = f__putn;
 
185
#else
 
186
        register void (*pn)(int) = f__putn;
 
187
#endif
 
188
        register int c;
 
189
 
 
190
        while(c = *s++)
 
191
                (*pn)(c);
 
192
        }
 
193
 
 
194
 static VOID
 
195
#ifdef KR_headers
 
196
lwrt_F(n) double n;
 
197
#else
 
198
lwrt_F(double n)
 
199
#endif
 
200
{
 
201
        char buf[LEFBL];
 
202
 
 
203
        if(f__recpos + l_g(buf,n) >= L_len)
 
204
                donewrec();
 
205
        l_put(buf);
 
206
}
 
207
 static VOID
 
208
#ifdef KR_headers
 
209
lwrt_C(a,b) double a,b;
 
210
#else
 
211
lwrt_C(double a, double b)
 
212
#endif
 
213
{
 
214
        char *ba, *bb, bufa[LEFBL], bufb[LEFBL];
 
215
        int al, bl;
 
216
 
 
217
        al = l_g(bufa, a);
 
218
        for(ba = bufa; *ba == ' '; ba++)
 
219
                --al;
 
220
        bl = l_g(bufb, b) + 1;  /* intentionally high by 1 */
 
221
        for(bb = bufb; *bb == ' '; bb++)
 
222
                --bl;
 
223
        if(f__recpos + al + bl + 3 >= L_len)
 
224
                donewrec();
 
225
#ifdef OMIT_BLANK_CC
 
226
        else
 
227
#endif
 
228
        PUT(' ');
 
229
        PUT('(');
 
230
        l_put(ba);
 
231
        PUT(',');
 
232
        if (f__recpos + bl >= L_len) {
 
233
                (*f__donewrec)();
 
234
#ifndef OMIT_BLANK_CC
 
235
                PUT(' ');
 
236
#endif
 
237
                }
 
238
        l_put(bb);
 
239
        PUT(')');
 
240
}
 
241
 
 
242
 int
 
243
#ifdef KR_headers
 
244
l_write(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
 
245
#else
 
246
l_write(ftnint *number, char *ptr, ftnlen len, ftnint type)
 
247
#endif
 
248
{
 
249
#define Ptr ((flex *)ptr)
 
250
        int i;
 
251
        longint x;
 
252
        double y,z;
 
253
        real *xx;
 
254
        doublereal *yy;
 
255
        for(i=0;i< *number; i++)
 
256
        {
 
257
                switch((int)type)
 
258
                {
 
259
                default: f__fatal(117,"unknown type in lio");
 
260
                case TYINT1:
 
261
                        x = Ptr->flchar;
 
262
                        goto xint;
 
263
                case TYSHORT:
 
264
                        x=Ptr->flshort;
 
265
                        goto xint;
 
266
#ifdef Allow_TYQUAD
 
267
                case TYQUAD:
 
268
                        x = Ptr->fllongint;
 
269
                        goto xint;
 
270
#endif
 
271
                case TYLONG:
 
272
                        x=Ptr->flint;
 
273
                xint:   lwrt_I(x);
 
274
                        break;
 
275
                case TYREAL:
 
276
                        y=Ptr->flreal;
 
277
                        goto xfloat;
 
278
                case TYDREAL:
 
279
                        y=Ptr->fldouble;
 
280
                xfloat: lwrt_F(y);
 
281
                        break;
 
282
                case TYCOMPLEX:
 
283
                        xx= &Ptr->flreal;
 
284
                        y = *xx++;
 
285
                        z = *xx;
 
286
                        goto xcomplex;
 
287
                case TYDCOMPLEX:
 
288
                        yy = &Ptr->fldouble;
 
289
                        y= *yy++;
 
290
                        z = *yy;
 
291
                xcomplex:
 
292
                        lwrt_C(y,z);
 
293
                        break;
 
294
                case TYLOGICAL1:
 
295
                        x = Ptr->flchar;
 
296
                        goto xlog;
 
297
                case TYLOGICAL2:
 
298
                        x = Ptr->flshort;
 
299
                        goto xlog;
 
300
                case TYLOGICAL:
 
301
                        x = Ptr->flint;
 
302
                xlog:   lwrt_L(Ptr->flint, len);
 
303
                        break;
 
304
                case TYCHAR:
 
305
                        lwrt_A(ptr,len);
 
306
                        break;
 
307
                }
 
308
                ptr += len;
 
309
        }
 
310
        return(0);
 
311
}
 
312
#ifdef __cplusplus
 
313
}
 
314
#endif