|
145
|
1 /* Copyright (C) 2002-2020 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 static void
|
|
145
|
689 write_boz (st_parameter_dt *dtp, const fnode *f, const char *q, int n, int len)
|
|
111
|
690 {
|
|
|
691 int w, m, digits, nzero, nblank;
|
|
|
692 char *p;
|
|
|
693
|
|
|
694 w = f->u.integer.w;
|
|
|
695 m = f->u.integer.m;
|
|
|
696
|
|
|
697 /* Special case: */
|
|
|
698
|
|
|
699 if (m == 0 && n == 0)
|
|
|
700 {
|
|
|
701 if (w == 0)
|
|
|
702 w = 1;
|
|
|
703
|
|
|
704 p = write_block (dtp, w);
|
|
|
705 if (p == NULL)
|
|
|
706 return;
|
|
|
707 if (unlikely (is_char4_unit (dtp)))
|
|
|
708 {
|
|
|
709 gfc_char4_t *p4 = (gfc_char4_t *) p;
|
|
|
710 memset4 (p4, ' ', w);
|
|
|
711 }
|
|
|
712 else
|
|
|
713 memset (p, ' ', w);
|
|
|
714 goto done;
|
|
|
715 }
|
|
|
716
|
|
|
717 digits = strlen (q);
|
|
|
718
|
|
|
719 /* Select a width if none was specified. The idea here is to always
|
|
|
720 print something. */
|
|
|
721
|
|
145
|
722 if (w == DEFAULT_WIDTH)
|
|
|
723 w = default_width_for_integer (len);
|
|
|
724
|
|
111
|
725 if (w == 0)
|
|
|
726 w = ((digits < m) ? m : digits);
|
|
|
727
|
|
|
728 p = write_block (dtp, w);
|
|
|
729 if (p == NULL)
|
|
|
730 return;
|
|
|
731
|
|
|
732 nzero = 0;
|
|
|
733 if (digits < m)
|
|
|
734 nzero = m - digits;
|
|
|
735
|
|
|
736 /* See if things will work. */
|
|
|
737
|
|
|
738 nblank = w - (nzero + digits);
|
|
|
739
|
|
|
740 if (unlikely (is_char4_unit (dtp)))
|
|
|
741 {
|
|
|
742 gfc_char4_t *p4 = (gfc_char4_t *) p;
|
|
|
743 if (nblank < 0)
|
|
|
744 {
|
|
|
745 memset4 (p4, '*', w);
|
|
|
746 return;
|
|
|
747 }
|
|
|
748
|
|
|
749 if (!dtp->u.p.no_leading_blank)
|
|
|
750 {
|
|
|
751 memset4 (p4, ' ', nblank);
|
|
|
752 q += nblank;
|
|
|
753 memset4 (p4, '0', nzero);
|
|
|
754 q += nzero;
|
|
|
755 memcpy4 (p4, q, digits);
|
|
|
756 }
|
|
|
757 else
|
|
|
758 {
|
|
|
759 memset4 (p4, '0', nzero);
|
|
|
760 q += nzero;
|
|
|
761 memcpy4 (p4, q, digits);
|
|
|
762 q += digits;
|
|
|
763 memset4 (p4, ' ', nblank);
|
|
|
764 dtp->u.p.no_leading_blank = 0;
|
|
|
765 }
|
|
|
766 return;
|
|
|
767 }
|
|
|
768
|
|
|
769 if (nblank < 0)
|
|
|
770 {
|
|
|
771 star_fill (p, w);
|
|
|
772 goto done;
|
|
|
773 }
|
|
|
774
|
|
|
775 if (!dtp->u.p.no_leading_blank)
|
|
|
776 {
|
|
|
777 memset (p, ' ', nblank);
|
|
|
778 p += nblank;
|
|
|
779 memset (p, '0', nzero);
|
|
|
780 p += nzero;
|
|
|
781 memcpy (p, q, digits);
|
|
|
782 }
|
|
|
783 else
|
|
|
784 {
|
|
|
785 memset (p, '0', nzero);
|
|
|
786 p += nzero;
|
|
|
787 memcpy (p, q, digits);
|
|
|
788 p += digits;
|
|
|
789 memset (p, ' ', nblank);
|
|
|
790 dtp->u.p.no_leading_blank = 0;
|
|
|
791 }
|
|
|
792
|
|
|
793 done:
|
|
|
794 return;
|
|
|
795 }
|
|
|
796
|
|
|
797 static void
|
|
|
798 write_decimal (st_parameter_dt *dtp, const fnode *f, const char *source,
|
|
|
799 int len,
|
|
|
800 const char *(*conv) (GFC_INTEGER_LARGEST, char *, size_t))
|
|
|
801 {
|
|
|
802 GFC_INTEGER_LARGEST n = 0;
|
|
|
803 int w, m, digits, nsign, nzero, nblank;
|
|
|
804 char *p;
|
|
|
805 const char *q;
|
|
|
806 sign_t sign;
|
|
|
807 char itoa_buf[GFC_BTOA_BUF_SIZE];
|
|
|
808
|
|
|
809 w = f->u.integer.w;
|
|
|
810 m = f->format == FMT_G ? -1 : f->u.integer.m;
|
|
|
811
|
|
|
812 n = extract_int (source, len);
|
|
|
813
|
|
|
814 /* Special case: */
|
|
|
815 if (m == 0 && n == 0)
|
|
|
816 {
|
|
|
817 if (w == 0)
|
|
|
818 w = 1;
|
|
|
819
|
|
|
820 p = write_block (dtp, w);
|
|
|
821 if (p == NULL)
|
|
|
822 return;
|
|
|
823 if (unlikely (is_char4_unit (dtp)))
|
|
|
824 {
|
|
|
825 gfc_char4_t *p4 = (gfc_char4_t *) p;
|
|
|
826 memset4 (p4, ' ', w);
|
|
|
827 }
|
|
|
828 else
|
|
|
829 memset (p, ' ', w);
|
|
|
830 goto done;
|
|
|
831 }
|
|
|
832
|
|
|
833 sign = calculate_sign (dtp, n < 0);
|
|
|
834 if (n < 0)
|
|
|
835 n = -n;
|
|
|
836 nsign = sign == S_NONE ? 0 : 1;
|
|
|
837
|
|
|
838 /* conv calls itoa which sets the negative sign needed
|
|
|
839 by write_integer. The sign '+' or '-' is set below based on sign
|
|
|
840 calculated above, so we just point past the sign in the string
|
|
|
841 before proceeding to avoid double signs in corner cases.
|
|
|
842 (see PR38504) */
|
|
|
843 q = conv (n, itoa_buf, sizeof (itoa_buf));
|
|
|
844 if (*q == '-')
|
|
|
845 q++;
|
|
|
846
|
|
|
847 digits = strlen (q);
|
|
|
848
|
|
|
849 /* Select a width if none was specified. The idea here is to always
|
|
|
850 print something. */
|
|
145
|
851 if (w == DEFAULT_WIDTH)
|
|
|
852 w = default_width_for_integer (len);
|
|
111
|
853
|
|
|
854 if (w == 0)
|
|
|
855 w = ((digits < m) ? m : digits) + nsign;
|
|
|
856
|
|
|
857 p = write_block (dtp, w);
|
|
|
858 if (p == NULL)
|
|
|
859 return;
|
|
|
860
|
|
|
861 nzero = 0;
|
|
|
862 if (digits < m)
|
|
|
863 nzero = m - digits;
|
|
|
864
|
|
|
865 /* See if things will work. */
|
|
|
866
|
|
|
867 nblank = w - (nsign + nzero + digits);
|
|
|
868
|
|
|
869 if (unlikely (is_char4_unit (dtp)))
|
|
|
870 {
|
|
|
871 gfc_char4_t *p4 = (gfc_char4_t *)p;
|
|
|
872 if (nblank < 0)
|
|
|
873 {
|
|
|
874 memset4 (p4, '*', w);
|
|
|
875 goto done;
|
|
|
876 }
|
|
|
877
|
|
131
|
878 if (!dtp->u.p.namelist_mode)
|
|
|
879 {
|
|
|
880 memset4 (p4, ' ', nblank);
|
|
|
881 p4 += nblank;
|
|
|
882 }
|
|
111
|
883
|
|
|
884 switch (sign)
|
|
|
885 {
|
|
|
886 case S_PLUS:
|
|
|
887 *p4++ = '+';
|
|
|
888 break;
|
|
|
889 case S_MINUS:
|
|
|
890 *p4++ = '-';
|
|
|
891 break;
|
|
|
892 case S_NONE:
|
|
|
893 break;
|
|
|
894 }
|
|
|
895
|
|
|
896 memset4 (p4, '0', nzero);
|
|
|
897 p4 += nzero;
|
|
|
898
|
|
|
899 memcpy4 (p4, q, digits);
|
|
|
900 return;
|
|
131
|
901
|
|
|
902 if (dtp->u.p.namelist_mode)
|
|
|
903 {
|
|
|
904 p4 += digits;
|
|
|
905 memset4 (p4, ' ', nblank);
|
|
|
906 }
|
|
111
|
907 }
|
|
|
908
|
|
|
909 if (nblank < 0)
|
|
|
910 {
|
|
|
911 star_fill (p, w);
|
|
|
912 goto done;
|
|
|
913 }
|
|
|
914
|
|
131
|
915 if (!dtp->u.p.namelist_mode)
|
|
|
916 {
|
|
|
917 memset (p, ' ', nblank);
|
|
|
918 p += nblank;
|
|
|
919 }
|
|
111
|
920
|
|
|
921 switch (sign)
|
|
|
922 {
|
|
|
923 case S_PLUS:
|
|
|
924 *p++ = '+';
|
|
|
925 break;
|
|
|
926 case S_MINUS:
|
|
|
927 *p++ = '-';
|
|
|
928 break;
|
|
|
929 case S_NONE:
|
|
|
930 break;
|
|
|
931 }
|
|
|
932
|
|
|
933 memset (p, '0', nzero);
|
|
|
934 p += nzero;
|
|
|
935
|
|
|
936 memcpy (p, q, digits);
|
|
|
937
|
|
131
|
938 if (dtp->u.p.namelist_mode)
|
|
|
939 {
|
|
|
940 p += digits;
|
|
|
941 memset (p, ' ', nblank);
|
|
|
942 }
|
|
|
943
|
|
111
|
944 done:
|
|
|
945 return;
|
|
|
946 }
|
|
|
947
|
|
|
948
|
|
|
949 /* Convert unsigned octal to ascii. */
|
|
|
950
|
|
|
951 static const char *
|
|
|
952 otoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
|
|
|
953 {
|
|
|
954 char *p;
|
|
|
955
|
|
|
956 assert (len >= GFC_OTOA_BUF_SIZE);
|
|
|
957
|
|
|
958 if (n == 0)
|
|
|
959 return "0";
|
|
|
960
|
|
|
961 p = buffer + GFC_OTOA_BUF_SIZE - 1;
|
|
|
962 *p = '\0';
|
|
|
963
|
|
|
964 while (n != 0)
|
|
|
965 {
|
|
|
966 *--p = '0' + (n & 7);
|
|
|
967 n >>= 3;
|
|
|
968 }
|
|
|
969
|
|
|
970 return p;
|
|
|
971 }
|
|
|
972
|
|
|
973
|
|
|
974 /* Convert unsigned binary to ascii. */
|
|
|
975
|
|
|
976 static const char *
|
|
|
977 btoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
|
|
|
978 {
|
|
|
979 char *p;
|
|
|
980
|
|
|
981 assert (len >= GFC_BTOA_BUF_SIZE);
|
|
|
982
|
|
|
983 if (n == 0)
|
|
|
984 return "0";
|
|
|
985
|
|
|
986 p = buffer + GFC_BTOA_BUF_SIZE - 1;
|
|
|
987 *p = '\0';
|
|
|
988
|
|
|
989 while (n != 0)
|
|
|
990 {
|
|
|
991 *--p = '0' + (n & 1);
|
|
|
992 n >>= 1;
|
|
|
993 }
|
|
|
994
|
|
|
995 return p;
|
|
|
996 }
|
|
|
997
|
|
|
998 /* The following three functions, btoa_big, otoa_big, and ztoa_big, are needed
|
|
|
999 to convert large reals with kind sizes that exceed the largest integer type
|
|
|
1000 available on certain platforms. In these cases, byte by byte conversion is
|
|
|
1001 performed. Endianess is taken into account. */
|
|
|
1002
|
|
|
1003 /* Conversion to binary. */
|
|
|
1004
|
|
|
1005 static const char *
|
|
|
1006 btoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
|
|
|
1007 {
|
|
|
1008 char *q;
|
|
|
1009 int i, j;
|
|
|
1010
|
|
|
1011 q = buffer;
|
|
131
|
1012 if (__BYTE_ORDER__ == __ORDER_BIG_ENDIAN__)
|
|
111
|
1013 {
|
|
|
1014 const char *p = s;
|
|
|
1015 for (i = 0; i < len; i++)
|
|
|
1016 {
|
|
|
1017 char c = *p;
|
|
|
1018
|
|
|
1019 /* Test for zero. Needed by write_boz later. */
|
|
|
1020 if (*p != 0)
|
|
|
1021 *n = 1;
|
|
|
1022
|
|
|
1023 for (j = 0; j < 8; j++)
|
|
|
1024 {
|
|
|
1025 *q++ = (c & 128) ? '1' : '0';
|
|
|
1026 c <<= 1;
|
|
|
1027 }
|
|
|
1028 p++;
|
|
|
1029 }
|
|
|
1030 }
|
|
|
1031 else
|
|
|
1032 {
|
|
|
1033 const char *p = s + len - 1;
|
|
|
1034 for (i = 0; i < len; i++)
|
|
|
1035 {
|
|
|
1036 char c = *p;
|
|
|
1037
|
|
|
1038 /* Test for zero. Needed by write_boz later. */
|
|
|
1039 if (*p != 0)
|
|
|
1040 *n = 1;
|
|
|
1041
|
|
|
1042 for (j = 0; j < 8; j++)
|
|
|
1043 {
|
|
|
1044 *q++ = (c & 128) ? '1' : '0';
|
|
|
1045 c <<= 1;
|
|
|
1046 }
|
|
|
1047 p--;
|
|
|
1048 }
|
|
|
1049 }
|
|
|
1050
|
|
|
1051 if (*n == 0)
|
|
|
1052 return "0";
|
|
|
1053
|
|
|
1054 /* Move past any leading zeros. */
|
|
|
1055 while (*buffer == '0')
|
|
|
1056 buffer++;
|
|
|
1057
|
|
|
1058 return buffer;
|
|
|
1059
|
|
|
1060 }
|
|
|
1061
|
|
|
1062 /* Conversion to octal. */
|
|
|
1063
|
|
|
1064 static const char *
|
|
|
1065 otoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
|
|
|
1066 {
|
|
|
1067 char *q;
|
|
|
1068 int i, j, k;
|
|
|
1069 uint8_t octet;
|
|
|
1070
|
|
|
1071 q = buffer + GFC_OTOA_BUF_SIZE - 1;
|
|
|
1072 *q = '\0';
|
|
|
1073 i = k = octet = 0;
|
|
|
1074
|
|
131
|
1075 if (__BYTE_ORDER__ == __ORDER_BIG_ENDIAN__)
|
|
111
|
1076 {
|
|
|
1077 const char *p = s + len - 1;
|
|
|
1078 char c = *p;
|
|
|
1079 while (i < len)
|
|
|
1080 {
|
|
|
1081 /* Test for zero. Needed by write_boz later. */
|
|
|
1082 if (*p != 0)
|
|
|
1083 *n = 1;
|
|
|
1084
|
|
|
1085 for (j = 0; j < 3 && i < len; j++)
|
|
|
1086 {
|
|
|
1087 octet |= (c & 1) << j;
|
|
|
1088 c >>= 1;
|
|
|
1089 if (++k > 7)
|
|
|
1090 {
|
|
|
1091 i++;
|
|
|
1092 k = 0;
|
|
|
1093 c = *--p;
|
|
|
1094 }
|
|
|
1095 }
|
|
|
1096 *--q = '0' + octet;
|
|
|
1097 octet = 0;
|
|
|
1098 }
|
|
|
1099 }
|
|
|
1100 else
|
|
|
1101 {
|
|
|
1102 const char *p = s;
|
|
|
1103 char c = *p;
|
|
|
1104 while (i < len)
|
|
|
1105 {
|
|
|
1106 /* Test for zero. Needed by write_boz later. */
|
|
|
1107 if (*p != 0)
|
|
|
1108 *n = 1;
|
|
|
1109
|
|
|
1110 for (j = 0; j < 3 && i < len; j++)
|
|
|
1111 {
|
|
|
1112 octet |= (c & 1) << j;
|
|
|
1113 c >>= 1;
|
|
|
1114 if (++k > 7)
|
|
|
1115 {
|
|
|
1116 i++;
|
|
|
1117 k = 0;
|
|
|
1118 c = *++p;
|
|
|
1119 }
|
|
|
1120 }
|
|
|
1121 *--q = '0' + octet;
|
|
|
1122 octet = 0;
|
|
|
1123 }
|
|
|
1124 }
|
|
|
1125
|
|
|
1126 if (*n == 0)
|
|
|
1127 return "0";
|
|
|
1128
|
|
|
1129 /* Move past any leading zeros. */
|
|
|
1130 while (*q == '0')
|
|
|
1131 q++;
|
|
|
1132
|
|
|
1133 return q;
|
|
|
1134 }
|
|
|
1135
|
|
|
1136 /* Conversion to hexidecimal. */
|
|
|
1137
|
|
|
1138 static const char *
|
|
|
1139 ztoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
|
|
|
1140 {
|
|
|
1141 static char a[16] = {'0', '1', '2', '3', '4', '5', '6', '7',
|
|
|
1142 '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'};
|
|
|
1143
|
|
|
1144 char *q;
|
|
|
1145 uint8_t h, l;
|
|
|
1146 int i;
|
|
|
1147
|
|
|
1148 q = buffer;
|
|
|
1149
|
|
131
|
1150 if (__BYTE_ORDER__ == __ORDER_BIG_ENDIAN__)
|
|
111
|
1151 {
|
|
|
1152 const char *p = s;
|
|
|
1153 for (i = 0; i < len; i++)
|
|
|
1154 {
|
|
|
1155 /* Test for zero. Needed by write_boz later. */
|
|
|
1156 if (*p != 0)
|
|
|
1157 *n = 1;
|
|
|
1158
|
|
|
1159 h = (*p >> 4) & 0x0F;
|
|
|
1160 l = *p++ & 0x0F;
|
|
|
1161 *q++ = a[h];
|
|
|
1162 *q++ = a[l];
|
|
|
1163 }
|
|
|
1164 }
|
|
|
1165 else
|
|
|
1166 {
|
|
|
1167 const char *p = s + len - 1;
|
|
|
1168 for (i = 0; i < len; i++)
|
|
|
1169 {
|
|
|
1170 /* Test for zero. Needed by write_boz later. */
|
|
|
1171 if (*p != 0)
|
|
|
1172 *n = 1;
|
|
|
1173
|
|
|
1174 h = (*p >> 4) & 0x0F;
|
|
|
1175 l = *p-- & 0x0F;
|
|
|
1176 *q++ = a[h];
|
|
|
1177 *q++ = a[l];
|
|
|
1178 }
|
|
|
1179 }
|
|
|
1180
|
|
|
1181 *q = '\0';
|
|
|
1182
|
|
|
1183 if (*n == 0)
|
|
|
1184 return "0";
|
|
|
1185
|
|
|
1186 /* Move past any leading zeros. */
|
|
|
1187 while (*buffer == '0')
|
|
|
1188 buffer++;
|
|
|
1189
|
|
|
1190 return buffer;
|
|
|
1191 }
|
|
|
1192
|
|
|
1193
|
|
|
1194 void
|
|
|
1195 write_i (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
|
|
|
1196 {
|
|
|
1197 write_decimal (dtp, f, p, len, (void *) gfc_itoa);
|
|
|
1198 }
|
|
|
1199
|
|
|
1200
|
|
|
1201 void
|
|
|
1202 write_b (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
|
|
|
1203 {
|
|
|
1204 const char *p;
|
|
|
1205 char itoa_buf[GFC_BTOA_BUF_SIZE];
|
|
|
1206 GFC_UINTEGER_LARGEST n = 0;
|
|
|
1207
|
|
145
|
1208 /* Ensure we end up with a null terminated string. */
|
|
|
1209 memset(itoa_buf, '\0', GFC_BTOA_BUF_SIZE);
|
|
|
1210
|
|
111
|
1211 if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
|
|
|
1212 {
|
|
|
1213 p = btoa_big (source, itoa_buf, len, &n);
|
|
145
|
1214 write_boz (dtp, f, p, n, len);
|
|
111
|
1215 }
|
|
|
1216 else
|
|
|
1217 {
|
|
|
1218 n = extract_uint (source, len);
|
|
|
1219 p = btoa (n, itoa_buf, sizeof (itoa_buf));
|
|
145
|
1220 write_boz (dtp, f, p, n, len);
|
|
111
|
1221 }
|
|
|
1222 }
|
|
|
1223
|
|
|
1224
|
|
|
1225 void
|
|
|
1226 write_o (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
|
|
|
1227 {
|
|
|
1228 const char *p;
|
|
|
1229 char itoa_buf[GFC_OTOA_BUF_SIZE];
|
|
|
1230 GFC_UINTEGER_LARGEST n = 0;
|
|
|
1231
|
|
|
1232 if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
|
|
|
1233 {
|
|
|
1234 p = otoa_big (source, itoa_buf, len, &n);
|
|
145
|
1235 write_boz (dtp, f, p, n, len);
|
|
111
|
1236 }
|
|
|
1237 else
|
|
|
1238 {
|
|
|
1239 n = extract_uint (source, len);
|
|
|
1240 p = otoa (n, itoa_buf, sizeof (itoa_buf));
|
|
145
|
1241 write_boz (dtp, f, p, n, len);
|
|
111
|
1242 }
|
|
|
1243 }
|
|
|
1244
|
|
|
1245 void
|
|
|
1246 write_z (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
|
|
|
1247 {
|
|
|
1248 const char *p;
|
|
|
1249 char itoa_buf[GFC_XTOA_BUF_SIZE];
|
|
|
1250 GFC_UINTEGER_LARGEST n = 0;
|
|
|
1251
|
|
|
1252 if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
|
|
|
1253 {
|
|
|
1254 p = ztoa_big (source, itoa_buf, len, &n);
|
|
145
|
1255 write_boz (dtp, f, p, n, len);
|
|
111
|
1256 }
|
|
|
1257 else
|
|
|
1258 {
|
|
|
1259 n = extract_uint (source, len);
|
|
|
1260 p = gfc_xtoa (n, itoa_buf, sizeof (itoa_buf));
|
|
145
|
1261 write_boz (dtp, f, p, n, len);
|
|
111
|
1262 }
|
|
|
1263 }
|
|
|
1264
|
|
|
1265 /* Take care of the X/TR descriptor. */
|
|
|
1266
|
|
|
1267 void
|
|
|
1268 write_x (st_parameter_dt *dtp, int len, int nspaces)
|
|
|
1269 {
|
|
|
1270 char *p;
|
|
|
1271
|
|
|
1272 p = write_block (dtp, len);
|
|
|
1273 if (p == NULL)
|
|
|
1274 return;
|
|
|
1275 if (nspaces > 0 && len - nspaces >= 0)
|
|
|
1276 {
|
|
|
1277 if (unlikely (is_char4_unit (dtp)))
|
|
|
1278 {
|
|
|
1279 gfc_char4_t *p4 = (gfc_char4_t *) p;
|
|
|
1280 memset4 (&p4[len - nspaces], ' ', nspaces);
|
|
|
1281 }
|
|
|
1282 else
|
|
|
1283 memset (&p[len - nspaces], ' ', nspaces);
|
|
|
1284 }
|
|
|
1285 }
|
|
|
1286
|
|
|
1287
|
|
|
1288 /* List-directed writing. */
|
|
|
1289
|
|
|
1290
|
|
|
1291 /* Write a single character to the output. Returns nonzero if
|
|
|
1292 something goes wrong. */
|
|
|
1293
|
|
|
1294 static int
|
|
|
1295 write_char (st_parameter_dt *dtp, int c)
|
|
|
1296 {
|
|
|
1297 char *p;
|
|
|
1298
|
|
|
1299 p = write_block (dtp, 1);
|
|
|
1300 if (p == NULL)
|
|
|
1301 return 1;
|
|
|
1302 if (unlikely (is_char4_unit (dtp)))
|
|
|
1303 {
|
|
|
1304 gfc_char4_t *p4 = (gfc_char4_t *) p;
|
|
|
1305 *p4 = c;
|
|
|
1306 return 0;
|
|
|
1307 }
|
|
|
1308
|
|
|
1309 *p = (uchar) c;
|
|
|
1310
|
|
|
1311 return 0;
|
|
|
1312 }
|
|
|
1313
|
|
|
1314
|
|
|
1315 /* Write a list-directed logical value. */
|
|
|
1316
|
|
|
1317 static void
|
|
|
1318 write_logical (st_parameter_dt *dtp, const char *source, int length)
|
|
|
1319 {
|
|
|
1320 write_char (dtp, extract_int (source, length) ? 'T' : 'F');
|
|
|
1321 }
|
|
|
1322
|
|
|
1323
|
|
|
1324 /* Write a list-directed integer value. */
|
|
|
1325
|
|
|
1326 static void
|
|
131
|
1327 write_integer (st_parameter_dt *dtp, const char *source, int kind)
|
|
111
|
1328 {
|
|
|
1329 int width;
|
|
131
|
1330 fnode f;
|
|
111
|
1331
|
|
131
|
1332 switch (kind)
|
|
111
|
1333 {
|
|
|
1334 case 1:
|
|
|
1335 width = 4;
|
|
|
1336 break;
|
|
|
1337
|
|
|
1338 case 2:
|
|
|
1339 width = 6;
|
|
|
1340 break;
|
|
|
1341
|
|
|
1342 case 4:
|
|
|
1343 width = 11;
|
|
|
1344 break;
|
|
|
1345
|
|
|
1346 case 8:
|
|
|
1347 width = 20;
|
|
|
1348 break;
|
|
|
1349
|
|
145
|
1350 case 16:
|
|
|
1351 width = 40;
|
|
|
1352 break;
|
|
|
1353
|
|
111
|
1354 default:
|
|
|
1355 width = 0;
|
|
|
1356 break;
|
|
|
1357 }
|
|
131
|
1358 f.u.integer.w = width;
|
|
|
1359 f.u.integer.m = -1;
|
|
|
1360 f.format = FMT_NONE;
|
|
|
1361 write_decimal (dtp, &f, source, kind, (void *) gfc_itoa);
|
|
111
|
1362 }
|
|
|
1363
|
|
|
1364
|
|
|
1365 /* Write a list-directed string. We have to worry about delimiting
|
|
|
1366 the strings if the file has been opened in that mode. */
|
|
|
1367
|
|
|
1368 #define DELIM 1
|
|
|
1369 #define NODELIM 0
|
|
|
1370
|
|
|
1371 static void
|
|
131
|
1372 write_character (st_parameter_dt *dtp, const char *source, int kind, size_t length, int mode)
|
|
111
|
1373 {
|
|
131
|
1374 size_t extra;
|
|
111
|
1375 char *p, d;
|
|
|
1376
|
|
|
1377 if (mode == DELIM)
|
|
|
1378 {
|
|
|
1379 switch (dtp->u.p.current_unit->delim_status)
|
|
|
1380 {
|
|
|
1381 case DELIM_APOSTROPHE:
|
|
|
1382 d = '\'';
|
|
|
1383 break;
|
|
|
1384 case DELIM_QUOTE:
|
|
|
1385 d = '"';
|
|
|
1386 break;
|
|
|
1387 default:
|
|
|
1388 d = ' ';
|
|
|
1389 break;
|
|
|
1390 }
|
|
|
1391 }
|
|
|
1392 else
|
|
|
1393 d = ' ';
|
|
|
1394
|
|
|
1395 if (kind == 1)
|
|
|
1396 {
|
|
|
1397 if (d == ' ')
|
|
|
1398 extra = 0;
|
|
|
1399 else
|
|
|
1400 {
|
|
|
1401 extra = 2;
|
|
|
1402
|
|
131
|
1403 for (size_t i = 0; i < length; i++)
|
|
111
|
1404 if (source[i] == d)
|
|
|
1405 extra++;
|
|
|
1406 }
|
|
|
1407
|
|
|
1408 p = write_block (dtp, length + extra);
|
|
|
1409 if (p == NULL)
|
|
|
1410 return;
|
|
|
1411
|
|
|
1412 if (unlikely (is_char4_unit (dtp)))
|
|
|
1413 {
|
|
|
1414 gfc_char4_t d4 = (gfc_char4_t) d;
|
|
|
1415 gfc_char4_t *p4 = (gfc_char4_t *) p;
|
|
|
1416
|
|
|
1417 if (d4 == ' ')
|
|
|
1418 memcpy4 (p4, source, length);
|
|
|
1419 else
|
|
|
1420 {
|
|
|
1421 *p4++ = d4;
|
|
|
1422
|
|
131
|
1423 for (size_t i = 0; i < length; i++)
|
|
111
|
1424 {
|
|
|
1425 *p4++ = (gfc_char4_t) source[i];
|
|
|
1426 if (source[i] == d)
|
|
|
1427 *p4++ = d4;
|
|
|
1428 }
|
|
|
1429
|
|
|
1430 *p4 = d4;
|
|
|
1431 }
|
|
|
1432 return;
|
|
|
1433 }
|
|
|
1434
|
|
|
1435 if (d == ' ')
|
|
|
1436 memcpy (p, source, length);
|
|
|
1437 else
|
|
|
1438 {
|
|
|
1439 *p++ = d;
|
|
|
1440
|
|
131
|
1441 for (size_t i = 0; i < length; i++)
|
|
111
|
1442 {
|
|
|
1443 *p++ = source[i];
|
|
|
1444 if (source[i] == d)
|
|
|
1445 *p++ = d;
|
|
|
1446 }
|
|
|
1447
|
|
|
1448 *p = d;
|
|
|
1449 }
|
|
|
1450 }
|
|
|
1451 else
|
|
|
1452 {
|
|
|
1453 if (d == ' ')
|
|
|
1454 {
|
|
|
1455 if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
|
|
|
1456 write_utf8_char4 (dtp, (gfc_char4_t *) source, length, 0);
|
|
|
1457 else
|
|
|
1458 write_default_char4 (dtp, (gfc_char4_t *) source, length, 0);
|
|
|
1459 }
|
|
|
1460 else
|
|
|
1461 {
|
|
|
1462 p = write_block (dtp, 1);
|
|
|
1463 *p = d;
|
|
|
1464
|
|
|
1465 if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
|
|
|
1466 write_utf8_char4 (dtp, (gfc_char4_t *) source, length, 0);
|
|
|
1467 else
|
|
|
1468 write_default_char4 (dtp, (gfc_char4_t *) source, length, 0);
|
|
|
1469
|
|
|
1470 p = write_block (dtp, 1);
|
|
|
1471 *p = d;
|
|
|
1472 }
|
|
|
1473 }
|
|
|
1474 }
|
|
|
1475
|
|
|
1476 /* Floating point helper functions. */
|
|
|
1477
|
|
131
|
1478 #define BUF_STACK_SZ 384
|
|
111
|
1479
|
|
|
1480 static int
|
|
|
1481 get_precision (st_parameter_dt *dtp, const fnode *f, const char *source, int kind)
|
|
|
1482 {
|
|
|
1483 if (f->format != FMT_EN)
|
|
|
1484 return determine_precision (dtp, f, kind);
|
|
|
1485 else
|
|
|
1486 return determine_en_precision (dtp, f, source, kind);
|
|
|
1487 }
|
|
|
1488
|
|
|
1489 /* 4932 is the maximum exponent of long double and quad precision, 3
|
|
|
1490 extra characters for the sign, the decimal point, and the
|
|
|
1491 trailing null. Extra digits are added by the calling functions for
|
|
|
1492 requested precision. Likewise for float and double. F0 editing produces
|
|
|
1493 full precision output. */
|
|
|
1494 static int
|
|
|
1495 size_from_kind (st_parameter_dt *dtp, const fnode *f, int kind)
|
|
|
1496 {
|
|
|
1497 int size;
|
|
|
1498
|
|
145
|
1499 if ((f->format == FMT_F && f->u.real.w == 0) || f->u.real.w == DEFAULT_WIDTH)
|
|
111
|
1500 {
|
|
|
1501 switch (kind)
|
|
|
1502 {
|
|
|
1503 case 4:
|
|
|
1504 size = 38 + 3; /* These constants shown for clarity. */
|
|
|
1505 break;
|
|
|
1506 case 8:
|
|
|
1507 size = 308 + 3;
|
|
|
1508 break;
|
|
|
1509 case 10:
|
|
|
1510 size = 4932 + 3;
|
|
|
1511 break;
|
|
|
1512 case 16:
|
|
|
1513 size = 4932 + 3;
|
|
|
1514 break;
|
|
|
1515 default:
|
|
|
1516 internal_error (&dtp->common, "bad real kind");
|
|
|
1517 break;
|
|
|
1518 }
|
|
|
1519 }
|
|
|
1520 else
|
|
|
1521 size = f->u.real.w + 1; /* One byte for a NULL character. */
|
|
|
1522
|
|
|
1523 return size;
|
|
|
1524 }
|
|
|
1525
|
|
|
1526 static char *
|
|
|
1527 select_buffer (st_parameter_dt *dtp, const fnode *f, int precision,
|
|
|
1528 char *buf, size_t *size, int kind)
|
|
|
1529 {
|
|
|
1530 char *result;
|
|
|
1531
|
|
131
|
1532 /* The buffer needs at least one more byte to allow room for
|
|
|
1533 normalizing and 1 to hold null terminator. */
|
|
|
1534 *size = size_from_kind (dtp, f, kind) + precision + 1 + 1;
|
|
111
|
1535
|
|
|
1536 if (*size > BUF_STACK_SZ)
|
|
|
1537 result = xmalloc (*size);
|
|
|
1538 else
|
|
|
1539 result = buf;
|
|
|
1540 return result;
|
|
|
1541 }
|
|
|
1542
|
|
|
1543 static char *
|
|
|
1544 select_string (st_parameter_dt *dtp, const fnode *f, char *buf, size_t *size,
|
|
|
1545 int kind)
|
|
|
1546 {
|
|
|
1547 char *result;
|
|
131
|
1548 *size = size_from_kind (dtp, f, kind) + f->u.real.d + 1;
|
|
111
|
1549 if (*size > BUF_STACK_SZ)
|
|
|
1550 result = xmalloc (*size);
|
|
|
1551 else
|
|
|
1552 result = buf;
|
|
|
1553 return result;
|
|
|
1554 }
|
|
|
1555
|
|
|
1556 static void
|
|
|
1557 write_float_string (st_parameter_dt *dtp, char *fstr, size_t len)
|
|
|
1558 {
|
|
|
1559 char *p = write_block (dtp, len);
|
|
|
1560 if (p == NULL)
|
|
|
1561 return;
|
|
|
1562
|
|
|
1563 if (unlikely (is_char4_unit (dtp)))
|
|
|
1564 {
|
|
|
1565 gfc_char4_t *p4 = (gfc_char4_t *) p;
|
|
|
1566 memcpy4 (p4, fstr, len);
|
|
|
1567 return;
|
|
|
1568 }
|
|
|
1569 memcpy (p, fstr, len);
|
|
|
1570 }
|
|
|
1571
|
|
|
1572
|
|
|
1573 static void
|
|
|
1574 write_float_0 (st_parameter_dt *dtp, const fnode *f, const char *source, int kind)
|
|
|
1575 {
|
|
|
1576 char buf_stack[BUF_STACK_SZ];
|
|
|
1577 char str_buf[BUF_STACK_SZ];
|
|
|
1578 char *buffer, *result;
|
|
131
|
1579 size_t buf_size, res_len, flt_str_len;
|
|
111
|
1580
|
|
|
1581 /* Precision for snprintf call. */
|
|
|
1582 int precision = get_precision (dtp, f, source, kind);
|
|
|
1583
|
|
|
1584 /* String buffer to hold final result. */
|
|
|
1585 result = select_string (dtp, f, str_buf, &res_len, kind);
|
|
131
|
1586
|
|
111
|
1587 buffer = select_buffer (dtp, f, precision, buf_stack, &buf_size, kind);
|
|
131
|
1588
|
|
111
|
1589 get_float_string (dtp, f, source , kind, 0, buffer,
|
|
131
|
1590 precision, buf_size, result, &flt_str_len);
|
|
|
1591 write_float_string (dtp, result, flt_str_len);
|
|
111
|
1592
|
|
|
1593 if (buf_size > BUF_STACK_SZ)
|
|
|
1594 free (buffer);
|
|
|
1595 if (res_len > BUF_STACK_SZ)
|
|
|
1596 free (result);
|
|
|
1597 }
|
|
|
1598
|
|
|
1599 void
|
|
|
1600 write_d (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
|
|
|
1601 {
|
|
|
1602 write_float_0 (dtp, f, p, len);
|
|
|
1603 }
|
|
|
1604
|
|
|
1605
|
|
|
1606 void
|
|
|
1607 write_e (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
|
|
|
1608 {
|
|
|
1609 write_float_0 (dtp, f, p, len);
|
|
|
1610 }
|
|
|
1611
|
|
|
1612
|
|
|
1613 void
|
|
|
1614 write_f (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
|
|
|
1615 {
|
|
|
1616 write_float_0 (dtp, f, p, len);
|
|
|
1617 }
|
|
|
1618
|
|
|
1619
|
|
|
1620 void
|
|
|
1621 write_en (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
|
|
|
1622 {
|
|
|
1623 write_float_0 (dtp, f, p, len);
|
|
|
1624 }
|
|
|
1625
|
|
|
1626
|
|
|
1627 void
|
|
|
1628 write_es (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
|
|
|
1629 {
|
|
|
1630 write_float_0 (dtp, f, p, len);
|
|
|
1631 }
|
|
|
1632
|
|
|
1633
|
|
|
1634 /* Set an fnode to default format. */
|
|
|
1635
|
|
|
1636 static void
|
|
|
1637 set_fnode_default (st_parameter_dt *dtp, fnode *f, int length)
|
|
|
1638 {
|
|
|
1639 f->format = FMT_G;
|
|
|
1640 switch (length)
|
|
|
1641 {
|
|
|
1642 case 4:
|
|
|
1643 f->u.real.w = 16;
|
|
|
1644 f->u.real.d = 9;
|
|
|
1645 f->u.real.e = 2;
|
|
|
1646 break;
|
|
|
1647 case 8:
|
|
|
1648 f->u.real.w = 25;
|
|
|
1649 f->u.real.d = 17;
|
|
|
1650 f->u.real.e = 3;
|
|
|
1651 break;
|
|
|
1652 case 10:
|
|
|
1653 f->u.real.w = 30;
|
|
|
1654 f->u.real.d = 21;
|
|
|
1655 f->u.real.e = 4;
|
|
|
1656 break;
|
|
|
1657 case 16:
|
|
|
1658 /* Adjust decimal precision depending on binary precision, 106 or 113. */
|
|
|
1659 #if GFC_REAL_16_DIGITS == 113
|
|
|
1660 f->u.real.w = 45;
|
|
|
1661 f->u.real.d = 36;
|
|
|
1662 f->u.real.e = 4;
|
|
|
1663 #else
|
|
|
1664 f->u.real.w = 41;
|
|
|
1665 f->u.real.d = 32;
|
|
|
1666 f->u.real.e = 4;
|
|
|
1667 #endif
|
|
|
1668 break;
|
|
|
1669 default:
|
|
|
1670 internal_error (&dtp->common, "bad real kind");
|
|
|
1671 break;
|
|
|
1672 }
|
|
|
1673 }
|
|
|
1674
|
|
|
1675 /* Output a real number with default format.
|
|
|
1676 To guarantee that a binary -> decimal -> binary roundtrip conversion
|
|
|
1677 recovers the original value, IEEE 754-2008 requires 9, 17, 21 and 36
|
|
|
1678 significant digits for REAL kinds 4, 8, 10, and 16, respectively.
|
|
|
1679 Thus, we use 1PG16.9E2 for REAL(4), 1PG25.17E3 for REAL(8), 1PG30.21E4
|
|
|
1680 for REAL(10) and 1PG45.36E4 for REAL(16). The exception is that the
|
|
|
1681 Fortran standard requires outputting an extra digit when the scale
|
|
|
1682 factor is 1 and when the magnitude of the value is such that E
|
|
|
1683 editing is used. However, gfortran compensates for this, and thus
|
|
|
1684 for list formatted the same number of significant digits is
|
|
|
1685 generated both when using F and E editing. */
|
|
|
1686
|
|
|
1687 void
|
|
|
1688 write_real (st_parameter_dt *dtp, const char *source, int kind)
|
|
|
1689 {
|
|
|
1690 fnode f ;
|
|
|
1691 char buf_stack[BUF_STACK_SZ];
|
|
|
1692 char str_buf[BUF_STACK_SZ];
|
|
|
1693 char *buffer, *result;
|
|
131
|
1694 size_t buf_size, res_len, flt_str_len;
|
|
111
|
1695 int orig_scale = dtp->u.p.scale_factor;
|
|
|
1696 dtp->u.p.scale_factor = 1;
|
|
|
1697 set_fnode_default (dtp, &f, kind);
|
|
|
1698
|
|
|
1699 /* Precision for snprintf call. */
|
|
|
1700 int precision = get_precision (dtp, &f, source, kind);
|
|
|
1701
|
|
|
1702 /* String buffer to hold final result. */
|
|
|
1703 result = select_string (dtp, &f, str_buf, &res_len, kind);
|
|
|
1704
|
|
|
1705 /* Scratch buffer to hold final result. */
|
|
|
1706 buffer = select_buffer (dtp, &f, precision, buf_stack, &buf_size, kind);
|
|
|
1707
|
|
|
1708 get_float_string (dtp, &f, source , kind, 1, buffer,
|
|
131
|
1709 precision, buf_size, result, &flt_str_len);
|
|
|
1710 write_float_string (dtp, result, flt_str_len);
|
|
111
|
1711
|
|
|
1712 dtp->u.p.scale_factor = orig_scale;
|
|
|
1713 if (buf_size > BUF_STACK_SZ)
|
|
|
1714 free (buffer);
|
|
|
1715 if (res_len > BUF_STACK_SZ)
|
|
|
1716 free (result);
|
|
|
1717 }
|
|
|
1718
|
|
|
1719 /* Similar to list formatted REAL output, for kPG0 where k > 0 we
|
|
|
1720 compensate for the extra digit. */
|
|
|
1721
|
|
|
1722 void
|
|
145
|
1723 write_real_w0 (st_parameter_dt *dtp, const char *source, int kind,
|
|
|
1724 const fnode* f)
|
|
111
|
1725 {
|
|
145
|
1726 fnode ff;
|
|
111
|
1727 char buf_stack[BUF_STACK_SZ];
|
|
|
1728 char str_buf[BUF_STACK_SZ];
|
|
|
1729 char *buffer, *result;
|
|
131
|
1730 size_t buf_size, res_len, flt_str_len;
|
|
145
|
1731 int comp_d = 0;
|
|
|
1732
|
|
|
1733 set_fnode_default (dtp, &ff, kind);
|
|
111
|
1734
|
|
145
|
1735 if (f->u.real.d > 0)
|
|
|
1736 ff.u.real.d = f->u.real.d;
|
|
|
1737 ff.format = f->format;
|
|
111
|
1738
|
|
145
|
1739 /* For FMT_G, Compensate for extra digits when using scale factor, d
|
|
|
1740 is not specified, and the magnitude is such that E editing
|
|
|
1741 is used. */
|
|
|
1742 if (f->format == FMT_G)
|
|
|
1743 {
|
|
|
1744 if (dtp->u.p.scale_factor > 0 && f->u.real.d == 0)
|
|
|
1745 comp_d = 1;
|
|
|
1746 else
|
|
|
1747 comp_d = 0;
|
|
|
1748 }
|
|
|
1749
|
|
|
1750 if (f->u.real.e >= 0)
|
|
|
1751 ff.u.real.e = f->u.real.e;
|
|
|
1752
|
|
111
|
1753 dtp->u.p.g0_no_blanks = 1;
|
|
|
1754
|
|
|
1755 /* Precision for snprintf call. */
|
|
145
|
1756 int precision = get_precision (dtp, &ff, source, kind);
|
|
111
|
1757
|
|
|
1758 /* String buffer to hold final result. */
|
|
145
|
1759 result = select_string (dtp, &ff, str_buf, &res_len, kind);
|
|
111
|
1760
|
|
145
|
1761 buffer = select_buffer (dtp, &ff, precision, buf_stack, &buf_size, kind);
|
|
111
|
1762
|
|
145
|
1763 get_float_string (dtp, &ff, source , kind, comp_d, buffer,
|
|
|
1764 precision, buf_size, result, &flt_str_len);
|
|
131
|
1765 write_float_string (dtp, result, flt_str_len);
|
|
111
|
1766
|
|
|
1767 dtp->u.p.g0_no_blanks = 0;
|
|
|
1768 if (buf_size > BUF_STACK_SZ)
|
|
|
1769 free (buffer);
|
|
|
1770 if (res_len > BUF_STACK_SZ)
|
|
|
1771 free (result);
|
|
|
1772 }
|
|
|
1773
|
|
|
1774
|
|
|
1775 static void
|
|
|
1776 write_complex (st_parameter_dt *dtp, const char *source, int kind, size_t size)
|
|
|
1777 {
|
|
|
1778 char semi_comma =
|
|
|
1779 dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';';
|
|
|
1780
|
|
|
1781 /* Set for no blanks so we get a string result with no leading
|
|
|
1782 blanks. We will pad left later. */
|
|
|
1783 dtp->u.p.g0_no_blanks = 1;
|
|
|
1784
|
|
|
1785 fnode f ;
|
|
|
1786 char buf_stack[BUF_STACK_SZ];
|
|
|
1787 char str1_buf[BUF_STACK_SZ];
|
|
|
1788 char str2_buf[BUF_STACK_SZ];
|
|
|
1789 char *buffer, *result1, *result2;
|
|
131
|
1790 size_t buf_size, res_len1, res_len2, flt_str_len1, flt_str_len2;
|
|
111
|
1791 int width, lblanks, orig_scale = dtp->u.p.scale_factor;
|
|
|
1792
|
|
|
1793 dtp->u.p.scale_factor = 1;
|
|
|
1794 set_fnode_default (dtp, &f, kind);
|
|
|
1795
|
|
|
1796 /* Set width for two values, parenthesis, and comma. */
|
|
|
1797 width = 2 * f.u.real.w + 3;
|
|
|
1798
|
|
|
1799 /* Set for no blanks so we get a string result with no leading
|
|
|
1800 blanks. We will pad left later. */
|
|
|
1801 dtp->u.p.g0_no_blanks = 1;
|
|
|
1802
|
|
|
1803 /* Precision for snprintf call. */
|
|
|
1804 int precision = get_precision (dtp, &f, source, kind);
|
|
|
1805
|
|
|
1806 /* String buffers to hold final result. */
|
|
|
1807 result1 = select_string (dtp, &f, str1_buf, &res_len1, kind);
|
|
|
1808 result2 = select_string (dtp, &f, str2_buf, &res_len2, kind);
|
|
|
1809
|
|
|
1810 buffer = select_buffer (dtp, &f, precision, buf_stack, &buf_size, kind);
|
|
|
1811
|
|
|
1812 get_float_string (dtp, &f, source , kind, 0, buffer,
|
|
131
|
1813 precision, buf_size, result1, &flt_str_len1);
|
|
111
|
1814 get_float_string (dtp, &f, source + size / 2 , kind, 0, buffer,
|
|
131
|
1815 precision, buf_size, result2, &flt_str_len2);
|
|
|
1816 if (!dtp->u.p.namelist_mode)
|
|
|
1817 {
|
|
|
1818 lblanks = width - flt_str_len1 - flt_str_len2 - 3;
|
|
|
1819 write_x (dtp, lblanks, lblanks);
|
|
|
1820 }
|
|
111
|
1821 write_char (dtp, '(');
|
|
131
|
1822 write_float_string (dtp, result1, flt_str_len1);
|
|
111
|
1823 write_char (dtp, semi_comma);
|
|
131
|
1824 write_float_string (dtp, result2, flt_str_len2);
|
|
111
|
1825 write_char (dtp, ')');
|
|
|
1826
|
|
|
1827 dtp->u.p.scale_factor = orig_scale;
|
|
|
1828 dtp->u.p.g0_no_blanks = 0;
|
|
|
1829 if (buf_size > BUF_STACK_SZ)
|
|
|
1830 free (buffer);
|
|
|
1831 if (res_len1 > BUF_STACK_SZ)
|
|
|
1832 free (result1);
|
|
|
1833 if (res_len2 > BUF_STACK_SZ)
|
|
|
1834 free (result2);
|
|
|
1835 }
|
|
|
1836
|
|
|
1837
|
|
|
1838 /* Write the separator between items. */
|
|
|
1839
|
|
|
1840 static void
|
|
|
1841 write_separator (st_parameter_dt *dtp)
|
|
|
1842 {
|
|
|
1843 char *p;
|
|
|
1844
|
|
|
1845 p = write_block (dtp, options.separator_len);
|
|
|
1846 if (p == NULL)
|
|
|
1847 return;
|
|
|
1848 if (unlikely (is_char4_unit (dtp)))
|
|
|
1849 {
|
|
|
1850 gfc_char4_t *p4 = (gfc_char4_t *) p;
|
|
|
1851 memcpy4 (p4, options.separator, options.separator_len);
|
|
|
1852 }
|
|
|
1853 else
|
|
|
1854 memcpy (p, options.separator, options.separator_len);
|
|
|
1855 }
|
|
|
1856
|
|
|
1857
|
|
|
1858 /* Write an item with list formatting.
|
|
|
1859 TODO: handle skipping to the next record correctly, particularly
|
|
|
1860 with strings. */
|
|
|
1861
|
|
|
1862 static void
|
|
|
1863 list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
|
|
|
1864 size_t size)
|
|
|
1865 {
|
|
|
1866 if (dtp->u.p.current_unit == NULL)
|
|
|
1867 return;
|
|
|
1868
|
|
|
1869 if (dtp->u.p.first_item)
|
|
|
1870 {
|
|
|
1871 dtp->u.p.first_item = 0;
|
|
|
1872 if (dtp->u.p.current_unit->flags.cc != CC_FORTRAN)
|
|
|
1873 write_char (dtp, ' ');
|
|
|
1874 }
|
|
|
1875 else
|
|
|
1876 {
|
|
|
1877 if (type != BT_CHARACTER || !dtp->u.p.char_flag ||
|
|
|
1878 (dtp->u.p.current_unit->delim_status != DELIM_NONE
|
|
|
1879 && dtp->u.p.current_unit->delim_status != DELIM_UNSPECIFIED))
|
|
|
1880 write_separator (dtp);
|
|
|
1881 }
|
|
|
1882
|
|
|
1883 switch (type)
|
|
|
1884 {
|
|
|
1885 case BT_INTEGER:
|
|
|
1886 write_integer (dtp, p, kind);
|
|
|
1887 break;
|
|
|
1888 case BT_LOGICAL:
|
|
|
1889 write_logical (dtp, p, kind);
|
|
|
1890 break;
|
|
|
1891 case BT_CHARACTER:
|
|
|
1892 write_character (dtp, p, kind, size, DELIM);
|
|
|
1893 break;
|
|
|
1894 case BT_REAL:
|
|
|
1895 write_real (dtp, p, kind);
|
|
|
1896 break;
|
|
|
1897 case BT_COMPLEX:
|
|
|
1898 write_complex (dtp, p, kind, size);
|
|
|
1899 break;
|
|
|
1900 case BT_CLASS:
|
|
|
1901 {
|
|
|
1902 int unit = dtp->u.p.current_unit->unit_number;
|
|
|
1903 char iotype[] = "LISTDIRECTED";
|
|
|
1904 gfc_charlen_type iotype_len = 12;
|
|
|
1905 char tmp_iomsg[IOMSG_LEN] = "";
|
|
|
1906 char *child_iomsg;
|
|
|
1907 gfc_charlen_type child_iomsg_len;
|
|
|
1908 int noiostat;
|
|
|
1909 int *child_iostat = NULL;
|
|
131
|
1910 gfc_full_array_i4 vlist;
|
|
111
|
1911
|
|
|
1912 GFC_DESCRIPTOR_DATA(&vlist) = NULL;
|
|
|
1913 GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0);
|
|
|
1914
|
|
|
1915 /* Set iostat, intent(out). */
|
|
|
1916 noiostat = 0;
|
|
|
1917 child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
|
|
|
1918 dtp->common.iostat : &noiostat;
|
|
|
1919
|
|
|
1920 /* Set iomsge, intent(inout). */
|
|
|
1921 if (dtp->common.flags & IOPARM_HAS_IOMSG)
|
|
|
1922 {
|
|
|
1923 child_iomsg = dtp->common.iomsg;
|
|
|
1924 child_iomsg_len = dtp->common.iomsg_len;
|
|
|
1925 }
|
|
|
1926 else
|
|
|
1927 {
|
|
|
1928 child_iomsg = tmp_iomsg;
|
|
|
1929 child_iomsg_len = IOMSG_LEN;
|
|
|
1930 }
|
|
|
1931
|
|
|
1932 /* Call the user defined formatted WRITE procedure. */
|
|
|
1933 dtp->u.p.current_unit->child_dtio++;
|
|
|
1934 dtp->u.p.fdtio_ptr (p, &unit, iotype, &vlist,
|
|
|
1935 child_iostat, child_iomsg,
|
|
|
1936 iotype_len, child_iomsg_len);
|
|
|
1937 dtp->u.p.current_unit->child_dtio--;
|
|
|
1938 }
|
|
|
1939 break;
|
|
|
1940 default:
|
|
|
1941 internal_error (&dtp->common, "list_formatted_write(): Bad type");
|
|
|
1942 }
|
|
|
1943
|
|
|
1944 fbuf_flush_list (dtp->u.p.current_unit, LIST_WRITING);
|
|
|
1945 dtp->u.p.char_flag = (type == BT_CHARACTER);
|
|
|
1946 }
|
|
|
1947
|
|
|
1948
|
|
|
1949 void
|
|
|
1950 list_formatted_write (st_parameter_dt *dtp, bt type, void *p, int kind,
|
|
|
1951 size_t size, size_t nelems)
|
|
|
1952 {
|
|
|
1953 size_t elem;
|
|
|
1954 char *tmp;
|
|
|
1955 size_t stride = type == BT_CHARACTER ?
|
|
|
1956 size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
|
|
|
1957
|
|
|
1958 tmp = (char *) p;
|
|
|
1959
|
|
|
1960 /* Big loop over all the elements. */
|
|
|
1961 for (elem = 0; elem < nelems; elem++)
|
|
|
1962 {
|
|
|
1963 dtp->u.p.item_count++;
|
|
|
1964 list_formatted_write_scalar (dtp, type, tmp + elem * stride, kind, size);
|
|
|
1965 }
|
|
|
1966 }
|
|
|
1967
|
|
|
1968 /* NAMELIST OUTPUT
|
|
|
1969
|
|
|
1970 nml_write_obj writes a namelist object to the output stream. It is called
|
|
|
1971 recursively for derived type components:
|
|
|
1972 obj = is the namelist_info for the current object.
|
|
|
1973 offset = the offset relative to the address held by the object for
|
|
|
1974 derived type arrays.
|
|
|
1975 base = is the namelist_info of the derived type, when obj is a
|
|
|
1976 component.
|
|
|
1977 base_name = the full name for a derived type, including qualifiers
|
|
|
1978 if any.
|
|
|
1979 The returned value is a pointer to the object beyond the last one
|
|
|
1980 accessed, including nested derived types. Notice that the namelist is
|
|
|
1981 a linear linked list of objects, including derived types and their
|
|
|
1982 components. A tree, of sorts, is implied by the compound names of
|
|
|
1983 the derived type components and this is how this function recurses through
|
|
|
1984 the list. */
|
|
|
1985
|
|
|
1986 /* A generous estimate of the number of characters needed to print
|
|
|
1987 repeat counts and indices, including commas, asterices and brackets. */
|
|
|
1988
|
|
|
1989 #define NML_DIGITS 20
|
|
|
1990
|
|
|
1991 static void
|
|
|
1992 namelist_write_newline (st_parameter_dt *dtp)
|
|
|
1993 {
|
|
|
1994 if (!is_internal_unit (dtp))
|
|
|
1995 {
|
|
|
1996 #ifdef HAVE_CRLF
|
|
|
1997 write_character (dtp, "\r\n", 1, 2, NODELIM);
|
|
|
1998 #else
|
|
|
1999 write_character (dtp, "\n", 1, 1, NODELIM);
|
|
|
2000 #endif
|
|
|
2001 return;
|
|
|
2002 }
|
|
|
2003
|
|
|
2004 if (is_array_io (dtp))
|
|
|
2005 {
|
|
|
2006 gfc_offset record;
|
|
|
2007 int finished;
|
|
|
2008 char *p;
|
|
|
2009 int length = dtp->u.p.current_unit->bytes_left;
|
|
|
2010
|
|
|
2011 p = write_block (dtp, length);
|
|
|
2012 if (p == NULL)
|
|
|
2013 return;
|
|
|
2014
|
|
|
2015 if (unlikely (is_char4_unit (dtp)))
|
|
|
2016 {
|
|
|
2017 gfc_char4_t *p4 = (gfc_char4_t *) p;
|
|
|
2018 memset4 (p4, ' ', length);
|
|
|
2019 }
|
|
|
2020 else
|
|
|
2021 memset (p, ' ', length);
|
|
|
2022
|
|
|
2023 /* Now that the current record has been padded out,
|
|
|
2024 determine where the next record in the array is. */
|
|
|
2025 record = next_array_record (dtp, dtp->u.p.current_unit->ls,
|
|
|
2026 &finished);
|
|
|
2027 if (finished)
|
|
|
2028 dtp->u.p.current_unit->endfile = AT_ENDFILE;
|
|
|
2029 else
|
|
|
2030 {
|
|
|
2031 /* Now seek to this record */
|
|
|
2032 record = record * dtp->u.p.current_unit->recl;
|
|
|
2033
|
|
|
2034 if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
|
|
|
2035 {
|
|
|
2036 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
|
|
|
2037 return;
|
|
|
2038 }
|
|
|
2039
|
|
|
2040 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
|
|
|
2041 }
|
|
|
2042 }
|
|
|
2043 else
|
|
|
2044 write_character (dtp, " ", 1, 1, NODELIM);
|
|
|
2045 }
|
|
|
2046
|
|
|
2047
|
|
|
2048 static namelist_info *
|
|
|
2049 nml_write_obj (st_parameter_dt *dtp, namelist_info *obj, index_type offset,
|
|
|
2050 namelist_info *base, char *base_name)
|
|
|
2051 {
|
|
|
2052 int rep_ctr;
|
|
|
2053 int num;
|
|
|
2054 int nml_carry;
|
|
|
2055 int len;
|
|
|
2056 index_type obj_size;
|
|
|
2057 index_type nelem;
|
|
|
2058 size_t dim_i;
|
|
|
2059 size_t clen;
|
|
|
2060 index_type elem_ctr;
|
|
|
2061 size_t obj_name_len;
|
|
|
2062 void *p;
|
|
|
2063 char cup;
|
|
|
2064 char *obj_name;
|
|
|
2065 char *ext_name;
|
|
|
2066 char *q;
|
|
|
2067 size_t ext_name_len;
|
|
|
2068 char rep_buff[NML_DIGITS];
|
|
|
2069 namelist_info *cmp;
|
|
|
2070 namelist_info *retval = obj->next;
|
|
|
2071 size_t base_name_len;
|
|
|
2072 size_t base_var_name_len;
|
|
|
2073 size_t tot_len;
|
|
|
2074
|
|
|
2075 /* Set the character to be used to separate values
|
|
|
2076 to a comma or semi-colon. */
|
|
|
2077
|
|
|
2078 char semi_comma =
|
|
|
2079 dtp->u.p.current_unit->decimal_status == DECIMAL_POINT ? ',' : ';';
|
|
|
2080
|
|
|
2081 /* Write namelist variable names in upper case. If a derived type,
|
|
|
2082 nothing is output. If a component, base and base_name are set. */
|
|
|
2083
|
|
|
2084 if (obj->type != BT_DERIVED || obj->dtio_sub != NULL)
|
|
|
2085 {
|
|
|
2086 namelist_write_newline (dtp);
|
|
|
2087 write_character (dtp, " ", 1, 1, NODELIM);
|
|
|
2088
|
|
|
2089 len = 0;
|
|
|
2090 if (base)
|
|
|
2091 {
|
|
|
2092 len = strlen (base->var_name);
|
|
|
2093 base_name_len = strlen (base_name);
|
|
|
2094 for (dim_i = 0; dim_i < base_name_len; dim_i++)
|
|
|
2095 {
|
|
|
2096 cup = toupper ((int) base_name[dim_i]);
|
|
|
2097 write_character (dtp, &cup, 1, 1, NODELIM);
|
|
|
2098 }
|
|
|
2099 }
|
|
|
2100 clen = strlen (obj->var_name);
|
|
|
2101 for (dim_i = len; dim_i < clen; dim_i++)
|
|
|
2102 {
|
|
|
2103 cup = toupper ((int) obj->var_name[dim_i]);
|
|
|
2104 if (cup == '+')
|
|
|
2105 cup = '%';
|
|
|
2106 write_character (dtp, &cup, 1, 1, NODELIM);
|
|
|
2107 }
|
|
|
2108 write_character (dtp, "=", 1, 1, NODELIM);
|
|
|
2109 }
|
|
|
2110
|
|
|
2111 /* Counts the number of data output on a line, including names. */
|
|
|
2112
|
|
|
2113 num = 1;
|
|
|
2114
|
|
|
2115 len = obj->len;
|
|
|
2116
|
|
|
2117 switch (obj->type)
|
|
|
2118 {
|
|
|
2119
|
|
|
2120 case BT_REAL:
|
|
|
2121 obj_size = size_from_real_kind (len);
|
|
|
2122 break;
|
|
|
2123
|
|
|
2124 case BT_COMPLEX:
|
|
|
2125 obj_size = size_from_complex_kind (len);
|
|
|
2126 break;
|
|
|
2127
|
|
|
2128 case BT_CHARACTER:
|
|
|
2129 obj_size = obj->string_length;
|
|
|
2130 break;
|
|
|
2131
|
|
|
2132 default:
|
|
|
2133 obj_size = len;
|
|
|
2134 }
|
|
|
2135
|
|
|
2136 if (obj->var_rank)
|
|
|
2137 obj_size = obj->size;
|
|
|
2138
|
|
|
2139 /* Set the index vector and count the number of elements. */
|
|
|
2140
|
|
|
2141 nelem = 1;
|
|
|
2142 for (dim_i = 0; dim_i < (size_t) obj->var_rank; dim_i++)
|
|
|
2143 {
|
|
|
2144 obj->ls[dim_i].idx = GFC_DESCRIPTOR_LBOUND(obj, dim_i);
|
|
|
2145 nelem = nelem * GFC_DESCRIPTOR_EXTENT (obj, dim_i);
|
|
|
2146 }
|
|
|
2147
|
|
|
2148 /* Main loop to output the data held in the object. */
|
|
|
2149
|
|
|
2150 rep_ctr = 1;
|
|
|
2151 for (elem_ctr = 0; elem_ctr < nelem; elem_ctr++)
|
|
|
2152 {
|
|
|
2153
|
|
|
2154 /* Build the pointer to the data value. The offset is passed by
|
|
|
2155 recursive calls to this function for arrays of derived types.
|
|
|
2156 Is NULL otherwise. */
|
|
|
2157
|
|
|
2158 p = (void *)(obj->mem_pos + elem_ctr * obj_size);
|
|
|
2159 p += offset;
|
|
|
2160
|
|
|
2161 /* Check for repeat counts of intrinsic types. */
|
|
|
2162
|
|
|
2163 if ((elem_ctr < (nelem - 1)) &&
|
|
|
2164 (obj->type != BT_DERIVED) &&
|
|
|
2165 !memcmp (p, (void *)(p + obj_size ), obj_size ))
|
|
|
2166 {
|
|
|
2167 rep_ctr++;
|
|
|
2168 }
|
|
|
2169
|
|
|
2170 /* Execute a repeated output. Note the flag no_leading_blank that
|
|
|
2171 is used in the functions used to output the intrinsic types. */
|
|
|
2172
|
|
|
2173 else
|
|
|
2174 {
|
|
|
2175 if (rep_ctr > 1)
|
|
|
2176 {
|
|
|
2177 snprintf(rep_buff, NML_DIGITS, " %d*", rep_ctr);
|
|
|
2178 write_character (dtp, rep_buff, 1, strlen (rep_buff), NODELIM);
|
|
|
2179 dtp->u.p.no_leading_blank = 1;
|
|
|
2180 }
|
|
|
2181 num++;
|
|
|
2182
|
|
|
2183 /* Output the data, if an intrinsic type, or recurse into this
|
|
|
2184 routine to treat derived types. */
|
|
|
2185
|
|
|
2186 switch (obj->type)
|
|
|
2187 {
|
|
|
2188
|
|
|
2189 case BT_INTEGER:
|
|
|
2190 write_integer (dtp, p, len);
|
|
|
2191 break;
|
|
|
2192
|
|
|
2193 case BT_LOGICAL:
|
|
|
2194 write_logical (dtp, p, len);
|
|
|
2195 break;
|
|
|
2196
|
|
|
2197 case BT_CHARACTER:
|
|
|
2198 if (dtp->u.p.current_unit->flags.encoding == ENCODING_UTF8)
|
|
|
2199 write_character (dtp, p, 4, obj->string_length, DELIM);
|
|
|
2200 else
|
|
|
2201 write_character (dtp, p, 1, obj->string_length, DELIM);
|
|
|
2202 break;
|
|
|
2203
|
|
|
2204 case BT_REAL:
|
|
|
2205 write_real (dtp, p, len);
|
|
|
2206 break;
|
|
|
2207
|
|
|
2208 case BT_COMPLEX:
|
|
|
2209 dtp->u.p.no_leading_blank = 0;
|
|
|
2210 num++;
|
|
|
2211 write_complex (dtp, p, len, obj_size);
|
|
|
2212 break;
|
|
|
2213
|
|
|
2214 case BT_DERIVED:
|
|
|
2215 case BT_CLASS:
|
|
|
2216 /* To treat a derived type, we need to build two strings:
|
|
|
2217 ext_name = the name, including qualifiers that prepends
|
|
|
2218 component names in the output - passed to
|
|
|
2219 nml_write_obj.
|
|
|
2220 obj_name = the derived type name with no qualifiers but %
|
|
|
2221 appended. This is used to identify the
|
|
|
2222 components. */
|
|
|
2223
|
|
|
2224 /* First ext_name => get length of all possible components */
|
|
|
2225 if (obj->dtio_sub != NULL)
|
|
|
2226 {
|
|
|
2227 int unit = dtp->u.p.current_unit->unit_number;
|
|
|
2228 char iotype[] = "NAMELIST";
|
|
|
2229 gfc_charlen_type iotype_len = 8;
|
|
|
2230 char tmp_iomsg[IOMSG_LEN] = "";
|
|
|
2231 char *child_iomsg;
|
|
|
2232 gfc_charlen_type child_iomsg_len;
|
|
|
2233 int noiostat;
|
|
|
2234 int *child_iostat = NULL;
|
|
131
|
2235 gfc_full_array_i4 vlist;
|
|
111
|
2236 formatted_dtio dtio_ptr = (formatted_dtio)obj->dtio_sub;
|
|
|
2237
|
|
|
2238 GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0);
|
|
|
2239
|
|
|
2240 /* Set iostat, intent(out). */
|
|
|
2241 noiostat = 0;
|
|
|
2242 child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
|
|
|
2243 dtp->common.iostat : &noiostat;
|
|
|
2244
|
|
|
2245 /* Set iomsg, intent(inout). */
|
|
|
2246 if (dtp->common.flags & IOPARM_HAS_IOMSG)
|
|
|
2247 {
|
|
|
2248 child_iomsg = dtp->common.iomsg;
|
|
|
2249 child_iomsg_len = dtp->common.iomsg_len;
|
|
|
2250 }
|
|
|
2251 else
|
|
|
2252 {
|
|
|
2253 child_iomsg = tmp_iomsg;
|
|
|
2254 child_iomsg_len = IOMSG_LEN;
|
|
|
2255 }
|
|
|
2256
|
|
|
2257 /* Call the user defined formatted WRITE procedure. */
|
|
|
2258 dtp->u.p.current_unit->child_dtio++;
|
|
|
2259 if (obj->type == BT_DERIVED)
|
|
|
2260 {
|
|
131
|
2261 /* Build a class container. */
|
|
111
|
2262 gfc_class list_obj;
|
|
|
2263 list_obj.data = p;
|
|
|
2264 list_obj.vptr = obj->vtable;
|
|
|
2265 list_obj.len = 0;
|
|
|
2266 dtio_ptr ((void *)&list_obj, &unit, iotype, &vlist,
|
|
|
2267 child_iostat, child_iomsg,
|
|
|
2268 iotype_len, child_iomsg_len);
|
|
|
2269 }
|
|
|
2270 else
|
|
|
2271 {
|
|
|
2272 dtio_ptr (p, &unit, iotype, &vlist,
|
|
|
2273 child_iostat, child_iomsg,
|
|
|
2274 iotype_len, child_iomsg_len);
|
|
|
2275 }
|
|
|
2276 dtp->u.p.current_unit->child_dtio--;
|
|
|
2277
|
|
|
2278 goto obj_loop;
|
|
|
2279 }
|
|
|
2280
|
|
|
2281 base_name_len = base_name ? strlen (base_name) : 0;
|
|
|
2282 base_var_name_len = base ? strlen (base->var_name) : 0;
|
|
|
2283 ext_name_len = base_name_len + base_var_name_len
|
|
|
2284 + strlen (obj->var_name) + obj->var_rank * NML_DIGITS + 1;
|
|
|
2285 ext_name = xmalloc (ext_name_len);
|
|
|
2286
|
|
|
2287 if (base_name)
|
|
|
2288 memcpy (ext_name, base_name, base_name_len);
|
|
|
2289 clen = strlen (obj->var_name + base_var_name_len);
|
|
|
2290 memcpy (ext_name + base_name_len,
|
|
|
2291 obj->var_name + base_var_name_len, clen);
|
|
|
2292
|
|
|
2293 /* Append the qualifier. */
|
|
|
2294
|
|
|
2295 tot_len = base_name_len + clen;
|
|
|
2296 for (dim_i = 0; dim_i < (size_t) obj->var_rank; dim_i++)
|
|
|
2297 {
|
|
|
2298 if (!dim_i)
|
|
|
2299 {
|
|
|
2300 ext_name[tot_len] = '(';
|
|
|
2301 tot_len++;
|
|
|
2302 }
|
|
|
2303 snprintf (ext_name + tot_len, ext_name_len - tot_len, "%d",
|
|
|
2304 (int) obj->ls[dim_i].idx);
|
|
|
2305 tot_len += strlen (ext_name + tot_len);
|
|
|
2306 ext_name[tot_len] = ((int) dim_i == obj->var_rank - 1) ? ')' : ',';
|
|
|
2307 tot_len++;
|
|
|
2308 }
|
|
|
2309
|
|
|
2310 ext_name[tot_len] = '\0';
|
|
|
2311 for (q = ext_name; *q; q++)
|
|
|
2312 if (*q == '+')
|
|
|
2313 *q = '%';
|
|
|
2314
|
|
|
2315 /* Now obj_name. */
|
|
|
2316
|
|
|
2317 obj_name_len = strlen (obj->var_name) + 1;
|
|
|
2318 obj_name = xmalloc (obj_name_len + 1);
|
|
|
2319 memcpy (obj_name, obj->var_name, obj_name_len-1);
|
|
|
2320 memcpy (obj_name + obj_name_len-1, "%", 2);
|
|
|
2321
|
|
|
2322 /* Now loop over the components. Update the component pointer
|
|
|
2323 with the return value from nml_write_obj => this loop jumps
|
|
|
2324 past nested derived types. */
|
|
|
2325
|
|
|
2326 for (cmp = obj->next;
|
|
|
2327 cmp && !strncmp (cmp->var_name, obj_name, obj_name_len);
|
|
|
2328 cmp = retval)
|
|
|
2329 {
|
|
|
2330 retval = nml_write_obj (dtp, cmp,
|
|
|
2331 (index_type)(p - obj->mem_pos),
|
|
|
2332 obj, ext_name);
|
|
|
2333 }
|
|
|
2334
|
|
|
2335 free (obj_name);
|
|
|
2336 free (ext_name);
|
|
|
2337 goto obj_loop;
|
|
|
2338
|
|
|
2339 default:
|
|
|
2340 internal_error (&dtp->common, "Bad type for namelist write");
|
|
|
2341 }
|
|
|
2342
|
|
|
2343 /* Reset the leading blank suppression, write a comma (or semi-colon)
|
|
|
2344 and, if 5 values have been output, write a newline and advance
|
|
|
2345 to column 2. Reset the repeat counter. */
|
|
|
2346
|
|
|
2347 dtp->u.p.no_leading_blank = 0;
|
|
|
2348 if (obj->type == BT_CHARACTER)
|
|
|
2349 {
|
|
|
2350 if (dtp->u.p.nml_delim != '\0')
|
|
|
2351 write_character (dtp, &semi_comma, 1, 1, NODELIM);
|
|
|
2352 }
|
|
|
2353 else
|
|
|
2354 write_character (dtp, &semi_comma, 1, 1, NODELIM);
|
|
|
2355 if (num > 5)
|
|
|
2356 {
|
|
|
2357 num = 0;
|
|
|
2358 if (dtp->u.p.nml_delim == '\0')
|
|
|
2359 write_character (dtp, &semi_comma, 1, 1, NODELIM);
|
|
|
2360 namelist_write_newline (dtp);
|
|
|
2361 write_character (dtp, " ", 1, 1, NODELIM);
|
|
|
2362 }
|
|
|
2363 rep_ctr = 1;
|
|
|
2364 }
|
|
|
2365
|
|
|
2366 /* Cycle through and increment the index vector. */
|
|
|
2367
|
|
|
2368 obj_loop:
|
|
|
2369
|
|
|
2370 nml_carry = 1;
|
|
|
2371 for (dim_i = 0; nml_carry && (dim_i < (size_t) obj->var_rank); dim_i++)
|
|
|
2372 {
|
|
|
2373 obj->ls[dim_i].idx += nml_carry ;
|
|
|
2374 nml_carry = 0;
|
|
|
2375 if (obj->ls[dim_i].idx > GFC_DESCRIPTOR_UBOUND(obj,dim_i))
|
|
|
2376 {
|
|
|
2377 obj->ls[dim_i].idx = GFC_DESCRIPTOR_LBOUND(obj,dim_i);
|
|
|
2378 nml_carry = 1;
|
|
|
2379 }
|
|
|
2380 }
|
|
|
2381 }
|
|
|
2382
|
|
|
2383 /* Return a pointer beyond the furthest object accessed. */
|
|
|
2384
|
|
|
2385 return retval;
|
|
|
2386 }
|
|
|
2387
|
|
|
2388
|
|
|
2389 /* This is the entry function for namelist writes. It outputs the name
|
|
|
2390 of the namelist and iterates through the namelist by calls to
|
|
|
2391 nml_write_obj. The call below has dummys in the arguments used in
|
|
|
2392 the treatment of derived types. */
|
|
|
2393
|
|
|
2394 void
|
|
|
2395 namelist_write (st_parameter_dt *dtp)
|
|
|
2396 {
|
|
|
2397 namelist_info *t1, *t2, *dummy = NULL;
|
|
|
2398 index_type dummy_offset = 0;
|
|
|
2399 char c;
|
|
|
2400 char *dummy_name = NULL;
|
|
|
2401
|
|
|
2402 /* Set the delimiter for namelist output. */
|
|
|
2403 switch (dtp->u.p.current_unit->delim_status)
|
|
|
2404 {
|
|
|
2405 case DELIM_APOSTROPHE:
|
|
|
2406 dtp->u.p.nml_delim = '\'';
|
|
|
2407 break;
|
|
|
2408 case DELIM_QUOTE:
|
|
|
2409 case DELIM_UNSPECIFIED:
|
|
|
2410 dtp->u.p.nml_delim = '"';
|
|
|
2411 break;
|
|
|
2412 default:
|
|
|
2413 dtp->u.p.nml_delim = '\0';
|
|
|
2414 }
|
|
|
2415
|
|
|
2416 write_character (dtp, "&", 1, 1, NODELIM);
|
|
|
2417
|
|
|
2418 /* Write namelist name in upper case - f95 std. */
|
|
131
|
2419 for (gfc_charlen_type i = 0; i < dtp->namelist_name_len; i++ )
|
|
111
|
2420 {
|
|
|
2421 c = toupper ((int) dtp->namelist_name[i]);
|
|
|
2422 write_character (dtp, &c, 1 ,1, NODELIM);
|
|
|
2423 }
|
|
|
2424
|
|
|
2425 if (dtp->u.p.ionml != NULL)
|
|
|
2426 {
|
|
|
2427 t1 = dtp->u.p.ionml;
|
|
|
2428 while (t1 != NULL)
|
|
|
2429 {
|
|
|
2430 t2 = t1;
|
|
|
2431 t1 = nml_write_obj (dtp, t2, dummy_offset, dummy, dummy_name);
|
|
|
2432 }
|
|
|
2433 }
|
|
|
2434
|
|
|
2435 namelist_write_newline (dtp);
|
|
|
2436 write_character (dtp, " /", 1, 2, NODELIM);
|
|
|
2437 }
|
|
|
2438
|
|
|
2439 #undef NML_DIGITS
|
