1/* Copyright (C) 2002-2020 Free Software Foundation, Inc. 2 Contributed by Andy Vaught 3 Namelist output contributed by Paul Thomas 4 F2003 I/O support contributed by Jerry DeLisle 5 6This file is part of the GNU Fortran runtime library (libgfortran). 7 8Libgfortran is free software; you can redistribute it and/or modify 9it under the terms of the GNU General Public License as published by 10the Free Software Foundation; either version 3, or (at your option) 11any later version. 12 13Libgfortran is distributed in the hope that it will be useful, 14but WITHOUT ANY WARRANTY; without even the implied warranty of 15MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16GNU General Public License for more details. 17 18Under Section 7 of GPL version 3, you are granted additional 19permissions described in the GCC Runtime Library Exception, version 203.1, as published by the Free Software Foundation. 21 22You should have received a copy of the GNU General Public License and 23a copy of the GCC Runtime Library Exception along with this program; 24see 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 37typedef unsigned char uchar; 38 39/* Helper functions for character(kind=4) internal units. These are needed 40 by write_float.def. */ 41 42static void 43memcpy4 (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 57static void 58write_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 145static void 146write_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 237static void 238write_check_cc (st_parameter_dt *dtp, const char **source, size_t *alloc_len) 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 313static char * 314write_cc (st_parameter_dt *dtp, char *p, size_t *source_len) 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 362void 363 364write_a (st_parameter_dt *dtp, const fnode *f, const char *source, size_t len) 365{ 366 size_t wlen; 367 char *p; 368 369 wlen = f->u.string.length < 0 370 || (f->format == FMT_G && f->u.string.length == 0) 371 ? len : (size_t) f->u.string.length; 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"; 380 size_t q, bytes; 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. */ 393 for (size_t i = 0; i < wlen; i++) 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 474void 475write_a_char4 (st_parameter_dt *dtp, const fnode *f, const char *source, size_t len) 476{ 477 size_t wlen; 478 gfc_char4_t *q; 479 480 wlen = f->u.string.length < 0 481 || (f->format == FMT_G && f->u.string.length == 0) 482 ? len : (size_t) f->u.string.length; 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}; 492 size_t bytes; 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; 508 for (size_t i = 0; i < wlen; i++) 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 551static GFC_INTEGER_LARGEST 552extract_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 605static GFC_UINTEGER_LARGEST 606extract_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 661void 662write_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 688static void 689write_boz (st_parameter_dt *dtp, const fnode *f, const char *q, int n, int len) 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 722 if (w == DEFAULT_WIDTH) 723 w = default_width_for_integer (len); 724 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 797static void 798write_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. */ 851 if (w == DEFAULT_WIDTH) 852 w = default_width_for_integer (len); 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 878 if (!dtp->u.p.namelist_mode) 879 { 880 memset4 (p4, ' ', nblank); 881 p4 += nblank; 882 } 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; 901 902 if (dtp->u.p.namelist_mode) 903 { 904 p4 += digits; 905 memset4 (p4, ' ', nblank); 906 } 907 } 908 909 if (nblank < 0) 910 { 911 star_fill (p, w); 912 goto done; 913 } 914 915 if (!dtp->u.p.namelist_mode) 916 { 917 memset (p, ' ', nblank); 918 p += nblank; 919 } 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 938 if (dtp->u.p.namelist_mode) 939 { 940 p += digits; 941 memset (p, ' ', nblank); 942 } 943 944 done: 945 return; 946} 947 948 949/* Convert unsigned octal to ascii. */ 950 951static const char * 952otoa (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 976static const char * 977btoa (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 1005static const char * 1006btoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n) 1007{ 1008 char *q; 1009 int i, j; 1010 1011 q = buffer; 1012 if (__BYTE_ORDER__ == __ORDER_BIG_ENDIAN__) 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 1064static const char * 1065otoa_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 1075 if (__BYTE_ORDER__ == __ORDER_BIG_ENDIAN__) 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 1138static const char * 1139ztoa_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 1150 if (__BYTE_ORDER__ == __ORDER_BIG_ENDIAN__) 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 1194void 1195write_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 1201void 1202write_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 1208 /* Ensure we end up with a null terminated string. */ 1209 memset(itoa_buf, '\0', GFC_BTOA_BUF_SIZE); 1210 1211 if (len > (int) sizeof (GFC_UINTEGER_LARGEST)) 1212 { 1213 p = btoa_big (source, itoa_buf, len, &n); 1214 write_boz (dtp, f, p, n, len); 1215 } 1216 else 1217 { 1218 n = extract_uint (source, len); 1219 p = btoa (n, itoa_buf, sizeof (itoa_buf)); 1220 write_boz (dtp, f, p, n, len); 1221 } 1222} 1223 1224 1225void 1226write_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); 1235 write_boz (dtp, f, p, n, len); 1236 } 1237 else 1238 { 1239 n = extract_uint (source, len); 1240 p = otoa (n, itoa_buf, sizeof (itoa_buf)); 1241 write_boz (dtp, f, p, n, len); 1242 } 1243} 1244 1245void 1246write_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); 1255 write_boz (dtp, f, p, n, len); 1256 } 1257 else 1258 { 1259 n = extract_uint (source, len); 1260 p = gfc_xtoa (n, itoa_buf, sizeof (itoa_buf)); 1261 write_boz (dtp, f, p, n, len); 1262 } 1263} 1264 1265/* Take care of the X/TR descriptor. */ 1266 1267void 1268write_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 1294static int 1295write_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 1317static void 1318write_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 1326static void 1327write_integer (st_parameter_dt *dtp, const char *source, int kind) 1328{ 1329 int width; 1330 fnode f; 1331 1332 switch (kind) 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 1350 case 16: 1351 width = 40; 1352 break; 1353 1354 default: 1355 width = 0; 1356 break; 1357 } 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); 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 1371static void 1372write_character (st_parameter_dt *dtp, const char *source, int kind, size_t length, int mode) 1373{ 1374 size_t extra; 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 1403 for (size_t i = 0; i < length; i++) 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 1423 for (size_t i = 0; i < length; i++) 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 1441 for (size_t i = 0; i < length; i++) 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 1478#define BUF_STACK_SZ 384 1479 1480static int 1481get_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. */ 1494static int 1495size_from_kind (st_parameter_dt *dtp, const fnode *f, int kind) 1496{ 1497 int size; 1498 1499 if ((f->format == FMT_F && f->u.real.w == 0) || f->u.real.w == DEFAULT_WIDTH) 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 1526static char * 1527select_buffer (st_parameter_dt *dtp, const fnode *f, int precision, 1528 char *buf, size_t *size, int kind) 1529{ 1530 char *result; 1531 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; 1535 1536 if (*size > BUF_STACK_SZ) 1537 result = xmalloc (*size); 1538 else 1539 result = buf; 1540 return result; 1541} 1542 1543static char * 1544select_string (st_parameter_dt *dtp, const fnode *f, char *buf, size_t *size, 1545 int kind) 1546{ 1547 char *result; 1548 *size = size_from_kind (dtp, f, kind) + f->u.real.d + 1; 1549 if (*size > BUF_STACK_SZ) 1550 result = xmalloc (*size); 1551 else 1552 result = buf; 1553 return result; 1554} 1555 1556static void 1557write_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 1573static void 1574write_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; 1579 size_t buf_size, res_len, flt_str_len; 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); 1586 1587 buffer = select_buffer (dtp, f, precision, buf_stack, &buf_size, kind); 1588 1589 get_float_string (dtp, f, source , kind, 0, buffer, 1590 precision, buf_size, result, &flt_str_len); 1591 write_float_string (dtp, result, flt_str_len); 1592 1593 if (buf_size > BUF_STACK_SZ) 1594 free (buffer); 1595 if (res_len > BUF_STACK_SZ) 1596 free (result); 1597} 1598 1599void 1600write_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 1606void 1607write_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 1613void 1614write_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 1620void 1621write_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 1627void 1628write_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 1636static void 1637set_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 1687void 1688write_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; 1694 size_t buf_size, res_len, flt_str_len; 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, 1709 precision, buf_size, result, &flt_str_len); 1710 write_float_string (dtp, result, flt_str_len); 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 1722void 1723write_real_w0 (st_parameter_dt *dtp, const char *source, int kind, 1724 const fnode* f) 1725{ 1726 fnode ff; 1727 char buf_stack[BUF_STACK_SZ]; 1728 char str_buf[BUF_STACK_SZ]; 1729 char *buffer, *result; 1730 size_t buf_size, res_len, flt_str_len; 1731 int comp_d = 0; 1732 1733 set_fnode_default (dtp, &ff, kind); 1734 1735 if (f->u.real.d > 0) 1736 ff.u.real.d = f->u.real.d; 1737 ff.format = f->format; 1738 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 1753 dtp->u.p.g0_no_blanks = 1; 1754 1755 /* Precision for snprintf call. */ 1756 int precision = get_precision (dtp, &ff, source, kind); 1757 1758 /* String buffer to hold final result. */ 1759 result = select_string (dtp, &ff, str_buf, &res_len, kind); 1760 1761 buffer = select_buffer (dtp, &ff, precision, buf_stack, &buf_size, kind); 1762 1763 get_float_string (dtp, &ff, source , kind, comp_d, buffer, 1764 precision, buf_size, result, &flt_str_len); 1765 write_float_string (dtp, result, flt_str_len); 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 1775static void 1776write_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; 1790 size_t buf_size, res_len1, res_len2, flt_str_len1, flt_str_len2; 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, 1813 precision, buf_size, result1, &flt_str_len1); 1814 get_float_string (dtp, &f, source + size / 2 , kind, 0, buffer, 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 } 1821 write_char (dtp, '('); 1822 write_float_string (dtp, result1, flt_str_len1); 1823 write_char (dtp, semi_comma); 1824 write_float_string (dtp, result2, flt_str_len2); 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 1840static void 1841write_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 1862static void 1863list_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; 1910 gfc_full_array_i4 vlist; 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 1949void 1950list_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 1991static void 1992namelist_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 2048static namelist_info * 2049nml_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; 2235 gfc_full_array_i4 vlist; 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 { 2261 /* Build a class container. */ 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 2368obj_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 2394void 2395namelist_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. */ 2419 for (gfc_charlen_type i = 0; i < dtp->namelist_name_len; i++ ) 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 2440