+/* Floating point helper functions. */
+
+#define BUF_STACK_SZ 384
+
+static int
+get_precision (st_parameter_dt *dtp, const fnode *f, const char *source, int kind)
+{
+ if (f->format != FMT_EN)
+ return determine_precision (dtp, f, kind);
+ else
+ return determine_en_precision (dtp, f, source, kind);
+}
+
+/* 4932 is the maximum exponent of long double and quad precision, 3
+ extra characters for the sign, the decimal point, and the
+ trailing null. Extra digits are added by the calling functions for
+ requested precision. Likewise for float and double. F0 editing produces
+ full precision output. */
+static int
+size_from_kind (st_parameter_dt *dtp, const fnode *f, int kind)
+{
+ int size;
+
+ if ((f->format == FMT_F && f->u.real.w == 0) || f->u.real.w == DEFAULT_WIDTH)
+ {
+ switch (kind)
+ {
+ case 4:
+ size = 38 + 3; /* These constants shown for clarity. */
+ break;
+ case 8:
+ size = 308 + 3;
+ break;
+ case 10:
+ size = 4932 + 3;
+ break;
+ case 16:
+#ifdef HAVE_GFC_REAL_17
+ case 17:
+#endif
+ size = 4932 + 3;
+ break;
+ default:
+ internal_error (&dtp->common, "bad real kind");
+ break;
+ }
+ }
+ else
+ size = f->u.real.w + 1; /* One byte for a NULL character. */
+
+ return size;
+}
+
+static char *
+select_buffer (st_parameter_dt *dtp, const fnode *f, int precision,
+ char *buf, size_t *size, int kind)
+{
+ char *result;
+
+ /* The buffer needs at least one more byte to allow room for
+ normalizing and 1 to hold null terminator. */
+ *size = size_from_kind (dtp, f, kind) + precision + 1 + 1;
+
+ if (*size > BUF_STACK_SZ)
+ result = xmalloc (*size);
+ else
+ result = buf;
+ return result;
+}
+
+static char *
+select_string (st_parameter_dt *dtp, const fnode *f, char *buf, size_t *size,
+ int kind)
+{
+ char *result;
+ *size = size_from_kind (dtp, f, kind) + f->u.real.d + 1;
+ if (*size > BUF_STACK_SZ)
+ result = xmalloc (*size);
+ else
+ result = buf;
+ return result;
+}
+
+static void
+write_float_string (st_parameter_dt *dtp, char *fstr, size_t len)
+{
+ char *p = write_block (dtp, len);
+ if (p == NULL)
+ return;
+
+ if (unlikely (is_char4_unit (dtp)))
+ {
+ gfc_char4_t *p4 = (gfc_char4_t *) p;
+ memcpy4 (p4, fstr, len);
+ return;
+ }
+ memcpy (p, fstr, len);
+}
+
+
+static void
+write_float_0 (st_parameter_dt *dtp, const fnode *f, const char *source, int kind)
+{
+ char buf_stack[BUF_STACK_SZ];
+ char str_buf[BUF_STACK_SZ];
+ char *buffer, *result;
+ size_t buf_size, res_len, flt_str_len;
+
+ /* Precision for snprintf call. */
+ int precision = get_precision (dtp, f, source, kind);
+
+ /* String buffer to hold final result. */
+ result = select_string (dtp, f, str_buf, &res_len, kind);
+
+ buffer = select_buffer (dtp, f, precision, buf_stack, &buf_size, kind);
+
+ get_float_string (dtp, f, source , kind, 0, buffer,
+ precision, buf_size, result, &flt_str_len);
+ write_float_string (dtp, result, flt_str_len);
+
+ if (buf_size > BUF_STACK_SZ)
+ free (buffer);
+ if (res_len > BUF_STACK_SZ)
+ free (result);
+}
+
+void
+write_d (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
+{
+ write_float_0 (dtp, f, p, len);
+}
+
+
+void
+write_e (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
+{
+ write_float_0 (dtp, f, p, len);
+}
+
+
+void
+write_f (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
+{
+ write_float_0 (dtp, f, p, len);
+}
+
+
+void
+write_en (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
+{
+ write_float_0 (dtp, f, p, len);
+}
+
+
+void
+write_es (st_parameter_dt *dtp, const fnode *f, const char *p, int len)
+{
+ write_float_0 (dtp, f, p, len);
+}
+