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/write.c,v 1.31tsi Exp $ */ 31 32 #include "lisp/write.h" 33 #include "lisp/hash.h" 34 #include <math.h> 35 #include <ctype.h> 36 37 #define FLOAT_PREC 17 38 39 #define UPCASE 0 40 #define DOWNCASE 1 41 #define CAPITALIZE 2 42 43 #define INCDEPTH() \ 44 if (++info->depth > MAX_STACK_DEPTH / 2) \ 45 LispDestroy("stack overflow") 46 #define DECDEPTH() --info->depth 47 48 /* 49 * Types 50 */ 51 typedef struct _circle_info { 52 long circle_nth; /* nth circular list */ 53 LispObj *object; /* the circular object */ 54 } circle_info; 55 56 typedef struct _write_info { 57 long depth; 58 long level; /* current level */ 59 long length; /* current length */ 60 long print_level; /* *print-level* when started printing */ 61 long print_length; /* *print-length* when started printing */ 62 63 int print_escape; 64 int print_case; 65 66 long circle_count; 67 /* used while building circle info */ 68 LispObj **objects; 69 long num_objects; 70 /* the circular lists */ 71 circle_info *circles; 72 long num_circles; 73 } write_info; 74 75 /* 76 * Prototypes 77 */ 78 static void check_stream(LispObj*, LispFile**, LispString**, int); 79 static void parse_double(char*, int*, double, int); 80 static int float_string_inc(char*, int); 81 static void format_integer(char*, long, int); 82 static int LispWriteCPointer(LispObj*, void*); 83 static int LispWriteCString(LispObj*, char*, long, write_info*); 84 static int LispDoFormatExponentialFloat(LispObj*, LispObj*, 85 int, int, int*, int, int, 86 int, int, int, int); 87 88 static int LispWriteInteger(LispObj*, LispObj*); 89 static int LispWriteCharacter(LispObj*, LispObj*, write_info*); 90 static int LispWriteString(LispObj*, LispObj*, write_info*); 91 static int LispWriteFloat(LispObj*, LispObj*); 92 static int LispWriteAtom(LispObj*, LispObj*, write_info*); 93 static int LispDoWriteAtom(LispObj*, const char*, int, int); 94 static int LispWriteList(LispObj*, LispObj*, write_info*, int); 95 static int LispWriteArray(LispObj*, LispObj*, write_info*); 96 static int LispWriteStruct(LispObj*, LispObj*, write_info*); 97 static int LispDoWriteObject(LispObj*, LispObj*, write_info*, int); 98 static void LispBuildCircle(LispObj*, write_info*); 99 static void LispDoBuildCircle(LispObj*, write_info*); 100 static long LispCheckCircle(LispObj*, write_info*); 101 static int LispPrintCircle(LispObj*, LispObj*, long, int*, write_info*); 102 static int LispWriteAlist(LispObj*, LispArgList*, write_info*); 103 104 /* 105 * Initialization 106 */ 107 LispObj *Oprint_level, *Oprint_length, *Oprint_circle, 108 *Oprint_escape, *Oprint_case; 109 LispObj *Kupcase, *Kdowncase, *Kcapitalize; 110 111 /* 112 * Implementation 113 */ 114 void 115 LispWriteInit(void) 116 { 117 Oprint_level = STATIC_ATOM("*PRINT-LEVEL*"); 118 LispProclaimSpecial(Oprint_level, NIL, NIL); 119 LispExportSymbol(Oprint_level); 120 121 Oprint_length = STATIC_ATOM("*PRINT-LENGTH*"); 122 LispProclaimSpecial(Oprint_length, NIL, NIL); 123 LispExportSymbol(Oprint_length); 124 125 Oprint_circle = STATIC_ATOM("*PRINT-CIRCLE*"); 126 LispProclaimSpecial(Oprint_circle, T, NIL); 127 LispExportSymbol(Oprint_circle); 128 129 Oprint_escape = STATIC_ATOM("*PRINT-ESCAPE*"); 130 LispProclaimSpecial(Oprint_escape, T, NIL); 131 LispExportSymbol(Oprint_escape); 132 133 Kupcase = KEYWORD("UPCASE"); 134 Kdowncase = KEYWORD("DOWNCASE"); 135 Kcapitalize = KEYWORD("CAPITALIZE"); 136 Oprint_case = STATIC_ATOM("*PRINT-CASE*"); 137 LispProclaimSpecial(Oprint_case, Kupcase, NIL); 138 LispExportSymbol(Oprint_case); 139 } 140 141 LispObj * 142 Lisp_FreshLine(LispBuiltin *builtin) 143 /* 144 fresh-line &optional output-stream 145 */ 146 { 147 LispObj *output_stream; 148 149 output_stream = ARGUMENT(0); 150 151 if (output_stream == UNSPEC) 152 output_stream = NIL; 153 else if (output_stream != NIL) { 154 CHECK_STREAM(output_stream); 155 } 156 if (LispGetColumn(output_stream)) { 157 LispWriteChar(output_stream, '\n'); 158 if (output_stream == NIL || 159 (output_stream->data.stream.type == LispStreamStandard && 160 output_stream->data.stream.source.file == Stdout)) 161 LispFflush(Stdout); 162 return (T); 163 } 164 165 return (NIL); 166 } 167 168 LispObj * 169 Lisp_Prin1(LispBuiltin *builtin) 170 /* 171 prin1 object &optional output-stream 172 */ 173 { 174 LispObj *object, *output_stream; 175 176 output_stream = ARGUMENT(1); 177 object = ARGUMENT(0); 178 179 if (output_stream == UNSPEC) 180 output_stream = NIL; 181 LispPrint(object, output_stream, 0); 182 183 return (object); 184 } 185 186 LispObj * 187 Lisp_Princ(LispBuiltin *builtin) 188 /* 189 princ object &optional output-stream 190 */ 191 { 192 int head; 193 LispObj *object, *output_stream; 194 195 output_stream = ARGUMENT(1); 196 object = ARGUMENT(0); 197 198 if (output_stream == UNSPEC) 199 output_stream = NIL; 200 head = lisp__data.env.length; 201 LispAddVar(Oprint_escape, NIL); 202 ++lisp__data.env.head; 203 LispPrint(object, output_stream, 0); 204 lisp__data.env.head = lisp__data.env.length = head; 205 206 return (object); 207 } 208 209 LispObj * 210 Lisp_Print(LispBuiltin *builtin) 211 /* 212 print object &optional output-stream 213 */ 214 { 215 LispObj *object, *output_stream; 216 217 output_stream = ARGUMENT(1); 218 object = ARGUMENT(0); 219 220 if (output_stream == UNSPEC) 221 output_stream = NIL; 222 LispWriteChar(output_stream, '\n'); 223 LispPrint(object, output_stream, 0); 224 LispWriteChar(output_stream, ' '); 225 226 return (object); 227 } 228 229 LispObj * 230 Lisp_Terpri(LispBuiltin *builtin) 231 /* 232 terpri &optional output-stream 233 */ 234 { 235 LispObj *output_stream; 236 237 output_stream = ARGUMENT(0); 238 239 if (output_stream == UNSPEC) 240 output_stream = NIL; 241 else if (output_stream != NIL) { 242 CHECK_STREAM(output_stream); 243 } 244 LispWriteChar(output_stream, '\n'); 245 if (output_stream == NIL || 246 (output_stream->data.stream.type == LispStreamStandard && 247 output_stream->data.stream.source.file == Stdout)) 248 LispFflush(Stdout); 249 250 return (NIL); 251 } 252 253 LispObj * 254 Lisp_Write(LispBuiltin *builtin) 255 /* 256 write object &key case circle escape length level lines pretty readably right-margin stream 257 */ 258 { 259 int head = lisp__data.env.length; 260 261 LispObj *object, *ocase, *circle, *escape, *length, *level, *stream; 262 263 stream = ARGUMENT(10); 264 level = ARGUMENT(5); 265 length = ARGUMENT(4); 266 escape = ARGUMENT(3); 267 circle = ARGUMENT(2); 268 ocase = ARGUMENT(1); 269 object = ARGUMENT(0); 270 271 if (stream == UNSPEC) 272 stream = NIL; 273 else if (stream != NIL) { 274 CHECK_STREAM(stream); 275 } 276 277 /* prepare the printer environment */ 278 if (circle != UNSPEC) 279 LispAddVar(Oprint_circle, circle); 280 if (length != UNSPEC) 281 LispAddVar(Oprint_length, length); 282 if (level != UNSPEC) 283 LispAddVar(Oprint_level, level); 284 if (ocase != UNSPEC) 285 LispAddVar(Oprint_case, ocase); 286 if (escape != UNSPEC) 287 LispAddVar(Oprint_escape, escape); 288 289 lisp__data.env.head = lisp__data.env.length; 290 291 (void)LispWriteObject(stream, object); 292 293 lisp__data.env.head = lisp__data.env.length = head; 294 295 return (object); 296 } 297 298 LispObj * 299 Lisp_WriteChar(LispBuiltin *builtin) 300 /* 301 write-char character &optional output-stream 302 */ 303 { 304 int ch; 305 306 LispObj *character, *output_stream; 307 308 output_stream = ARGUMENT(1); 309 character = ARGUMENT(0); 310 311 if (output_stream == UNSPEC) 312 output_stream = NIL; 313 CHECK_SCHAR(character); 314 ch = SCHAR_VALUE(character); 315 316 LispWriteChar(output_stream, ch); 317 318 return (character); 319 } 320 321 LispObj * 322 Lisp_WriteLine(LispBuiltin *builtin) 323 /* 324 write-line string &optional output-stream &key start end 325 */ 326 { 327 return (LispWriteString_(builtin, 1)); 328 } 329 330 LispObj * 331 Lisp_WriteString(LispBuiltin *builtin) 332 /* 333 write-string string &optional output-stream &key start end 334 */ 335 { 336 return (LispWriteString_(builtin, 0)); 337 } 338 339 340 int 341 LispWriteObject(LispObj *stream, LispObj *object) 342 { 343 write_info info; 344 int bytes; 345 LispObj *level, *length, *circle, *oescape, *ocase; 346 347 /* current state */ 348 info.depth = info.level = info.length = 0; 349 350 /* maximum level to descend */ 351 level = LispGetVar(Oprint_level); 352 if (level && INDEXP(level)) 353 info.print_level = FIXNUM_VALUE(level); 354 else 355 info.print_level = -1; 356 357 /* maximum list length */ 358 length = LispGetVar(Oprint_length); 359 if (length && INDEXP(length)) 360 info.print_length = FIXNUM_VALUE(length); 361 else 362 info.print_length = -1; 363 364 /* detect circular/shared objects? */ 365 circle = LispGetVar(Oprint_circle); 366 info.circle_count = 0; 367 info.objects = NULL; 368 info.num_objects = 0; 369 info.circles = NULL; 370 info.num_circles = 0; 371 if (circle && circle != NIL) { 372 LispBuildCircle(object, &info); 373 /* free this data now */ 374 if (info.num_objects) { 375 LispFree(info.objects); 376 info.num_objects = 0; 377 } 378 } 379 380 /* escape characters and strings? */ 381 oescape = LispGetVar(Oprint_escape); 382 if (oescape != NULL) 383 info.print_escape = oescape == NIL; 384 else 385 info.print_escape = -1; 386 387 /* don't use the default case printing? */ 388 ocase = LispGetVar(Oprint_case); 389 if (ocase == Kdowncase) 390 info.print_case = DOWNCASE; 391 else if (ocase == Kcapitalize) 392 info.print_case = CAPITALIZE; 393 else 394 info.print_case = UPCASE; 395 396 bytes = LispDoWriteObject(stream, object, &info, 1); 397 if (circle && circle != NIL && info.num_circles) 398 LispFree(info.circles); 399 400 return (bytes); 401 } 402 403 static void 404 LispBuildCircle(LispObj *object, write_info *info) 405 { 406 LispObj *list; 407 408 switch (OBJECT_TYPE(object)) { 409 case LispCons_t: 410 LispDoBuildCircle(object, info); 411 break; 412 case LispArray_t: 413 /* Currently arrays are implemented as lists, but only 414 * the elements could/should be circular */ 415 if (LispCheckCircle(object, info) >= 0) 416 return; 417 LispDoBuildCircle(object, info); 418 for (list = object->data.array.list; 419 CONSP(list); list = CDR(list)) 420 LispBuildCircle(CAR(list), info); 421 break; 422 case LispStruct_t: 423 /* Like arrays, structs are currently implemented as lists, 424 * but only the elements could/should be circular */ 425 if (LispCheckCircle(object, info) >= 0) 426 return; 427 LispDoBuildCircle(object, info); 428 for (list = object->data.struc.fields; 429 CONSP(list); list = CDR(list)) 430 LispBuildCircle(CAR(list), info); 431 break; 432 case LispQuote_t: 433 case LispBackquote_t: 434 case LispFunctionQuote_t: 435 LispDoBuildCircle(object, info); 436 LispBuildCircle(object->data.quote, info); 437 break; 438 case LispComma_t: 439 LispDoBuildCircle(object, info); 440 LispBuildCircle(object->data.comma.eval, info); 441 break; 442 case LispLambda_t: 443 /* Circularity in a function body should fail elsewhere... */ 444 if (LispCheckCircle(object, info) >= 0) 445 return; 446 LispDoBuildCircle(object, info); 447 LispBuildCircle(object->data.lambda.code, info); 448 break; 449 default: 450 break; 451 } 452 } 453 454 static void 455 LispDoBuildCircle(LispObj *object, write_info *info) 456 { 457 long i; 458 459 if (LispCheckCircle(object, info) >= 0) 460 return; 461 462 for (i = 0; i < info->num_objects; i++) 463 if (info->objects[i] == object) { 464 /* circularity found */ 465 info->circles = LispRealloc(info->circles, sizeof(circle_info) * 466 (info->num_circles + 1)); 467 info->circles[info->num_circles].circle_nth = 0; 468 info->circles[info->num_circles].object = object; 469 ++info->num_circles; 470 return; 471 } 472 473 /* object pointer not yet recorded */ 474 if ((i % 16) == 0) 475 info->objects = LispRealloc(info->objects, sizeof(LispObj*) * 476 (info->num_objects + 16)); 477 info->objects[info->num_objects++] = object; 478 479 if (CONSP(object)) { 480 if (CONSP(CAR(object))) 481 LispDoBuildCircle(CAR(object), info); 482 else 483 LispBuildCircle(CAR(object), info); 484 if (CONSP(CDR(object))) 485 LispDoBuildCircle(CDR(object), info); 486 else 487 LispBuildCircle(CDR(object), info); 488 } 489 } 490 491 static long 492 LispCheckCircle(LispObj *object, write_info *info) 493 { 494 long i; 495 496 for (i = 0; i < info->num_circles; i++) 497 if (info->circles[i].object == object) 498 return (i); 499 500 return (-1); 501 } 502 503 static int 504 LispPrintCircle(LispObj *stream, LispObj *object, long circle, 505 int *length, write_info *info) 506 { 507 char stk[32]; 508 509 if (!info->circles[circle].circle_nth) { 510 sprintf(stk, "#%ld=", ++info->circle_count); 511 *length += LispWriteStr(stream, stk, strlen(stk)); 512 info->circles[circle].circle_nth = info->circle_count; 513 514 return (1); 515 } 516 sprintf(stk, "#%ld#", info->circles[circle].circle_nth); 517 *length += LispWriteStr(stream, stk, strlen(stk)); 518 519 return (0); 520 } 521 522 static int 523 LispWriteAlist(LispObj *stream, LispArgList *alist, write_info *info) 524 { 525 Atom_id name; 526 int i, length = 0, need_space = 0; 527 528 #define WRITE_ATOM(object) \ 529 name = ATOMID(object); \ 530 length += LispDoWriteAtom(stream, name->value, name->length, \ 531 info->print_case) 532 #define WRITE_ATOMID(atomid) \ 533 length += LispDoWriteAtom(stream, atomid->value, atomid->length, \ 534 info->print_case) 535 #define WRITE_OBJECT(object) \ 536 length += LispDoWriteObject(stream, object, info, 1) 537 #define WRITE_OPAREN() \ 538 length += LispWriteChar(stream, '(') 539 #define WRITE_SPACE() \ 540 length += LispWriteChar(stream, ' ') 541 #define WRITE_CPAREN() \ 542 length += LispWriteChar(stream, ')') 543 544 WRITE_OPAREN(); 545 for (i = 0; i < alist->normals.num_symbols; i++) { 546 WRITE_ATOM(alist->normals.symbols[i]); 547 if (i + 1 < alist->normals.num_symbols) 548 WRITE_SPACE(); 549 else 550 need_space = 1; 551 } 552 if (alist->optionals.num_symbols) { 553 if (need_space) 554 WRITE_SPACE(); 555 WRITE_ATOMID(Soptional); 556 WRITE_SPACE(); 557 for (i = 0; i < alist->optionals.num_symbols; i++) { 558 WRITE_OPAREN(); 559 WRITE_ATOM(alist->optionals.symbols[i]); 560 WRITE_SPACE(); 561 WRITE_OBJECT(alist->optionals.defaults[i]); 562 if (alist->optionals.sforms[i]) { 563 WRITE_SPACE(); 564 WRITE_ATOM(alist->optionals.sforms[i]); 565 } 566 WRITE_CPAREN(); 567 if (i + 1 < alist->optionals.num_symbols) 568 WRITE_SPACE(); 569 } 570 need_space = 1; 571 } 572 if (alist->keys.num_symbols) { 573 if (need_space) 574 WRITE_SPACE(); 575 length += LispDoWriteAtom(stream, Skey->value, 4, info->print_case); 576 WRITE_SPACE(); 577 for (i = 0; i < alist->keys.num_symbols; i++) { 578 WRITE_OPAREN(); 579 if (alist->keys.keys[i]) { 580 WRITE_OPAREN(); 581 WRITE_ATOM(alist->keys.keys[i]); 582 WRITE_SPACE(); 583 } 584 WRITE_ATOM(alist->keys.symbols[i]); 585 if (alist->keys.keys[i]) 586 WRITE_CPAREN(); 587 WRITE_SPACE(); 588 WRITE_OBJECT(alist->keys.defaults[i]); 589 if (alist->keys.sforms[i]) { 590 WRITE_SPACE(); 591 WRITE_ATOM(alist->keys.sforms[i]); 592 } 593 WRITE_CPAREN(); 594 if (i + 1 < alist->keys.num_symbols) 595 WRITE_SPACE(); 596 } 597 need_space = 1; 598 } 599 if (alist->rest) { 600 if (need_space) 601 WRITE_SPACE(); 602 WRITE_ATOMID(Srest); 603 WRITE_SPACE(); 604 WRITE_ATOM(alist->rest); 605 need_space = 1; 606 } 607 if (alist->auxs.num_symbols) { 608 if (need_space) 609 WRITE_SPACE(); 610 WRITE_ATOMID(Saux); 611 WRITE_SPACE(); 612 for (i = 0; i < alist->auxs.num_symbols; i++) { 613 WRITE_OPAREN(); 614 WRITE_ATOM(alist->auxs.symbols[i]); 615 WRITE_SPACE(); 616 WRITE_OBJECT(alist->auxs.initials[i]); 617 WRITE_CPAREN(); 618 if (i + 1 < alist->auxs.num_symbols) 619 WRITE_SPACE(); 620 } 621 } 622 WRITE_CPAREN(); 623 624 #undef WRITE_ATOM 625 #undef WRITE_ATOMID 626 #undef WRITE_OBJECT 627 #undef WRITE_OPAREN 628 #undef WRITE_SPACE 629 #undef WRITE_CPAREN 630 631 return (length); 632 } 633 634 static void 635 check_stream(LispObj *stream, 636 LispFile **file, LispString **string, int check_writable) 637 { 638 /* NIL is UNIX stdout, *STANDARD-OUTPUT* may not be UNIX stdout */ 639 if (stream == NIL) { 640 *file = Stdout; 641 *string = NULL; 642 } 643 else { 644 if (!STREAMP(stream)) 645 LispDestroy("%s is not a stream", STROBJ(stream)); 646 if (check_writable && !stream->data.stream.writable) 647 LispDestroy("%s is not writable", STROBJ(stream)); 648 else if (stream->data.stream.type == LispStreamString) { 649 *string = SSTREAMP(stream); 650 *file = NULL; 651 } 652 else { 653 if (stream->data.stream.type == LispStreamPipe) 654 *file = OPSTREAMP(stream); 655 else 656 *file = stream->data.stream.source.file; 657 *string = NULL; 658 } 659 } 660 } 661 662 /* Assumes buffer has enough storage, 64 bytes should be more than enough */ 663 static void 664 parse_double(char *buffer, int *exponent, double value, int d) 665 { 666 char stk[64], fmt[32], *ptr, *fract = NULL; 667 int positive = value >= 0.0; 668 669 parse_double_again: 670 if (d >= 8) { 671 double dcheck; 672 int icheck, count; 673 674 /* this should to do the correct rounding */ 675 for (count = 2; count >= 0; count--) { 676 icheck = d <= 0 ? 0 : d > FLOAT_PREC ? FLOAT_PREC - count : d - count; 677 sprintf(fmt, "%%.%de", icheck); 678 sprintf(stk, fmt, value); 679 if (count) { 680 /* if the value read back is the same formatted */ 681 sscanf(stk, "%lf", &dcheck); 682 if (dcheck == value) 683 break; 684 } 685 } 686 } 687 else { 688 sprintf(fmt, "%%.%de", d <= 0 ? 0 : d > FLOAT_PREC ? FLOAT_PREC : d); 689 sprintf(stk, fmt, value); 690 } 691 692 /* this "should" never fail */ 693 ptr = strchr(stk, 'e'); 694 if (ptr) { 695 *ptr++ = '\0'; 696 *exponent = atoi(ptr); 697 } 698 else 699 *exponent = 0; 700 701 /* find start of number representation */ 702 for (ptr = stk; *ptr && !isdigit(*ptr); ptr++) 703 ; 704 705 /* check if did not trim any significant digit, 706 * this may happen because '%.e' puts only one digit before the '.' */ 707 if (d > 0 && d < FLOAT_PREC && fabs(value) >= 10.0 && 708 strlen(ptr) - 1 - !positive <= *exponent) { 709 d += *exponent - (strlen(ptr) - 1 - !positive) + 1; 710 goto parse_double_again; 711 } 712 713 /* this "should" never fail */ 714 fract = strchr(ptr, '.'); 715 if (fract) 716 *fract++ = '\0'; 717 718 /* store number representation in buffer */ 719 *buffer = positive ? '+' : '-'; 720 strcpy(buffer + 1, ptr); 721 if (fract) 722 strcpy(buffer + strlen(buffer), fract); 723 } 724 725 static void 726 format_integer(char *buffer, long value, int radix) 727 { 728 if (radix == 10) 729 sprintf(buffer, "%ld", value); 730 else if (radix == 16) 731 sprintf(buffer, "%lx", value); 732 else if (radix == 8) 733 sprintf(buffer, "%lo", value); 734 else { 735 /* use bignum routine to convert number to string */ 736 mpi integer; 737 738 mpi_init(&integer); 739 mpi_seti(&integer, value); 740 mpi_getstr(buffer, &integer, radix); 741 mpi_clear(&integer); 742 } 743 } 744 745 static int 746 LispWriteCPointer(LispObj *stream, void *data) 747 { 748 char stk[32]; 749 750 #ifdef LONG64 751 sprintf(stk, "0x%016lx", (long)data); 752 #else 753 sprintf(stk, "0x%08lx", (long)data); 754 #endif 755 756 return (LispWriteStr(stream, stk, strlen(stk))); 757 } 758 759 static int 760 LispWriteCString(LispObj *stream, char *string, long length, write_info *info) 761 { 762 int result; 763 764 if (!info->print_escape) { 765 char *base, *ptr, *end; 766 767 result = LispWriteChar(stream, '"'); 768 for (base = ptr = string, end = string + length; ptr < end; ptr++) { 769 if (*ptr == '\\' || *ptr == '"') { 770 result += LispWriteStr(stream, base, ptr - base); 771 result += LispWriteChar(stream, '\\'); 772 result += LispWriteChar(stream, *ptr); 773 base = ptr + 1; 774 } 775 } 776 result += LispWriteStr(stream, base, end - base); 777 result += LispWriteChar(stream, '"'); 778 } 779 else 780 result = LispWriteStr(stream, string, length); 781 782 return (result); 783 } 784 785 static int 786 LispWriteList(LispObj *stream, LispObj *object, write_info *info, int paren) 787 { 788 int length = 0; 789 long circle = 0; 790 791 INCDEPTH(); 792 if (info->print_level < 0 || info->level <= info->print_level) { 793 LispObj *car, *cdr; 794 long print_length = info->length; 795 796 if (info->circles && (circle = LispCheckCircle(object, info)) >= 0) { 797 if (!paren) { 798 length += LispWriteStr(stream, ". ", 2); 799 paren = 1; 800 } 801 if (LispPrintCircle(stream, object, circle, &length, info) == 0) { 802 DECDEPTH(); 803 804 return (length); 805 } 806 } 807 808 car = CAR(object); 809 cdr = CDR(object); 810 811 if (cdr == NIL) { 812 if (paren) 813 length += LispWriteChar(stream, '('); 814 if (info->print_length < 0 || info->length < info->print_length) { 815 info->length = 0; 816 length += LispDoWriteObject(stream, car, info, 1); 817 info->length = print_length + 1; 818 } 819 else 820 length += LispWriteStr(stream, "...", 3); 821 if (paren) 822 length += LispWriteChar(stream, ')'); 823 } 824 else { 825 if (paren) 826 length += LispWriteChar(stream, '('); 827 if (info->print_length < 0 || info->length < info->print_length) { 828 info->length = 0; 829 length += LispDoWriteObject(stream, car, info, 1); 830 info->length = print_length + 1; 831 if (!CONSP(cdr)) { 832 length += LispWriteStr(stream, " . ", 3); 833 info->length = 0; 834 length += LispDoWriteObject(stream, cdr, info, 0); 835 } 836 else { 837 length += LispWriteChar(stream, ' '); 838 if (info->print_length < 0 || 839 info->length < info->print_length) 840 length += LispWriteList(stream, cdr, info, 0); 841 else 842 length += LispWriteStr(stream, "...", 3); 843 } 844 } 845 else 846 length += LispWriteStr(stream, "...", 3); 847 if (paren) 848 length += LispWriteChar(stream, ')'); 849 } 850 info->length = print_length; 851 } 852 else 853 length += LispWriteChar(stream, '#'); 854 DECDEPTH(); 855 856 return (length); 857 } 858 859 static int 860 LispDoWriteObject(LispObj *stream, LispObj *object, write_info *info, int paren) 861 { 862 long print_level; 863 int length = 0; 864 char stk[64]; 865 const char *string = NULL; 866 867 write_again: 868 switch (OBJECT_TYPE(object)) { 869 case LispNil_t: 870 if (object == NIL) 871 string = Snil->value; 872 else if (object == T) 873 string = St->value; 874 else if (object == DOT) 875 string = "#<DOT>"; 876 else if (object == UNSPEC) 877 string = "#<UNSPEC>"; 878 else if (object == UNBOUND) 879 string = "#<UNBOUND>"; 880 else 881 string = "#<ERROR>"; 882 length += LispDoWriteAtom(stream, string, strlen(string), 883 info->print_case); 884 break; 885 case LispOpaque_t: { 886 char *desc = LispIntToOpaqueType(object->data.opaque.type); 887 888 length += LispWriteChar(stream, '#'); 889 length += LispWriteCPointer(stream, object->data.opaque.data); 890 length += LispWriteStr(stream, desc, strlen(desc)); 891 } break; 892 case LispAtom_t: 893 length += LispWriteAtom(stream, object, info); 894 break; 895 case LispFunction_t: 896 if (object->data.atom->a_function) { 897 object = object->data.atom->property->fun.function; 898 goto write_lambda; 899 } 900 length += LispWriteStr(stream, "#<", 2); 901 if (object->data.atom->a_compiled) 902 LispDoWriteAtom(stream, "COMPILED", 8, info->print_case); 903 else if (object->data.atom->a_builtin) 904 LispDoWriteAtom(stream, "BUILTIN", 7, info->print_case); 905 /* XXX the function does not exist anymore */ 906 /* FIXME not sure if I want this fixed... */ 907 else 908 LispDoWriteAtom(stream, "UNBOUND", 7, info->print_case); 909 LispDoWriteAtom(stream, "-FUNCTION", 9, info->print_case); 910 length += LispWriteChar(stream, ' '); 911 length += LispWriteAtom(stream, object->data.atom->object, info); 912 length += LispWriteChar(stream, '>'); 913 break; 914 case LispString_t: 915 length += LispWriteString(stream, object, info); 916 break; 917 case LispSChar_t: 918 length += LispWriteCharacter(stream, object, info); 919 break; 920 case LispDFloat_t: 921 length += LispWriteFloat(stream, object); 922 break; 923 case LispFixnum_t: 924 case LispInteger_t: 925 case LispBignum_t: 926 length += LispWriteInteger(stream, object); 927 break; 928 case LispRatio_t: 929 format_integer(stk, object->data.ratio.numerator, 10); 930 length += LispWriteStr(stream, stk, strlen(stk)); 931 length += LispWriteChar(stream, '/'); 932 format_integer(stk, object->data.ratio.denominator, 10); 933 length += LispWriteStr(stream, stk, strlen(stk)); 934 break; 935 case LispBigratio_t: { 936 int sz; 937 char *ptr; 938 939 sz = mpi_getsize(mpr_num(object->data.mp.ratio), 10) + 1 + 940 mpi_getsize(mpr_den(object->data.mp.ratio), 10) + 1 + 941 (mpi_sgn(mpr_num(object->data.mp.ratio)) < 0); 942 if (sz > sizeof(stk)) 943 ptr = LispMalloc(sz); 944 else 945 ptr = stk; 946 mpr_getstr(ptr, object->data.mp.ratio, 10); 947 length += LispWriteStr(stream, ptr, sz - 1); 948 if (ptr != stk) 949 LispFree(ptr); 950 } break; 951 case LispComplex_t: 952 length += LispWriteStr(stream, "#C(", 3); 953 length += LispDoWriteObject(stream, 954 object->data.complex.real, info, 0); 955 length += LispWriteChar(stream, ' '); 956 length += LispDoWriteObject(stream, 957 object->data.complex.imag, info, 0); 958 length += LispWriteChar(stream, ')'); 959 break; 960 case LispCons_t: 961 print_level = info->level; 962 ++info->level; 963 length += LispWriteList(stream, object, info, paren); 964 info->level = print_level; 965 break; 966 case LispQuote_t: 967 length += LispWriteChar(stream, '\''); 968 paren = 1; 969 object = object->data.quote; 970 goto write_again; 971 case LispBackquote_t: 972 length += LispWriteChar(stream, '`'); 973 paren = 1; 974 object = object->data.quote; 975 goto write_again; 976 case LispComma_t: 977 if (object->data.comma.atlist) 978 length += LispWriteStr(stream, ",@", 2); 979 else 980 length += LispWriteChar(stream, ','); 981 paren = 1; 982 object = object->data.comma.eval; 983 goto write_again; 984 break; 985 case LispFunctionQuote_t: 986 length += LispWriteStr(stream, "#'", 2); 987 paren = 1; 988 object = object->data.quote; 989 goto write_again; 990 case LispArray_t: 991 length += LispWriteArray(stream, object, info); 992 break; 993 case LispStruct_t: 994 length += LispWriteStruct(stream, object, info); 995 break; 996 case LispLambda_t: 997 write_lambda: 998 switch (object->funtype) { 999 case LispLambda: 1000 string = "#<LAMBDA "; 1001 break; 1002 case LispFunction: 1003 string = "#<FUNCTION "; 1004 break; 1005 case LispMacro: 1006 string = "#<MACRO "; 1007 break; 1008 case LispSetf: 1009 string = "#<SETF "; 1010 break; 1011 } 1012 length += LispDoWriteAtom(stream, string, strlen(string), 1013 info->print_case); 1014 if (object->funtype != LispLambda) { 1015 length += LispWriteAtom(stream, object->data.lambda.name, info); 1016 length += LispWriteChar(stream, ' '); 1017 length += LispWriteAlist(stream, object->data.lambda.name 1018 ->data.atom->property->alist, info); 1019 } 1020 else { 1021 length += LispDoWriteAtom(stream, "NIL", 3, info->print_case); 1022 length += LispWriteChar(stream, ' '); 1023 length += LispWriteAlist(stream, (LispArgList*)object-> 1024 data.lambda.name->data.opaque.data, 1025 info); 1026 } 1027 length += LispWriteChar(stream, ' '); 1028 length += LispDoWriteObject(stream, 1029 object->data.lambda.code, info, 0); 1030 length += LispWriteChar(stream, '>'); 1031 break; 1032 case LispStream_t: 1033 length += LispWriteStr(stream, "#<", 2); 1034 if (object->data.stream.type == LispStreamFile) 1035 string = "FILE-STREAM "; 1036 else if (object->data.stream.type == LispStreamString) 1037 string = "STRING-STREAM "; 1038 else if (object->data.stream.type == LispStreamStandard) 1039 string = "STANDARD-STREAM "; 1040 else if (object->data.stream.type == LispStreamPipe) 1041 string = "PIPE-STREAM "; 1042 length += LispDoWriteAtom(stream, string, strlen(string), 1043 info->print_case); 1044 1045 if (!object->data.stream.readable && !object->data.stream.writable) 1046 length += LispDoWriteAtom(stream, "CLOSED", 1047 6, info->print_case); 1048 else { 1049 if (object->data.stream.readable) 1050 length += LispDoWriteAtom(stream, "READ", 1051 4, info->print_case); 1052 if (object->data.stream.writable) { 1053 if (object->data.stream.readable) 1054 length += LispWriteChar(stream, '-'); 1055 length += LispDoWriteAtom(stream, "WRITE", 1056 5, info->print_case); 1057 } 1058 } 1059 if (object->data.stream.type != LispStreamString) { 1060 length += LispWriteChar(stream, ' '); 1061 length += LispDoWriteObject(stream, 1062 object->data.stream.pathname, 1063 info, 1); 1064 /* same address/size for pipes */ 1065 length += LispWriteChar(stream, ' '); 1066 length += LispWriteCPointer(stream, 1067 object->data.stream.source.file); 1068 if (object->data.stream.readable && 1069 object->data.stream.type == LispStreamFile && 1070 !object->data.stream.source.file->binary) { 1071 length += LispWriteStr(stream, " @", 2); 1072 format_integer(stk, object->data.stream.source.file->line, 10); 1073 length += LispWriteStr(stream, stk, strlen(stk)); 1074 } 1075 } 1076 length += LispWriteChar(stream, '>'); 1077 break; 1078 case LispPathname_t: 1079 length += LispWriteStr(stream, "#P", 2); 1080 paren = 1; 1081 object = CAR(object->data.quote); 1082 goto write_again; 1083 case LispPackage_t: 1084 length += LispDoWriteAtom(stream, "#<PACKAGE ", 1085 10, info->print_case); 1086 length += LispWriteStr(stream, 1087 THESTR(object->data.package.name), 1088 STRLEN(object->data.package.name)); 1089 length += LispWriteChar(stream, '>'); 1090 break; 1091 case LispRegex_t: 1092 length += LispDoWriteAtom(stream, "#<REGEX ", 1093 8, info->print_case); 1094 length += LispDoWriteObject(stream, 1095 object->data.regex.pattern, info, 1); 1096 if (object->data.regex.options & RE_NOSPEC) 1097 length += LispDoWriteAtom(stream, " :NOSPEC", 1098 8, info->print_case); 1099 if (object->data.regex.options & RE_ICASE) 1100 length += LispDoWriteAtom(stream, " :ICASE", 1101 7, info->print_case); 1102 if (object->data.regex.options & RE_NOSUB) 1103 length += LispDoWriteAtom(stream, " :NOSUB", 1104 7, info->print_case); 1105 if (object->data.regex.options & RE_NEWLINE) 1106 length += LispDoWriteAtom(stream, " :NEWLINE", 1107 9, info->print_case); 1108 length += LispWriteChar(stream, '>'); 1109 break; 1110 case LispBytecode_t: 1111 length += LispDoWriteAtom(stream, "#<BYTECODE ", 1112 11, info->print_case); 1113 length += LispWriteCPointer(stream, 1114 object->data.bytecode.bytecode); 1115 length += LispWriteChar(stream, '>'); 1116 break; 1117 case LispHashTable_t: 1118 length += LispDoWriteAtom(stream, "#<HASH-TABLE ", 1119 13, info->print_case); 1120 length += LispWriteAtom(stream, object->data.hash.test, info); 1121 snprintf(stk, sizeof(stk), " %g %g", 1122 object->data.hash.table->rehash_size, 1123 object->data.hash.table->rehash_threshold); 1124 length += LispWriteStr(stream, stk, strlen(stk)); 1125 snprintf(stk, sizeof(stk), " %ld/%ld>", 1126 object->data.hash.table->count, 1127 object->data.hash.table->num_entries); 1128 length += LispWriteStr(stream, stk, strlen(stk)); 1129 break; 1130 } 1131 1132 return (length); 1133 } 1134 1135 /* return current column number in stream */ 1136 int 1137 LispGetColumn(LispObj *stream) 1138 { 1139 LispFile *file; 1140 LispString *string; 1141 1142 check_stream(stream, &file, &string, 0); 1143 if (file != NULL) 1144 return (file->column); 1145 return (string->column); 1146 } 1147 1148 /* write a character to stream */ 1149 int 1150 LispWriteChar(LispObj *stream, int character) 1151 { 1152 LispFile *file; 1153 LispString *string; 1154 1155 check_stream(stream, &file, &string, 1); 1156 if (file != NULL) 1157 return (LispFputc(file, character)); 1158 1159 return (LispSputc(string, character)); 1160 } 1161 1162 /* write a character count times to stream */ 1163 int 1164 LispWriteChars(LispObj *stream, int character, int count) 1165 { 1166 int length = 0; 1167 1168 if (count > 0) { 1169 char stk[64]; 1170 LispFile *file; 1171 LispString *string; 1172 1173 check_stream(stream, &file, &string, 1); 1174 if (count >= sizeof(stk)) { 1175 memset(stk, character, sizeof(stk)); 1176 for (; count >= sizeof(stk); count -= sizeof(stk)) { 1177 if (file != NULL) 1178 length += LispFwrite(file, stk, sizeof(stk)); 1179 else 1180 length += LispSwrite(string, stk, sizeof(stk)); 1181 } 1182 } 1183 else 1184 memset(stk, character, count); 1185 1186 if (count) { 1187 if (file != NULL) 1188 length += LispFwrite(file, stk, count); 1189 else 1190 length += LispSwrite(string, stk, count); 1191 } 1192 } 1193 1194 return (length); 1195 } 1196 1197 /* write a string to stream */ 1198 int 1199 LispWriteStr(LispObj *stream, const char *buffer, long length) 1200 { 1201 LispFile *file; 1202 LispString *string; 1203 1204 check_stream(stream, &file, &string, 1); 1205 if (file != NULL) 1206 return (LispFwrite(file, buffer, length)); 1207 return (LispSwrite(string, buffer, length)); 1208 } 1209 1210 static int 1211 LispDoWriteAtom(LispObj *stream, const char *string, int length, int print_case) 1212 { 1213 int bytes = 0, cap = 0; 1214 char buffer[128], *ptr; 1215 1216 switch (print_case) { 1217 case DOWNCASE: 1218 for (ptr = buffer; length > 0; length--, string++) { 1219 if (isupper(*string)) 1220 *ptr = tolower(*string); 1221 else 1222 *ptr = *string; 1223 ++ptr; 1224 if (ptr - buffer >= sizeof(buffer)) { 1225 bytes += LispWriteStr(stream, buffer, ptr - buffer); 1226 ptr = buffer; 1227 } 1228 } 1229 if (ptr > buffer) 1230 bytes += LispWriteStr(stream, buffer, ptr - buffer); 1231 break; 1232 case CAPITALIZE: 1233 for (ptr = buffer; length > 0; length--, string++) { 1234 if (isalnum(*string)) { 1235 if (cap && isupper(*string)) 1236 *ptr = tolower(*string); 1237 else 1238 *ptr = *string; 1239 cap = 1; 1240 } 1241 else { 1242 *ptr = *string; 1243 cap = 0; 1244 } 1245 ++ptr; 1246 if (ptr - buffer >= sizeof(buffer)) { 1247 bytes += LispWriteStr(stream, buffer, ptr - buffer); 1248 ptr = buffer; 1249 } 1250 } 1251 if (ptr > buffer) 1252 bytes += LispWriteStr(stream, buffer, ptr - buffer); 1253 break; 1254 default: 1255 /* Strings are already stored upcase/quoted */ 1256 bytes += LispWriteStr(stream, string, length); 1257 break; 1258 } 1259 1260 return (bytes); 1261 } 1262 1263 static int 1264 LispWriteAtom(LispObj *stream, LispObj *object, write_info *info) 1265 { 1266 int length = 0; 1267 LispAtom *atom = object->data.atom; 1268 Atom_id id = atom->key; 1269 1270 if (atom->package != PACKAGE) { 1271 if (atom->package == lisp__data.keyword) 1272 length += LispWriteChar(stream, ':'); 1273 else if (atom->package == NULL) 1274 length += LispWriteStr(stream, "#:", 2); 1275 else { 1276 /* Check if the symbol is visible */ 1277 int i, visible = 0; 1278 1279 if (atom->ext) { 1280 for (i = lisp__data.pack->use.length - 1; i >= 0; i--) { 1281 if (lisp__data.pack->use.pairs[i] == atom->package) { 1282 visible = 1; 1283 break; 1284 } 1285 } 1286 } 1287 1288 if (!visible) { 1289 /* XXX this assumes that package names are always "readable" */ 1290 length += 1291 LispDoWriteAtom(stream, 1292 THESTR(atom->package->data.package.name), 1293 STRLEN(atom->package->data.package.name), 1294 info->print_case); 1295 length += LispWriteChar(stream, ':'); 1296 if (!atom->ext) 1297 length += LispWriteChar(stream, ':'); 1298 } 1299 } 1300 } 1301 if (atom->unreadable) 1302 length += LispWriteChar(stream, '|'); 1303 length += LispDoWriteAtom(stream, id->value, id->length, 1304 atom->unreadable ? UPCASE : info->print_case); 1305 if (atom->unreadable) 1306 length += LispWriteChar(stream, '|'); 1307 1308 return (length); 1309 } 1310 1311 static int 1312 LispWriteInteger(LispObj *stream, LispObj *object) 1313 { 1314 return (LispFormatInteger(stream, object, 10, 0, 0, 0, 0, 0, 0)); 1315 } 1316 1317 static int 1318 LispWriteCharacter(LispObj *stream, LispObj *object, write_info *info) 1319 { 1320 return (LispFormatCharacter(stream, object, !info->print_escape, 0)); 1321 } 1322 1323 static int 1324 LispWriteString(LispObj *stream, LispObj *object, write_info *info) 1325 { 1326 return (LispWriteCString(stream, THESTR(object), STRLEN(object), info)); 1327 } 1328 1329 static int 1330 LispWriteFloat(LispObj *stream, LispObj *object) 1331 { 1332 double value = DFLOAT_VALUE(object); 1333 1334 if (value == 0.0 || (fabs(value) < 1.0E7 && fabs(value) > 1.0E-4)) 1335 return (LispFormatFixedFloat(stream, object, 0, 0, NULL, 0, 0, 0)); 1336 1337 return (LispDoFormatExponentialFloat(stream, object, 0, 0, NULL, 1338 0, 1, 0, ' ', 'E', 0)); 1339 } 1340 1341 static int 1342 LispWriteArray(LispObj *stream, LispObj *object, write_info *info) 1343 { 1344 int length = 0; 1345 long print_level = info->level, circle; 1346 1347 if (info->circles && (circle = LispCheckCircle(object, info)) >= 0 && 1348 LispPrintCircle(stream, object, circle, &length, info) == 0) 1349 return (length); 1350 1351 if (object->data.array.rank == 0) { 1352 length += LispWriteStr(stream, "#0A", 3); 1353 length += LispDoWriteObject(stream, object->data.array.list, info, 1); 1354 return (length); 1355 } 1356 1357 INCDEPTH(); 1358 ++info->level; 1359 if (info->print_level < 0 || info->level <= info->print_level) { 1360 if (object->data.array.rank == 1) 1361 length += LispWriteStr(stream, "#(", 2); 1362 else { 1363 char stk[32]; 1364 1365 format_integer(stk, object->data.array.rank, 10); 1366 length += LispWriteChar(stream, '#'); 1367 length += LispWriteStr(stream, stk, strlen(stk)); 1368 length += LispWriteStr(stream, "A(", 2); 1369 } 1370 1371 if (!object->data.array.zero) { 1372 long print_length = info->length, local_length = 0; 1373 1374 if (object->data.array.rank == 1) { 1375 LispObj *ary; 1376 long count; 1377 1378 for (ary = object->data.array.dim, count = 1; 1379 ary != NIL; ary = CDR(ary)) 1380 count *= FIXNUM_VALUE(CAR(ary)); 1381 for (ary = object->data.array.list; count > 0; 1382 ary = CDR(ary), count--) { 1383 if (info->print_length < 0 || 1384 ++local_length <= info->print_length) { 1385 info->length = 0; 1386 length += LispDoWriteObject(stream, CAR(ary), info, 1); 1387 } 1388 else { 1389 length += LispWriteStr(stream, "...", 3); 1390 break; 1391 } 1392 if (count - 1 > 0) 1393 length += LispWriteChar(stream, ' '); 1394 } 1395 } 1396 else { 1397 LispObj *ary; 1398 int i, k, rank, *dims, *loop; 1399 1400 rank = object->data.array.rank; 1401 dims = LispMalloc(sizeof(int) * rank); 1402 loop = LispCalloc(1, sizeof(int) * (rank - 1)); 1403 1404 /* fill dim */ 1405 for (i = 0, ary = object->data.array.dim; ary != NIL; 1406 i++, ary = CDR(ary)) 1407 dims[i] = FIXNUM_VALUE(CAR(ary)); 1408 1409 i = 0; 1410 ary = object->data.array.list; 1411 while (loop[0] < dims[0]) { 1412 if (info->print_length < 0 || 1413 local_length < info->print_length) { 1414 for (; i < rank - 1; i++) 1415 length += LispWriteChar(stream, '('); 1416 --i; 1417 for (;;) { 1418 ++loop[i]; 1419 if (i && loop[i] >= dims[i]) 1420 loop[i] = 0; 1421 else 1422 break; 1423 --i; 1424 } 1425 for (k = 0; k < dims[rank - 1] - 1; 1426 k++, ary = CDR(ary)) { 1427 if (info->print_length < 0 || 1428 k < info->print_length) { 1429 ++local_length; 1430 info->length = 0; 1431 length += LispDoWriteObject(stream, 1432 CAR(ary), info, 1); 1433 length += LispWriteChar(stream, ' '); 1434 } 1435 } 1436 if (info->print_length < 0 || k < info->print_length) { 1437 ++local_length; 1438 info->length = 0; 1439 length += LispDoWriteObject(stream, 1440 CAR(ary), info, 0); 1441 } 1442 else 1443 length += LispWriteStr(stream, "...", 3); 1444 for (k = rank - 1; k > i; k--) 1445 length += LispWriteChar(stream, ')'); 1446 if (loop[0] < dims[0]) 1447 length += LispWriteChar(stream, ' '); 1448 ary = CDR(ary); 1449 } 1450 else { 1451 ++local_length; 1452 length += LispWriteStr(stream, "...)", 4); 1453 for (; local_length < dims[0] - 1; local_length++) 1454 length += LispWriteStr(stream, " ...)", 5); 1455 if (local_length <= dims[0]) 1456 length += LispWriteStr(stream, " ...", 4); 1457 break; 1458 } 1459 } 1460 LispFree(dims); 1461 LispFree(loop); 1462 } 1463 info->length = print_length; 1464 } 1465 length += LispWriteChar(stream, ')'); 1466 } 1467 else 1468 length += LispWriteChar(stream, '#'); 1469 info->level = print_level; 1470 DECDEPTH(); 1471 1472 return (length); 1473 } 1474 1475 static int 1476 LispWriteStruct(LispObj *stream, LispObj *object, write_info *info) 1477 { 1478 int length; 1479 long circle; 1480 LispObj *symbol; 1481 LispObj *def = object->data.struc.def; 1482 LispObj *field = object->data.struc.fields; 1483 1484 if (info->circles && (circle = LispCheckCircle(object, info)) >= 0 && 1485 LispPrintCircle(stream, object, circle, &length, info) == 0) 1486 return (length); 1487 1488 INCDEPTH(); 1489 length = LispWriteStr(stream, "#S(", 3); 1490 symbol = SYMBOLP(CAR(def)) ? CAR(def) : CAAR(def); 1491 length += LispWriteAtom(stream, symbol, info); 1492 def = CDR(def); 1493 for (; def != NIL; def = CDR(def), field = CDR(field)) { 1494 length += LispWriteChar(stream, ' '); 1495 symbol = SYMBOLP(CAR(def)) ? CAR(def) : CAAR(def); 1496 length += LispWriteAtom(stream, symbol, info); 1497 length += LispWriteChar(stream, ' '); 1498 length += LispDoWriteObject(stream, CAR(field), info, 1); 1499 } 1500 length += LispWriteChar(stream, ')'); 1501 DECDEPTH(); 1502 1503 return (length); 1504 } 1505 1506 int 1507 LispFormatInteger(LispObj *stream, LispObj *object, int radix, 1508 int atsign, int collon, int mincol, 1509 int padchar, int commachar, int commainterval) 1510 { 1511 char stk[128], *str = stk; 1512 int i, length, sign, intervals; 1513 1514 if (LONGINTP(object)) 1515 format_integer(stk, LONGINT_VALUE(object), radix); 1516 else { 1517 if (mpi_getsize(object->data.mp.integer, radix) >= sizeof(stk)) 1518 str = mpi_getstr(NULL, object->data.mp.integer, radix); 1519 else 1520 mpi_getstr(str, object->data.mp.integer, radix); 1521 } 1522 1523 sign = *str == '-'; 1524 length = strlen(str); 1525 1526 /* if collon, update length for the number of commachars to be printed */ 1527 if (collon && commainterval > 0 && commachar) { 1528 intervals = length / commainterval; 1529 length += intervals; 1530 } 1531 else 1532 intervals = 0; 1533 1534 /* if sign must be printed, and number is positive */ 1535 if (atsign && !sign) 1536 ++length; 1537 1538 /* if need padding */ 1539 if (padchar && mincol > length) 1540 LispWriteChars(stream, padchar, mincol - length); 1541 1542 /* if need to print number sign */ 1543 if (sign || atsign) 1544 LispWriteChar(stream, sign ? '-' : '+'); 1545 1546 /* if need to print commas to separate groups of numbers */ 1547 if (intervals) { 1548 int j; 1549 char *ptr; 1550 1551 i = (length - atsign) - intervals; 1552 j = i % commainterval; 1553 /* make the loop below easier */ 1554 if (j == 0) 1555 j = commainterval; 1556 i -= j; 1557 ptr = str + sign; 1558 for (; j > 0; j--, ptr++) 1559 LispWriteChar(stream, *ptr); 1560 for (; i > 0; i -= commainterval) { 1561 LispWriteChar(stream, commachar); 1562 for (j = 0; j < commainterval; j++, ptr++) 1563 LispWriteChar(stream, *ptr); 1564 } 1565 } 1566 /* else, just print the string */ 1567 else 1568 LispWriteStr(stream, str + sign, length - sign); 1569 1570 /* if number required more than sizeof(stk) bytes */ 1571 if (str != stk) 1572 LispFree(str); 1573 1574 return (length); 1575 } 1576 1577 int 1578 LispFormatRomanInteger(LispObj *stream, long value, int new_roman) 1579 { 1580 char stk[32]; 1581 int length; 1582 1583 length = 0; 1584 while (value > 1000) { 1585 stk[length++] = 'M'; 1586 value -= 1000; 1587 } 1588 if (new_roman) { 1589 if (value >= 900) { 1590 strcpy(stk + length, "CM"); 1591 length += 2, 1592 value -= 900; 1593 } 1594 else if (value < 500 && value >= 400) { 1595 strcpy(stk + length, "CD"); 1596 length += 2; 1597 value -= 400; 1598 } 1599 } 1600 if (value >= 500) { 1601 stk[length++] = 'D'; 1602 value -= 500; 1603 } 1604 while (value >= 100) { 1605 stk[length++] = 'C'; 1606 value -= 100; 1607 } 1608 if (new_roman) { 1609 if (value >= 90) { 1610 strcpy(stk + length, "XC"); 1611 length += 2, 1612 value -= 90; 1613 } 1614 else if (value < 50 && value >= 40) { 1615 strcpy(stk + length, "XL"); 1616 length += 2; 1617 value -= 40; 1618 } 1619 } 1620 if (value >= 50) { 1621 stk[length++] = 'L'; 1622 value -= 50; 1623 } 1624 while (value >= 10) { 1625 stk[length++] = 'X'; 1626 value -= 10; 1627 } 1628 if (new_roman) { 1629 if (value == 9) { 1630 strcpy(stk + length, "IX"); 1631 length += 2, 1632 value -= 9; 1633 } 1634 else if (value == 4) { 1635 strcpy(stk + length, "IV"); 1636 length += 2; 1637 value -= 4; 1638 } 1639 } 1640 if (value >= 5) { 1641 stk[length++] = 'V'; 1642 value -= 5; 1643 } 1644 while (value) { 1645 stk[length++] = 'I'; 1646 --value; 1647 } 1648 1649 stk[length] = '\0'; 1650 1651 return (LispWriteStr(stream, stk, length)); 1652 } 1653 1654 int 1655 LispFormatEnglishInteger(LispObj *stream, long number, int ordinal) 1656 { 1657 static const char *ds[] = { 1658 "", "one", "two", "three", "four", 1659 "five", "six", "seven", "eight", "nine", 1660 "ten", "eleven", "twelve", "thirteen", "fourteen", 1661 "fifteen", "sixteen", "seventeen", "eighteen", "nineteen" 1662 }; 1663 static const char *dsth[] = { 1664 "", "first", "second", "third", "fourth", 1665 "fifth", "sixth", "seventh", "eighth", "ninth", 1666 "tenth", "eleventh", "twelfth", "thirteenth", "fourteenth", 1667 "fifteenth", "sixteenth", "seventeenth", "eighteenth", "nineteenth" 1668 }; 1669 static const char *hs[] = { 1670 "", "", "twenty", "thirty", "forty", 1671 "fifty", "sixty", "seventy", "eighty", "ninety" 1672 }; 1673 static const char *hsth[] = { 1674 "", "", "twentieth", "thirtieth", "fortieth", 1675 "fiftieth", "sixtieth", "seventieth", "eightieth", "ninetieth" 1676 }; 1677 static const char *ts[] = { 1678 "", "thousand", "million" 1679 }; 1680 static const char *tsth[] = { 1681 "", "thousandth", "millionth" 1682 }; 1683 char stk[256]; 1684 int length, sign; 1685 1686 sign = number < 0; 1687 if (sign) 1688 number = -number; 1689 length = 0; 1690 1691 #define SIGNLEN 6 /* strlen("minus ") */ 1692 if (sign) { 1693 strcpy(stk, "minus "); 1694 length += SIGNLEN; 1695 } 1696 else if (number == 0) { 1697 if (ordinal) { 1698 strcpy(stk, "zeroth"); 1699 length += 6; /* strlen("zeroth") */ 1700 } 1701 else { 1702 strcpy(stk, "zero"); 1703 length += 4; /* strlen("zero") */ 1704 } 1705 } 1706 for (;;) { 1707 int count, temp; 1708 const char *t, *h, *d; 1709 long value = number; 1710 1711 for (count = 0; value >= 1000; value /= 1000, count++) 1712 ; 1713 1714 t = ds[value / 100]; 1715 if (ordinal && !count && (value % 10) == 0) 1716 h = hsth[(value % 100) / 10]; 1717 else 1718 h = hs[(value % 100) / 10]; 1719 1720 if (ordinal && !count) 1721 d = *h ? dsth[value % 10] : dsth[value % 20]; 1722 else 1723 d = *h ? ds[value % 10] : ds[value % 20]; 1724 1725 if (((!sign && length) || length > SIGNLEN) && (*t || *h || *d)) { 1726 if (!ordinal || count || *h || *t) { 1727 strcpy(stk + length, ", "); 1728 length += 2; 1729 } 1730 else { 1731 strcpy(stk + length, " "); 1732 ++length; 1733 } 1734 } 1735 1736 if (*t) { 1737 if (ordinal && !count && (value % 100) == 0) 1738 temp = sprintf(stk + length, "%s hundredth", t); 1739 else 1740 temp = sprintf(stk + length, "%s hundred", t); 1741 length += temp; 1742 } 1743 1744 if (*h) { 1745 if (*t) { 1746 if (ordinal && !count) { 1747 strcpy(stk + length, " "); 1748 ++length; 1749 } 1750 else { 1751 strcpy(stk + length, " and "); 1752 length += 5; /* strlen(" and ") */ 1753 } 1754 } 1755 strcpy(stk + length, h); 1756 length += strlen(h); 1757 } 1758 1759 if (*d) { 1760 if (*h) { 1761 strcpy(stk + length, "-"); 1762 ++length; 1763 } 1764 else if (*t) { 1765 if (ordinal && !count) { 1766 strcpy(stk + length, " "); 1767 ++length; 1768 } 1769 else { 1770 strcpy(stk + length, " and "); 1771 length += 5; /* strlen(" and ") */ 1772 } 1773 } 1774 strcpy(stk + length, d); 1775 length += strlen(d); 1776 } 1777 1778 if (!count) 1779 break; 1780 else 1781 temp = count; 1782 1783 if (count > 1) { 1784 value *= 1000; 1785 while (--count) 1786 value *= 1000; 1787 number -= value; 1788 } 1789 else 1790 number %= 1000; 1791 1792 if (ordinal && number == 0 && !*t && !*h) 1793 temp = sprintf(stk + length, " %s", tsth[temp]); 1794 else 1795 temp = sprintf(stk + length, " %s", ts[temp]); 1796 length += temp; 1797 1798 if (!number) 1799 break; 1800 } 1801 1802 return (LispWriteStr(stream, stk, length)); 1803 } 1804 1805 int 1806 LispFormatCharacter(LispObj *stream, LispObj *object, 1807 int atsign, int collon) 1808 { 1809 int length = 0; 1810 int ch = SCHAR_VALUE(object); 1811 1812 if (atsign && !collon) 1813 length += LispWriteStr(stream, "#\\", 2); 1814 if ((atsign || collon) && (ch <= ' ' || ch == 0177)) { 1815 const char *name = LispChars[ch].names[0]; 1816 1817 length += LispWriteStr(stream, name, strlen(name)); 1818 } 1819 else 1820 length += LispWriteChar(stream, ch); 1821 1822 return (length); 1823 } 1824 1825 /* returns 1 if string size must grow, done inplace */ 1826 static int 1827 float_string_inc(char *buffer, int offset) 1828 { 1829 int i; 1830 1831 for (i = offset; i >= 0; i--) { 1832 if (buffer[i] == '9') 1833 buffer[i] = '0'; 1834 else if (buffer[i] != '.') { 1835 ++buffer[i]; 1836 break; 1837 } 1838 } 1839 if (i < 0) { 1840 int length = strlen(buffer); 1841 1842 /* string size must change */ 1843 memmove(buffer + 1, buffer, length + 1); 1844 buffer[0] = '1'; 1845 1846 return (1); 1847 } 1848 1849 return (0); 1850 } 1851 1852 int 1853 LispFormatFixedFloat(LispObj *stream, LispObj *object, 1854 int atsign, int w, int *pd, int k, int overflowchar, 1855 int padchar) 1856 { 1857 char buffer[512], stk[64]; 1858 int sign, exponent, length, offset, d = pd ? *pd : FLOAT_PREC, again; 1859 double value = DFLOAT_VALUE(object); 1860 1861 if (value == 0.0) { 1862 exponent = k = 0; 1863 strcpy(stk, "+0"); 1864 } 1865 else 1866 /* calculate format parameters, adjusting scale factor */ 1867 parse_double(stk, &exponent, value, d + 1 + k); 1868 1869 /* make sure k won't cause overflow */ 1870 if (k > 128) 1871 k = 128; 1872 else if (k < -128) 1873 k = -128; 1874 1875 /* make sure d won't cause overflow */ 1876 if (d > 128) 1877 d = 128; 1878 else if (d < -128) 1879 d = -128; 1880 1881 /* adjust scale factor, exponent is used as an index in stk */ 1882 exponent += k + 1; 1883 1884 /* how many bytes in float representation */ 1885 length = strlen(stk) - 1; 1886 1887 /* need to print a sign? */ 1888 sign = atsign || (stk[0] == '-'); 1889 1890 /* format number, cannot overflow, as control variables were checked */ 1891 offset = 0; 1892 if (sign) 1893 buffer[offset++] = stk[0]; 1894 if (exponent > 0) { 1895 if (exponent > length) { 1896 memcpy(buffer + offset, stk + 1, length); 1897 memset(buffer + offset + length, '0', exponent - length); 1898 } 1899 else 1900 memcpy(buffer + offset, stk + 1, exponent); 1901 offset += exponent; 1902 buffer[offset++] = '.'; 1903 if (length > exponent) { 1904 memcpy(buffer + offset, stk + 1 + exponent, length - exponent); 1905 offset += length - exponent; 1906 } 1907 else 1908 buffer[offset++] = '0'; 1909 } 1910 else { 1911 buffer[offset++] = '0'; 1912 buffer[offset++] = '.'; 1913 while (exponent < 0) { 1914 buffer[offset++] = '0'; 1915 exponent++; 1916 } 1917 memcpy(buffer + offset, stk + 1, length); 1918 offset += length; 1919 } 1920 buffer[offset] = '\0'; 1921 1922 again = 0; 1923 fixed_float_check_again: 1924 /* make sure only d digits are printed after decimal point */ 1925 if (d > 0) { 1926 char *dptr = strchr(buffer, '.'); 1927 1928 length = strlen(dptr) - 1; 1929 /* check if need to remove excess digits */ 1930 if (length > d) { 1931 int digit; 1932 1933 offset = (dptr - buffer) + 1 + d; 1934 digit = buffer[offset]; 1935 1936 /* remove extra digits */ 1937 buffer[offset] = '\0'; 1938 1939 /* check if need to round */ 1940 if (!again && offset > 1 && isdigit(digit) && digit >= '5' && 1941 isdigit(buffer[offset - 1]) && 1942 float_string_inc(buffer, offset - 1)) 1943 ++offset; 1944 } 1945 /* check if need to add extra zero digits to fill space */ 1946 else if (length < d) { 1947 offset += d - length; 1948 for (++length; length <= d; length++) 1949 dptr[length] = '0'; 1950 dptr[length] = '\0'; 1951 } 1952 } 1953 else { 1954 /* no digits after decimal point */ 1955 int digit, inc = 0; 1956 char *dptr = strchr(buffer, '.') + 1; 1957 1958 digit = *dptr; 1959 if (!again && digit >= '5' && dptr >= buffer + 2 && isdigit(dptr[-2])) 1960 inc = float_string_inc(buffer, dptr - buffer - 2); 1961 1962 offset = (dptr - buffer) + inc; 1963 buffer[offset] = '\0'; 1964 } 1965 1966 /* if d was not specified, remove any extra zeros */ 1967 if (pd == NULL) { 1968 while (offset > 2 && buffer[offset - 2] != '.' && 1969 buffer[offset - 1] == '0') 1970 --offset; 1971 buffer[offset] = '\0'; 1972 } 1973 1974 if (w > 0 && offset > w) { 1975 /* first check if can remove extra fractional digits */ 1976 if (pd == NULL) { 1977 char *ptr = strchr(buffer, '.') + 1; 1978 1979 if (ptr - buffer < w) { 1980 d = w - (ptr - buffer); 1981 goto fixed_float_check_again; 1982 } 1983 } 1984 1985 /* remove leading "zero" to save space */ 1986 if ((!sign && buffer[0] == '0') || (sign && buffer[1] == '0')) { 1987 /* ending nul also copied */ 1988 memmove(buffer + sign, buffer + sign + 1, offset); 1989 --offset; 1990 } 1991 /* remove leading '+' to "save" space */ 1992 if (offset > w && buffer[0] == '+') { 1993 /* ending nul also copied */ 1994 memmove(buffer, buffer + 1, offset); 1995 --offset; 1996 } 1997 } 1998 1999 /* if cannot represent number in given width */ 2000 if (overflowchar && offset > w) { 2001 again = 1; 2002 goto fixed_float_overflow; 2003 } 2004 2005 length = 0; 2006 /* print padding if required */ 2007 if (w > offset) 2008 length += LispWriteChars(stream, padchar, w - offset); 2009 2010 /* print float number representation */ 2011 return (LispWriteStr(stream, buffer, offset) + length); 2012 2013 fixed_float_overflow: 2014 return (LispWriteChars(stream, overflowchar, w)); 2015 } 2016 2017 int 2018 LispFormatExponentialFloat(LispObj *stream, LispObj *object, 2019 int atsign, int w, int *pd, int e, int k, 2020 int overflowchar, int padchar, int exponentchar) 2021 { 2022 return (LispDoFormatExponentialFloat(stream, object, atsign, w, 2023 pd, e, k, overflowchar, padchar, 2024 exponentchar, 1)); 2025 } 2026 2027 int 2028 LispDoFormatExponentialFloat(LispObj *stream, LispObj *object, 2029 int atsign, int w, int *pd, int e, int k, 2030 int overflowchar, int padchar, int exponentchar, 2031 int format) 2032 { 2033 char buffer[512], stk[64]; 2034 int sign, exponent, length, offset, d = pd ? *pd : FLOAT_PREC; 2035 double value = DFLOAT_VALUE(object); 2036 2037 if (value == 0.0) { 2038 exponent = 0; 2039 k = 1; 2040 strcpy(stk, "+0"); 2041 } 2042 else 2043 /* calculate format parameters, adjusting scale factor */ 2044 parse_double(stk, &exponent, value, d + k - 1); 2045 2046 /* set e to a value that won't overflow */ 2047 if (e > 16) 2048 e = 16; 2049 2050 /* set k to a value that won't overflow */ 2051 if (k > 128) 2052 k = 128; 2053 else if (k < -128) 2054 k = -128; 2055 2056 /* set d to a value that won't overflow */ 2057 if (d > 128) 2058 d = 128; 2059 else if (d < -128) 2060 d = -128; 2061 2062 /* how many bytes in float representation */ 2063 length = strlen(stk) - 1; 2064 2065 /* need to print a sign? */ 2066 sign = atsign || (stk[0] == '-'); 2067 2068 /* adjust number of digits after decimal point */ 2069 if (k > 0) 2070 d -= k - 1; 2071 2072 /* adjust exponent, based on scale factor */ 2073 exponent -= k - 1; 2074 2075 /* format number, cannot overflow, as control variables were checked */ 2076 offset = 0; 2077 if (sign) 2078 buffer[offset++] = stk[0]; 2079 if (k > 0) { 2080 if (k > length) { 2081 memcpy(buffer + offset, stk + 1, length); 2082 offset += length; 2083 } 2084 else { 2085 memcpy(buffer + offset, stk + 1, k); 2086 offset += k; 2087 } 2088 buffer[offset++] = '.'; 2089 if (length > k) { 2090 memcpy(buffer + offset, stk + 1 + k, length - k); 2091 offset += length - k; 2092 } 2093 else 2094 buffer[offset++] = '0'; 2095 } 2096 else { 2097 int tmp = k; 2098 2099 buffer[offset++] = '0'; 2100 buffer[offset++] = '.'; 2101 while (tmp < 0) { 2102 buffer[offset++] = '0'; 2103 tmp++; 2104 } 2105 memcpy(buffer + offset, stk + 1, length); 2106 offset += length; 2107 } 2108 2109 /* if format, then always add a sign to exponent */ 2110 buffer[offset++] = exponentchar; 2111 if (format || exponent < 0) 2112 buffer[offset++] = exponent < 0 ? '-' : '+'; 2113 2114 /* XXX destroy stk contents */ 2115 sprintf(stk, "%%0%dd", e); 2116 /* format scale factor*/ 2117 length = sprintf(buffer + offset, stk, 2118 exponent < 0 ? -exponent : exponent); 2119 /* check for overflow in exponent */ 2120 if (length > e && overflowchar) 2121 goto exponential_float_overflow; 2122 offset += length; 2123 2124 /* make sure only d digits are printed after decimal point */ 2125 if (d > 0) { 2126 int currd; 2127 char *dptr = strchr(buffer, '.'), 2128 *eptr = strchr(dptr, exponentchar); 2129 2130 currd = eptr - dptr - 1; 2131 length = strlen(eptr); 2132 2133 /* check if need to remove excess digits */ 2134 if (currd > d) { 2135 int digit, dpos; 2136 2137 dpos = offset = (dptr - buffer) + 1 + d; 2138 digit = buffer[offset]; 2139 2140 memmove(buffer + offset, eptr, length + 1); 2141 /* also copy ending nul character */ 2142 2143 /* adjust offset to length of total string */ 2144 offset += length; 2145 2146 /* check if need to round */ 2147 if (dpos > 1 && isdigit(digit) && digit >= '5' && 2148 isdigit(buffer[dpos - 1]) && 2149 float_string_inc(buffer, dpos - 1)) 2150 ++offset; 2151 } 2152 /* check if need to add extra zero digits to fill space */ 2153 else if (pd && currd < d) { 2154 memmove(eptr + d - currd, eptr, length + 1); 2155 /* also copy ending nul character */ 2156 2157 offset += d - currd; 2158 for (++currd; currd <= d; currd++) 2159 dptr[currd] = '0'; 2160 } 2161 /* check if need to remove zeros */ 2162 else if (pd == NULL) { 2163 int zeros = 1; 2164 2165 while (eptr[-zeros] == '0') 2166 ++zeros; 2167 if (eptr[-zeros] == '.') 2168 --zeros; 2169 if (zeros > 1) { 2170 memmove(eptr - zeros + 1, eptr, length + 1); 2171 offset -= zeros - 1; 2172 } 2173 } 2174 } 2175 else { 2176 /* no digits after decimal point */ 2177 int digit, inc = 0; 2178 char *dptr = strchr(buffer, '.'), 2179 *eptr = strchr(dptr, exponentchar); 2180 2181 digit = dptr[1]; 2182 2183 offset = (dptr - buffer) + 1; 2184 length = strlen(eptr); 2185 memmove(buffer + offset, eptr, length + 1); 2186 /* also copy ending nul character */ 2187 2188 if (digit >= '5' && dptr >= buffer + 2 && 2189 isdigit(dptr[-2])) 2190 inc = float_string_inc(buffer, dptr - buffer - 2); 2191 2192 /* adjust offset to length of total string */ 2193 offset += length + inc; 2194 } 2195 2196 if (w > 0 && offset > w) { 2197 /* remove leading "zero" to save space */ 2198 if ((!sign && buffer[0] == '0') || (sign && buffer[1] == '0')) { 2199 /* ending nul also copied */ 2200 memmove(buffer + sign, buffer + sign + 1, offset); 2201 --offset; 2202 } 2203 /* remove leading '+' to "save" space */ 2204 if (offset > w && buffer[0] == '+') { 2205 /* ending nul also copied */ 2206 memmove(buffer, buffer + 1, offset); 2207 --offset; 2208 } 2209 } 2210 2211 /* if cannot represent number in given width */ 2212 if (overflowchar && offset > w) 2213 goto exponential_float_overflow; 2214 2215 length = 0; 2216 /* print padding if required */ 2217 if (w > offset) 2218 length += LispWriteChars(stream, padchar, w - offset); 2219 2220 /* print float number representation */ 2221 return (LispWriteStr(stream, buffer, offset) + length); 2222 2223 exponential_float_overflow: 2224 return (LispWriteChars(stream, overflowchar, w)); 2225 } 2226 2227 int 2228 LispFormatGeneralFloat(LispObj *stream, LispObj *object, 2229 int atsign, int w, int *pd, int e, int k, 2230 int overflowchar, int padchar, int exponentchar) 2231 { 2232 char stk[64]; 2233 int length, exponent, n, dd, ee, ww, d = pd ? *pd : FLOAT_PREC; 2234 double value = DFLOAT_VALUE(object); 2235 2236 if (value == 0.0) { 2237 exponent = 0; 2238 n = 0; 2239 d = 1; 2240 strcpy(stk, "+0"); 2241 } 2242 else { 2243 /* calculate format parameters, adjusting scale factor */ 2244 parse_double(stk, &exponent, value, d + k - 1); 2245 n = exponent + 1; 2246 } 2247 2248 /* Let ee equal e+2, or 4 if e is omitted. */ 2249 if (e) 2250 ee = e + 2; 2251 else 2252 ee = 4; 2253 2254 /* Let ww equal w-ee, or nil if w is omitted. */ 2255 if (w) 2256 ww = w - ee; 2257 else 2258 ww = 0; 2259 2260 dd = d - n; 2261 if (d >= dd && dd >= 0) { 2262 length = LispFormatFixedFloat(stream, object, atsign, ww, 2263 &dd, 0, overflowchar, padchar); 2264 2265 /* ~ee@T */ 2266 length += LispWriteChars(stream, padchar, ee); 2267 } 2268 else 2269 length = LispFormatExponentialFloat(stream, object, atsign, 2270 w, pd, e, k, overflowchar, 2271 padchar, exponentchar); 2272 2273 return (length); 2274 } 2275 2276 int 2277 LispFormatDollarFloat(LispObj *stream, LispObj *object, 2278 int atsign, int collon, int d, int n, int w, int padchar) 2279 { 2280 char buffer[512], stk[64]; 2281 int sign, exponent, length, offset; 2282 double value = DFLOAT_VALUE(object); 2283 2284 if (value == 0.0) { 2285 exponent = 0; 2286 strcpy(stk, "+0"); 2287 } 2288 else 2289 /* calculate format parameters, adjusting scale factor */ 2290 parse_double(stk, &exponent, value, d == 0 ? FLOAT_PREC : d + 1); 2291 2292 /* set d to a "sane" value */ 2293 if (d > 128) 2294 d = 128; 2295 2296 /* set n to a "sane" value */ 2297 if (n > 128) 2298 n = 128; 2299 2300 /* use exponent as index in stk */ 2301 ++exponent; 2302 2303 /* don't put sign in buffer, 2304 * if collon specified, must go before padding */ 2305 sign = atsign || (stk[0] == '-'); 2306 2307 offset = 0; 2308 2309 /* pad with zeros if required */ 2310 if (exponent > 0) 2311 n -= exponent; 2312 while (n > 0) { 2313 buffer[offset++] = '0'; 2314 n--; 2315 } 2316 2317 /* how many bytes in float representation */ 2318 length = strlen(stk) - 1; 2319 2320 if (exponent > 0) { 2321 if (exponent > length) { 2322 memcpy(buffer + offset, stk + 1, length); 2323 memset(buffer + offset + length, '0', exponent - length); 2324 } 2325 else 2326 memcpy(buffer + offset, stk + 1, exponent); 2327 offset += exponent; 2328 buffer[offset++] = '.'; 2329 if (length > exponent) { 2330 memcpy(buffer + offset, stk + 1 + exponent, length - exponent); 2331 offset += length - exponent; 2332 } 2333 else 2334 buffer[offset++] = '0'; 2335 } 2336 else { 2337 if (n > 0) 2338 buffer[offset++] = '0'; 2339 buffer[offset++] = '.'; 2340 while (exponent < 0) { 2341 buffer[offset++] = '0'; 2342 exponent++; 2343 } 2344 memcpy(buffer + offset, stk + 1, length); 2345 offset += length; 2346 } 2347 buffer[offset] = '\0'; 2348 2349 /* make sure only d digits are printed after decimal point */ 2350 if (d > 0) { 2351 char *dptr = strchr(buffer, '.'); 2352 2353 length = strlen(dptr) - 1; 2354 /* check if need to remove excess digits */ 2355 if (length > d) { 2356 int digit; 2357 2358 offset = (dptr - buffer) + 1 + d; 2359 digit = buffer[offset]; 2360 2361 /* remove extra digits */ 2362 buffer[offset] = '\0'; 2363 2364 /* check if need to round */ 2365 if (offset > 1 && isdigit(digit) && digit >= '5' && 2366 isdigit(buffer[offset - 1]) && 2367 float_string_inc(buffer, offset - 1)) 2368 ++offset; 2369 } 2370 /* check if need to add extra zero digits to fill space */ 2371 else if (length < d) { 2372 offset += d - length; 2373 for (++length; length <= d; length++) 2374 dptr[length] = '0'; 2375 dptr[length] = '\0'; 2376 } 2377 } 2378 else { 2379 /* no digits after decimal point */ 2380 int digit, inc = 0; 2381 char *dptr = strchr(buffer, '.') + 1; 2382 2383 digit = *dptr; 2384 if (digit >= '5' && dptr >= buffer + 2 && isdigit(dptr[-2])) 2385 inc = float_string_inc(buffer, dptr - buffer - 2); 2386 2387 offset = (dptr - buffer) + inc; 2388 buffer[offset] = '\0'; 2389 } 2390 2391 length = 0; 2392 if (sign) { 2393 ++offset; 2394 if (atsign && collon) 2395 length += LispWriteChar(stream, value >= 0.0 ? '+' : '-'); 2396 } 2397 2398 /* print padding if required */ 2399 if (w > offset) 2400 length += LispWriteChars(stream, padchar, w - offset); 2401 2402 if (atsign && !collon) 2403 length += LispWriteChar(stream, value >= 0.0 ? '+' : '-'); 2404 2405 /* print float number representation */ 2406 return (LispWriteStr(stream, buffer, offset) + length); 2407 } 2408
Indexes created Wed Jul 01 00:25:26 UTC 2026