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