|
131
|
1 /* Copyright (C) 2002-2018 Free Software Foundation, Inc.
|
|
111
|
2 Contributed by Andy Vaught
|
|
|
3 Namelist output contributed by Paul Thomas
|
|
|
4 F2003 I/O support contributed by Jerry DeLisle
|
|
|
5
|
|
|
6 This file is part of the GNU Fortran runtime library (libgfortran).
|
|
|
7
|
|
|
8 Libgfortran is free software; you can redistribute it and/or modify
|
|
|
9 it under the terms of the GNU General Public License as published by
|
|
|
10 the Free Software Foundation; either version 3, or (at your option)
|
|
|
11 any later version.
|
|
|
12
|
|
|
13 Libgfortran is distributed in the hope that it will be useful,
|
|
|
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
16 GNU General Public License for more details.
|
|
|
17
|
|
|
18 Under Section 7 of GPL version 3, you are granted additional
|
|
|
19 permissions described in the GCC Runtime Library Exception, version
|
|
|
20 3.1, as published by the Free Software Foundation.
|
|
|
21
|
|
|
22 You should have received a copy of the GNU General Public License and
|
|
|
23 a copy of the GCC Runtime Library Exception along with this program;
|
|
|
24 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|
|
25 <http://www.gnu.org/licenses/>. */
|
|
|
26
|
|
|
27 #include "io.h"
|
|
|
28 #include "fbuf.h"
|
|
|
29 #include "format.h"
|
|
|
30 #include "unix.h"
|
|
|
31 #include <assert.h>
|
|
|
32 #include <string.h>
|
|
|
33 #include <ctype.h>
|
|
|
34
|
|
|
35 #define star_fill(p, n) memset(p, '*', n)
|
|
|
36
|
|
|
37 typedef unsigned char uchar;
|
|
|
38
|
|
|
39 /* Helper functions for character(kind=4) internal units. These are needed
|
|
|
40 by write_float.def. */
|
|
|
41
|
|
|
42 static void
|
|
|
43 memcpy4 (gfc_char4_t *dest, const char *source, int k)
|
|
|
44 {
|
|
|
45 int j;
|
|
|
46
|
|
|
47 const char *p = source;
|
|
|
48 for (j = 0; j < k; j++)
|
|
|
49 *dest++ = (gfc_char4_t) *p++;
|
|
|
50 }
|
|
|
51
|
|
|
52 /* This include contains the heart and soul of formatted floating point. */
|
|
|
53 #include "write_float.def"
|
|
|
54
|
|
|
55 /* Write out default char4. */
|
|
|
56
|
|
|
57 static void
|
|
|
58 write_default_char4 (st_parameter_dt *dtp, const gfc_char4_t *source,
|
|
|
59 int src_len, int w_len)
|
|
|
60 {
|
|
|
61 char *p;
|
|
|
62 int j, k = 0;
|
|
|
63 gfc_char4_t c;
|
|
|
64 uchar d;
|
|
|
65
|
|
|
66 /* Take care of preceding blanks. */
|
|
|
67 if (w_len > src_len)
|
|
|
68 {
|
|
|
69 k = w_len - src_len;
|
|
|
70 p = write_block (dtp, k);
|
|
|
71 if (p == NULL)
|
|
|
72 return;
|
|
|
73 if (is_char4_unit (dtp))
|
|
|
74 {
|
|
|
75 gfc_char4_t *p4 = (gfc_char4_t *) p;
|
|
|
76 memset4 (p4, ' ', k);
|
|
|
77 }
|
|
|
78 else
|
|
|
79 memset (p, ' ', k);
|
|
|
80 }
|
|
|
81
|
|
|
82 /* Get ready to handle delimiters if needed. */
|
|
|
83 switch (dtp->u.p.current_unit->delim_status)
|
|
|
84 {
|
|
|
85 case DELIM_APOSTROPHE:
|
|
|
86 d = '\'';
|
|
|
87 break;
|
|
|
88 case DELIM_QUOTE:
|
|
|
89 d = '"';
|
|
|
90 break;
|
|
|
91 default:
|
|
|
92 d = ' ';
|
|
|
93 break;
|
|
|
94 }
|
|
|
95
|
|
|
96 /* Now process the remaining characters, one at a time. */
|
|
|
97 for (j = 0; j < src_len; j++)
|
|
|
98 {
|
|
|
99 c = source[j];
|
|
|
100 if (is_char4_unit (dtp))
|
|
|
101 {
|
|
|
102 gfc_char4_t *q;
|
|
|
103 /* Handle delimiters if any. */
|
|
|
104 if (c == d && d != ' ')
|
|
|
105 {
|
|
|
106 p = write_block (dtp, 2);
|
|
|
107 if (p == NULL)
|
|
|
108 return;
|
|
|
109 q = (gfc_char4_t *) p;
|
|
|
110 *q++ = c;
|
|
|
111 }
|
|
|
112 else
|
|
|
113 {
|
|
|
114 p = write_block (dtp, 1);
|
|
|
115 if (p == NULL)
|
|
|
116 return;
|
|
|
117 q = (gfc_char4_t *) p;
|
|
|
118 }
|
|
|
119 *q = c;
|
|
|
120 }
|
|
|
121 else
|
|
|
122 {
|
|
|
123 /* Handle delimiters if any. */
|
|
|
124 if (c == d && d != ' ')
|
|
|
125 {
|
|
|
126 p = write_block (dtp, 2);
|
|
|
127 if (p == NULL)
|
|
|
128 return;
|
|
|
129 *p++ = (uchar) c;
|
|
|
130 }
|
|
|
131 else
|
|
|
132 {
|
|
|
133 p = write_block (dtp, 1);
|
|
|
134 if (p == NULL)
|
|
|
135 return;
|
|
|
136 }
|
|
|
137 *p = c > 255 ? '?' : (uchar) c;
|
|
|
138 }
|
|
|
139 }
|
|
|
140 }
|
|
|
141
|
|
|
142
|
|
|
143 /* Write out UTF-8 converted from char4. */
|
|
|
144
|
|
|
145 static void
|
|
|
146 write_utf8_char4 (st_parameter_dt *dtp, gfc_char4_t *source,
|
|
|
147 int src_len, int w_len)
|
|
|
148 {
|
|
|
149 char *p;
|
|
|
150 int j, k = 0;
|
|
|
151 gfc_char4_t c;
|
|
|
152 static const uchar masks[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
|
|
|
153 static const uchar limits[6] = { 0x80, 0xE0, 0xF0, 0xF8, 0xFC, 0xFE };
|
|
|
154 int nbytes;
|
|
|
155 uchar buf[6], d, *q;
|
|
|
156
|
|
|
157 /* Take care of preceding blanks. */
|
|
|
158 if (w_len > src_len)
|
|
|
159 {
|
|
|
160 k = w_len - src_len;
|
|
|
161 p = write_block (dtp, k);
|
|
|
162 if (p == NULL)
|
|
|
163 return;
|
|
|
164 memset (p, ' ', k);
|
|
|
165 }
|
|
|
166
|
|
|
167 /* Get ready to handle delimiters if needed. */
|
|
|
168 switch (dtp->u.p.current_unit->delim_status)
|
|
|
169 {
|
|
|
170 case DELIM_APOSTROPHE:
|
|
|
171 d = '\'';
|
|
|
172 break;
|
|
|
173 case DELIM_QUOTE:
|
|
|
174 d = '"';
|
|
|
175 break;
|
|
|
176 default:
|
|
|
177 d = ' ';
|
|
|
178 break;
|
|
|
179 }
|
|
|
180
|
|
|
181 /* Now process the remaining characters, one at a time. */
|
|
|
182 for (j = k; j < src_len; j++)
|
|
|
183 {
|
|
|
184 c = source[j];
|
|
|
185 if (c < 0x80)
|
|
|
186 {
|
|
|
187 /* Handle the delimiters if any. */
|
|
|
188 if (c == d && d != ' ')
|
|
|
189 {
|
|
|
190 p = write_block (dtp, 2);
|
|
|
191 if (p == NULL)
|
|
|
192 return;
|
|
|
193 *p++ = (uchar) c;
|
|
|
194 }
|
|
|
195 else
|
|
|
196 {
|
|
|
197 p = write_block (dtp, 1);
|
|
|
198 if (p == NULL)
|
|
|
199 return;
|
|
|
200 }
|
|
|
201 *p = (uchar) c;
|
|
|
202 }
|
|
|
203 else
|
|
|
204 {
|
|
|
205 /* Convert to UTF-8 sequence. */
|
|
|
206 nbytes = 1;
|
|
|
207 q = &buf[6];
|
|
|
208
|
|
|
209 do
|
|
|
210 {
|
|
|
211 *--q = ((c & 0x3F) | 0x80);
|
|
|
212 c >>= 6;
|
|
|
213 nbytes++;
|
|
|
214 }
|
|
|
215 while (c >= 0x3F || (c & limits[nbytes-1]));
|
|
|
216
|
|
|
217 *--q = (c | masks[nbytes-1]);
|
|
|
218
|
|
|
219 p = write_block (dtp, nbytes);
|
|
|
220 if (p == NULL)
|
|
|
221 return;
|
|
|
222
|
|
|
223 while (q < &buf[6])
|
|
|
224 *p++ = *q++;
|
|
|
225 }
|
|
|
226 }
|
|
|
227 }
|
|
|
228
|
|
|
229
|
|
|
230 /* Check the first character in source if we are using CC_FORTRAN
|
|
|
231 and set the cc.type appropriately. The cc.type is used later by write_cc
|
|
|
232 to determine the output start-of-record, and next_record_cc to determine the
|
|
|
233 output end-of-record.
|
|
|
234 This function is called before the output buffer is allocated, so alloc_len
|
|
|
235 is set to the appropriate size to allocate. */
|
|
|
236
|
|
|
237 static void
|
|
131
|
238 write_check_cc (st_parameter_dt *dtp, const char **source, size_t *alloc_len)
|
|
111
|
239 {
|
|
|
240 /* Only valid for CARRIAGECONTROL=FORTRAN. */
|
|
|
241 if (dtp->u.p.current_unit->flags.cc != CC_FORTRAN
|
|
|
242 || alloc_len == NULL || source == NULL)
|
|
|
243 return;
|
|
|
244
|
|
|
245 /* Peek at the first character. */
|
|
|
246 int c = (*alloc_len > 0) ? (*source)[0] : EOF;
|
|
|
247 if (c != EOF)
|
|
|
248 {
|
|
|
249 /* The start-of-record character which will be printed. */
|
|
|
250 dtp->u.p.cc.u.start = '\n';
|
|
|
251 /* The number of characters to print at the start-of-record.
|
|
|
252 len > 1 means copy the SOR character multiple times.
|
|
|
253 len == 0 means no SOR will be output. */
|
|
|
254 dtp->u.p.cc.len = 1;
|
|
|
255
|
|
|
256 switch (c)
|
|
|
257 {
|
|
|
258 case '+':
|
|
|
259 dtp->u.p.cc.type = CCF_OVERPRINT;
|
|
|
260 dtp->u.p.cc.len = 0;
|
|
|
261 break;
|
|
|
262 case '-':
|
|
|
263 dtp->u.p.cc.type = CCF_ONE_LF;
|
|
|
264 dtp->u.p.cc.len = 1;
|
|
|
265 break;
|
|
|
266 case '0':
|
|
|
267 dtp->u.p.cc.type = CCF_TWO_LF;
|
|
|
268 dtp->u.p.cc.len = 2;
|
|
|
269 break;
|
|
|
270 case '1':
|
|
|
271 dtp->u.p.cc.type = CCF_PAGE_FEED;
|
|
|
272 dtp->u.p.cc.len = 1;
|
|
|
273 dtp->u.p.cc.u.start = '\f';
|
|
|
274 break;
|
|
|
275 case '$':
|
|
|
276 dtp->u.p.cc.type = CCF_PROMPT;
|
|
|
277 dtp->u.p.cc.len = 1;
|
|
|
278 break;
|
|
|
279 case '\0':
|
|
|
280 dtp->u.p.cc.type = CCF_OVERPRINT_NOA;
|
|
|
281 dtp->u.p.cc.len = 0;
|
|
|
282 break;
|
|
|
283 default:
|
|
|
284 /* In the default case we copy ONE_LF. */
|
|
|
285 dtp->u.p.cc.type = CCF_DEFAULT;
|
|
|
286 dtp->u.p.cc.len = 1;
|
|
|
287 break;
|
|
|
288 }
|
|
|
289
|
|
|
290 /* We add n-1 to alloc_len so our write buffer is the right size.
|
|
|
291 We are replacing the first character, and possibly prepending some
|
|
|
292 additional characters. Note for n==0, we actually subtract one from
|
|
|
293 alloc_len, which is correct, since that character is skipped. */
|
|
|
294 if (*alloc_len > 0)
|
|
|
295 {
|
|
|
296 *source += 1;
|
|
|
297 *alloc_len += dtp->u.p.cc.len - 1;
|
|
|
298 }
|
|
|
299 /* If we have no input, there is no first character to replace. Make
|
|
|
300 sure we still allocate enough space for the start-of-record string. */
|
|
|
301 else
|
|
|
302 *alloc_len = dtp->u.p.cc.len;
|
|
|
303 }
|
|
|
304 }
|
|
|
305
|
|
|
306
|
|
|
307 /* Write the start-of-record character(s) for CC_FORTRAN.
|
|
|
308 Also adjusts the 'cc' struct to contain the end-of-record character
|
|
|
309 for next_record_cc.
|
|
|
310 The source_len is set to the remaining length to copy from the source,
|
|
|
311 after the start-of-record string was inserted. */
|
|
|
312
|
|
|
313 static char *
|
|
131
|
314 write_cc (st_parameter_dt *dtp, char *p, size_t *source_len)
|
|
111
|
315 {
|
|
|
316 /* Only valid for CARRIAGECONTROL=FORTRAN. */
|
|
|
317 if (dtp->u.p.current_unit->flags.cc != CC_FORTRAN || source_len == NULL)
|
|
|
318 return p;
|
|
|
319
|
|
|
320 /* Write the start-of-record string to the output buffer. Note that len is
|
|
|
321 never more than 2. */
|
|
|
322 if (dtp->u.p.cc.len > 0)
|
|
|
323 {
|
|
|
324 *(p++) = dtp->u.p.cc.u.start;
|
|
|
325 if (dtp->u.p.cc.len > 1)
|
|
|
326 *(p++) = dtp->u.p.cc.u.start;
|
|
|
327
|
|
|
328 /* source_len comes from write_check_cc where it is set to the full
|
|
|
329 allocated length of the output buffer. Therefore we subtract off the
|
|
|
330 length of the SOR string to obtain the remaining source length. */
|
|
|
331 *source_len -= dtp->u.p.cc.len;
|
|
|
332 }
|
|
|
333
|
|
|
334 /* Common case. */
|
|
|
335 dtp->u.p.cc.len = 1;
|
|
|
336 dtp->u.p.cc.u.end = '\r';
|
|
|
337
|
|
|
338 /* Update end-of-record character for next_record_w. */
|
|
|
339 switch (dtp->u.p.cc.type)
|
|
|
340 {
|
|
|
341 case CCF_PROMPT:
|
|
|
342 case CCF_OVERPRINT_NOA:
|
|
|
343 /* No end-of-record. */
|
|
|
344 dtp->u.p.cc.len = 0;
|
|
|
345 dtp->u.p.cc.u.end = '\0';
|
|
|
346 break;
|
|
|
347 case CCF_OVERPRINT:
|
|
|
348 case CCF_ONE_LF:
|
|
|
349 case CCF_TWO_LF:
|
|
|
350 case CCF_PAGE_FEED:
|
|
|
351 case CCF_DEFAULT:
|
|
|
352 default:
|
|
|
353 /* Carriage return. */
|
|
|
354 dtp->u.p.cc.len = 1;
|
|
|
355 dtp->u.p.cc.u.end = '\r';
|
|
|
356 break;
|
|
|
357 }
|
|
|
358
|
|
|
359 return p;
|
|
|
360 }
|
|
|
361
|
|
|
362 void
|
|
131
|
363
|
|
|
364 write_a (st_parameter_dt *dtp, const fnode *f, const char *source, size_t len)
|
|
111
|
365 {
|
|
131
|
366 size_t wlen;
|
|
111
|
367 char *p;
|
|
|
368
|
|
|
369 wlen = f->u.string.length < 0
|
|
|
370 || (f->format == FMT_G && f->u.string.length == 0)
|
|
131
|
371 ? len : (size_t) f->u.string.length;
|
|
111
|
372
|
|
|
373 #ifdef HAVE_CRLF
|
|
|
374 /* If this is formatted STREAM IO convert any embedded line feed characters
|
|
|
375 to CR_LF on systems that use that sequence for newlines. See F2003
|
|
|
376 Standard sections 10.6.3 and 9.9 for further information. */
|
|
|
377 if (is_stream_io (dtp))
|
|
|
378 {
|
|
|
379 const char crlf[] = "\r\n";
|
|
131
|
380 size_t q, bytes;
|
|
111
|
381 q = bytes = 0;
|
|
|
382
|
|
|
383 /* Write out any padding if needed. */
|
|
|
384 if (len < wlen)
|
|
|
385 {
|
|
|
386 p = write_block (dtp, wlen - len);
|
|
|
387 if (p == NULL)
|
|
|
388 return;
|
|
|
389 memset (p, ' ', wlen - len);
|
|
|
390 }
|
|
|
391
|
|
|
392 /* Scan the source string looking for '\n' and convert it if found. */
|
|
131
|
393 for (size_t i = 0; i < wlen; i++)
|
|
111
|
394 {
|
|
|
395 if (source[i] == '\n')
|
|
|
396 {
|
|
|
397 /* Write out the previously scanned characters in the string. */
|
|
|
398 if (bytes > 0)
|
|
|
399 {
|
|
|
400 p = write_block (dtp, bytes);
|
|
|
401 if (p == NULL)
|
|
|
402 return;
|
|
|
403 memcpy (p, &source[q], bytes);
|
|
|
404 q += bytes;
|
|
|
405 bytes = 0;
|
|
|
406 }
|
|
|
407
|
|
|
408 /* Write out the CR_LF sequence. */
|
|
|
409 q++;
|
|
|
410 p = write_block (dtp, 2);
|
|
|
411 if (p == NULL)
|
|
|
412 return;
|
|
|
413 memcpy (p, crlf, 2);
|
|
|
414 }
|
|
|
415 else
|
|
|
416 bytes++;
|
|
|
417 }
|
|
|
418
|
|
|
419 /* Write out any remaining bytes if no LF was found. */
|
|
|
420 if (bytes > 0)
|
|
|
421 {
|
|
|
422 p = write_block (dtp, bytes);
|
|
|
423 if (p == NULL)
|
|
|
424 return;
|
|
|
425 memcpy (p, &source[q], bytes);
|
|
|
426 }
|
|
|
427 }
|
|
|
428 else
|
|
|
429 {
|
|
|
430 #endif
|
|
|
431 if (dtp->u.p.current_unit->flags.cc == CC_FORTRAN)
|
|
|
432 write_check_cc (dtp, &source, &wlen);
|
|
|
433
|
|
|
434 p = write_block (dtp, wlen);
|
|
|
435 if (p == NULL)
|
|
|
436 return;
|
|
|
437
|
|
|
438 if (dtp->u.p.current_unit->flags.cc == CC_FORTRAN)
|
|
|
439 p = write_cc (dtp, p, &wlen);
|
|
|
440
|
|
|
441 if (unlikely (is_char4_unit (dtp)))
|
|
|
442 {
|
|
|
443 gfc_char4_t *p4 = (gfc_char4_t *) p;
|
|
|
444 if (wlen < len)
|
|
|
445 memcpy4 (p4, source, wlen);
|
|
|
446 else
|
|
|
447 {
|
|
|
448 memset4 (p4, ' ', wlen - len);
|
|
|
449 memcpy4 (p4 + wlen - len, source, len);
|
|
|
450 }
|
|
|
451 return;
|
|
|
452 }
|
|
|
453
|
|
|
454 if (wlen < len)
|
|
|
455 memcpy (p, source, wlen);
|
|
|
456 else
|
|
|
457 {
|
|
|
458 memset (p, ' ', wlen - len);
|
|
|
459 memcpy (p + wlen - len, source, len);
|
|
|
460 }
|
|
|
461 #ifdef HAVE_CRLF
|
|
|
462 }
|
|
|
463 #endif
|
|
|
464 }
|
|
|
465
|
|
|
466
|
|
|
467 /* The primary difference between write_a_char4 and write_a is that we have to
|
|
|
468 deal with writing from the first byte of the 4-byte character and pay
|
|
|
469 attention to the most significant bytes. For ENCODING="default" write the
|
|
|
470 lowest significant byte. If the 3 most significant bytes contain
|
|
|
471 non-zero values, emit a '?'. For ENCODING="utf-8", convert the UCS-32 value
|
|
|
472 to the UTF-8 encoded string before writing out. */
|
|
|
473
|
|
|
474 void
|
|
131
|
475 write_a_char4 (st_parameter_dt *dtp, const fnode *f, const char *source, size_t len)
|
|
111
|
476 {
|
|
131
|
477 size_t wlen;
|
|
111
|
478 gfc_char4_t *q;
|
|
|
479
|
|
|
480 wlen = f->u.string.length < 0
|
|
|
481 || (f->format == FMT_G && f->u.string.length == 0)
|
|
131
|
482 ? len : (size_t) f->u.string.length;
|
|
111
|
483
|
|
|
484 q = (gfc_char4_t *) source;
|
|
|
485 #ifdef HAVE_CRLF
|
|
|
486 /* If this is formatted STREAM IO convert any embedded line feed characters
|
|
|
487 to CR_LF on systems that use that sequence for newlines. See F2003
|
|
|
488 Standard sections 10.6.3 and 9.9 for further information. */
|
|
|
489 if (is_stream_io (dtp))
|
|
|
490 {
|
|
|
491 const gfc_char4_t crlf[] = {0x000d,0x000a};
|
|
131
|
492 size_t bytes;
|
|
111
|
493 gfc_char4_t *qq;
|
|
|
494 bytes = 0;
|
|
|
495
|
|
|
496 /* Write out any padding if needed. */
|
|
|
497 if (len < wlen)
|
|
|
498 {
|
|
|
499 char *p;
|
|
|
500 p = write_block (dtp, wlen - len);
|
|
|
501 if (p == NULL)
|
|
|
502 return;
|
|
|
503 memset (p, ' ', wlen - len);
|
|
|
504 }
|
|
|
505
|
|
|
506 /* Scan the source string looking for '\n' and convert it if found. */
|
|
|
507 qq = (gfc_char4_t *) source;
|
|
131
|
508 for (size_t i = 0; i < wlen; i++)
|
|
111
|
509 {
|
|
|
510 if (qq[i] == '\n')
|
|
|
511 {
|
|
|
512 /* Write out the previously scanned characters in the string. */
|
|
|
513 if (bytes > 0)
|
|
|
514 {
|
|
|
515 if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
|
|
|
516 write_utf8_char4 (dtp, q, bytes, 0);
|
|
|
517 else
|
|
|
518 write_default_char4 (dtp, q, bytes, 0);
|
|
|
519 bytes = 0;
|
|
|
520 }
|
|
|
521
|
|
|
522 /* Write out the CR_LF sequence. */
|
|
|
523 write_default_char4 (dtp, crlf, 2, 0);
|
|
|
524 }
|
|
|
525 else
|
|
|
526 bytes++;
|
|
|
527 }
|
|
|
528
|
|
|
529 /* Write out any remaining bytes if no LF was found. */
|
|
|
530 if (bytes > 0)
|
|
|
531 {
|
|
|
532 if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
|
|
|
533 write_utf8_char4 (dtp, q, bytes, 0);
|
|
|
534 else
|
|
|
535 write_default_char4 (dtp, q, bytes, 0);
|
|
|
536 }
|
|
|
537 }
|
|
|
538 else
|
|
|
539 {
|
|
|
540 #endif
|
|
|
541 if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
|
|
|
542 write_utf8_char4 (dtp, q, len, wlen);
|
|
|
543 else
|
|
|
544 write_default_char4 (dtp, q, len, wlen);
|
|
|
545 #ifdef HAVE_CRLF
|
|
|
546 }
|
|
|
547 #endif
|
|
|
548 }
|
|
|
549
|
|
|
550
|
|
|
551 static GFC_INTEGER_LARGEST
|
|
|
552 extract_int (const void *p, int len)
|
|
|
553 {
|
|
|
554 GFC_INTEGER_LARGEST i = 0;
|
|
|
555
|
|
|
556 if (p == NULL)
|
|
|
557 return i;
|
|
|
558
|
|
|
559 switch (len)
|
|
|
560 {
|
|
|
561 case 1:
|
|
|
562 {
|
|
|
563 GFC_INTEGER_1 tmp;
|
|
|
564 memcpy ((void *) &tmp, p, len);
|
|
|
565 i = tmp;
|
|
|
566 }
|
|
|
567 break;
|
|
|
568 case 2:
|
|
|
569 {
|
|
|
570 GFC_INTEGER_2 tmp;
|
|
|
571 memcpy ((void *) &tmp, p, len);
|
|
|
572 i = tmp;
|
|
|
573 }
|
|
|
574 break;
|
|
|
575 case 4:
|
|
|
576 {
|
|
|
577 GFC_INTEGER_4 tmp;
|
|
|
578 memcpy ((void *) &tmp, p, len);
|
|
|
579 i = tmp;
|
|
|
580 }
|
|
|
581 break;
|
|
|
582 case 8:
|
|
|
583 {
|
|
|
584 GFC_INTEGER_8 tmp;
|
|
|
585 memcpy ((void *) &tmp, p, len);
|
|
|
586 i = tmp;
|
|
|
587 }
|
|
|
588 break;
|
|
|
589 #ifdef HAVE_GFC_INTEGER_16
|
|
|
590 case 16:
|
|
|
591 {
|
|
|
592 GFC_INTEGER_16 tmp;
|
|
|
593 memcpy ((void *) &tmp, p, len);
|
|
|
594 i = tmp;
|
|
|
595 }
|
|
|
596 break;
|
|
|
597 #endif
|
|
|
598 default:
|
|
|
599 internal_error (NULL, "bad integer kind");
|
|
|
600 }
|
|
|
601
|
|
|
602 return i;
|
|
|
603 }
|
|
|
604
|
|
|
605 static GFC_UINTEGER_LARGEST
|
|
|
606 extract_uint (const void *p, int len)
|
|
|
607 {
|
|
|
608 GFC_UINTEGER_LARGEST i = 0;
|
|
|
609
|
|
|
610 if (p == NULL)
|
|
|
611 return i;
|
|
|
612
|
|
|
613 switch (len)
|
|
|
614 {
|
|
|
615 case 1:
|
|
|
616 {
|
|
|
617 GFC_INTEGER_1 tmp;
|
|
|
618 memcpy ((void *) &tmp, p, len);
|
|
|
619 i = (GFC_UINTEGER_1) tmp;
|
|
|
620 }
|
|
|
621 break;
|
|
|
622 case 2:
|
|
|
623 {
|
|
|
624 GFC_INTEGER_2 tmp;
|
|
|
625 memcpy ((void *) &tmp, p, len);
|
|
|
626 i = (GFC_UINTEGER_2) tmp;
|
|
|
627 }
|
|
|
628 break;
|
|
|
629 case 4:
|
|
|
630 {
|
|
|
631 GFC_INTEGER_4 tmp;
|
|
|
632 memcpy ((void *) &tmp, p, len);
|
|
|
633 i = (GFC_UINTEGER_4) tmp;
|
|
|
634 }
|
|
|
635 break;
|
|
|
636 case 8:
|
|
|
637 {
|
|
|
638 GFC_INTEGER_8 tmp;
|
|
|
639 memcpy ((void *) &tmp, p, len);
|
|
|
640 i = (GFC_UINTEGER_8) tmp;
|
|
|
641 }
|
|
|
642 break;
|
|
|
643 #ifdef HAVE_GFC_INTEGER_16
|
|
|
644 case 10:
|
|
|
645 case 16:
|
|
|
646 {
|
|
|
647 GFC_INTEGER_16 tmp = 0;
|
|
|
648 memcpy ((void *) &tmp, p, len);
|
|
|
649 i = (GFC_UINTEGER_16) tmp;
|
|
|
650 }
|
|
|
651 break;
|
|
|
652 #endif
|
|
|
653 default:
|
|
|
654 internal_error (NULL, "bad integer kind");
|
|
|
655 }
|
|
|
656
|
|
|
657 return i;
|
|
|
658 }
|
|
|
659
|
|
|
660
|
|
|
661 void
|
|
|
662 write_l (st_parameter_dt *dtp, const fnode *f, char *source, int len)
|
|
|
663 {
|
|
|
664 char *p;
|
|
|
665 int wlen;
|
|
|
666 GFC_INTEGER_LARGEST n;
|
|
|
667
|
|
|
668 wlen = (f->format == FMT_G && f->u.w == 0) ? 1 : f->u.w;
|
|
|
669
|
|
|
670 p = write_block (dtp, wlen);
|
|
|
671 if (p == NULL)
|
|
|
672 return;
|
|
|
673
|
|
|
674 n = extract_int (source, len);
|
|
|
675
|
|
|
676 if (unlikely (is_char4_unit (dtp)))
|
|
|
677 {
|
|
|
678 gfc_char4_t *p4 = (gfc_char4_t *) p;
|
|
|
679 memset4 (p4, ' ', wlen -1);
|
|
|
680 p4[wlen - 1] = (n) ? 'T' : 'F';
|
|
|
681 return;
|
|
|
682 }
|
|
|
683
|
|
|
684 memset (p, ' ', wlen -1);
|
|
|
685 p[wlen - 1] = (n) ? 'T' : 'F';
|
|
|
686 }
|
|
|
687
|
|
|
688
|
|
|
689 static void
|
|
|
690 write_boz (st_parameter_dt *dtp, const fnode *f, const char *q, int n)
|
|
|
691 {
|
|
|
692 int w, m, digits, nzero, nblank;
|
|
|
693 char *p;
|
|
|
694
|
|
|
695 w = f->u.integer.w;
|
|
|
696 m = f->u.integer.m;
|
|
|
697
|
|
|
698 /* Special case: */
|
|
|
699
|
|
|
700 if (m == 0 && n == 0)
|
|
|
701 {
|
|
|
702 if (w == 0)
|
|
|
703 w = 1;
|
|
|
704
|
|
|
705 p = write_block (dtp, w);
|
|
|
706 if (p == NULL)
|
|
|
707 return;
|
|
|
708 if (unlikely (is_char4_unit (dtp)))
|
|
|
709 {
|
|
|
710 gfc_char4_t *p4 = (gfc_char4_t *) p;
|
|
|
711 memset4 (p4, ' ', w);
|
|
|
712 }
|
|
|
713 else
|
|
|
714 memset (p, ' ', w);
|
|
|
715 goto done;
|
|
|
716 }
|
|
|
717
|
|
|
718 digits = strlen (q);
|
|
|
719
|
|
|
720 /* Select a width if none was specified. The idea here is to always
|
|
|
721 print something. */
|
|
|
722
|
|
|
723 if (w == 0)
|
|
|
724 w = ((digits < m) ? m : digits);
|
|
|
725
|
|
|
726 p = write_block (dtp, w);
|
|
|
727 if (p == NULL)
|
|
|
728 return;
|
|
|
729
|
|
|
730 nzero = 0;
|
|
|
731 if (digits < m)
|
|
|
732 nzero = m - digits;
|
|
|
733
|
|
|
734 /* See if things will work. */
|
|
|
735
|
|
|
736 nblank = w - (nzero + digits);
|
|
|
737
|
|
|
738 if (unlikely (is_char4_unit (dtp)))
|
|
|
739 {
|
|
|
740 gfc_char4_t *p4 = (gfc_char4_t *) p;
|
|
|
741 if (nblank < 0)
|
|
|
742 {
|
|
|
743 memset4 (p4, '*', w);
|
|
|
744 return;
|
|
|
745 }
|
|
|
746
|
|
|
747 if (!dtp->u.p.no_leading_blank)
|
|
|
748 {
|
|
|
749 memset4 (p4, ' ', nblank);
|
|
|
750 q += nblank;
|
|
|
751 memset4 (p4, '0', nzero);
|
|
|
752 q += nzero;
|
|
|
753 memcpy4 (p4, q, digits);
|
|
|
754 }
|
|
|
755 else
|
|
|
756 {
|
|
|
757 memset4 (p4, '0', nzero);
|
|
|
758 q += nzero;
|
|
|
759 memcpy4 (p4, q, digits);
|
|
|
760 q += digits;
|
|
|
761 memset4 (p4, ' ', nblank);
|
|
|
762 dtp->u.p.no_leading_blank = 0;
|
|
|
763 }
|
|
|
764 return;
|
|
|
765 }
|
|
|
766
|
|
|
767 if (nblank < 0)
|
|
|
768 {
|
|
|
769 star_fill (p, w);
|
|
|
770 goto done;
|
|
|
771 }
|
|
|
772
|
|
|
773 if (!dtp->u.p.no_leading_blank)
|
|
|
774 {
|
|
|
775 memset (p, ' ', nblank);
|
|
|
776 p += nblank;
|
|
|
777 memset (p, '0', nzero);
|
|
|
778 p += nzero;
|
|
|
779 memcpy (p, q, digits);
|
|
|
780 }
|
|
|
781 else
|
|
|
782 {
|
|
|
783 memset (p, '0', nzero);
|
|
|
784 p += nzero;
|
|
|
785 memcpy (p, q, digits);
|
|
|
786 p += digits;
|
|
|
787 memset (p, ' ', nblank);
|
|
|
788 dtp->u.p.no_leading_blank = 0;
|
|
|
789 }
|
|
|
790
|
|
|
791 done:
|
|
|
792 return;
|
|
|
793 }
|
|
|
794
|
|
|
795 static void
|
|
|
796 write_decimal (st_parameter_dt *dtp, const fnode *f, const char *source,
|
|
|
797 int len,
|
|
|
798 const char *(*conv) (GFC_INTEGER_LARGEST, char *, size_t))
|
|
|
799 {
|
|
|
800 GFC_INTEGER_LARGEST n = 0;
|
|
|
801 int w, m, digits, nsign, nzero, nblank;
|
|
|
802 char *p;
|
|
|
803 const char *q;
|
|
|
804 sign_t sign;
|
|
|
805 char itoa_buf[GFC_BTOA_BUF_SIZE];
|
|
|
806
|
|
|
807 w = f->u.integer.w;
|
|
|
808 m = f->format == FMT_G ? -1 : f->u.integer.m;
|
|
|
809
|
|
|
810 n = extract_int (source, len);
|
|
|
811
|
|
|
812 /* Special case: */
|
|
|
813 if (m == 0 && n == 0)
|
|
|
814 {
|
|
|
815 if (w == 0)
|
|
|
816 w = 1;
|
|
|
817
|
|
|
818 p = write_block (dtp, w);
|
|
|
819 if (p == NULL)
|
|
|
820 return;
|
|
|
821 if (unlikely (is_char4_unit (dtp)))
|
|
|
822 {
|
|
|
823 gfc_char4_t *p4 = (gfc_char4_t *) p;
|
|
|
824 memset4 (p4, ' ', w);
|
|
|
825 }
|
|
|
826 else
|
|
|
827 memset (p, ' ', w);
|
|
|
828 goto done;
|
|
|
829 }
|
|
|
830
|
|
|
831 sign = calculate_sign (dtp, n < 0);
|
|
|
832 if (n < 0)
|
|
|
833 n = -n;
|
|
|
834 nsign = sign == S_NONE ? 0 : 1;
|
|
|
835
|
|
|
836 /* conv calls itoa which sets the negative sign needed
|
|
|
837 by write_integer. The sign '+' or '-' is set below based on sign
|
|
|
838 calculated above, so we just point past the sign in the string
|
|
|
839 before proceeding to avoid double signs in corner cases.
|
|
|
840 (see PR38504) */
|
|
|
841 q = conv (n, itoa_buf, sizeof (itoa_buf));
|
|
|
842 if (*q == '-')
|
|
|
843 q++;
|
|
|
844
|
|
|
845 digits = strlen (q);
|
|
|
846
|
|
|
847 /* Select a width if none was specified. The idea here is to always
|
|
|
848 print something. */
|
|
|
849
|
|
|
850 if (w == 0)
|
|
|
851 w = ((digits < m) ? m : digits) + nsign;
|
|
|
852
|
|
|
853 p = write_block (dtp, w);
|
|
|
854 if (p == NULL)
|
|
|
855 return;
|
|
|
856
|
|
|
857 nzero = 0;
|
|
|
858 if (digits < m)
|
|
|
859 nzero = m - digits;
|
|
|
860
|
|
|
861 /* See if things will work. */
|
|
|
862
|
|
|
863 nblank = w - (nsign + nzero + digits);
|
|
|
864
|
|
|
865 if (unlikely (is_char4_unit (dtp)))
|
|
|
866 {
|
|
|
867 gfc_char4_t *p4 = (gfc_char4_t *)p;
|
|
|
868 if (nblank < 0)
|
|
|
869 {
|
|
|
870 memset4 (p4, '*', w);
|
|
|
871 goto done;
|
|
|
872 }
|
|
|
873
|
|
131
|
874 if (!dtp->u.p.namelist_mode)
|
|
|
875 {
|
|
|
876 memset4 (p4, ' ', nblank);
|
|
|
877 p4 += nblank;
|
|
|
878 }
|
|
111
|
879
|
|
|
880 switch (sign)
|
|
|
881 {
|
|
|
882 case S_PLUS:
|
|
|
883 *p4++ = '+';
|
|
|
884 break;
|
|
|
885 case S_MINUS:
|
|
|
886 *p4++ = '-';
|
|
|
887 break;
|
|
|
888 case S_NONE:
|
|
|
889 break;
|
|
|
890 }
|
|
|
891
|
|
|
892 memset4 (p4, '0', nzero);
|
|
|
893 p4 += nzero;
|
|
|
894
|
|
|
895 memcpy4 (p4, q, digits);
|
|
|
896 return;
|
|
131
|
897
|
|
|
898 if (dtp->u.p.namelist_mode)
|
|
|
899 {
|
|
|
900 p4 += digits;
|
|
|
901 memset4 (p4, ' ', nblank);
|
|
|
902 }
|
|
111
|
903 }
|
|
|
904
|
|
|
905 if (nblank < 0)
|
|
|
906 {
|
|
|
907 star_fill (p, w);
|
|
|
908 goto done;
|
|
|
909 }
|
|
|
910
|
|
131
|
911 if (!dtp->u.p.namelist_mode)
|
|
|
912 {
|
|
|
913 memset (p, ' ', nblank);
|
|
|
914 p += nblank;
|
|
|
915 }
|
|
111
|
916
|
|
|
917 switch (sign)
|
|
|
918 {
|
|
|
919 case S_PLUS:
|
|
|
920 *p++ = '+';
|
|
|
921 break;
|
|
|
922 case S_MINUS:
|
|
|
923 *p++ = '-';
|
|
|
924 break;
|
|
|
925 case S_NONE:
|
|
|
926 break;
|
|
|
927 }
|
|
|
928
|
|
|
929 memset (p, '0', nzero);
|
|
|
930 p += nzero;
|
|
|
931
|
|
|
932 memcpy (p, q, digits);
|
|
|
933
|
|
131
|
934 if (dtp->u.p.namelist_mode)
|
|
|
935 {
|
|
|
936 p += digits;
|
|
|
937 memset (p, ' ', nblank);
|
|
|
938 }
|
|
|
939
|
|
111
|
940 done:
|
|
|
941 return;
|
|
|
942 }
|
|
|
943
|
|
|
944
|
|
|
945 /* Convert unsigned octal to ascii. */
|
|
|
946
|
|
|
947 static const char *
|
|
|
948 otoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
|
|
|
949 {
|
|
|
950 char *p;
|
|
|
951
|
|
|
952 assert (len >= GFC_OTOA_BUF_SIZE);
|
|
|
953
|
|
|
954 if (n == 0)
|
|
|
955 return "0";
|
|
|
956
|
|
|
957 p = buffer + GFC_OTOA_BUF_SIZE - 1;
|
|
|
958 *p = '\0';
|
|
|
959
|
|
|
960 while (n != 0)
|
|
|
961 {
|
|
|
962 *--p = '0' + (n & 7);
|
|
|
963 n >>= 3;
|
|
|
964 }
|
|
|
965
|
|
|
966 return p;
|
|
|
967 }
|
|
|
968
|
|
|
969
|
|
|
970 /* Convert unsigned binary to ascii. */
|
|
|
971
|
|
|
972 static const char *
|
|
|
973 btoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
|
|
|
974 {
|
|
|
975 char *p;
|
|
|
976
|
|
|
977 assert (len >= GFC_BTOA_BUF_SIZE);
|
|
|
978
|
|
|
979 if (n == 0)
|
|
|
980 return "0";
|
|
|
981
|
|
|
982 p = buffer + GFC_BTOA_BUF_SIZE - 1;
|
|
|
983 *p = '\0';
|
|
|
984
|
|
|
985 while (n != 0)
|
|
|
986 {
|
|
|
987 *--p = '0' + (n & 1);
|
|
|
988 n >>= 1;
|
|
|
989 }
|
|
|
990
|
|
|
991 return p;
|
|
|
992 }
|
|
|
993
|
|
|
994 /* The following three functions, btoa_big, otoa_big, and ztoa_big, are needed
|
|
|
995 to convert large reals with kind sizes that exceed the largest integer type
|
|
|
996 available on certain platforms. In these cases, byte by byte conversion is
|
|
|
997 performed. Endianess is taken into account. */
|
|
|
998
|
|
|
999 /* Conversion to binary. */
|
|
|
1000
|
|
|
1001 static const char *
|
|
|
1002 btoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
|
|
|
1003 {
|
|
|
1004 char *q;
|
|
|
1005 int i, j;
|
|
|
1006
|
|
|
1007 q = buffer;
|
|
131
|
1008 if (__BYTE_ORDER__ == __ORDER_BIG_ENDIAN__)
|
|
111
|
1009 {
|
|
|
1010 const char *p = s;
|
|
|
1011 for (i = 0; i < len; i++)
|
|
|
1012 {
|
|
|
1013 char c = *p;
|
|
|
1014
|
|
|
1015 /* Test for zero. Needed by write_boz later. */
|
|
|
1016 if (*p != 0)
|
|
|
1017 *n = 1;
|
|
|
1018
|
|
|
1019 for (j = 0; j < 8; j++)
|
|
|
1020 {
|
|
|
1021 *q++ = (c & 128) ? '1' : '0';
|
|
|
1022 c <<= 1;
|
|
|
1023 }
|
|
|
1024 p++;
|
|
|
1025 }
|
|
|
1026 }
|
|
|
1027 else
|
|
|
1028 {
|
|
|
1029 const char *p = s + len - 1;
|
|
|
1030 for (i = 0; i < len; i++)
|
|
|
1031 {
|
|
|
1032 char c = *p;
|
|
|
1033
|
|
|
1034 /* Test for zero. Needed by write_boz later. */
|
|
|
1035 if (*p != 0)
|
|
|
1036 *n = 1;
|
|
|
1037
|
|
|
1038 for (j = 0; j < 8; j++)
|
|
|
1039 {
|
|
|
1040 *q++ = (c & 128) ? '1' : '0';
|
|
|
1041 c <<= 1;
|
|
|
1042 }
|
|
|
1043 p--;
|
|
|
1044 }
|
|
|
1045 }
|
|
|
1046
|
|
|
1047 *q = '\0';
|
|
|
1048
|
|
|
1049 if (*n == 0)
|
|
|
1050 return "0";
|
|
|
1051
|
|
|
1052 /* Move past any leading zeros. */
|
|
|
1053 while (*buffer == '0')
|
|
|
1054 buffer++;
|
|
|
1055
|
|
|
1056 return buffer;
|
|
|
1057
|
|
|
1058 }
|
|
|
1059
|
|
|
1060 /* Conversion to octal. */
|
|
|
1061
|
|
|
1062 static const char *
|
|
|
1063 otoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
|
|
|
1064 {
|
|
|
1065 char *q;
|
|
|
1066 int i, j, k;
|
|
|
1067 uint8_t octet;
|
|
|
1068
|
|
|
1069 q = buffer + GFC_OTOA_BUF_SIZE - 1;
|
|
|
1070 *q = '\0';
|
|
|
1071 i = k = octet = 0;
|
|
|
1072
|
|
131
|
1073 if (__BYTE_ORDER__ == __ORDER_BIG_ENDIAN__)
|
|
111
|
1074 {
|
|
|
1075 const char *p = s + len - 1;
|
|
|
1076 char c = *p;
|
|
|
1077 while (i < len)
|
|
|
1078 {
|
|
|
1079 /* Test for zero. Needed by write_boz later. */
|
|
|
1080 if (*p != 0)
|
|
|
1081 *n = 1;
|
|
|
1082
|
|
|
1083 for (j = 0; j < 3 && i < len; j++)
|
|
|
1084 {
|
|
|
1085 octet |= (c & 1) << j;
|
|
|
1086 c >>= 1;
|
|
|
1087 if (++k > 7)
|
|
|
1088 {
|
|
|
1089 i++;
|
|
|
1090 k = 0;
|
|
|
1091 c = *--p;
|
|
|
1092 }
|
|
|
1093 }
|
|
|
1094 *--q = '0' + octet;
|
|
|
1095 octet = 0;
|
|
|
1096 }
|
|
|
1097 }
|
|
|
1098 else
|
|
|
1099 {
|
|
|
1100 const char *p = s;
|
|
|
1101 char c = *p;
|
|
|
1102 while (i < len)
|
|
|
1103 {
|
|
|
1104 /* Test for zero. Needed by write_boz later. */
|
|
|
1105 if (*p != 0)
|
|
|
1106 *n = 1;
|
|
|
1107
|
|
|
1108 for (j = 0; j < 3 && i < len; j++)
|
|
|
1109 {
|
|
|
1110 octet |= (c & 1) << j;
|
|
|
1111 c >>= 1;
|
|
|
1112 if (++k > 7)
|
|
|
1113 {
|
|
|
1114 i++;
|
|
|
1115 k = 0;
|
|
|
1116 c = *++p;
|
|
|
1117 }
|
|
|
1118 }
|
|
|
1119 *--q = '0' + octet;
|
|
|
1120 octet = 0;
|
|
|
1121 }
|
|
|
1122 }
|
|
|
1123
|
|
|
1124 if (*n == 0)
|
|
|
1125 return "0";
|
|
|
1126
|
|
|
1127 /* Move past any leading zeros. */
|
|
|
1128 while (*q == '0')
|
|
|
1129 q++;
|
|
|
1130
|
|
|
1131 return q;
|
|
|
1132 }
|
|
|
1133
|
|
|
1134 /* Conversion to hexidecimal. */
|
|
|
1135
|
|
|
1136 static const char *
|
|
|
1137 ztoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
|
|
|
1138 {
|
|
|
1139 static char a[16] = {'0', '1', '2', '3', '4', '5', '6', '7',
|
|
|
1140 '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'};
|
|
|
1141
|
|
|
1142 char *q;
|
|
|
1143 uint8_t h, l;
|
|
|
1144 int i;
|
|
|
1145
|
|
|
1146 q = buffer;
|
|
|
1147
|
|
131
|
1148 if (__BYTE_ORDER__ == __ORDER_BIG_ENDIAN__)
|
|
111
|
1149 {
|
|
|
1150 const char *p = s;
|
|
|
1151 for (i = 0; i < len; i++)
|
|
|
1152 {
|
|
|
1153 /* Test for zero. Needed by write_boz later. */
|
|
|
1154 if (*p != 0)
|
|
|
1155 *n = 1;
|
|
|
1156
|
|
|
1157 h = (*p >> 4) & 0x0F;
|
|
|
1158 l = *p++ & 0x0F;
|
|
|
1159 *q++ = a[h];
|
|
|
1160 *q++ = a[l];
|
|
|
1161 }
|
|
|
1162 }
|
|
|
1163 else
|
|
|
1164 {
|
|
|
1165 const char *p = s + len - 1;
|
|
|
1166 for (i = 0; i < len; i++)
|
|
|
1167 {
|
|
|
1168 /* Test for zero. Needed by write_boz later. */
|
|
|
1169 if (*p != 0)
|
|
|
1170 *n = 1;
|
|
|
1171
|
|
|
1172 h = (*p >> 4) & 0x0F;
|
|
|
1173 l = *p-- & 0x0F;
|
|
|
1174 *q++ = a[h];
|
|
|
1175 *q++ = a[l];
|
|
|
1176 }
|
|
|
1177 }
|
|
|
1178
|
|
|
1179 *q = '\0';
|
|
|
1180
|
|
|
1181 if (*n == 0)
|
|
|
1182 return "0";
|
|
|
1183
|
|
|
1184 /* Move past any leading zeros. */
|
|
|
1185 while (*buffer == '0')
|
|
|
1186 buffer++;
|
|
|
1187
|
|
|
1188 return buffer;
|
|
|
1189 }
|
|
|
1190
|
|
|
1191
|
|
|
1192 void
|
|
|
1193 write_i (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
|
|
|
1194 {
|
|
|
1195 write_decimal (dtp, f, p, len, (void *) gfc_itoa);
|
|
|
1196 }
|
|
|
1197
|
|
|
1198
|
|
|
1199 void
|
|
|
1200 write_b (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
|
|
|
1201 {
|
|
|
1202 const char *p;
|
|
|
1203 char itoa_buf[GFC_BTOA_BUF_SIZE];
|
|
|
1204 GFC_UINTEGER_LARGEST n = 0;
|
|
|
1205
|
|
|
1206 if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
|
|
|
1207 {
|
|
|
1208 p = btoa_big (source, itoa_buf, len, &n);
|
|
|
1209 write_boz (dtp, f, p, n);
|
|
|
1210 }
|
|
|
1211 else
|
|
|
1212 {
|
|
|
1213 n = extract_uint (source, len);
|
|
|
1214 p = btoa (n, itoa_buf, sizeof (itoa_buf));
|
|
|
1215 write_boz (dtp, f, p, n);
|
|
|
1216 }
|
|
|
1217 }
|
|
|
1218
|
|
|
1219
|
|
|
1220 void
|
|
|
1221 write_o (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
|
|
|
1222 {
|
|
|
1223 const char *p;
|
|
|
1224 char itoa_buf[GFC_OTOA_BUF_SIZE];
|
|
|
1225 GFC_UINTEGER_LARGEST n = 0;
|
|
|
1226
|
|
|
1227 if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
|
|
|
1228 {
|
|
|
1229 p = otoa_big (source, itoa_buf, len, &n);
|
|
|
1230 write_boz (dtp, f, p, n);
|
|
|
1231 }
|
|
|
1232 else
|
|
|
1233 {
|
|
|
1234 n = extract_uint (source, len);
|
|
|
1235 p = otoa (n, itoa_buf, sizeof (itoa_buf));
|
|
|
1236 write_boz (dtp, f, p, n);
|
|
|
1237 }
|
|
|
1238 }
|
|
|
1239
|
|
|
1240 void
|
|
|
1241 write_z (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
|
|
|
1242 {
|
|
|
1243 const char *p;
|
|
|
1244 char itoa_buf[GFC_XTOA_BUF_SIZE];
|
|
|
1245 GFC_UINTEGER_LARGEST n = 0;
|
|
|
1246
|
|
|
1247 if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
|
|
|
1248 {
|
|
|
1249 p = ztoa_big (source, itoa_buf, len, &n);
|
|
|
1250 write_boz (dtp, f, p, n);
|
|
|
1251 }
|
|
|
1252 else
|
|
|
1253 {
|
|
|
1254 n = extract_uint (source, len);
|
|
|
1255 p = gfc_xtoa (n, itoa_buf, sizeof (itoa_buf));
|
|
|
1256 write_boz (dtp, f, p, n);
|
|
|
1257 }
|
|
|
1258 }
|
|
|
1259
|
|
|
1260 /* Take care of the X/TR descriptor. */
|
|
|
1261
|
|
|
1262 void
|
|
|
1263 write_x (st_parameter_dt *dtp, int len, int nspaces)
|
|
|
1264 {
|
|
|
1265 char *p;
|
|
|
1266
|
|
|
1267 p = write_block (dtp, len);
|
|
|
1268 if (p == NULL)
|
|
|
1269 return;
|
|
|
1270 if (nspaces > 0 && len - nspaces >= 0)
|
|
|
1271 {
|
|
|
1272 if (unlikely (is_char4_unit (dtp)))
|
|
|
1273 {
|
|
|
1274 gfc_char4_t *p4 = (gfc_char4_t *) p;
|
|
|
1275 memset4 (&p4[len - nspaces], ' ', nspaces);
|
|
|
1276 }
|
|
|
1277 else
|
|
|
1278 memset (&p[len - nspaces], ' ', nspaces);
|
|
|
1279 }
|
|
|
1280 }
|
|
|
1281
|
|
|
1282
|
|
|
1283 /* List-directed writing. */
|
|
|
1284
|
|
|
1285
|
|
|
1286 /* Write a single character to the output. Returns nonzero if
|
|
|
1287 something goes wrong. */
|
|
|
1288
|
|
|
1289 static int
|
|
|
1290 write_char (st_parameter_dt *dtp, int c)
|
|
|
1291 {
|
|
|
1292 char *p;
|
|
|
1293
|
|
|
1294 p = write_block (dtp, 1);
|
|
|
1295 if (p == NULL)
|
|
|
1296 return 1;
|
|
|
1297 if (unlikely (is_char4_unit (dtp)))
|
|
|
1298 {
|
|
|
1299 gfc_char4_t *p4 = (gfc_char4_t *) p;
|
|
|
1300 *p4 = c;
|
|
|
1301 return 0;
|
|
|
1302 }
|
|
|
1303
|
|
|
1304 *p = (uchar) c;
|
|
|
1305
|
|
|
1306 return 0;
|
|
|
1307 }
|
|
|
1308
|
|
|
1309
|
|
|
1310 /* Write a list-directed logical value. */
|
|
|
1311
|
|
|
1312 static void
|
|
|
1313 write_logical (st_parameter_dt *dtp, const char *source, int length)
|
|
|
1314 {
|
|
|
1315 write_char (dtp, extract_int (source, length) ? 'T' : 'F');
|
|
|
1316 }
|
|
|
1317
|
|
|
1318
|
|
|
1319 /* Write a list-directed integer value. */
|
|
|
1320
|
|
|
1321 static void
|
|
131
|
1322 write_integer (st_parameter_dt *dtp, const char *source, int kind)
|
|
111
|
1323 {
|
|
|
1324 int width;
|
|
131
|
1325 fnode f;
|
|
111
|
1326
|
|
131
|
1327 switch (kind)
|
|
111
|
1328 {
|
|
|
1329 case 1:
|
|
|
1330 width = 4;
|
|
|
1331 break;
|
|
|
1332
|
|
|
1333 case 2:
|
|
|
1334 width = 6;
|
|
|
1335 break;
|
|
|
1336
|
|
|
1337 case 4:
|
|
|
1338 width = 11;
|
|
|
1339 break;
|
|
|
1340
|
|
|
1341 case 8:
|
|
|
1342 width = 20;
|
|
|
1343 break;
|
|
|
1344
|
|
|
1345 default:
|
|
|
1346 width = 0;
|
|
|
1347 break;
|
|
|
1348 }
|
|
131
|
1349 f.u.integer.w = width;
|
|
|
1350 f.u.integer.m = -1;
|
|
|
1351 f.format = FMT_NONE;
|
|
|
1352 write_decimal (dtp, &f, source, kind, (void *) gfc_itoa);
|
|
111
|
1353 }
|
|
|
1354
|
|
|
1355
|
|
|
1356 /* Write a list-directed string. We have to worry about delimiting
|
|
|
1357 the strings if the file has been opened in that mode. */
|
|
|
1358
|
|
|
1359 #define DELIM 1
|
|
|
1360 #define NODELIM 0
|
|
|
1361
|
|
|
1362 static void
|
|
131
|
1363 write_character (st_parameter_dt *dtp, const char *source, int kind, size_t length, int mode)
|
|
111
|
1364 {
|
|
131
|
1365 size_t extra;
|
|
111
|
1366 char *p, d;
|
|
|
1367
|
|
|
1368 if (mode == DELIM)
|
|
|
1369 {
|
|
|
1370 switch (dtp->u.p.current_unit->delim_status)
|
|
|
1371 {
|
|
|
1372 case DELIM_APOSTROPHE:
|
|
|
1373 d = '\'';
|
|
|
1374 break;
|
|
|
1375 case DELIM_QUOTE:
|
|
|
1376 d = '"';
|
|
|
1377 break;
|
|
|
1378 default:
|
|
|
1379 d = ' ';
|
|
|
1380 break;
|
|
|
1381 }
|
|
|
1382 }
|
|
|
1383 else
|
|
|
1384 d = ' ';
|
|
|
1385
|
|
|
1386 if (kind == 1)
|
|
|
1387 {
|
|
|
1388 if (d == ' ')
|
|
|
1389 extra = 0;
|
|
|
1390 else
|
|
|
1391 {
|
|
|
1392 extra = 2;
|
|
|
1393
|
|
131
|
1394 for (size_t i = 0; i < length; i++)
|
|
111
|
1395 if (source[i] == d)
|
|
|
1396 extra++;
|
|
|
1397 }
|
|
|
1398
|
|
|
1399 p = write_block (dtp, length + extra);
|
|
|
1400 if (p == NULL)
|
|
|
1401 return;
|
|
|
1402
|
|
|
1403 if (unlikely (is_char4_unit (dtp)))
|
|
|
1404 {
|
|
|
1405 gfc_char4_t d4 = (gfc_char4_t) d;
|
|
|
1406 gfc_char4_t *p4 = (gfc_char4_t *) p;
|
|
|
1407
|
|
|
1408 if (d4 == ' ')
|
|
|
1409 memcpy4 (p4, source, length);
|
|
|
1410 else
|
|
|
1411 {
|
|
|
1412 *p4++ = d4;
|
|
|
1413
|
|
131
|
1414 for (size_t i = 0; i < length; i++)
|
|
111
|
1415 {
|
|
|
1416 *p4++ = (gfc_char4_t) source[i];
|
|
|
1417 if (source[i] == d)
|
|
|
1418 *p4++ = d4;
|
|
|
1419 }
|
|
|
1420
|
|
|
1421 *p4 = d4;
|
|
|
1422 }
|
|
|
1423 return;
|
|
|
1424 }
|
|
|
1425
|
|
|
1426 if (d == ' ')
|
|
|
1427 memcpy (p, source, length);
|
|
|
1428 else
|
|
|
1429 {
|
|
|
1430 *p++ = d;
|
|
|
1431
|
|
131
|
1432 for (size_t i = 0; i < length; i++)
|
|
111
|
1433 {
|
|
|
1434 *p++ = source[i];
|
|
|
1435 if (source[i] == d)
|
|
|
1436 *p++ = d;
|
|
|
1437 }
|
|
|
1438
|
|
|
1439 *p = d;
|
|
|
1440 }
|
|
|
1441 }
|
|
|
1442 else
|
|
|
1443 {
|
|
|
1444 if (d == ' ')
|
|
|
1445 {
|
|
|
1446 if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
|
|
|
1447 write_utf8_char4 (dtp, (gfc_char4_t *) source, length, 0);
|
|
|
1448 else
|
|
|
1449 write_default_char4 (dtp, (gfc_char4_t *) source, length, 0);
|
|
|
1450 }
|
|
|
1451 else
|
|
|
1452 {
|
|
|
1453 p = write_block (dtp, 1);
|
|
|
1454 *p = d;
|
|
|
1455
|
|
|
1456 if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
|
|
|
1457 write_utf8_char4 (dtp, (gfc_char4_t *) source, length, 0);
|
|
|
1458 else
|
|
|
1459 write_default_char4 (dtp, (gfc_char4_t *) source, length, 0);
|
|
|
1460
|
|
|
1461 p = write_block (dtp, 1);
|
|
|
1462 *p = d;
|
|
|
1463 }
|
|
|
1464 }
|
|
|
1465 }
|
|
|
1466
|
|
|
1467 /* Floating point helper functions. */
|
|
|
1468
|
|
131
|
1469 #define BUF_STACK_SZ 384
|
|
111
|
1470
|
|
|
1471 static int
|
|
|
1472 get_precision (st_parameter_dt *dtp, const fnode *f, const char *source, int kind)
|
|
|
1473 {
|
|
|
1474 if (f->format != FMT_EN)
|
|
|
1475 return determine_precision (dtp, f, kind);
|
|
|
1476 else
|
|
|
1477 return determine_en_precision (dtp, f, source, kind);
|
|
|
1478 }
|
|
|
1479
|
|
|
1480 /* 4932 is the maximum exponent of long double and quad precision, 3
|
|
|
1481 extra characters for the sign, the decimal point, and the
|
|
|
1482 trailing null. Extra digits are added by the calling functions for
|
|
|
1483 requested precision. Likewise for float and double. F0 editing produces
|
|
|
1484 full precision output. */
|
|
|
1485 static int
|
|
|
1486 size_from_kind (st_parameter_dt *dtp, const fnode *f, int kind)
|
|
|
1487 {
|
|
|
1488 int size;
|
|
|
1489
|
|
|
1490 if (f->format == FMT_F && f->u.real.w == 0)
|
|
|
1491 {
|
|
|
1492 switch (kind)
|
|
|
1493 {
|
|
|
1494 case 4:
|
|
|
1495 size = 38 + 3; /* These constants shown for clarity. */
|
|
|
1496 break;
|
|
|
1497 case 8:
|
|
|
1498 size = 308 + 3;
|
|
|
1499 break;
|
|
|
1500 case 10:
|
|
|
1501 size = 4932 + 3;
|
|
|
1502 break;
|
|
|
1503 case 16:
|
|
|
1504 size = 4932 + 3;
|
|
|
1505 break;
|
|
|
1506 default:
|
|
|
1507 internal_error (&dtp->common, "bad real kind");
|
|
|
1508 break;
|
|
|
1509 }
|
|
|
1510 }
|
|
|
1511 else
|
|
|
1512 size = f->u.real.w + 1; /* One byte for a NULL character. */
|
|
|
1513
|
|
|
1514 return size;
|
|
|
1515 }
|
|
|
1516
|
|
|
1517 static char *
|
|
|
1518 select_buffer (st_parameter_dt *dtp, const fnode *f, int precision,
|
|
|
1519 char *buf, size_t *size, int kind)
|
|
|
1520 {
|
|
|
1521 char *result;
|
|
|
1522
|
|
131
|
1523 /* The buffer needs at least one more byte to allow room for
|
|
|
1524 normalizing and 1 to hold null terminator. */
|
|
|
1525 *size = size_from_kind (dtp, f, kind) + precision + 1 + 1;
|
|
111
|
1526
|
|
|
1527 if (*size > BUF_STACK_SZ)
|
|
|
1528 result = xmalloc (*size);
|
|
|
1529 else
|
|
|
1530 result = buf;
|
|
|
1531 return result;
|
|
|
1532 }
|
|
|
1533
|
|
|
1534 static char *
|
|
|
1535 select_string (st_parameter_dt *dtp, const fnode *f, char *buf, size_t *size,
|
|
|
1536 int kind)
|
|
|
1537 {
|
|
|
1538 char *result;
|
|
131
|
1539 *size = size_from_kind (dtp, f, kind) + f->u.real.d + 1;
|
|
111
|
1540 if (*size > BUF_STACK_SZ)
|
|
|
1541 result = xmalloc (*size);
|
|
|
1542 else
|
|
|
1543 result = buf;
|
|
|
1544 return result;
|
|
|
1545 }
|
|
|
1546
|
|
|
1547 static void
|
|
|
1548 write_float_string (st_parameter_dt *dtp, char *fstr, size_t len)
|
|
|
1549 {
|
|
|
1550 char *p = write_block (dtp, len);
|
|
|
1551 if (p == NULL)
|
|
|
1552 return;
|
|
|
1553
|
|
|
1554 if (unlikely (is_char4_unit (dtp)))
|
|
|
1555 {
|
|
|
1556 gfc_char4_t *p4 = (gfc_char4_t *) p;
|
|
|
1557 memcpy4 (p4, fstr, len);
|
|
|
1558 return;
|
|
|
1559 }
|
|
|
1560 memcpy (p, fstr, len);
|
|
|
1561 }
|
|
|
1562
|
|
|
1563
|
|
|
1564 static void
|
|
|
1565 write_float_0 (st_parameter_dt *dtp, const fnode *f, const char *source, int kind)
|
|
|
1566 {
|
|
|
1567 char buf_stack[BUF_STACK_SZ];
|
|
|
1568 char str_buf[BUF_STACK_SZ];
|
|
|
1569 char *buffer, *result;
|
|
131
|
1570 size_t buf_size, res_len, flt_str_len;
|
|
111
|
1571
|
|
|
1572 /* Precision for snprintf call. */
|
|
|
1573 int precision = get_precision (dtp, f, source, kind);
|
|
|
1574
|
|
|
1575 /* String buffer to hold final result. */
|
|
|
1576 result = select_string (dtp, f, str_buf, &res_len, kind);
|
|
131
|
1577
|
|
111
|
1578 buffer = select_buffer (dtp, f, precision, buf_stack, &buf_size, kind);
|
|
131
|
1579
|
|
111
|
1580 get_float_string (dtp, f, source , kind, 0, buffer,
|
|
131
|
1581 precision, buf_size, result, &flt_str_len);
|
|
|
1582 write_float_string (dtp, result, flt_str_len);
|
|
111
|
1583
|
|
|
1584 if (buf_size > BUF_STACK_SZ)
|
|
|
1585 free (buffer);
|
|
|
1586 if (res_len > BUF_STACK_SZ)
|
|
|
1587 free (result);
|
|
|
1588 }
|
|
|
1589
|
|
|
1590 void
|
|
|
1591 write_d (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
|
|
|
1592 {
|
|
|
1593 write_float_0 (dtp, f, p, len);
|
|
|
1594 }
|
|
|
1595
|
|
|
1596
|
|
|
1597 void
|
|
|
1598 write_e (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
|
|
|
1599 {
|
|
|
1600 write_float_0 (dtp, f, p, len);
|
|
|
1601 }
|
|
|
1602
|
|
|
1603
|
|
|
1604 void
|
|
|
1605 write_f (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
|
|
|
1606 {
|
|
|
1607 write_float_0 (dtp, f, p, len);
|
|
|
1608 }
|
|
|
1609
|
|
|
1610
|
|
|
1611 void
|
|
|
1612 write_en (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
|
|
|
1613 {
|
|
|
1614 write_float_0 (dtp, f, p, len);
|
|
|
1615 }
|
|
|
1616
|
|
|
1617
|
|
|
1618 void
|
|
|
1619 write_es (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
|
|
|
1620 {
|
|
|
1621 write_float_0 (dtp, f, p, len);
|
|
|
1622 }
|
|
|
1623
|
|
|
1624
|
|
|
1625 /* Set an fnode to default format. */
|
|
|
1626
|
|
|
1627 static void
|
|
|
1628 set_fnode_default (st_parameter_dt *dtp, fnode *f, int length)
|
|
|
1629 {
|
|
|
1630 f->format = FMT_G;
|
|
|
1631 switch (length)
|
|
|
1632 {
|
|
|
1633 case 4:
|
|
|
1634 f->u.real.w = 16;
|
|
|
1635 f->u.real.d = 9;
|
|
|
1636 f->u.real.e = 2;
|
|
|
1637 break;
|
|
|
1638 case 8:
|
|
|
1639 f->u.real.w = 25;
|
|
|
1640 f->u.real.d = 17;
|
|
|
1641 f->u.real.e = 3;
|
|
|
1642 break;
|
|
|
1643 case 10:
|
|
|
1644 f->u.real.w = 30;
|
|
|
1645 f->u.real.d = 21;
|
|
|
1646 f->u.real.e = 4;
|
|
|
1647 break;
|
|
|
1648 case 16:
|
|
|
1649 /* Adjust decimal precision depending on binary precision, 106 or 113. */
|
|
|
1650 #if GFC_REAL_16_DIGITS == 113
|
|
|
1651 f->u.real.w = 45;
|
|
|
1652 f->u.real.d = 36;
|
|
|
1653 f->u.real.e = 4;
|
|
|
1654 #else
|
|
|
1655 f->u.real.w = 41;
|
|
|
1656 f->u.real.d = 32;
|
|
|
1657 f->u.real.e = 4;
|
|
|
1658 #endif
|
|
|
1659 break;
|
|
|
1660 default:
|
|
|
1661 internal_error (&dtp->common, "bad real kind");
|
|
|
1662 break;
|
|
|
1663 }
|
|
|
1664 }
|
|
|
1665
|
|
|
1666 /* Output a real number with default format.
|
|
|
1667 To guarantee that a binary -> decimal -> binary roundtrip conversion
|
|
|
1668 recovers the original value, IEEE 754-2008 requires 9, 17, 21 and 36
|
|
|
1669 significant digits for REAL kinds 4, 8, 10, and 16, respectively.
|
|
|
1670 Thus, we use 1PG16.9E2 for REAL(4), 1PG25.17E3 for REAL(8), 1PG30.21E4
|
|
|
1671 for REAL(10) and 1PG45.36E4 for REAL(16). The exception is that the
|
|
|
1672 Fortran standard requires outputting an extra digit when the scale
|
|
|
1673 factor is 1 and when the magnitude of the value is such that E
|
|
|
1674 editing is used. However, gfortran compensates for this, and thus
|
|
|
1675 for list formatted the same number of significant digits is
|
|
|
1676 generated both when using F and E editing. */
|
|
|
1677
|
|
|
1678 void
|
|
|
1679 write_real (st_parameter_dt *dtp, const char *source, int kind)
|
|
|
1680 {
|
|
|
1681 fnode f ;
|
|
|
1682 char buf_stack[BUF_STACK_SZ];
|
|
|
1683 char str_buf[BUF_STACK_SZ];
|
|
|
1684 char *buffer, *result;
|
|
131
|
1685 size_t buf_size, res_len, flt_str_len;
|
|
111
|
1686 int orig_scale = dtp->u.p.scale_factor;
|
|
|
1687 dtp->u.p.scale_factor = 1;
|
|
|
1688 set_fnode_default (dtp, &f, kind);
|
|
|
1689
|
|
|
1690 /* Precision for snprintf call. */
|
|
|
1691 int precision = get_precision (dtp, &f, source, kind);
|
|
|
1692
|
|
|
1693 /* String buffer to hold final result. */
|
|
|
1694 result = select_string (dtp, &f, str_buf, &res_len, kind);
|
|
|
1695
|
|
|
1696 /* Scratch buffer to hold final result. */
|
|
|
1697 buffer = select_buffer (dtp, &f, precision, buf_stack, &buf_size, kind);
|
|
|
1698
|
|
|
1699 get_float_string (dtp, &f, source , kind, 1, buffer,
|
|
131
|
1700 precision, buf_size, result, &flt_str_len);
|
|
|
1701 write_float_string (dtp, result, flt_str_len);
|
|
111
|
1702
|
|
|
1703 dtp->u.p.scale_factor = orig_scale;
|
|
|
1704 if (buf_size > BUF_STACK_SZ)
|
|
|
1705 free (buffer);
|
|
|
1706 if (res_len > BUF_STACK_SZ)
|
|
|
1707 free (result);
|
|
|
1708 }
|
|
|
1709
|
|
|
1710 /* Similar to list formatted REAL output, for kPG0 where k > 0 we
|
|
|
1711 compensate for the extra digit. */
|
|
|
1712
|
|
|
1713 void
|
|
|
1714 write_real_g0 (st_parameter_dt *dtp, const char *source, int kind, int d)
|
|
|
1715 {
|
|
|
1716 fnode f;
|
|
|
1717 char buf_stack[BUF_STACK_SZ];
|
|
|
1718 char str_buf[BUF_STACK_SZ];
|
|
|
1719 char *buffer, *result;
|
|
131
|
1720 size_t buf_size, res_len, flt_str_len;
|
|
111
|
1721 int comp_d;
|
|
|
1722 set_fnode_default (dtp, &f, kind);
|
|
|
1723
|
|
|
1724 if (d > 0)
|
|
|
1725 f.u.real.d = d;
|
|
|
1726
|
|
|
1727 /* Compensate for extra digits when using scale factor, d is not
|
|
|
1728 specified, and the magnitude is such that E editing is used. */
|
|
|
1729 if (dtp->u.p.scale_factor > 0 && d == 0)
|
|
|
1730 comp_d = 1;
|
|
|
1731 else
|
|
|
1732 comp_d = 0;
|
|
|
1733 dtp->u.p.g0_no_blanks = 1;
|
|
|
1734
|
|
|
1735 /* Precision for snprintf call. */
|
|
|
1736 int precision = get_precision (dtp, &f, source, kind);
|
|
|
1737
|
|
|
1738 /* String buffer to hold final result. */
|
|
|
1739 result = select_string (dtp, &f, str_buf, &res_len, kind);
|
|
|
1740
|
|
|
1741 buffer = select_buffer (dtp, &f, precision, buf_stack, &buf_size, kind);
|
|
|
1742
|
|
|
1743 get_float_string (dtp, &f, source , kind, comp_d, buffer,
|
|
131
|
1744 precision, buf_size, result, &flt_str_len);
|
|
|
1745 write_float_string (dtp, result, flt_str_len);
|
|
111
|
1746
|
|
|
1747 dtp->u.p.g0_no_blanks = 0;
|
|
|
1748 if (buf_size > BUF_STACK_SZ)
|
|
|
1749 free (buffer);
|
|
|
1750 if (res_len > BUF_STACK_SZ)
|
|
|
1751 free (result);
|
|
|
1752 }
|
|
|
1753
|
|
|
1754
|
|
|
1755 static void
|
|
|
1756 write_complex (st_parameter_dt *dtp, const char *source, int kind, size_t size)
|
|
|
1757 {
|
|
|
1758 char semi_comma =
|
|
|
1759 dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';';
|
|
|
1760
|
|
|
1761 /* Set for no blanks so we get a string result with no leading
|
|
|
1762 blanks. We will pad left later. */
|
|
|
1763 dtp->u.p.g0_no_blanks = 1;
|
|
|
1764
|
|
|
1765 fnode f ;
|
|
|
1766 char buf_stack[BUF_STACK_SZ];
|
|
|
1767 char str1_buf[BUF_STACK_SZ];
|
|
|
1768 char str2_buf[BUF_STACK_SZ];
|
|
|
1769 char *buffer, *result1, *result2;
|
|
131
|
1770 size_t buf_size, res_len1, res_len2, flt_str_len1, flt_str_len2;
|
|
111
|
1771 int width, lblanks, orig_scale = dtp->u.p.scale_factor;
|
|
|
1772
|
|
|
1773 dtp->u.p.scale_factor = 1;
|
|
|
1774 set_fnode_default (dtp, &f, kind);
|
|
|
1775
|
|
|
1776 /* Set width for two values, parenthesis, and comma. */
|
|
|
1777 width = 2 * f.u.real.w + 3;
|
|
|
1778
|
|
|
1779 /* Set for no blanks so we get a string result with no leading
|
|
|
1780 blanks. We will pad left later. */
|
|
|
1781 dtp->u.p.g0_no_blanks = 1;
|
|
|
1782
|
|
|
1783 /* Precision for snprintf call. */
|
|
|
1784 int precision = get_precision (dtp, &f, source, kind);
|
|
|
1785
|
|
|
1786 /* String buffers to hold final result. */
|
|
|
1787 result1 = select_string (dtp, &f, str1_buf, &res_len1, kind);
|
|
|
1788 result2 = select_string (dtp, &f, str2_buf, &res_len2, kind);
|
|
|
1789
|
|
|
1790 buffer = select_buffer (dtp, &f, precision, buf_stack, &buf_size, kind);
|
|
|
1791
|
|
|
1792 get_float_string (dtp, &f, source , kind, 0, buffer,
|
|
131
|
1793 precision, buf_size, result1, &flt_str_len1);
|
|
111
|
1794 get_float_string (dtp, &f, source + size / 2 , kind, 0, buffer,
|
|
131
|
1795 precision, buf_size, result2, &flt_str_len2);
|
|
|
1796 if (!dtp->u.p.namelist_mode)
|
|
|
1797 {
|
|
|
1798 lblanks = width - flt_str_len1 - flt_str_len2 - 3;
|
|
|
1799 write_x (dtp, lblanks, lblanks);
|
|
|
1800 }
|
|
111
|
1801 write_char (dtp, '(');
|
|
131
|
1802 write_float_string (dtp, result1, flt_str_len1);
|
|
111
|
1803 write_char (dtp, semi_comma);
|
|
131
|
1804 write_float_string (dtp, result2, flt_str_len2);
|
|
111
|
1805 write_char (dtp, ')');
|
|
|
1806
|
|
|
1807 dtp->u.p.scale_factor = orig_scale;
|
|
|
1808 dtp->u.p.g0_no_blanks = 0;
|
|
|
1809 if (buf_size > BUF_STACK_SZ)
|
|
|
1810 free (buffer);
|
|
|
1811 if (res_len1 > BUF_STACK_SZ)
|
|
|
1812 free (result1);
|
|
|
1813 if (res_len2 > BUF_STACK_SZ)
|
|
|
1814 free (result2);
|
|
|
1815 }
|
|
|
1816
|
|
|
1817
|
|
|
1818 /* Write the separator between items. */
|
|
|
1819
|
|
|
1820 static void
|
|
|
1821 write_separator (st_parameter_dt *dtp)
|
|
|
1822 {
|
|
|
1823 char *p;
|
|
|
1824
|
|
|
1825 p = write_block (dtp, options.separator_len);
|
|
|
1826 if (p == NULL)
|
|
|
1827 return;
|
|
|
1828 if (unlikely (is_char4_unit (dtp)))
|
|
|
1829 {
|
|
|
1830 gfc_char4_t *p4 = (gfc_char4_t *) p;
|
|
|
1831 memcpy4 (p4, options.separator, options.separator_len);
|
|
|
1832 }
|
|
|
1833 else
|
|
|
1834 memcpy (p, options.separator, options.separator_len);
|
|
|
1835 }
|
|
|
1836
|
|
|
1837
|
|
|
1838 /* Write an item with list formatting.
|
|
|
1839 TODO: handle skipping to the next record correctly, particularly
|
|
|
1840 with strings. */
|
|
|
1841
|
|
|
1842 static void
|
|
|
1843 list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
|
|
|
1844 size_t size)
|
|
|
1845 {
|
|
|
1846 if (dtp->u.p.current_unit == NULL)
|
|
|
1847 return;
|
|
|
1848
|
|
|
1849 if (dtp->u.p.first_item)
|
|
|
1850 {
|
|
|
1851 dtp->u.p.first_item = 0;
|
|
|
1852 if (dtp->u.p.current_unit->flags.cc != CC_FORTRAN)
|
|
|
1853 write_char (dtp, ' ');
|
|
|
1854 }
|
|
|
1855 else
|
|
|
1856 {
|
|
|
1857 if (type != BT_CHARACTER || !dtp->u.p.char_flag ||
|
|
|
1858 (dtp->u.p.current_unit->delim_status != DELIM_NONE
|
|
|
1859 && dtp->u.p.current_unit->delim_status != DELIM_UNSPECIFIED))
|
|
|
1860 write_separator (dtp);
|
|
|
1861 }
|
|
|
1862
|
|
|
1863 switch (type)
|
|
|
1864 {
|
|
|
1865 case BT_INTEGER:
|
|
|
1866 write_integer (dtp, p, kind);
|
|
|
1867 break;
|
|
|
1868 case BT_LOGICAL:
|
|
|
1869 write_logical (dtp, p, kind);
|
|
|
1870 break;
|
|
|
1871 case BT_CHARACTER:
|
|
|
1872 write_character (dtp, p, kind, size, DELIM);
|
|
|
1873 break;
|
|
|
1874 case BT_REAL:
|
|
|
1875 write_real (dtp, p, kind);
|
|
|
1876 break;
|
|
|
1877 case BT_COMPLEX:
|
|
|
1878 write_complex (dtp, p, kind, size);
|
|
|
1879 break;
|
|
|
1880 case BT_CLASS:
|
|
|
1881 {
|
|
|
1882 int unit = dtp->u.p.current_unit->unit_number;
|
|
|
1883 char iotype[] = "LISTDIRECTED";
|
|
|
1884 gfc_charlen_type iotype_len = 12;
|
|
|
1885 char tmp_iomsg[IOMSG_LEN] = "";
|
|
|
1886 char *child_iomsg;
|
|
|
1887 gfc_charlen_type child_iomsg_len;
|
|
|
1888 int noiostat;
|
|
|
1889 int *child_iostat = NULL;
|
|
131
|
1890 gfc_full_array_i4 vlist;
|
|
111
|
1891
|
|
|
1892 GFC_DESCRIPTOR_DATA(&vlist) = NULL;
|
|
|
1893 GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0);
|
|
|
1894
|
|
|
1895 /* Set iostat, intent(out). */
|
|
|
1896 noiostat = 0;
|
|
|
1897 child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
|
|
|
1898 dtp->common.iostat : &noiostat;
|
|
|
1899
|
|
|
1900 /* Set iomsge, intent(inout). */
|
|
|
1901 if (dtp->common.flags & IOPARM_HAS_IOMSG)
|
|
|
1902 {
|
|
|
1903 child_iomsg = dtp->common.iomsg;
|
|
|
1904 child_iomsg_len = dtp->common.iomsg_len;
|
|
|
1905 }
|
|
|
1906 else
|
|
|
1907 {
|
|
|
1908 child_iomsg = tmp_iomsg;
|
|
|
1909 child_iomsg_len = IOMSG_LEN;
|
|
|
1910 }
|
|
|
1911
|
|
|
1912 /* Call the user defined formatted WRITE procedure. */
|
|
|
1913 dtp->u.p.current_unit->child_dtio++;
|
|
|
1914 dtp->u.p.fdtio_ptr (p, &unit, iotype, &vlist,
|
|
|
1915 child_iostat, child_iomsg,
|
|
|
1916 iotype_len, child_iomsg_len);
|
|
|
1917 dtp->u.p.current_unit->child_dtio--;
|
|
|
1918 }
|
|
|
1919 break;
|
|
|
1920 default:
|
|
|
1921 internal_error (&dtp->common, "list_formatted_write(): Bad type");
|
|
|
1922 }
|
|
|
1923
|
|
|
1924 fbuf_flush_list (dtp->u.p.current_unit, LIST_WRITING);
|
|
|
1925 dtp->u.p.char_flag = (type == BT_CHARACTER);
|
|
|
1926 }
|
|
|
1927
|
|
|
1928
|
|
|
1929 void
|
|
|
1930 list_formatted_write (st_parameter_dt *dtp, bt type, void *p, int kind,
|
|
|
1931 size_t size, size_t nelems)
|
|
|
1932 {
|
|
|
1933 size_t elem;
|
|
|
1934 char *tmp;
|
|
|
1935 size_t stride = type == BT_CHARACTER ?
|
|
|
1936 size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
|
|
|
1937
|
|
|
1938 tmp = (char *) p;
|
|
|
1939
|
|
|
1940 /* Big loop over all the elements. */
|
|
|
1941 for (elem = 0; elem < nelems; elem++)
|
|
|
1942 {
|
|
|
1943 dtp->u.p.item_count++;
|
|
|
1944 list_formatted_write_scalar (dtp, type, tmp + elem * stride, kind, size);
|
|
|
1945 }
|
|
|
1946 }
|
|
|
1947
|
|
|
1948 /* NAMELIST OUTPUT
|
|
|
1949
|
|
|
1950 nml_write_obj writes a namelist object to the output stream. It is called
|
|
|
1951 recursively for derived type components:
|
|
|
1952 obj = is the namelist_info for the current object.
|
|
|
1953 offset = the offset relative to the address held by the object for
|
|
|
1954 derived type arrays.
|
|
|
1955 base = is the namelist_info of the derived type, when obj is a
|
|
|
1956 component.
|
|
|
1957 base_name = the full name for a derived type, including qualifiers
|
|
|
1958 if any.
|
|
|
1959 The returned value is a pointer to the object beyond the last one
|
|
|
1960 accessed, including nested derived types. Notice that the namelist is
|
|
|
1961 a linear linked list of objects, including derived types and their
|
|
|
1962 components. A tree, of sorts, is implied by the compound names of
|
|
|
1963 the derived type components and this is how this function recurses through
|
|
|
1964 the list. */
|
|
|
1965
|
|
|
1966 /* A generous estimate of the number of characters needed to print
|
|
|
1967 repeat counts and indices, including commas, asterices and brackets. */
|
|
|
1968
|
|
|
1969 #define NML_DIGITS 20
|
|
|
1970
|
|
|
1971 static void
|
|
|
1972 namelist_write_newline (st_parameter_dt *dtp)
|
|
|
1973 {
|
|
|
1974 if (!is_internal_unit (dtp))
|
|
|
1975 {
|
|
|
1976 #ifdef HAVE_CRLF
|
|
|
1977 write_character (dtp, "\r\n", 1, 2, NODELIM);
|
|
|
1978 #else
|
|
|
1979 write_character (dtp, "\n", 1, 1, NODELIM);
|
|
|
1980 #endif
|
|
|
1981 return;
|
|
|
1982 }
|
|
|
1983
|
|
|
1984 if (is_array_io (dtp))
|
|
|
1985 {
|
|
|
1986 gfc_offset record;
|
|
|
1987 int finished;
|
|
|
1988 char *p;
|
|
|
1989 int length = dtp->u.p.current_unit->bytes_left;
|
|
|
1990
|
|
|
1991 p = write_block (dtp, length);
|
|
|
1992 if (p == NULL)
|
|
|
1993 return;
|
|
|
1994
|
|
|
1995 if (unlikely (is_char4_unit (dtp)))
|
|
|
1996 {
|
|
|
1997 gfc_char4_t *p4 = (gfc_char4_t *) p;
|
|
|
1998 memset4 (p4, ' ', length);
|
|
|
1999 }
|
|
|
2000 else
|
|
|
2001 memset (p, ' ', length);
|
|
|
2002
|
|
|
2003 /* Now that the current record has been padded out,
|
|
|
2004 determine where the next record in the array is. */
|
|
|
2005 record = next_array_record (dtp, dtp->u.p.current_unit->ls,
|
|
|
2006 &finished);
|
|
|
2007 if (finished)
|
|
|
2008 dtp->u.p.current_unit->endfile = AT_ENDFILE;
|
|
|
2009 else
|
|
|
2010 {
|
|
|
2011 /* Now seek to this record */
|
|
|
2012 record = record * dtp->u.p.current_unit->recl;
|
|
|
2013
|
|
|
2014 if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
|
|
|
2015 {
|
|
|
2016 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
|
|
|
2017 return;
|
|
|
2018 }
|
|
|
2019
|
|
|
2020 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
|
|
|
2021 }
|
|
|
2022 }
|
|
|
2023 else
|
|
|
2024 write_character (dtp, " ", 1, 1, NODELIM);
|
|
|
2025 }
|
|
|
2026
|
|
|
2027
|
|
|
2028 static namelist_info *
|
|
|
2029 nml_write_obj (st_parameter_dt *dtp, namelist_info *obj, index_type offset,
|
|
|
2030 namelist_info *base, char *base_name)
|
|
|
2031 {
|
|
|
2032 int rep_ctr;
|
|
|
2033 int num;
|
|
|
2034 int nml_carry;
|
|
|
2035 int len;
|
|
|
2036 index_type obj_size;
|
|
|
2037 index_type nelem;
|
|
|
2038 size_t dim_i;
|
|
|
2039 size_t clen;
|
|
|
2040 index_type elem_ctr;
|
|
|
2041 size_t obj_name_len;
|
|
|
2042 void *p;
|
|
|
2043 char cup;
|
|
|
2044 char *obj_name;
|
|
|
2045 char *ext_name;
|
|
|
2046 char *q;
|
|
|
2047 size_t ext_name_len;
|
|
|
2048 char rep_buff[NML_DIGITS];
|
|
|
2049 namelist_info *cmp;
|
|
|
2050 namelist_info *retval = obj->next;
|
|
|
2051 size_t base_name_len;
|
|
|
2052 size_t base_var_name_len;
|
|
|
2053 size_t tot_len;
|
|
|
2054
|
|
|
2055 /* Set the character to be used to separate values
|
|
|
2056 to a comma or semi-colon. */
|
|
|
2057
|
|
|
2058 char semi_comma =
|
|
|
2059 dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';';
|
|
|
2060
|
|
|
2061 /* Write namelist variable names in upper case. If a derived type,
|
|
|
2062 nothing is output. If a component, base and base_name are set. */
|
|
|
2063
|
|
|
2064 if (obj->type != BT_DERIVED || obj->dtio_sub != NULL)
|
|
|
2065 {
|
|
|
2066 namelist_write_newline (dtp);
|
|
|
2067 write_character (dtp, " ", 1, 1, NODELIM);
|
|
|
2068
|
|
|
2069 len = 0;
|
|
|
2070 if (base)
|
|
|
2071 {
|
|
|
2072 len = strlen (base->var_name);
|
|
|
2073 base_name_len = strlen (base_name);
|
|
|
2074 for (dim_i = 0; dim_i < base_name_len; dim_i++)
|
|
|
2075 {
|
|
|
2076 cup = toupper ((int) base_name[dim_i]);
|
|
|
2077 write_character (dtp, &cup, 1, 1, NODELIM);
|
|
|
2078 }
|
|
|
2079 }
|
|
|
2080 clen = strlen (obj->var_name);
|
|
|
2081 for (dim_i = len; dim_i < clen; dim_i++)
|
|
|
2082 {
|
|
|
2083 cup = toupper ((int) obj->var_name[dim_i]);
|
|
|
2084 if (cup == '+')
|
|
|
2085 cup = '%';
|
|
|
2086 write_character (dtp, &cup, 1, 1, NODELIM);
|
|
|
2087 }
|
|
|
2088 write_character (dtp, "=", 1, 1, NODELIM);
|
|
|
2089 }
|
|
|
2090
|
|
|
2091 /* Counts the number of data output on a line, including names. */
|
|
|
2092
|
|
|
2093 num = 1;
|
|
|
2094
|
|
|
2095 len = obj->len;
|
|
|
2096
|
|
|
2097 switch (obj->type)
|
|
|
2098 {
|
|
|
2099
|
|
|
2100 case BT_REAL:
|
|
|
2101 obj_size = size_from_real_kind (len);
|
|
|
2102 break;
|
|
|
2103
|
|
|
2104 case BT_COMPLEX:
|
|
|
2105 obj_size = size_from_complex_kind (len);
|
|
|
2106 break;
|
|
|
2107
|
|
|
2108 case BT_CHARACTER:
|
|
|
2109 obj_size = obj->string_length;
|
|
|
2110 break;
|
|
|
2111
|
|
|
2112 default:
|
|
|
2113 obj_size = len;
|
|
|
2114 }
|
|
|
2115
|
|
|
2116 if (obj->var_rank)
|
|
|
2117 obj_size = obj->size;
|
|
|
2118
|
|
|
2119 /* Set the index vector and count the number of elements. */
|
|
|
2120
|
|
|
2121 nelem = 1;
|
|
|
2122 for (dim_i = 0; dim_i < (size_t) obj->var_rank; dim_i++)
|
|
|
2123 {
|
|
|
2124 obj->ls[dim_i].idx = GFC_DESCRIPTOR_LBOUND(obj, dim_i);
|
|
|
2125 nelem = nelem * GFC_DESCRIPTOR_EXTENT (obj, dim_i);
|
|
|
2126 }
|
|
|
2127
|
|
|
2128 /* Main loop to output the data held in the object. */
|
|
|
2129
|
|
|
2130 rep_ctr = 1;
|
|
|
2131 for (elem_ctr = 0; elem_ctr < nelem; elem_ctr++)
|
|
|
2132 {
|
|
|
2133
|
|
|
2134 /* Build the pointer to the data value. The offset is passed by
|
|
|
2135 recursive calls to this function for arrays of derived types.
|
|
|
2136 Is NULL otherwise. */
|
|
|
2137
|
|
|
2138 p = (void *)(obj->mem_pos + elem_ctr * obj_size);
|
|
|
2139 p += offset;
|
|
|
2140
|
|
|
2141 /* Check for repeat counts of intrinsic types. */
|
|
|
2142
|
|
|
2143 if ((elem_ctr < (nelem - 1)) &&
|
|
|
2144 (obj->type != BT_DERIVED) &&
|
|
|
2145 !memcmp (p, (void *)(p + obj_size ), obj_size ))
|
|
|
2146 {
|
|
|
2147 rep_ctr++;
|
|
|
2148 }
|
|
|
2149
|
|
|
2150 /* Execute a repeated output. Note the flag no_leading_blank that
|
|
|
2151 is used in the functions used to output the intrinsic types. */
|
|
|
2152
|
|
|
2153 else
|
|
|
2154 {
|
|
|
2155 if (rep_ctr > 1)
|
|
|
2156 {
|
|
|
2157 snprintf(rep_buff, NML_DIGITS, " %d*", rep_ctr);
|
|
|
2158 write_character (dtp, rep_buff, 1, strlen (rep_buff), NODELIM);
|
|
|
2159 dtp->u.p.no_leading_blank = 1;
|
|
|
2160 }
|
|
|
2161 num++;
|
|
|
2162
|
|
|
2163 /* Output the data, if an intrinsic type, or recurse into this
|
|
|
2164 routine to treat derived types. */
|
|
|
2165
|
|
|
2166 switch (obj->type)
|
|
|
2167 {
|
|
|
2168
|
|
|
2169 case BT_INTEGER:
|
|
|
2170 write_integer (dtp, p, len);
|
|
|
2171 break;
|
|
|
2172
|
|
|
2173 case BT_LOGICAL:
|
|
|
2174 write_logical (dtp, p, len);
|
|
|
2175 break;
|
|
|
2176
|
|
|
2177 case BT_CHARACTER:
|
|
|
2178 if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
|
|
|
2179 write_character (dtp, p, 4, obj->string_length, DELIM);
|
|
|
2180 else
|
|
|
2181 write_character (dtp, p, 1, obj->string_length, DELIM);
|
|
|
2182 break;
|
|
|
2183
|
|
|
2184 case BT_REAL:
|
|
|
2185 write_real (dtp, p, len);
|
|
|
2186 break;
|
|
|
2187
|
|
|
2188 case BT_COMPLEX:
|
|
|
2189 dtp->u.p.no_leading_blank = 0;
|
|
|
2190 num++;
|
|
|
2191 write_complex (dtp, p, len, obj_size);
|
|
|
2192 break;
|
|
|
2193
|
|
|
2194 case BT_DERIVED:
|
|
|
2195 case BT_CLASS:
|
|
|
2196 /* To treat a derived type, we need to build two strings:
|
|
|
2197 ext_name = the name, including qualifiers that prepends
|
|
|
2198 component names in the output - passed to
|
|
|
2199 nml_write_obj.
|
|
|
2200 obj_name = the derived type name with no qualifiers but %
|
|
|
2201 appended. This is used to identify the
|
|
|
2202 components. */
|
|
|
2203
|
|
|
2204 /* First ext_name => get length of all possible components */
|
|
|
2205 if (obj->dtio_sub != NULL)
|
|
|
2206 {
|
|
|
2207 int unit = dtp->u.p.current_unit->unit_number;
|
|
|
2208 char iotype[] = "NAMELIST";
|
|
|
2209 gfc_charlen_type iotype_len = 8;
|
|
|
2210 char tmp_iomsg[IOMSG_LEN] = "";
|
|
|
2211 char *child_iomsg;
|
|
|
2212 gfc_charlen_type child_iomsg_len;
|
|
|
2213 int noiostat;
|
|
|
2214 int *child_iostat = NULL;
|
|
131
|
2215 gfc_full_array_i4 vlist;
|
|
111
|
2216 formatted_dtio dtio_ptr = (formatted_dtio)obj->dtio_sub;
|
|
|
2217
|
|
|
2218 GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0);
|
|
|
2219
|
|
|
2220 /* Set iostat, intent(out). */
|
|
|
2221 noiostat = 0;
|
|
|
2222 child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
|
|
|
2223 dtp->common.iostat : &noiostat;
|
|
|
2224
|
|
|
2225 /* Set iomsg, intent(inout). */
|
|
|
2226 if (dtp->common.flags & IOPARM_HAS_IOMSG)
|
|
|
2227 {
|
|
|
2228 child_iomsg = dtp->common.iomsg;
|
|
|
2229 child_iomsg_len = dtp->common.iomsg_len;
|
|
|
2230 }
|
|
|
2231 else
|
|
|
2232 {
|
|
|
2233 child_iomsg = tmp_iomsg;
|
|
|
2234 child_iomsg_len = IOMSG_LEN;
|
|
|
2235 }
|
|
|
2236
|
|
|
2237 /* Call the user defined formatted WRITE procedure. */
|
|
|
2238 dtp->u.p.current_unit->child_dtio++;
|
|
|
2239 if (obj->type == BT_DERIVED)
|
|
|
2240 {
|
|
131
|
2241 /* Build a class container. */
|
|
111
|
2242 gfc_class list_obj;
|
|
|
2243 list_obj.data = p;
|
|
|
2244 list_obj.vptr = obj->vtable;
|
|
|
2245 list_obj.len = 0;
|
|
|
2246 dtio_ptr ((void *)&list_obj, &unit, iotype, &vlist,
|
|
|
2247 child_iostat, child_iomsg,
|
|
|
2248 iotype_len, child_iomsg_len);
|
|
|
2249 }
|
|
|
2250 else
|
|
|
2251 {
|
|
|
2252 dtio_ptr (p, &unit, iotype, &vlist,
|
|
|
2253 child_iostat, child_iomsg,
|
|
|
2254 iotype_len, child_iomsg_len);
|
|
|
2255 }
|
|
|
2256 dtp->u.p.current_unit->child_dtio--;
|
|
|
2257
|
|
|
2258 goto obj_loop;
|
|
|
2259 }
|
|
|
2260
|
|
|
2261 base_name_len = base_name ? strlen (base_name) : 0;
|
|
|
2262 base_var_name_len = base ? strlen (base->var_name) : 0;
|
|
|
2263 ext_name_len = base_name_len + base_var_name_len
|
|
|
2264 + strlen (obj->var_name) + obj->var_rank * NML_DIGITS + 1;
|
|
|
2265 ext_name = xmalloc (ext_name_len);
|
|
|
2266
|
|
|
2267 if (base_name)
|
|
|
2268 memcpy (ext_name, base_name, base_name_len);
|
|
|
2269 clen = strlen (obj->var_name + base_var_name_len);
|
|
|
2270 memcpy (ext_name + base_name_len,
|
|
|
2271 obj->var_name + base_var_name_len, clen);
|
|
|
2272
|
|
|
2273 /* Append the qualifier. */
|
|
|
2274
|
|
|
2275 tot_len = base_name_len + clen;
|
|
|
2276 for (dim_i = 0; dim_i < (size_t) obj->var_rank; dim_i++)
|
|
|
2277 {
|
|
|
2278 if (!dim_i)
|
|
|
2279 {
|
|
|
2280 ext_name[tot_len] = '(';
|
|
|
2281 tot_len++;
|
|
|
2282 }
|
|
|
2283 snprintf (ext_name + tot_len, ext_name_len - tot_len, "%d",
|
|
|
2284 (int) obj->ls[dim_i].idx);
|
|
|
2285 tot_len += strlen (ext_name + tot_len);
|
|
|
2286 ext_name[tot_len] = ((int) dim_i == obj->var_rank - 1) ? ')' : ',';
|
|
|
2287 tot_len++;
|
|
|
2288 }
|
|
|
2289
|
|
|
2290 ext_name[tot_len] = '\0';
|
|
|
2291 for (q = ext_name; *q; q++)
|
|
|
2292 if (*q == '+')
|
|
|
2293 *q = '%';
|
|
|
2294
|
|
|
2295 /* Now obj_name. */
|
|
|
2296
|
|
|
2297 obj_name_len = strlen (obj->var_name) + 1;
|
|
|
2298 obj_name = xmalloc (obj_name_len + 1);
|
|
|
2299 memcpy (obj_name, obj->var_name, obj_name_len-1);
|
|
|
2300 memcpy (obj_name + obj_name_len-1, "%", 2);
|
|
|
2301
|
|
|
2302 /* Now loop over the components. Update the component pointer
|
|
|
2303 with the return value from nml_write_obj => this loop jumps
|
|
|
2304 past nested derived types. */
|
|
|
2305
|
|
|
2306 for (cmp = obj->next;
|
|
|
2307 cmp && !strncmp (cmp->var_name, obj_name, obj_name_len);
|
|
|
2308 cmp = retval)
|
|
|
2309 {
|
|
|
2310 retval = nml_write_obj (dtp, cmp,
|
|
|
2311 (index_type)(p - obj->mem_pos),
|
|
|
2312 obj, ext_name);
|
|
|
2313 }
|
|
|
2314
|
|
|
2315 free (obj_name);
|
|
|
2316 free (ext_name);
|
|
|
2317 goto obj_loop;
|
|
|
2318
|
|
|
2319 default:
|
|
|
2320 internal_error (&dtp->common, "Bad type for namelist write");
|
|
|
2321 }
|
|
|
2322
|
|
|
2323 /* Reset the leading blank suppression, write a comma (or semi-colon)
|
|
|
2324 and, if 5 values have been output, write a newline and advance
|
|
|
2325 to column 2. Reset the repeat counter. */
|
|
|
2326
|
|
|
2327 dtp->u.p.no_leading_blank = 0;
|
|
|
2328 if (obj->type == BT_CHARACTER)
|
|
|
2329 {
|
|
|
2330 if (dtp->u.p.nml_delim != '\0')
|
|
|
2331 write_character (dtp, &semi_comma, 1, 1, NODELIM);
|
|
|
2332 }
|
|
|
2333 else
|
|
|
2334 write_character (dtp, &semi_comma, 1, 1, NODELIM);
|
|
|
2335 if (num > 5)
|
|
|
2336 {
|
|
|
2337 num = 0;
|
|
|
2338 if (dtp->u.p.nml_delim == '\0')
|
|
|
2339 write_character (dtp, &semi_comma, 1, 1, NODELIM);
|
|
|
2340 namelist_write_newline (dtp);
|
|
|
2341 write_character (dtp, " ", 1, 1, NODELIM);
|
|
|
2342 }
|
|
|
2343 rep_ctr = 1;
|
|
|
2344 }
|
|
|
2345
|
|
|
2346 /* Cycle through and increment the index vector. */
|
|
|
2347
|
|
|
2348 obj_loop:
|
|
|
2349
|
|
|
2350 nml_carry = 1;
|
|
|
2351 for (dim_i = 0; nml_carry && (dim_i < (size_t) obj->var_rank); dim_i++)
|
|
|
2352 {
|
|
|
2353 obj->ls[dim_i].idx += nml_carry ;
|
|
|
2354 nml_carry = 0;
|
|
|
2355 if (obj->ls[dim_i].idx > GFC_DESCRIPTOR_UBOUND(obj,dim_i))
|
|
|
2356 {
|
|
|
2357 obj->ls[dim_i].idx = GFC_DESCRIPTOR_LBOUND(obj,dim_i);
|
|
|
2358 nml_carry = 1;
|
|
|
2359 }
|
|
|
2360 }
|
|
|
2361 }
|
|
|
2362
|
|
|
2363 /* Return a pointer beyond the furthest object accessed. */
|
|
|
2364
|
|
|
2365 return retval;
|
|
|
2366 }
|
|
|
2367
|
|
|
2368
|
|
|
2369 /* This is the entry function for namelist writes. It outputs the name
|
|
|
2370 of the namelist and iterates through the namelist by calls to
|
|
|
2371 nml_write_obj. The call below has dummys in the arguments used in
|
|
|
2372 the treatment of derived types. */
|
|
|
2373
|
|
|
2374 void
|
|
|
2375 namelist_write (st_parameter_dt *dtp)
|
|
|
2376 {
|
|
|
2377 namelist_info *t1, *t2, *dummy = NULL;
|
|
|
2378 index_type dummy_offset = 0;
|
|
|
2379 char c;
|
|
|
2380 char *dummy_name = NULL;
|
|
|
2381
|
|
|
2382 /* Set the delimiter for namelist output. */
|
|
|
2383 switch (dtp->u.p.current_unit->delim_status)
|
|
|
2384 {
|
|
|
2385 case DELIM_APOSTROPHE:
|
|
|
2386 dtp->u.p.nml_delim = '\'';
|
|
|
2387 break;
|
|
|
2388 case DELIM_QUOTE:
|
|
|
2389 case DELIM_UNSPECIFIED:
|
|
|
2390 dtp->u.p.nml_delim = '"';
|
|
|
2391 break;
|
|
|
2392 default:
|
|
|
2393 dtp->u.p.nml_delim = '\0';
|
|
|
2394 }
|
|
|
2395
|
|
|
2396 write_character (dtp, "&", 1, 1, NODELIM);
|
|
|
2397
|
|
|
2398 /* Write namelist name in upper case - f95 std. */
|
|
131
|
2399 for (gfc_charlen_type i = 0; i < dtp->namelist_name_len; i++ )
|
|
111
|
2400 {
|
|
|
2401 c = toupper ((int) dtp->namelist_name[i]);
|
|
|
2402 write_character (dtp, &c, 1 ,1, NODELIM);
|
|
|
2403 }
|
|
|
2404
|
|
|
2405 if (dtp->u.p.ionml != NULL)
|
|
|
2406 {
|
|
|
2407 t1 = dtp->u.p.ionml;
|
|
|
2408 while (t1 != NULL)
|
|
|
2409 {
|
|
|
2410 t2 = t1;
|
|
|
2411 t1 = nml_write_obj (dtp, t2, dummy_offset, dummy, dummy_name);
|
|
|
2412 }
|
|
|
2413 }
|
|
|
2414
|
|
|
2415 namelist_write_newline (dtp);
|
|
|
2416 write_character (dtp, " /", 1, 2, NODELIM);
|
|
|
2417 }
|
|
|
2418
|
|
|
2419 #undef NML_DIGITS
|
