klisp

an open source interpreter for the Kernel Programming Language.
git clone http://git.hanabi.in/repos/klisp.git
Log | Files | Refs | README

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 }