cgit.sxemacs.org Git - sxemacs/blob - src/doprnt.c

   1 /* Output like sprintf to a buffer of specified size.
   2    Also takes args differently: pass one pointer to an array of strings
   3    in addition to the format string which is separate.
   4    Copyright (C) 1995 Free Software Foundation, Inc.
   5    Rewritten by mly to use varargs.h.
   6    Rewritten from scratch by Ben Wing (February 1995) for Mule; expanded
   7    to full printf spec.
   8
   9 This file is part of SXEmacs
  10
  11 SXEmacs is free software: you can redistribute it and/or modify
  12 it under the terms of the GNU General Public License as published by
  13 the Free Software Foundation, either version 3 of the License, or
  14 (at your option) any later version.
  15
  16 SXEmacs is distributed in the hope that it will be useful,
  17 but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 GNU General Public License for more details.
  20
  21 You should have received a copy of the GNU General Public License
  22 along with this program.  If not, see <http://www.gnu.org/licenses/>. */
  23
  24
  25 /* Synched up with: Rewritten.  Not in FSF. */
  26
  27 #include <config.h>
  28 #include "lisp.h"
  29
  30 #include "buffer.h"
  31 #include "lstream.h"
  32
  33 static const char *const valid_flags = "-+ #0";
  34 static const char *const valid_converters = "dic" "oxX" "feEgG" "sS" "b"
  35 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP) ||        \
  36         defined HAVE_MPQ && defined WITH_GMP
  37         "ZQ"
  38 #endif
  39 #if defined HAVE_MPF && defined WITH_GMP ||     \
  40         defined HAVE_MPFR && defined WITH_MPFR
  41         "FR"
  42 #endif
  43 #if defined HAVE_PSEUG && defined WITH_PSEUG
  44         "B"
  45 #endif
  46 #if defined HAVE_MPC && defined WITH_MPC ||     \
  47         defined HAVE_PSEUC && defined WITH_PSEUC
  48         "C"
  49 #endif
  50         ;
  51 static const char *const int_converters = "dic";
  52 static const char *const base_converters = "boxX";
  53 static const char *const double_converters = "feEgG";
  54 static const char *const string_converters = "sS";
  55 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP) ||        \
  56         defined HAVE_MPQ && defined WITH_GMP
  57 static const char *const bigz_converters = "ZQ";
  58 #endif
  59 #if defined HAVE_MPF && defined WITH_GMP ||     \
  60         defined HAVE_MPFR && defined WITH_MPFR
  61 static const char *const bigf_converters = "FR";
  62 #endif
  63 #if defined HAVE_PSEUG && defined WITH_PSEUG
  64 static const char *const bigg_converters = "B";
  65 #endif
  66 #if defined HAVE_MPC && defined WITH_MPC ||     \
  67         defined HAVE_PSEUC && defined WITH_PSEUC
  68 static const char *const bigc_converters = "C";
  69 #endif
  70
  71
  72 typedef struct printf_spec_s *printf_spec_t;
  73 typedef struct printf_spec_s printf_spec; /* to make Wing's dynarrs happy */
  74 struct printf_spec_s {
  75         int argnum;             /* which argument does this spec want?  This is
  76                                    one-based: The first argument given is
  77                                    numbered 1, the second is 2, etc.  This is to
  78                                    handle %##$x-type specs. */
  79         int minwidth;
  80         int precision;
  81         bool minus_flag:1;
  82         bool plus_flag:1;
  83         bool space_flag:1;
  84         bool zero_flag:1;
  85         /* print 0x78 instead of just 78 */
  86         bool number_flag:1;
  87         /* prefers 0x-2 to -0x2 */
  88         bool sign_after_hash_flag:1;
  89         /* uses #x2 instead of 0x2 */
  90         bool lisp_reader_syntax:1;
  91         /* group numbers */
  92         bool group_flag:1;
  93         /* short flag */
  94         bool h_flag:1;
  95         /* long flag */
  96         bool l_flag:1;
  97         bool forwarding_precision:1;
  98         /* caching approach */
  99         bool negativep:1;
 100         char converter;         /* converter character or 0 for dummy marker
 101                                    indicating literal text at the end of the
 102                                    specification */
 103         Bytecount text_before;  /* position of the first character of the
 104                                    block of literal text before this spec */
 105         Bytecount text_before_len;      /* length of that text */
 106         char pad_char;          /* char to use for padding */
 107 };
 108
 109 typedef union printf_arg_u printf_arg_t;
 110 typedef union printf_arg_u printf_arg; /* to make Wing's dynarrs happy */
 111 union printf_arg_u {
 112         long l;
 113         unsigned long ul;
 114         double d;
 115         Bufbyte *bp;
 116         Lisp_Object obj;
 117 };
 118
 119 /* We maintain a list of all the % specs in the specification,
 120    along with the offset and length of the block of literal text
 121    before each spec.  In addition, we have a "dummy" spec that
 122    represents all the literal text at the end of the specification.
 123    Its converter is 0. */
 124
 125 typedef struct {
 126         Dynarr_declare(struct printf_spec_s);
 127 } printf_spec_dynarr;
 128
 129 typedef struct {
 130         Dynarr_declare(union printf_arg_u);
 131 } printf_arg_dynarr;
 132
 133 /* Append STRING (of length LEN bytes) to STREAM.
 134    MINLEN is the minimum field width.
 135    If MINUS_FLAG is set, left-justify the string in its field;
 136     otherwise, right-justify.
 137    If ZERO_FLAG is set, pad with 0's; otherwise pad with spaces.
 138    If MAXLEN is non-negative, the string is first truncated on the
 139     right to that many characters.
 140
 141    Note that MINLEN and MAXLEN are Charcounts but LEN is a Bytecount. */
 142
 143 static void
 144 doprnt_1(Lisp_Object stream, const Bufbyte * string, Bytecount len,
 145          Charcount minlen, Charcount maxlen, int minus_flag, int zero_flag)
 146 {
 147         Lstream *lstr = XLSTREAM(stream);
 148         Charcount cclen = bytecount_to_charcount(string, len);
 149         int to_add = minlen - cclen;
 150
 151         /* Padding at beginning to right-justify ... */
 152         if (!minus_flag)
 153                 while (to_add-- > 0)
 154                         Lstream_putc(lstr, zero_flag ? '0' : ' ');
 155
 156         if (0 <= maxlen && maxlen < cclen)
 157                 len = charcount_to_bytecount(string, maxlen);
 158         Lstream_write(lstr, string, len);
 159
 160         /* Padding at end to left-justify ... */
 161         if (minus_flag)
 162                 while (to_add-- > 0)
 163                         Lstream_putc(lstr, zero_flag ? '0' : ' ');
 164 }
 165
 166 static const Bufbyte *parse_off_posnum(const Bufbyte * start,
 167                                        const Bufbyte * end, int *returned_num)
 168 {
 169         Bufbyte arg_convert[100];
 170         REGISTER Bufbyte *arg_ptr = arg_convert;
 171
 172         *returned_num = -1;
 173         while (start != end && isdigit(*start)) {
 174                 if ((size_t) (arg_ptr - arg_convert) >= sizeof(arg_convert) - 1)
 175                         error("Format converter number too large");
 176                 *arg_ptr++ = *start++;
 177         }
 178         *arg_ptr = '\0';
 179         if (arg_convert != arg_ptr)
 180                 *returned_num = atoi((char *)arg_convert);
 181         return start;
 182 }
 183
 184 #define NEXT_ASCII_BYTE(ch)                                             \
 185         do {                                                            \
 186                 if (fmt == fmt_end)                                     \
 187                         error ("Premature end of format string");       \
 188                 ch = *fmt;                                              \
 189                 if (ch >= 0200)                                         \
 190                         error ("Non-ASCII character in format "         \
 191                                "converter spec");                       \
 192                 fmt++;                                                  \
 193         } while (0)
 194
 195 #define RESOLVE_FLAG_CONFLICTS(spec)                            \
 196         do {                                                    \
 197                 if (spec.space_flag && spec.plus_flag)          \
 198                         spec.space_flag = 0;                    \
 199         } while (0)
 200
 201 static printf_spec_dynarr *
 202 parse_doprnt_spec(const Bufbyte * format, Bytecount format_length)
 203 {
 204         const Bufbyte *fmt = format;
 205         const Bufbyte *fmt_end = format + format_length;
 206         printf_spec_dynarr *specs = Dynarr_new(printf_spec);
 207         int prev_argnum = 0;
 208
 209         while (1) {
 210                 struct printf_spec_s spec;
 211                 const Bufbyte *text_end;
 212                 Bufbyte ch;
 213
 214                 xzero(spec);
 215                 if (fmt == fmt_end) {
 216                         return specs;
 217                 }
 218                 text_end = (Bufbyte *) memchr(fmt, '%', fmt_end - fmt);
 219                 if (!text_end) {
 220                         text_end = fmt_end;
 221                 }
 222                 spec.text_before = fmt - format;
 223                 spec.text_before_len = text_end - fmt;
 224                 spec.pad_char = ' ';
 225                 fmt = text_end;
 226                 if (fmt != fmt_end) {
 227                         fmt++;  /* skip over % */
 228
 229                         /* A % is special -- no arg number.
 230                            According to ANSI specs, field width does
 231                            not apply to %% conversion. */
 232                         if (fmt != fmt_end && *fmt == '%') {
 233                                 spec.converter = '%';
 234                                 Dynarr_add(specs, spec);
 235                                 fmt++;
 236                                 continue;
 237                         }
 238
 239                         /* Is there a field number specifier? */
 240                         {
 241                                 const Bufbyte *ptr;
 242                                 int fieldspec;
 243
 244                                 ptr =
 245                                     parse_off_posnum(fmt, fmt_end, &fieldspec);
 246                                 if (fieldspec > 0 && ptr != fmt_end
 247                                     && *ptr == '$') {
 248                                         /* There is a format specifier */
 249                                         prev_argnum = fieldspec;
 250                                         fmt = ptr + 1;
 251                                 } else
 252                                         prev_argnum++;
 253                                 spec.argnum = prev_argnum;
 254                         }
 255
 256                         /* Parse off any flags */
 257                         do {
 258                                 NEXT_ASCII_BYTE(ch);
 259                                 switch (ch) {
 260                                 case '-':
 261                                         spec.minus_flag = true;
 262                                         break;
 263                                 case '+':
 264                                         spec.plus_flag = true;
 265                                         break;
 266                                 case ' ':
 267                                         spec.space_flag = true;
 268                                         break;
 269                                 case '#':
 270                                         spec.number_flag = true;
 271                                         break;
 272                                 case '&':
 273                                         spec.number_flag = true;
 274                                         spec.lisp_reader_syntax = true;
 275                                 case '~':
 276                                         spec.sign_after_hash_flag = true;
 277                                         break;
 278                                 case '\'':
 279                                         spec.group_flag = true;
 280                                         break;
 281                                 case '0':
 282                                         spec.zero_flag = true;
 283                                         break;
 284                                 case '!':
 285                                         NEXT_ASCII_BYTE(ch);
 286                                         spec.pad_char = ch;
 287                                         break;
 288                                 case '\000': /* steve's favourite */
 289                                         ch = '\001';
 290                                         break;
 291                                 default:
 292                                         ch = '\000';
 293                                         break;
 294                                 }
 295                         } while (ch);
 296
 297                         /* Parse off the minimum field width */
 298                         fmt--;  /* back up */
 299
 300                         /*
 301                          * * means the field width was passed as an argument.
 302                          * Mark the current spec as one that forwards its
 303                          * field width and flags to the next spec in the array.
 304                          * Then create a new spec and continue with the parsing.
 305                          */
 306                         if (fmt != fmt_end && *fmt == '*') {
 307                                 spec.converter = '*';
 308                                 RESOLVE_FLAG_CONFLICTS(spec);
 309                                 Dynarr_add(specs, spec);
 310                                 spec.argnum = ++prev_argnum;
 311                                 fmt++;
 312                         } else {
 313                                 fmt = parse_off_posnum(fmt, fmt_end,
 314                                                        &spec.minwidth);
 315                                 if (spec.minwidth == -1)
 316                                         spec.minwidth = 0;
 317                         }
 318
 319                         /* Parse off any precision specified */
 320                         NEXT_ASCII_BYTE(ch);
 321                         if (ch == '.') {
 322                                 /*
 323                                  * * means the precision was passed as an argument.
 324                                  * Mark the current spec as one that forwards its
 325                                  * fieldwidth, flags and precision to the next spec in
 326                                  * the array.  Then create a new spec and continue
 327                                  * with the parse.
 328                                  */
 329                                 if (fmt != fmt_end && *fmt == '*') {
 330                                         spec.converter = '*';
 331                                         spec.forwarding_precision = 1;
 332                                         RESOLVE_FLAG_CONFLICTS(spec);
 333                                         Dynarr_add(specs, spec);
 334                                         spec.argnum = ++prev_argnum;
 335                                         fmt++;
 336                                 } else {
 337                                         fmt =
 338                                             parse_off_posnum(fmt, fmt_end,
 339                                                              &spec.precision);
 340                                         if (spec.precision == -1)
 341                                                 spec.precision = 0;
 342                                 }
 343                                 NEXT_ASCII_BYTE(ch);
 344                         } else {
 345                                 /* No precision specified */
 346                                 spec.precision = -1;
 347                         }
 348
 349                         /* Parse off h or l flag */
 350                         if (ch == 'h' || ch == 'l') {
 351                                 if (ch == 'h')
 352                                         spec.h_flag = 1;
 353                                 else
 354                                         spec.l_flag = 1;
 355                                 NEXT_ASCII_BYTE(ch);
 356                         }
 357
 358                         if (!strchr(valid_converters, ch))
 359                                 error("Invalid converter character %c", ch);
 360                         spec.converter = ch;
 361                 }
 362
 363                 RESOLVE_FLAG_CONFLICTS(spec);
 364                 Dynarr_add(specs, spec);
 365         }
 366
 367         RETURN_NOT_REACHED(specs)       /* suppress compiler warning */
 368 }
 369
 370 static int get_args_needed(printf_spec_dynarr *specs)
 371 {
 372         int args_needed = 0;
 373         REGISTER int i;
 374
 375         /* Figure out how many args are needed.  This may be less than
 376            the number of specs because a spec could be %% or could be
 377            missing (literal text at end of format string) or there
 378            could be specs where the field number is explicitly given.
 379            We just look for the maximum argument number that's referenced. */
 380
 381         for (i = 0; i < Dynarr_length(specs); i++) {
 382                 char ch = Dynarr_at(specs, i).converter;
 383                 if (ch && ch != '%') {
 384                         int argnum = Dynarr_at(specs, i).argnum;
 385                         if (argnum > args_needed)
 386                                 args_needed = argnum;
 387                 }
 388         }
 389
 390         return args_needed;
 391 }
 392
 393 static printf_arg_dynarr *
 394 get_doprnt_args(printf_spec_dynarr *specs, va_list vargs)
 395 {
 396         printf_arg_dynarr *args = Dynarr_new(printf_arg);
 397         printf_arg_t arg;
 398         REGISTER int i;
 399         int args_needed = get_args_needed(specs);
 400
 401         xzero(arg);
 402         for (i = 1; i <= args_needed; i++) {
 403                 int j;
 404                 char ch;
 405                 printf_spec_t spec = 0;
 406
 407                 for (j = 0; j < Dynarr_length(specs); j++) {
 408                         spec = Dynarr_atp(specs, j);
 409                         if (spec->argnum == i) {
 410                                 break;
 411                         }
 412                 }
 413
 414                 if (j == Dynarr_length(specs))
 415                         error("No conversion spec for argument %d", i);
 416
 417                 ch = spec->converter;
 418
 419                 if (strchr(int_converters, ch)) {
 420                         if (spec->l_flag)
 421                                 arg.l = va_arg(vargs, long);
 422                         else
 423                                 /* int even if ch == 'c' or spec->h_flag: "the
 424                                    type used in va_arg is supposed to match the
 425                                    actual type **after default promotions**."
 426                                    Hence we read an int, not a short, if
 427                                    spec->h_flag. */
 428                                 arg.l = va_arg(vargs, int);
 429                 } else if (strchr(base_converters, ch)) {
 430                         if (spec->l_flag) {
 431                                 arg.l = va_arg(vargs, int);
 432                         } else {
 433                                 /* unsigned int even if ch == 'c'
 434                                    or spec->h_flag */
 435                                 arg.l = va_arg(vargs, int);
 436                         }
 437                 } else if (strchr(double_converters, ch)) {
 438                         arg.d = va_arg(vargs, double);
 439                 } else if (strchr(string_converters, ch)) {
 440                         arg.bp = va_arg(vargs, Bufbyte *);
 441 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP) ||        \
 442         defined HAVE_MPQ && defined WITH_GMP
 443                 } else if (strchr(bigz_converters, ch)) {
 444                         arg.obj = va_arg(vargs, Lisp_Object);
 445 #endif
 446 #if defined HAVE_MPF && defined WITH_GMP ||     \
 447         defined HAVE_MPFR && defined WITH_MPFR
 448                 } else if (strchr(bigf_converters, ch)) {
 449                         arg.obj = va_arg(vargs, Lisp_Object);
 450 #endif
 451                 } else {
 452                         abort();
 453                 }
 454                 Dynarr_add(args, arg);
 455         }
 456
 457         return args;
 458 }
 459
 460 /* Generate output from a format-spec FORMAT, of length FORMAT_LENGTH.
 461    Output goes in BUFFER, which has room for BUFSIZE bytes.
 462    If the output does not fit, truncate it to fit.
 463    Returns the number of bytes stored into BUFFER.
 464    LARGS or VARGS points to the arguments, and NARGS says how many.
 465    if LARGS is non-zero, it should be a pointer to NARGS worth of
 466    Lisp arguments.  Otherwise, VARGS should be a va_list referring
 467    to the arguments. */
 468
 469
 470 /* we divide the emacs_doprnt_1 into readable chunks */
 471
 472 static void emacs_doprnt_number(
 473         Lisp_Object, const Lisp_Object *,
 474         printf_arg_dynarr *, printf_spec_t, char);
 475
 476
 477 #define DOPRNT_AND_FREE(b, l)                                           \
 478         do {                                                            \
 479                 doprnt_1(stream, b, l, 0, -1, 0, 0);                    \
 480                 xfree(b);                                               \
 481         } while (0)
 482
 483 static inline int
 484 __ulong_to_bit_string(char *p, long unsigned int number)
 485 {
 486         int i, seen_high_order = 0;
 487         char *origp = p;
 488
 489         for (i = ((SIZEOF_LONG * 8) - 1); i >= 0; --i) {
 490                 if (number & 1UL << i) {
 491                         seen_high_order = 1;
 492                         *p++ = '1';
 493                 } else {
 494                         if (seen_high_order) {
 495                                 *p++ = '0';
 496                         }
 497                 }
 498         }
 499         *p = '\0';
 500         return (int)(p - origp);
 501 }
 502
 503 static inline int
 504 __nnaughts(printf_spec_t s, int nlen, int tlen)
 505 {
 506 /* return the number of naughts to insert, given specs S and a
 507  * pure length of the number of NLEN and a overall length of the
 508  * text of TLEN
 509  * the result will always be nonnegative */
 510         int result = 0;
 511
 512         /* trivial case */
 513         if (UNLIKELY(s->precision == 0)) {
 514                 /* nothing */
 515                 ;
 516         } else if (s->precision > 0) {
 517                 if ((result = s->precision - nlen) < 0) {
 518                         result = 0;
 519                 }
 520         } else if (s->zero_flag && !s->minus_flag) {
 521                 /* in this case use s->minwidth */
 522                 if ((result = s->minwidth - tlen) < 0) {
 523                         result = 0;
 524                 }
 525         }
 526         return result;
 527 }
 528
 529 static inline int
 530 __bsize_smZ(printf_spec_t s, EMACS_INT SXE_UNUSED(Z))
 531         __attribute__((always_inline));
 532 static inline int
 533 __bsize_smZ(printf_spec_t s, EMACS_INT SXE_UNUSED(Z))
 534 {
 535         return 32 + s->minwidth + sizeof(long int) *
 536                 /* if binary representation is wanted, use an
 537                  * awful lot more space */
 538                 (s->converter != 'b' ? 3 : 8) + s->precision +
 539                 3 /* for 0x and friends */;
 540 }
 541
 542 #if defined HAVE_MPZ && defined WITH_GMP
 543 static inline int
 544 __bsize_Z(printf_spec_t s, bigz Z)
 545         __attribute__((always_inline));
 546 static inline int
 547 __bsize_Z(printf_spec_t s, bigz Z)
 548 {
 549         size_t ms;
 550
 551         switch (s->converter) {
 552         default:
 553                 ms = mpz_sizeinbase(Z, 10);
 554                 break;
 555         case 'x':
 556         case 'X':
 557                 ms = mpz_sizeinbase(Z, 16);
 558                 break;
 559         case 'o':
 560                 ms = mpz_sizeinbase(Z, 8);
 561                 break;
 562         case 'b':
 563                 ms = mpz_sizeinbase(Z, 2);
 564                 break;
 565         }
 566         if ((long int)ms < s->minwidth) {
 567                 return 32 + s->minwidth + s->precision +
 568                         3 /* for 0x and friends */;
 569         } else {
 570                 return 32 + ms + s->precision + 3;
 571         }
 572 }
 573
 574 static inline int
 575 __bsize_Q(printf_spec_t s, bigq Q)
 576         __attribute__((always_inline));
 577 static inline int
 578 __bsize_Q(printf_spec_t s, bigq Q)
 579 {
 580         size_t ms;
 581         int base;
 582
 583         switch (s->converter) {
 584         default:
 585                 base = 10;
 586                 break;
 587         case 'x':
 588         case 'X':
 589                 base = 16;
 590                 break;
 591         case 'o':
 592                 base = 8;
 593                 break;
 594         case 'b':
 595                 base = 2;
 596                 break;
 597         }
 598         ms = mpz_sizeinbase(mpq_numref(Q), base)
 599                 + mpz_sizeinbase(mpq_denref(Q), base) + 3;
 600
 601         if ((long int)ms < s->minwidth) {
 602                 return 32 + s->minwidth + s->precision +
 603                         3 /* for 0x and friends */;
 604         } else {
 605                 return 32 + ms + s->precision + 3;
 606         }
 607 }
 608 #endif  /* HAVE_MPZ && HAVE_GMP */
 609
 610 #define __assign_sign_Z(s, p)                           \
 611         do {                                            \
 612                 if (s->negativep) {                     \
 613                         *(p)++ = '-';                   \
 614                 } else if (s->plus_flag) {              \
 615                         *(p)++ = '+';                   \
 616                 } else if (s->space_flag &&             \
 617                            !s->lisp_reader_syntax) {    \
 618                         *(p)++ = ' ';                   \
 619                 }                                       \
 620         } while (0)
 621
 622 static inline int
 623 __postproc2(printf_spec_t s, char *restrict, size_t, size_t)
 624         __attribute__((always_inline));
 625 static inline int
 626 __postproc2(printf_spec_t s, char *restrict text, size_t text_len, size_t allsz)
 627 {
 628         int nnaughts = 0, num_len = text_len;
 629         int ini_len = 0, pre_len = 0, post_len = 0;
 630         char *restrict num, *restrict ini, *restrict pre, *restrict post;
 631         bool base_conv = (strchr(base_converters, s->converter) != NULL);
 632
 633         /* determine how much stuff to put in front */
 634         if (base_conv && s->number_flag) {
 635                 ini_len = 2;
 636         }
 637         if (s->negativep || s->plus_flag ||
 638             (s->space_flag && !s->lisp_reader_syntax)) {
 639                 ini_len++;
 640         }
 641         /* determine the number of zeroes */
 642         text_len = num_len + ini_len;
 643         text_len += (nnaughts = __nnaughts(s, num_len, text_len));
 644
 645         if ((long int)text_len < s->minwidth) {
 646                 if (s->minus_flag) {
 647                         post_len = s->minwidth - num_len;
 648                 } else {
 649                         pre_len = s->minwidth - text_len;
 650                 }
 651                 text_len = s->minwidth;
 652         }
 653
 654         /* move the number to the final location */
 655         pre = text + pre_len;
 656         ini = pre + ini_len;
 657         num = ini + nnaughts;
 658         post = num + num_len;
 659         memmove(num, text, num_len);
 660
 661         /* put `-' or  */
 662         if (LIKELY(!s->sign_after_hash_flag)) {
 663                 __assign_sign_Z(s, pre);
 664         }
 665
 666         /* this 0x stuff */
 667         if (base_conv && s->number_flag) {
 668                 if (LIKELY(!s->lisp_reader_syntax)) {
 669                         *pre++ = '0';
 670                 } else {
 671                         *pre++ = '#';
 672                 }
 673                 /* the idea behind that is to just swap the
 674                  * leading zero with a # et voila the number
 675                  * can be read in again
 676                  */
 677                 switch (s->converter) {
 678                 case 'o':
 679                         *pre++ = 'o';
 680                         break;
 681                 case 'x':
 682                 case 'X':
 683                         *pre++ = 'x';
 684                         break;
 685                 case 'b':
 686                         *pre++ = 'b';
 687                         break;
 688                 default:
 689                         /* unknown */
 690                         *pre++ = 'u';
 691                         break;
 692                 }
 693         }
 694
 695         if (UNLIKELY(s->sign_after_hash_flag)) {
 696                 __assign_sign_Z(s, pre);
 697         }
 698
 699         /* we pad with zeroes before the number, if desired */
 700         if (nnaughts > 0) {
 701                 memset(ini, '0', nnaughts);
 702         }
 703
 704         /* care about s->minwidth, we move the entire immobile block */
 705         if (s->minus_flag) {
 706                 memset(post, s->pad_char, post_len);
 707         } else {
 708                 memset(text, s->pad_char, pre_len);
 709         }
 710         return text_len;
 711 }
 712
 713 static void
 714 emacs_doprnt_smZ(Lisp_Object stream, EMACS_INT Z, printf_spec_t s,  char ch)
 715 {
 716         /* ASCII Decimal representation uses 2.4 times as many
 717            bits as machine binary.  */
 718         char constructed_spec[100];
 719         char *p = constructed_spec;
 720         int alloc_sz = __bsize_smZ(s, Z), text_len = 0;
 721         /* get a chunk of space to load off the result */
 722         /* C99 we need you so badly */
 723         char text[alloc_sz];
 724
 725         *p++ = '%';
 726         *p++ = 'l';     /* use long */
 727         *p++ = ch;
 728         *p++ = '\0';
 729
 730         s->negativep = Z < 0L;
 731         if (ch != 'b' && Z < 0L) {
 732                 /* We cannot simply use sprintf,
 733                  * sprintf would return a two-complement
 734                  * on negative numbers
 735                  * however for further movements we hav to advance
 736                  * cruft_len because that minus char must stay
 737                  * where it is */
 738                 text_len = snprintf(text, alloc_sz, constructed_spec, -Z);
 739         } else if (ch != 'b' /* && Z >= 0L */) {
 740                 text_len = snprintf(text, alloc_sz, constructed_spec, Z);
 741         } else if (ch == 'b' && Z < 0) {
 742                 text_len = __ulong_to_bit_string(text, -Z);
 743         } else /* ch == 'b' */ {
 744                 text_len = __ulong_to_bit_string(text, Z);
 745         }
 746         assert(text_len >= 0 && text_len < alloc_sz);
 747         /* postprocess, move stuff around, insert naughts, etc. */
 748         text_len = __postproc2(s, text, text_len, alloc_sz);
 749
 750         doprnt_1(stream, (Bufbyte*)text, text_len, 0, -1, 0, 0);
 751         return;
 752 }
 753
 754 #if defined(HAVE_MPZ) && defined WITH_GMP
 755 static void
 756 emacs_doprnt_Z(Lisp_Object stream, Lisp_Object obj, printf_spec_t s, char ch)
 757 {
 758         int base;
 759         int alloc_sz = __bsize_Z(s, XBIGZ_DATA(obj)), text_len = 0;
 760         /* get a chunk of space to load off the result */
 761         /* C99 we need you so badly */
 762         char text[alloc_sz];
 763
 764         switch (ch) {
 765         case 'o':
 766                 base = 8;
 767                 break;
 768         case 'x':
 769         case 'X':
 770                 base = 16;
 771                 break;
 772         case 'b':
 773                 base = 2;
 774                 break;
 775         default:
 776                 base = 10;
 777         }
 778
 779         s->negativep = bigz_sign(XBIGZ_DATA(obj)) < 0;
 780         bigz_to_string2(text, XBIGZ_DATA(obj), base);
 781         text_len = strlen(text);
 782
 783         /* special case %X, MPZ does not upcase hex chars,
 784          * so we have to do it here
 785          */
 786         if (ch == 'X') {
 787                 char *q;
 788                 for (q = (char*)text; *q != '\0'; q++) {
 789                         if (strchr("abcdef", *q))
 790                                 *q -= 32;
 791                 }
 792         }
 793
 794         if (!s->negativep) {
 795                 text_len = __postproc2(s, text, text_len, alloc_sz);
 796                 doprnt_1(stream, (Bufbyte*)text, text_len, 0, -1, 0, 0);
 797                 return;
 798         } else {
 799                 text_len = __postproc2(s, text+1, text_len-1, alloc_sz);
 800                 doprnt_1(stream, (Bufbyte*)text+1, text_len, 0, -1, 0, 0);
 801                 return;
 802         }
 803 }
 804
 805 static void
 806 emacs_doprnt_Q(Lisp_Object stream, Lisp_Object obj, printf_spec_t s, char ch)
 807 {
 808         int alloc_sz = __bsize_Q(s, XBIGQ_DATA(obj)), text_len = 0;
 809         /* get a chunk of space to load off the result */
 810         /* C99 we need you so badly */
 811         char text[alloc_sz];
 812
 813         s->negativep = bigq_sign(XBIGQ_DATA(obj)) < 0;
 814         /* the following two are meaningless for rationals */
 815         s->zero_flag = false;
 816         s->precision = -1;
 817         /* dump him */
 818         bigq_to_string2(text, XBIGQ_DATA(obj), 10);
 819         text_len = strlen(text);
 820
 821         /* special case %X, MPZ does not upcase hex chars,
 822          * so we have to do it here
 823          */
 824         if (ch == 'X') {
 825                 char *q;
 826                 for (q = (char*)text; *q != '\0'; q++) {
 827                         if (strchr("abcdef", *q))
 828                                 *q -= 32;
 829                 }
 830         }
 831
 832         if (!s->negativep) {
 833                 text_len = __postproc2(s, text, text_len, alloc_sz);
 834                 doprnt_1(stream, (Bufbyte*)text, text_len, 0, -1, 0, 0);
 835                 return;
 836         } else {
 837                 text_len = __postproc2(s, text+1, text_len-1, alloc_sz);
 838                 doprnt_1(stream, (Bufbyte*)text+1, text_len, 0, -1, 0, 0);
 839                 return;
 840         }
 841 }
 842 #endif  /* HAVE_MPZ && WITH_GMP */
 843
 844 static void
 845 emacs_doprnt_number(Lisp_Object stream,
 846                     const Lisp_Object *largs,
 847                     printf_arg_dynarr *args,
 848                     printf_spec_t spec,
 849                     char ch)
 850 {
 851         /* Must be a number. */
 852         printf_arg_t arg;
 853         Lisp_Object obj;
 854
 855         if (!largs) {
 856                 arg = Dynarr_at(args, spec->argnum - 1);
 857                 obj = Qnil;
 858         } else {
 859                 obj = largs[spec->argnum - 1];
 860                 if (CHARP(obj))
 861                         obj = make_int(XCHAR(obj));
 862                 if (MARKERP(obj))
 863                         obj = make_int(marker_position(obj));
 864         }
 865
 866         if (!NUMBERP(obj) && !NILP(obj)) {
 867                 error("format specifier %%%c "
 868                       "doesn't match argument type", ch);
 869         }
 870
 871         if (NILP(obj)) {
 872
 873         } else if (ch == 'c') {
 874                 /* always convert to int if we deal with characters */
 875                 obj = Fcoerce_number(obj, Qint, Qnil);
 876
 877         } else if (strchr(int_converters, ch) && (ch != 'c')) {
 878                 obj = Fcoerce_number(obj, Qinteger, Qnil);
 879
 880         } else if (strchr(base_converters, ch)) {
 881                 /* must that really be int?
 882                  * The ENT libraries have support for printing floats
 883                  * or fractions in hex and octal
 884                  */
 885                 obj = Fcoerce_number(obj, Qinteger, Qnil);
 886
 887         } else if (strchr(double_converters, ch)) {
 888                 obj = Fcoerce_number(obj, Qfloat, Qnil);
 889
 890 #if defined(HAVE_MPZ) && (defined WITH_GMP || defined WITH_MP)
 891         } else if (ch == 'Z') {
 892                 obj = Fcoerce_number(obj, Qbigz, Qnil);
 893
 894 #endif /* HAVE_MPZ */
 895 #if defined(HAVE_MPQ) && defined WITH_GMP
 896         } else if (ch == 'Q') {
 897                 obj = Fcoerce_number(obj, Qbigq, Qnil);
 898
 899 #endif /* HAVE_MPQ */
 900 #if defined(HAVE_MPFR) && defined WITH_MPFR
 901         } else if (ch == 'F') {
 902                 obj = Fcoerce_number(obj, Qbigfr, Qnil);
 903
 904 #elif defined(HAVE_MPF) && defined WITH_GMP
 905         } else if (ch == 'F') {
 906                 obj = Fcoerce_number(obj, Qbigf, Qnil);
 907
 908 #endif /* HAVE_MPFR || HAVE_MPF */
 909 #if defined(HAVE_MPFR) && defined WITH_MPFR ||  \
 910         defined(HAVE_MPF) && defined WITH_GMP
 911         } else if (ch == 'R') {
 912                 obj = Fcoerce_number(obj, Qreal, Qnil);
 913
 914                 if (FLOATP(obj)) {
 915                         ch = 'f';
 916                 }
 917
 918 #endif
 919 #if defined(HAVE_PSEUG) && defined WITH_PSEUG
 920         } else if (strchr(bigg_converters, ch)) {
 921                 obj = Fcoerce_number(obj, Qbigg, Qnil);
 922
 923 #endif
 924 #if defined HAVE_MPC && defined WITH_MPC ||     \
 925         defined HAVE_PSEUC && defined WITH_PSEUC
 926         } else if (strchr(bigc_converters, ch)) {
 927                 obj = Fcoerce_number(obj, Qbigc, Qnil);
 928
 929 #endif
 930         }
 931
 932         if (0) {
 933                 ;
 934
 935         } else if ((NILP(obj) || INTP(obj)) && ch == 'c') {
 936                 Emchar a;
 937                 Bytecount charlen;
 938                 Bufbyte charbuf[MAX_EMCHAR_LEN];
 939
 940                 if (NILP(obj))
 941                         a = (Emchar)arg.l;
 942                 else
 943                         a = (Emchar)XINT(obj);
 944
 945                 if (!valid_char_p(a))
 946                         error("invalid character value %d to %%c spec", a);
 947
 948                 charlen = set_charptr_emchar(charbuf, a);
 949                 doprnt_1(stream, charbuf, charlen,
 950                          spec->minwidth, -1, spec->minus_flag,
 951                          spec->zero_flag);
 952                 return;
 953
 954         } else if ((NILP(obj) || FLOATP(obj)) &&
 955                    strchr(double_converters, ch)) {
 956
 957                 /* ASCII Decimal representation uses 2.4 times as many
 958                    bits as machine binary.  */
 959                 char *text_to_print;
 960                 char constructed_spec[100];
 961                 char *p = constructed_spec;
 962                 int length, alloca_sz = max_float_print_size;
 963                 int min = spec->minwidth, prec = spec->precision;
 964                 int max_spec = sizeof(constructed_spec);
 965
 966 #if 0
 967                 /* absolute non-sense :O ...
 968                    anyone actually computed the size which is stated here?! */
 969                 alloca_sz =
 970                         32 + max(spec->minwidth,
 971                                  (EMACS_INT)max(sizeof(double), sizeof(long))
 972                                  * 3 + max(spec->precision, 0));
 973 #else
 974                 if (prec < 0)
 975                         prec = 0;
 976                 if (min < 0)
 977                         min = 0;
 978
 979                 if (32+min+prec > alloca_sz)
 980                         alloca_sz = 32 + min + prec;
 981 #endif
 982                 text_to_print = alloca_array(char, alloca_sz);
 983
 984                 /* Mostly reconstruct the spec and use sprintf() to
 985                    format the string. */
 986
 987                 *p++ = '%';
 988                 if (spec->plus_flag)
 989                         *p++ = '+';
 990                 if (spec->space_flag)
 991                         *p++ = ' ';
 992                 if (spec->number_flag)
 993                         *p++ = '#';
 994                 if (spec->minus_flag)
 995                         *p++ = '-';
 996                 if (spec->zero_flag)
 997                         *p++ = '0';
 998
 999                 if (spec->minwidth >= 0) {
1000                         long_to_string(p, spec->minwidth, max_spec);
1001                         max_spec -= strlen(p);
1002                         p += strlen (p);
1003                 }
1004                 if (spec->precision >= 0) {
1005                         *p++ = '.';
1006                         --max_spec;
1007                         long_to_string(p, spec->precision, max_spec);
1008                         max_spec -= strlen(p);
1009                         p += strlen (p);
1010                 }
1011
1012 #if fpfloat_long_double_p
1013                 *p++ = 'L';
1014                 --max_spec;
1015 #endif
1016                 *p++ = ch;
1017                 --max_spec;
1018                 *p++ = '\0';
1019                 --max_spec;
1020                 assert(max_spec >= 0);
1021                 if (NILP(obj))
1022                         length = snprintf(text_to_print, alloca_sz,
1023                                           constructed_spec, arg.d);
1024                 else
1025                         length = snprintf(text_to_print, alloca_sz,
1026                                           constructed_spec, XFLOAT_DATA(obj));
1027
1028                 if (length > alloca_sz) {
1029                         /* should we really silently truncate?! */
1030                         length = alloca_sz;
1031                 }
1032                 doprnt_1(stream, (Bufbyte *)text_to_print, length, 0, -1, 0, 0);
1033                 return;
1034
1035         } else if ((NILP(obj) || INTP(obj)) && (ch != 'c')) {
1036                 EMACS_INT XINTobj;
1037
1038                 if (NILP(obj)) {
1039                         XINTobj = arg.l;
1040                 } else {
1041                         XINTobj = XINT(obj);
1042                 }
1043                 emacs_doprnt_smZ(stream, XINTobj, spec, ch);
1044
1045 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1046         } else if (BIGZP(obj)) {
1047                 emacs_doprnt_Z(stream, obj, spec, ch);
1048 #endif  /* HAVE_MPZ */
1049 #if defined HAVE_MPQ && defined WITH_GMP
1050         } else if (BIGQP(obj)) {
1051                 emacs_doprnt_Q(stream, obj, spec, ch);
1052
1053 #if 0
1054                 Bufbyte *text_to_print;
1055                 int ttp_len;
1056                 int base;
1057
1058                 switch (ch) {
1059                 case 'o':
1060                         base = 8;
1061                         break;
1062                 case 'x':
1063                 case 'X':
1064                         base = 16;
1065                         break;
1066                 case 'b':
1067                         base = 2;
1068                         break;
1069                 default:
1070                         base = 10;
1071                 }
1072
1073                 text_to_print =
1074                         (Bufbyte*)bigq_to_string(XBIGQ_DATA(obj), base);
1075                 ttp_len = strlen((char*)text_to_print);
1076
1077                 /* now maybe print the signed or spaced version */
1078                 if ((spec->plus_flag || spec->space_flag) &&
1079                     (bigq_sign(XBIGQ_DATA(obj))>=0)) {
1080                         XREALLOC_ARRAY(text_to_print, Bufbyte,
1081                                        ttp_len + 1);
1082                         memmove(text_to_print+1, text_to_print, ttp_len);
1083                         ttp_len++;
1084                         if (spec->plus_flag)
1085                                 text_to_print[0] = '+';
1086                         if (spec->space_flag)
1087                                 text_to_print[0] = ' ';
1088                 }
1089
1090                 /* care about spec->minwidth */
1091                 if (ttp_len < spec->minwidth) {
1092                         XREALLOC_ARRAY(text_to_print, Bufbyte, spec->minwidth);
1093                         if (spec->minus_flag)
1094                                 memset(text_to_print+ttp_len, ' ',
1095                                        spec->minwidth-ttp_len);
1096                         else {
1097                                 memmove(text_to_print+spec->minwidth-ttp_len,
1098                                         text_to_print, ttp_len);
1099                                 if (spec->zero_flag && spec->precision <= 0)
1100                                         memset(text_to_print, '0',
1101                                                spec->minwidth-ttp_len);
1102                                 else
1103                                         memset(text_to_print, ' ',
1104                                                spec->minwidth-ttp_len);
1105                         }
1106                         ttp_len = spec->minwidth;
1107                 }
1108
1109                 DOPRNT_AND_FREE(text_to_print, ttp_len);
1110                 return;
1111 #endif
1112 #endif  /* HAVE_MPZ */
1113 #if defined HAVE_MPFR && defined WITH_MPFR
1114         } else if (BIGFRP(obj)) {
1115                 Bufbyte *text_to_print;
1116                 int ttp_len;
1117                 long preradix_len, postradix_len;
1118                 int base;
1119
1120                 switch (ch) {
1121                 case 'o':
1122                         base = 8;
1123                         break;
1124                 case 'x':
1125                 case 'X':
1126                         base = 16;
1127                         break;
1128                 case 'b':
1129                         base = 2;
1130                         break;
1131                 default:
1132                         base = 10;
1133                 }
1134
1135                 text_to_print =
1136                         (Bufbyte*)bigfr_to_string(XBIGFR_DATA(obj), base);
1137                 ttp_len = strlen((char*)text_to_print);
1138
1139                 /* if obj is an infinite point or not-a-number dont care about
1140                  * precision flags,
1141                  * also dont care about space or plus flag since the infinities
1142                  * always carry their sign, and not-a-number cannot have a sign
1143                  */
1144                 if (bigfr_nan_p(XBIGFR_DATA(obj)) ||
1145                     bigfr_inf_p(XBIGFR_DATA(obj))) {
1146                         DOPRNT_AND_FREE(text_to_print, ttp_len);
1147                         return;
1148                 }
1149
1150                 /* examine the lengths of digits before and after
1151                  * the decimal dot
1152                  */
1153                 if ((preradix_len = (long int)
1154                      (void*)strchr((char *)text_to_print, '.'))) {
1155                         preradix_len = preradix_len - (long)text_to_print;
1156                         postradix_len = ttp_len - preradix_len - 1;
1157                 } else {
1158                         preradix_len = ttp_len;
1159                         postradix_len = 0;
1160                 }
1161
1162                 /* now cut unwanted places after the decimal dot */
1163                 if (postradix_len > spec->precision &&
1164                     spec->precision >= 0) {
1165                         text_to_print[ttp_len -
1166                                       postradix_len +
1167                                       spec->precision] = '\0';
1168                         ttp_len = ttp_len - postradix_len + spec->precision;
1169                         if (spec->precision == 0) {
1170                                 text_to_print[ttp_len] = '\0';
1171                                 ttp_len--;
1172                         }
1173
1174                 /* now extend to wanted places after the decimal dot */
1175                 } else if (postradix_len < spec->precision &&
1176                            postradix_len > 0) {
1177                         XREALLOC_ARRAY(text_to_print, Bufbyte,
1178                                        ttp_len - postradix_len +
1179                                        spec->precision);
1180                         text_to_print[preradix_len] = '.';
1181                         memset(text_to_print+ttp_len, '0',
1182                                spec->precision - postradix_len);
1183                         ttp_len = ttp_len - postradix_len + spec->precision;
1184
1185                 /* now extend to wanted places, insert a decimal dot first */
1186                 } else if (postradix_len < spec->precision &&
1187                            postradix_len == 0) {
1188                         XREALLOC_ARRAY(text_to_print, Bufbyte,
1189                                        ttp_len + spec->precision + 1);
1190                         text_to_print[preradix_len] = '.';
1191                         memset(text_to_print+preradix_len+1, '0',
1192                                spec->precision);
1193                         ttp_len = ttp_len + spec->precision + 1;
1194                 }
1195
1196                 /* now maybe print the signed or spaced version */
1197                 if ((spec->plus_flag || spec->space_flag) &&
1198                     (bigfr_sign(XBIGFR_DATA(obj))>=0)) {
1199                         XREALLOC_ARRAY(text_to_print, Bufbyte,
1200                                        ttp_len + 1);
1201                         memmove(text_to_print+1, text_to_print, ttp_len);
1202                         ttp_len++;
1203                         if (spec->plus_flag)
1204                                 text_to_print[0] = '+';
1205                         if (spec->space_flag)
1206                                 text_to_print[0] = ' ';
1207                 }
1208
1209                 /* care about spec->minwidth */
1210                 if (ttp_len < spec->minwidth) {
1211                         XREALLOC_ARRAY(text_to_print, Bufbyte, spec->minwidth);
1212                         if (spec->minus_flag)
1213                                 memset(text_to_print+ttp_len, ' ',
1214                                        spec->minwidth-ttp_len);
1215                         else {
1216                                 memmove(text_to_print+spec->minwidth-ttp_len,
1217                                         text_to_print, ttp_len);
1218                                 if (spec->zero_flag && spec->precision <= 0)
1219                                         memset(text_to_print, '0',
1220                                                spec->minwidth-ttp_len);
1221                                 else
1222                                         memset(text_to_print, ' ',
1223                                                spec->minwidth-ttp_len);
1224                         }
1225                         ttp_len = spec->minwidth;
1226                 }
1227
1228                 DOPRNT_AND_FREE(text_to_print, ttp_len);
1229                 return;
1230 #endif  /* HAVE_MPFR */
1231 #if defined HAVE_PSEUG && defined WITH_PSEUG
1232         } else if (BIGGP(obj)) {
1233
1234                 int old_argnum, old_plus_flag, old_space_flag;
1235                 Lisp_Object *modobj = alloca_array(Lisp_Object, 1);
1236
1237                 /* Actually, %a.bB is a rewrite for %a.bd%+a.bd */
1238
1239                 old_argnum = spec->argnum;
1240                 old_plus_flag = spec->plus_flag;
1241                 old_space_flag = spec->space_flag;
1242
1243                 /* rewrite the real part */
1244                 spec->argnum = 1;
1245                 modobj[0] = Freal_part(obj);
1246                 emacs_doprnt_number(stream, modobj, args, spec, 'Z');
1247
1248                 /* rewrite the imaginary part */
1249                 spec->argnum = 1;
1250                 spec->plus_flag = 1;
1251                 spec->space_flag = 0;
1252                 modobj[0] = Fimaginary_part(obj);
1253                 emacs_doprnt_number(stream, modobj, args, spec, 'Z');
1254                 /* print the imaginary unit now */
1255                 doprnt_1(stream, (Bufbyte*)"i", 1, 1, -1, 0, 0);
1256
1257                 spec->argnum = old_argnum;
1258                 spec->plus_flag = old_plus_flag;
1259                 spec->space_flag = old_space_flag;
1260                 return;
1261 #endif  /* HAVE_PSEUG */
1262 #if defined HAVE_MPC && defined WITH_MPC ||     \
1263         defined HAVE_PSEUC && defined WITH_PSEUC
1264         } else if (BIGCP(obj)) {
1265
1266                 int old_argnum, old_plus_flag, old_space_flag;
1267                 Lisp_Object *modobj = alloca_array(Lisp_Object, 1);
1268
1269                 /* Actually, %a.bC is a rewrite for %a.bF%+a.bF */
1270
1271                 old_argnum = spec->argnum;
1272                 old_plus_flag = spec->plus_flag;
1273                 old_space_flag = spec->space_flag;
1274
1275                 /* rewrite the real part */
1276                 spec->argnum = 1;
1277                 modobj[0] = Freal_part(obj);
1278                 emacs_doprnt_number(stream, modobj, args, spec, 'F');
1279
1280                 /* rewrite the imaginary part */
1281                 spec->argnum = 1;
1282                 spec->plus_flag = 1;
1283                 spec->space_flag = 0;
1284                 modobj[0] = Fimaginary_part(obj);
1285                 emacs_doprnt_number(stream, modobj, args, spec, 'F');
1286                 /* print the imaginary unit now */
1287                 doprnt_1(stream, (Bufbyte*)"i", 1, 1, -1, 0, 0);
1288
1289                 spec->argnum = old_argnum;
1290                 spec->plus_flag = old_plus_flag;
1291                 spec->space_flag = old_space_flag;
1292                 return;
1293 #endif  /* HAVE_MPC */
1294         }
1295 }
1296
1297
1298 static Bytecount
1299 emacs_doprnt_1(Lisp_Object stream, const Bufbyte * format_nonreloc,
1300                Lisp_Object format_reloc, Bytecount format_length, int nargs,
1301                /* #### Gag me, gag me, gag me */
1302                const Lisp_Object * largs, va_list vargs)
1303 {
1304         printf_spec_dynarr *specs = 0;
1305         printf_arg_dynarr *args = 0;
1306         REGISTER int i;
1307         int init_byte_count = Lstream_byte_count(XLSTREAM(stream));
1308
1309         if (!NILP(format_reloc)) {
1310                 format_nonreloc = XSTRING_DATA(format_reloc);
1311                 format_length = XSTRING_LENGTH(format_reloc);
1312         }
1313         if (format_length < 0)
1314                 format_length =
1315                     (Bytecount) strlen((const char *)format_nonreloc);
1316
1317         specs = parse_doprnt_spec(format_nonreloc, format_length);
1318
1319         if (largs) {
1320                 /* allow too many args for string, but not too few */
1321                 if (nargs < get_args_needed(specs))
1322                         signal_error(Qwrong_number_of_arguments,
1323                                      list3(Qformat,
1324                                            make_int(nargs),
1325                                            !NILP(format_reloc) ? format_reloc :
1326                                            make_string(format_nonreloc,
1327                                                        format_length)));
1328         } else {
1329                 args = get_doprnt_args(specs, vargs);
1330         }
1331
1332         for (i = 0; i < Dynarr_length(specs); i++) {
1333                 printf_spec_t spec = Dynarr_atp(specs, i);
1334                 char ch;
1335
1336                 /* Copy the text before */
1337                 if (!NILP(format_reloc))        /* refetch in case of GC below */
1338                         format_nonreloc = XSTRING_DATA(format_reloc);
1339
1340                 doprnt_1(stream, format_nonreloc + spec->text_before,
1341                          spec->text_before_len, 0, -1, 0, 0);
1342
1343                 ch = spec->converter;
1344
1345                 if (!ch)
1346                         continue;
1347
1348                 if (ch == '%') {
1349                         doprnt_1(stream, (Bufbyte *) & ch, 1, 0, -1, 0, 0);
1350                         continue;
1351                 }
1352
1353                 /* The char '*' as converter means the field width, precision
1354                    was specified as an argument.  Extract the data and forward
1355                    it to the next spec, to which it will apply.  */
1356                 if (ch == '*') {
1357                         printf_spec_t nextspec = Dynarr_atp(specs, i + 1);
1358                         Lisp_Object obj = largs[spec->argnum - 1];
1359
1360                         if (INTP(obj)) {
1361                                 if (spec->forwarding_precision) {
1362                                         nextspec->precision = XINT(obj);
1363                                         nextspec->minwidth = spec->minwidth;
1364                                 } else {
1365                                         nextspec->minwidth = XINT(obj);
1366                                         if (XINT(obj) < 0) {
1367                                                 spec->minus_flag = 1;
1368                                                 nextspec->minwidth =
1369                                                     -nextspec->minwidth;
1370                                         }
1371                                 }
1372                                 nextspec->minus_flag = spec->minus_flag;
1373                                 nextspec->plus_flag = spec->plus_flag;
1374                                 nextspec->space_flag = spec->space_flag;
1375                                 nextspec->number_flag = spec->number_flag;
1376                                 nextspec->zero_flag = spec->zero_flag;
1377                         }
1378                         continue;
1379                 }
1380
1381                 if (largs && (spec->argnum < 1 || spec->argnum > nargs))
1382                         error("Invalid repositioning argument %d",
1383                               spec->argnum);
1384
1385                 else if (ch == 'S' || ch == 's') {
1386                         Bufbyte *string;
1387                         Bytecount string_len;
1388
1389                         if (!largs) {
1390                                 string = Dynarr_at(args, spec->argnum - 1).bp;
1391                                 /* error() can be called with null string
1392                                    arguments.  E.g., in fileio.c, the return
1393                                    value of strerror() is never checked.  We'll
1394                                    print (null), like some printf
1395                                    implementations do.  Would it be better (and
1396                                    safe) to signal an error instead?  Or should
1397                                    we just use the empty string?
1398                                    -dkindred@cs.cmu.edu 8/1997
1399                                  */
1400                                 if (!string)
1401                                         string = (Bufbyte *) "(null)";
1402                                 string_len = strlen((char *)string);
1403                         } else {
1404                                 Lisp_Object obj = largs[spec->argnum - 1];
1405                                 Lisp_String *ls;
1406
1407                                 if (ch == 'S') {
1408                                         /* For `S', prin1 the argument and
1409                                          * then treat like a string.
1410                                          */
1411                                         Lisp_Object tmp =
1412                                                 Fprin1_to_string(obj, Qnil);
1413                                         ls = XSTRING(tmp);
1414                                 } else if (STRINGP(obj)) {
1415                                         ls = XSTRING(obj);
1416                                 } else if (SYMBOLP(obj)) {
1417                                         ls = XSYMBOL(obj)->name;
1418                                 } else {
1419                                         /* convert to string using princ. */
1420                                         Lisp_Object tmp =
1421                                                 Fprin1_to_string(obj, Qt);
1422                                         ls = XSTRING(tmp);
1423                                 }
1424                                 string = string_data(ls);
1425                                 string_len = string_length(ls);
1426                         }
1427
1428                         doprnt_1(stream, string, string_len, spec->minwidth,
1429                                  spec->precision, spec->minus_flag,
1430                                  spec->zero_flag);
1431                 } else {
1432                         /* Must be a number. */
1433                         emacs_doprnt_number(stream, largs, args, spec, ch);
1434                 }
1435         }
1436
1437         /* #### will not get freed if error */
1438         if (specs)
1439                 Dynarr_free(specs);
1440         if (args)
1441                 Dynarr_free(args);
1442         return Lstream_byte_count(XLSTREAM(stream)) - init_byte_count;
1443 }
1444
1445 /* You really don't want to know why this is necessary... */
1446 static Bytecount
1447 emacs_doprnt_2(Lisp_Object stream, const Bufbyte * format_nonreloc,
1448                Lisp_Object format_reloc, Bytecount format_length, int nargs,
1449                const Lisp_Object * largs, ...)
1450 {
1451         va_list vargs;
1452         Bytecount val;
1453         va_start(vargs, largs);
1454         val = emacs_doprnt_1(stream, format_nonreloc, format_reloc,
1455                              format_length, nargs, largs, vargs);
1456         va_end(vargs);
1457         return val;
1458 }
1459
1460 /*********************** external entry points ***********************/
1461
1462 #ifdef I18N3
1463   /* A note about I18N3 translating: the format string should get
1464      translated, but not under all circumstances.  When the format
1465      string is a Lisp string, what should happen is that Fformat()
1466      should format the untranslated args[0] and return that, and also
1467      call Fgettext() on args[0] and, if that is different, format it
1468      and store it in the `string-translatable' property of
1469      the returned string.  See Fgettext(). */
1470 #endif
1471
1472 /* Send formatted output to STREAM.  The format string comes from
1473    either FORMAT_NONRELOC (of length FORMAT_LENGTH; -1 means use
1474    strlen() to determine the length) or from FORMAT_RELOC, which
1475    should be a Lisp string.  Return the number of bytes written
1476    to the stream.
1477
1478    DO NOT pass the data from a Lisp string as the FORMAT_NONRELOC
1479    parameter, because this function can cause GC. */
1480
1481 Bytecount
1482 emacs_doprnt_c(Lisp_Object stream, const Bufbyte * format_nonreloc,
1483                Lisp_Object format_reloc, Bytecount format_length, ...)
1484 {
1485         int val;
1486         va_list vargs;
1487
1488         va_start(vargs, format_length);
1489         val = emacs_doprnt_1(stream, format_nonreloc, format_reloc,
1490                              format_length, 0, 0, vargs);
1491         va_end(vargs);
1492         return val;
1493 }
1494
1495 /* Like emacs_doprnt_c but the args come in va_list format. */
1496
1497 Bytecount
1498 emacs_doprnt_va(Lisp_Object stream, const Bufbyte * format_nonreloc,
1499                 Lisp_Object format_reloc, Bytecount format_length,
1500                 va_list vargs)
1501 {
1502         return emacs_doprnt_1(stream, format_nonreloc, format_reloc,
1503                               format_length, 0, 0, vargs);
1504 }
1505
1506 /* Like emacs_doprnt_c but the args are Lisp objects instead of
1507    C arguments.  This causes somewhat different behavior from
1508    the above two functions (which should act like printf).
1509    See `format' for a description of this behavior. */
1510
1511 Bytecount
1512 emacs_doprnt_lisp(Lisp_Object stream, const Bufbyte * format_nonreloc,
1513                   Lisp_Object format_reloc, Bytecount format_length,
1514                   int nargs, const Lisp_Object * largs)
1515 {
1516         return emacs_doprnt_2(stream, format_nonreloc, format_reloc,
1517                               format_length, nargs, largs);
1518 }
1519
1520 /* Like the previous function but takes a variable number of arguments. */
1521
1522 Bytecount
1523 emacs_doprnt_lisp_2(Lisp_Object stream, const Bufbyte * format_nonreloc,
1524                     Lisp_Object format_reloc, Bytecount format_length,
1525                     int nargs, ...)
1526 {
1527         va_list vargs;
1528         int i;
1529         Lisp_Object *foo = alloca_array(Lisp_Object, nargs);
1530
1531         va_start(vargs, nargs);
1532         for (i = 0; i < nargs; i++)
1533                 foo[i] = va_arg(vargs, Lisp_Object);
1534         va_end(vargs);
1535
1536         return emacs_doprnt_2(stream, format_nonreloc, format_reloc,
1537                               format_length, nargs, foo);
1538 }
1539
1540 /* The following four functions work like the above three but
1541    return their output as a Lisp string instead of sending it
1542    to a stream. */
1543
1544 Lisp_Object
1545 emacs_doprnt_string_c(const Bufbyte * format_nonreloc,
1546                       Lisp_Object format_reloc, Bytecount format_length, ...)
1547 {
1548         va_list vargs;
1549         Lisp_Object obj;
1550         Lisp_Object stream = make_resizing_buffer_output_stream();
1551         struct gcpro gcpro1;
1552
1553         GCPRO1(stream);
1554         va_start(vargs, format_length);
1555         emacs_doprnt_1(stream, format_nonreloc, format_reloc,
1556                        format_length, 0, 0, vargs);
1557         va_end(vargs);
1558         Lstream_flush(XLSTREAM(stream));
1559         obj = make_string(resizing_buffer_stream_ptr(XLSTREAM(stream)),
1560                           Lstream_byte_count(XLSTREAM(stream)));
1561         UNGCPRO;
1562         Lstream_delete(XLSTREAM(stream));
1563         return obj;
1564 }
1565
1566 Lisp_Object
1567 emacs_doprnt_string_va(const Bufbyte * format_nonreloc,
1568                        Lisp_Object format_reloc, Bytecount format_length,
1569                        va_list vargs)
1570 {
1571         /* I'm fairly sure that this function cannot actually GC.
1572            That can only happen when the arguments to emacs_doprnt_1() are
1573            Lisp objects rather than C args. */
1574         Lisp_Object obj;
1575         Lisp_Object stream = make_resizing_buffer_output_stream();
1576         struct gcpro gcpro1;
1577
1578         GCPRO1(stream);
1579         emacs_doprnt_1(stream, format_nonreloc, format_reloc,
1580                        format_length, 0, 0, vargs);
1581         Lstream_flush(XLSTREAM(stream));
1582         obj = make_string(resizing_buffer_stream_ptr(XLSTREAM(stream)),
1583                           Lstream_byte_count(XLSTREAM(stream)));
1584         UNGCPRO;
1585         Lstream_delete(XLSTREAM(stream));
1586         return obj;
1587 }
1588
1589 Lisp_Object
1590 emacs_doprnt_string_lisp(const Bufbyte * format_nonreloc,
1591                          Lisp_Object format_reloc, Bytecount format_length,
1592                          int nargs, const Lisp_Object * largs)
1593 {
1594         Lisp_Object obj;
1595         Lisp_Object stream = make_resizing_buffer_output_stream();
1596         struct gcpro gcpro1;
1597
1598         GCPRO1(stream);
1599         emacs_doprnt_2(stream, format_nonreloc, format_reloc,
1600                        format_length, nargs, largs);
1601         Lstream_flush(XLSTREAM(stream));
1602         obj = make_string(resizing_buffer_stream_ptr(XLSTREAM(stream)),
1603                           Lstream_byte_count(XLSTREAM(stream)));
1604         UNGCPRO;
1605         Lstream_delete(XLSTREAM(stream));
1606         return obj;
1607 }
1608
1609 Lisp_Object
1610 emacs_doprnt_string_lisp_2(const Bufbyte * format_nonreloc,
1611                            Lisp_Object format_reloc, Bytecount format_length,
1612                            int nargs, ...)
1613 {
1614         Lisp_Object obj;
1615         Lisp_Object stream = make_resizing_buffer_output_stream();
1616         struct gcpro gcpro1;
1617         va_list vargs;
1618         int i;
1619         Lisp_Object *foo = alloca_array(Lisp_Object, nargs);
1620
1621         va_start(vargs, nargs);
1622         for (i = 0; i < nargs; i++)
1623                 foo[i] = va_arg(vargs, Lisp_Object);
1624         va_end(vargs);
1625
1626         GCPRO1(stream);
1627         emacs_doprnt_2(stream, format_nonreloc, format_reloc,
1628                        format_length, nargs, foo);
1629         Lstream_flush(XLSTREAM(stream));
1630         obj = make_string(resizing_buffer_stream_ptr(XLSTREAM(stream)),
1631                           Lstream_byte_count(XLSTREAM(stream)));
1632         UNGCPRO;
1633         Lstream_delete(XLSTREAM(stream));
1634         return obj;
1635 }