kwrite.c (30448B)
1 /* 2 ** kwrite.c 3 ** Writer for the Kernel Programming Language 4 ** See Copyright Notice in klisp.h 5 */ 6 7 #include <stdio.h> 8 #include <stdlib.h> 9 #include <stdarg.h> 10 #include <assert.h> 11 #include <inttypes.h> 12 #include <string.h> 13 #include <ctype.h> 14 15 #include "kwrite.h" 16 #include "kobject.h" 17 #include "kinteger.h" 18 #include "krational.h" 19 #include "kreal.h" 20 #include "kpair.h" 21 #include "kstring.h" 22 #include "ksymbol.h" 23 #include "kkeyword.h" 24 #include "kstate.h" 25 #include "kerror.h" 26 #include "ktable.h" 27 #include "kport.h" 28 #include "kenvironment.h" 29 #include "kbytevector.h" 30 #include "kvector.h" 31 #include "ktoken.h" /* for identifier checking */ 32 33 /* 34 ** Stack for the write FSM 35 ** 36 */ 37 #define push_data(ks_, data_) (ks_spush(ks_, data_)) 38 #define pop_data(ks_) (ks_sdpop(ks_)) 39 #define get_data(ks_) (ks_sget(ks_)) 40 #define data_is_empty(ks_) (ks_sisempty(ks_)) 41 42 void kwrite_error(klisp_State *K, char *msg) 43 { 44 /* all cleaning is done in throw 45 (stacks, shared_dict, rooted objs) */ 46 klispE_throw_simple(K, msg); 47 } 48 49 void kw_printf(klisp_State *K, const char *format, ...) 50 { 51 va_list argp; 52 TValue port = K->curr_port; 53 54 if (ttisfport(port)) { 55 FILE *file = kfport_file(port); 56 va_start(argp, format); 57 /* LOCK: only a single lock should be acquired */ 58 klisp_unlock(K); 59 int ret = vfprintf(file, format, argp); 60 klisp_lock(K); 61 va_end(argp); 62 63 if (ret < 0) { 64 clearerr(file); /* clear error for next time */ 65 kwrite_error(K, "error writing"); 66 return; 67 } 68 } else if (ttismport(port)) { 69 /* bytevector ports shouldn't write chars */ 70 klisp_assert(kport_is_textual(port)); 71 /* string port */ 72 uint32_t size; 73 int written; 74 uint32_t off = kmport_off(port); 75 76 size = kstring_size(kmport_buf(port)) - 77 kmport_off(port) + 1; 78 79 /* size is always at least 1 (for the '\0') */ 80 va_start(argp, format); 81 written = vsnprintf(kstring_buf(kmport_buf(port)) + off, 82 size, format, argp); 83 va_end(argp); 84 85 if (written >= size) { /* space wasn't enough */ 86 kmport_resize_buffer(K, port, off + written); 87 /* size may be greater than off + written, so get again */ 88 size = kstring_size(kmport_buf(port)) - off + 1; 89 va_start(argp, format); 90 written = vsnprintf(kstring_buf(kmport_buf(port)) + off, 91 size, format, argp); 92 va_end(argp); 93 if (written < 0 || written >= size) { 94 /* shouldn't happen */ 95 kwrite_error(K, "error writing"); 96 return; 97 } 98 } 99 kmport_off(port) = off + written; 100 } else { 101 kwrite_error(K, "unknown port type"); 102 return; 103 } 104 } 105 106 void kw_flush(klisp_State *K) { kwrite_flush_port(K, K->curr_port); } 107 108 109 /* TODO: check for return codes and throw error if necessary */ 110 #define KDEFAULT_NUMBER_RADIX 10 111 void kw_print_bigint(klisp_State *K, TValue bigint) 112 { 113 int32_t radix = KDEFAULT_NUMBER_RADIX; 114 int32_t size = kbigint_print_size(bigint, radix); 115 krooted_tvs_push(K, bigint); 116 /* here we are using 1 byte extra, because size already includes 117 1 for the terminator, but better be safe than sorry */ 118 TValue buf_str = kstring_new_s(K, size); 119 krooted_tvs_push(K, buf_str); 120 121 char *buf = kstring_buf(buf_str); 122 kbigint_print_string(K, bigint, radix, buf, size); 123 kw_printf(K, "%s", buf); 124 125 krooted_tvs_pop(K); 126 krooted_tvs_pop(K); 127 } 128 129 void kw_print_bigrat(klisp_State *K, TValue bigrat) 130 { 131 int32_t radix = KDEFAULT_NUMBER_RADIX; 132 int32_t size = kbigrat_print_size(bigrat, radix); 133 krooted_tvs_push(K, bigrat); 134 /* here we are using 1 byte extra, because size already includes 135 1 for the terminator, but better be safe than sorry */ 136 TValue buf_str = kstring_new_s(K, size); 137 krooted_tvs_push(K, buf_str); 138 139 char *buf = kstring_buf(buf_str); 140 kbigrat_print_string(K, bigrat, radix, buf, size); 141 kw_printf(K, "%s", buf); 142 143 krooted_tvs_pop(K); 144 krooted_tvs_pop(K); 145 } 146 147 void kw_print_double(klisp_State *K, TValue tv_double) 148 { 149 int32_t size = kdouble_print_size(tv_double); 150 krooted_tvs_push(K, tv_double); 151 /* here we are using 1 byte extra, because size already includes 152 1 for the terminator, but better be safe than sorry */ 153 TValue buf_str = kstring_new_s(K, size); 154 krooted_tvs_push(K, buf_str); 155 156 char *buf = kstring_buf(buf_str); 157 kdouble_print_string(K, tv_double, buf, size); 158 kw_printf(K, "%s", buf); 159 160 krooted_tvs_pop(K); 161 krooted_tvs_pop(K); 162 } 163 164 /* 165 ** Helper for printing strings. 166 ** If !displayp it prints the surrounding double quotes 167 ** and escapes backslashes, double quotes, 168 ** and non printable chars (including NULL). 169 ** if displayp it doesn't include surrounding quotes and just 170 ** converts non-printable characters to spaces 171 */ 172 void kw_print_string(klisp_State *K, TValue str) 173 { 174 int size = kstring_size(str); 175 char *buf = kstring_buf(str); 176 char *ptr = buf; 177 int i = 0; 178 179 if (!K->write_displayp) 180 kw_printf(K, "\""); 181 182 while (i < size) { 183 /* find the longest printf-able substring to avoid calling printf 184 for every char */ 185 for (ptr = buf; 186 i < size && *ptr != '\0' && 187 (*ptr >= 32 && *ptr < 127) && 188 (K->write_displayp || (*ptr != '\\' && *ptr != '"')); 189 i++, ptr++) 190 ; 191 192 /* NOTE: this work even if ptr == buf (which can only happen the 193 first or last time) */ 194 char ch = *ptr; 195 *ptr = '\0'; 196 kw_printf(K, "%s", buf); 197 *ptr = ch; 198 199 for(; i < size && (*ptr == '\0' || (*ptr < 32 || *ptr >= 127) || 200 (!K->write_displayp && 201 (*ptr == '\\' || *ptr == '"'))); 202 ++i, ptr++) { 203 /* This are all ASCII printable characters (including space, 204 and exceptuating '\' and '"' if !displayp) */ 205 char *fmt; 206 /* must be uint32_t to support all unicode chars 207 in the future */ 208 uint32_t arg; 209 ch = *ptr; 210 if (K->write_displayp) { 211 fmt = "%c"; 212 /* in display only show tabs and newlines, 213 all other non printables are shown as spaces */ 214 arg = (uint32_t) ((ch == '\r' || ch == '\n' || ch == '\t')? 215 ch : ' '); 216 } else { 217 switch(*ptr) { 218 /* regular \ escapes */ 219 case '\"': fmt = "\\%c"; arg = (uint32_t) '"'; break; 220 case '\\': fmt = "\\%c"; arg = (uint32_t) '\\'; break; 221 case '\0': fmt = "\\%c"; arg = (uint32_t) '0'; break; 222 case '\a': fmt = "\\%c"; arg = (uint32_t) 'a'; break; 223 case '\b': fmt = "\\%c"; arg = (uint32_t) 'b'; break; 224 case '\t': fmt = "\\%c"; arg = (uint32_t) 't'; break; 225 case '\n': fmt = "\\%c"; arg = (uint32_t) 'n'; break; 226 case '\r': fmt = "\\%c"; arg = (uint32_t) 'r'; break; 227 case '\v': fmt = "\\%c"; arg = (uint32_t) 'v'; break; 228 case '\f': fmt = "\\%c"; arg = (uint32_t) 'f'; break; 229 /* for the rest of the non printable chars, 230 use hex escape */ 231 default: fmt = "\\x%x;"; arg = (uint32_t) ch; break; 232 } 233 } 234 kw_printf(K, fmt, arg); 235 } 236 buf = ptr; 237 } 238 239 if (!K->write_displayp) 240 kw_printf(K, "\""); 241 } 242 243 /* 244 ** Helper for printing symbols & keywords. 245 ** If symbol is not a regular identifier it 246 ** uses the "|...|" syntax, escaping '|', '\' and 247 ** non printing characters. 248 */ 249 void kw_print_symbol_buf(klisp_State *K, char *buf, uint32_t size) 250 { 251 /* first determine if it's a simple identifier */ 252 bool identifierp; 253 if (size == 0) 254 identifierp = false; 255 else if (size == 1 && *buf == '.') 256 identifierp = false; 257 else if (size == 1 && (*buf == '+' || *buf == '-')) 258 identifierp = true; 259 else if (*buf == tolower(*buf) && ktok_is_initial(*buf)) { 260 char *ptr = buf; 261 uint32_t i = 0; 262 identifierp = true; 263 while (identifierp && i < size) { 264 char ch = *ptr++; 265 ++i; 266 if (tolower(ch) != ch || !ktok_is_subsequent(ch)) 267 identifierp = false; 268 } 269 } else 270 identifierp = false; 271 272 if (identifierp) { 273 /* no problem, just a simple string */ 274 kw_printf(K, "%s", buf); 275 return; 276 } 277 278 /* 279 ** In case we get here, we'll have to use the "|...|" syntax 280 */ 281 char *ptr = buf; 282 int i = 0; 283 284 kw_printf(K, "|"); 285 286 while (i < size) { 287 /* find the longest printf-able substring to avoid calling printf 288 for every char */ 289 for (ptr = buf; 290 i < size && *ptr != '\0' && 291 (*ptr >= 32 && *ptr < 127) && 292 (*ptr != '\\' && *ptr != '|'); 293 i++, ptr++) 294 ; 295 296 /* NOTE: this work even if ptr == buf (which can only happen the 297 first or last time) */ 298 char ch = *ptr; 299 *ptr = '\0'; 300 kw_printf(K, "%s", buf); 301 *ptr = ch; 302 303 for(; i < size && (*ptr == '\0' || (*ptr < 32 || *ptr >= 127) || 304 (*ptr == '\\' || *ptr == '|')); 305 ++i, ptr++) { 306 /* This are all ASCII printable characters (including space, 307 and exceptuating '\' and '|') */ 308 char *fmt; 309 /* must be uint32_t to support all unicode chars 310 in the future */ 311 uint32_t arg; 312 ch = *ptr; 313 switch(*ptr) { 314 /* regular \ escapes */ 315 case '|': fmt = "\\%c"; arg = (uint32_t) '|'; break; 316 case '\\': fmt = "\\%c"; arg = (uint32_t) '\\'; break; 317 /* for the rest of the non printable chars, 318 use hex escape */ 319 default: fmt = "\\x%x;"; arg = (uint32_t) ch; break; 320 } 321 kw_printf(K, fmt, arg); 322 } 323 buf = ptr; 324 } 325 326 kw_printf(K, "|"); 327 } 328 329 void kw_print_symbol(klisp_State *K, TValue sym) 330 { 331 kw_print_symbol_buf(K, ksymbol_buf(sym), ksymbol_size(sym)); 332 } 333 334 void kw_print_keyword(klisp_State *K, TValue keyw) 335 { 336 kw_printf(K, "#:"); 337 kw_print_symbol_buf(K, kkeyword_buf(keyw), kkeyword_size(keyw)); 338 } 339 340 /* 341 ** Mark initialization and clearing 342 */ 343 /* GC: root is rooted */ 344 void kw_clear_marks(klisp_State *K, TValue root) 345 { 346 assert(ks_sisempty(K)); 347 push_data(K, root); 348 349 while(!data_is_empty(K)) { 350 TValue obj = get_data(K); 351 pop_data(K); 352 353 if (ttispair(obj)) { 354 if (kis_marked(obj)) { 355 kunmark(obj); 356 push_data(K, kcdr(obj)); 357 push_data(K, kcar(obj)); 358 } 359 } else if (ttisstring(obj) && (kis_marked(obj))) { 360 kunmark(obj); 361 } 362 } 363 assert(ks_sisempty(K)); 364 } 365 366 /* 367 ** NOTE: 368 ** - The objects that appear more than once are marked with a -1. 369 ** that way, the first time they are found in write, a shared def 370 ** token will be generated and the mark updated with the number; 371 ** from then on, the writer will generate a shared ref each time 372 ** it appears again. 373 ** - The objects that appear only once are marked with a #t to 374 ** find repetitions and to allow unmarking after write 375 */ 376 /* GC: root is rooted */ 377 void kw_set_initial_marks(klisp_State *K, TValue root) 378 { 379 assert(ks_sisempty(K)); 380 push_data(K, root); 381 382 while(!data_is_empty(K)) { 383 TValue obj = get_data(K); 384 pop_data(K); 385 386 if (ttispair(obj)) { 387 if (kis_unmarked(obj)) { 388 kmark(obj); /* this mark just means visited */ 389 push_data(K, kcdr(obj)); 390 push_data(K, kcar(obj)); 391 } else { 392 /* this mark means it will need a ref number */ 393 kset_mark(obj, i2tv(-1)); 394 } 395 } else if (ttisstring(obj)) { 396 if (kis_unmarked(obj)) { 397 kmark(obj); /* this mark just means visited */ 398 } else { 399 /* this mark means it will need a ref number */ 400 kset_mark(obj, i2tv(-1)); 401 } 402 } 403 /* all other types of object don't matter */ 404 } 405 assert(ks_sisempty(K)); 406 } 407 408 #if KTRACK_NAMES 409 void kw_print_name(klisp_State *K, TValue obj) 410 { 411 kw_printf(K, ": "); 412 kw_print_symbol(K, kget_name(K, obj)); 413 } 414 #endif /* KTRACK_NAMES */ 415 416 #if KTRACK_SI 417 /* Assumes obj has a si */ 418 void kw_print_si(klisp_State *K, TValue obj) 419 { 420 /* should be an improper list of 2 pairs, 421 with a string and 2 fixints */ 422 TValue si = kget_source_info(K, obj); 423 kw_printf(K, " @ "); 424 /* this is a hack, would be better to change the interface of 425 kw_print_string */ 426 bool saved_displayp = K->write_displayp; 427 K->write_displayp = true; /* avoid "s and escapes */ 428 429 TValue str = kcar(si); 430 int32_t row = ivalue(kcadr(si)); 431 int32_t col = ivalue(kcddr(si)); 432 kw_print_string(K, str); 433 kw_printf(K, " (line: %d, col: %d)", row, col); 434 435 K->write_displayp = saved_displayp; 436 } 437 #endif /* KTRACK_SI */ 438 439 /* obj should be a continuation */ 440 /* REFACTOR: move get cont name to a function somewhere else */ 441 void kw_print_cont_type(klisp_State *K, TValue obj) 442 { 443 bool saved_displayp = K->write_displayp; 444 K->write_displayp = true; /* avoid "s and escapes */ 445 446 Continuation *cont = tv2cont(obj); 447 448 /* XXX lock? */ 449 const TValue *node = klispH_get(tv2table(G(K)->cont_name_table), 450 p2tv(cont->fn)); 451 452 char *type; 453 if (node == &kfree) { 454 type = "?"; 455 } else { 456 klisp_assert(ttisstring(*node)); 457 type = kstring_buf(*node); 458 } 459 460 kw_printf(K, " (%s)", type); 461 K->write_displayp = saved_displayp; 462 } 463 464 /* 465 ** Writes all values except strings and pairs 466 */ 467 void kwrite_scalar(klisp_State *K, TValue obj) 468 { 469 switch(ttype(obj)) { 470 case K_TSTRING: 471 /* shouldn't happen */ 472 klisp_assert(0); 473 /* avoid warning */ 474 return; 475 case K_TFIXINT: 476 kw_printf(K, "%" PRId32, ivalue(obj)); 477 break; 478 case K_TBIGINT: 479 kw_print_bigint(K, obj); 480 break; 481 case K_TBIGRAT: 482 kw_print_bigrat(K, obj); 483 break; 484 case K_TEINF: 485 kw_printf(K, "#e%cinfinity", tv_equal(obj, KEPINF)? '+' : '-'); 486 break; 487 case K_TIINF: 488 kw_printf(K, "#i%cinfinity", tv_equal(obj, KIPINF)? '+' : '-'); 489 break; 490 case K_TDOUBLE: { 491 kw_print_double(K, obj); 492 break; 493 } 494 case K_TRWNPV: 495 /* ASK John/TEMP: until John tells me what should this be... */ 496 kw_printf(K, "#real"); 497 break; 498 case K_TUNDEFINED: 499 kw_printf(K, "#undefined"); 500 break; 501 case K_TNIL: 502 kw_printf(K, "()"); 503 break; 504 case K_TCHAR: { 505 if (K->write_displayp) { 506 kw_printf(K, "%c", chvalue(obj)); 507 } else { 508 char ch_buf[16]; /* should be able to contain hex escapes */ 509 char ch = chvalue(obj); 510 char *ch_ptr; 511 512 switch (ch) { 513 case '\0': 514 ch_ptr = "null"; 515 break; 516 case '\a': 517 ch_ptr = "alarm"; 518 break; 519 case '\b': 520 ch_ptr = "backspace"; 521 break; 522 case '\t': 523 ch_ptr = "tab"; 524 break; 525 case '\n': 526 ch_ptr = "newline"; 527 break; 528 case '\r': 529 ch_ptr = "return"; 530 break; 531 case '\x1b': 532 ch_ptr = "escape"; 533 break; 534 case ' ': 535 ch_ptr = "space"; 536 break; 537 case '\x7f': 538 ch_ptr = "delete"; 539 break; 540 case '\v': 541 ch_ptr = "vtab"; 542 break; 543 default: { 544 int i = 0; 545 if (ch >= 32 && ch < 127) { 546 /* printable ASCII range */ 547 /* (del(127) and space(32) were already considered, 548 but it's clearer this way) */ 549 ch_buf[i++] = ch; 550 } else { 551 /* use an hex escape for non printing, unnamed chars */ 552 ch_buf[i++] = 'x'; 553 int res = snprintf(ch_buf+i, sizeof(ch_buf) - i, 554 "%x", ch); 555 if (res < 0) { 556 /* shouldn't happen, but for the sake of 557 completeness... */ 558 TValue port = K->curr_port; 559 if (ttisfport(port)) { 560 FILE *file = kfport_file(port); 561 clearerr(file); /* clear error for next time */ 562 } 563 kwrite_error(K, "error writing"); 564 return; 565 } 566 i += res; /* res doesn't include the '\0' */ 567 } 568 ch_buf[i++] = '\0'; 569 ch_ptr = ch_buf; 570 } 571 } 572 kw_printf(K, "#\\%s", ch_ptr); 573 } 574 break; 575 } 576 case K_TBOOLEAN: 577 kw_printf(K, "#%c", bvalue(obj)? 't' : 'f'); 578 break; 579 case K_TSYMBOL: 580 kw_print_symbol(K, obj); 581 break; 582 case K_TKEYWORD: 583 kw_print_keyword(K, obj); 584 break; 585 case K_TINERT: 586 kw_printf(K, "#inert"); 587 break; 588 case K_TIGNORE: 589 kw_printf(K, "#ignore"); 590 break; 591 /* unreadable objects */ 592 case K_TUSER: 593 kw_printf(K, "#[user pointer: %p]", pvalue(obj)); 594 break; 595 case K_TEOF: 596 kw_printf(K, "#[eof]"); 597 break; 598 case K_TENVIRONMENT: 599 kw_printf(K, "#[environment"); 600 #if KTRACK_NAMES 601 if (khas_name(obj)) { 602 kw_print_name(K, obj); 603 } 604 #endif 605 kw_printf(K, "]"); 606 break; 607 case K_TCONTINUATION: 608 kw_printf(K, "#[continuation"); 609 #if KTRACK_NAMES 610 if (khas_name(obj)) { 611 kw_print_name(K, obj); 612 } 613 #endif 614 615 kw_print_cont_type(K, obj); 616 617 #if KTRACK_SI 618 if (khas_si(obj)) 619 kw_print_si(K, obj); 620 #endif 621 kw_printf(K, "]"); 622 break; 623 case K_TOPERATIVE: 624 kw_printf(K, "#[operative"); 625 #if KTRACK_NAMES 626 if (khas_name(obj)) { 627 kw_print_name(K, obj); 628 } 629 #endif 630 #if KTRACK_SI 631 if (khas_si(obj)) 632 kw_print_si(K, obj); 633 #endif 634 kw_printf(K, "]"); 635 break; 636 case K_TAPPLICATIVE: 637 kw_printf(K, "#[applicative"); 638 #if KTRACK_NAMES 639 if (khas_name(obj)) { 640 kw_print_name(K, obj); 641 } 642 #endif 643 #if KTRACK_SI 644 if (khas_si(obj)) 645 kw_print_si(K, obj); 646 #endif 647 kw_printf(K, "]"); 648 break; 649 case K_TENCAPSULATION: 650 /* TODO try to get the name */ 651 kw_printf(K, "#[encapsulation]"); 652 break; 653 case K_TPROMISE: 654 /* TODO try to get the name */ 655 kw_printf(K, "#[promise]"); 656 break; 657 case K_TFPORT: 658 /* TODO try to get the filename */ 659 kw_printf(K, "#[%s %s file port", 660 kport_is_binary(obj)? "binary" : "textual", 661 kport_is_input(obj)? "input" : "output"); 662 #if KTRACK_NAMES 663 if (khas_name(obj)) { 664 kw_print_name(K, obj); 665 } 666 #endif 667 kw_printf(K, "]"); 668 break; 669 case K_TMPORT: 670 kw_printf(K, "#[%s %s port", 671 kport_is_binary(obj)? "bytevector" : "string", 672 kport_is_input(obj)? "input" : "output"); 673 #if KTRACK_NAMES 674 if (khas_name(obj)) { 675 kw_print_name(K, obj); 676 } 677 #endif 678 kw_printf(K, "]"); 679 break; 680 case K_TERROR: { 681 kw_printf(K, "#[error: "); 682 683 /* TEMP for now show only msg */ 684 bool saved_displayp = K->write_displayp; 685 K->write_displayp = false; /* use "'s and escapes */ 686 kw_print_string(K, tv2error(obj)->msg); 687 K->write_displayp = saved_displayp; 688 689 kw_printf(K, "]"); 690 break; 691 } 692 case K_TBYTEVECTOR: 693 kw_printf(K, "#[bytevector"); 694 #if KTRACK_NAMES 695 if (khas_name(obj)) { 696 kw_print_name(K, obj); 697 } 698 #endif 699 kw_printf(K, "]"); 700 break; 701 case K_TVECTOR: 702 kw_printf(K, "#[vector"); 703 #if KTRACK_NAMES 704 if (khas_name(obj)) { 705 kw_print_name(K, obj); 706 } 707 #endif 708 kw_printf(K, "]"); 709 break; 710 case K_TTABLE: 711 kw_printf(K, "#[hash-table"); 712 #if KTRACK_NAMES 713 if (khas_name(obj)) { 714 kw_print_name(K, obj); 715 } 716 #endif 717 kw_printf(K, "]"); 718 break; 719 case K_TLIBRARY: 720 kw_printf(K, "#[library"); 721 #if KTRACK_NAMES 722 if (khas_name(obj)) { 723 kw_print_name(K, obj); 724 } 725 #endif 726 kw_printf(K, "]"); 727 break; 728 case K_TTHREAD: 729 kw_printf(K, "#[thread"); 730 #if KTRACK_NAMES 731 if (khas_name(obj)) { 732 kw_print_name(K, obj); 733 } 734 #endif 735 kw_printf(K, "]"); 736 break; 737 case K_TMUTEX: 738 kw_printf(K, "#[mutex"); 739 #if KTRACK_NAMES 740 if (khas_name(obj)) { 741 kw_print_name(K, obj); 742 } 743 #endif 744 kw_printf(K, "]"); 745 break; 746 case K_TCONDVAR: 747 kw_printf(K, "#[condvar"); 748 #if KTRACK_NAMES 749 if (khas_name(obj)) { 750 kw_print_name(K, obj); 751 } 752 #endif 753 kw_printf(K, "]"); 754 break; 755 default: 756 /* shouldn't happen */ 757 kwrite_error(K, "unknown object type"); 758 /* avoid warning */ 759 return; 760 } 761 } 762 763 764 /* GC: obj is rooted */ 765 void kwrite_fsm(klisp_State *K, TValue obj) 766 { 767 /* NOTE: a fixint is more than enough for output */ 768 int32_t kw_shared_count = 0; 769 770 assert(ks_sisempty(K)); 771 push_data(K, obj); 772 773 bool middle_list = false; 774 while (!data_is_empty(K)) { 775 TValue obj = get_data(K); 776 pop_data(K); 777 778 if (middle_list) { 779 if (ttisnil(obj)) { /* end of list */ 780 kw_printf(K, ")"); 781 /* middle_list = true; */ 782 } else if (ttispair(obj) && ttisboolean(kget_mark(obj))) { 783 push_data(K, kcdr(obj)); 784 push_data(K, kcar(obj)); 785 kw_printf(K, " "); 786 middle_list = false; 787 } else { /* improper list is the same as shared ref */ 788 kw_printf(K, " . "); 789 push_data(K, KNIL); 790 push_data(K, obj); 791 middle_list = false; 792 } 793 } else { /* if (middle_list) */ 794 switch(ttype(obj)) { 795 case K_TPAIR: { 796 TValue mark = kget_mark(obj); 797 if (ttisboolean(mark)) { /* simple pair (only once) */ 798 kw_printf(K, "("); 799 push_data(K, kcdr(obj)); 800 push_data(K, kcar(obj)); 801 middle_list = false; 802 } else if (ivalue(mark) < 0) { /* pair with no assigned # */ 803 /* TEMP: for now only fixints in shared refs */ 804 assert(kw_shared_count >= 0); 805 806 kset_mark(obj, i2tv(kw_shared_count)); 807 kw_printf(K, "#%" PRId32 "=(", kw_shared_count); 808 kw_shared_count++; 809 push_data(K, kcdr(obj)); 810 push_data(K, kcar(obj)); 811 middle_list = false; 812 } else { /* pair with an assigned number */ 813 kw_printf(K, "#%" PRId32 "#", ivalue(mark)); 814 middle_list = true; 815 } 816 break; 817 } 818 case K_TSTRING: { 819 if (kstring_emptyp(obj)) { 820 if (!K->write_displayp) 821 kw_printf(K, "\"\""); 822 } else { 823 TValue mark = kget_mark(obj); 824 if (K->write_displayp || ttisboolean(mark)) { 825 /* simple string (only once) or in display 826 (show all strings) */ 827 kw_print_string(K, obj); 828 } else if (ivalue(mark) < 0) { /* string with no assigned # */ 829 /* TEMP: for now only fixints in shared refs */ 830 assert(kw_shared_count >= 0); 831 kset_mark(obj, i2tv(kw_shared_count)); 832 kw_printf(K, "#%" PRId32 "=", kw_shared_count); 833 kw_shared_count++; 834 kw_print_string(K, obj); 835 } else { /* string with an assigned number */ 836 kw_printf(K, "#%" PRId32 "#", ivalue(mark)); 837 } 838 } 839 middle_list = true; 840 break; 841 } 842 default: 843 kwrite_scalar(K, obj); 844 middle_list = true; 845 } 846 } 847 } 848 849 assert(ks_sisempty(K)); 850 } 851 852 /* 853 ** Writer Main function 854 */ 855 void kwrite(klisp_State *K, TValue obj) 856 { 857 /* GC: root obj */ 858 krooted_tvs_push(K, obj); 859 860 kw_set_initial_marks(K, obj); 861 kwrite_fsm(K, obj); 862 kw_flush(K); 863 kw_clear_marks(K, obj); 864 865 krooted_tvs_pop(K); 866 } 867 868 /* 869 ** This is the same as above but will not display 870 ** shared tags (and will hang if there are cycles) 871 */ 872 void kwrite_simple(klisp_State *K, TValue obj) 873 { 874 /* GC: root obj */ 875 krooted_tvs_push(K, obj); 876 kwrite_fsm(K, obj); 877 kw_flush(K); 878 krooted_tvs_pop(K); 879 } 880 881 /* 882 ** Writer Interface 883 */ 884 void kwrite_display_to_port(klisp_State *K, TValue port, TValue obj, 885 bool displayp) 886 { 887 klisp_assert(ttisport(port)); 888 klisp_assert(kport_is_output(port)); 889 klisp_assert(kport_is_open(port)); 890 klisp_assert(kport_is_textual(port)); 891 892 K->curr_port = port; 893 K->write_displayp = displayp; 894 kwrite(K, obj); 895 } 896 897 void kwrite_simple_to_port(klisp_State *K, TValue port, TValue obj) 898 { 899 klisp_assert(ttisport(port)); 900 klisp_assert(kport_is_output(port)); 901 klisp_assert(kport_is_open(port)); 902 klisp_assert(kport_is_textual(port)); 903 904 K->curr_port = port; 905 K->write_displayp = false; 906 kwrite_simple(K, obj); 907 } 908 909 void kwrite_newline_to_port(klisp_State *K, TValue port) 910 { 911 klisp_assert(ttisport(port)); 912 klisp_assert(kport_is_output(port)); 913 klisp_assert(kport_is_open(port)); 914 klisp_assert(kport_is_textual(port)); 915 K->curr_port = port; /* this isn't needed but all other 916 i/o functions set it */ 917 kwrite_char_to_port(K, port, ch2tv('\n')); 918 } 919 920 void kwrite_char_to_port(klisp_State *K, TValue port, TValue ch) 921 { 922 klisp_assert(ttisport(port)); 923 klisp_assert(kport_is_output(port)); 924 klisp_assert(kport_is_open(port)); 925 klisp_assert(kport_is_textual(port)); 926 K->curr_port = port; /* this isn't needed but all other 927 i/o functions set it */ 928 929 if (ttisfport(port)) { 930 FILE *file = kfport_file(port); 931 klisp_unlock(K); 932 int res = fputc(chvalue(ch), file); 933 klisp_lock(K); 934 935 if (res == EOF) { 936 clearerr(file); /* clear error for next time */ 937 kwrite_error(K, "error writing char"); 938 } 939 } else if (ttismport(port)) { 940 if (kport_is_binary(port)) { 941 /* bytebuffer port */ 942 if (kmport_off(port) >= kbytevector_size(kmport_buf(port))) { 943 kmport_resize_buffer(K, port, kmport_off(port) + 1); 944 } 945 kbytevector_buf(kmport_buf(port))[kmport_off(port)] = chvalue(ch); 946 ++kmport_off(port); 947 } else { 948 /* string port */ 949 if (kmport_off(port) >= kstring_size(kmport_buf(port))) { 950 kmport_resize_buffer(K, port, kmport_off(port) + 1); 951 } 952 kstring_buf(kmport_buf(port))[kmport_off(port)] = chvalue(ch); 953 ++kmport_off(port); 954 } 955 } else { 956 kwrite_error(K, "unknown port type"); 957 return; 958 } 959 } 960 961 void kwrite_u8_to_port(klisp_State *K, TValue port, TValue u8) 962 { 963 klisp_assert(ttisport(port)); 964 klisp_assert(kport_is_output(port)); 965 klisp_assert(kport_is_open(port)); 966 klisp_assert(kport_is_binary(port)); 967 K->curr_port = port; /* this isn't needed but all other 968 i/o functions set it */ 969 if (ttisfport(port)) { 970 FILE *file = kfport_file(port); 971 klisp_unlock(K); 972 int res = fputc(ivalue(u8), file); 973 klisp_lock(K); 974 975 if (res == EOF) { 976 clearerr(file); /* clear error for next time */ 977 kwrite_error(K, "error writing u8"); 978 } 979 } else if (ttismport(port)) { 980 if (kport_is_binary(port)) { 981 /* bytebuffer port */ 982 if (kmport_off(port) >= kbytevector_size(kmport_buf(port))) { 983 kmport_resize_buffer(K, port, kmport_off(port) + 1); 984 } 985 kbytevector_buf(kmport_buf(port))[kmport_off(port)] = 986 (uint8_t) ivalue(u8); 987 ++kmport_off(port); 988 } else { 989 /* string port */ 990 if (kmport_off(port) >= kstring_size(kmport_buf(port))) { 991 kmport_resize_buffer(K, port, kmport_off(port) + 1); 992 } 993 kstring_buf(kmport_buf(port))[kmport_off(port)] = 994 (char) ivalue(u8); 995 ++kmport_off(port); 996 } 997 } else { 998 kwrite_error(K, "unknown port type"); 999 return; 1000 } 1001 } 1002 1003 void kwrite_flush_port(klisp_State *K, TValue port) 1004 { 1005 klisp_assert(ttisport(port)); 1006 klisp_assert(kport_is_output(port)); 1007 klisp_assert(kport_is_open(port)); 1008 K->curr_port = port; /* this isn't needed but all other 1009 i/o functions set it */ 1010 if (ttisfport(port)) { /* only necessary for file ports */ 1011 FILE *file = kfport_file(port); 1012 klisp_assert(file); 1013 klisp_unlock(K); 1014 int res = fflush(file); 1015 klisp_lock(K); 1016 if (res == EOF) { 1017 clearerr(file); /* clear error for next time */ 1018 kwrite_error(K, "error writing"); 1019 } 1020 } 1021 }