/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */
/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */

/*
 * format.d - format
 *
 * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya
 * Copyright (c) 1990 Giuseppe Attardi
 * Copyright (c) 2001 Juan Jose Garcia Ripoll
 *
 * See file 'LICENSE' for the copyright details.
 *
 */

#include <string.h>
#include <float.h>
#define ECL_INCLUDE_MATH_H
#include <ecl/ecl.h>
#include <limits.h>
#include <ecl/impl/math_fenv.h>
#include <ecl/internal.h>

#if !defined(ECL_CMU_FORMAT)

#warning "The old version of FORMAT is not ANSI compliant"

#define FMT_MAX_PARAM   8
typedef struct format_stack_struct {
  cl_object     stream;
  cl_object     aux_stream;
  cl_object     aux_string;
  cl_index      ctl_index, ctl_end;
  cl_object     ctl_str;
  cl_object     args, current;
  jmp_buf       *jmp_buf;
  cl_index      indents;
  cl_index      spare_spaces;
  cl_index      line_length;
  cl_object     param[FMT_MAX_PARAM];
  int           nparam;
} *format_stack;

#if MOST_POSITIVE_FIXNUM_VAL < INT_MAX
# define FMT_VALUE_UPPER_LIMIT MOST_POSITIVE_FIXNUM
#else
# define FMT_VALUE_UPPER_LIMIT INT_MAX
#endif

#if MOST_NEGATIVE_FIXNUM_VAL > INT_MIN
# define FMT_VALUE_LOWER_LIMIT MOST_NEGATIVE_FIXNUM
#else
# define FMT_VALUE_LOWER_LIMIT INT_MIN
#endif


/******************* COMMON ***************************/

#define NONE    0
#define INT     1
#define CHAR    2

static const char *fmt_big_numeral[] = {
  "thousand",
  "million",
  "billion",
  "trillion",
  "quadrillion",
  "quintillion",
  "sextillion",
  "septillion",
  "octillion"
};

static const char *fmt_numeral[] = {
  "zero", "one", "two", "three", "four",
  "five", "six", "seven", "eight", "nine",
  "ten", "eleven", "twelve", "thirteen", "fourteen",
  "fifteen", "sixteen", "seventeen", "eighteen", "nineteen",
  "zero", "ten", "twenty", "thirty", "forty",
  "fifty", "sixty", "seventy", "eighty", "ninety"
};

static const char *fmt_ordinal[] = {
  "zeroth", "first", "second", "third", "fourth",
  "fifth", "sixth", "seventh", "eighth", "ninth",
  "tenth", "eleventh", "twelfth", "thirteenth", "fourteenth",
  "fifteenth", "sixteenth", "seventeenth", "eighteenth", "nineteenth",
  "zeroth", "tenth", "twentieth", "thirtieth", "fortieth",
  "fiftieth", "sixtieth", "seventieth", "eightieth", "ninetieth"
};

static void format(format_stack, cl_index, cl_index);
static cl_object doformat(cl_narg narg, cl_object strm, cl_object string, ecl_va_list args, bool in_formatter);

static cl_object
get_aux_stream(void)
{
  cl_env_ptr env = ecl_process_env();
  cl_object stream;

  ECL_WITHOUT_INTERRUPTS_BEGIN(env) {
    if (env->fmt_aux_stream == ECL_NIL) {
      stream = ecl_make_string_output_stream(64, 1);
    } else {
      stream = env->fmt_aux_stream;
      env->fmt_aux_stream = ECL_NIL;
    }
  } ECL_WITHOUT_INTERRUPTS_END;
  return stream;
}

static void
fmt_error(format_stack fmt, const char *s)
{
  cl_error(7, @'si::format-error',
           @':format-control', ecl_make_constant_base_string(s,-1),
           @':control-string', fmt->ctl_str,
           @':offset', ecl_make_fixnum(fmt->ctl_index));
}

static ecl_character
tempstr(format_stack fmt, int s)
{
  return ecl_char(fmt->aux_string,s);
}

static ecl_character
ctl_advance(format_stack fmt)
{
  if (fmt->ctl_index >= fmt->ctl_end)
    fmt_error(fmt, "unexpected end of control string");
  return ecl_char(fmt->ctl_str, fmt->ctl_index++);
}

static void
fmt_go(format_stack fmt, cl_fixnum n)
{
  cl_object p;
  if (n < 0)
    fmt_error(fmt, "can't goto");
  if ((p = ecl_nthcdr(n, fmt->args)) == ECL_NIL)
    fmt_error(fmt, "can't goto");
  fmt->current = p;
}

static cl_index
fmt_index(format_stack fmt)
{
  cl_object p = fmt->args, target = fmt->current;
  cl_index n = 0;
  if (target == ECL_NIL)
    return ecl_length(p);
  while (p != fmt->current) {
    p = CDR(p);
    if (p == ECL_NIL)
      fmt_error(fmt, "Overflow");
    n++;
  }
  return n;
}

static cl_object
fmt_back_up(format_stack fmt)
{
  fmt_go(fmt, fmt_index(fmt) - 1);
}

static bool
fmt_more_args_p(format_stack fmt)
{
  return fmt->current != ECL_NIL;
}

static cl_index
fmt_args_left(format_stack fmt)
{
  return ecl_length(fmt->current);
}

static cl_object
fmt_advance(format_stack fmt)
{
  cl_object output, l = fmt->current;
  if (l == ECL_NIL)
    fmt_error(fmt, "arguments exhausted");
  output = CAR(l);
  fmt->current = CDR(l);
  return output;
}

static void
fmt_set_arg_list(format_stack fmt, cl_object l)
{
  assert_type_proper_list(l);
  fmt->current = fmt->args = cl_copy_list(l);
}

static int
fmt_skip(format_stack fmt)
{
  ecl_character c;
  int level = 0;

 LOOP:
  if (ctl_advance(fmt) != '~')
    goto LOOP;
  for (;;)
    switch (c = ctl_advance(fmt)) {
    case '\'':
      ctl_advance(fmt);

    case ',':
    case '0':  case '1':  case '2':  case '3':  case '4':
    case '5':  case '6':  case '7':  case '8':  case '9':
    case '+':
    case '-':
    case 'v':  case 'V':
    case '#':
    case ':':  case '@@':
      continue;

    default:
      goto DIRECTIVE;
    }

 DIRECTIVE:
  switch (c) {
  case '(':  case '[':  case '<':  case '{':
    level++;
    break;

  case ')':  case ']':  case '>':  case '}':
    if (level == 0)
      return(fmt->ctl_index);
    else
      --level;
    break;

  case ';':
    if (level == 0)
      return(fmt->ctl_index);
    break;
  }
  goto LOOP;
}

static void
ensure_param(format_stack fmt, int n)
{
  if (fmt->nparam > n)
    fmt_error(fmt, "too many parameters");
  while (n-- > fmt->nparam)
    fmt->param[n] = ECL_NIL;
}

static void
fmt_not_colon(format_stack fmt, bool colon)
{
  if (colon)
    fmt_error(fmt, "illegal :");
}

static void
fmt_not_atsign(format_stack fmt, bool atsign)
{
  if (atsign)
    fmt_error(fmt, "illegal @@");
}

static void
fmt_not_colon_atsign(format_stack fmt, bool colon, bool atsign)
{
  if (colon && atsign)
    fmt_error(fmt, "illegal :@@");
}

static cl_object
set_param(format_stack fmt, int i, int t, cl_object v)
{
  if (i >= fmt->nparam || fmt->param[i] == ECL_NIL)
    return v;
  else if ((t != INT && t != CHAR) ||
           (t == INT && !cl_integerp(fmt->param[i])) ||
           (t == CHAR && !ECL_CHARACTERP(fmt->param[i])))
    fmt_error(fmt, "illegal parameter type");
  return fmt->param[i];
}

static int
set_param_positive(format_stack fmt, int i, const char *message)
{
  if (i >= fmt->nparam || fmt->param[i] == ECL_NIL)
    return -1;
  else if (cl_integerp(fmt->param[i]) == ECL_NIL)
    fmt_error(fmt, "illegal parameter type");
  else {
    cl_object p = fmt->param[i];
    if (ecl_minusp(p)) fmt_error(fmt, message);
    return ecl_to_fix(p);
  }
}

static void
fmt_copy(format_stack fmt_copy, format_stack fmt)
{
  *fmt_copy = *fmt;
}

static void
fmt_copy1(format_stack fmt_copy, format_stack fmt)
{
  fmt_copy->stream = fmt->stream;
  fmt_copy->ctl_str = fmt->ctl_str;
  fmt_copy->ctl_index = fmt->ctl_index;
  fmt_copy->ctl_end = fmt->ctl_end;
  fmt_copy->jmp_buf = fmt->jmp_buf;
  fmt_copy->indents = fmt->indents;
}

static void
fmt_prepare_aux_stream(format_stack fmt)
{
  fmt->aux_string->base_string.fillp = 0;
  fmt->aux_stream->stream.int0 = ecl_file_column(fmt->stream);
  fmt->aux_stream->stream.int1 = ecl_file_column(fmt->stream);
}


static void
fmt_ascii(format_stack fmt, bool colon, bool atsign)
{
  int mincol, colinc, minpad;
  ecl_character padchar;
  cl_object x;
  int l, i;

  ensure_param(fmt, 4);
  mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0)));
  colinc = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(1)));
  minpad = ecl_to_fix(set_param(fmt, 2, INT, ecl_make_fixnum(0)));
  padchar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR(' ')));

  fmt_prepare_aux_stream(fmt);
  x = fmt_advance(fmt);
  if (colon && Null(x))
    writestr_stream("()", fmt->aux_stream);
  else if (mincol == 0 && minpad == 0) {
    ecl_princ(x, fmt->stream);
    return;
  } else
    ecl_princ(x, fmt->aux_stream);
  l = fmt->aux_string->base_string.fillp;
  for (i = minpad;  l + i < mincol;  i += colinc)
    ;
  if (!atsign) {
    ecl_write_string(fmt->aux_string, fmt->stream);
    while (i-- > 0)
      ecl_write_char(padchar, fmt->stream);
  } else {
    while (i-- > 0)
      ecl_write_char(padchar, fmt->stream);
    ecl_write_string(fmt->aux_string, fmt->stream);
  }
}

static void
fmt_S_expression(format_stack fmt, bool colon, bool atsign)
{
  int mincol, colinc, minpad;
  ecl_character padchar;
  cl_object x;
  int l, i;

  ensure_param(fmt, 4);
  mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0)));
  colinc = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(1)));
  minpad = ecl_to_fix(set_param(fmt, 2, INT, ecl_make_fixnum(0)));
  padchar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR(' ')));

  fmt_prepare_aux_stream(fmt);
  x = fmt_advance(fmt);
  if (colon && Null(x))
    writestr_stream("()", fmt->aux_stream);
  else if (mincol == 0 && minpad == 0) {
    ecl_prin1(x, fmt->stream);
    return;
  } else
    ecl_prin1(x, fmt->aux_stream);
  l = fmt->aux_string->base_string.fillp;
  for (i = minpad;  l + i < mincol;  i += colinc)
    ;
  if (!atsign) {
    ecl_write_string(fmt->aux_string, fmt->stream);
    while (i-- > 0)
      ecl_write_char(padchar, fmt->stream);
  } else {
    while (i-- > 0)
      ecl_write_char(padchar, fmt->stream);
    ecl_write_string(fmt->aux_string, fmt->stream);
  }
}


static void
fmt_integer(format_stack fmt, cl_object x, bool colon, bool atsign,
            int radix, int mincol, ecl_character padchar, ecl_character commachar)
{
  const cl_env_ptr env = ecl_process_env();
  int l, l1;
  int s;

  if (!ECL_FIXNUMP(x) && ecl_t_of(x) != t_bignum) {
    fmt_prepare_aux_stream(fmt);
    ecl_bds_bind(env, @'*print-escape*', ECL_NIL);
    ecl_bds_bind(env, @'*print-base*', ecl_make_fixnum(radix));
    si_write_object(x, fmt->aux_stream);
    ecl_bds_unwind_n(env, 2);
    l = fmt->aux_string->base_string.fillp;
    mincol -= l;
    while (mincol-- > 0)
      ecl_write_char(padchar, fmt->stream);
    ecl_write_string(fmt->aux_string, fmt->stream);
    return;
  }
  fmt_prepare_aux_stream(fmt);
  ecl_bds_bind(env, @'*print-radix*', ECL_NIL);
  ecl_bds_bind(env, @'*print-base*', ecl_make_fixnum(radix));
  si_write_object(x, fmt->aux_stream);
  ecl_bds_unwind_n(env, 2);
  l = l1 = fmt->aux_string->base_string.fillp;
  s = 0;
  if (tempstr(fmt, s) == '-')
    --l1;
  mincol -= l;
  if (colon)
    mincol -= (l1 - 1)/3;
  if (atsign && tempstr(fmt, s) != '-')
    --mincol;
  while (mincol-- > 0)
    ecl_write_char(padchar, fmt->stream);
  if (tempstr(fmt, s) == '-') {
    s++;
    ecl_write_char('-', fmt->stream);
  } else if (atsign)
    ecl_write_char('+', fmt->stream);
  while (l1-- > 0) {
    ecl_write_char(tempstr(fmt, s++), fmt->stream);
    if (colon && l1 > 0 && l1%3 == 0)
      ecl_write_char(commachar, fmt->stream);
  }
}

static void
fmt_decimal(format_stack fmt, bool colon, bool atsign)
{
  int mincol;
  ecl_character padchar, commachar;

  ensure_param(fmt, 3);
  mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0)));
  padchar = ECL_CHAR_CODE(set_param(fmt, 1, CHAR, ECL_CODE_CHAR(' ')));
  commachar = ECL_CHAR_CODE(set_param(fmt, 2, CHAR, ECL_CODE_CHAR(',')));
  fmt_integer(fmt, fmt_advance(fmt), colon, atsign,
              10, mincol, padchar, commachar);
}

static void
fmt_binary(format_stack fmt, bool colon, bool atsign)
{
  int mincol;
  ecl_character padchar, commachar;

  ensure_param(fmt, 3);
  mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0)));
  padchar = ECL_CHAR_CODE(set_param(fmt, 1, CHAR, ECL_CODE_CHAR(' ')));
  commachar = ECL_CHAR_CODE(set_param(fmt, 2, CHAR, ECL_CODE_CHAR(',')));
  fmt_integer(fmt, fmt_advance(fmt), colon, atsign,
              2, mincol, padchar, commachar);
}

static void
fmt_octal(format_stack fmt, bool colon, bool atsign)
{
  int mincol;
  ecl_character padchar, commachar;

  ensure_param(fmt, 3);
  mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0)));
  padchar = ECL_CHAR_CODE(set_param(fmt, 1, CHAR, ECL_CODE_CHAR(' ')));
  commachar = ECL_CHAR_CODE(set_param(fmt, 2, CHAR, ECL_CODE_CHAR(',')));
  fmt_integer(fmt, fmt_advance(fmt), colon, atsign,
              8, mincol, padchar, commachar);
}

static void
fmt_hexadecimal(format_stack fmt, bool colon, bool atsign)
{
  int mincol;
  ecl_character padchar, commachar;

  ensure_param(fmt, 3);
  mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0)));
  padchar = ECL_CHAR_CODE(set_param(fmt, 1, CHAR, ECL_CODE_CHAR(' ')));
  commachar = ECL_CHAR_CODE(set_param(fmt, 2, CHAR, ECL_CODE_CHAR(',')));
  fmt_integer(fmt, fmt_advance(fmt), colon, atsign,
              16, mincol, padchar, commachar);
}

static void
fmt_write_numeral(format_stack fmt, int s, int i)
{
  writestr_stream(fmt_numeral[tempstr(fmt, s) - '0' + i], fmt->stream);
}

static void
fmt_write_ordinal(format_stack fmt, int s, int i)
{
  writestr_stream(fmt_ordinal[tempstr(fmt, s) - '0' + i], fmt->stream);
}

static bool
fmt_thousand(format_stack fmt, int s, int i, bool b, bool o, int t)
{
  if (i == 3 && tempstr(fmt, s) > '0') {
    if (b)
      ecl_write_char(' ', fmt->stream);
    fmt_write_numeral(fmt, s, 0);
    writestr_stream(" hundred", fmt->stream);
    --i;
    s++;
    b = TRUE;
    if (o && (s > t))
      writestr_stream("th", fmt->stream);
  }
  if (i == 3) {
    --i;
    s++;
  }
  if (i == 2 && tempstr(fmt, s) > '0') {
    if (b)
      ecl_write_char(' ', fmt->stream);
    if (tempstr(fmt, s) == '1') {
      if (o && (s + 2 > t))
        fmt_write_ordinal(fmt, ++s, 10);
      else
        fmt_write_numeral(fmt, ++s, 10);
      return(TRUE);
    } else {
      if (o && (s + 1 > t))
        fmt_write_ordinal(fmt, s, 20);
      else
        fmt_write_numeral(fmt, s, 20);
      s++;
      if (tempstr(fmt, s) > '0') {
        ecl_write_char('-', fmt->stream);
        if (o && s + 1 > t)
          fmt_write_ordinal(fmt, s, 0);
        else
          fmt_write_numeral(fmt, s, 0);
      }
      return(TRUE);
    }
  }
  if (i == 2)
    s++;
  if (tempstr(fmt, s) > '0') {
    if (b)
      ecl_write_char(' ', fmt->stream);
    if (o && s + 1 > t)
      fmt_write_ordinal(fmt, s, 0);
    else
      fmt_write_numeral(fmt, s, 0);
    return(TRUE);
  }
  return(b);
}

static bool
fmt_nonillion(format_stack fmt, int s, int i, bool b, bool o, int t)
{
  int j;

  for (;  i > 3;  i -= j) {
    b = fmt_thousand(fmt, s, j = (i+2)%3+1, b, FALSE, t);
    if (j != 3 || tempstr(fmt, s) != '0' ||
        tempstr(fmt, s+1) != '0' || tempstr(fmt, s+2) != '0') {
      ecl_write_char(' ', fmt->stream);
      writestr_stream(fmt_big_numeral[(i - 1)/3 - 1],
                      fmt->stream);
      s += j;
      if (o && s > t)
        writestr_stream("th", fmt->stream);
    } else
      s += j;
  }
  return(fmt_thousand(fmt, s, i, b, o, t));
}

static void
fmt_roman(format_stack fmt, int i, int one, int five, int ten, bool colon)
{
  int j;

  if (i == 0)
    return;
  if ((!colon && i < 4) || (colon && i < 5))
    for (j = 0;  j < i;  j++)
      ecl_write_char(one, fmt->stream);
  else if (!colon && i == 4) {
    ecl_write_char(one, fmt->stream);
    ecl_write_char(five, fmt->stream);
  } else if ((!colon && i < 9) || colon) {
    ecl_write_char(five, fmt->stream);
    for (j = 5;  j < i;  j++)
      ecl_write_char(one, fmt->stream);
  } else if (!colon && i == 9) {
    ecl_write_char(one, fmt->stream);
    ecl_write_char(ten, fmt->stream);
  }
}

static void
fmt_radix(format_stack fmt, bool colon, bool atsign)
{
  const cl_env_ptr env = ecl_process_env();
  int radix, mincol;
  ecl_character padchar, commachar;
  cl_object x;
  int i, j, k;
  int s, t;
  bool b;

  if (fmt->nparam == 0) {
    x = fmt_advance(fmt);
    assert_type_integer(x);
    if (atsign) {
      if (ECL_FIXNUMP(x))
        i = ecl_fixnum(x);
      else
        i = -1;
      if ((!colon && (i <= 0 || i >= 4000)) ||
          (colon && (i <= 0 || i >= 5000))) {
        fmt_integer(fmt, x, FALSE, FALSE, 10, 0, ' ', ',');
        return;
      }
      fmt_roman(fmt, i/1000, 'M', '*', '*', colon);
      fmt_roman(fmt, i%1000/100, 'C', 'D', 'M', colon);
      fmt_roman(fmt, i%100/10, 'X', 'L', 'C', colon);
      fmt_roman(fmt, i%10, 'I', 'V', 'X', colon);
      return;
    }
    fmt_prepare_aux_stream(fmt);
    ecl_bds_bind(env, @'*print-radix*', ECL_NIL);
    ecl_bds_bind(env, @'*print-base*', ecl_make_fixnum(10));
    si_write_object(x, fmt->aux_stream);
    ecl_bds_unwind_n(env, 2);
    s = 0;
    i = fmt->aux_string->base_string.fillp;
    if (i == 1 && tempstr(fmt, s) == '0') {
      writestr_stream("zero", fmt->stream);
      if (colon)
        writestr_stream("th", fmt->stream);
      return;
    } else if (tempstr(fmt, s) == '-') {
      writestr_stream("minus ", fmt->stream);
      --i;
      s++;
    }
    t = fmt->aux_string->base_string.fillp;
    for (; tempstr(fmt, --t) == '0' ;) ;
    for (b = FALSE;  i > 0;  i -= j) {
      b = fmt_nonillion(fmt, s, j = (i+29)%30+1, b,
                        i<=30&&colon, t);
      s += j;
      if (b && i > 30) {
        for (k = (i - 1)/30;  k > 0;  --k)
          writestr_stream(" nonillion",
                          fmt->stream);
        if (colon && s > t)
          writestr_stream("th", fmt->stream);
      }
    }
    return;
  }
  ensure_param(fmt, 4);
  radix = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(10)));
  mincol = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(0)));
  padchar = ECL_CHAR_CODE(set_param(fmt, 2, CHAR, ECL_CODE_CHAR(' ')));
  commachar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR(',')));
  x = fmt_advance(fmt);
  assert_type_integer(x);
  if (radix < 0 || radix > 36)
    FEerror("~D is illegal as a radix.", 1, ecl_make_fixnum(radix));
  fmt_integer(fmt, x, colon, atsign, radix, mincol, padchar, commachar);
}

static void
fmt_plural(format_stack fmt, bool colon, bool atsign)
{
  ensure_param(fmt, 0);
  if (colon) {
    fmt_back_up(fmt);
  }
  if (ecl_eql(fmt_advance(fmt), ecl_make_fixnum(1))) {
    if (atsign)
      ecl_write_char('y', fmt->stream);
  }
  else
    if (atsign)
      writestr_stream("ies", fmt->stream);
    else
      ecl_write_char('s', fmt->stream);
}

static void
fmt_character(format_stack fmt, bool colon, bool atsign)
{
  cl_object x;
  cl_index i;

  ensure_param(fmt, 0);
  x = fmt_advance(fmt);
  x = ecl_check_cl_type(@'format',x,t_character);
  if (!colon && !atsign) {
    ecl_write_char(ECL_CHAR_CODE(x), fmt->stream);
  } else {
    fmt_prepare_aux_stream(fmt);
    ecl_prin1(x, fmt->aux_stream);
    if (!colon && atsign)
      i = 0;
    else
      i = 2;
    for (;  i < fmt->aux_string->base_string.fillp;  i++)
      ecl_write_char(tempstr(fmt, i), fmt->stream);
  }
}

/* The floating point precision is required to make the
   most-positive-long-float printed expression readable.
   If this is too small, then the rounded off fraction, may be too big
   to read */

/* Maximum number of significant digits required to represent accurately
 * a double or single float. */

#define LOG10_2 0.30103
#define DBL_SIG ((int)(DBL_MANT_DIG * LOG10_2 + 1))
#define FLT_SIG ((int)(FLT_MANT_DIG * LOG10_2 + 1))

/* This is the maximum number of decimal digits that our numbers will have.
 * Notice that we leave some extra margin, to ensure that reading the number
 * again will produce the same floating point number.
 */
#define LDBL_SIG ((int)(LDBL_MANT_DIG * LOG10_2 + 1))
#define DBL_MAX_DIGITS (LDBL_SIG + 3)
#define DBL_EXPONENT_SIZE (1 + 1 + 4)

/* The sinificant digits + the possible sign + the decimal dot. */
#define DBL_MANTISSA_SIZE (DBL_MAX_DIGITS + 1 + 1)
/* Total estimated size that a floating point number can take. */
#define DBL_SIZE (DBL_MANTISSA_SIZE + DBL_EXPONENT_SIZE)

#define EXP_STRING "Le"
#define G_EXP_STRING "Lg"
#define DBL_TYPE long double
#define strtod strtold
extern long double strtold(const char *nptr, char **endptr);

static int
edit_double(int n, DBL_TYPE d, int *sp, char *s, int *ep)
{
  char *exponent, buff[DBL_SIZE + 1];
  int length;

  ECL_WITHOUT_FPE_BEGIN {
    unlikely_if (isnan(d) || !isfinite(d)) {
      FEerror("Can't print a non-number.", 0);
    }
    if (n < -DBL_MAX_DIGITS)
      n = DBL_MAX_DIGITS;
    if (n < 0) {
      DBL_TYPE aux;
      n = -n;
      do {
        sprintf(buff, "%- *.*" EXP_STRING, n + 1 + 1 + DBL_EXPONENT_SIZE, n-1, d);
        aux = strtod(buff, NULL);
        if (n < LDBL_SIG)
          aux = (double) aux;
        if (n < DBL_SIG)
          aux = (float)aux;
        n++;
      } while (d != aux && n <= DBL_MAX_DIGITS);
      n--;
    } else {
      sprintf(buff, "%- *.*" EXP_STRING, DBL_SIZE,
              (n <= DBL_MAX_DIGITS)? (n-1) : (DBL_MAX_DIGITS-1), d);
    }
    exponent = strchr(buff, 'e');

    /* Get the exponent */
    *ep = strtol(exponent+1, NULL, 10);

    /* Get the sign */
    *sp = (buff[0] == '-') ? -1 : +1;

    /* Get the digits of the mantissa */
    buff[2] = buff[1];

    /* Get the actual number of digits in the mantissa */
    length = exponent - (buff + 2);

    /* The output consists of a string {d1,d2,d3,...,dn}
       with all N digits of the mantissa. If we ask for more
       digits than there are, the last ones are set to zero. */
    if (n <= length) {
      memcpy(s, buff+2, n);
    } else {
      cl_index i;
      memcpy(s, buff+2, length);
      for (i = length;  i < n;  i++)
        s[i] = '0';
    }
    s[n] = '\0';
  } ECL_WITHOUT_FPE_END;

  return length;
}

static void
fmt_fix_float(format_stack fmt, bool colon, bool atsign)
{
  int w, d, k;
  ecl_character overflowchar, padchar;
  double f;
  int sign;
  char buff[256], *b, buff1[256];
  int exp;
  int i, j;
  cl_object x;
  int n, m;

  b = buff1 + 1;

  fmt_not_colon(fmt, colon);
  ensure_param(fmt, 5);
  w = set_param_positive(fmt, 0, "illegal width");
  d = set_param_positive(fmt, 1, "illegal number of digits");
  k = ecl_to_fix(set_param(fmt, 2, INT, ecl_make_fixnum(0)));
  overflowchar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR('\0')));
  padchar = ECL_CHAR_CODE(set_param(fmt, 4, CHAR, ECL_CODE_CHAR(' ')));

  x = fmt_advance(fmt);
  if (ECL_FIXNUMP(x) ||
      ecl_t_of(x) == t_bignum ||
      ecl_t_of(x) == t_ratio)
    x = ecl_make_single_float(ecl_to_float(x));
  if (!ECL_REAL_TYPE_P(ecl_t_of(x))) {
    if (fmt->nparam > 1) fmt->nparam = 1;
    fmt_back_up(fmt);
    fmt_decimal(fmt, colon, atsign);
    return;
  }
  if (ecl_t_of(x) == t_doublefloat)
    n = 16;
  else
    n = 7;
  f = ecl_to_double(x);
  edit_double(n, f, &sign, buff, &exp);
  if (exp + k > 100 || exp + k < -100 || d > 100) {
    ecl_prin1(x, fmt->stream);
    return;
  }
  if (d >= 0)
    m = d + exp + k + 1;
  else if (w >= 0) {
    if (exp + k >= 0)
      m = w - 1;
    else
      m = w + exp + k - 2;
    if (sign < 0 || atsign)
      --m;
    if (m == 0)
      m = 1;
  } else
    m = n;
  if (m <= 0) {
    if (m == 0 && buff[0] >= '5') {
      exp++;
      n = m = 1;
      buff[0] = '1';
    } else
      n = m = 0;
  } else if (m < n) {
    n = m;
    edit_double(n, f, &sign, buff, &exp);
  }
  while (n >= 0)
    if (buff[n - 1] == '0')
      --n;
    else
      break;
  exp += k;
  j = 0;
  if (exp >= 0) {
    for (i = 0;  i <= exp;  i++)
      b[j++] = i < n ? buff[i] : '0';
    b[j++] = '.';
    if (d >= 0)
      for (m = i + d;  i < m;  i++)
        b[j++] = i < n ? buff[i] : '0';
    else
      for (;  i < n;  i++)
        b[j++] = buff[i];
  } else {
    b[j++] = '.';
    if (d >= 0) {
      for (i = 0;  i < (-exp) - 1 && i < d;  i++)
        b[j++] = '0';
      for (m = d - i, i = 0;  i < m;  i++)
        b[j++] = i < n ? buff[i] : '0';
    } else if (n > 0) {
      for (i = 0;  i < (-exp) - 1;  i++)
        b[j++] = '0';
      for (i = 0;  i < n;  i++)
        b[j++] = buff[i];
    }
  }
  b[j] = '\0';
  if (w >= 0) {
    if (sign < 0 || atsign)
      --w;
    if (j > w && overflowchar != '\0') {
      w = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0)));
      for (i = 0;  i < w;  i++)
        ecl_write_char(overflowchar, fmt->stream);
      return;
    }
    if (j < w && d < 0 && b[j-1] == '.') {
      b[j++] = '0';
      b[j] = '\0';
    }
    if (j < w && b[0] == '.') {
      *--b = '0';
      j++;
    }
    for (i = j;  i < w;  i++)
      ecl_write_char(padchar, fmt->stream);
  } else {
    if (b[0] == '.') {
      *--b = '0';
      j++;
    }
    if (d < 0 && b[j-1] == '.') {
      b[j++] = '0';
      b[j] = '\0';
    }
  }
  if (sign < 0)
    ecl_write_char('-', fmt->stream);
  else if (atsign)
    ecl_write_char('+', fmt->stream);
  writestr_stream(b, fmt->stream);
}

static int
fmt_exponent_length(int e)
{
  int i;

  if (e == 0)
    return(1);
  if (e < 0)
    e = -e;
  for (i = 0;  e > 0;  i++, e /= 10)
    ;
  return(i);
}

static void
fmt_exponent1(cl_object stream, int e)
{
  if (e == 0)
    return;
  fmt_exponent1(stream, e/10);
  ecl_write_char('0' + e%10, stream);
}

static void
fmt_exponent(format_stack fmt, int e)
{
  if (e == 0) {
    ecl_write_char('0', fmt->stream);
    return;
  }
  if (e < 0)
    e = -e;
  fmt_exponent1(fmt->stream, e);
}

static void
fmt_exponential_float(format_stack fmt, bool colon, bool atsign)
{
  int w, d, e, k;
  ecl_character overflowchar, padchar, exponentchar;
  double f;
  int sign;
  char buff[256], *b, buff1[256];
  int exp;
  int i, j;
  cl_object x, y;
  int n, m;
  cl_type t;

  b = buff1 + 1;

  fmt_not_colon(fmt, colon);
  ensure_param(fmt, 7);
  w = set_param_positive(fmt, 0, "illegal width");
  d = set_param_positive(fmt, 1, "illegal number of digits");
  e = set_param_positive(fmt, 2, "illegal number of digits in exponent");
  k = ecl_to_fix(set_param(fmt, 3, INT, ecl_make_fixnum(1)));
  overflowchar = ECL_CHAR_CODE(set_param(fmt, 4, CHAR, ECL_CODE_CHAR('\0')));
  padchar = ECL_CHAR_CODE(set_param(fmt, 5, CHAR, ECL_CODE_CHAR(' ')));
  exponentchar = ECL_CHAR_CODE(set_param(fmt, 6, CHAR, ECL_CODE_CHAR('\0')));

  x = fmt_advance(fmt);
  if (ECL_FIXNUMP(x) ||
      ecl_t_of(x) == t_bignum ||
      ecl_t_of(x) == t_ratio)
    x = ecl_make_single_float(ecl_to_float(x));
  if (!ECL_REAL_TYPE_P(ecl_t_of(x))) {
    if (fmt->nparam > 1) fmt->nparam = 1;
    fmt_back_up(fmt);
    fmt_decimal(fmt, colon, atsign);
    return;
  }
  if (ecl_t_of(x) == t_doublefloat)
    n = 16;
  else
    n = 7;
  f = ecl_to_double(x);
  edit_double(n, f, &sign, buff, &exp);
  if (d >= 0) {
    if (k > 0) {
      if (!(k < d + 2))
        fmt_error(fmt, "illegal scale factor");
      m = d + 1;
    } else {
      if (!(k > -d))
        fmt_error(fmt, "illegal scale factor");
      m = d + k;
    }
  } else if (w >= 0) {
    if (k > 0)
      m = w - 1;
    else
      m = w + k - 1;
    if (sign < 0 || atsign)
      --m;
    if (e >= 0)
      m -= e + 2;
    else
      m -= fmt_exponent_length(e - k + 1) + 2;
  } else
    m = n;
  if (m <= 0) {
    if (m == 0 && buff[0] >= '5') {
      exp++;
      n = m = 1;
      buff[0] = '1';
    } else
      n = m = 0;
  } else if (m < n) {
    n = m;
    edit_double(n, f, &sign, buff, &exp);
  }
  while (n >= 0)
    if (buff[n - 1] == '0')
      --n;
    else
      break;
  exp = exp - k + 1;
  j = 0;
  if (k > 0) {
    for (i = 0;  i < k;  i++)
      b[j++] = i < n ? buff[i] : '0';
    b[j++] = '.';
    if (d >= 0)
      for (m = i + (d - k + 1);  i < m;  i++)
        b[j++] = i < n ? buff[i] : '0';
    else
      for (;  i < n;  i++)
        b[j++] = buff[i];
  } else {
    b[j++] = '.';
    if (d >= 0) {
      for (i = 0;  i < -k && i < d;  i++)
        b[j++] = '0';
      for (m = d - i, i = 0;  i < m;  i++)
        b[j++] = i < n ? buff[i] : '0';
    } else if (n > 0) {
      for (i = 0;  i < -k;  i++)
        b[j++] = '0';
      for (i = 0;  i < n;  i++)
        b[j++] = buff[i];
    }
  }
  b[j] = '\0';
  if (w >= 0) {
    if (sign < 0 || atsign)
      --w;
    i = fmt_exponent_length(exp);
    if (e >= 0) {
      if (i > e) {
        if (overflowchar != '\0')
          goto OVER;
        else
          e = i;
      }
      w -= e + 2;
    } else
      w -= i + 2;
    if (j > w && overflowchar != '\0')
      goto OVER;
    if (j < w && b[0] == '.') {
      *--b = '0';
      j++;
    }
    for (i = j;  i < w;  i++)
      ecl_write_char(padchar, fmt->stream);
  } else {
    if (b[j-1] == '.') {
      b[j++] = '0';
      b[j] = '\0';
    }
    if (d < 0 && b[0] == '.') {
      *--b = '0';
      j++;
    }
  }
  if (sign < 0)
    ecl_write_char('-', fmt->stream);
  else if (atsign)
    ecl_write_char('+', fmt->stream);
  writestr_stream(b, fmt->stream);
  y = ecl_symbol_value(@'*read-default-float-format*');
  if (exponentchar < 0) {
    if (y == @'long-float') {
      t = t_longfloat;
    } else if (y == @'double-float') {
      t = t_doublefloat;
    } else if (y == @'single-float') {
      t = t_singlefloat;
    } else {
      t = t_singlefloat;
    }
    if (ecl_t_of(x) == t)
      exponentchar = 'E';
    else if (ecl_t_of(x) == t_singlefloat)
      exponentchar = 'F';
    else if (ecl_t_of(x) == t_longfloat)
      exponentchar = 'L';
    else
      exponentchar = 'D';
  }
  ecl_write_char(exponentchar, fmt->stream);
  if (exp < 0)
    ecl_write_char('-', fmt->stream);
  else
    ecl_write_char('+', fmt->stream);
  if (e >= 0)
    for (i = e - fmt_exponent_length(exp);  i > 0;  --i)
      ecl_write_char('0', fmt->stream);
  fmt_exponent(fmt, exp);
  return;

 OVER:
  w = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0)));
  for (i = 0;  i < w;  i++)
    ecl_write_char(overflowchar, fmt->stream);
  return;
}

static void
fmt_general_float(format_stack fmt, bool colon, bool atsign)
{
  int w, d, e, k;
  ecl_character overflowchar, padchar, exponentchar;
  int sign, exp;
  char buff[256];
  cl_object x;
  int n, ee, ww, q, dd;

  fmt_not_colon(fmt, colon);
  ensure_param(fmt, 7);
  w = set_param_positive(fmt, 0, "illegal width");
  d = set_param_positive(fmt, 1, "illegal number of digits");
  e = set_param_positive(fmt, 2, "illegal number of digits in exponent");
  k = ecl_to_fix(set_param(fmt, 3, INT, ecl_make_fixnum(1)));
  overflowchar = ECL_CHAR_CODE(set_param(fmt, 4, CHAR, ECL_CODE_CHAR('\0')));
  padchar = ECL_CHAR_CODE(set_param(fmt, 5, CHAR, ECL_CODE_CHAR(' ')));
  exponentchar = ECL_CHAR_CODE(set_param(fmt, 6, CHAR, ECL_CODE_CHAR('\0')));

  x = fmt_advance(fmt);
  if (!ECL_REAL_TYPE_P(ecl_t_of(x))) {
    if (fmt->nparam > 1) fmt->nparam = 1;
    fmt_back_up(fmt);
    fmt_decimal(fmt, colon, atsign);
    return;
  }
  if (ecl_t_of(x) == t_doublefloat)
    q = 16;
  else
    q = 7;
  edit_double(q, ecl_to_double(x), &sign, buff, &exp);
  n = exp + 1;
  while (q >= 0)
    if (buff[q - 1] == '0')
      --q;
    else
      break;
  if (e >= 0)
    ee = e + 2;
  else
    ee = 4;
  ww = w - ee;
  if (d < 0) {
    d = n < 7 ? n : 7;
    d = q > d ? q : d;
  }
  dd = d - n;
  if (0 <= dd && dd <= d) {
    fmt->nparam = 5;
    fmt->param[0] = ecl_make_fixnum(ww);
    fmt->param[1] = ecl_make_fixnum(dd);
    fmt->param[2] = ECL_NIL;
    fmt->param[3] = fmt->param[4];
    fmt->param[4] = fmt->param[5];
    fmt_back_up(fmt);
    fmt_fix_float(fmt, colon, atsign);
    if (w >= 0)
      while (ww++ < w)
        ecl_write_char(padchar, fmt->stream);
    return;
  }
  fmt->param[1] = ecl_make_fixnum(d);
  fmt_back_up(fmt);
  fmt_exponential_float(fmt, colon, atsign);
}

static void
fmt_dollars_float(format_stack fmt, bool colon, bool atsign)
{
  int d, n, w;
  ecl_character padchar;
  double f;
  int sign;
  char buff[256];
  int exp;
  int q, i;
  cl_object x;

  ensure_param(fmt, 4);
  d = set_param_positive(fmt, 0, "illegal number of digits");
  if (d < 0) d = 2;
  n = set_param_positive(fmt, 1, "illegal number of digits");
  if (n < 0) n = 1;
  w = set_param_positive(fmt, 2, "illegal width");
  if (w < 0) w = 0;
  padchar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR(' ')));
  x = fmt_advance(fmt);
  if (!ECL_REAL_TYPE_P(ecl_t_of(x))) {
    if (fmt->nparam < 3)
      fmt->nparam = 0;
    else {
      fmt->nparam = 1;
      fmt->param[0] = fmt->param[2];
    }
    fmt_back_up(fmt);
    fmt_decimal(fmt, colon, atsign);
    return;
  }
  q = 7;
  if (ecl_t_of(x) == t_doublefloat)
    q = 16;
  f = ecl_to_double(x);
  edit_double(q, f, &sign, buff, &exp);
  if ((q = exp + d + 1) > 0)
    edit_double(q, f, &sign, buff, &exp);
  exp++;
  if (w > 100 || exp > 100 || exp < -100) {
    fmt->nparam = 6;
    fmt->param[0] = fmt->param[2];
    fmt->param[1] = ecl_make_fixnum(d + n - 1);
    fmt->param[5] = fmt->param[3];
    fmt->param[2] =
      fmt->param[3] =
      fmt->param[4] = ECL_NIL;
    fmt_back_up(fmt);
    fmt_exponential_float(fmt, colon, atsign);
  }
  if (exp > n)
    n = exp;
  if (sign < 0 || atsign)
    --w;
  if (colon) {
    if (sign < 0)
      ecl_write_char('-', fmt->stream);
    else if (atsign)
      ecl_write_char('+', fmt->stream);
    while (--w > n + d)
      ecl_write_char(padchar, fmt->stream);
  } else {
    while (--w > n + d)
      ecl_write_char(padchar, fmt->stream);
    if (sign < 0)
      ecl_write_char('-', fmt->stream);
    else if (atsign)
      ecl_write_char('+', fmt->stream);
  }
  for (i = n - exp;  i > 0;  --i)
    ecl_write_char('0', fmt->stream);
  for (i = 0;  i < exp;  i++)
    ecl_write_char((i < q ? buff[i] : '0'), fmt->stream);
  ecl_write_char('.', fmt->stream);
  for (d += i;  i < d;  i++)
    ecl_write_char((i < q ? buff[i] : '0'), fmt->stream);
}

static void
fmt_percent(format_stack fmt, bool colon, bool atsign)
{
  int n, i;

  ensure_param(fmt, 1);
  n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1)));
  fmt_not_colon(fmt, colon);
  fmt_not_atsign(fmt, atsign);
  while (n-- > 0) {
    ecl_write_char('\n', fmt->stream);
    if (n == 0)
      for (i = fmt->indents;  i > 0;  --i)
        ecl_write_char(' ', fmt->stream);
  }
}

static void
fmt_ampersand(format_stack fmt, bool colon, bool atsign)
{
  int n;

  ensure_param(fmt, 1);
  n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1)));
  fmt_not_colon(fmt, colon);
  fmt_not_atsign(fmt, atsign);
  if (n == 0)
    return;
  if (ecl_file_column(fmt->stream) != 0)
    ecl_write_char('\n', fmt->stream);
  while (--n > 0)
    ecl_write_char('\n', fmt->stream);
  fmt->indents = 0;
}

static void
fmt_bar(format_stack fmt, bool colon, bool atsign)
{
  int n;

  ensure_param(fmt, 1);
  n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1)));
  fmt_not_colon(fmt, colon);
  fmt_not_atsign(fmt, atsign);
  while (n-- > 0)
    ecl_write_char('\f', fmt->stream);
}

static void
fmt_tilde(format_stack fmt, bool colon, bool atsign)
{
  int n;

  ensure_param(fmt, 1);
  n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1)));
  fmt_not_colon(fmt, colon);
  fmt_not_atsign(fmt, atsign);
  while (n-- > 0)
    ecl_write_char('~', fmt->stream);
}

static void
fmt_newline(format_stack fmt, bool colon, bool atsign)
{
  ensure_param(fmt, 0);
  fmt_not_colon_atsign(fmt, colon, atsign);
  if (atsign)
    ecl_write_char('\n', fmt->stream);
  while (fmt->ctl_index < fmt->ctl_end && isspace(ecl_char(fmt->ctl_str, fmt->ctl_index))) {
    if (colon)
      ecl_write_char(ecl_char(fmt->ctl_str, fmt->ctl_index), fmt->stream);
    fmt->ctl_index++;
  }
}

static void
fmt_tabulate(format_stack fmt, bool colon, bool atsign)
{
  int colnum, colinc;
  int c, i;

  ensure_param(fmt, 2);
  fmt_not_colon(fmt, colon);
  colnum = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1)));
  colinc = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(1)));
  if (!atsign) {
    c = ecl_file_column(fmt->stream);
    if (c < 0) {
      writestr_stream("  ", fmt->stream);
      return;
    }
    if (c > colnum && colinc <= 0)
      return;
    while (c > colnum)
      colnum += colinc;
    for (i = colnum - c;  i > 0;  --i)
      ecl_write_char(' ', fmt->stream);
  } else {
    for (i = colnum;  i > 0;  --i)
      ecl_write_char(' ', fmt->stream);
    c = ecl_file_column(fmt->stream);
    if (c < 0 || colinc <= 0)
      return;
    colnum = 0;
    while (c > colnum)
      colnum += colinc;
    for (i = colnum - c;  i > 0;  --i)
      ecl_write_char(' ', fmt->stream);
  }
}

static void
fmt_asterisk(format_stack fmt, bool colon, bool atsign)
{
  int n;

  ensure_param(fmt, 1);
  fmt_not_colon_atsign(fmt, colon, atsign);
  if (atsign) {
    n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0)));
    fmt_go(fmt, n);
  } else if (colon) {
    n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1)));
    fmt_go(fmt, fmt_index(fmt) - n);
  } else {
    n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1)));
    while (n-- > 0)
      fmt_advance(fmt);
  }
}

static void
fmt_indirection(format_stack fmt, bool colon, bool atsign)
{
  cl_object s, l;
  struct format_stack_struct fmt_old;
  jmp_buf fmt_jmp_buf0;
  int up_colon;

  ensure_param(fmt, 0);
  fmt_not_colon(fmt, colon);
  s = fmt_advance(fmt);
  switch (ecl_t_of(s)) {
#ifdef ECL_UNICODE
  case t_string:
#endif
  case t_base_string:
    break;
  default:
    fmt_error(fmt, "control string expected");
  }
  if (atsign) {
    fmt_copy(&fmt_old, fmt);
    fmt->jmp_buf = &fmt_jmp_buf0;
    fmt->ctl_str = s;
    if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) {
      if (--up_colon)
        fmt_error(fmt, "illegal ~~:^");
    } else
      format(fmt, 0, s->base_string.fillp);
    fmt_copy1(fmt, &fmt_old);
  } else {
    l = fmt_advance(fmt);
    fmt_copy(&fmt_old, fmt);
    fmt_set_arg_list(fmt, l);
    fmt->jmp_buf = &fmt_jmp_buf0;
    fmt->ctl_str = s;
    if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) {
      if (--up_colon)
        fmt_error(fmt, "illegal ~~:^");
    } else
      format(fmt, 0, s->base_string.fillp);
    fmt_copy(fmt, &fmt_old);
  }
}

static void
fmt_case(format_stack fmt, bool colon, bool atsign)
{
  cl_object x;
  cl_index i;
  int j;
  ecl_character c;
  struct format_stack_struct fmt_old;
  jmp_buf fmt_jmp_buf0;
  int up_colon;
  bool b;

  x = ecl_make_string_output_stream(64, 1);
  i = fmt->ctl_index;
  j = fmt_skip(fmt);
  if (ecl_char(fmt->ctl_str, --j) != ')' || ecl_char(fmt->ctl_str, --j) != '~')
    fmt_error(fmt, "~~) expected");
  fmt_copy(&fmt_old, fmt);
  fmt->stream = x;
  fmt->jmp_buf = &fmt_jmp_buf0;
  if ((up_colon = ecl_setjmp(*fmt->jmp_buf)))
    ;
  else
    format(fmt, i, j);
  fmt_copy1(fmt, &fmt_old);
  x = STRING_OUTPUT_STRING(x);
  if (!colon && !atsign)
    for (i = 0;  i < x->base_string.fillp;  i++) {
      if (ecl_upper_case_p(c = ecl_char(x, i)))
        c = ecl_char_downcase(c);
      ecl_write_char(c, fmt->stream);
    }
  else if (colon && !atsign)
    for (b = TRUE, i = 0;  i < x->base_string.fillp;  i++) {
      if (ecl_lower_case_p(c = ecl_char(x, i))) {
        if (b)
          c = ecl_char_upcase(c);
        b = FALSE;
      } else if (ecl_upper_case_p(c)) {
        if (!b)
          c = ecl_char_downcase(c);
        b = FALSE;
      } else if (ecl_digitp(c,10) == -1)
        b = TRUE;
      ecl_write_char(c, fmt->stream);
    }
  else if (!colon && atsign)
    for (b = TRUE, i = 0;  i < x->base_string.fillp;  i++) {
      if (ecl_lower_case_p(c = ecl_char(x, i))) {
        if (b)
          c = ecl_char_upcase(c);
        b = FALSE;
      } else if (ecl_upper_case_p(c)) {
        if (!b)
          c = ecl_char_downcase(c);
        b = FALSE;
      }
      ecl_write_char(c, fmt->stream);
    }
  else
    for (i = 0;  i < x->base_string.fillp;  i++) {
      if (ecl_lower_case_p(c = ecl_char(x, i)))
        c = ecl_char_upcase(c);
      ecl_write_char(c, fmt->stream);
    }
  if (up_colon)
    ecl_longjmp(*fmt->jmp_buf, up_colon);
}

static void
fmt_conditional(format_stack fmt, bool colon, bool atsign)
{
  int i, j, k;
  cl_object x;
  int n;
  bool done;
  struct format_stack_struct fmt_old;

  fmt_not_colon_atsign(fmt, colon, atsign);
  if (colon) {
    ensure_param(fmt, 0);
    i = fmt->ctl_index;
    j = fmt_skip(fmt);
    if (ecl_char(fmt->ctl_str, --j) != ';' || ecl_char(fmt->ctl_str, --j) != '~')
      fmt_error(fmt, "~~; expected");
    k = fmt_skip(fmt);
    if (ecl_char(fmt->ctl_str, --k) != ']' || ecl_char(fmt->ctl_str, --k) != '~')
      fmt_error(fmt, "~~] expected");
    if (Null(fmt_advance(fmt))) {
      fmt_copy(&fmt_old, fmt);
      format(fmt, i, j);
      fmt_copy1(fmt, &fmt_old);
    } else {
      fmt_copy(&fmt_old, fmt);
      format(fmt, j + 2, k);
      fmt_copy1(fmt, &fmt_old);
    }
  } else if (atsign) {
    i = fmt->ctl_index;
    j = fmt_skip(fmt);
    if (ecl_char(fmt->ctl_str, --j) != ']' || ecl_char(fmt->ctl_str, --j) != '~')
      fmt_error(fmt, "~~] expected");
    if (Null(fmt_advance(fmt)))
      ;
    else {
      fmt_back_up(fmt);
      fmt_copy(&fmt_old, fmt);
      format(fmt, i, j);
      fmt_copy1(fmt, &fmt_old);
    }
  } else {
    ensure_param(fmt, 1);
    if (fmt->nparam == 0) {
      x = fmt_advance(fmt);
      if (!ECL_FIXNUMP(x))
        fmt_error(fmt, "illegal argument for conditional");
      n = ecl_fixnum(x);
    } else
      n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0)));
    i = fmt->ctl_index;
    for (done = FALSE;;  --n) {
      j = fmt_skip(fmt);
      for (k = j; ecl_char(fmt->ctl_str, --k) != '~';)
        ;
      if (n == 0) {
        fmt_copy(&fmt_old, fmt);
        format(fmt, i, k);
        fmt_copy1(fmt, &fmt_old);
        done = TRUE;
      }
      i = j;
      if (ecl_char(fmt->ctl_str, --j) == ']') {
        if (ecl_char(fmt->ctl_str, --j) != '~')
          fmt_error(fmt, "~~] expected");
        return;
      }
      if (ecl_char(fmt->ctl_str, j) == ';') {
        if (ecl_char(fmt->ctl_str, --j) == '~')
          continue;
        if (ecl_char(fmt->ctl_str, j) == ':')
          goto ELSE;
      }
      fmt_error(fmt, "~~; or ~~] expected");
    }
  ELSE:
    if (ecl_char(fmt->ctl_str, --j) != '~')
      fmt_error(fmt, "~~:; expected");
    j = fmt_skip(fmt);
    if (ecl_char(fmt->ctl_str, --j) != ']' || ecl_char(fmt->ctl_str, --j) != '~')
      fmt_error(fmt, "~~] expected");
    if (!done) {
      fmt_copy(&fmt_old, fmt);
      format(fmt, i, j);
      fmt_copy1(fmt, &fmt_old);
    }
  }
}

static void
fmt_iteration(format_stack fmt, bool colon, bool atsign)
{
  int n, i;
  volatile int j;
  bool colon_close = FALSE;
  cl_object l;
  struct format_stack_struct fmt_old;
  jmp_buf fmt_jmp_buf0;
  int up_colon;

  ensure_param(fmt, 1);
  n = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(1000000)));
  i = fmt->ctl_index;
  j = fmt_skip(fmt);
  if (ecl_char(fmt->ctl_str, --j) != '}')
    fmt_error(fmt, "~~} expected");
  if (ecl_char(fmt->ctl_str, --j) == ':') {
    colon_close = TRUE;
    --j;
  }
  if (ecl_char(fmt->ctl_str, j) != '~')
    fmt_error(fmt, "syntax error");
  if (!colon && !atsign) {
    l = fmt_advance(fmt);
    fmt_copy(&fmt_old, fmt);
    fmt_set_arg_list(fmt, l);
    fmt->jmp_buf = &fmt_jmp_buf0;
    if (colon_close)
      goto L1;
    while (fmt_more_args_p(fmt)) {
    L1:
      if (n-- <= 0)
        break;
      if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) {
        if (--up_colon)
          fmt_error(fmt, "illegal ~~:^");
        break;
      }
      format(fmt, i, j);
    }
    fmt_copy(fmt, &fmt_old);
  } else if (colon && !atsign) {
    int fl = 0;
    volatile cl_object l0;
    l0 = fmt_advance(fmt);
    fmt_copy(&fmt_old, fmt);
    for (l = l0; !ecl_endp(l); l = CDR(l))
      fl += ecl_length(CAR(l));
    fmt->jmp_buf = &fmt_jmp_buf0;
    if (colon_close)
      goto L2;
    while (!ecl_endp(l0)) {
    L2:
      if (n-- <= 0)
        break;
      l = CAR(l0);
      l0 = CDR(l0);
      fmt_set_arg_list(fmt, l);
      if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) {
        if (--up_colon)
          break;
        else
          continue;
      }
      format(fmt, i, j);
    }
    fmt_copy(fmt, &fmt_old);
  } else if (!colon && atsign) {
    fmt_copy(&fmt_old, fmt);
    fmt->jmp_buf = &fmt_jmp_buf0;
    if (colon_close)
      goto L3;
    while (fmt_more_args_p(fmt)) {
    L3:
      if (n-- <= 0)
        break;
      if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) {
        if (--up_colon)
          fmt_error(fmt, "illegal ~~:^");
        break;
      }
      format(fmt, i, j);
    }
    fmt_copy1(fmt, &fmt_old);
  } else if (colon && atsign) {
    if (colon_close)
      goto L4;
    while (fmt_more_args_p(fmt)) {
    L4:
      if (n-- <= 0)
        break;
      l = fmt_advance(fmt);
      fmt_copy(&fmt_old, fmt);
      fmt_set_arg_list(fmt, l);
      fmt->jmp_buf = &fmt_jmp_buf0;
      if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) {
        fmt_copy(fmt, &fmt_old);
        if (--up_colon)
          break;
        else
          continue;
      }
      format(fmt, i, j);
      fmt_copy(fmt, &fmt_old);
    }
  }
}

static void
fmt_justification(format_stack fmt, volatile bool colon, bool atsign)
{
  int mincol, colinc;
  ecl_character minpad, padchar;
  volatile cl_object fields;
  cl_object p;
  struct format_stack_struct fmt_old;
  jmp_buf fmt_jmp_buf0;
  volatile int i, j, k, l, m, j0, l0;
  int up_colon;
  volatile cl_object special = ECL_NIL;
  volatile int spare_spaces, line_length;

  ensure_param(fmt, 4);
  mincol = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0)));
  colinc = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(1)));
  minpad = ecl_to_fix(set_param(fmt, 2, INT, ecl_make_fixnum(0)));
  padchar = ECL_CHAR_CODE(set_param(fmt, 3, CHAR, ECL_CODE_CHAR(' ')));

  fields = ECL_NIL;
  for (;;) {
    cl_object this_field = ecl_make_string_output_stream(64, 1);
    i = fmt->ctl_index;
    j0 = j = fmt_skip(fmt);
    while (ecl_char(fmt->ctl_str, --j) != '~')
      ;

    fmt_copy(&fmt_old, fmt);
    fmt->jmp_buf = &fmt_jmp_buf0;
    if ((up_colon = ecl_setjmp(*fmt->jmp_buf))) {
      if (--up_colon)
        fmt_error(fmt, "illegal ~~:^");
      fmt_copy1(fmt, &fmt_old);
      while (ecl_char(fmt->ctl_str, --j0) != '>')
        j0 = fmt_skip(fmt);
      if (ecl_char(fmt->ctl_str, --j0) != '~')
        fmt_error(fmt, "~~> expected");
      break;
    }
    fmt->stream = this_field;
    format(fmt, i, j);
    fields = CONS(STRING_OUTPUT_STRING(this_field), fields);
    fmt_copy1(fmt, &fmt_old);

    if (ecl_char(fmt->ctl_str, --j0) == '>') {
      if (ecl_char(fmt->ctl_str, --j0) != '~')
        fmt_error(fmt, "~~> expected");
      break;
    } else if (ecl_char(fmt->ctl_str, j0) != ';')
      fmt_error(fmt, "~~; expected");
    else if (ecl_char(fmt->ctl_str, --j0) == ':') {
      if (ecl_length(fields) != 1 || !Null(special))
        fmt_error(fmt, "illegal ~~:;");
      special = CAR(fields);
      fields = CDR(fields);
      for (j = j0; ecl_char(fmt->ctl_str, j) != '~';  --j)
        ;
      fmt_copy(&fmt_old, fmt);
      format(fmt, j, j0 + 2);
      fmt_copy1(fmt, &fmt_old);
      spare_spaces = fmt->spare_spaces;
      line_length = fmt->line_length;
    } else if (ecl_char(fmt->ctl_str, j0) != '~')
      fmt_error(fmt, "~~; expected");
  }
  /*
   * Compute the length of items to be output. If the clause ~:; was
   * found, the first item is not included.
   */
  fields = cl_nreverse(fields);
  for (p = fields, l = 0;  p != ECL_NIL; p = CDR(p))
    l += CAR(p)->base_string.fillp;
  /*
   * Count the number of segments that need padding, "M". If the colon
   * modifier, the first item needs padding. If the @@ modifier is
   * present, the last modifier also needs padding.
   */
  m = ecl_length(fields) - 1;
  if (m <= 0 && !colon && !atsign) {
    m = 0;
    colon = TRUE;
  }
  if (colon)
    m++;
  if (atsign)
    m++;
  /*
   * Count the minimal length in which the text fits. This length must
   * the smallest integer of the form l = mincol + k * colinc. If the
   * length exceeds the line length, the text before the ~:; is output
   * first.
   */
  l0 = l;
  l += minpad * m;
  for (k = 0;  mincol + k * colinc < l;  k++)
    ;
  l = mincol + k * colinc;
  if (special != ECL_NIL &&
      ecl_file_column(fmt->stream) + l + spare_spaces > line_length)
    ecl_princ(special, fmt->stream);
  /*
   * Output the text with the padding segments. The total number of
   * padchars is kept in "l", and it is shared equally among all segments.
   */
  l -= l0;
  for (p = fields;  p != ECL_NIL; p = CDR(p)) {
    if (p != fields || colon)
      for (j = l / m, l -= j, --m;  j > 0;  --j)
        ecl_write_char(padchar, fmt->stream);
    ecl_princ(CAR(p), fmt->stream);
  }
  if (atsign)
    for (j = l;  j > 0;  --j)
      ecl_write_char(padchar, fmt->stream);
}

static void
fmt_up_and_out(format_stack fmt, bool colon, bool atsign)
{
  int i, j, k;

  ensure_param(fmt, 3);
  fmt_not_atsign(fmt, atsign);
  if (fmt->nparam == 0) {
    if (!fmt_more_args_p(fmt))
      ecl_longjmp(*fmt->jmp_buf, ++colon);
  } else if (fmt->nparam == 1) {
    i = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0)));
    if (i == 0)
      ecl_longjmp(*fmt->jmp_buf, ++colon);
  } else if (fmt->nparam == 2) {
    i = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0)));
    j = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(0)));
    if (i == j)
      ecl_longjmp(*fmt->jmp_buf, ++colon);
  } else {
    i = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0)));
    j = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(0)));
    k = ecl_to_fix(set_param(fmt, 2, INT, ecl_make_fixnum(0)));
    if (i <= j && j <= k)
      ecl_longjmp(*fmt->jmp_buf, ++colon);
  }
}

static void
fmt_semicolon(format_stack fmt, bool colon, bool atsign)
{
  fmt_not_atsign(fmt, atsign);
  if (!colon)
    fmt_error(fmt, "~~:; expected");
  ensure_param(fmt, 2);
  fmt->spare_spaces = ecl_to_fix(set_param(fmt, 0, INT, ecl_make_fixnum(0)));
  fmt->line_length = ecl_to_fix(set_param(fmt, 1, INT, ecl_make_fixnum(72)));
}

@(defun si::formatter-aux (strm string &rest args)
@
  @(return doformat(narg, strm, string, args, TRUE))
@)


static cl_object
doformat(cl_narg narg, cl_object strm, cl_object string, ecl_va_list args, bool in_formatter)
{
  struct format_stack_struct fmt;
  jmp_buf fmt_jmp_buf0;
  int colon;
  cl_object output = cl_grab_rest_args(args);
  while(!ecl_stringp(string))
#ifdef ECL_UNICODE
    string = ecl_type_error(@'format', "argument", string, @'string');
#else
  string = ecl_type_error(@'format', "argument", string, @'base-string');
#endif
  fmt.stream = strm;
  fmt_set_arg_list(&fmt, output);
  fmt.jmp_buf = &fmt_jmp_buf0;
  if (ecl_symbol_value(@'si::*indent-formatted-output*') != ECL_NIL)
    fmt.indents = ecl_file_column(strm);
  else
    fmt.indents = 0;
  fmt.ctl_str = string;
  fmt.aux_stream = get_aux_stream();
  fmt.aux_string = STRING_OUTPUT_STRING(fmt.aux_stream);
  if ((colon = ecl_setjmp(*fmt.jmp_buf))) {
    if (--colon)
      fmt_error(&fmt, "illegal ~~:^");
  } else {
    format(&fmt, 0, string->base_string.fillp);
    ecl_force_output(strm);
  }
  ecl_process_env()->fmt_aux_stream = fmt.aux_stream;
  if (!in_formatter)
    output = ECL_NIL;
  return output;
}

static void
format(format_stack fmt, cl_index start, cl_index end)
{
  ecl_character c;
  cl_index i, n;
  bool colon, atsign;
  cl_object x;

  fmt->ctl_index = start;
  fmt->ctl_end = end;

 LOOP:
  if (fmt->ctl_index >= fmt->ctl_end)
    return;
  if ((c = ctl_advance(fmt)) != '~') {
    ecl_write_char(c, fmt->stream);
    goto LOOP;
  }
  n = 0;
  for (;;) {
    switch (c = ctl_advance(fmt)) {
    case ',':
      fmt->param[n] = ECL_NIL;
      break;

    case '+':  case '-':
    case '0':  case '1':  case '2':  case '3':  case '4':
    case '5':  case '6':  case '7':  case '8':  case '9':
      i = fmt->ctl_index - 1;
      do {
        c = ctl_advance(fmt);
      } while (ecl_digitp(c,10) != -1);
      x = ecl_parse_integer(fmt->ctl_str, i, fmt->ctl_index, &i, 10);
    INTEGER:
      /* FIXME! A hack to solve the problem of bignums in arguments */
      if (x == OBJNULL || !ecl_numberp(x))
        fmt_error(fmt, "integer expected");
      if (ecl_number_compare(x, ecl_make_fixnum(FMT_VALUE_UPPER_LIMIT)) > 0) {
        fmt->param[n] = ecl_make_fixnum(FMT_VALUE_UPPER_LIMIT);
      } else if (ecl_number_compare(x, ecl_make_fixnum(FMT_VALUE_LOWER_LIMIT)) < 0) {
        fmt->param[n] = ecl_make_fixnum(FMT_VALUE_LOWER_LIMIT);
      } else {
        fmt->param[n] = x;
      }
      if (ECL_FIXNUMP(x)) {
        fmt->param[n] = x;
      } else if (ecl_plusp(x)) {
        fmt->param[n] = ecl_make_fixnum(MOST_POSITIVE_FIXNUM);
      } else {
        fmt->param[n] = ecl_make_fixnum(MOST_NEGATIVE_FIXNUM);
      }
      break;

    case '\'':
      fmt->param[n] = ECL_CODE_CHAR(ctl_advance(fmt));
      c = ctl_advance(fmt);
      break;

    case 'v':  case 'V':
      x = fmt_advance(fmt);
      c = ctl_advance(fmt);
      if (ecl_t_of(x) == t_character) {
        fmt->param[n] = x;
      } else {
        goto INTEGER;
      }
      break;

    case '#':
      fmt->param[n] = ecl_make_fixnum(fmt_args_left(fmt));
      c = ctl_advance(fmt);
      break;

    default:
      if (n > 0)
        fmt_error(fmt, "illegal ,");
      else
        goto DIRECTIVE;
    }
    n++;
    if (n == FMT_MAX_PARAM)
      fmt_error(fmt, "too many parameters");
    if (c != ',')
      break;
  }

 DIRECTIVE:
  colon = atsign = FALSE;
  if (c == ':') {
    colon = TRUE;
    c = ctl_advance(fmt);
  }
  if (c == '@@') {
    atsign = TRUE;
    c = ctl_advance(fmt);
  }
  fmt->nparam = n;
  switch (c) {
  case 'a':  case 'A':
    fmt_ascii(fmt, colon, atsign);
    break;

  case 's':  case 'S':
    fmt_S_expression(fmt, colon, atsign);
    break;

  case 'd':  case 'D':
    fmt_decimal(fmt, colon, atsign);
    break;

  case 'b':  case 'B':
    fmt_binary(fmt, colon, atsign);
    break;

  case 'o':  case 'O':
    fmt_octal(fmt, colon, atsign);
    break;

  case 'x':  case 'X':
    fmt_hexadecimal(fmt, colon, atsign);
    break;

  case 'r':  case 'R':
    fmt_radix(fmt, colon, atsign);
    break;

  case 'p':  case 'P':
    fmt_plural(fmt, colon, atsign);
    break;

  case 'c':  case 'C':
    fmt_character(fmt, colon, atsign);
    break;

  case 'f':  case 'F':
    fmt_fix_float(fmt, colon, atsign);
    break;

  case 'e':  case 'E':
    fmt_exponential_float(fmt, colon, atsign);
    break;

  case 'g':  case 'G':
    fmt_general_float(fmt, colon, atsign);
    break;

  case '$':
    fmt_dollars_float(fmt, colon, atsign);
    break;

  case '%':
    fmt_percent(fmt, colon, atsign);
    break;

  case '&':
    fmt_ampersand(fmt, colon, atsign);
    break;

  case '|':
    fmt_bar(fmt, colon, atsign);
    break;

  case '~':
    fmt_tilde(fmt, colon, atsign);
    break;

  case '\n':
  case '\r':
    fmt_newline(fmt, colon, atsign);
    break;

  case 't':  case 'T':
    fmt_tabulate(fmt, colon, atsign);
    break;

  case '*':
    fmt_asterisk(fmt, colon, atsign);
    break;

  case '?':
    fmt_indirection(fmt, colon, atsign);
    break;

  case '(':
    fmt_case(fmt, colon, atsign);
    break;

  case '[':
    fmt_conditional(fmt, colon, atsign);
    break;

  case '{':
    fmt_iteration(fmt, colon, atsign);
    break;

  case '<':
    fmt_justification(fmt, colon, atsign);
    break;

  case '^':
    fmt_up_and_out(fmt, colon, atsign);
    break;

  case ';':
    fmt_semicolon(fmt, colon, atsign);
    break;

  default:
    fmt_error(fmt, "illegal directive");
  }
  goto LOOP;
}
#endif /* !ECL_CMU_FORMAT */

@(defun format (strm string &rest args)
  cl_object output = ECL_NIL;
  int null_strm = 0;
@
  if (Null(strm)) {
#ifdef ECL_UNICODE
    strm = ecl_alloc_adjustable_extended_string(64);
#else
    strm = ecl_alloc_adjustable_base_string(64);
#endif
    null_strm = 1;
  } else if (strm == ECL_T) {
    strm = ecl_cmp_symbol_value(the_env, @'*standard-output*');
  }
  if (ecl_stringp(strm)) {
    output = strm;
    if (!ECL_ARRAY_HAS_FILL_POINTER_P(output)) {
      cl_error(7, @'si::format-error',
               @':format-control',
               @"Cannot output to a non adjustable string.",
               @':control-string', string,
               @':offset', ecl_make_fixnum(0));
    }
    strm = si_make_string_output_stream_from_string(strm);
    if (null_strm == 0)
      output = ECL_NIL;
  }
  if (!Null(cl_functionp(string))) {
    cl_apply(3, string, strm, cl_grab_rest_args(args));
  } else {
#ifdef ECL_CMU_FORMAT
    _ecl_funcall4(@'si::formatter-aux', strm, string,
                  cl_grab_rest_args(args));
#else
    doformat(narg, strm, string, args, FALSE);
#endif
  }
  output = cl_copy_seq(output);
  @(return output);
@)
