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 UNUSED(Z))
 531         __attribute__((always_inline));
 532 static inline int
 533 __bsize_smZ(printf_spec_t s, EMACS_INT 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
 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
 965 #if 0
 966                 /* absolute non-sense :O ...
 967                    anyone actually computed the size which is stated here?! */
 968                 alloca_sz =
 969                         32 + max(spec->minwidth,
 970                                  (EMACS_INT)max(sizeof(double), sizeof(long))
 971                                  * 3 + max(spec->precision, 0));
 972 #else
 973                 if (prec < 0)
 974                         prec = 0;
 975                 if (min < 0)
 976                         min = 0;
 977
 978                 if (32+min+prec > alloca_sz)
 979                         alloca_sz = 32 + min + prec;
 980 #endif
 981                 text_to_print = alloca_array(char, alloca_sz);
 982
 983                 /* Mostly reconstruct the spec and use sprintf() to
 984                    format the string. */
 985
 986                 *p++ = '%';
 987                 if (spec->plus_flag)
 988                         *p++ = '+';
 989                 if (spec->space_flag)
 990                         *p++ = ' ';
 991                 if (spec->number_flag)
 992                         *p++ = '#';
 993                 if (spec->minus_flag)
 994                         *p++ = '-';
 995                 if (spec->zero_flag)
 996                         *p++ = '0';
 997
 998                 if (spec->minwidth >= 0) {
 999                         long_to_string(p, spec->minwidth);
1000                         p += strlen (p);
1001                 }
1002                 if (spec->precision >= 0) {
1003                         *p++ = '.';
1004                         long_to_string(p, spec->precision);
1005                         p += strlen (p);
1006                 }
1007
1008 #if fpfloat_long_double_p
1009                 *p++ = 'L';
1010 #endif
1011                 *p++ = ch;
1012                 *p++ = '\0';
1013                 if (NILP(obj))
1014                         length = snprintf(text_to_print, alloca_sz,
1015                                           constructed_spec, arg.d);
1016                 else
1017                         length = snprintf(text_to_print, alloca_sz,
1018                                           constructed_spec, XFLOAT_DATA(obj));
1019
1020                 if (length > alloca_sz)
1021                         length = alloca_sz;
1022
1023                 doprnt_1(stream, (Bufbyte *)text_to_print, length, 0, -1, 0, 0);
1024                 return;
1025
1026         } else if ((NILP(obj) || INTP(obj)) && (ch != 'c')) {
1027                 EMACS_INT XINTobj;
1028
1029                 if (NILP(obj)) {
1030                         XINTobj = arg.l;
1031                 } else {
1032                         XINTobj = XINT(obj);
1033                 }
1034                 emacs_doprnt_smZ(stream, XINTobj, spec, ch);
1035
1036 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1037         } else if (BIGZP(obj)) {
1038                 emacs_doprnt_Z(stream, obj, spec, ch);
1039 #endif  /* HAVE_MPZ */
1040 #if defined HAVE_MPQ && defined WITH_GMP
1041         } else if (BIGQP(obj)) {
1042                 emacs_doprnt_Q(stream, obj, spec, ch);
1043
1044 #if 0
1045                 Bufbyte *text_to_print;
1046                 int ttp_len;
1047                 int base;
1048
1049                 switch (ch) {
1050                 case 'o':
1051                         base = 8;
1052                         break;
1053                 case 'x':
1054                 case 'X':
1055                         base = 16;
1056                         break;
1057                 case 'b':
1058                         base = 2;
1059                         break;
1060                 default:
1061                         base = 10;
1062                 }
1063
1064                 text_to_print =
1065                         (Bufbyte*)bigq_to_string(XBIGQ_DATA(obj), base);
1066                 ttp_len = strlen((char*)text_to_print);
1067
1068                 /* now maybe print the signed or spaced version */
1069                 if ((spec->plus_flag || spec->space_flag) &&
1070                     (bigq_sign(XBIGQ_DATA(obj))>=0)) {
1071                         XREALLOC_ARRAY(text_to_print, Bufbyte,
1072                                        ttp_len + 1);
1073                         memmove(text_to_print+1, text_to_print, ttp_len);
1074                         ttp_len++;
1075                         if (spec->plus_flag)
1076                                 text_to_print[0] = '+';
1077                         if (spec->space_flag)
1078                                 text_to_print[0] = ' ';
1079                 }
1080
1081                 /* care about spec->minwidth */
1082                 if (ttp_len < spec->minwidth) {
1083                         XREALLOC_ARRAY(text_to_print, Bufbyte, spec->minwidth);
1084                         if (spec->minus_flag)
1085                                 memset(text_to_print+ttp_len, ' ',
1086                                        spec->minwidth-ttp_len);
1087                         else {
1088                                 memmove(text_to_print+spec->minwidth-ttp_len,
1089                                         text_to_print, ttp_len);
1090                                 if (spec->zero_flag && spec->precision <= 0)
1091                                         memset(text_to_print, '0',
1092                                                spec->minwidth-ttp_len);
1093                                 else
1094                                         memset(text_to_print, ' ',
1095                                                spec->minwidth-ttp_len);
1096                         }
1097                         ttp_len = spec->minwidth;
1098                 }
1099
1100                 DOPRNT_AND_FREE(text_to_print, ttp_len);
1101                 return;
1102 #endif
1103 #endif  /* HAVE_MPZ */
1104 #if defined HAVE_MPFR && defined WITH_MPFR
1105         } else if (BIGFRP(obj)) {
1106                 Bufbyte *text_to_print;
1107                 int ttp_len;
1108                 long preradix_len, postradix_len;
1109                 int base;
1110
1111                 switch (ch) {
1112                 case 'o':
1113                         base = 8;
1114                         break;
1115                 case 'x':
1116                 case 'X':
1117                         base = 16;
1118                         break;
1119                 case 'b':
1120                         base = 2;
1121                         break;
1122                 default:
1123                         base = 10;
1124                 }
1125
1126                 text_to_print =
1127                         (Bufbyte*)bigfr_to_string(XBIGFR_DATA(obj), base);
1128                 ttp_len = strlen((char*)text_to_print);
1129
1130                 /* if obj is an infinite point or not-a-number dont care about
1131                  * precision flags,
1132                  * also dont care about space or plus flag since the infinities
1133                  * always carry their sign, and not-a-number cannot have a sign
1134                  */
1135                 if (bigfr_nan_p(XBIGFR_DATA(obj)) ||
1136                     bigfr_inf_p(XBIGFR_DATA(obj))) {
1137                         DOPRNT_AND_FREE(text_to_print, ttp_len);
1138                         return;
1139                 }
1140
1141                 /* examine the lengths of digits before and after
1142                  * the decimal dot
1143                  */
1144                 if ((preradix_len = (long int)
1145                      (void*)strchr((char *)text_to_print, '.'))) {
1146                         preradix_len = preradix_len - (long)text_to_print;
1147                         postradix_len = ttp_len - preradix_len - 1;
1148                 } else {
1149                         preradix_len = ttp_len;
1150                         postradix_len = 0;
1151                 }
1152
1153                 /* now cut unwanted places after the decimal dot */
1154                 if (postradix_len > spec->precision &&
1155                     spec->precision >= 0) {
1156                         text_to_print[ttp_len -
1157                                       postradix_len +
1158                                       spec->precision] = '\0';
1159                         ttp_len = ttp_len - postradix_len + spec->precision;
1160                         if (spec->precision == 0) {
1161                                 text_to_print[ttp_len] = '\0';
1162                                 ttp_len--;
1163                         }
1164
1165                 /* now extend to wanted places after the decimal dot */
1166                 } else if (postradix_len < spec->precision &&
1167                            postradix_len > 0) {
1168                         XREALLOC_ARRAY(text_to_print, Bufbyte,
1169                                        ttp_len - postradix_len +
1170                                        spec->precision);
1171                         text_to_print[preradix_len] = '.';
1172                         memset(text_to_print+ttp_len, '0',
1173                                spec->precision - postradix_len);
1174                         ttp_len = ttp_len - postradix_len + spec->precision;
1175
1176                 /* now extend to wanted places, insert a decimal dot first */
1177                 } else if (postradix_len < spec->precision &&
1178                            postradix_len == 0) {
1179                         XREALLOC_ARRAY(text_to_print, Bufbyte,
1180                                        ttp_len + spec->precision + 1);
1181                         text_to_print[preradix_len] = '.';
1182                         memset(text_to_print+preradix_len+1, '0',
1183                                spec->precision);
1184                         ttp_len = ttp_len + spec->precision + 1;
1185                 }
1186
1187                 /* now maybe print the signed or spaced version */
1188                 if ((spec->plus_flag || spec->space_flag) &&
1189                     (bigfr_sign(XBIGFR_DATA(obj))>=0)) {
1190                         XREALLOC_ARRAY(text_to_print, Bufbyte,
1191                                        ttp_len + 1);
1192                         memmove(text_to_print+1, text_to_print, ttp_len);
1193                         ttp_len++;
1194                         if (spec->plus_flag)
1195                                 text_to_print[0] = '+';
1196                         if (spec->space_flag)
1197                                 text_to_print[0] = ' ';
1198                 }
1199
1200                 /* care about spec->minwidth */
1201                 if (ttp_len < spec->minwidth) {
1202                         XREALLOC_ARRAY(text_to_print, Bufbyte, spec->minwidth);
1203                         if (spec->minus_flag)
1204                                 memset(text_to_print+ttp_len, ' ',
1205                                        spec->minwidth-ttp_len);
1206                         else {
1207                                 memmove(text_to_print+spec->minwidth-ttp_len,
1208                                         text_to_print, ttp_len);
1209                                 if (spec->zero_flag && spec->precision <= 0)
1210                                         memset(text_to_print, '0',
1211                                                spec->minwidth-ttp_len);
1212                                 else
1213                                         memset(text_to_print, ' ',
1214                                                spec->minwidth-ttp_len);
1215                         }
1216                         ttp_len = spec->minwidth;
1217                 }
1218
1219                 DOPRNT_AND_FREE(text_to_print, ttp_len);
1220                 return;
1221 #endif  /* HAVE_MPFR */
1222 #if defined HAVE_PSEUG && defined WITH_PSEUG
1223         } else if (BIGGP(obj)) {
1224
1225                 int old_argnum, old_plus_flag, old_space_flag;
1226                 Lisp_Object *modobj = alloca_array(Lisp_Object, 1);
1227
1228                 /* Actually, %a.bB is a rewrite for %a.bd%+a.bd */
1229
1230                 old_argnum = spec->argnum;
1231                 old_plus_flag = spec->plus_flag;
1232                 old_space_flag = spec->space_flag;
1233
1234                 /* rewrite the real part */
1235                 spec->argnum = 1;
1236                 modobj[0] = Freal_part(obj);
1237                 emacs_doprnt_number(stream, modobj, args, spec, 'Z');
1238
1239                 /* rewrite the imaginary part */
1240                 spec->argnum = 1;
1241                 spec->plus_flag = 1;
1242                 spec->space_flag = 0;
1243                 modobj[0] = Fimaginary_part(obj);
1244                 emacs_doprnt_number(stream, modobj, args, spec, 'Z');
1245                 /* print the imaginary unit now */
1246                 doprnt_1(stream, (Bufbyte*)"i", 1, 1, -1, 0, 0);
1247
1248                 spec->argnum = old_argnum;
1249                 spec->plus_flag = old_plus_flag;
1250                 spec->space_flag = old_space_flag;
1251                 return;
1252 #endif  /* HAVE_PSEUG */
1253 #if defined HAVE_MPC && defined WITH_MPC ||     \
1254         defined HAVE_PSEUC && defined WITH_PSEUC
1255         } else if (BIGCP(obj)) {
1256
1257                 int old_argnum, old_plus_flag, old_space_flag;
1258                 Lisp_Object *modobj = alloca_array(Lisp_Object, 1);
1259
1260                 /* Actually, %a.bC is a rewrite for %a.bF%+a.bF */
1261
1262                 old_argnum = spec->argnum;
1263                 old_plus_flag = spec->plus_flag;
1264                 old_space_flag = spec->space_flag;
1265
1266                 /* rewrite the real part */
1267                 spec->argnum = 1;
1268                 modobj[0] = Freal_part(obj);
1269                 emacs_doprnt_number(stream, modobj, args, spec, 'F');
1270
1271                 /* rewrite the imaginary part */
1272                 spec->argnum = 1;
1273                 spec->plus_flag = 1;
1274                 spec->space_flag = 0;
1275                 modobj[0] = Fimaginary_part(obj);
1276                 emacs_doprnt_number(stream, modobj, args, spec, 'F');
1277                 /* print the imaginary unit now */
1278                 doprnt_1(stream, (Bufbyte*)"i", 1, 1, -1, 0, 0);
1279
1280                 spec->argnum = old_argnum;
1281                 spec->plus_flag = old_plus_flag;
1282                 spec->space_flag = old_space_flag;
1283                 return;
1284 #endif  /* HAVE_MPC */
1285         }
1286 }
1287
1288
1289 static Bytecount
1290 emacs_doprnt_1(Lisp_Object stream, const Bufbyte * format_nonreloc,
1291                Lisp_Object format_reloc, Bytecount format_length, int nargs,
1292                /* #### Gag me, gag me, gag me */
1293                const Lisp_Object * largs, va_list vargs)
1294 {
1295         printf_spec_dynarr *specs = 0;
1296         printf_arg_dynarr *args = 0;
1297         REGISTER int i;
1298         int init_byte_count = Lstream_byte_count(XLSTREAM(stream));
1299
1300         if (!NILP(format_reloc)) {
1301                 format_nonreloc = XSTRING_DATA(format_reloc);
1302                 format_length = XSTRING_LENGTH(format_reloc);
1303         }
1304         if (format_length < 0)
1305                 format_length =
1306                     (Bytecount) strlen((const char *)format_nonreloc);
1307
1308         specs = parse_doprnt_spec(format_nonreloc, format_length);
1309
1310         if (largs) {
1311                 /* allow too many args for string, but not too few */
1312                 if (nargs < get_args_needed(specs))
1313                         signal_error(Qwrong_number_of_arguments,
1314                                      list3(Qformat,
1315                                            make_int(nargs),
1316                                            !NILP(format_reloc) ? format_reloc :
1317                                            make_string(format_nonreloc,
1318                                                        format_length)));
1319         } else {
1320                 args = get_doprnt_args(specs, vargs);
1321         }
1322
1323         for (i = 0; i < Dynarr_length(specs); i++) {
1324                 printf_spec_t spec = Dynarr_atp(specs, i);
1325                 char ch;
1326
1327                 /* Copy the text before */
1328                 if (!NILP(format_reloc))        /* refetch in case of GC below */
1329                         format_nonreloc = XSTRING_DATA(format_reloc);
1330
1331                 doprnt_1(stream, format_nonreloc + spec->text_before,
1332                          spec->text_before_len, 0, -1, 0, 0);
1333
1334                 ch = spec->converter;
1335
1336                 if (!ch)
1337                         continue;
1338
1339                 if (ch == '%') {
1340                         doprnt_1(stream, (Bufbyte *) & ch, 1, 0, -1, 0, 0);
1341                         continue;
1342                 }
1343
1344                 /* The char '*' as converter means the field width, precision
1345                    was specified as an argument.  Extract the data and forward
1346                    it to the next spec, to which it will apply.  */
1347                 if (ch == '*') {
1348                         printf_spec_t nextspec = Dynarr_atp(specs, i + 1);
1349                         Lisp_Object obj = largs[spec->argnum - 1];
1350
1351                         if (INTP(obj)) {
1352                                 if (spec->forwarding_precision) {
1353                                         nextspec->precision = XINT(obj);
1354                                         nextspec->minwidth = spec->minwidth;
1355                                 } else {
1356                                         nextspec->minwidth = XINT(obj);
1357                                         if (XINT(obj) < 0) {
1358                                                 spec->minus_flag = 1;
1359                                                 nextspec->minwidth =
1360                                                     -nextspec->minwidth;
1361                                         }
1362                                 }
1363                                 nextspec->minus_flag = spec->minus_flag;
1364                                 nextspec->plus_flag = spec->plus_flag;
1365                                 nextspec->space_flag = spec->space_flag;
1366                                 nextspec->number_flag = spec->number_flag;
1367                                 nextspec->zero_flag = spec->zero_flag;
1368                         }
1369                         continue;
1370                 }
1371
1372                 if (largs && (spec->argnum < 1 || spec->argnum > nargs))
1373                         error("Invalid repositioning argument %d",
1374                               spec->argnum);
1375
1376                 else if (ch == 'S' || ch == 's') {
1377                         Bufbyte *string;
1378                         Bytecount string_len;
1379
1380                         if (!largs) {
1381                                 string = Dynarr_at(args, spec->argnum - 1).bp;
1382                                 /* error() can be called with null string
1383                                    arguments.  E.g., in fileio.c, the return
1384                                    value of strerror() is never checked.  We'll
1385                                    print (null), like some printf
1386                                    implementations do.  Would it be better (and
1387                                    safe) to signal an error instead?  Or should
1388                                    we just use the empty string?
1389                                    -dkindred@cs.cmu.edu 8/1997
1390                                  */
1391                                 if (!string)
1392                                         string = (Bufbyte *) "(null)";
1393                                 string_len = strlen((char *)string);
1394                         } else {
1395                                 Lisp_Object obj = largs[spec->argnum - 1];
1396                                 Lisp_String *ls;
1397
1398                                 if (ch == 'S') {
1399                                         /* For `S', prin1 the argument and
1400                                          * then treat like a string.
1401                                          */
1402                                         Lisp_Object tmp =
1403                                                 Fprin1_to_string(obj, Qnil);
1404                                         ls = XSTRING(tmp);
1405                                 } else if (STRINGP(obj)) {
1406                                         ls = XSTRING(obj);
1407                                 } else if (SYMBOLP(obj)) {
1408                                         ls = XSYMBOL(obj)->name;
1409                                 } else {
1410                                         /* convert to string using princ. */
1411                                         Lisp_Object tmp =
1412                                                 Fprin1_to_string(obj, Qt);
1413                                         ls = XSTRING(tmp);
1414                                 }
1415                                 string = string_data(ls);
1416                                 string_len = string_length(ls);
1417                         }
1418
1419                         doprnt_1(stream, string, string_len, spec->minwidth,
1420                                  spec->precision, spec->minus_flag,
1421                                  spec->zero_flag);
1422                 } else {
1423                         /* Must be a number. */
1424                         emacs_doprnt_number(stream, largs, args, spec, ch);
1425                 }
1426         }
1427
1428         /* #### will not get freed if error */
1429         if (specs)
1430                 Dynarr_free(specs);
1431         if (args)
1432                 Dynarr_free(args);
1433         return Lstream_byte_count(XLSTREAM(stream)) - init_byte_count;
1434 }
1435
1436 /* You really don't want to know why this is necessary... */
1437 static Bytecount
1438 emacs_doprnt_2(Lisp_Object stream, const Bufbyte * format_nonreloc,
1439                Lisp_Object format_reloc, Bytecount format_length, int nargs,
1440                const Lisp_Object * largs, ...)
1441 {
1442         va_list vargs;
1443         Bytecount val;
1444         va_start(vargs, largs);
1445         val = emacs_doprnt_1(stream, format_nonreloc, format_reloc,
1446                              format_length, nargs, largs, vargs);
1447         va_end(vargs);
1448         return val;
1449 }
1450
1451 /*********************** external entry points ***********************/
1452
1453 #ifdef I18N3
1454   /* A note about I18N3 translating: the format string should get
1455      translated, but not under all circumstances.  When the format
1456      string is a Lisp string, what should happen is that Fformat()
1457      should format the untranslated args[0] and return that, and also
1458      call Fgettext() on args[0] and, if that is different, format it
1459      and store it in the `string-translatable' property of
1460      the returned string.  See Fgettext(). */
1461 #endif
1462
1463 /* Send formatted output to STREAM.  The format string comes from
1464    either FORMAT_NONRELOC (of length FORMAT_LENGTH; -1 means use
1465    strlen() to determine the length) or from FORMAT_RELOC, which
1466    should be a Lisp string.  Return the number of bytes written
1467    to the stream.
1468
1469    DO NOT pass the data from a Lisp string as the FORMAT_NONRELOC
1470    parameter, because this function can cause GC. */
1471
1472 Bytecount
1473 emacs_doprnt_c(Lisp_Object stream, const Bufbyte * format_nonreloc,
1474                Lisp_Object format_reloc, Bytecount format_length, ...)
1475 {
1476         int val;
1477         va_list vargs;
1478
1479         va_start(vargs, format_length);
1480         val = emacs_doprnt_1(stream, format_nonreloc, format_reloc,
1481                              format_length, 0, 0, vargs);
1482         va_end(vargs);
1483         return val;
1484 }
1485
1486 /* Like emacs_doprnt_c but the args come in va_list format. */
1487
1488 Bytecount
1489 emacs_doprnt_va(Lisp_Object stream, const Bufbyte * format_nonreloc,
1490                 Lisp_Object format_reloc, Bytecount format_length,
1491                 va_list vargs)
1492 {
1493         return emacs_doprnt_1(stream, format_nonreloc, format_reloc,
1494                               format_length, 0, 0, vargs);
1495 }
1496
1497 /* Like emacs_doprnt_c but the args are Lisp objects instead of
1498    C arguments.  This causes somewhat different behavior from
1499    the above two functions (which should act like printf).
1500    See `format' for a description of this behavior. */
1501
1502 Bytecount
1503 emacs_doprnt_lisp(Lisp_Object stream, const Bufbyte * format_nonreloc,
1504                   Lisp_Object format_reloc, Bytecount format_length,
1505                   int nargs, const Lisp_Object * largs)
1506 {
1507         return emacs_doprnt_2(stream, format_nonreloc, format_reloc,
1508                               format_length, nargs, largs);
1509 }
1510
1511 /* Like the previous function but takes a variable number of arguments. */
1512
1513 Bytecount
1514 emacs_doprnt_lisp_2(Lisp_Object stream, const Bufbyte * format_nonreloc,
1515                     Lisp_Object format_reloc, Bytecount format_length,
1516                     int nargs, ...)
1517 {
1518         va_list vargs;
1519         int i;
1520         Lisp_Object *foo = alloca_array(Lisp_Object, nargs);
1521
1522         va_start(vargs, nargs);
1523         for (i = 0; i < nargs; i++)
1524                 foo[i] = va_arg(vargs, Lisp_Object);
1525         va_end(vargs);
1526
1527         return emacs_doprnt_2(stream, format_nonreloc, format_reloc,
1528                               format_length, nargs, foo);
1529 }
1530
1531 /* The following four functions work like the above three but
1532    return their output as a Lisp string instead of sending it
1533    to a stream. */
1534
1535 Lisp_Object
1536 emacs_doprnt_string_c(const Bufbyte * format_nonreloc,
1537                       Lisp_Object format_reloc, Bytecount format_length, ...)
1538 {
1539         va_list vargs;
1540         Lisp_Object obj;
1541         Lisp_Object stream = make_resizing_buffer_output_stream();
1542         struct gcpro gcpro1;
1543
1544         GCPRO1(stream);
1545         va_start(vargs, format_length);
1546         emacs_doprnt_1(stream, format_nonreloc, format_reloc,
1547                        format_length, 0, 0, vargs);
1548         va_end(vargs);
1549         Lstream_flush(XLSTREAM(stream));
1550         obj = make_string(resizing_buffer_stream_ptr(XLSTREAM(stream)),
1551                           Lstream_byte_count(XLSTREAM(stream)));
1552         UNGCPRO;
1553         Lstream_delete(XLSTREAM(stream));
1554         return obj;
1555 }
1556
1557 Lisp_Object
1558 emacs_doprnt_string_va(const Bufbyte * format_nonreloc,
1559                        Lisp_Object format_reloc, Bytecount format_length,
1560                        va_list vargs)
1561 {
1562         /* I'm fairly sure that this function cannot actually GC.
1563            That can only happen when the arguments to emacs_doprnt_1() are
1564            Lisp objects rather than C args. */
1565         Lisp_Object obj;
1566         Lisp_Object stream = make_resizing_buffer_output_stream();
1567         struct gcpro gcpro1;
1568
1569         GCPRO1(stream);
1570         emacs_doprnt_1(stream, format_nonreloc, format_reloc,
1571                        format_length, 0, 0, vargs);
1572         Lstream_flush(XLSTREAM(stream));
1573         obj = make_string(resizing_buffer_stream_ptr(XLSTREAM(stream)),
1574                           Lstream_byte_count(XLSTREAM(stream)));
1575         UNGCPRO;
1576         Lstream_delete(XLSTREAM(stream));
1577         return obj;
1578 }
1579
1580 Lisp_Object
1581 emacs_doprnt_string_lisp(const Bufbyte * format_nonreloc,
1582                          Lisp_Object format_reloc, Bytecount format_length,
1583                          int nargs, const Lisp_Object * largs)
1584 {
1585         Lisp_Object obj;
1586         Lisp_Object stream = make_resizing_buffer_output_stream();
1587         struct gcpro gcpro1;
1588
1589         GCPRO1(stream);
1590         emacs_doprnt_2(stream, format_nonreloc, format_reloc,
1591                        format_length, nargs, largs);
1592         Lstream_flush(XLSTREAM(stream));
1593         obj = make_string(resizing_buffer_stream_ptr(XLSTREAM(stream)),
1594                           Lstream_byte_count(XLSTREAM(stream)));
1595         UNGCPRO;
1596         Lstream_delete(XLSTREAM(stream));
1597         return obj;
1598 }
1599
1600 Lisp_Object
1601 emacs_doprnt_string_lisp_2(const Bufbyte * format_nonreloc,
1602                            Lisp_Object format_reloc, Bytecount format_length,
1603                            int nargs, ...)
1604 {
1605         Lisp_Object obj;
1606         Lisp_Object stream = make_resizing_buffer_output_stream();
1607         struct gcpro gcpro1;
1608         va_list vargs;
1609         int i;
1610         Lisp_Object *foo = alloca_array(Lisp_Object, nargs);
1611
1612         va_start(vargs, nargs);
1613         for (i = 0; i < nargs; i++)
1614                 foo[i] = va_arg(vargs, Lisp_Object);
1615         va_end(vargs);
1616
1617         GCPRO1(stream);
1618         emacs_doprnt_2(stream, format_nonreloc, format_reloc,
1619                        format_length, nargs, foo);
1620         Lstream_flush(XLSTREAM(stream));
1621         obj = make_string(resizing_buffer_stream_ptr(XLSTREAM(stream)),
1622                           Lstream_byte_count(XLSTREAM(stream)));
1623         UNGCPRO;
1624         Lstream_delete(XLSTREAM(stream));
1625         return obj;
1626 }