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 Csar 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*, const 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*, const 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 const 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 const FmtDefs IntegerDefs = { 169 4, 170 { 171 {0, 0}, /* mincol */ 172 {1, ' '}, /* padchar */ 173 {1, ','}, /* commachar */ 174 {0, 3}, /* commainterval */ 175 }, 176 }; 177 178 static const 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 const FmtDefs NoneDefs = { 190 0, 191 }; 192 193 static const 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 const 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 const 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 const FmtDefs OneDefs = { 230 1, 231 { 232 {0, 1}, 233 }, 234 }; 235 236 static const 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, const FmtDefs *defaults, int *code) 251 { 252 int count; 253 const 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 const char * const 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 const char * const 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 const char * const 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, const 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 const 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; 1503 const char *str; 1504 LispObj *string, *strings = NIL, *cons; 1505 int atsign = info->args.atsign, 1506 collon = info->args.collon, 1507 mincol = info->args.arguments[0].value, 1508 colinc = info->args.arguments[1].value, 1509 minpad = info->args.arguments[2].value, 1510 padchar = info->args.arguments[3].value; 1511 int i, k, total_length, length, padding, num_formats, has_default, 1512 comma_width, line_width, size, extra; 1513 1514 next_format = *(info->format); 1515 1516 /* list formats */ 1517 list_formats(info, '<', &next_format, &formats, &num_formats, 1518 &has_default, &comma_width, &line_width); 1519 1520 /* initialize list of strings streams */ 1521 if (num_formats) { 1522 string = LSTRINGSTREAM("", STREAM_READ | STREAM_WRITE, 0); 1523 strings = cons = CONS(string, NIL); 1524 GC_PROTECT(strings); 1525 for (i = 1; i < num_formats; i++) { 1526 string = LSTRINGSTREAM("", STREAM_READ | STREAM_WRITE, 0); 1527 RPLACD(cons, CONS(string, NIL)); 1528 cons = CDR(cons); 1529 } 1530 } 1531 1532 /* most information is the same */ 1533 memcpy(&justify_info, info, sizeof(FmtInfo)); 1534 1535 /* loop formating strings */ 1536 for (i = 0, cons = strings; i < num_formats; i++, cons = CDR(cons)) { 1537 /* set new format string */ 1538 format = formats[i]; 1539 justify_info.args.base = justify_info.args.format = format; 1540 justify_info.format = &format; 1541 1542 /* format string, maybe consuming arguments */ 1543 LispFormat(CAR(cons), &justify_info); 1544 1545 /* if format was aborted, it is discarded */ 1546 if (justify_info.upandout) 1547 RPLACA(cons, NIL); 1548 /* check if the entire "main" iteration must be aborted */ 1549 if (justify_info.upandout & UPANDOUT_COLLON) { 1550 for (cons = CDR(cons); i < num_formats; i++, cons = CDR(cons)) 1551 RPLACA(cons, NIL); 1552 break; 1553 } 1554 } 1555 1556 /* free temporary format strings */ 1557 free_formats(formats, num_formats); 1558 1559 /* remove aborted formats */ 1560 /* first remove leading discarded formats */ 1561 if (CAR(strings) == NIL) { 1562 while (CAR(strings) == NIL) { 1563 strings = CDR(strings); 1564 --num_formats; 1565 } 1566 /* keep strings gc protected, discarding first entries */ 1567 lisp__data.protect.objects[gc__protect] = strings; 1568 } 1569 /* now remove intermediary discarded formats */ 1570 cons = strings; 1571 while (CONSP(cons)) { 1572 if (CONSP(CDR(cons)) && CAR(CDR(cons)) == NIL) { 1573 RPLACD(cons, CDR(CDR(cons))); 1574 --num_formats; 1575 } 1576 else 1577 cons = CDR(cons); 1578 } 1579 1580 /* calculate total length required for output */ 1581 if (has_default) 1582 cons = CDR(strings); /* if has_defaults, strings is surely a list */ 1583 else 1584 cons = strings; 1585 for (total_length = 0; CONSP(cons); cons = CDR(cons)) 1586 total_length += SSTREAMP(CAR(cons))->length; 1587 1588 /* initialize pointer to string streams */ 1589 if (has_default) 1590 cons = CDR(strings); 1591 else 1592 cons = strings; 1593 1594 /* check if padding will need to be printed */ 1595 extra = 0; 1596 padding = mincol - total_length; 1597 if (padding < 0) 1598 k = padding = 0; 1599 else { 1600 int num_fields = num_formats - (has_default != 0); 1601 1602 if (num_fields > 1) { 1603 /* check if padding is distributed in num_fields or 1604 * num_fields - 1 steps */ 1605 if (!collon) 1606 --num_fields; 1607 } 1608 1609 if (num_fields) 1610 k = padding / num_fields; 1611 else 1612 k = padding; 1613 1614 if (k <= 0) 1615 k = colinc; 1616 else if (colinc) 1617 k = k + (k % colinc); 1618 extra = mincol - (num_fields * k + total_length); 1619 if (extra < 0) 1620 extra = 0; 1621 } 1622 if (padding && k < minpad) { 1623 k = minpad; 1624 if (colinc) 1625 k = k + (k % colinc); 1626 } 1627 1628 /* first check for the special case of only one string being justified */ 1629 if (num_formats - has_default == 1) { 1630 if (has_default && line_width > 0 && comma_width >= 0 && 1631 total_length + comma_width > line_width) { 1632 str = LispGetSstring(SSTREAMP(CAR(strings)), &size); 1633 LispWriteStr(stream, str, size); 1634 } 1635 string = has_default ? CAR(CDR(strings)) : CAR(strings); 1636 /* check if need left padding */ 1637 if (k && !atsign) { 1638 LispWriteChars(stream, padchar, k); 1639 k = 0; 1640 } 1641 /* check for centralizing text */ 1642 else if (k && atsign && collon) { 1643 LispWriteChars(stream, padchar, k / 2 + ((k / 2) & 1)); 1644 k -= k / 2; 1645 } 1646 str = LispGetSstring(SSTREAMP(string), &size); 1647 LispWriteStr(stream, str, size); 1648 /* if any padding remaining */ 1649 if (k) 1650 LispWriteChars(stream, padchar, k); 1651 } 1652 else { 1653 LispObj *result; 1654 int last, spaces_before, padout; 1655 1656 /* if has default, need to check output length */ 1657 if (has_default && line_width > 0 && comma_width >= 0) { 1658 result = LSTRINGSTREAM("", STREAM_READ | STREAM_WRITE, 0); 1659 GC_PROTECT(result); 1660 } 1661 /* else write directly to stream */ 1662 else 1663 result = stream; 1664 1665 /* loop printing justified text */ 1666 /* padout controls padding for cases where padding is 1667 * is separated in n-1 chunks, where n is the number of 1668 * formatted strings. 1669 */ 1670 for (i = padout = 0; CONSP(cons); i++, cons = CDR(cons), --extra) { 1671 string = CAR(cons); 1672 last = !CONSP(CDR(cons)); 1673 1674 spaces_before = (i != 0 || collon) && (!last || !atsign); 1675 1676 if (!spaces_before) { 1677 /* check for special case */ 1678 if (last && atsign && collon && padding > 0) { 1679 int spaces; 1680 1681 spaces = minpad > colinc ? minpad : colinc; 1682 LispWriteChars(result, padchar, spaces + (extra > 0)); 1683 k -= spaces; 1684 } 1685 str = LispGetSstring(SSTREAMP(string), &size); 1686 LispWriteStr(result, str, size); 1687 padout = 0; 1688 } 1689 if (!padout) 1690 LispWriteChars(result, padchar, k + (extra > 0)); 1691 padout = k; 1692 /* if not first string, or if left padding specified */ 1693 if (spaces_before) { 1694 str = LispGetSstring(SSTREAMP(string), &size); 1695 LispWriteStr(result, str, size); 1696 padout = 0; 1697 } 1698 padding -= k; 1699 } 1700 1701 if (has_default && line_width > 0 && comma_width >= 0) { 1702 length = SSTREAMP(result)->length + LispGetColumn(stream); 1703 1704 /* if current line is too large */ 1705 if (has_default && length + comma_width > line_width) { 1706 str = LispGetSstring(SSTREAMP(CAR(strings)), &size); 1707 LispWriteStr(stream, str, size); 1708 } 1709 1710 /* write result to stream */ 1711 str = LispGetSstring(SSTREAMP(result), &size); 1712 LispWriteStr(stream, str, size); 1713 } 1714 } 1715 1716 /* unprotect string streams from GC */ 1717 GC_LEAVE(); 1718 1719 /* this information always updated */ 1720 *(info->format) = next_format; 1721 } 1722 1723 static void 1724 LispFormat(LispObj *stream, FmtInfo *info) 1725 { 1726 FmtArgs *args; 1727 const FmtDefs *defs = NULL; 1728 LispObj *object, *arguments; 1729 char stk[256], *format, *next_format; 1730 int length, num_arguments, code, need_update, need_argument, hash, head; 1731 1732 /* arguments that will be updated on function exit */ 1733 format = *(info->format); 1734 object = *(info->object); 1735 arguments = *(info->arguments); 1736 num_arguments = *(info->num_arguments); 1737 1738 /* initialize */ 1739 length = 0; 1740 args = &(info->args); 1741 info->upandout = 0; 1742 1743 while (*format) { 1744 if (*format == '~') { 1745 /* flush non formatted characters */ 1746 if (length) { 1747 LispWriteStr(stream, stk, length); 1748 length = 0; 1749 } 1750 1751 need_argument = need_update = hash = 0; 1752 1753 /* parse parameters */ 1754 args->format = format + 1; 1755 next_format = parse_arguments(format + 1, args, &num_arguments, 1756 &arguments, &code); 1757 if (code != NOERROR) 1758 parse_error(args, code); 1759 1760 /* check parameters */ 1761 switch (args->command) { 1762 case 'A': case 'S': 1763 defs = &AsciiDefs; 1764 break; 1765 case 'B': case 'O': case 'D': case 'X': 1766 defs = &IntegerDefs; 1767 break; 1768 case 'R': 1769 defs = &RadixDefs; 1770 break; 1771 case 'P': case 'C': 1772 defs = &NoneDefs; 1773 break; 1774 case 'F': 1775 defs = &FixedFloatDefs; 1776 break; 1777 case 'E': case 'G': 1778 defs = &ExponentialFloatDefs; 1779 break; 1780 case '$': 1781 defs = &DollarFloatDefs; 1782 break; 1783 case '%': case '&': case '|': case '~': case '\n': 1784 defs = &OneDefs; 1785 break; 1786 case 'T': 1787 defs = &TabulateDefs; 1788 break; 1789 case '*': 1790 defs = &OneDefs; 1791 break; 1792 case '?': case '(': 1793 defs = &NoneDefs; 1794 break; 1795 case ')': 1796 /* this is never seen, processed in format_case_conversion */ 1797 format_error(args, "no match for directive ~)"); 1798 case '[': 1799 defs = &OneDefs; 1800 break; 1801 case ']': 1802 /* this is never seen, processed in format_conditional */ 1803 format_error(args, "no match for directive ~]"); 1804 case '{': 1805 defs = &OneDefs; 1806 break; 1807 case '}': 1808 /* this is never seen, processed in format_iterate */ 1809 format_error(args, "no match for directive ~}"); 1810 case '<': 1811 defs = &AsciiDefs; 1812 break; 1813 case '>': 1814 /* this is never seen, processed in format_justify */ 1815 format_error(args, "no match for directive ~>"); 1816 case ';': 1817 /* this is never seen here */ 1818 format_error(args, "misplaced directive ~;"); 1819 case '#': 1820 /* special handling for ~#^ */ 1821 if (*next_format == '^') { 1822 ++next_format; 1823 hash = 1; 1824 defs = &NoneDefs; 1825 args->command = '^'; 1826 break; 1827 } 1828 parse_error(args, PARSE_BADDIRECTIVE); 1829 case '^': 1830 defs = &NoneDefs; 1831 break; 1832 default: 1833 parse_error(args, PARSE_BADDIRECTIVE); 1834 break; 1835 } 1836 merge_arguments(args, defs, &code); 1837 if (code != NOERROR) 1838 merge_error(args, code); 1839 1840 /* check if an argument is required by directive */ 1841 switch (args->command) { 1842 case 'A': case 'S': 1843 case 'B': case 'O': case 'D': case 'X': case 'R': 1844 need_argument = 1; 1845 break; 1846 case 'P': 1847 /* if collon specified, plural is the last print argument */ 1848 need_argument = !args->collon; 1849 break; 1850 case 'C': 1851 need_argument = 1; 1852 break; 1853 case 'F': case 'E': case 'G': case '$': 1854 need_argument = 1; 1855 break; 1856 case '%': case '&': case '|': case '~': case '\n': 1857 break; 1858 case 'T': 1859 break; 1860 case '*': /* check arguments below */ 1861 need_update = 1; 1862 break; 1863 case '?': 1864 need_argument = need_update = 1; 1865 break; 1866 case '(': case '[': case '{': case '<': 1867 need_update = 1; 1868 break; 1869 case '^': 1870 break; 1871 } 1872 if (need_argument) { 1873 if (!CONSP(arguments)) 1874 parse_error(args, PARSE_NOARGSLEFT); 1875 object = CAR(arguments); 1876 arguments = CDR(arguments); 1877 --num_arguments; 1878 } 1879 1880 /* will do recursive calls that change info */ 1881 if (need_update) { 1882 *(info->format) = next_format; 1883 *(info->object) = object; 1884 *(info->arguments) = arguments; 1885 *(info->num_arguments) = num_arguments; 1886 } 1887 1888 /* everything seens fine, print the format directive */ 1889 switch (args->command) { 1890 case 'A': 1891 head = lisp__data.env.length; 1892 LispAddVar(Oprint_escape, NIL); 1893 ++lisp__data.env.head; 1894 format_ascii(stream, object, args); 1895 lisp__data.env.head = lisp__data.env.length = head; 1896 break; 1897 case 'S': 1898 head = lisp__data.env.length; 1899 LispAddVar(Oprint_escape, T); 1900 ++lisp__data.env.head; 1901 format_ascii(stream, object, args); 1902 lisp__data.env.head = lisp__data.env.length = head; 1903 break; 1904 case 'B': 1905 format_in_radix(stream, object, 2, args); 1906 break; 1907 case 'O': 1908 format_in_radix(stream, object, 8, args); 1909 break; 1910 case 'D': 1911 format_in_radix(stream, object, 10, args); 1912 break; 1913 case 'X': 1914 format_in_radix(stream, object, 16, args); 1915 break; 1916 case 'R': 1917 /* if a single argument specified */ 1918 if (args->count) 1919 format_in_radix(stream, object, 0, args); 1920 else 1921 format_radix_special(stream, object, args); 1922 break; 1923 case 'P': 1924 if (args->atsign) { 1925 if (FIXNUMP(object) && FIXNUM_VALUE(object) == 1) 1926 LispWriteChar(stream, 'y'); 1927 else 1928 LispWriteStr(stream, "ies", 3); 1929 } 1930 else if (!FIXNUMP(object) || FIXNUM_VALUE(object) != 1) 1931 LispWriteChar(stream, 's'); 1932 break; 1933 case 'C': 1934 format_character(stream, object, args); 1935 break; 1936 case 'F': 1937 format_fixed_float(stream, object, args); 1938 break; 1939 case 'E': 1940 format_exponential_float(stream, object, args); 1941 break; 1942 case 'G': 1943 format_general_float(stream, object, args); 1944 break; 1945 case '$': 1946 format_dollar_float(stream, object, args); 1947 break; 1948 case '&': 1949 if (LispGetColumn(stream) == 0) 1950 --args->arguments[0].value; 1951 case '%': 1952 LispWriteChars(stream, '\n', args->arguments[0].value); 1953 break; 1954 case '|': 1955 LispWriteChars(stream, '\f', args->arguments[0].value); 1956 break; 1957 case '~': 1958 LispWriteChars(stream, '~', args->arguments[0].value); 1959 break; 1960 case '\n': 1961 if (!args->collon) { 1962 if (args->atsign) 1963 LispWriteChar(stream, '\n'); 1964 /* ignore newline and following spaces */ 1965 while (*next_format && isspace(*next_format)) 1966 ++next_format; 1967 } 1968 break; 1969 case 'T': 1970 format_tabulate(stream, args); 1971 break; 1972 case '*': 1973 format_goto(info); 1974 break; 1975 case '?': 1976 format_indirection(stream, object, info); 1977 need_update = 1; 1978 break; 1979 case '(': 1980 format_case_conversion(stream, info); 1981 /* next_format if far from what is set now */ 1982 next_format = *(info->format); 1983 break; 1984 case '[': 1985 format_conditional(stream, info); 1986 /* next_format if far from what is set now */ 1987 next_format = *(info->format); 1988 break; 1989 case '{': 1990 format_iterate(stream, info); 1991 /* next_format if far from what is set now */ 1992 next_format = *(info->format); 1993 break; 1994 case '<': 1995 format_justify(stream, info); 1996 /* next_format if far from what is set now */ 1997 next_format = *(info->format); 1998 break; 1999 case '^': 2000 if (args->collon) { 2001 if (hash && num_arguments == 0) { 2002 info->upandout = UPANDOUT_HASH; 2003 goto format_up_and_out; 2004 } 2005 if (info->iteration && 2006 info->iteration == ITERATION_NORMAL) 2007 /* not exactly an error, but in this case, 2008 * command is ignored */ 2009 break; 2010 info->upandout = UPANDOUT_COLLON; 2011 goto format_up_and_out; 2012 } 2013 else if (num_arguments == 0) { 2014 info->upandout = UPANDOUT_NORMAL; 2015 goto format_up_and_out; 2016 } 2017 break; 2018 } 2019 2020 if (need_update) { 2021 object = *(info->object); 2022 arguments = *(info->arguments); 2023 num_arguments = *(info->num_arguments); 2024 } 2025 2026 format = next_format; 2027 } 2028 else { 2029 if (length >= sizeof(stk)) { 2030 LispWriteStr(stream, stk, length); 2031 length = 0; 2032 } 2033 stk[length++] = *format++; 2034 } 2035 } 2036 2037 /* flush any peding output */ 2038 if (length) 2039 LispWriteStr(stream, stk, length); 2040 2041 format_up_and_out: 2042 /* update for recursive call */ 2043 *(info->format) = format; 2044 *(info->object) = object; 2045 *(info->arguments) = arguments; 2046 *(info->num_arguments) = num_arguments; 2047 } 2048 2049 LispObj * 2050 Lisp_Format(LispBuiltin *builtin) 2051 /* 2052 format destination control-string &rest arguments 2053 */ 2054 { 2055 GC_ENTER(); 2056 FmtInfo info; 2057 LispObj *object; 2058 char *control_string; 2059 int num_arguments; 2060 2061 LispObj *stream, *format, *arguments; 2062 2063 arguments = ARGUMENT(2); 2064 format = ARGUMENT(1); 2065 stream = ARGUMENT(0); 2066 2067 /* check format and stream */ 2068 CHECK_STRING(format); 2069 if (stream == NIL) { /* return a string */ 2070 stream = LSTRINGSTREAM("", STREAM_READ | STREAM_WRITE, 0); 2071 GC_PROTECT(stream); 2072 } 2073 else if (stream == T || /* print directly to *standard-output* */ 2074 stream == STANDARD_OUTPUT) 2075 stream = NIL; 2076 else { 2077 CHECK_STREAM(stream); 2078 if (!stream->data.stream.writable) 2079 LispDestroy("%s: stream %s is not writable", 2080 STRFUN(builtin), STROBJ(stream)); 2081 } 2082 2083 /* count number of arguments */ 2084 for (object = arguments, num_arguments = 0; CONSP(object); 2085 object = CDR(object), num_arguments++) 2086 ; 2087 2088 /* initialize plural/argument info */ 2089 object = NIL; 2090 2091 /* the format string */ 2092 control_string = THESTR(format); 2093 2094 /* arguments to recursive calls */ 2095 info.args.base = control_string; 2096 info.base_arguments = arguments; 2097 info.total_arguments = num_arguments; 2098 info.format = &control_string; 2099 info.object = &object; 2100 info.arguments = &arguments; 2101 info.num_arguments = &num_arguments; 2102 info.iteration = 0; 2103 2104 /* format arguments */ 2105 LispFormat(stream, &info); 2106 2107 /* if printing to stdout */ 2108 if (stream == NIL) 2109 LispFflush(Stdout); 2110 /* else if printing to string-stream, return a string */ 2111 else if (stream->data.stream.type == LispStreamString) { 2112 int length; 2113 const char *string; 2114 2115 string = LispGetSstring(SSTREAMP(stream), &length); 2116 stream = LSTRING(string, length); 2117 } 2118 2119 GC_LEAVE(); 2120 2121 return (stream); 2122 } 2123
Indexes created Fri Jul 03 00:25:33 UTC 2026