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         int spec_len = -1;
 401
 402         if (specs)
 403                 spec_len = Dynarr_length(specs);
 404
 405         xzero(arg);
 406         for (i = 1; i <= args_needed; i++) {
 407                 int j;
 408                 char ch;
 409                 printf_spec_t spec = 0;
 410
 411                 for (j = 0; j < spec_len; j++) {
 412                         spec = Dynarr_atp(specs, j);
 413                         if (spec->argnum == i) {
 414                                 break;
 415                         }
 416                 }
 417
 418                 if (j >= spec_len)
 419                         error("No conversion spec for argument %d", i);
 420
 421                 ch = spec->converter;
 422
 423                 if (strchr(int_converters, ch)) {
 424                         if (spec->l_flag)
 425                                 arg.l = va_arg(vargs, long);
 426                         else
 427                                 /* int even if ch == 'c' or spec->h_flag: "the
 428                                    type used in va_arg is supposed to match the
 429                                    actual type **after default promotions**."
 430                                    Hence we read an int, not a short, if
 431                                    spec->h_flag. */
 432                                 arg.l = va_arg(vargs, int);
 433                 } else if (strchr(base_converters, ch)) {
 434                         if (spec->l_flag) {
 435                                 arg.l = va_arg(vargs, int);
 436                         } else {
 437                                 /* unsigned int even if ch == 'c'
 438                                    or spec->h_flag */
 439                                 arg.l = va_arg(vargs, int);
 440                         }
 441                 } else if (strchr(double_converters, ch)) {
 442                         arg.d = va_arg(vargs, double);
 443                 } else if (strchr(string_converters, ch)) {
 444                         arg.bp = va_arg(vargs, Bufbyte *);
 445 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP) ||        \
 446         defined HAVE_MPQ && defined WITH_GMP
 447                 } else if (strchr(bigz_converters, ch)) {
 448                         arg.obj = va_arg(vargs, Lisp_Object);
 449 #endif
 450 #if defined HAVE_MPF && defined WITH_GMP ||     \
 451         defined HAVE_MPFR && defined WITH_MPFR
 452                 } else if (strchr(bigf_converters, ch)) {
 453                         arg.obj = va_arg(vargs, Lisp_Object);
 454 #endif
 455                 } else {
 456                         abort();
 457                 }
 458                 Dynarr_add(args, arg);
 459         }
 460
 461         return args;
 462 }
 463
 464 /* Generate output from a format-spec FORMAT, of length FORMAT_LENGTH.
 465    Output goes in BUFFER, which has room for BUFSIZE bytes.
 466    If the output does not fit, truncate it to fit.
 467    Returns the number of bytes stored into BUFFER.
 468    LARGS or VARGS points to the arguments, and NARGS says how many.
 469    if LARGS is non-zero, it should be a pointer to NARGS worth of
 470    Lisp arguments.  Otherwise, VARGS should be a va_list referring
 471    to the arguments. */
 472
 473
 474 /* we divide the emacs_doprnt_1 into readable chunks */
 475
 476 static void emacs_doprnt_number(
 477         Lisp_Object, const Lisp_Object *,
 478         printf_arg_dynarr *, printf_spec_t, char);
 479
 480
 481 #define DOPRNT_AND_FREE(b, l)                                           \
 482         do {                                                            \
 483                 doprnt_1(stream, b, l, 0, -1, 0, 0);                    \
 484                 xfree(b);                                               \
 485         } while (0)
 486
 487 static inline int
 488 __ulong_to_bit_string(char *p, long unsigned int number)
 489 {
 490         int i, seen_high_order = 0;
 491         char *origp = p;
 492
 493         for (i = ((SIZEOF_LONG * 8) - 1); i >= 0; --i) {
 494                 if (number & 1UL << i) {
 495                         seen_high_order = 1;
 496                         *p++ = '1';
 497                 } else {
 498                         if (seen_high_order) {
 499                                 *p++ = '0';
 500                         }
 501                 }
 502         }
 503         *p = '\0';
 504         return (int)(p - origp);
 505 }
 506
 507 static inline int
 508 __nnaughts(printf_spec_t s, int nlen, int tlen)
 509 {
 510 /* return the number of naughts to insert, given specs S and a
 511  * pure length of the number of NLEN and a overall length of the
 512  * text of TLEN
 513  * the result will always be nonnegative */
 514         int result = 0;
 515
 516         /* trivial case */
 517         if (UNLIKELY(s->precision == 0)) {
 518                 /* nothing */
 519                 ;
 520         } else if (s->precision > 0) {
 521                 if ((result = s->precision - nlen) < 0) {
 522                         result = 0;
 523                 }
 524         } else if (s->zero_flag && !s->minus_flag) {
 525                 /* in this case use s->minwidth */
 526                 if ((result = s->minwidth - tlen) < 0) {
 527                         result = 0;
 528                 }
 529         }
 530         return result;
 531 }
 532
 533 static inline int
 534 __bsize_smZ(printf_spec_t s, EMACS_INT SXE_UNUSED(Z))
 535         __attribute__((always_inline));
 536 static inline int
 537 __bsize_smZ(printf_spec_t s, EMACS_INT SXE_UNUSED(Z))
 538 {
 539         return 32 + s->minwidth + sizeof(long int) *
 540                 /* if binary representation is wanted, use an
 541                  * awful lot more space */
 542                 (s->converter != 'b' ? 3 : 8) + s->precision +
 543                 3 /* for 0x and friends */;
 544 }
 545
 546 #if defined HAVE_MPZ && defined WITH_GMP
 547 static inline int
 548 __bsize_Z(printf_spec_t s, bigz Z)
 549         __attribute__((always_inline));
 550 static inline int
 551 __bsize_Z(printf_spec_t s, bigz Z)
 552 {
 553         size_t ms;
 554
 555         switch (s->converter) {
 556         default:
 557                 ms = mpz_sizeinbase(Z, 10);
 558                 break;
 559         case 'x':
 560         case 'X':
 561                 ms = mpz_sizeinbase(Z, 16);
 562                 break;
 563         case 'o':
 564                 ms = mpz_sizeinbase(Z, 8);
 565                 break;
 566         case 'b':
 567                 ms = mpz_sizeinbase(Z, 2);
 568                 break;
 569         }
 570         if ((long int)ms < s->minwidth) {
 571                 return 32 + s->minwidth + s->precision +
 572                         3 /* for 0x and friends */;
 573         } else {
 574                 return 32 + ms + s->precision + 3;
 575         }
 576 }
 577
 578 static inline int
 579 __bsize_Q(printf_spec_t s, bigq Q)
 580         __attribute__((always_inline));
 581 static inline int
 582 __bsize_Q(printf_spec_t s, bigq Q)
 583 {
 584         size_t ms;
 585         int base;
 586
 587         switch (s->converter) {
 588         default:
 589                 base = 10;
 590                 break;
 591         case 'x':
 592         case 'X':
 593                 base = 16;
 594                 break;
 595         case 'o':
 596                 base = 8;
 597                 break;
 598         case 'b':
 599                 base = 2;
 600                 break;
 601         }
 602         ms = mpz_sizeinbase(mpq_numref(Q), base)
 603                 + mpz_sizeinbase(mpq_denref(Q), base) + 3;
 604
 605         if ((long int)ms < s->minwidth) {
 606                 return 32 + s->minwidth + s->precision +
 607                         3 /* for 0x and friends */;
 608         } else {
 609                 return 32 + ms + s->precision + 3;
 610         }
 611 }
 612 #endif  /* HAVE_MPZ && HAVE_GMP */
 613
 614 #define __assign_sign_Z(s, p)                           \
 615         do {                                            \
 616                 if (s->negativep) {                     \
 617                         *(p)++ = '-';                   \
 618                 } else if (s->plus_flag) {              \
 619                         *(p)++ = '+';                   \
 620                 } else if (s->space_flag &&             \
 621                            !s->lisp_reader_syntax) {    \
 622                         *(p)++ = ' ';                   \
 623                 }                                       \
 624         } while (0)
 625
 626 static inline int
 627 __postproc2(printf_spec_t s, char *restrict, size_t, size_t)
 628         __attribute__((always_inline));
 629 static inline int
 630 __postproc2(printf_spec_t s, char *restrict text, size_t text_len, size_t allsz)
 631 {
 632         int nnaughts = 0, num_len = text_len;
 633         int ini_len = 0, pre_len = 0, post_len = 0;
 634         char *restrict num, *restrict ini, *restrict pre, *restrict post;
 635         bool base_conv = (strchr(base_converters, s->converter) != NULL);
 636
 637         /* determine how much stuff to put in front */
 638         if (base_conv && s->number_flag) {
 639                 ini_len = 2;
 640         }
 641         if (s->negativep || s->plus_flag ||
 642             (s->space_flag && !s->lisp_reader_syntax)) {
 643                 ini_len++;
 644         }
 645         /* determine the number of zeroes */
 646         text_len = num_len + ini_len;
 647         text_len += (nnaughts = __nnaughts(s, num_len, text_len));
 648
 649         if ((long int)text_len < s->minwidth) {
 650                 if (s->minus_flag) {
 651                         post_len = s->minwidth - num_len;
 652                 } else {
 653                         pre_len = s->minwidth - text_len;
 654                 }
 655                 text_len = s->minwidth;
 656         }
 657
 658         /* move the number to the final location */
 659         pre = text + pre_len;
 660         ini = pre + ini_len;
 661         num = ini + nnaughts;
 662         post = num + num_len;
 663         memmove(num, text, num_len);
 664
 665         /* put `-' or  */
 666         if (LIKELY(!s->sign_after_hash_flag)) {
 667                 __assign_sign_Z(s, pre);
 668         }
 669
 670         /* this 0x stuff */
 671         if (base_conv && s->number_flag) {
 672                 if (LIKELY(!s->lisp_reader_syntax)) {
 673                         *pre++ = '0';
 674                 } else {
 675                         *pre++ = '#';
 676                 }
 677                 /* the idea behind that is to just swap the
 678                  * leading zero with a # et voila the number
 679                  * can be read in again
 680                  */
 681                 switch (s->converter) {
 682                 case 'o':
 683                         *pre++ = 'o';
 684                         break;
 685                 case 'x':
 686                 case 'X':
 687                         *pre++ = 'x';
 688                         break;
 689                 case 'b':
 690                         *pre++ = 'b';
 691                         break;
 692                 default:
 693                         /* unknown */
 694                         *pre++ = 'u';
 695                         break;
 696                 }
 697         }
 698
 699         if (UNLIKELY(s->sign_after_hash_flag)) {
 700                 __assign_sign_Z(s, pre);
 701         }
 702
 703         /* we pad with zeroes before the number, if desired */
 704         if (nnaughts > 0) {
 705                 memset(ini, '0', nnaughts);
 706         }
 707
 708         /* care about s->minwidth, we move the entire immobile block */
 709         if (s->minus_flag) {
 710                 memset(post, s->pad_char, post_len);
 711         } else {
 712                 memset(text, s->pad_char, pre_len);
 713         }
 714         return text_len;
 715 }
 716
 717 static void
 718 emacs_doprnt_smZ(Lisp_Object stream, EMACS_INT Z, printf_spec_t s,  char ch)
 719 {
 720         /* ASCII Decimal representation uses 2.4 times as many
 721            bits as machine binary.  */
 722         char constructed_spec[100];
 723         char *p = constructed_spec;
 724         int alloc_sz = __bsize_smZ(s, Z), text_len = 0;
 725         /* get a chunk of space to load off the result */
 726         /* C99 we need you so badly */
 727         char text[alloc_sz];
 728
 729         *p++ = '%';
 730         *p++ = 'l';     /* use long */
 731         *p++ = ch;
 732         *p++ = '\0';
 733
 734         s->negativep = Z < 0L;
 735         if (ch != 'b' && Z < 0L) {
 736                 /* We cannot simply use sprintf,
 737                  * sprintf would return a two-complement
 738                  * on negative numbers
 739                  * however for further movements we hav to advance
 740                  * cruft_len because that minus char must stay
 741                  * where it is */
 742                 text_len = snprintf(text, alloc_sz, constructed_spec, -Z);
 743         } else if (ch != 'b' /* && Z >= 0L */) {
 744                 text_len = snprintf(text, alloc_sz, constructed_spec, Z);
 745         } else if (ch == 'b' && Z < 0) {
 746                 text_len = __ulong_to_bit_string(text, -Z);
 747         } else /* ch == 'b' */ {
 748                 text_len = __ulong_to_bit_string(text, Z);
 749         }
 750         assert(text_len >= 0 && text_len < alloc_sz);
 751         /* postprocess, move stuff around, insert naughts, etc. */
 752         text_len = __postproc2(s, text, text_len, alloc_sz);
 753
 754         doprnt_1(stream, (Bufbyte*)text, text_len, 0, -1, 0, 0);
 755         return;
 756 }
 757
 758 #if defined(HAVE_MPZ) && defined WITH_GMP
 759 static void
 760 emacs_doprnt_Z(Lisp_Object stream, Lisp_Object obj, printf_spec_t s, char ch)
 761 {
 762         int base;
 763         int alloc_sz = __bsize_Z(s, XBIGZ_DATA(obj)), text_len = 0;
 764         /* get a chunk of space to load off the result */
 765         /* C99 we need you so badly */
 766         char text[alloc_sz];
 767
 768         switch (ch) {
 769         case 'o':
 770                 base = 8;
 771                 break;
 772         case 'x':
 773         case 'X':
 774                 base = 16;
 775                 break;
 776         case 'b':
 777                 base = 2;
 778                 break;
 779         default:
 780                 base = 10;
 781         }
 782
 783         s->negativep = bigz_sign(XBIGZ_DATA(obj)) < 0;
 784         bigz_to_string2(text, XBIGZ_DATA(obj), base);
 785         text_len = strlen(text);
 786
 787         /* special case %X, MPZ does not upcase hex chars,
 788          * so we have to do it here
 789          */
 790         if (ch == 'X') {
 791                 char *q;
 792                 for (q = (char*)text; *q != '\0'; q++) {
 793                         if (strchr("abcdef", *q))
 794                                 *q -= 32;
 795                 }
 796         }
 797
 798         if (!s->negativep) {
 799                 text_len = __postproc2(s, text, text_len, alloc_sz);
 800                 doprnt_1(stream, (Bufbyte*)text, text_len, 0, -1, 0, 0);
 801                 return;
 802         } else {
 803                 text_len = __postproc2(s, text+1, text_len-1, alloc_sz);
 804                 doprnt_1(stream, (Bufbyte*)text+1, text_len, 0, -1, 0, 0);
 805                 return;
 806         }
 807 }
 808
 809 static void
 810 emacs_doprnt_Q(Lisp_Object stream, Lisp_Object obj, printf_spec_t s, char ch)
 811 {
 812         int alloc_sz = __bsize_Q(s, XBIGQ_DATA(obj)), text_len = 0;
 813         /* get a chunk of space to load off the result */
 814         /* C99 we need you so badly */
 815         char text[alloc_sz];
 816
 817         s->negativep = bigq_sign(XBIGQ_DATA(obj)) < 0;
 818         /* the following two are meaningless for rationals */
 819         s->zero_flag = false;
 820         s->precision = -1;
 821         /* dump him */
 822         bigq_to_string2(text, XBIGQ_DATA(obj), 10);
 823         text_len = strlen(text);
 824
 825         /* special case %X, MPZ does not upcase hex chars,
 826          * so we have to do it here
 827          */
 828         if (ch == 'X') {
 829                 char *q;
 830                 for (q = (char*)text; *q != '\0'; q++) {
 831                         if (strchr("abcdef", *q))
 832                                 *q -= 32;
 833                 }
 834         }
 835
 836         if (!s->negativep) {
 837                 text_len = __postproc2(s, text, text_len, alloc_sz);
 838                 doprnt_1(stream, (Bufbyte*)text, text_len, 0, -1, 0, 0);
 839                 return;
 840         } else {
 841                 text_len = __postproc2(s, text+1, text_len-1, alloc_sz);
 842                 doprnt_1(stream, (Bufbyte*)text+1, text_len, 0, -1, 0, 0);
 843                 return;
 844         }
 845 }
 846 #endif  /* HAVE_MPZ && WITH_GMP */
 847
 848 static void
 849 emacs_doprnt_number(Lisp_Object stream,
 850                     const Lisp_Object *largs,
 851                     printf_arg_dynarr *args,
 852                     printf_spec_t spec,
 853                     char ch)
 854 {
 855         /* Must be a number. */
 856         printf_arg_t arg;
 857         Lisp_Object obj;
 858
 859         if (!largs) {
 860                 arg = Dynarr_at(args, spec->argnum - 1);
 861                 obj = Qnil;
 862         } else {
 863                 obj = largs[spec->argnum - 1];
 864                 if (CHARP(obj))
 865                         obj = make_int(XCHAR(obj));
 866                 if (MARKERP(obj))
 867                         obj = make_int(marker_position(obj));
 868         }
 869
 870         if (!NUMBERP(obj) && !NILP(obj)) {
 871                 error("format specifier %%%c "
 872                       "doesn't match argument type", ch);
 873         }
 874
 875         if (NILP(obj)) {
 876
 877         } else if (ch == 'c') {
 878                 /* always convert to int if we deal with characters */
 879                 obj = Fcoerce_number(obj, Qint, Qnil);
 880
 881         } else if (strchr(int_converters, ch) && (ch != 'c')) {
 882                 obj = Fcoerce_number(obj, Qinteger, Qnil);
 883
 884         } else if (strchr(base_converters, ch)) {
 885                 /* must that really be int?
 886                  * The ENT libraries have support for printing floats
 887                  * or fractions in hex and octal
 888                  */
 889                 obj = Fcoerce_number(obj, Qinteger, Qnil);
 890
 891         } else if (strchr(double_converters, ch)) {
 892                 obj = Fcoerce_number(obj, Qfloat, Qnil);
 893
 894 #if defined(HAVE_MPZ) && (defined WITH_GMP || defined WITH_MP)
 895         } else if (ch == 'Z') {
 896                 obj = Fcoerce_number(obj, Qbigz, Qnil);
 897
 898 #endif /* HAVE_MPZ */
 899 #if defined(HAVE_MPQ) && defined WITH_GMP
 900         } else if (ch == 'Q') {
 901                 obj = Fcoerce_number(obj, Qbigq, Qnil);
 902
 903 #endif /* HAVE_MPQ */
 904 #if defined(HAVE_MPFR) && defined WITH_MPFR
 905         } else if (ch == 'F') {
 906                 obj = Fcoerce_number(obj, Qbigfr, Qnil);
 907
 908 #elif defined(HAVE_MPF) && defined WITH_GMP
 909         } else if (ch == 'F') {
 910                 obj = Fcoerce_number(obj, Qbigf, Qnil);
 911
 912 #endif /* HAVE_MPFR || HAVE_MPF */
 913 #if defined(HAVE_MPFR) && defined WITH_MPFR ||  \
 914         defined(HAVE_MPF) && defined WITH_GMP
 915         } else if (ch == 'R') {
 916                 obj = Fcoerce_number(obj, Qreal, Qnil);
 917
 918                 if (FLOATP(obj)) {
 919                         ch = 'f';
 920                 }
 921
 922 #endif
 923 #if defined(HAVE_PSEUG) && defined WITH_PSEUG
 924         } else if (strchr(bigg_converters, ch)) {
 925                 obj = Fcoerce_number(obj, Qbigg, Qnil);
 926
 927 #endif
 928 #if defined HAVE_MPC && defined WITH_MPC ||     \
 929         defined HAVE_PSEUC && defined WITH_PSEUC
 930         } else if (strchr(bigc_converters, ch)) {
 931                 obj = Fcoerce_number(obj, Qbigc, Qnil);
 932
 933 #endif
 934         }
 935
 936         if (0) {
 937                 ;
 938
 939         } else if ((NILP(obj) || INTP(obj)) && ch == 'c') {
 940                 Emchar a;
 941                 Bytecount charlen;
 942                 Bufbyte charbuf[MAX_EMCHAR_LEN];
 943
 944                 if (NILP(obj))
 945                         a = (Emchar)arg.l;
 946                 else
 947                         a = (Emchar)XINT(obj);
 948
 949                 if (!valid_char_p(a))
 950                         error("invalid character value %d to %%c spec", a);
 951
 952                 charlen = set_charptr_emchar(charbuf, a);
 953                 doprnt_1(stream, charbuf, charlen,
 954                          spec->minwidth, -1, spec->minus_flag,
 955                          spec->zero_flag);
 956                 return;
 957
 958         } else if ((NILP(obj) || FLOATP(obj)) &&
 959                    strchr(double_converters, ch)) {
 960
 961                 /* ASCII Decimal representation uses 2.4 times as many
 962                    bits as machine binary.  */
 963                 char *text_to_print;
 964                 char constructed_spec[100];
 965                 char *p = constructed_spec;
 966                 int length, alloca_sz = max_float_print_size;
 967                 int min = spec->minwidth, prec = spec->precision;
 968                 int max_spec = sizeof(constructed_spec);
 969
 970 #if 0
 971                 /* absolute non-sense :O ...
 972                    anyone actually computed the size which is stated here?! */
 973                 alloca_sz =
 974                         32 + max(spec->minwidth,
 975                                  (EMACS_INT)max(sizeof(double), sizeof(long))
 976                                  * 3 + max(spec->precision, 0));
 977 #else
 978                 if (prec < 0)
 979                         prec = 0;
 980                 if (min < 0)
 981                         min = 0;
 982
 983                 if (32+min+prec > alloca_sz)
 984                         alloca_sz = 32 + min + prec;
 985 #endif
 986                 text_to_print = alloca_array(char, alloca_sz);
 987
 988                 /* Mostly reconstruct the spec and use sprintf() to
 989                    format the string. */
 990
 991                 *p++ = '%';
 992                 if (spec->plus_flag)
 993                         *p++ = '+';
 994                 if (spec->space_flag)
 995                         *p++ = ' ';
 996                 if (spec->number_flag)
 997                         *p++ = '#';
 998                 if (spec->minus_flag)
 999                         *p++ = '-';
1000                 if (spec->zero_flag)
1001                         *p++ = '0';
1002
1003                 if (spec->minwidth >= 0) {
1004                         long_to_string(p, spec->minwidth, max_spec);
1005                         max_spec -= strlen(p);
1006                         p += strlen (p);
1007                 }
1008                 if (spec->precision >= 0) {
1009                         *p++ = '.';
1010                         --max_spec;
1011                         long_to_string(p, spec->precision, max_spec);
1012                         max_spec -= strlen(p);
1013                         p += strlen (p);
1014                 }
1015
1016 #if fpfloat_long_double_p
1017                 *p++ = 'L';
1018                 --max_spec;
1019 #endif
1020                 *p++ = ch;
1021                 --max_spec;
1022                 *p++ = '\0';
1023                 --max_spec;
1024                 assert(max_spec >= 0);
1025                 if (NILP(obj))
1026                         length = snprintf(text_to_print, alloca_sz,
1027                                           constructed_spec, arg.d);
1028                 else
1029                         length = snprintf(text_to_print, alloca_sz,
1030                                           constructed_spec, XFLOAT_DATA(obj));
1031
1032                 if (length > alloca_sz) {
1033                         /* should we really silently truncate?! */
1034                         length = alloca_sz;
1035                 }
1036                 doprnt_1(stream, (Bufbyte *)text_to_print, length, 0, -1, 0, 0);
1037                 return;
1038
1039         } else if ((NILP(obj) || INTP(obj)) && (ch != 'c')) {
1040                 EMACS_INT XINTobj;
1041
1042                 if (NILP(obj)) {
1043                         XINTobj = arg.l;
1044                 } else {
1045                         XINTobj = XINT(obj);
1046                 }
1047                 emacs_doprnt_smZ(stream, XINTobj, spec, ch);
1048
1049 #if defined HAVE_MPZ && (defined WITH_GMP || defined WITH_MP)
1050         } else if (BIGZP(obj)) {
1051                 emacs_doprnt_Z(stream, obj, spec, ch);
1052 #endif  /* HAVE_MPZ */
1053 #if defined HAVE_MPQ && defined WITH_GMP
1054         } else if (BIGQP(obj)) {
1055                 emacs_doprnt_Q(stream, obj, spec, ch);
1056
1057 #if 0
1058                 Bufbyte *text_to_print;
1059                 int ttp_len;
1060                 int base;
1061
1062                 switch (ch) {
1063                 case 'o':
1064                         base = 8;
1065                         break;
1066                 case 'x':
1067                 case 'X':
1068                         base = 16;
1069                         break;
1070                 case 'b':
1071                         base = 2;
1072                         break;
1073                 default:
1074                         base = 10;
1075                 }
1076
1077                 text_to_print =
1078                         (Bufbyte*)bigq_to_string(XBIGQ_DATA(obj), base);
1079                 ttp_len = strlen((char*)text_to_print);
1080
1081                 /* now maybe print the signed or spaced version */
1082                 if ((spec->plus_flag || spec->space_flag) &&
1083                     (bigq_sign(XBIGQ_DATA(obj))>=0)) {
1084                         XREALLOC_ARRAY(text_to_print, Bufbyte,
1085                                        ttp_len + 1);
1086                         memmove(text_to_print+1, text_to_print, ttp_len);
1087                         ttp_len++;
1088                         if (spec->plus_flag)
1089                                 text_to_print[0] = '+';
1090                         if (spec->space_flag)
1091                                 text_to_print[0] = ' ';
1092                 }
1093
1094                 /* care about spec->minwidth */
1095                 if (ttp_len < spec->minwidth) {
1096                         XREALLOC_ARRAY(text_to_print, Bufbyte, spec->minwidth);
1097                         if (spec->minus_flag)
1098                                 memset(text_to_print+ttp_len, ' ',
1099                                        spec->minwidth-ttp_len);
1100                         else {
1101                                 memmove(text_to_print+spec->minwidth-ttp_len,
1102                                         text_to_print, ttp_len);
1103                                 if (spec->zero_flag && spec->precision <= 0)
1104                                         memset(text_to_print, '0',
1105                                                spec->minwidth-ttp_len);
1106                                 else
1107                                         memset(text_to_print, ' ',
1108                                                spec->minwidth-ttp_len);
1109                         }
1110                         ttp_len = spec->minwidth;
1111                 }
1112
1113                 DOPRNT_AND_FREE(text_to_print, ttp_len);
1114                 return;
1115 #endif
1116 #endif  /* HAVE_MPZ */
1117 #if defined HAVE_MPFR && defined WITH_MPFR
1118         } else if (BIGFRP(obj)) {
1119                 Bufbyte *text_to_print;
1120                 int ttp_len;
1121                 long preradix_len, postradix_len;
1122                 int base;
1123
1124                 switch (ch) {
1125                 case 'o':
1126                         base = 8;
1127                         break;
1128                 case 'x':
1129                 case 'X':
1130                         base = 16;
1131                         break;
1132                 case 'b':
1133                         base = 2;
1134                         break;
1135                 default:
1136                         base = 10;
1137                 }
1138
1139                 text_to_print =
1140                         (Bufbyte*)bigfr_to_string(XBIGFR_DATA(obj), base);
1141                 ttp_len = strlen((char*)text_to_print);
1142
1143                 /* if obj is an infinite point or not-a-number dont care about
1144                  * precision flags,
1145                  * also dont care about space or plus flag since the infinities
1146                  * always carry their sign, and not-a-number cannot have a sign
1147                  */
1148                 if (bigfr_nan_p(XBIGFR_DATA(obj)) ||
1149                     bigfr_inf_p(XBIGFR_DATA(obj))) {
1150                         DOPRNT_AND_FREE(text_to_print, ttp_len);
1151                         return;
1152                 }
1153
1154                 /* examine the lengths of digits before and after
1155                  * the decimal dot
1156                  */
1157                 if ((preradix_len = (long int)
1158                      (void*)strchr((char *)text_to_print, '.'))) {
1159                         preradix_len = preradix_len - (long)text_to_print;
1160                         postradix_len = ttp_len - preradix_len - 1;
1161                 } else {
1162                         preradix_len = ttp_len;
1163                         postradix_len = 0;
1164                 }
1165
1166                 /* now cut unwanted places after the decimal dot */
1167                 if (postradix_len > spec->precision &&
1168                     spec->precision >= 0) {
1169                         text_to_print[ttp_len -
1170                                       postradix_len +
1171                                       spec->precision] = '\0';
1172                         ttp_len = ttp_len - postradix_len + spec->precision;
1173                         if (spec->precision == 0) {
1174                                 text_to_print[ttp_len] = '\0';
1175                                 ttp_len--;
1176                         }
1177
1178                 /* now extend to wanted places after the decimal dot */
1179                 } else if (postradix_len < spec->precision &&
1180                            postradix_len > 0) {
1181                         XREALLOC_ARRAY(text_to_print, Bufbyte,
1182                                        ttp_len - postradix_len +
1183                                        spec->precision);
1184                         text_to_print[preradix_len] = '.';
1185                         memset(text_to_print+ttp_len, '0',
1186                                spec->precision - postradix_len);
1187                         ttp_len = ttp_len - postradix_len + spec->precision;
1188
1189                 /* now extend to wanted places, insert a decimal dot first */
1190                 } else if (postradix_len < spec->precision &&
1191                            postradix_len == 0) {
1192                         XREALLOC_ARRAY(text_to_print, Bufbyte,
1193                                        ttp_len + spec->precision + 1);
1194                         text_to_print[preradix_len] = '.';
1195                         memset(text_to_print+preradix_len+1, '0',
1196                                spec->precision);
1197                         ttp_len = ttp_len + spec->precision + 1;
1198                 }
1199
1200                 /* now maybe print the signed or spaced version */
1201                 if ((spec->plus_flag || spec->space_flag) &&
1202                     (bigfr_sign(XBIGFR_DATA(obj))>=0)) {
1203                         XREALLOC_ARRAY(text_to_print, Bufbyte,
1204                                        ttp_len + 1);
1205                         memmove(text_to_print+1, text_to_print, ttp_len);
1206                         ttp_len++;
1207                         if (spec->plus_flag)
1208                                 text_to_print[0] = '+';
1209                         if (spec->space_flag)
1210                                 text_to_print[0] = ' ';
1211                 }
1212
1213                 /* care about spec->minwidth */
1214                 if (ttp_len < spec->minwidth) {
1215                         XREALLOC_ARRAY(text_to_print, Bufbyte, spec->minwidth);
1216                         if (spec->minus_flag)
1217                                 memset(text_to_print+ttp_len, ' ',
1218                                        spec->minwidth-ttp_len);
1219                         else {
1220                                 memmove(text_to_print+spec->minwidth-ttp_len,
1221                                         text_to_print, ttp_len);
1222                                 if (spec->zero_flag && spec->precision <= 0)
1223                                         memset(text_to_print, '0',
1224                                                spec->minwidth-ttp_len);
1225                                 else
1226                                         memset(text_to_print, ' ',
1227                                                spec->minwidth-ttp_len);
1228                         }
1229                         ttp_len = spec->minwidth;
1230                 }
1231
1232                 DOPRNT_AND_FREE(text_to_print, ttp_len);
1233                 return;
1234 #endif  /* HAVE_MPFR */
1235 #if defined HAVE_PSEUG && defined WITH_PSEUG
1236         } else if (BIGGP(obj)) {
1237
1238                 int old_argnum, old_plus_flag, old_space_flag;
1239                 Lisp_Object *modobj = alloca_array(Lisp_Object, 1);
1240
1241                 /* Actually, %a.bB is a rewrite for %a.bd%+a.bd */
1242
1243                 old_argnum = spec->argnum;
1244                 old_plus_flag = spec->plus_flag;
1245                 old_space_flag = spec->space_flag;
1246
1247                 /* rewrite the real part */
1248                 spec->argnum = 1;
1249                 modobj[0] = Freal_part(obj);
1250                 emacs_doprnt_number(stream, modobj, args, spec, 'Z');
1251
1252                 /* rewrite the imaginary part */
1253                 spec->argnum = 1;
1254                 spec->plus_flag = 1;
1255                 spec->space_flag = 0;
1256                 modobj[0] = Fimaginary_part(obj);
1257                 emacs_doprnt_number(stream, modobj, args, spec, 'Z');
1258                 /* print the imaginary unit now */
1259                 doprnt_1(stream, (Bufbyte*)"i", 1, 1, -1, 0, 0);
1260
1261                 spec->argnum = old_argnum;
1262                 spec->plus_flag = old_plus_flag;
1263                 spec->space_flag = old_space_flag;
1264                 return;
1265 #endif  /* HAVE_PSEUG */
1266 #if defined HAVE_MPC && defined WITH_MPC ||     \
1267         defined HAVE_PSEUC && defined WITH_PSEUC
1268         } else if (BIGCP(obj)) {
1269
1270                 int old_argnum, old_plus_flag, old_space_flag;
1271                 Lisp_Object *modobj = alloca_array(Lisp_Object, 1);
1272
1273                 /* Actually, %a.bC is a rewrite for %a.bF%+a.bF */
1274
1275                 old_argnum = spec->argnum;
1276                 old_plus_flag = spec->plus_flag;
1277                 old_space_flag = spec->space_flag;
1278
1279                 /* rewrite the real part */
1280                 spec->argnum = 1;
1281                 modobj[0] = Freal_part(obj);
1282                 emacs_doprnt_number(stream, modobj, args, spec, 'F');
1283
1284                 /* rewrite the imaginary part */
1285                 spec->argnum = 1;
1286                 spec->plus_flag = 1;
1287                 spec->space_flag = 0;
1288                 modobj[0] = Fimaginary_part(obj);
1289                 emacs_doprnt_number(stream, modobj, args, spec, 'F');
1290                 /* print the imaginary unit now */
1291                 doprnt_1(stream, (Bufbyte*)"i", 1, 1, -1, 0, 0);
1292
1293                 spec->argnum = old_argnum;
1294                 spec->plus_flag = old_plus_flag;
1295                 spec->space_flag = old_space_flag;
1296                 return;
1297 #endif  /* HAVE_MPC */
1298         }
1299 }
1300
1301
1302 static Bytecount
1303 emacs_doprnt_1(Lisp_Object stream, const Bufbyte * format_nonreloc,
1304                Lisp_Object format_reloc, Bytecount format_length, int nargs,
1305                /* #### Gag me, gag me, gag me */
1306                const Lisp_Object * largs, va_list vargs)
1307 {
1308         printf_spec_dynarr *specs = 0;
1309         printf_arg_dynarr *args = 0;
1310         REGISTER int i;
1311         int init_byte_count = Lstream_byte_count(XLSTREAM(stream));
1312
1313         if (!NILP(format_reloc)) {
1314                 format_nonreloc = XSTRING_DATA(format_reloc);
1315                 format_length = XSTRING_LENGTH(format_reloc);
1316         }
1317         if (format_length < 0)
1318                 format_length =
1319                     (Bytecount) strlen((const char *)format_nonreloc);
1320
1321         specs = parse_doprnt_spec(format_nonreloc, format_length);
1322
1323         if (largs) {
1324                 /* allow too many args for string, but not too few */
1325                 if (nargs < get_args_needed(specs))
1326                         signal_error(Qwrong_number_of_arguments,
1327                                      list3(Qformat,
1328                                            make_int(nargs),
1329                                            !NILP(format_reloc) ? format_reloc :
1330                                            make_string(format_nonreloc,
1331                                                        format_length)));
1332         } else {
1333                 args = get_doprnt_args(specs, vargs);
1334         }
1335
1336         for (i = 0; specs && i < Dynarr_length(specs); i++) {
1337                 printf_spec_t spec = Dynarr_atp(specs, i);
1338                 char ch;
1339
1340                 /* Copy the text before */
1341                 if (!NILP(format_reloc))        /* refetch in case of GC below */
1342                         format_nonreloc = XSTRING_DATA(format_reloc);
1343
1344                 doprnt_1(stream, format_nonreloc + spec->text_before,
1345                          spec->text_before_len, 0, -1, 0, 0);
1346
1347                 ch = spec->converter;
1348
1349                 if (!ch)
1350                         continue;
1351
1352                 if (ch == '%') {
1353                         doprnt_1(stream, (Bufbyte *) & ch, 1, 0, -1, 0, 0);
1354                         continue;
1355                 }
1356
1357                 /* The char '*' as converter means the field width, precision
1358                    was specified as an argument.  Extract the data and forward
1359                    it to the next spec, to which it will apply.  */
1360                 if (ch == '*') {
1361                         printf_spec_t nextspec = Dynarr_atp(specs, i + 1);
1362                         Lisp_Object obj = largs[spec->argnum - 1];
1363
1364                         if (INTP(obj)) {
1365                                 if (spec->forwarding_precision) {
1366                                         nextspec->precision = XINT(obj);
1367                                         nextspec->minwidth = spec->minwidth;
1368                                 } else {
1369                                         nextspec->minwidth = XINT(obj);
1370                                         if (XINT(obj) < 0) {
1371                                                 spec->minus_flag = 1;
1372                                                 nextspec->minwidth =
1373                                                     -nextspec->minwidth;
1374                                         }
1375                                 }
1376                                 nextspec->minus_flag = spec->minus_flag;
1377                                 nextspec->plus_flag = spec->plus_flag;
1378                                 nextspec->space_flag = spec->space_flag;
1379                                 nextspec->number_flag = spec->number_flag;
1380                                 nextspec->zero_flag = spec->zero_flag;
1381                         }
1382                         continue;
1383                 }
1384
1385                 if (largs && (spec->argnum < 1 || spec->argnum > nargs))
1386                         error("Invalid repositioning argument %d",
1387                               spec->argnum);
1388
1389                 else if (ch == 'S' || ch == 's') {
1390                         Bufbyte *string;
1391                         Bytecount string_len;
1392
1393                         if (!largs) {
1394                                 string = Dynarr_at(args, spec->argnum - 1).bp;
1395                                 /* error() can be called with null string
1396                                    arguments.  E.g., in fileio.c, the return
1397                                    value of strerror() is never checked.  We'll
1398                                    print (null), like some printf
1399                                    implementations do.  Would it be better (and
1400                                    safe) to signal an error instead?  Or should
1401                                    we just use the empty string?
1402                                    -dkindred@cs.cmu.edu 8/1997
1403                                  */
1404                                 if (!string)
1405                                         string = (Bufbyte *) "(null)";
1406                                 string_len = strlen((char *)string);
1407                         } else {
1408                                 Lisp_Object obj = largs[spec->argnum - 1];
1409                                 Lisp_String *ls;
1410
1411                                 if (ch == 'S') {
1412                                         /* For `S', prin1 the argument and
1413                                          * then treat like a string.
1414                                          */
1415                                         Lisp_Object tmp =
1416                                                 Fprin1_to_string(obj, Qnil);
1417                                         ls = XSTRING(tmp);
1418                                 } else if (STRINGP(obj)) {
1419                                         ls = XSTRING(obj);
1420                                 } else if (SYMBOLP(obj)) {
1421                                         ls = XSYMBOL(obj)->name;
1422                                 } else {
1423                                         /* convert to string using princ. */
1424                                         Lisp_Object tmp =
1425                                                 Fprin1_to_string(obj, Qt);
1426                                         ls = XSTRING(tmp);
1427                                 }
1428                                 string = string_data(ls);
1429                                 string_len = string_length(ls);
1430                         }
1431
1432                         doprnt_1(stream, string, string_len, spec->minwidth,
1433                                  spec->precision, spec->minus_flag,
1434                                  spec->zero_flag);
1435                 } else {
1436                         /* Must be a number. */
1437                         emacs_doprnt_number(stream, largs, args, spec, ch);
1438                 }
1439         }
1440
1441         /* #### will not get freed if error */
1442         if (specs)
1443                 Dynarr_free(specs);
1444         if (args)
1445                 Dynarr_free(args);
1446         return Lstream_byte_count(XLSTREAM(stream)) - init_byte_count;
1447 }
1448
1449 /* You really don't want to know why this is necessary... */
1450 static Bytecount
1451 emacs_doprnt_2(Lisp_Object stream, const Bufbyte * format_nonreloc,
1452                Lisp_Object format_reloc, Bytecount format_length, int nargs,
1453                const Lisp_Object * largs, ...)
1454 {
1455         va_list vargs;
1456         Bytecount val;
1457         va_start(vargs, largs);
1458         val = emacs_doprnt_1(stream, format_nonreloc, format_reloc,
1459                              format_length, nargs, largs, vargs);
1460         va_end(vargs);
1461         return val;
1462 }
1463
1464 /*********************** external entry points ***********************/
1465
1466 #ifdef I18N3
1467   /* A note about I18N3 translating: the format string should get
1468      translated, but not under all circumstances.  When the format
1469      string is a Lisp string, what should happen is that Fformat()
1470      should format the untranslated args[0] and return that, and also
1471      call Fgettext() on args[0] and, if that is different, format it
1472      and store it in the `string-translatable' property of
1473      the returned string.  See Fgettext(). */
1474 #endif
1475
1476 /* Send formatted output to STREAM.  The format string comes from
1477    either FORMAT_NONRELOC (of length FORMAT_LENGTH; -1 means use
1478    strlen() to determine the length) or from FORMAT_RELOC, which
1479    should be a Lisp string.  Return the number of bytes written
1480    to the stream.
1481
1482    DO NOT pass the data from a Lisp string as the FORMAT_NONRELOC
1483    parameter, because this function can cause GC. */
1484
1485 Bytecount
1486 emacs_doprnt_c(Lisp_Object stream, const Bufbyte * format_nonreloc,
1487                Lisp_Object format_reloc, Bytecount format_length, ...)
1488 {
1489         int val;
1490         va_list vargs;
1491
1492         va_start(vargs, format_length);
1493         val = emacs_doprnt_1(stream, format_nonreloc, format_reloc,
1494                              format_length, 0, 0, vargs);
1495         va_end(vargs);
1496         return val;
1497 }
1498
1499 /* Like emacs_doprnt_c but the args come in va_list format. */
1500
1501 Bytecount
1502 emacs_doprnt_va(Lisp_Object stream, const Bufbyte * format_nonreloc,
1503                 Lisp_Object format_reloc, Bytecount format_length,
1504                 va_list vargs)
1505 {
1506         return emacs_doprnt_1(stream, format_nonreloc, format_reloc,
1507                               format_length, 0, 0, vargs);
1508 }
1509
1510 /* Like emacs_doprnt_c but the args are Lisp objects instead of
1511    C arguments.  This causes somewhat different behavior from
1512    the above two functions (which should act like printf).
1513    See `format' for a description of this behavior. */
1514
1515 Bytecount
1516 emacs_doprnt_lisp(Lisp_Object stream, const Bufbyte * format_nonreloc,
1517                   Lisp_Object format_reloc, Bytecount format_length,
1518                   int nargs, const Lisp_Object * largs)
1519 {
1520         return emacs_doprnt_2(stream, format_nonreloc, format_reloc,
1521                               format_length, nargs, largs);
1522 }
1523
1524 /* Like the previous function but takes a variable number of arguments. */
1525
1526 Bytecount
1527 emacs_doprnt_lisp_2(Lisp_Object stream, const Bufbyte * format_nonreloc,
1528                     Lisp_Object format_reloc, Bytecount format_length,
1529                     int nargs, ...)
1530 {
1531         va_list vargs;
1532         int i;
1533         Lisp_Object *foo = alloca_array(Lisp_Object, nargs);
1534
1535         va_start(vargs, nargs);
1536         for (i = 0; i < nargs; i++)
1537                 foo[i] = va_arg(vargs, Lisp_Object);
1538         va_end(vargs);
1539
1540         return emacs_doprnt_2(stream, format_nonreloc, format_reloc,
1541                               format_length, nargs, foo);
1542 }
1543
1544 /* The following four functions work like the above three but
1545    return their output as a Lisp string instead of sending it
1546    to a stream. */
1547
1548 Lisp_Object
1549 emacs_doprnt_string_c(const Bufbyte * format_nonreloc,
1550                       Lisp_Object format_reloc, Bytecount format_length, ...)
1551 {
1552         va_list vargs;
1553         Lisp_Object obj;
1554         Lisp_Object stream = make_resizing_buffer_output_stream();
1555         struct gcpro gcpro1;
1556
1557         GCPRO1(stream);
1558         va_start(vargs, format_length);
1559         emacs_doprnt_1(stream, format_nonreloc, format_reloc,
1560                        format_length, 0, 0, vargs);
1561         va_end(vargs);
1562         Lstream_flush(XLSTREAM(stream));
1563         obj = make_string(resizing_buffer_stream_ptr(XLSTREAM(stream)),
1564                           Lstream_byte_count(XLSTREAM(stream)));
1565         UNGCPRO;
1566         Lstream_delete(XLSTREAM(stream));
1567         return obj;
1568 }
1569
1570 Lisp_Object
1571 emacs_doprnt_string_va(const Bufbyte * format_nonreloc,
1572                        Lisp_Object format_reloc, Bytecount format_length,
1573                        va_list vargs)
1574 {
1575         /* I'm fairly sure that this function cannot actually GC.
1576            That can only happen when the arguments to emacs_doprnt_1() are
1577            Lisp objects rather than C args. */
1578         Lisp_Object obj;
1579         Lisp_Object stream = make_resizing_buffer_output_stream();
1580         struct gcpro gcpro1;
1581
1582         GCPRO1(stream);
1583         emacs_doprnt_1(stream, format_nonreloc, format_reloc,
1584                        format_length, 0, 0, vargs);
1585         Lstream_flush(XLSTREAM(stream));
1586         obj = make_string(resizing_buffer_stream_ptr(XLSTREAM(stream)),
1587                           Lstream_byte_count(XLSTREAM(stream)));
1588         UNGCPRO;
1589         Lstream_delete(XLSTREAM(stream));
1590         return obj;
1591 }
1592
1593 Lisp_Object
1594 emacs_doprnt_string_lisp(const Bufbyte * format_nonreloc,
1595                          Lisp_Object format_reloc, Bytecount format_length,
1596                          int nargs, const Lisp_Object * largs)
1597 {
1598         Lisp_Object obj;
1599         Lisp_Object stream = make_resizing_buffer_output_stream();
1600         struct gcpro gcpro1;
1601
1602         GCPRO1(stream);
1603         emacs_doprnt_2(stream, format_nonreloc, format_reloc,
1604                        format_length, nargs, largs);
1605         Lstream_flush(XLSTREAM(stream));
1606         obj = make_string(resizing_buffer_stream_ptr(XLSTREAM(stream)),
1607                           Lstream_byte_count(XLSTREAM(stream)));
1608         UNGCPRO;
1609         Lstream_delete(XLSTREAM(stream));
1610         return obj;
1611 }
1612
1613 Lisp_Object
1614 emacs_doprnt_string_lisp_2(const Bufbyte * format_nonreloc,
1615                            Lisp_Object format_reloc, Bytecount format_length,
1616                            int nargs, ...)
1617 {
1618         Lisp_Object obj;
1619         Lisp_Object stream = make_resizing_buffer_output_stream();
1620         struct gcpro gcpro1;
1621         va_list vargs;
1622         int i;
1623         Lisp_Object *foo = alloca_array(Lisp_Object, nargs);
1624
1625         va_start(vargs, nargs);
1626         for (i = 0; i < nargs; i++)
1627                 foo[i] = va_arg(vargs, Lisp_Object);
1628         va_end(vargs);
1629
1630         GCPRO1(stream);
1631         emacs_doprnt_2(stream, format_nonreloc, format_reloc,
1632                        format_length, nargs, foo);
1633         Lstream_flush(XLSTREAM(stream));
1634         obj = make_string(resizing_buffer_stream_ptr(XLSTREAM(stream)),
1635                           Lstream_byte_count(XLSTREAM(stream)));
1636         UNGCPRO;
1637         Lstream_delete(XLSTREAM(stream));
1638         return obj;
1639 }