xedit/lisp/format.c

   1 /*
   2  * Copyright (c) 2002 by The XFree86 Project, Inc.
   3  *
   4  * Permission is hereby granted, free of charge, to any person obtaining a
   5  * copy of this software and associated documentation files (the "Software"),
   6  * to deal in the Software without restriction, including without limitation
   7  * the rights to use, copy, modify, merge, publish, distribute, sublicense,
   8  * and/or sell copies of the Software, and to permit persons to whom the
   9  * Software is furnished to do so, subject to the following conditions:
  10  *
  11  * The above copyright notice and this permission notice shall be included in
  12  * all copies or substantial portions of the Software.
  13  *
  14  * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  15  * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  16  * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL
  17  * THE XFREE86 PROJECT BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  18  * WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF
  19  * OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
  20  * SOFTWARE.
  21  *
  22  * Except as contained in this notice, the name of the XFree86 Project shall
  23  * not be used in advertising or otherwise to promote the sale, use or other
  24  * dealings in this Software without prior written authorization from the
  25  * XFree86 Project.
  26  *
  27  * Author: Paulo César Pereira de Andrade
  28  */
  29
  30 /* $XFree86: xc/programs/xedit/lisp/format.c,v 1.29tsi Exp $ */
  31
  32 #include "lisp/io.h"
  33 #include "lisp/write.h"
  34 #include "lisp/format.h"
  35 #include <ctype.h>
  36
  37 #define MAXFMT                  8
  38 #define NOERROR                 0
  39
  40 /* parse error codes */
  41 #define PARSE_2MANYPARM         1       /* too many directive parameters */
  42 #define PARSE_2MANYATS          2       /* more than one @ in directive */
  43 #define PARSE_2MANYCOLS         3       /* more than one : in directive */
  44 #define PARSE_NOARGSLEFT        4       /* no arguments left to format */
  45 #define PARSE_BADFMTARG         5       /* argument is not an integer or char */
  46 #define PARSE_BADDIRECTIVE      6       /* unknown format directive */
  47 #define PARSE_BADINTEGER        7       /* bad integer representation */
  48
  49 /* merge error codes */
  50 #define MERGE_2MANY             1       /* too many parameters to directive */
  51 #define MERGE_NOCHAR            2       /* parameter must be a character */
  52 #define MERGE_NOINT             3       /* parameter must be an integer */
  53
  54 /* generic error codes */
  55 #define GENERIC_RADIX           1       /* radix not in range 2-36 */
  56 #define GENERIC_NEGATIVE        2       /* parameter is negative */
  57 #define GENERIC_BADSTRING       3       /* argument is not a string */
  58 #define GENERIC_BADLIST         4       /* argument is not a list */
  59
  60 #define IF_SPECIFIED(arg)       (arg).specified ? &((arg).value) : NULL
  61
  62 #define UPANDOUT_NORMAL         1
  63 #define UPANDOUT_COLLON         2
  64 #define UPANDOUT_HASH           4       /* only useful inside a ~{ iteration
  65                                          * forces loop finalization. */
  66
  67 #define ITERATION_NORMAL        1
  68 #define ITERATION_LAST          2
  69
  70 /*
  71  * Types
  72  */
  73 /* parameter to format */
  74 typedef struct {
  75     unsigned int achar : 1;     /* value was specified as a character */
  76     unsigned int specified : 1; /* set if value was specified */
  77     unsigned int offset : 30;   /* offset in format string, for error printing */
  78     int value;
  79 } FmtArg;
  80
  81 /* information about format parameters */
  82 typedef struct {
  83     unsigned int atsign : 1;    /* @ specified */
  84     unsigned int collon : 1;    /* : specified */
  85     unsigned int command : 8;   /* the format command */
  86     unsigned int count : 4;     /* number of arguments processed */
  87     unsigned int offset : 10;   /* offset in format string, for error printing */
  88     char *base, *format;
  89     FmtArg arguments[MAXFMT];
  90 } FmtArgs;
  91
  92 /* used for combining default format parameter values */
  93 typedef struct {
  94     int achar;
  95     int value;
  96 } FmtDef;
  97
  98 /* number of default format parameter values and defaults */
  99 typedef struct {
 100     int count;
 101     FmtDef defaults[MAXFMT];
 102 } FmtDefs;
 103
 104 /* used on recursive calls to LispFormat */
 105 typedef struct {
 106     FmtArgs args;
 107     LispObj *base_arguments;    /* pointer to first format argument */
 108     int total_arguments;        /* number of objects in base_arguments */
 109     char **format;              /* if need to update format string pointer */
 110     LispObj **object;           /* CAR(arguments), for plural check */
 111     LispObj **arguments;        /* current element of base_arguments */
 112     int *num_arguments;         /* number of arguments after arguments */
 113     int upandout;               /* information for recursive calls */
 114     int iteration;              /* only set if in ~:{... or ~:@{ and in the
 115                                  * last argument list, hint for upandout */
 116 } FmtInfo;
 117
 118 /*
 119  * Prototypes
 120  */
 121 static void merge_arguments(FmtArgs*, FmtDefs*, int*);
 122 static char *parse_arguments(char*, FmtArgs*, int*, LispObj**, int*);
 123 static void merge_error(FmtArgs*, int);
 124 static void parse_error(FmtArgs*, int);
 125 static void generic_error(FmtArgs*, int);
 126 static void format_error(FmtArgs*, char*);
 127
 128 static int format_object(LispObj*, LispObj*);
 129
 130 static void format_ascii(LispObj*, LispObj*, FmtArgs*);
 131 static void format_in_radix(LispObj*, LispObj*, int, FmtArgs*);
 132 static void format_radix_special(LispObj*, LispObj*, FmtArgs*);
 133 static void format_roman(LispObj*, LispObj*, FmtArgs*);
 134 static void format_english(LispObj*, LispObj*, FmtArgs*);
 135 static void format_character(LispObj*, LispObj*, FmtArgs*);
 136 static void format_fixed_float(LispObj*, LispObj*, FmtArgs*);
 137 static void format_exponential_float(LispObj*, LispObj*, FmtArgs*);
 138 static void format_general_float(LispObj*, LispObj*, FmtArgs*);
 139 static void format_dollar_float(LispObj*, LispObj*, FmtArgs*);
 140 static void format_tabulate(LispObj*, FmtArgs*);
 141
 142 static void format_goto(FmtInfo*);
 143 static void format_indirection(LispObj*, LispObj*, FmtInfo*);
 144
 145 static void list_formats(FmtInfo*, int, char**, char***, int*, int*, int*, int*);
 146 static void free_formats(char**, int);
 147
 148 static void format_case_conversion(LispObj*, FmtInfo*);
 149 static void format_conditional(LispObj*, FmtInfo*);
 150 static void format_iterate(LispObj*, FmtInfo*);
 151 static void format_justify(LispObj*, FmtInfo*);
 152
 153 static void LispFormat(LispObj*, FmtInfo*);
 154
 155 /*
 156  * Initialization
 157  */
 158 static FmtDefs AsciiDefs = {
 159     4,
 160     {
 161         {0, 0},                 /* mincol */
 162         {0, 1},                 /* colinc */
 163         {0, 0},                 /* minpad */
 164         {1, ' '},               /* padchar */
 165     },
 166 };
 167
 168 static FmtDefs IntegerDefs = {
 169     4,
 170     {
 171         {0, 0},                 /* mincol */
 172         {1, ' '},               /* padchar */
 173         {1, ','},               /* commachar */
 174         {0, 3},                 /* commainterval */
 175     },
 176 };
 177
 178 static FmtDefs RadixDefs = {
 179     5,
 180     {
 181         {0, 10},                /* radix */
 182         {0, 0},                 /* mincol */
 183         {1, ' '},               /* padchar */
 184         {1, ','},               /* commachar */
 185         {0, 3},                 /* commainterval */
 186     },
 187 };
 188
 189 static FmtDefs NoneDefs = {
 190     0,
 191 };
 192
 193 static FmtDefs FixedFloatDefs = {
 194     5,
 195     {
 196         {0, 0},                 /* w */
 197         {0, 16},                /* d */
 198         {0, 0},                 /* k */
 199         {1, '\0'},              /* overflowchar */
 200         {1, ' '},               /* padchar */
 201     },
 202 };
 203
 204 static FmtDefs ExponentialFloatDefs = {
 205     7,
 206     {
 207         {0, 0},                 /* w */
 208         {0, 16},                /* d */
 209         {0, 0},                 /* e */
 210         {0, 1},                 /* k */
 211         {1, '\0'},              /* overflowchar */
 212         {1, ' '},               /* padchar */
 213         {1, 'E'},               /* exponentchar */
 214         /* XXX if/when more than one float format,
 215          * should default to object type */
 216     },
 217 };
 218
 219 static FmtDefs DollarFloatDefs = {
 220     4,
 221     {
 222         {0, 2},                 /* d */
 223         {0, 1},                 /* n */
 224         {0, 0},                 /* w */
 225         {1, ' '},               /* padchar */
 226     },
 227 };
 228
 229 static FmtDefs OneDefs = {
 230     1,
 231     {
 232         {0, 1},
 233     },
 234 };
 235
 236 static FmtDefs TabulateDefs = {
 237     2,
 238     {
 239         {0, 0},                 /* colnum */
 240         {0, 1},                 /* colinc */
 241     },
 242 };
 243
 244 extern LispObj *Oprint_escape;
 245
 246 /*
 247  * Implementation
 248  */
 249 static void
 250 merge_arguments(FmtArgs *arguments, FmtDefs *defaults, int *code)
 251 {
 252     int count;
 253     FmtDef *defaul;
 254     FmtArg *argument;
 255
 256     defaul = &(defaults->defaults[0]);
 257     argument = &(arguments->arguments[0]);
 258     for (count = 0; count < defaults->count; count++, argument++, defaul++) {
 259         if (count >= arguments->count)
 260             argument->specified = 0;
 261         if (argument->specified) {
 262             if (argument->achar != defaul->achar) {
 263                 *code = defaul->achar ? MERGE_NOCHAR : MERGE_NOINT;
 264                 arguments->offset = argument->offset;
 265                 return;
 266             }
 267         }
 268         else {
 269             argument->specified = 0;
 270             argument->achar = defaul->achar;
 271             argument->value = defaul->value;
 272         }
 273     }
 274
 275     /* check if extra arguments were provided */
 276     if (arguments->count > defaults->count)
 277         *code = MERGE_2MANY;
 278 }
 279
 280 /* the pointer arguments may be null, useful when just testing/parsing
 281  * the directive parameters */
 282 static char *
 283 parse_arguments(char *format, FmtArgs *arguments,
 284                 int *num_objects, LispObj **objects, int *code)
 285 {
 286     int test;
 287     char *ptr;
 288     FmtArg *argument;
 289     unsigned int tmpcmd = 0;
 290
 291     /* initialize */
 292     test = objects == NULL || code == NULL || num_objects == NULL;
 293     ptr = format;
 294     argument = &(arguments->arguments[0]);
 295     arguments->atsign = arguments->collon = arguments->command = 0;
 296
 297     /* parse format parameters */
 298     for (arguments->count = 0;; arguments->count++) {
 299         arguments->offset = ptr - format + 1;
 300         if (arguments->count >= MAXFMT) {
 301             if (!test)
 302                 *code = PARSE_2MANYPARM;
 303             return (ptr);
 304         }
 305         if (*ptr == '\'') {             /* character parameter value */
 306             ++ptr;                      /* skip ' */
 307             argument->achar = argument->specified = 1;
 308             argument->value = *ptr++;
 309         }
 310         else if (*ptr == ',') {         /* use default parameter value */
 311             argument->achar = 0;
 312             argument->specified = 0;
 313             /* don't increment ptr, will be incremented below */
 314         }
 315         else if (*ptr == '#') {         /* number of arguments is value */
 316             ++ptr;                      /* skip # */
 317             argument->achar = 0;
 318             argument->specified = 1;
 319             if (!test)
 320                 argument->value = *num_objects;
 321         }
 322         else if (*ptr == 'v' ||
 323                  *ptr == 'V') {         /* format object argument is value */
 324             LispObj *object;
 325
 326             ++ptr;                      /* skip V */
 327             if (!test) {
 328                 if (!CONSP(*objects)) {
 329                     *code = PARSE_NOARGSLEFT;
 330                     return (ptr);
 331                 }
 332                 object = CAR((*objects));
 333                 if (FIXNUMP(object)) {
 334                     argument->achar = 0;
 335                     argument->specified = 1;
 336                     argument->value = FIXNUM_VALUE(object);
 337                 }
 338                 else if (SCHARP(object)) {
 339                     argument->achar = argument->specified = 1;
 340                     argument->value = SCHAR_VALUE(object);
 341                 }
 342                 else {
 343                     *code = PARSE_BADFMTARG;
 344                     return (ptr);
 345                 }
 346                 *objects = CDR(*objects);
 347                 --*num_objects;
 348             }
 349         }
 350         else if (isdigit(*ptr) ||
 351                 *ptr == '-' || *ptr == '+') {   /* integer parameter value */
 352             int sign;
 353
 354             argument->achar = 0;
 355             argument->specified = 1;
 356             if (!isdigit(*ptr)) {
 357                 sign = *ptr++ == '-';
 358             }
 359             else
 360                 sign = 0;
 361             if (!test && !isdigit(*ptr)) {
 362                 *code = PARSE_BADINTEGER;
 363                 return (ptr);
 364             }
 365             argument->value = *ptr++ - '0';
 366             while (isdigit(*ptr)) {
 367                 argument->value = (argument->value * 10) + (*ptr++ - '0');
 368                 if (argument->value > 65536) {
 369                     if (!test) {
 370                         *code = PARSE_BADINTEGER;
 371                         return (ptr);
 372                     }
 373                 }
 374             }
 375             if (sign)
 376                 argument->value = -argument->value;
 377         }
 378         else                            /* no more arguments to format */
 379             break;
 380
 381         if (*ptr == ',')
 382             ++ptr;
 383
 384         /* remember offset of format parameter, for better error printing */
 385         argument->offset = arguments->offset;
 386         argument++;
 387     }
 388
 389     /* check for extra flags */
 390     for (;;) {
 391         if (*ptr == '@') {              /* check for special parameter atsign */
 392             if (arguments->atsign) {
 393                 if (!test) {
 394                     *code = PARSE_2MANYATS;
 395                     return (ptr);
 396                 }
 397             }
 398             ++ptr;
 399             ++arguments->offset;
 400             arguments->atsign = 1;
 401         }
 402         else if (*ptr == ':') {         /* check for special parameter collon */
 403             if (arguments->collon) {
 404                 if (!test) {
 405                     *code = PARSE_2MANYCOLS;
 406                     return (ptr);
 407                 }
 408             }
 409             ++ptr;
 410             ++arguments->offset;
 411             arguments->collon = 1;
 412         }
 413         else                            /* next value is format command */
 414             break;
 415     }
 416
 417     if (!test)
 418         *code = NOERROR;
 419     arguments->command = *ptr++;
 420     tmpcmd = arguments->command;
 421     if (islower(tmpcmd))
 422         arguments->command = toupper(tmpcmd);
 423     ++arguments->offset;
 424
 425     return (ptr);
 426 }
 427
 428 static void
 429 parse_error(FmtArgs *args, int code)
 430 {
 431     static char *errors[] = {
 432         NULL,
 433         "too many parameters to directive",
 434         "too many @ parameters",
 435         "too many : parameters",
 436         "no arguments left to format",
 437         "argument is not a fixnum integer or a character",
 438         "unknown format directive",
 439         "parameter is not a fixnum integer",
 440     };
 441
 442     format_error(args, errors[code]);
 443 }
 444
 445 static void
 446 merge_error(FmtArgs *args, int code)
 447 {
 448     static char *errors[] = {
 449         NULL,
 450         "too many parameters to directive",
 451         "argument must be a character",
 452         "argument must be a fixnum integer",
 453     };
 454
 455     format_error(args, errors[code]);
 456 }
 457
 458 static void
 459 generic_error(FmtArgs *args, int code)
 460 {
 461     static char *errors[] = {
 462         NULL,
 463         "radix must be in the range 2 to 36, inclusive",
 464         "parameter must be positive",
 465         "argument must be a string",
 466         "argument must be a list",
 467     };
 468
 469     format_error(args, errors[code]);
 470 }
 471
 472 static void
 473 format_error(FmtArgs *args, char *str)
 474 {
 475     char *message;
 476     int errorlen, formatlen;
 477
 478     /* number of bytes of format to be printed */
 479     formatlen = (args->format - args->base) + args->offset;
 480
 481     /* length of specific error message */
 482     errorlen = strlen(str) + 1;                 /* plus '\n' */
 483
 484     /* XXX allocate string with LispMalloc,
 485      * so that it will be freed in LispTopLevel */
 486     message = LispMalloc(formatlen + errorlen + 1);
 487
 488     sprintf(message, "%s\n", str);
 489     memcpy(message + errorlen, args->base, formatlen);
 490     message[errorlen + formatlen] = '\0';
 491
 492     LispDestroy("FORMAT: %s", message);
 493 }
 494
 495 static int
 496 format_object(LispObj *stream, LispObj *object)
 497 {
 498     int length;
 499
 500     length = LispWriteObject(stream, object);
 501
 502     return (length);
 503 }
 504
 505 static void
 506 format_ascii(LispObj *stream, LispObj *object, FmtArgs *args)
 507 {
 508     GC_ENTER();
 509     LispObj *string = NIL;
 510     int length = 0,
 511         atsign = args->atsign,
 512         collon = args->collon,
 513         mincol = args->arguments[0].value,
 514         colinc = args->arguments[1].value,
 515         minpad = args->arguments[2].value,
 516         padchar = args->arguments[3].value;
 517
 518     /* check/correct arguments */
 519     if (mincol < 0)
 520         mincol = 0;
 521     if (colinc < 0)
 522         colinc = 1;
 523     if (minpad < 0)
 524         minpad = 0;
 525     /* XXX pachar can be the null character? */
 526
 527     if (object == NIL)
 528         length = collon ? 2 : 3;            /* () or NIL */
 529
 530     /* left padding */
 531     if (atsign) {
 532         /* if length not yet known */
 533         if (object == NIL) {
 534             string = LSTRINGSTREAM("", STREAM_READ | STREAM_WRITE, 0);
 535             GC_PROTECT(string);
 536             length = LispWriteObject(string, object);
 537         }
 538
 539         /* output minpad characters at left */
 540         if (minpad) {
 541             length += minpad;
 542             LispWriteChars(stream, padchar, minpad);
 543         }
 544
 545         if (colinc) {
 546             /* puts colinc spaces at a time,
 547              * until at least mincol chars out */
 548             while (length < mincol) {
 549                 LispWriteChars(stream, padchar, colinc);
 550                 length += colinc;
 551             }
 552         }
 553     }
 554
 555     if (object == NIL) {
 556         if (collon)
 557             LispWriteStr(stream, "()", 2);
 558         else
 559             LispWriteStr(stream,  Snil->value, 3);
 560     }
 561     else {
 562         /* if string is not NIL, atsign was specified
 563          * and object printed to string */
 564         if (string == NIL)
 565             length = format_object(stream, object);
 566         else {
 567             int size;
 568             char *str = LispGetSstring(SSTREAMP(string), &size);
 569
 570             LispWriteStr(stream, str, size);
 571         }
 572     }
 573
 574     /* right padding */
 575     if (!atsign) {
 576         /* output minpad characters at left */
 577         if (minpad) {
 578             length += minpad;
 579             LispWriteChars(stream, padchar, minpad);
 580         }
 581         if (colinc) {
 582             /* puts colinc spaces at a time,
 583              * until at least mincol chars out */
 584             while (length < mincol) {
 585                 LispWriteChars(stream, padchar, colinc);
 586                 length += colinc;
 587             }
 588         }
 589     }
 590
 591     GC_LEAVE();
 592 }
 593
 594 /* assumes radix is 0 or in range 2 - 36 */
 595 static void
 596 format_in_radix(LispObj *stream, LispObj *object, int radix, FmtArgs *args)
 597 {
 598     if (INTEGERP(object)) {
 599         int i, atsign, collon, mincol, padchar, commachar, commainterval;
 600
 601         i = (radix == 0);
 602         atsign = args->atsign;
 603         collon = args->collon;
 604         if (radix == 0) {
 605             radix = args->arguments[0].value;
 606             if (radix < 2 || radix > 36) {
 607                 args->offset = args->arguments[0].offset;
 608                 generic_error(args, GENERIC_RADIX);
 609             }
 610         }
 611         mincol = args->arguments[i++].value;
 612         padchar = args->arguments[i++].value;
 613         commachar = args->arguments[i++].value;
 614         commainterval = args->arguments[i++].value;
 615
 616         LispFormatInteger(stream, object, radix, atsign, collon,
 617                           mincol, padchar, commachar, commainterval);
 618     }
 619     else
 620         format_object(stream, object);
 621 }
 622
 623 static void
 624 format_radix_special(LispObj *stream, LispObj *object, FmtArgs *args)
 625 {
 626     if (FIXNUMP(object)) {
 627         if (args->atsign)
 628             format_roman(stream, object, args);
 629         else
 630             format_english(stream, object, args);
 631     }
 632     else
 633         format_object(stream, object);
 634 }
 635
 636 static void
 637 format_roman(LispObj *stream, LispObj *object, FmtArgs *args)
 638 {
 639     long value = 0;
 640     int cando, new_roman = args->collon == 0;
 641
 642     if (FIXNUMP(object)) {
 643         value = FIXNUM_VALUE(object);
 644         if (new_roman)
 645             cando = value >= 1 && value <= 3999;
 646         else
 647             cando = value >= 1 && value <= 4999;
 648     }
 649     else
 650         cando = 0;
 651
 652     if (cando)
 653         LispFormatRomanInteger(stream, value, new_roman);
 654     else
 655         format_object(stream, object);
 656 }
 657
 658 static void
 659 format_english(LispObj *stream, LispObj *object, FmtArgs *args)
 660 {
 661     int cando;
 662     long number = 0;
 663
 664     if (FIXNUMP(object)) {
 665         number = FIXNUM_VALUE(object);
 666         cando = number >= -999999999 && number <= 999999999;
 667     }
 668     else
 669         cando = 0;
 670
 671     if (cando)
 672         LispFormatEnglishInteger(stream, number, args->collon);
 673     else
 674         format_object(stream, object);
 675 }
 676
 677 static void
 678 format_character(LispObj *stream, LispObj *object, FmtArgs *args)
 679 {
 680     if (SCHARP(object))
 681         LispFormatCharacter(stream, object, args->atsign, args->collon);
 682     else
 683         format_object(stream, object);
 684 }
 685
 686 static void
 687 format_fixed_float(LispObj *stream, LispObj *object, FmtArgs *args)
 688 {
 689     if (FLOATP(object))
 690         LispFormatFixedFloat(stream, object, args->atsign,
 691                              args->arguments[0].value,
 692                              IF_SPECIFIED(args->arguments[1]),
 693                              args->arguments[2].value,
 694                              args->arguments[3].value,
 695                              args->arguments[4].value);
 696     else
 697         format_object(stream, object);
 698 }
 699
 700 static void
 701 format_exponential_float(LispObj *stream, LispObj *object, FmtArgs *args)
 702 {
 703     if (FLOATP(object))
 704         LispFormatExponentialFloat(stream, object, args->atsign,
 705                                    args->arguments[0].value,
 706                                    IF_SPECIFIED(args->arguments[1]),
 707                                    args->arguments[2].value,
 708                                    args->arguments[3].value,
 709                                    args->arguments[4].value,
 710                                    args->arguments[5].value,
 711                                    args->arguments[6].value);
 712     else
 713         format_object(stream, object);
 714 }
 715
 716 static void
 717 format_general_float(LispObj *stream, LispObj *object, FmtArgs *args)
 718 {
 719     if (FLOATP(object))
 720         LispFormatGeneralFloat(stream, object, args->atsign,
 721                                 args->arguments[0].value,
 722                                 IF_SPECIFIED(args->arguments[1]),
 723                                 args->arguments[2].value,
 724                                 args->arguments[3].value,
 725                                 args->arguments[4].value,
 726                                 args->arguments[5].value,
 727                                 args->arguments[6].value);
 728     else
 729         format_object(stream, object);
 730 }
 731
 732 static void
 733 format_dollar_float(LispObj *stream, LispObj *object, FmtArgs *args)
 734 {
 735     if (FLOATP(object))
 736         LispFormatDollarFloat(stream, object,
 737                               args->atsign, args->collon,
 738                               args->arguments[0].value,
 739                               args->arguments[1].value,
 740                               args->arguments[2].value,
 741                               args->arguments[3].value);
 742     else
 743         format_object(stream, object);
 744 }
 745
 746 static void
 747 format_tabulate(LispObj *stream, FmtArgs *args)
 748 {
 749     int atsign = args->atsign,
 750         colnum = args->arguments[0].value,
 751         colinc = args->arguments[1].value,
 752         column;
 753
 754     column = LispGetColumn(stream);
 755
 756     if (atsign) {
 757         /* relative tabulation */
 758         if (colnum > 0) {
 759             LispWriteChars(stream, ' ', colnum);
 760             column += colnum;
 761         }
 762         /* tabulate until at a multiple of colinc */
 763         if (colinc > 0)
 764             LispWriteChars(stream, ' ', colinc - (column % colinc));
 765     }
 766     else {
 767         /* if colinc not specified, just move to given column */
 768         if (colinc <= 0)
 769             LispWriteChars(stream, ' ', column - colnum);
 770         else {
 771             /* always output at least colinc spaces */
 772             do {
 773                 LispWriteChars(stream, ' ', colinc);
 774                 colnum -= colinc;
 775             } while (colnum > column);
 776         }
 777     }
 778 }
 779
 780 static void
 781 format_goto(FmtInfo *info)
 782 {
 783     int count, num_arguments;
 784     LispObj *object, *arguments;
 785
 786     /* number of arguments to ignore or goto offset */
 787     count = info->args.arguments[0].value;
 788     if (count < 0)
 789         generic_error(&(info->args), GENERIC_NEGATIVE);
 790
 791     if (info->args.atsign) {
 792         /* absolute goto */
 793
 794         /* if not specified, defaults to zero */
 795         if (!(info->args.arguments[0].specified))
 796             count = 0;
 797
 798         /* if offset too large */
 799         if (count > info->total_arguments)
 800             parse_error(&(info->args), PARSE_NOARGSLEFT);
 801         else if (count != info->total_arguments - *(info->num_arguments)) {
 802             /* calculate new parameters */
 803             object = NIL;
 804             arguments = info->base_arguments;
 805             num_arguments = info->total_arguments - count;
 806
 807             for (; count > 0; count--, arguments = CDR(arguments))
 808                 object = CAR(arguments);
 809
 810             /* update format information */
 811             *(info->object) = object;
 812             *(info->arguments) = arguments;
 813             *(info->num_arguments) = num_arguments;
 814         }
 815     }
 816     else if (count) {
 817         /* relative goto, ignore or go back count arguments */
 818
 819         /* prepare to update parameters */
 820         arguments = *(info->arguments);
 821         num_arguments = *(info->num_arguments);
 822
 823         /* go back count arguments? */
 824         if (info->args.collon)
 825             count = -count;
 826
 827         num_arguments -= count;
 828
 829         if (count > 0) {
 830             if (count > *(info->num_arguments))
 831                 parse_error(&(info->args), PARSE_NOARGSLEFT);
 832
 833             object = *(info->object);
 834             for (; count > 0; count--, arguments = CDR(arguments))
 835                 object = CAR(arguments);
 836         }
 837         else {          /* count < 0 */
 838             if (info->total_arguments + count - *(info->num_arguments) < 0)
 839                 parse_error(&(info->args), PARSE_NOARGSLEFT);
 840
 841             object = NIL;
 842             arguments = info->base_arguments;
 843             for (count = 0; count < info->total_arguments - num_arguments;
 844                 count++, arguments = CDR(arguments))
 845                 object = CAR(arguments);
 846         }
 847
 848         /* update format parameters */
 849         *(info->object) = object;
 850         *(info->arguments) = arguments;
 851         *(info->num_arguments) = num_arguments;
 852     }
 853 }
 854
 855 static void
 856 format_indirection(LispObj *stream, LispObj *format, FmtInfo *info)
 857 {
 858     char *string;
 859     LispObj *object;
 860     FmtInfo indirect_info;
 861
 862     if (!STRINGP(format))
 863         generic_error(&(info->args), GENERIC_BADSTRING);
 864     string = THESTR(format);
 865
 866     /* most information is the same */
 867     memcpy(&indirect_info, info, sizeof(FmtInfo));
 868
 869     /* set new format string */
 870     indirect_info.args.base = indirect_info.args.format = string;
 871     indirect_info.format = &string;
 872
 873     if (info->args.atsign) {
 874         /* use current arguments */
 875
 876         /* do the indirect format */
 877         LispFormat(stream, &indirect_info);
 878     }
 879     else {
 880         /* next argument is the recursive call arguments */
 881
 882         int num_arguments;
 883
 884         /* it is valid to not have a list following string, as string may
 885          * not have format directives */
 886         if (CONSP(*(indirect_info.arguments)))
 887             object = CAR(*(indirect_info.arguments));
 888         else
 889             object = NIL;
 890
 891         if (!LISTP(object) || !CONSP(*(info->arguments)))
 892             generic_error(&(info->args), GENERIC_BADLIST);
 893
 894         /* update information now */
 895         *(info->object) = object;
 896         *(info->arguments) = CDR(*(info->arguments));
 897         *(info->num_arguments) -= 1;
 898
 899         /* set arguments for recursive call */
 900         indirect_info.base_arguments = object;
 901         indirect_info.arguments = &object;
 902         for (num_arguments = 0; CONSP(object); object = CDR(object))
 903             ++num_arguments;
 904
 905         /* note that indirect_info.arguments is a pointer to "object",
 906          * keep it pointing to the correct object */
 907         object = indirect_info.base_arguments;
 908         indirect_info.total_arguments = num_arguments;
 909         indirect_info.num_arguments = &num_arguments;
 910
 911         /* do the indirect format */
 912         LispFormat(stream, &indirect_info);
 913     }
 914 }
 915
 916 /* update pointers to a list of format strings:
 917  *      for '(' and '{' only one list is required
 918  *      for '[' and '<' more than one may be returned
 919  *      has_default is only meaningful for '[' and '<'
 920  *      comma_width and line_width are only meaningful to '<', and
 921  *          only valid if has_default set
 922  * if the string is finished prematurely, LispDestroy is called
 923  * format_ptr is updated to the correct pointer in the "main" format string
 924  */
 925 static void
 926 list_formats(FmtInfo *info, int command, char **format_ptr,
 927              char ***format_list, int *format_count, int *has_default,
 928              int *comma_width, int *line_width)
 929 {
 930     /* instead of processing the directives recursively, just separate the
 931      * input formats in separate strings, then see if one of then need to
 932      * be used */
 933     FmtArgs args;
 934     int counters[] = {  0,   0,   0,   0};
 935                     /* '[', '(', '{', '<' */
 936     char *format, *next_format, *start, **formats;
 937     int num_formats, format_index, separator, add_format;
 938
 939     /* initialize */
 940     formats = NULL;
 941     num_formats = format_index = 0;
 942     if (has_default != NULL)
 943         *has_default = 0;
 944     if (comma_width != NULL)
 945         *comma_width = 0;
 946     if (line_width != NULL)
 947         *line_width = 0;
 948     format = start = next_format = *format_ptr;
 949     switch (command) {
 950         case '[': counters[0] = 1; format_index = 0; break;
 951         case '(': counters[1] = 1; format_index = 1; break;
 952         case '{': counters[2] = 1; format_index = 2; break;
 953         case '<': counters[3] = 1; format_index = 3; break;
 954     }
 955
 956 #define LIST_FORMATS_ADD        1
 957 #define LIST_FORMATS_DONE       2
 958
 959     /* fill list of format options to conditional */
 960     while (*format) {
 961         if (*format == '~') {
 962             separator = add_format = 0;
 963             args.format = format + 1;
 964             next_format = parse_arguments(format + 1, &args, NULL, NULL, NULL);
 965             switch (args.command) {
 966                 case '[': ++counters[0];    break;
 967                 case ']': --counters[0];    break;
 968                 case '(': ++counters[1];    break;
 969                 case ')': --counters[1];    break;
 970                 case '{': ++counters[2];    break;
 971                 case '}': --counters[2];    break;
 972                 case '<': ++counters[3];    break;
 973                 case '>': --counters[3];    break;
 974                 case ';': separator = 1;    break;
 975             }
 976
 977             /* check if a new format string must be added */
 978             if (separator && counters[format_index] == 1 &&
 979                 (command == '[' || command == '<'))
 980                 add_format = LIST_FORMATS_ADD;
 981             else if (counters[format_index] == 0)
 982                 add_format = LIST_FORMATS_DONE;
 983
 984             if (add_format) {
 985                 int length = format - start;
 986
 987                 formats = LispRealloc(formats,
 988                                       (num_formats + 1) * sizeof(char*));
 989
 990                 formats[num_formats] = LispMalloc(length + 1);
 991                 strncpy(formats[num_formats], start, length);
 992                 formats[num_formats][length] = '\0';
 993                 ++num_formats;
 994                 /* loop finished? */
 995                 if (add_format == LIST_FORMATS_DONE)
 996                     break;
 997                 else if (command == '[' && has_default != NULL)
 998                     /* will be set only for the last parameter, what is
 999                      * expected, just don't warn about it in the incorrect
1000                      * place */
1001                     *has_default = args.collon != 0;
1002                 else if (command == '<' && num_formats == 1) {
1003                     /* if the first parameter to '<', there may be overrides
1004                      * to comma-width and line-width */
1005                     if (args.collon && has_default != NULL) {
1006                         *has_default = 1;
1007                         if (comma_width != NULL &&
1008                             args.arguments[0].specified &&
1009                             !args.arguments[0].achar)
1010                             *comma_width = args.arguments[0].value;
1011                         if (line_width != NULL &&
1012                             args.arguments[1].specified &&
1013                             !args.arguments[1].achar)
1014                             *line_width = args.arguments[1].value;
1015                     }
1016                 }
1017                 start = next_format;
1018             }
1019             format = next_format;
1020         }
1021         else
1022             ++format;
1023     }
1024
1025     /* check if format string did not finish prematurely */
1026     if (counters[format_index] != 0) {
1027         char error_message[64];
1028
1029         sprintf(error_message, "expecting ~%c", command);
1030         format_error(&(info->args), error_message);
1031     }
1032
1033     /* update pointers */
1034     *format_list = formats;
1035     *format_count = num_formats;
1036     *format_ptr = next_format;
1037 }
1038
1039 static void
1040 free_formats(char **formats, int num_formats)
1041 {
1042     if (num_formats) {
1043         while (--num_formats >= 0)
1044             LispFree(formats[num_formats]);
1045         LispFree(formats);
1046     }
1047 }
1048
1049 static void
1050 format_case_conversion(LispObj *stream, FmtInfo *info)
1051 {
1052     GC_ENTER();
1053     LispObj *string;
1054     FmtInfo case_info;
1055     char *str, *ptr;
1056     char *format, *next_format, **formats;
1057     int atsign, collon, num_formats, length;
1058
1059     atsign = info->args.atsign;
1060     collon = info->args.collon;
1061
1062     /* output to a string, before case conversion */
1063     string = LSTRINGSTREAM("", STREAM_READ | STREAM_WRITE, 0);
1064     GC_PROTECT(string);
1065
1066     /* most information is the same */
1067     memcpy(&case_info, info, sizeof(FmtInfo));
1068
1069     /* list formats */
1070     next_format = *(info->format);
1071     list_formats(info, '(', &next_format, &formats, &num_formats,
1072                  NULL, NULL, NULL);
1073
1074     /* set new format string */
1075     format = formats[0];
1076     case_info.args.base = case_info.args.format = format;
1077     case_info.format = &format;
1078
1079     /* format text to string */
1080     LispFormat(string, &case_info);
1081
1082     str = ptr = LispGetSstring(SSTREAMP(string), &length);
1083
1084     /* do case conversion */
1085     if (!atsign && !collon) {
1086         /* convert all upercase to lowercase */
1087         for (; *ptr; ptr++) {
1088             if (isupper(*ptr))
1089                 *ptr = tolower(*ptr);
1090         }
1091     }
1092     else if (atsign && collon) {
1093         /* convert all lowercase to upercase */
1094         for (; *ptr; ptr++) {
1095             if (islower(*ptr))
1096                 *ptr = toupper(*ptr);
1097         }
1098     }
1099     else {
1100         int upper = 1;
1101
1102         /* skip non-alphanumeric characters */
1103         for (; *ptr; ptr++)
1104             if (isalnum(*ptr))
1105                 break;
1106
1107         /* capitalize words */
1108         for (; *ptr; ptr++) {
1109             if (isalnum(*ptr)) {
1110                 if (upper) {
1111                     if (islower(*ptr))
1112                         *ptr = toupper(*ptr);
1113                     upper = 0;
1114                 }
1115                 else if (isupper(*ptr))
1116                     *ptr = tolower(*ptr);
1117             }
1118             else
1119                 upper = collon;
1120                 /* if collon, capitalize all words, else just first word */
1121         }
1122     }
1123
1124     /* output case converted string */
1125     LispWriteStr(stream, str, length);
1126
1127     /* temporary string stream is not necessary anymore */
1128     GC_LEAVE();
1129
1130     /* free temporary memory */
1131     free_formats(formats, num_formats);
1132
1133     /* this information always updated */
1134     *(info->format) = next_format;
1135 }
1136
1137 static void
1138 format_conditional(LispObj *stream, FmtInfo *info)
1139 {
1140     LispObj *object, *arguments;
1141     char *format, *next_format, **formats;
1142     int choice, num_formats, has_default, num_arguments;
1143
1144     /* save information that may change */
1145     object = *(info->object);
1146     arguments = *(info->arguments);
1147     num_arguments = *(info->num_arguments);
1148
1149     /* initialize */
1150     choice = -1;
1151     next_format = *(info->format);
1152
1153     /* list formats */
1154     list_formats(info, '[',
1155                  &next_format, &formats, &num_formats, &has_default, NULL, NULL);
1156
1157     /* ~:[false;true] */
1158     if (info->args.collon) {
1159         /* one argument always consumed */
1160         if (!CONSP(arguments))
1161             parse_error(&(info->args), PARSE_NOARGSLEFT);
1162         object = CAR(arguments);
1163         arguments = CDR(arguments);
1164         --num_arguments;
1165         choice = object == NIL ? 0 : 1;
1166     }
1167     /* ~@[true] */
1168     else if (info->args.atsign) {
1169         /* argument consumed only if nil, but one must be available */
1170         if (!CONSP(arguments))
1171             parse_error(&(info->args), PARSE_NOARGSLEFT);
1172         if (CAR(arguments) != NIL)
1173             choice = 0;
1174         else {
1175             object = CAR(arguments);
1176             arguments = CDR(arguments);
1177             --num_arguments;
1178         }
1179     }
1180     /* ~n[...~] */
1181     else if (info->args.arguments[0].specified)
1182         /* no arguments consumed */
1183         choice = info->args.arguments[0].value;
1184     /* ~[...~] */
1185     else {
1186         /* one argument consumed, it is the index in the available formats */
1187         if (!CONSP(arguments))
1188             parse_error(&(info->args), PARSE_NOARGSLEFT);
1189         object = CAR(arguments);
1190         arguments = CDR(arguments);
1191         --num_arguments;
1192         /* no error if it isn't a number? */
1193         if (FIXNUMP(object))
1194             choice = FIXNUM_VALUE(object);
1195     }
1196
1197     /* update anything that may have changed */
1198     *(info->object) = object;
1199     *(info->arguments) = arguments;
1200     *(info->num_arguments) = num_arguments;
1201
1202     /* if choice is out of range check if there is a default choice */
1203     if (has_default && (choice < 0 || choice >= num_formats))
1204         choice = num_formats - 1;
1205
1206     /* if one of the formats must be parsed */
1207     if (choice >= 0 && choice < num_formats) {
1208         FmtInfo conditional_info;
1209
1210         /* most information is the same */
1211         memcpy(&conditional_info, info, sizeof(FmtInfo));
1212
1213         /* set new format string */
1214         format = formats[choice];
1215         conditional_info.args.base = conditional_info.args.format = format;
1216         conditional_info.format = &format;
1217
1218         /* do the conditional format */
1219         LispFormat(stream, &conditional_info);
1220     }
1221
1222     /* free temporary memory */
1223     free_formats(formats, num_formats);
1224
1225     /* this information always updated */
1226     *(info->format) = next_format;
1227 }
1228
1229 static void
1230 format_iterate(LispObj *stream, FmtInfo *info)
1231 {
1232     FmtInfo iterate_info;
1233     LispObj *object, *arguments, *iarguments, *iobject;
1234     char *format, *next_format, *loop_format, **formats;
1235     int num_arguments, iterate, iterate_max, has_max, has_min, inum_arguments,
1236         num_formats;
1237
1238     /* save information that may change */
1239     object = *(info->object);
1240     arguments = *(info->arguments);
1241     num_arguments = *(info->num_arguments);
1242
1243     /* initialize */
1244     iterate = has_min = 0;
1245     next_format = *(info->format);
1246
1247     /* if has_max set, iterate at most iterate_max times */
1248     has_max = info->args.arguments[0].specified;
1249     iterate_max = info->args.arguments[0].value;
1250
1251     /* list formats */
1252     list_formats(info, '{', &next_format, &formats, &num_formats,
1253                  NULL, NULL, NULL);
1254     loop_format = formats[0];
1255
1256     /* most information is the same */
1257     memcpy(&iterate_info, info, sizeof(FmtInfo));
1258
1259     /* ~{...~} */
1260     if (!info->args.atsign && !info->args.collon) {
1261         /* next argument is the argument list for the iteration */
1262
1263         /* fetch argument list, must exist */
1264         if (!CONSP(arguments))
1265             parse_error(&(info->args), PARSE_NOARGSLEFT);
1266         iarguments = object = CAR(arguments);
1267         object = CAR(arguments);
1268         arguments = CDR(arguments);
1269         --num_arguments;
1270
1271         inum_arguments = 0;
1272         if (CONSP(object)) {
1273             /* count arguments to format */
1274             for (iobject = object; CONSP(iobject); iobject = CDR(iobject))
1275                 ++inum_arguments;
1276         }
1277         else if (object != NIL)
1278             generic_error(&(info->args), GENERIC_BADLIST);
1279
1280         iobject = NIL;
1281
1282         /* set new arguments to recursive calls */
1283         iarguments = object;
1284         iterate_info.base_arguments = iarguments;
1285         iterate_info.total_arguments = inum_arguments;
1286         iterate_info.object = &iobject;
1287         iterate_info.arguments = &iarguments;
1288         iterate_info.num_arguments = &inum_arguments;
1289
1290         /* iterate */
1291         for (;; iterate++) {
1292             /* if maximum iterations done or all arguments consumed */
1293             if (has_max && iterate > iterate_max)
1294                 break;
1295             else if (inum_arguments == 0 && (!has_min || iterate > 0))
1296                 break;
1297
1298             format = loop_format;
1299
1300             /* set new format string */
1301             iterate_info.args.base = iterate_info.args.format = format;
1302             iterate_info.format = &format;
1303
1304             /* information for possible ~^, in this case ~:^ is a noop */
1305             iterate_info.iteration = ITERATION_NORMAL;
1306
1307             /* do the format */
1308             LispFormat(stream, &iterate_info);
1309
1310             /* check for forced loop break */
1311             if (iterate_info.upandout & UPANDOUT_HASH)
1312                 break;
1313         }
1314     }
1315     /* ~:@{...~} */
1316     else if (info->args.atsign && info->args.collon) {
1317         /* every following argument is the argument list for the iteration */
1318
1319         /* iterate */
1320         for (;; iterate++) {
1321             /* if maximum iterations done or all arguments consumed */
1322             if (has_max && iterate > iterate_max)
1323                 break;
1324             else if (num_arguments == 0 && (!has_min || iterate > 0))
1325                 break;
1326
1327             /* fetch argument list, must exist */
1328             if (!CONSP(arguments))
1329                 parse_error(&(info->args), PARSE_NOARGSLEFT);
1330             iarguments = object = CAR(arguments);
1331             object = CAR(arguments);
1332             arguments = CDR(arguments);
1333             --num_arguments;
1334
1335             inum_arguments = 0;
1336             if (CONSP(object)) {
1337                 /* count arguments to format */
1338                 for (iobject = object; CONSP(iobject); iobject = CDR(iobject))
1339                     ++inum_arguments;
1340             }
1341             else if (object != NIL)
1342                 generic_error(&(info->args), GENERIC_BADLIST);
1343
1344             iobject = NIL;
1345
1346             /* set new arguments to recursive calls */
1347             iarguments = object;
1348             iterate_info.base_arguments = iarguments;
1349             iterate_info.total_arguments = inum_arguments;
1350             iterate_info.object = &iobject;
1351             iterate_info.arguments = &iarguments;
1352             iterate_info.num_arguments = &inum_arguments;
1353
1354             format = loop_format;
1355
1356             /* set new format string */
1357             iterate_info.args.base = iterate_info.args.format = format;
1358             iterate_info.format = &format;
1359
1360             /* information for possible ~^ */
1361             iterate_info.iteration =
1362                 num_arguments > 0 ? ITERATION_NORMAL : ITERATION_LAST;
1363
1364             /* do the format */
1365             LispFormat(stream, &iterate_info);
1366
1367             /* check for forced loop break */
1368             if (iterate_info.upandout & UPANDOUT_HASH)
1369                 break;
1370         }
1371     }
1372     /* ~:{...~} */
1373     else if (info->args.collon) {
1374         /* next argument is a list of lists */
1375
1376         LispObj *sarguments, *sobject;
1377         int snum_arguments;
1378
1379         /* fetch argument list, must exist */
1380         if (!CONSP(arguments))
1381             parse_error(&(info->args), PARSE_NOARGSLEFT);
1382         sarguments = object = CAR(arguments);
1383         object = CAR(arguments);
1384         arguments = CDR(arguments);
1385         --num_arguments;
1386
1387         snum_arguments = 0;
1388         if (CONSP(object)) {
1389             /* count arguments to format */
1390             for (sobject = object; CONSP(sobject); sobject = CDR(sobject))
1391                 ++snum_arguments;
1392         }
1393         else
1394             generic_error(&(info->args), GENERIC_BADLIST);
1395
1396         /* iterate */
1397         for (;; iterate++) {
1398             /* if maximum iterations done or all arguments consumed */
1399             if (has_max && iterate > iterate_max)
1400                 break;
1401             else if (snum_arguments == 0 && (!has_min || iterate > 0))
1402                 break;
1403
1404             /* fetch argument list, must exist */
1405             if (!CONSP(sarguments))
1406                 parse_error(&(info->args), PARSE_NOARGSLEFT);
1407             iarguments = sobject = CAR(sarguments);
1408             sobject = CAR(sarguments);
1409             sarguments = CDR(sarguments);
1410             --snum_arguments;
1411
1412             inum_arguments = 0;
1413             if (CONSP(object)) {
1414                 /* count arguments to format */
1415                 for (iobject = sobject; CONSP(iobject); iobject = CDR(iobject))
1416                     ++inum_arguments;
1417             }
1418             else if (sobject != NIL)
1419                 generic_error(&(info->args), GENERIC_BADLIST);
1420
1421             iobject = NIL;
1422
1423             /* set new arguments to recursive calls */
1424             iarguments = sobject;
1425             iterate_info.base_arguments = iarguments;
1426             iterate_info.total_arguments = inum_arguments;
1427             iterate_info.object = &iobject;
1428             iterate_info.arguments = &iarguments;
1429             iterate_info.num_arguments = &inum_arguments;
1430
1431             format = loop_format;
1432
1433             /* set new format string */
1434             iterate_info.args.base = iterate_info.args.format = format;
1435             iterate_info.format = &format;
1436
1437             /* information for possible ~^ */
1438             iterate_info.iteration =
1439                 snum_arguments > 0 ? ITERATION_NORMAL : ITERATION_LAST;
1440
1441             /* do the format */
1442             LispFormat(stream, &iterate_info);
1443
1444             /* check for forced loop break */
1445             if (iterate_info.upandout & UPANDOUT_HASH)
1446                 break;
1447         }
1448     }
1449     /* ~@{...~} */
1450     else if (info->args.atsign) {
1451         /* current argument list is used */
1452
1453         /* set new arguments to recursive calls */
1454         iterate_info.base_arguments = info->base_arguments;
1455         iterate_info.total_arguments = info->total_arguments;
1456         iterate_info.object = &object;
1457         iterate_info.arguments = &arguments;
1458         iterate_info.num_arguments = &num_arguments;
1459
1460         for (;; iterate++) {
1461             /* if maximum iterations done or all arguments consumed */
1462             if (has_max && iterate > iterate_max)
1463                 break;
1464             else if (num_arguments == 0 && (!has_min || iterate > 0))
1465                 break;
1466
1467             format = loop_format;
1468
1469             /* set new format string */
1470             iterate_info.args.base = iterate_info.args.format = format;
1471             iterate_info.format = &format;
1472
1473             /* information for possible ~^, in this case ~:^ is a noop */
1474             iterate_info.iteration = ITERATION_NORMAL;
1475
1476             /* do the format */
1477             LispFormat(stream, &iterate_info);
1478
1479             /* check for forced loop break */
1480             if (iterate_info.upandout & UPANDOUT_HASH)
1481                 break;
1482         }
1483     }
1484
1485     /* free temporary memory */
1486     free_formats(formats, num_formats);
1487
1488     /* update anything that may have changed */
1489     *(info->object) = object;
1490     *(info->arguments) = arguments;
1491     *(info->num_arguments) = num_arguments;
1492
1493     /* this information always updated */
1494     *(info->format) = next_format;
1495 }
1496
1497 static void
1498 format_justify(LispObj *stream, FmtInfo *info)
1499 {
1500     GC_ENTER();
1501     FmtInfo justify_info;
1502     char **formats, *format, *next_format, *str;
1503     LispObj *string, *strings = NIL, *cons;
1504     int atsign = info->args.atsign,
1505         collon = info->args.collon,
1506         mincol = info->args.arguments[0].value,
1507         colinc = info->args.arguments[1].value,
1508         minpad = info->args.arguments[2].value,
1509         padchar = info->args.arguments[3].value;
1510     int i, k, total_length, length, padding, num_formats, has_default,
1511         comma_width, line_width, size, extra;
1512
1513     next_format = *(info->format);
1514
1515     /* list formats */
1516     list_formats(info, '<', &next_format, &formats, &num_formats,
1517                  &has_default, &comma_width, &line_width);
1518
1519     /* initialize list of strings streams */
1520     if (num_formats) {
1521         string = LSTRINGSTREAM("", STREAM_READ | STREAM_WRITE, 0);
1522         strings = cons = CONS(string, NIL);
1523         GC_PROTECT(strings);
1524         for (i = 1; i < num_formats; i++) {
1525             string = LSTRINGSTREAM("", STREAM_READ | STREAM_WRITE, 0);
1526             RPLACD(cons, CONS(string, NIL));
1527             cons = CDR(cons);
1528         }
1529     }
1530
1531     /* most information is the same */
1532     memcpy(&justify_info, info, sizeof(FmtInfo));
1533
1534     /* loop formating strings */
1535     for (i = 0, cons = strings; i < num_formats; i++, cons = CDR(cons)) {
1536         /* set new format string */
1537         format = formats[i];
1538         justify_info.args.base = justify_info.args.format = format;
1539         justify_info.format = &format;
1540
1541         /* format string, maybe consuming arguments */
1542         LispFormat(CAR(cons), &justify_info);
1543
1544         /* if format was aborted, it is discarded */
1545         if (justify_info.upandout)
1546             RPLACA(cons, NIL);
1547         /* check if the entire "main" iteration must be aborted */
1548         if (justify_info.upandout & UPANDOUT_COLLON) {
1549             for (cons = CDR(cons); i < num_formats; i++, cons = CDR(cons))
1550                 RPLACA(cons, NIL);
1551             break;
1552         }
1553     }
1554
1555     /* free temporary format strings */
1556     free_formats(formats, num_formats);
1557
1558     /* remove aborted formats */
1559         /* first remove leading discarded formats */
1560     if (CAR(strings) == NIL) {
1561         while (CAR(strings) == NIL) {
1562             strings = CDR(strings);
1563             --num_formats;
1564         }
1565         /* keep strings gc protected, discarding first entries */
1566         lisp__data.protect.objects[gc__protect] = strings;
1567     }
1568         /* now remove intermediary discarded formats */
1569     cons = strings;
1570     while (CONSP(cons)) {
1571         if (CONSP(CDR(cons)) && CAR(CDR(cons)) == NIL) {
1572             RPLACD(cons, CDR(CDR(cons)));
1573             --num_formats;
1574         }
1575         else
1576             cons = CDR(cons);
1577     }
1578
1579     /* calculate total length required for output */
1580     if (has_default)
1581         cons = CDR(strings);    /* if has_defaults, strings is surely a list */
1582     else
1583         cons = strings;
1584     for (total_length = 0; CONSP(cons); cons = CDR(cons))
1585         total_length += SSTREAMP(CAR(cons))->length;
1586
1587     /* initialize pointer to string streams */
1588     if (has_default)
1589         cons = CDR(strings);
1590     else
1591         cons = strings;
1592
1593     /* check if padding will need to be printed */
1594     extra = 0;
1595     padding = mincol - total_length;
1596     if (padding < 0)
1597         k = padding = 0;
1598     else {
1599         int num_fields = num_formats - (has_default != 0);
1600
1601         if (num_fields > 1) {
1602             /* check if padding is distributed in num_fields or
1603              * num_fields - 1 steps */
1604             if (!collon)
1605                 --num_fields;
1606         }
1607
1608         if (num_fields)
1609             k = padding / num_fields;
1610         else
1611             k = padding;
1612
1613         if (k <= 0)
1614             k = colinc;
1615         else if (colinc)
1616             k = k + (k % colinc);
1617         extra = mincol - (num_fields * k + total_length);
1618         if (extra < 0)
1619             extra = 0;
1620     }
1621     if (padding && k < minpad) {
1622         k = minpad;
1623         if (colinc)
1624             k = k + (k % colinc);
1625     }
1626
1627     /* first check for the special case of only one string being justified */
1628     if (num_formats - has_default == 1) {
1629         if (has_default && line_width > 0 && comma_width >= 0 &&
1630             total_length + comma_width > line_width) {
1631             str = LispGetSstring(SSTREAMP(CAR(strings)), &size);
1632             LispWriteStr(stream, str, size);
1633         }
1634         string = has_default ? CAR(CDR(strings)) : CAR(strings);
1635         /* check if need left padding */
1636         if (k && !atsign) {
1637             LispWriteChars(stream, padchar, k);
1638             k = 0;
1639         }
1640         /* check for centralizing text */
1641         else if (k && atsign && collon) {
1642             LispWriteChars(stream, padchar, k / 2 + ((k / 2) & 1));
1643             k -= k / 2;
1644         }
1645         str = LispGetSstring(SSTREAMP(string), &size);
1646         LispWriteStr(stream, str, size);
1647         /* if any padding remaining */
1648         if (k)
1649             LispWriteChars(stream, padchar, k);
1650     }
1651     else {
1652         LispObj *result;
1653         int last, spaces_before, padout;
1654
1655         /* if has default, need to check output length */
1656         if (has_default && line_width > 0 && comma_width >= 0) {
1657             result = LSTRINGSTREAM("", STREAM_READ | STREAM_WRITE, 0);
1658             GC_PROTECT(result);
1659         }
1660         /* else write directly to stream */
1661         else
1662             result = stream;
1663
1664         /* loop printing justified text */
1665             /* padout controls padding for cases where padding is
1666              * is separated in n-1 chunks, where n is the number of
1667              * formatted strings.
1668              */
1669         for (i = padout = 0; CONSP(cons); i++, cons = CDR(cons), --extra) {
1670             string = CAR(cons);
1671             last = !CONSP(CDR(cons));
1672
1673             spaces_before = (i != 0 || collon) && (!last || !atsign);
1674
1675             if (!spaces_before) {
1676                 /* check for special case */
1677                 if (last && atsign && collon && padding > 0) {
1678                     int spaces;
1679
1680                     spaces = minpad > colinc ? minpad : colinc;
1681                     LispWriteChars(result, padchar, spaces + (extra > 0));
1682                     k -= spaces;
1683                 }
1684                 str = LispGetSstring(SSTREAMP(string), &size);
1685                 LispWriteStr(result, str, size);
1686                 padout = 0;
1687             }
1688             if (!padout)
1689                 LispWriteChars(result, padchar, k + (extra > 0));
1690             padout = k;
1691             /* if not first string, or if left padding specified */
1692             if (spaces_before) {
1693                 str = LispGetSstring(SSTREAMP(string), &size);
1694                 LispWriteStr(result, str, size);
1695                 padout = 0;
1696             }
1697             padding -= k;
1698         }
1699
1700         if (has_default && line_width > 0 && comma_width >= 0) {
1701             length = SSTREAMP(result)->length + LispGetColumn(stream);
1702
1703             /* if current line is too large */
1704             if (has_default && length + comma_width > line_width) {
1705                 str = LispGetSstring(SSTREAMP(CAR(strings)), &size);
1706                 LispWriteStr(stream, str, size);
1707             }
1708
1709             /* write result to stream */
1710             str = LispGetSstring(SSTREAMP(result), &size);
1711             LispWriteStr(stream, str, size);
1712         }
1713     }
1714
1715     /* unprotect string streams from GC */
1716     GC_LEAVE();
1717
1718     /* this information always updated */
1719     *(info->format) = next_format;
1720 }
1721
1722 static void
1723 LispFormat(LispObj *stream, FmtInfo *info)
1724 {
1725     FmtArgs *args;
1726     FmtDefs *defs = NULL;
1727     LispObj *object, *arguments;
1728     char stk[256], *format, *next_format;
1729     int length, num_arguments, code, need_update, need_argument, hash, head;
1730
1731     /* arguments that will be updated on function exit */
1732     format = *(info->format);
1733     object = *(info->object);
1734     arguments = *(info->arguments);
1735     num_arguments = *(info->num_arguments);
1736
1737     /* initialize */
1738     length = 0;
1739     args = &(info->args);
1740     info->upandout = 0;
1741
1742     while (*format) {
1743         if (*format == '~') {
1744             /* flush non formatted characters */
1745             if (length) {
1746                 LispWriteStr(stream, stk, length);
1747                 length = 0;
1748             }
1749
1750             need_argument = need_update = hash = 0;
1751
1752             /* parse parameters */
1753             args->format = format + 1;
1754             next_format = parse_arguments(format + 1, args, &num_arguments,
1755                                           &arguments, &code);
1756             if (code != NOERROR)
1757                 parse_error(args, code);
1758
1759             /* check parameters */
1760             switch (args->command) {
1761                 case 'A': case 'S':
1762                     defs = &AsciiDefs;
1763                     break;
1764                 case 'B': case 'O': case 'D': case 'X':
1765                     defs = &IntegerDefs;
1766                     break;
1767                 case 'R':
1768                     defs = &RadixDefs;
1769                     break;
1770                 case 'P': case 'C':
1771                     defs = &NoneDefs;
1772                     break;
1773                 case 'F':
1774                     defs = &FixedFloatDefs;
1775                     break;
1776                 case 'E': case 'G':
1777                     defs = &ExponentialFloatDefs;
1778                     break;
1779                 case '$':
1780                     defs = &DollarFloatDefs;
1781                     break;
1782                 case '%': case '&': case '|': case '~': case '\n':
1783                     defs = &OneDefs;
1784                     break;
1785                 case 'T':
1786                     defs = &TabulateDefs;
1787                     break;
1788                 case '*':
1789                     defs = &OneDefs;
1790                     break;
1791                 case '?': case '(':
1792                     defs = &NoneDefs;
1793                     break;
1794                 case ')':
1795                     /* this is never seen, processed in format_case_conversion */
1796                     format_error(args, "no match for directive ~)");
1797                 case '[':
1798                     defs = &OneDefs;
1799                     break;
1800                 case ']':
1801                     /* this is never seen, processed in format_conditional */
1802                     format_error(args, "no match for directive ~]");
1803                 case '{':
1804                     defs = &OneDefs;
1805                     break;
1806                 case '}':
1807                     /* this is never seen, processed in format_iterate */
1808                     format_error(args, "no match for directive ~}");
1809                 case '<':
1810                     defs = &AsciiDefs;
1811                     break;
1812                 case '>':
1813                     /* this is never seen, processed in format_justify */
1814                     format_error(args, "no match for directive ~>");
1815                 case ';':
1816                     /* this is never seen here */
1817                     format_error(args, "misplaced directive ~;");
1818                 case '#':
1819                     /* special handling for ~#^ */
1820                     if (*next_format == '^') {
1821                         ++next_format;
1822                         hash = 1;
1823                         defs = &NoneDefs;
1824                         args->command = '^';
1825                         break;
1826                     }
1827                     parse_error(args, PARSE_BADDIRECTIVE);
1828                 case '^':
1829                     defs = &NoneDefs;
1830                     break;
1831                 default:
1832                     parse_error(args, PARSE_BADDIRECTIVE);
1833                     break;
1834             }
1835             merge_arguments(args, defs, &code);
1836             if (code != NOERROR)
1837                 merge_error(args, code);
1838
1839             /* check if an argument is required by directive */
1840             switch (args->command) {
1841                 case 'A': case 'S':
1842                 case 'B': case 'O': case 'D': case 'X': case 'R':
1843                     need_argument = 1;
1844                     break;
1845                 case 'P':
1846                     /* if collon specified, plural is the last print argument */
1847                     need_argument = !args->collon;
1848                     break;
1849                 case 'C':
1850                     need_argument = 1;
1851                     break;
1852                 case 'F': case 'E': case 'G': case '$':
1853                     need_argument = 1;
1854                     break;
1855                 case '%': case '&': case '|': case '~': case '\n':
1856                     break;
1857                 case 'T':
1858                     break;
1859                 case '*':                       /* check arguments below */
1860                     need_update = 1;
1861                     break;
1862                 case '?':
1863                     need_argument = need_update = 1;
1864                     break;
1865                 case '(': case '[': case '{': case '<':
1866                     need_update = 1;
1867                     break;
1868                 case '^':
1869                     break;
1870             }
1871             if (need_argument) {
1872                 if (!CONSP(arguments))
1873                     parse_error(args, PARSE_NOARGSLEFT);
1874                 object = CAR(arguments);
1875                 arguments = CDR(arguments);
1876                 --num_arguments;
1877             }
1878
1879             /* will do recursive calls that change info */
1880             if (need_update) {
1881                 *(info->format) = next_format;
1882                 *(info->object) = object;
1883                 *(info->arguments) = arguments;
1884                 *(info->num_arguments) = num_arguments;
1885             }
1886
1887             /* everything seens fine, print the format directive */
1888             switch (args->command) {
1889                 case 'A':
1890                     head = lisp__data.env.length;
1891                     LispAddVar(Oprint_escape, NIL);
1892                     ++lisp__data.env.head;
1893                     format_ascii(stream, object, args);
1894                     lisp__data.env.head = lisp__data.env.length = head;
1895                     break;
1896                 case 'S':
1897                     head = lisp__data.env.length;
1898                     LispAddVar(Oprint_escape, T);
1899                     ++lisp__data.env.head;
1900                     format_ascii(stream, object, args);
1901                     lisp__data.env.head = lisp__data.env.length = head;
1902                     break;
1903                 case 'B':
1904                     format_in_radix(stream, object, 2, args);
1905                     break;
1906                 case 'O':
1907                     format_in_radix(stream, object, 8, args);
1908                     break;
1909                 case 'D':
1910                     format_in_radix(stream, object, 10, args);
1911                     break;
1912                 case 'X':
1913                     format_in_radix(stream, object, 16, args);
1914                     break;
1915                 case 'R':
1916                     /* if a single argument specified */
1917                     if (args->count)
1918                         format_in_radix(stream, object, 0, args);
1919                     else
1920                         format_radix_special(stream, object, args);
1921                     break;
1922                 case 'P':
1923                     if (args->atsign) {
1924                         if (FIXNUMP(object) && FIXNUM_VALUE(object) == 1)
1925                             LispWriteChar(stream, 'y');
1926                         else
1927                             LispWriteStr(stream, "ies", 3);
1928                     }
1929                     else if (!FIXNUMP(object) || FIXNUM_VALUE(object) != 1)
1930                         LispWriteChar(stream, 's');
1931                     break;
1932                 case 'C':
1933                     format_character(stream, object, args);
1934                     break;
1935                 case 'F':
1936                     format_fixed_float(stream, object, args);
1937                     break;
1938                 case 'E':
1939                     format_exponential_float(stream, object, args);
1940                     break;
1941                 case 'G':
1942                     format_general_float(stream, object, args);
1943                     break;
1944                 case '$':
1945                     format_dollar_float(stream, object, args);
1946                     break;
1947                 case '&':
1948                     if (LispGetColumn(stream) == 0)
1949                         --args->arguments[0].value;
1950                 case '%':
1951                     LispWriteChars(stream, '\n', args->arguments[0].value);
1952                     break;
1953                 case '|':
1954                     LispWriteChars(stream, '\f', args->arguments[0].value);
1955                     break;
1956                 case '~':
1957                     LispWriteChars(stream, '~', args->arguments[0].value);
1958                     break;
1959                 case '\n':
1960                     if (!args->collon) {
1961                         if (args->atsign)
1962                             LispWriteChar(stream, '\n');
1963                         /* ignore newline and following spaces */
1964                         while (*next_format && isspace(*next_format))
1965                             ++next_format;
1966                     }
1967                     break;
1968                 case 'T':
1969                     format_tabulate(stream, args);
1970                     break;
1971                 case '*':
1972                     format_goto(info);
1973                     break;
1974                 case '?':
1975                     format_indirection(stream, object, info);
1976                     need_update = 1;
1977                     break;
1978                 case '(':
1979                     format_case_conversion(stream, info);
1980                     /* next_format if far from what is set now */
1981                     next_format = *(info->format);
1982                     break;
1983                 case '[':
1984                     format_conditional(stream, info);
1985                     /* next_format if far from what is set now */
1986                     next_format = *(info->format);
1987                     break;
1988                 case '{':
1989                     format_iterate(stream, info);
1990                     /* next_format if far from what is set now */
1991                     next_format = *(info->format);
1992                     break;
1993                 case '<':
1994                     format_justify(stream, info);
1995                     /* next_format if far from what is set now */
1996                     next_format = *(info->format);
1997                     break;
1998                 case '^':
1999                     if (args->collon) {
2000                         if (hash && num_arguments == 0) {
2001                             info->upandout = UPANDOUT_HASH;
2002                             goto format_up_and_out;
2003                         }
2004                         if (info->iteration &&
2005                             info->iteration == ITERATION_NORMAL)
2006                         /* not exactly an error, but in this case,
2007                          * command is ignored */
2008                             break;
2009                         info->upandout = UPANDOUT_COLLON;
2010                         goto format_up_and_out;
2011                     }
2012                     else if (num_arguments == 0) {
2013                         info->upandout = UPANDOUT_NORMAL;
2014                         goto format_up_and_out;
2015                     }
2016                     break;
2017             }
2018
2019             if (need_update) {
2020                 object = *(info->object);
2021                 arguments = *(info->arguments);
2022                 num_arguments = *(info->num_arguments);
2023             }
2024
2025             format = next_format;
2026         }
2027         else {
2028             if (length >= sizeof(stk)) {
2029                 LispWriteStr(stream, stk, length);
2030                 length = 0;
2031             }
2032             stk[length++] = *format++;
2033         }
2034     }
2035
2036     /* flush any peding output */
2037     if (length)
2038         LispWriteStr(stream, stk, length);
2039
2040 format_up_and_out:
2041     /* update for recursive call */
2042     *(info->format) = format;
2043     *(info->object) = object;
2044     *(info->arguments) = arguments;
2045     *(info->num_arguments) = num_arguments;
2046 }
2047
2048 LispObj *
2049 Lisp_Format(LispBuiltin *builtin)
2050 /*
2051  format destination control-string &rest arguments
2052  */
2053 {
2054     GC_ENTER();
2055     FmtInfo info;
2056     LispObj *object;
2057     char *control_string;
2058     int num_arguments;
2059
2060     LispObj *stream, *format, *arguments;
2061
2062     arguments = ARGUMENT(2);
2063     format = ARGUMENT(1);
2064     stream = ARGUMENT(0);
2065
2066     /* check format and stream */
2067     CHECK_STRING(format);
2068     if (stream == NIL) {        /* return a string */
2069         stream = LSTRINGSTREAM("", STREAM_READ | STREAM_WRITE, 0);
2070         GC_PROTECT(stream);
2071     }
2072     else if (stream == T ||     /* print directly to *standard-output* */
2073              stream == STANDARD_OUTPUT)
2074         stream = NIL;
2075     else {
2076         CHECK_STREAM(stream);
2077         if (!stream->data.stream.writable)
2078             LispDestroy("%s: stream %s is not writable",
2079                         STRFUN(builtin), STROBJ(stream));
2080     }
2081
2082     /* count number of arguments */
2083     for (object = arguments, num_arguments = 0; CONSP(object);
2084          object = CDR(object), num_arguments++)
2085         ;
2086
2087     /* initialize plural/argument info */
2088     object = NIL;
2089
2090     /* the format string */
2091     control_string = THESTR(format);
2092
2093     /* arguments to recursive calls */
2094     info.args.base = control_string;
2095     info.base_arguments = arguments;
2096     info.total_arguments = num_arguments;
2097     info.format = &control_string;
2098     info.object = &object;
2099     info.arguments = &arguments;
2100     info.num_arguments = &num_arguments;
2101     info.iteration = 0;
2102
2103     /* format arguments */
2104     LispFormat(stream, &info);
2105
2106     /* if printing to stdout */
2107     if (stream == NIL)
2108         LispFflush(Stdout);
2109     /* else if printing to string-stream, return a string */
2110     else if (stream->data.stream.type == LispStreamString) {
2111         int length;
2112         char *string;
2113
2114         string = LispGetSstring(SSTREAMP(stream), &length);
2115         stream = LSTRING(string, length);
2116     }
2117
2118     GC_LEAVE();
2119
2120     return (stream);
2121 }