yap-6.3/os/format.c

/*************************************************************************
 *									 *
 *	 YAP Prolog 							 *
 *									 *
 *	Yap Prolog was developed at NCCUP - Universidade do Porto	 *
 *									 *
 * Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997	 *
 *									 *
 **************************************************************************
 *									 *
 * File:		charcodes.c *
 * Last rev:	5/2/88							 *
 * mods: *
 * comments:	Character codes and character conversion		 *
 *									 *
 *************************************************************************/
#ifdef SCCS
static char SccsId[] = "%W% %G%";
#endif

/**
 * @defgroup FormattedIO Formatted Output
 * @ingroup YAPIO
 * This file includes the definition of the formatted output predicates.
 *
 * @{
 *
 * @pred  format(+ _T_, :_L_)


Print formatted output to the current output stream. The arguments in
list _L_ are output according to the string, list of codes or
characters, or by the atom _T_.

A control sequence is introduced by a `~`. The following control
sequences are available in YAP:

+ `~~`
Print a single tilde.

+ `~a`
The next argument must be an atom, that will be printed as if by `write`.

+ `~Nc`
The next argument must be an integer, that will be printed as a
character code. The number  _N_ is the number of times to print the
character (default 1).

+ `~Ne`
+ `~NE`
+ `~Nf`
+ `~Ng`
+ `~NG`
The next argument must be a floating point number. The float  _F_, the number
 _N_ and the control code `c` will be passed to `printf` as:

~~~~~{.prolog}
    printf("%s.Nc", F)
~~~~~

As an example:

~~~~~{.prolog}
?- format("~8e, ~8E, ~8f, ~8g, ~8G~w",
          [3.14,3.14,3.14,3.14,3.14,3.14]).
3.140000e+00, 3.140000E+00, 3.140000, 3.14, 3.143.14
~~~~~

+ `~Nd`
The next argument must be an integer, and  _N_ is the number of digits
after the decimal point. If  _N_ is `0` no decimal points will be
printed. The default is  _N = 0_.

~~~~~{.prolog}
?- format("~2d, ~d",[15000, 15000]).
150.00, 15000
~~~~~

+ `~ND`
Identical to `~Nd`, except that commas are used to separate groups
of three digits.

~~~~~{.prolog}
?- format("~2D, ~D",[150000, 150000]).
1,500.00, 150,000
~~~~~

+ `~i`
Ignore the next argument in the list of arguments:

~~~~~{.prolog}
?- format('The ~i met the boregrove',[mimsy]).
The  met the boregrove
~~~~~

+ `~k`
Print the next argument with `write_canonical`:

~~~~~{.prolog}
?- format("Good night ~k",a+[1,2]).
Good night +(a,[1,2])
~~~~~

+ `~Nn`
Print  _N_ newlines (where  _N_ defaults to 1).

+ `~NN`
Print  _N_ newlines if at the beginning of the line (where  _N_
defaults to 1).

+ `~Nr`
The next argument must be an integer, and  _N_ is interpreted as a
radix, such that `2 <= N <= 36` (the default is 8).

~~~~~{.prolog}
?- format("~2r, 0x~16r, ~r",
          [150000, 150000, 150000]).
100100100111110000, 0x249f0, 444760
~~~~~

Note that the letters `a-z` denote digits larger than 9.

+ `~NR`
Similar to `~NR`. The next argument must be an integer, and  _N_ is
interpreted as a radix, such that `2 <= N <= 36` (the default is 8).

~~~~~{.prolog}
?- format("~2r, 0x~16r, ~r",
          [150000, 150000, 150000]).
100100100111110000, 0x249F0, 444760
~~~~~

The only difference is that letters `A-Z` denote digits larger than 9.

+ `~p`
Print the next argument with print/1:

~~~~~{.prolog}
?- format("Good night ~p",a+[1,2]).
Good night a+[1,2]
~~~~~

+ `~q`
Print the next argument with writeq/1:

~~~~~{.prolog}
?- format("Good night ~q",'Hello'+[1,2]).
Good night 'Hello'+[1,2]
~~~~~

+ `~Ns`
The next argument must be a list of character codes.The system then
outputs their representation as a string, where  _N_ is the maximum
number of characters for the string ( _N_ defaults to the length of the
string).

~~~~~{.prolog}
?- format("The ~s are ~4s",["woods","lovely"]).
The woods are love
~~~~~

+ `~w`
Print the next argument with write/1:

~~~~~
?- format("Good night ~w",'Hello'+[1,2]).
Good night Hello+[1,2]
~~~~~


The number of arguments, `N`, may be given as an integer, or it
may be given as an extra argument. The next example shows a small
procedure to write a variable number of `a` characters:

~~~~~
write_many_as(N) :-
        format("~*c",[N,0'a]).
~~~~~

The format/2 built-in also allows for formatted output.  One can
specify column boundaries and fill the intermediate space by a padding
character:

+ `~N|`
Set a column boundary at position  _N_, where  _N_ defaults to the
current position.

+ `~N+`
Set a column boundary at  _N_ characters past the current position, where
 _N_ defaults to `8`.

+ `~Nt`
Set padding for a column, where  _N_ is the fill code (default is
`SPC`).



The next example shows how to align columns and padding. We first show
left-alignment:

~~~~~
   ?- format("~n*Hello~16+*~n",[]).
*Hello          *
~~~~~

Note that we reserve 16 characters for the column.

The following example shows how to do right-alignment:

~~~~~
   ?- format("*~tHello~16+*~n",[]).
*          Hello*

~~~~~

The `~t` escape sequence forces filling before `Hello`.

We next show how to do centering:

~~~~~
   ?- format("*~tHello~t~16+*~n",[]).
*     Hello     *
~~~~~

The two `~t` escape sequence force filling both before and after
`Hello`. Space is then evenly divided between the right and the
left sides.

+ `~@`
Evaluate the next argument as a goal whose standard
output is directed to the stream used by format/2.

*/

#include "Yap.h"
#include "YapHeap.h"
#include "YapText.h"
#include "Yatom.h"
#include "yapio.h"
#include <stdlib.h>

#if HAVE_UNISTD_H

#include <unistd.h>

#endif
#if HAVE_STDARG_H

#include <stdarg.h>

#endif
#ifdef _WIN32
#if HAVE_IO_H
/* Windows */
#include <io.h>
#endif
#if HAVE_SOCKET
#include <winsock2.h>
#endif
#include <windows.h>
#ifndef S_ISDIR
#define S_ISDIR(x) (((x)&_S_IFDIR) == _S_IFDIR)
#endif
#endif

#include "eval.h"
#include "iopreds.h"

#define FORMAT_MAX_SIZE 1024

typedef struct {
  Int filler;
  /* character to dump */
  int phys;
  /* position in buffer */
  int log; /* columnn as wide chsh */
} gap_t;

typedef struct format_status {
  gap_t gap[16];
  // number of octets
  int phys_start;
  // number of characters
  int lstart;
  int gapi;
} format_info;

static bool format_synch(int sno, int sno0, format_info *fg) {
  int (*f_putc)(int, int);
  const char *s;
  int n;
  if (sno == sno0) {
#if MAY_WRITE
    fflush(GLOBAL_Stream[sno].file);
#endif
    return true;
  }
  f_putc = GLOBAL_Stream[sno0].stream_putc;
#if MAY_WRITE
  if (fflush(GLOBAL_Stream[sno].file) == 0) {
    s = GLOBAL_Stream[sno].nbuf;
    n = ftell(GLOBAL_Stream[sno].file);
    fwrite(s, n, 1, GLOBAL_Stream[sno0].file);
    rewind(GLOBAL_Stream[sno].file);
    fflush(GLOBAL_Stream[sno0].file);
  } else
    return false;
#else
  s = GLOBAL_Stream[sno].u.mem_string.buf;
  n = GLOBAL_Stream[sno].u.mem_string.pos;
#endif
#if MAY_WRITE
#else
  while (n--) {
    f_putc(sno0, *s++);
  }
  GLOBAL_Stream[sno].u.mem_string.pos = 0;
#endif
  GLOBAL_Stream[sno].linecount = 1;
  GLOBAL_Stream[sno].linepos = 0;
  GLOBAL_Stream[sno].charcount = 0;
  fg->lstart = 0;
  fg->phys_start = 0;
  fg->gapi = 0;
  return true;
}

// uses directly the buffer in the memory stream.
static bool fill_pads(int sno, int sno0, int total, format_info *fg USES_REGS) {
  int nfillers, fill_space, lfill_space, nchars;
  int (*f_putc)(int, int);
  const char *buf;
  int phys_end;

  f_putc = GLOBAL_Stream[sno0].stream_putc;
#if MAY_WRITE
  if (fflush(GLOBAL_Stream[sno].file) == 0) {
    buf = GLOBAL_Stream[sno].nbuf;
    phys_end = ftell(GLOBAL_Stream[sno].file);
  } else
    return false;
#else
  buf = GLOBAL_Stream[sno].u.mem_string.buf;
  phys_end = GLOBAL_Stream[sno].u.mem_string.pos;
#endif
  if (fg->gapi == 0) {
    fg->gap[0].phys = phys_end;
    fg->gap[0].filler = ' ';
    fg->gapi = 1;
  }
  nchars = total - GLOBAL_Stream[sno].linepos;
  if (nchars < 0)
    nchars = 0; /* ignore */
  nfillers = fg->gapi;
  fill_space = nchars / nfillers;
  lfill_space = nchars % nfillers;

  int i = fg->phys_start;
  gap_t *padi = fg->gap;
  while (i < phys_end) {
    if (i == padi->phys) {
      int j;
      for (j = 0; j < fill_space; j++)
        f_putc(sno0, padi->filler);
      padi++;
      /* last gap??*/
      if (padi - fg->gap == fg->gapi) {
        for (j = 0; j < fill_space; j++)
          f_putc(sno0, (padi - 1)->filler);
      }
    }
    f_putc(sno0, buf[i++]);
  }
  // final gap
  if (i == padi->phys) {
    int j;
    for (j = 0; j < fill_space + lfill_space; j++)
      f_putc(sno0, padi->filler);
  };

#if MAY_WRITE
  rewind(GLOBAL_Stream[sno].file);
  fflush(GLOBAL_Stream[sno0].file);
#else
  GLOBAL_Stream[sno].u.mem_string.pos = 0;
#endif
  GLOBAL_Stream[sno].linecount = 1;
  GLOBAL_Stream[sno].linepos += nchars;
  GLOBAL_Stream[sno].charcount = 0;
  fg->phys_start = 0;
  fg->lstart = GLOBAL_Stream[sno].linepos;
  fg->gapi = 0;
  return true;
}

static int format_print_str(Int sno, Int size, Int has_size, Term args,
                            int (*f_putc)(int, wchar_t)) {
  Term arghd;
  if (IsStringTerm(args)) {
    const unsigned char *pt = UStringOfTerm(args);
    while (*pt && (!has_size || size > 0)) {
      utf8proc_int32_t ch;
      pt += get_utf8(pt, -1, &ch);
    }
  } else {
    while (!has_size || size > 0) {
      if (IsVarTerm(args)) {
        Yap_Error(INSTANTIATION_ERROR, args, "format/2");
        return FALSE;
      } else if (args == TermNil) {
        return TRUE;
      } else if (!IsPairTerm(args)) {
        Yap_Error(TYPE_ERROR_LIST, args, "format/2");
        return FALSE;
      }
      arghd = HeadOfTerm(args);
      args = TailOfTerm(args);
      if (IsVarTerm(arghd)) {
        Yap_Error(INSTANTIATION_ERROR, arghd, "format/2");
        return FALSE;
      } else if (!IsIntTerm(arghd)) {
        Yap_Error(TYPE_ERROR_LIST, arghd, "format/2");
        return FALSE;
      }
      f_putc(sno, (int)IntOfTerm(arghd));
      size--;
    }
  }
  return TRUE;
}

#define FORMAT_COPY_ARGS_ERROR -1
#define FORMAT_COPY_ARGS_OVERFLOW -2

static Int format_copy_args(Term args, Term *targs, Int tsz) {
  Int n = 0;
  while (args != TermNil) {
    if (IsVarTerm(args)) {
      Yap_Error(INSTANTIATION_ERROR, args, "format/2");
      return FORMAT_COPY_ARGS_ERROR;
    }
    if (!IsPairTerm(args)) {
      Yap_Error(TYPE_ERROR_LIST, args, "format/2");
      return FORMAT_COPY_ARGS_ERROR;
    }
    if (n == tsz)
      return FORMAT_COPY_ARGS_OVERFLOW;
    targs[n] = HeadOfTerm(args);
    args = TailOfTerm(args);
    n++;
  }
  return n;
}

static void

format_clean_up(int sno, int sno0, format_info *finf, const unsigned char *fstr,
                const Term *targs) {
  if (sno != sno0) {
    format_synch(sno, sno0, finf);
    Yap_CloseStream(sno);
  }
  if (fstr) {
    free((void *)fstr);
  }
  if (targs)
    Yap_FreeAtomSpace((void *)targs);
}

static Int fetch_index_from_args(Term t) {
  Int i;

  if (IsVarTerm(t))
    return -1;
  if (!IsIntegerTerm(t))
    return -1;
  i = IntegerOfTerm(t);
  if (i < 0)
    return -1;
  return i;
}

static wchar_t base_dig(Int dig, Int ch) {
  if (dig < 10)
    return dig + '0';
  else if (ch == 'r')
    return (dig - 10) + 'a';
  else /* ch == 'R' */
    return (dig - 10) + 'A';
}

#define TMP_STRING_SIZE 1024

static Int doformat(volatile Term otail, volatile Term oargs,
                    int sno0 USES_REGS) {
  char tmp1[TMP_STRING_SIZE], *tmpbase;
  int ch;
  Term mytargs[8], *targs;
  Int tnum, targ;
  const unsigned char *fstr, *fptr;
  Term args;
  Term tail;
  int (*f_putc)(int, wchar_t);
  int sno = sno0;
  jmp_buf format_botch;
  volatile void *old_handler;
  volatile int old_pos;
  format_info finfo;
  Term fmod = CurrentModule;
  bool alloc_fstr = false;

  if (GLOBAL_Stream[sno0].status & InMemory_Stream_f) {
    old_handler = GLOBAL_Stream[sno].u.mem_string.error_handler;
    GLOBAL_Stream[sno].u.mem_string.error_handler = (void *)&format_botch;
    old_pos = GLOBAL_Stream[sno].u.mem_string.pos;
    /* set up an error handler */
    if (setjmp(format_botch)) {
      restore_machine_regs();
      *HR++ = oargs;
      *HR++ = otail;
      if (!Yap_growheap(FALSE, LOCAL_Error_Size, NULL)) {
        Yap_Error(RESOURCE_ERROR_HEAP, otail, "format/2");
        return false;
      }
      oargs = HR[-2];
      otail = HR[-1];
      GLOBAL_Stream[sno].u.mem_string.pos = old_pos;
      HR -= 2;
    }
  } else {
    old_handler = NULL;
  }
  args = oargs;
  tail = otail;
  targ = 0;
  if (IsVarTerm(tail)) {
    Yap_Error(INSTANTIATION_ERROR, tail, "format/2");
    return (FALSE);
  } else if ((fptr = Yap_TextToUTF8Buffer(tail))) {
    fstr = fptr;
    alloc_fstr = true;
  } else {
    Yap_Error(TYPE_ERROR_TEXT, tail, "format/2");
    return false;
  }
  if (IsVarTerm(args)) {
    Yap_Error(INSTANTIATION_ERROR, args, "format/2");
    return FALSE;
  }
  while (IsApplTerm(args) && FunctorOfTerm(args) == FunctorModule) {
    fmod = ArgOfTerm(1, args);
    args = ArgOfTerm(2, args);
    if (IsVarTerm(fmod)) {
      Yap_Error(INSTANTIATION_ERROR, fmod, "format/2");
      return FALSE;
    }
    if (!IsAtomTerm(fmod)) {
      Yap_Error(TYPE_ERROR_ATOM, fmod, "format/2");
      return FALSE;
    }
    if (IsVarTerm(args)) {
      Yap_Error(INSTANTIATION_ERROR, args, "format/2");
      return FALSE;
    }
  }
  if (IsPairTerm(args)) {
    Int tsz = 8;

    targs = mytargs;
    do {
      tnum = format_copy_args(args, targs, tsz);
      if (tnum == FORMAT_COPY_ARGS_ERROR)
        return FALSE;
      else if (tnum == FORMAT_COPY_ARGS_OVERFLOW) {
        if (mytargs != targs) {
          Yap_FreeCodeSpace((char *)targs);
        }
        tsz += 16;
        targs = (Term *)Yap_AllocAtomSpace(tsz * sizeof(Term));
      } else {
        break;
      }
    } while (true);
  } else if (args != TermNil) {
    tnum = 1;
    mytargs[0] = args;
    targs = mytargs;
  } else {
    tnum = 0;
    targs = mytargs;
  }

  // it starts here
  finfo.gapi = 0;
  finfo.phys_start = 0;
  finfo.lstart = 0;
  if (true || !(GLOBAL_Stream[sno].status & InMemory_Stream_f))
    sno = Yap_OpenBufWriteStream(PASS_REGS1);

  f_putc = GLOBAL_Stream[sno0].stream_wputc;
  if (sno == -1) {
    if (!alloc_fstr)
      fstr = NULL;
    if (mytargs == targs) {
      targs = NULL;
    }
    format_clean_up(sno, sno0, &finfo, fstr, targs);
    return false;
  }
  while ((fptr += get_utf8(fptr, -1, &ch)) && ch) {
    Term t = TermNil;
    int has_repeats = false;
    int repeats = 0;

    if (ch == '~') {
      /* start command */
      fptr += get_utf8(fptr, -1, &ch);
      if (ch == '*') {
        fptr += get_utf8(fptr, -1, &ch);
        has_repeats = TRUE;
        if (targ > tnum - 1) {
          goto do_format_control_sequence_error;
        }
        repeats = fetch_index_from_args(targs[targ++]);
        if (repeats == -1)
          goto do_format_control_sequence_error;
      } else if (ch == '`') {
        /* next character is kept as code */
        has_repeats = TRUE;
        fptr += get_utf8(fptr, -1, &repeats);
        fptr += get_utf8(fptr, -1, &ch);
      } else if (ch >= '0' && ch <= '9') {
        has_repeats = TRUE;
        repeats = 0;
        while (ch >= '0' && ch <= '9') {
          repeats = repeats * 10 + (ch - '0');
          fptr += get_utf8(fptr, -1, &ch);
        }
      }
      switch (ch) {
      case 'a':
        /* print an atom */
        if (has_repeats || targ > tnum - 1)
          goto do_format_control_sequence_error;
        t = targs[targ++];
        if (IsVarTerm(t))
          goto do_instantiation_error;
        if (!IsAtomTerm(t))
          goto do_type_atom_error;
        yhandle_t sl = Yap_StartSlots();
        // stream is already locked.
        Yap_plwrite(t, GLOBAL_Stream + sno, 0, Handle_vars_f | To_heap_f,
                    GLOBAL_MaxPriority);
        Yap_CloseSlots(sl);
        break;
      case 'c': {
        Int nch, i;

        if (targ > tnum - 1)
          goto do_format_control_sequence_error;
        t = targs[targ++];
        if (IsVarTerm(t))
          goto do_instantiation_error;
        if (!IsIntegerTerm(t))
          goto do_type_int_error;
        nch = IntegerOfTerm(t);
        if (nch < 0)
          goto do_domain_not_less_zero_error;
        if (!has_repeats)
          repeats = 1;
        for (i = 0; i < repeats; i++)
          f_putc(sno, nch);
        break;
      }
      case 'e':
      case 'E':
      case 'f':
      case 'g':
      case 'G': {
        Float fl;
        char *ptr;
        char fmt[32];

        if (targ > tnum - 1)
          goto do_format_control_sequence_error;
        t = targs[targ++];
        if (IsVarTerm(t))
          goto do_instantiation_error;
        if (!IsNumTerm(t))
          goto do_type_number_error;
        if (IsIntegerTerm(t)) {
          fl = (Float)IntegerOfTerm(t);
#ifdef HAVE_GMP
        } else if (IsBigIntTerm(t)) {
          fl = Yap_gmp_to_float(t);
#endif
        } else {
          fl = FloatOfTerm(t);
        }
        if (!has_repeats)
          repeats = 6;
        fmt[0] = '%';
        fmt[1] = '.';
        ptr = fmt + 2;
#if HAVE_SNPRINTF
        snprintf(ptr, 31 - 5, "%d", repeats);
#else
        sprintf(ptr, "%d", repeats);
#endif
        while (*ptr)
          ptr++;
        ptr[0] = ch;
        ptr[1] = '\0';
        {
          unsigned char *uptr = (unsigned char *)tmp1;
#if HAVE_SNPRINTF
          snprintf(tmp1, repeats + 10, fmt, fl);
#else
          sprintf(tmp1, fmt, fl);
#endif
          while ((uptr += get_utf8(uptr, -1, &ch)) && ch != 0)
            f_putc(sno, ch);
        }
        break;
      case 'd':
      case 'D':
        /* print a decimal, using weird . stuff */
        if (targ > tnum - 1)
          goto do_format_control_sequence_error;
        t = targs[targ++];
        if (IsVarTerm(t))
          goto do_instantiation_error;
        if (!IsIntegerTerm(t)
#ifdef HAVE_GMP
            && !IsBigIntTerm(t)
#endif

                )
          goto do_type_int_error;

        {
          Int siz = 0;
          char *ptr = tmp1;
          tmpbase = tmp1;

          if (IsIntegerTerm(t)) {
            Int il = IntegerOfTerm(t);
#if HAVE_SNPRINTF
            snprintf(tmp1, 256, "%ld", (long int)il);
#else
            sprintf(tmp1, "%ld", (long int)il);
#endif
            siz = strlen(tmp1);
            if (il < 0)
              siz--;
#ifdef HAVE_GMP
          } else if (IsBigIntTerm(t) && RepAppl(t)[1] == BIG_INT) {
            char *res;

            tmpbase = tmp1;

            while (
                !(res = Yap_gmp_to_string(t, tmpbase, TMP_STRING_SIZE, 10))) {
              if (tmpbase == tmp1) {
                tmpbase = NULL;
              } else {
                tmpbase = res;

                goto do_type_int_error;
              }
            }
            tmpbase = res;
            ptr = tmpbase;
#endif
            siz = strlen(tmpbase);
          } else {
            goto do_type_int_error;
          }

          if (tmpbase[0] == '-') {
            f_putc(sno, (int)'-');
            ptr++;
          }
          if (ch == 'D') {
            int first = TRUE;

            while (siz > repeats) {
              if ((siz - repeats) % 3 == 0 && !first) {
                f_putc(sno, (int)',');
              }
              f_putc(sno, (int)(*ptr++));
              first = FALSE;
              siz--;
            }
          } else {
            while (siz > repeats) {
              f_putc(sno, (int)(*ptr++));
              siz--;
            }
          }
          if (repeats) {
            if (ptr == tmpbase || ptr[-1] == '-') {
              f_putc(sno, (int)'0');
            }
            f_putc(sno, (int)'.');
            while (repeats > siz) {
              f_putc(sno, (int)'0');
              repeats--;
            }
            while (repeats) {
              f_putc(sno, (int)(*ptr++));
              repeats--;
            }
          }
          if (tmpbase != tmp1)
            free(tmpbase);
          break;
        case 'r':
        case 'R': {
          Int numb, radix;
          UInt divfactor = 1, size = 1, i;
          wchar_t och;

          /* print a decimal, using weird . stuff */
          if (targ > tnum - 1)
            goto do_format_control_sequence_error;
          t = targs[targ++];
          if (IsVarTerm(t))
            goto do_instantiation_error;
          if (!has_repeats)
            radix = 8;
          else
            radix = repeats;
          if (radix > 36 || radix < 2)
            goto do_domain_error_radix;
#ifdef HAVE_GMP
          if (IsBigIntTerm(t) && RepAppl(t)[1] == BIG_INT) {
            char *pt, *res;

            tmpbase = tmp1;
            while (!(
                res = Yap_gmp_to_string(t, tmpbase, TMP_STRING_SIZE, radix))) {
              if (tmpbase == tmp1) {
                tmpbase = NULL;
              } else {
                tmpbase = res;
                goto do_type_int_error;
              }
            }
            tmpbase = res;
            pt = tmpbase;
            while ((ch = *pt++))
              f_putc(sno, ch);
            if (tmpbase != tmp1)
              free(tmpbase);
            break;
          }
#endif
          if (!IsIntegerTerm(t))
            goto do_type_int_error;
          numb = IntegerOfTerm(t);
          if (numb < 0) {
            numb = -numb;
            f_putc(sno, (int)'-');
          }
          while (numb / divfactor >= radix) {
            divfactor *= radix;
            size++;
          }
          for (i = 1; i < size; i++) {
            Int dig = numb / divfactor;
            och = base_dig(dig, ch);
            f_putc(sno, och);
            numb %= divfactor;
            divfactor /= radix;
          }
          och = base_dig(numb, ch);
          f_putc(sno, och);
          break;
        }
        case 's':
          if (targ > tnum - 1)
            goto do_format_control_sequence_error;
          t = targs[targ++];
          if (IsVarTerm(t))
            goto do_instantiation_error;
          if (!format_print_str(sno, repeats, has_repeats, t, f_putc)) {
            goto do_default_error;
          }
          break;
        case 'i':
          if (targ > tnum - 1 || has_repeats)
            goto do_format_control_sequence_error;
          targ++;
          break;
        case 'k':
          if (targ > tnum - 1 || has_repeats)
            goto do_format_control_sequence_error;
          t = targs[targ++];
          yhandle_t sl = Yap_StartSlots();
          Yap_plwrite(t, GLOBAL_Stream + sno, 0,
                      Quote_illegal_f | Ignore_ops_f | To_heap_f,
                      GLOBAL_MaxPriority);
          Yap_CloseSlots(sl);
          break;
        case '@':
          t = targs[targ++];
          {
            yhandle_t sl0 = Yap_StartSlots(), s1 = Yap_PushHandle(ARG1),
                      sl = Yap_InitSlots(tnum - targ, targs + targ);

            Int res;
            int os = LOCAL_c_output_stream;
            LOCAL_c_output_stream = sno;
            res = Yap_execute_goal(t, 0, fmod, true);
            LOCAL_c_output_stream = os;
            if (Yap_HasException())
              goto ex_handler;
            if (!res) {
              if (!alloc_fstr)
                fstr = NULL;
              if (mytargs == targs) {
                targs = NULL;
              }
              format_clean_up(sno, sno0, &finfo, fstr, targs);
              return false;
            }
            ARG1 = Yap_GetFromHandle(s1);
            Yap_RecoverHandles(sl, tnum - targ);
            Yap_CloseSlots(sl0);
          }
          break;
        case 'p':
          if (targ > tnum - 1 || has_repeats)
            goto do_format_control_sequence_error;
          t = targs[targ++];
          {
            Int sl = Yap_InitSlot(args);
            Yap_plwrite(t, GLOBAL_Stream + sno, 0,
                        Handle_vars_f | Use_portray_f | To_heap_f,
                        GLOBAL_MaxPriority);
            args = Yap_GetFromSlot(sl);
            Yap_CloseSlots(sl);
          }
          if (Yap_HasException()) {

          ex_handler:
            if (tnum <= 8)
              targs = NULL;
            if (IsAtomTerm(tail)) {
              fstr = NULL;
            }
            if (GLOBAL_Stream[sno].status & InMemory_Stream_f) {
              GLOBAL_Stream[sno].u.mem_string.error_handler = old_handler;
            }
            if (!alloc_fstr)
              fstr = NULL;
            if (mytargs == targs) {
              targs = NULL;
            }
            format_clean_up(sno, sno0, &finfo, fstr, targs);
            Yap_RaiseException();
            return false;
          }
          break;
        case 'q':
          if (targ > tnum - 1 || has_repeats)
            goto do_format_control_sequence_error;
          t = targs[targ++];
          yhandle_t sl0 = Yap_StartSlots();
          Yap_plwrite(t, GLOBAL_Stream + sno, 0,
                      Handle_vars_f | Quote_illegal_f | To_heap_f,
                      GLOBAL_MaxPriority);
          Yap_CloseSlots(sl0);
          break;
        case 'w':
          if (targ > tnum - 1 || has_repeats)
            goto do_format_control_sequence_error;
          t = targs[targ++];
          yhandle_t slf = Yap_StartSlots();
          Yap_plwrite(t, GLOBAL_Stream + sno, 0, Handle_vars_f | To_heap_f,
                      GLOBAL_MaxPriority);
          Yap_CloseSlots(slf);
          break;
        case 'W':
          if (targ > tnum - 2 || has_repeats)
            goto do_format_control_sequence_error;
          targ -= 2;
          {
            yhandle_t slf = Yap_StartSlots();
            if (!Yap_WriteTerm(sno, targs[1], targs[0] PASS_REGS)) {
              Yap_CloseSlots(slf);
              goto do_default_error;
            };
            Yap_CloseSlots(slf);
          }
          break;
        case '~':
          if (has_repeats)
            goto do_format_control_sequence_error;
          f_putc(sno, (int)'~');
          break;
        case 'n':
          if (!has_repeats)
            repeats = 1;
          while (repeats--) {
            f_putc(sno, (int)'\n');
          }
          format_synch(sno, sno0, &finfo);
          break;
        case 'N':
          if (!has_repeats)
            has_repeats = 1;
          if (GLOBAL_Stream[sno].linepos != 0) {
            f_putc(sno, '\n');
            format_synch(sno, sno0, &finfo);
          }
          if (repeats > 1) {
            Int i;
            for (i = 1; i < repeats; i++)
              f_putc(sno, '\n');
          }
          format_synch(sno, sno0, &finfo);
          break;
        /* padding */
        case '|':
          fill_pads(sno, sno0, repeats, &finfo PASS_REGS);
          break;
        case '+':
          fill_pads(sno, sno0, finfo.lstart + repeats, &finfo PASS_REGS);
          break;
        case 't': {
#if MAY_WRITE
          if (fflush(GLOBAL_Stream[sno].file) == 0) {
            finfo.gap[finfo.gapi].phys = ftell(GLOBAL_Stream[sno].file);
          }
#else
          finfo.gap[finfo.gapi].phys = GLOBAL_Stream[sno].u.mem_string.pos;
#endif
          finfo.gap[finfo.gapi].log = GLOBAL_Stream[sno].linepos;
          if (has_repeats)
            finfo.gap[finfo.gapi].filler = fptr[-2];
          else
            finfo.gap[finfo.gapi].filler = ' ';
          finfo.gapi++;
        } break;

        do_instantiation_error:
          LOCAL_Error_TYPE = INSTANTIATION_ERROR;
          goto do_default_error;
        do_type_int_error:
          LOCAL_Error_TYPE = TYPE_ERROR_INTEGER;
          goto do_default_error;
        do_type_number_error:
          LOCAL_Error_TYPE = TYPE_ERROR_NUMBER;
          goto do_default_error;
        do_type_atom_error:
          LOCAL_Error_TYPE = TYPE_ERROR_ATOM;
          goto do_default_error;
        do_domain_not_less_zero_error:
          LOCAL_Error_TYPE = DOMAIN_ERROR_NOT_LESS_THAN_ZERO;
          goto do_default_error;
        do_domain_error_radix:
          LOCAL_Error_TYPE = DOMAIN_ERROR_RADIX;
          goto do_default_error;
        do_format_control_sequence_error:
          LOCAL_Error_TYPE = DOMAIN_ERROR_FORMAT_CONTROL_SEQUENCE;
        default:
          LOCAL_Error_TYPE = YAP_NO_ERROR;
        do_default_error:
          if (tnum <= 8)
            targs = NULL;
          if (IsAtomTerm(tail)) {
            fstr = NULL;
          }
          {
            Term ta[2];
            ta[0] = otail;
            ta[1] = oargs;
            Yap_Error(LOCAL_Error_TYPE,
                      Yap_MkApplTerm(Yap_MkFunctor(AtomFormat, 2), 2, ta),
                      "arguments to format");
          }
          if (GLOBAL_Stream[sno].status & InMemory_Stream_f) {
            GLOBAL_Stream[sno].u.mem_string.error_handler = old_handler;
          }
          if (!alloc_fstr)
            fstr = NULL;
          if (mytargs == targs) {
            targs = NULL;
          }
          format_clean_up(sno, sno0, &finfo, fstr, targs);
          LOCAL_Error_TYPE = YAP_NO_ERROR;
          return FALSE;
        }
      }
        /* ok, now we should have a command */
      }
    } else {
      if (ch == '\n') {
        format_synch(sno, sno0, &finfo);
      }
      f_putc(sno, ch);
    }
  }
  //    fill_pads( sno, 0, &finfo);
  if (IsAtomTerm(tail) || IsStringTerm(tail)) {
    fstr = NULL;
  }
  if (tnum <= 8)
    targs = NULL;
  if (GLOBAL_Stream[sno].status & InMemory_Stream_f) {
    GLOBAL_Stream[sno].u.mem_string.error_handler = old_handler;
  }
  if (!alloc_fstr)
    fstr = NULL;
  if (mytargs == targs) {
    targs = NULL;
  }
  format_clean_up(sno, sno0, &finfo, fstr, targs);
  return (TRUE);
}

static Term memStreamToTerm(int output_stream, Functor f, Term inp) {
  const char *s = Yap_MemExportStreamPtr(output_stream);

  encoding_t enc = GLOBAL_Stream[output_stream].encoding;
  if (f == FunctorAtom) {
    return MkAtomTerm(Yap_LookupAtom(s));
  } else if (f == FunctorCodes) {
    return Yap_CharsToDiffListOfCodes(s, ArgOfTerm(2, inp), enc PASS_REGS);
  } else if (f == FunctorCodes1) {
    return Yap_CharsToListOfCodes(s, enc PASS_REGS);
  } else if (f == FunctorChars) {
    return Yap_CharsToDiffListOfAtoms(s, ArgOfTerm(2, inp), enc PASS_REGS);
  } else if (f == FunctorChars1) {
    return Yap_CharsToListOfAtoms(s, enc PASS_REGS);
  } else if (f == FunctorString1) {
    return Yap_CharsToString(s, enc PASS_REGS);
  }
  Yap_Error(DOMAIN_ERROR_FORMAT_OUTPUT, inp, NULL);
  return 0L;
}

/**
 * @pred  with_output_to(+ _Ouput_,: _Goal_)

Run  _Goal_ as once/1, while characters written to the current
output are sent to  _Output_. The predicate was introduced by SWI-Prolog.

 The example below
defines the DCG rule `term/3` to insert a term in the output:

~~~~~
 term(Term, In, Tail) :-
        with_output_to(codes(In, Tail), write(Term)).

?- phrase(term(hello), X).

X = [104, 101, 108, 108, 111]
~~~~~

+ A Stream handle or alias
Temporary switch current output to the given stream. Redirection using
with_output_to/2 guarantees the original output is restored, also if Goal fails
or raises an exception. See also call_cleanup/2.
+ atom(- _Atom_)
Create an atom from the emitted characters.
Applications should generally avoid creating atoms by breaking and
concatenating other atoms as the creation of large numbers of
intermediate atoms puts pressure on the atom table and the data-base. This may
lead to collisions in the hash tables used to implement atoms, and may result in
frequent calls to the garbage collector. In multi-threaded applications, access
to the atom table is controlled by locks. This predicate supports creating the
therms by expanding
difference-list.

+ string(- _String_)
Create a string-object, notice that strings are atomic objects.
+ codes(- _Codes_)
Create a list of character codes from the emitted characters, similar to
atom_codes/2.
+ codes(- _Codes_, - _Tail_)
Create a list of character codes as a difference-list.
+ chars(- _Chars_)
Create a list of one-character-atoms codes from the emitted characters, similar
to atom_chars/2.
+ chars(- _Chars_, - _Tail_)
Create a list of one-character-atoms as a difference-list.

 */
static Int with_output_to(USES_REGS1) {
  int old_out = LOCAL_c_output_stream;
  int output_stream;
  Term tin = Deref(ARG1);
  Functor f;
  bool out;
  bool my_mem_stream;
  yhandle_t hdl = Yap_PushHandle(tin);
  if (IsVarTerm(tin)) {
    Yap_Error(INSTANTIATION_ERROR, tin, "with_output_to/3");
    return false;
  }
  if (IsApplTerm(tin) && (f = FunctorOfTerm(tin)) &&
      (f == FunctorAtom || f == FunctorString || f == FunctorCodes1 ||
       f == FunctorCodes || f == FunctorChars1 || f == FunctorChars)) {
    output_stream = Yap_OpenBufWriteStream(PASS_REGS1);
    my_mem_stream = true;
  } else {
    /* needs to change LOCAL_c_output_stream for write */
    output_stream = Yap_CheckStream(ARG1, Output_Stream_f, "format/3");
    my_mem_stream = false;
    f = NIL;
  }
  if (output_stream == -1) {
    return false;
  }
  UNLOCK(GLOBAL_Stream[output_stream].streamlock);
  out = Yap_Execute(Deref(ARG2) PASS_REGS);
  LOCK(GLOBAL_Stream[output_stream].streamlock);
  LOCAL_c_output_stream = old_out;
  if (my_mem_stream) {
    Term tat;
    Term inp = Yap_GetFromHandle(hdl);
    if (out) {
      tat = memStreamToTerm(output_stream, f, inp);
      out = Yap_unify(tat, ArgOfTerm(1, inp));
    }
    Yap_CloseStream(output_stream);
  }
  return out;
}

static Int format(Term tf, Term tas, Term tout USES_REGS) {
  Int out;
  Functor f;
  int output_stream;
  bool mem_stream = false;

  if (IsVarTerm(tout)) {
    Yap_Error(INSTANTIATION_ERROR, tout, "format/3");
    return false;
  }
  yhandle_t hl = Yap_StartHandles(), yo = Yap_PushHandle(tout);
  if (IsApplTerm(tout) && (f = FunctorOfTerm(tout)) &&
      (f == FunctorAtom || f == FunctorString1 || f == FunctorCodes1 ||
       f == FunctorCodes || f == FunctorChars1 || f == FunctorChars)) {
    output_stream = Yap_OpenBufWriteStream(PASS_REGS1);
    mem_stream = true;
  } else {
    /* needs to change LOCAL_c_output_stream for write */
    output_stream = Yap_CheckStream(tout, Output_Stream_f, "format/3");
  }
  if (output_stream == -1) {
    UNLOCK(GLOBAL_Stream[output_stream].streamlock);
    return false;
  } else {

    out = doformat(tf, tas, output_stream PASS_REGS);

    UNLOCK(GLOBAL_Stream[output_stream].streamlock);
    if (mem_stream) {

      if (out) {
        Term to = Yap_GetFromHandle(yo);
        Term tat = memStreamToTerm(output_stream, f, to);
        if (tat == 0)
          return false;
        out = Yap_unify(tat, ArgOfTerm(1, to));
      }

      Yap_CloseStream(output_stream);
    }
  }
  Yap_CloseHandles(hl);
  return out;
}

/** @pred  format(+ _T_, :ListWithArguments)
 *
 * Print formatted output to the current output stream.
 */
static Int format2(USES_REGS1) { /* 'format'(Stream,Control,Args)          */
  Int res;

  res = doformat(Deref(ARG1), Deref(ARG2), LOCAL_c_output_stream PASS_REGS);
  return res;
}

/** @pred  format(+_Stream_+ _T_, :ListWithArguments)
 *
 * Print formatted output to the stream _Stream_.
 */
static Int format3(USES_REGS1) {
  Int res;
  res = format(Deref(ARG2), Deref(ARG3), Deref(ARG1) PASS_REGS);
  return res;
}

void Yap_InitFormat(void) {
  Yap_InitCPred("format", 2, format2, SyncPredFlag);
  Yap_InitCPred("format", 3, format3, SyncPredFlag);
  Yap_InitCPred("with_output_to", 2, with_output_to, SyncPredFlag);
}

/// @}