OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [libgfortran/] [io/] [write.c] - Blame information for rev 733

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.