]>
git.ipfire.org Git - thirdparty/gcc.git/blob - libgfortran/io/write.c
1 /* Copyright (C) 2002-2003 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
4 This file is part of the GNU Fortran 95 runtime library (libgfortran).
6 Libgfortran is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 Libgfortran is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with Libgfortran; see the file COPYING. If not, write to
18 the Free Software Foundation, 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
24 #include "libgfortran.h"
29 #define star_fill(p, n) memset(p, '*', n)
33 { SIGN_NONE
, SIGN_MINUS
, SIGN_PLUS
}
38 write_a (fnode
* f
, const char *source
, int len
)
43 wlen
= f
->u
.string
.length
< 0 ? len
: f
->u
.string
.length
;
45 p
= write_block (wlen
);
50 memcpy (p
, source
, wlen
);
53 memcpy (p
, source
, len
);
54 memset (p
+ len
, ' ', wlen
- len
);
59 extract_int (const void *p
, int len
)
69 i
= *((const int8_t *) p
);
72 i
= *((const int16_t *) p
);
75 i
= *((const int32_t *) p
);
78 i
= *((const int64_t *) p
);
81 internal_error ("bad integer kind");
88 extract_real (const void *p
, int len
)
94 i
= *((const float *) p
);
97 i
= *((const double *) p
);
100 internal_error ("bad real kind");
107 /* calculate sign()-- Given a flag that indicate if a value is
108 * negative or not, return a sign_t that gives the sign that we need
112 calculate_sign (int negative_flag
)
114 sign_t s
= SIGN_NONE
;
119 switch (g
.sign_status
)
128 s
= options
.optional_plus
? SIGN_PLUS
: SIGN_NONE
;
136 /* calculate_exp()-- returns the value of 10**d. */
139 calculate_exp (int d
)
144 for (i
= 0; i
< (d
>= 0 ? d
: -d
); i
++)
147 r
= (d
>= 0) ? r
: 1.0 / r
;
153 /* calculate_G_format()-- geneate corresponding I/O format for
155 The rules to translate FMT_G to FMT_E or FNT_F from DEC fortran
156 LRM (table 11-2, Chapter 11, "I/O Formatting", P11-25) is:
158 Data Magnitude Equivalent Conversion
159 0< m < 0.1-0.5*10**(-d-1) Ew.d[Ee]
160 m = 0 F(w-n).(d-1), n' '
161 0.1-0.5*10**(-d-1)<= m < 1-0.5*10**(-d) F(w-n).d, n' '
162 1-0.5*10**(-d)<= m < 10-0.5*10**(-d+1) F(w-n).(d-1), n' '
163 10-0.5*10**(-d+1)<= m < 100-0.5*10**(-d+2) F(w-n).(d-2), n' '
164 ................ ..........
165 10**(d-1)-0.5*10**(-1)<= m <10**d-0.5 F(w-n).0,n(' ')
166 m >= 10**d-0.5 Ew.d[Ee]
168 notes: for Gw.d , n' ' means 4 blanks
169 for Gw.dEe, n' ' means e+2 blanks */
172 calculate_G_format (fnode
*f
, double value
, int len
, int *num_blank
)
182 newf
= get_mem (sizeof (fnode
));
184 /* Absolute value. */
185 m
= (value
> 0.0) ? value
: -value
;
187 /* In case of the two data magnitude ranges,
188 generate E editing, Ew.d[Ee]. */
189 exp_d
= calculate_exp (d
);
190 if ((m
> 0.0 && m
< 0.1 - 0.05 / (double) exp_d
)
191 || (m
>= (double) exp_d
- 0.5 ))
193 newf
->format
= FMT_E
;
201 /* Use binary search to find the data magnitude range. */
211 mid
= (low
+ high
) / 2;
213 /* 0.1 * 10**mid - 0.5 * 10**(mid-d-1) */
214 temp
= 0.1 * calculate_exp (mid
) - 0.5 * calculate_exp (mid
- d
- 1);
219 if (ubound
== lbound
+ 1)
226 if (ubound
== lbound
+ 1)
237 /* Generate the F editing. F(w-4).(-(mid-d-1)), 4' '. */
238 newf
->format
= FMT_F
;
239 newf
->u
.real
.w
= f
->u
.real
.w
- 4;
243 newf
->u
.real
.d
= d
- 1;
245 newf
->u
.real
.d
= - (mid
- d
- 1);
249 /* For F editing, the scale factor is ignored. */
255 /* output_float() -- output a real number according to its format
256 which is FMT_G free */
259 output_float (fnode
*f
, double value
, int len
)
263 int nsign
, nblank
, nesign
;
264 int sca
, neval
, itmp
;
266 const char *q
, *intstr
, *base
;
272 double minv
= 0.0, maxv
= 0.0;
273 sign_t sign
= SIGN_NONE
, esign
= SIGN_NONE
;
275 int intval
= 0, intlen
= 0;
278 /* EXP value for this number */
281 /* Width of EXP and it's sign*/
288 /* Width of the EXP */
291 sca
= g
.scale_factor
;
294 sign
= calculate_sign (n
< 0.0);
298 /* Width of the sign for the whole number */
299 nsign
= (sign
== SIGN_NONE
? 0 : 1);
306 if (ft
== FMT_F
|| ft
== FMT_E
|| ft
== FMT_D
)
315 /* Here calculate the new val of the number with consideration
316 of Globle Scale value */
326 /* Now calculate the new Exp value for this number */
327 sca
= g
.scale_factor
;
346 /* OK, let's scale the number to appropriate range */
347 while (scale_flag
&& n
> 0.0 && n
< minv
)
355 while (scale_flag
&& n
> 0.0 && n
> maxv
)
364 /* It is time to process the EXP part of the number.
365 Value of 'nesign' is 0 unless following codes is executed.
369 /* Sign of the EXP value */
378 /* Width of the EXP*/
389 /* Got the width of EXP */
393 /* Minimum value of the width would be 2 */
397 nesign
= 1 ; /* We must give a position for the 'exp_char' */
399 nesign
= e
+ nesign
+ (esign
!= SIGN_NONE
? 1 : 0);
404 intstr
= itoa (intval
);
405 intlen
= strlen (intstr
);
407 q
= rtoa (n
, len
, d
);
410 /* Select a width if none was specified. */
420 nblank
= w
- (nsign
+ intlen
+ d
+ nesign
);
421 if (nblank
== -1 && ft
!= FMT_F
)
425 nblank
= w
- (nsign
+ intlen
+ d
+ nesign
);
427 /* don't let a leading '0' cause field overflow */
428 if (nblank
== -1 && ft
== FMT_F
&& q
[0] == '0')
439 memset (p
, ' ', nblank
);
454 memcpy (p
, q
, intlen
+ d
+ 1);
475 for (itmp
= 0; itmp
< e
- digits
; itmp
++)
477 memcpy (p
, q
, digits
);
486 write_l (fnode
* f
, char *source
, int len
)
491 p
= write_block (f
->u
.w
);
495 memset (p
, ' ', f
->u
.w
- 1);
496 n
= extract_int (source
, len
);
497 p
[f
->u
.w
- 1] = (n
) ? 'T' : 'F';
500 /* write_float() -- output a real number according to its format */
503 write_float (fnode
*f
, const char *source
, int len
)
510 n
= extract_real (source
, len
);
512 if (f
->format
!= FMT_B
&& f
->format
!= FMT_O
&& f
->format
!= FMT_Z
)
520 p
= write_block (nb
);
531 memset (p
+ 1, fin
, nb
- 1);
534 sprintf(p
+ 1, "NaN");
539 if (f
->format
!= FMT_G
)
541 output_float (f
, n
, len
);
545 f2
= calculate_G_format(f
, n
, len
, &nb
);
546 output_float (f2
, n
, len
);
552 p
= write_block (nb
);
560 write_int (fnode
*f
, const char *source
, int len
, char *(*conv
) (uint64_t))
564 int w
, m
, digits
, nzero
, nblank
;
570 n
= extract_int (source
, len
);
574 if (m
== 0 && n
== 0)
598 /* Select a width if none was specified. The idea here is to always
599 * print something. */
602 w
= ((digits
< m
) ? m
: digits
);
612 /* See if things will work */
614 nblank
= w
- (nzero
+ digits
);
622 memset (p
, ' ', nblank
);
625 memset (p
, '0', nzero
);
628 memcpy (p
, q
, digits
);
635 write_decimal (fnode
*f
, const char *source
, int len
, char *(*conv
) (int64_t))
638 int w
, m
, digits
, nsign
, nzero
, nblank
;
645 n
= extract_int (source
, len
);
649 if (m
== 0 && n
== 0)
662 sign
= calculate_sign (n
< 0);
666 nsign
= sign
== SIGN_NONE
? 0 : 1;
671 /* Select a width if none was specified. The idea here is to always
672 * print something. */
675 w
= ((digits
< m
) ? m
: digits
) + nsign
;
685 /* See if things will work */
687 nblank
= w
- (nsign
+ nzero
+ digits
);
695 memset (p
, ' ', nblank
);
710 memset (p
, '0', nzero
);
713 memcpy (p
, q
, digits
);
720 /* otoa()-- Convert unsigned octal to ascii */
734 p
= scratch
+ sizeof (SCRATCH_SIZE
) - 1;
748 /* btoa()-- Convert unsigned binary to ascii */
762 p
= scratch
+ sizeof (SCRATCH_SIZE
) - 1;
767 *p
-- = '0' + (n
& 1);
776 write_i (fnode
* f
, const char *p
, int len
)
779 write_decimal (f
, p
, len
, (void *) itoa
);
784 write_b (fnode
* f
, const char *p
, int len
)
787 write_int (f
, p
, len
, btoa
);
792 write_o (fnode
* f
, const char *p
, int len
)
795 write_int (f
, p
, len
, otoa
);
799 write_z (fnode
* f
, const char *p
, int len
)
802 write_int (f
, p
, len
, xtoa
);
807 write_d (fnode
*f
, const char *p
, int len
)
809 write_float (f
, p
, len
);
814 write_e (fnode
*f
, const char *p
, int len
)
816 write_float (f
, p
, len
);
821 write_f (fnode
*f
, const char *p
, int len
)
823 write_float (f
, p
, len
);
828 write_en (fnode
*f
, const char *p
, int len
)
830 write_float (f
, p
, len
);
835 write_es (fnode
*f
, const char *p
, int len
)
837 write_float (f
, p
, len
);
841 /* write_x()-- Take care of the X/TR descriptor */
848 p
= write_block (f
->u
.n
);
852 memset (p
, ' ', f
->u
.n
);
856 /* List-directed writing */
859 /* write_char()-- Write a single character to the output. Returns
860 * nonzero if something goes wrong. */
877 /* write_logical()-- Write a list-directed logical value */
878 /* Default logical output should be L2
879 according to DEC fortran Manual. */
881 write_logical (const char *source
, int length
)
884 write_char (extract_int (source
, length
) ? 'T' : 'F');
888 /* write_integer()-- Write a list-directed integer value. */
891 write_integer (const char *source
, int length
)
898 q
= itoa (extract_int (source
, length
));
904 p
= write_block (width
) ;
906 memset(p
,' ', width
- digits
) ;
907 memcpy (p
+ width
- digits
, q
, digits
);
911 /* write_character()-- Write a list-directed string. We have to worry
912 * about delimiting the strings if the file has been opened in that
916 write_character (const char *source
, int length
)
921 switch (current_unit
->flags
.delim
)
923 case DELIM_APOSTROPHE
:
940 for (i
= 0; i
< length
; i
++)
945 p
= write_block (length
+ extra
);
950 memcpy (p
, source
, length
);
955 for (i
= 0; i
< length
; i
++)
967 /* Output the Real number with default format.
968 According to DEC fortran LRM, default format for
969 REAL(4) is 1PG15.7E2, and for REAL(8) is 1PG25.15E3 */
972 write_real (const char *source
, int length
)
975 int org_scale
= g
.scale_factor
;
990 write_float (&f
, source
, length
);
991 g
.scale_factor
= org_scale
;
996 write_complex (const char *source
, int len
)
999 if (write_char ('('))
1001 write_real (source
, len
);
1003 if (write_char (','))
1005 write_real (source
+ len
, len
);
1011 /* write_separator()-- Write the separator between items. */
1014 write_separator (void)
1018 p
= write_block (options
.separator_len
);
1022 memcpy (p
, options
.separator
, options
.separator_len
);
1026 /* list_formatted_write()-- Write an item with list formatting.
1027 * TODO: handle skipping to the next record correctly, particularly
1031 list_formatted_write (bt type
, void *p
, int len
)
1033 static int char_flag
;
1035 if (current_unit
== NULL
)
1045 if (type
!= BT_CHARACTER
|| !char_flag
||
1046 current_unit
->flags
.delim
!= DELIM_NONE
)
1053 write_integer (p
, len
);
1056 write_logical (p
, len
);
1059 write_character (p
, len
);
1062 write_real (p
, len
);
1065 write_complex (p
, len
);
1068 internal_error ("list_formatted_write(): Bad type");
1071 char_flag
= (type
== BT_CHARACTER
);
1075 namelist_write (void)
1077 namelist_info
* t1
, *t2
;
1082 write_character("&",1);
1083 write_character (ioparm
.namelist_name
, ioparm
.namelist_name_len
);
1084 write_character("\n",1);
1094 write_character(t2
->var_name
, strlen(t2
->var_name
));
1095 write_character("=",1);
1101 write_integer (p
, len
);
1104 write_logical (p
, len
);
1107 write_character (p
, len
);
1110 write_real (p
, len
);
1113 write_complex (p
, len
);
1116 internal_error ("Bad type for namelist write");
1118 write_character(",",1);
1122 write_character("\n",1);
1126 write_character("/",1);