Back to index

plt-scheme  4.2.1
print.c
Go to the documentation of this file.
00001 /*
00002   MzScheme
00003   Copyright (c) 2004-2009 PLT Scheme Inc.
00004   Copyright (c) 1995-2001 Matthew Flatt
00005 
00006     This library is free software; you can redistribute it and/or
00007     modify it under the terms of the GNU Library General Public
00008     License as published by the Free Software Foundation; either
00009     version 2 of the License, or (at your option) any later version.
00010 
00011     This library is distributed in the hope that it will be useful,
00012     but WITHOUT ANY WARRANTY; without even the implied warranty of
00013     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
00014     Library General Public License for more details.
00015 
00016     You should have received a copy of the GNU Library General Public
00017     License along with this library; if not, write to the Free
00018     Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
00019     Boston, MA 02110-1301 USA.
00020 
00021   libscheme
00022   Copyright (c) 1994 Brent Benson
00023   All rights reserved.
00024 */
00025 
00026 #include "schpriv.h"
00027 #include "schvers.h"
00028 #include "schmach.h"
00029 #include "schcpt.h"
00030 #include <ctype.h>
00031 #ifdef USE_STACKAVAIL
00032 # include <malloc.h>
00033 #endif
00034 
00035 int (*scheme_check_print_is_obj)(Scheme_Object *o);
00036 
00037 #define QUICK_ENCODE_BUFFER_SIZE 256
00038 static THREAD_LOCAL char *quick_buffer = NULL;
00039 static THREAD_LOCAL char *quick_encode_buffer = NULL;
00040 
00041 /* FIXME places possible race condition on growing printer size */
00042 static Scheme_Type_Printer *printers;
00043 static int printers_count;
00044 
00045 static Scheme_Hash_Table *cache_ht;
00046 
00047 /* read-only globals */
00048 static char compacts[_CPT_COUNT_];
00049 static Scheme_Hash_Table *global_constants_ht;
00050 static Scheme_Object *quote_link_symbol = NULL;
00051 
00052 /* Flag for debugging compiled code in printed form: */
00053 #define NO_COMPACT 0
00054 
00055 #define PRINT_MAXLEN_MIN 3
00056 
00057 /* locals */
00058 #define MAX_PRINT_BUFFER 500
00059 
00060 typedef struct Scheme_Print_Params {
00061   MZTAG_IF_REQUIRED
00062   
00063   char print_struct;
00064   char print_graph;
00065   char print_box;
00066   char print_vec_shorthand;
00067   char print_hash_table;
00068   char print_unreadable;
00069   char print_pair_curly, print_mpair_curly;
00070   char can_read_pipe_quote;
00071   char case_sens;
00072   char honu_mode;
00073   Scheme_Object *inspector;
00074 
00075   /* Used during `display' and `write': */
00076   char *print_buffer;
00077   long print_position;
00078   long print_allocated;
00079   long print_maxlen;
00080   long print_offset;
00081   Scheme_Object *print_port;
00082   mz_jmp_buf *print_escape;
00083 } PrintParams;
00084 
00085 #ifdef MZ_PRECISE_GC
00086 static void register_traversers(void);
00087 #endif
00088 
00089 static void print_to_port(char *name, Scheme_Object *obj, Scheme_Object *port, 
00090                        int notdisplay, long maxl, int check_honu);
00091 static int print(Scheme_Object *obj, int notdisplay, int compact, 
00092                Scheme_Hash_Table *ht,
00093                  Scheme_Marshal_Tables *mt,
00094                PrintParams *p);
00095 static void print_char_string(const char *s, int l, const mzchar *us, int delta, int ul, 
00096                            int notdisplay, int honu_char, PrintParams *pp);
00097 static void print_byte_string(const char *s, int delta, int l, int notdisplay, PrintParams *pp);
00098 static void print_pair(Scheme_Object *pair, int notdisplay, int compact, 
00099                      Scheme_Hash_Table *ht, 
00100                        Scheme_Marshal_Tables *mt,
00101                      PrintParams *pp,
00102                        Scheme_Type type, int round_parens);
00103 static void print_vector(Scheme_Object *vec, int notdisplay, int compact, 
00104                       Scheme_Hash_Table *ht, 
00105                          Scheme_Marshal_Tables *mt,
00106                       PrintParams *pp,
00107                          int as_prefab);
00108 static void print_char(Scheme_Object *chobj, int notdisplay, PrintParams *pp);
00109 static char *print_to_string(Scheme_Object *obj, long * volatile len, int write,
00110                           Scheme_Object *port, long maxl, int check_honu);
00111 
00112 static void custom_write_struct(Scheme_Object *s, Scheme_Hash_Table *ht, 
00113                                 Scheme_Marshal_Tables *mt,
00114                             PrintParams *pp, int notdisplay);
00115 static Scheme_Object *writable_struct_subs(Scheme_Object *s, int for_write, PrintParams *pp);
00116 
00117 
00118 #define print_compact(pp, v) print_this_string(pp, &compacts[v], 0, 1)
00119 
00120 #define PRINTABLE_STRUCT(obj, pp) (scheme_inspector_sees_part(obj, pp->inspector, -1))
00121 #define SCHEME_PREFABP(obj) (((Scheme_Structure *)(obj))->stype->prefab_key)
00122 
00123 #define SCHEME_HASHTPx(obj) ((SCHEME_HASHTP(obj) && !(MZ_OPT_HASH_KEY(&(((Scheme_Hash_Table *)obj)->iso)) & 0x1)))
00124 
00125 #define HAS_SUBSTRUCT(obj, qk) \
00126    (SCHEME_PAIRP(obj) \
00127     || SCHEME_MUTABLE_PAIRP(obj) \
00128     || SCHEME_VECTORP(obj) \
00129     || (qk(pp->print_box, 1) && SCHEME_BOXP(obj)) \
00130     || (qk(pp->print_struct  \
00131           && SCHEME_STRUCTP(obj) \
00132           && PRINTABLE_STRUCT(obj, pp), 0)) \
00133     || (qk(SCHEME_STRUCTP(obj) && scheme_is_writable_struct(obj), 0)) \
00134     || (qk(pp->print_hash_table, 1) && (SCHEME_HASHTPx(obj) || SCHEME_HASHTRP(obj))))
00135 #define ssQUICK(x, isbox) x
00136 #define ssQUICKp(x, isbox) (pp ? x : isbox)
00137 #define ssALL(x, isbox) 1
00138 #define ssALLp(x, isbox) isbox
00139 
00140 void scheme_init_print(Scheme_Env *env)
00141 {
00142   int i;
00143 
00144 
00145   REGISTER_SO(quote_link_symbol);
00146   
00147   quote_link_symbol = scheme_intern_symbol("-q");
00148   
00149   for (i = 0; i < _CPT_COUNT_; i++) {
00150     compacts[i] = i;
00151   }
00152 
00153 #ifdef MZ_PRECISE_GC
00154   register_traversers();
00155 #endif
00156 
00157   REGISTER_SO(cache_ht);
00158 }
00159 
00160 void scheme_init_print_buffers_places() 
00161 {
00162   REGISTER_SO(quick_buffer);
00163   REGISTER_SO(quick_encode_buffer);
00164   
00165   quick_buffer = (char *)scheme_malloc_atomic(100);
00166   quick_encode_buffer = (char *)scheme_malloc_atomic(QUICK_ENCODE_BUFFER_SIZE);
00167 }
00168 
00169 Scheme_Object *scheme_make_svector(mzshort c, mzshort *a)
00170 {
00171   Scheme_Object *o;
00172   o = scheme_alloc_object();
00173 
00174   o->type = scheme_svector_type;
00175   SCHEME_SVEC_LEN(o) = c;
00176   SCHEME_SVEC_VEC(o) = a;
00177 
00178   return o;
00179 }
00180 
00181 PrintParams *copy_print_params(PrintParams *pp)
00182 {
00183   PrintParams *pp2;
00184 
00185   pp2 = MALLOC_ONE_RT(PrintParams);
00186   memcpy(pp2, pp, sizeof(PrintParams));
00187 #ifdef MZTAG_REQUIRED
00188   pp2->type = scheme_rt_print_params;
00189 #endif
00190   return pp2;
00191 }
00192 
00193 void
00194 scheme_debug_print (Scheme_Object *obj)
00195 {
00196   scheme_write(obj, scheme_orig_stdout_port);
00197   fflush (stdout);
00198 }
00199 
00200 static void *print_to_port_k(void)
00201 {
00202   Scheme_Thread *p = scheme_current_thread;
00203   Scheme_Object *obj, *port;
00204 
00205   port = (Scheme_Object *)p->ku.k.p1;
00206   obj = (Scheme_Object *)p->ku.k.p2;
00207 
00208   print_to_port(p->ku.k.i2 ? "write" : "display", 
00209               obj, port,
00210               p->ku.k.i2, p->ku.k.i1, p->ku.k.i3);
00211 
00212   return NULL;
00213 }
00214 
00215 static void do_handled_print(Scheme_Object *obj, Scheme_Object *port,
00216                           Scheme_Object *proc, long maxl)
00217 {
00218   Scheme_Object *a[2];
00219 
00220   a[0] = obj;
00221   
00222   if (maxl > 0) {
00223     a[1] = scheme_make_byte_string_output_port();
00224   } else
00225     a[1] = port;
00226   
00227   scheme_apply_multi(scheme_write_proc, 2, a);
00228   
00229   if (maxl > 0) {
00230     char *s;
00231     long len;
00232 
00233     s = scheme_get_sized_byte_string_output(a[1], &len);
00234     if (len > maxl)
00235       len = maxl;
00236 
00237     scheme_write_byte_string(s, len, port);
00238   }
00239 }
00240 
00241 void scheme_write_w_max(Scheme_Object *obj, Scheme_Object *port, long maxl)
00242 {
00243   if (((Scheme_Output_Port *)port)->write_handler)
00244     do_handled_print(obj, port, scheme_write_proc, maxl);
00245   else {
00246     Scheme_Thread *p = scheme_current_thread;
00247     
00248     p->ku.k.p1 = port;
00249     p->ku.k.p2 = obj;
00250     p->ku.k.i1 = maxl;
00251     p->ku.k.i2 = 1;
00252     p->ku.k.i3 = 0;
00253     
00254     (void)scheme_top_level_do(print_to_port_k, 0);
00255   }
00256 }
00257 
00258 void scheme_write(Scheme_Object *obj, Scheme_Object *port)
00259 {
00260   scheme_write_w_max(obj, port, -1);
00261 }
00262 
00263 void scheme_display_w_max(Scheme_Object *obj, Scheme_Object *port, long maxl)
00264 {
00265   if (((Scheme_Output_Port *)port)->display_handler)
00266     do_handled_print(obj, port, scheme_display_proc, maxl);
00267   else {
00268     Scheme_Thread *p = scheme_current_thread;
00269     
00270     p->ku.k.p1 = port;
00271     p->ku.k.p2 = obj;
00272     p->ku.k.i1 = maxl;
00273     p->ku.k.i2 = 0;
00274     p->ku.k.i3 = 0;
00275     
00276     (void)scheme_top_level_do(print_to_port_k, 0);
00277   }
00278 }
00279 
00280 void scheme_display(Scheme_Object *obj, Scheme_Object *port)
00281 {
00282   scheme_display_w_max(obj, port, -1);
00283 }
00284 
00285 void scheme_print_w_max(Scheme_Object *obj, Scheme_Object *port, long maxl)
00286 {
00287   if (((Scheme_Output_Port *)port)->print_handler)
00288     do_handled_print(obj, port, scheme_print_proc, maxl);
00289   else {
00290     Scheme_Thread *p = scheme_current_thread;
00291     
00292     p->ku.k.p1 = port;
00293     p->ku.k.p2 = obj;
00294     p->ku.k.i1 = maxl;
00295     p->ku.k.i2 = 1;
00296     p->ku.k.i3 = 1;
00297     
00298     (void)scheme_top_level_do(print_to_port_k, 0);
00299   }
00300 }
00301 
00302 void scheme_print(Scheme_Object *obj, Scheme_Object *port)
00303 {
00304   scheme_print_w_max(obj, port, -1);
00305 }
00306 
00307 static void *print_to_string_k(void)
00308 {
00309   Scheme_Thread *p = scheme_current_thread;
00310   Scheme_Object *obj;
00311   long *len, maxl;
00312   int iswrite, check_honu;
00313 
00314   obj = (Scheme_Object *)p->ku.k.p1;
00315   len = (long *) mzALIAS p->ku.k.p2;
00316   maxl = p->ku.k.i1;
00317   iswrite = p->ku.k.i2;
00318   check_honu = p->ku.k.i3;
00319 
00320   p->ku.k.p1 = NULL;
00321   p->ku.k.p2 = NULL;
00322 
00323   return (void *)print_to_string(obj, len, iswrite, NULL, maxl, check_honu);
00324 }
00325 
00326 char *scheme_write_to_string_w_max(Scheme_Object *obj, long *len, long maxl)
00327 {
00328   Scheme_Thread *p = scheme_current_thread;
00329 
00330   p->ku.k.p1 = obj;
00331   p->ku.k.p2 = len;
00332   p->ku.k.i1 = maxl;
00333   p->ku.k.i2 = 1;
00334   p->ku.k.i3 = 0;
00335 
00336   return (char *)scheme_top_level_do(print_to_string_k, 0);
00337 }
00338 
00339 char *scheme_write_to_string(Scheme_Object *obj, long *len)
00340 {
00341   return scheme_write_to_string_w_max(obj, len, -1);
00342 }
00343 
00344 char *scheme_display_to_string_w_max(Scheme_Object *obj, long *len, long maxl)
00345 {
00346   Scheme_Thread *p = scheme_current_thread;
00347 
00348   p->ku.k.p1 = obj;
00349   p->ku.k.p2 = len;
00350   p->ku.k.i1 = maxl;
00351   p->ku.k.i2 = 0;
00352   p->ku.k.i3 = 0;
00353 
00354   return (char *)scheme_top_level_do(print_to_string_k, 0);
00355 }
00356 
00357 char *scheme_display_to_string(Scheme_Object *obj, long *len)
00358 {
00359   return scheme_display_to_string_w_max(obj, len, -1);
00360 }
00361 
00362 char *scheme_print_to_string_w_max(Scheme_Object *obj, long *len, long maxl)
00363 {
00364   Scheme_Thread *p = scheme_current_thread;
00365 
00366   p->ku.k.p1 = obj;
00367   p->ku.k.p2 = len;
00368   p->ku.k.i1 = maxl;
00369   p->ku.k.i2 = 1;
00370   p->ku.k.i3 = 1;
00371 
00372   return (char *)scheme_top_level_do(print_to_string_k, 0);
00373 }
00374 
00375 char *scheme_print_to_string(Scheme_Object *obj, long *len)
00376 {
00377   return scheme_print_to_string_w_max(obj, len, -1);
00378 }
00379 
00380 void
00381 scheme_internal_write(Scheme_Object *obj, Scheme_Object *port)
00382 {
00383   print_to_port("write", obj, port, 1, -1, 0);
00384 }
00385 
00386 void
00387 scheme_internal_display(Scheme_Object *obj, Scheme_Object *port)
00388 {
00389   print_to_port("display", obj, port, 0, -1, 0);
00390 }
00391 
00392 void
00393 scheme_internal_print(Scheme_Object *obj, Scheme_Object *port)
00394 {
00395   print_to_port("print", obj, port, 1, -1, 1);
00396 }
00397 
00398 #ifdef DO_STACK_CHECK
00399 static int check_cycles(Scheme_Object *, int, Scheme_Hash_Table *ht, PrintParams *);
00400 
00401 static Scheme_Object *check_cycle_k(void)
00402 {
00403   Scheme_Thread *p = scheme_current_thread;
00404   Scheme_Object *o = (Scheme_Object *)p->ku.k.p1;
00405   Scheme_Hash_Table *ht = (Scheme_Hash_Table *)p->ku.k.p2;
00406   PrintParams *pp = (PrintParams *)p->ku.k.p3;
00407 
00408   p->ku.k.p1 = NULL;
00409   p->ku.k.p2 = NULL;
00410   p->ku.k.p3 = NULL;
00411 
00412   return check_cycles(o, p->ku.k.i1, ht, pp)
00413     ? scheme_true : scheme_false;
00414 }
00415 #endif
00416 
00417 static int check_cycles(Scheme_Object *obj, int for_write, Scheme_Hash_Table *ht, PrintParams *pp)
00418 {
00419   Scheme_Type t;
00420 
00421 #ifdef DO_STACK_CHECK
00422   {
00423 #include "mzstkchk.h"
00424     {
00425       pp = copy_print_params(pp);
00426       scheme_current_thread->ku.k.p1 = (void *)obj;
00427       scheme_current_thread->ku.k.p2 = (void *)ht;
00428       scheme_current_thread->ku.k.p3 = (void *)pp;
00429       scheme_current_thread->ku.k.i1 = for_write;
00430       return SCHEME_TRUEP(scheme_handle_stack_overflow(check_cycle_k));
00431     }
00432   }
00433 #endif
00434   SCHEME_USE_FUEL(1);
00435 
00436   t = SCHEME_TYPE(obj);
00437 
00438   if (SCHEME_PAIRP(obj)
00439       || SCHEME_MUTABLE_PAIRP(obj)
00440       || (pp->print_box && SCHEME_BOXP(obj))
00441       || SCHEME_VECTORP(obj)
00442       || ((SAME_TYPE(t, scheme_structure_type)
00443           || SAME_TYPE(t, scheme_proc_struct_type))
00444           && ((pp->print_struct 
00445               && PRINTABLE_STRUCT(obj, pp))
00446              || scheme_is_writable_struct(obj)))
00447       || (pp->print_hash_table
00448          && (SAME_TYPE(t, scheme_hash_table_type)
00449               || SAME_TYPE(t, scheme_hash_tree_type)))) {
00450     if (scheme_hash_get(ht, obj))
00451       return 1;
00452     scheme_hash_set(ht, obj, (Scheme_Object *)0x1);
00453   } else 
00454     return 0;
00455 
00456   if (SCHEME_PAIRP(obj) || SCHEME_MUTABLE_PAIRP(obj)) {
00457     if (check_cycles(SCHEME_CAR(obj), for_write, ht, pp))
00458       return 1;
00459     if (check_cycles(SCHEME_CDR(obj), for_write, ht, pp))
00460       return 1;
00461   } else if (SCHEME_BOXP(obj)) {
00462     /* got here => printable */
00463     if (check_cycles(SCHEME_BOX_VAL(obj), for_write, ht, pp))
00464       return 1;
00465   } else if (SCHEME_VECTORP(obj)) {
00466     int i, len;
00467 
00468     len = SCHEME_VEC_SIZE(obj);
00469     for (i = 0; i < len; i++) {
00470       if (check_cycles(SCHEME_VEC_ELS(obj)[i], for_write, ht, pp)) {
00471        return 1;
00472       }
00473     }
00474   } else if (SAME_TYPE(t, scheme_structure_type)
00475             || SAME_TYPE(t, scheme_proc_struct_type)) {
00476     if (scheme_is_writable_struct(obj)) {
00477       if (check_cycles(writable_struct_subs(obj, for_write, pp), for_write, ht, pp))
00478        return 1;
00479     } else {
00480       /* got here => printable */
00481       int i = SCHEME_STRUCT_NUM_SLOTS(obj);
00482 
00483       while (i--) {
00484        if (scheme_inspector_sees_part(obj, pp->inspector, i)) {
00485          if (check_cycles(((Scheme_Structure *)obj)->slots[i], for_write, ht, pp)) {
00486            return 1;
00487          }
00488        }
00489       }
00490     }
00491   } else if (SCHEME_HASHTPx(obj)) {
00492     /* got here => printable */
00493     Scheme_Hash_Table *t;
00494     Scheme_Object **keys, **vals, *val;
00495     int i;
00496     
00497     t = (Scheme_Hash_Table *)obj;
00498     keys = t->keys;
00499     vals = t->vals;
00500     for (i = t->size; i--; ) {
00501       if (vals[i]) {
00502        val = vals[i];
00503        if (check_cycles(keys[i], for_write, ht, pp))
00504          return 1;
00505        if (check_cycles(val, for_write, ht, pp))
00506          return 1;
00507       }
00508     }
00509   } else if (SCHEME_HASHTRP(obj)) {
00510     /* got here => printable */
00511     Scheme_Hash_Tree *t = (Scheme_Hash_Tree *)obj;
00512     Scheme_Object *key, *val;
00513     int i;
00514     
00515     i = scheme_hash_tree_next(t, -1);
00516     while (i != -1) {
00517       scheme_hash_tree_index(t, i, &key, &val);
00518       if (check_cycles(key, for_write, ht, pp))
00519         return 1;
00520       if (check_cycles(val, for_write, ht, pp))
00521         return 1;
00522       i = scheme_hash_tree_next(t, i);
00523     }
00524   }
00525 
00526   scheme_hash_set(ht, obj, NULL);
00527 
00528   return 0;
00529 }
00530 
00531 #ifdef MZ_XFORM
00532 START_XFORM_SKIP;
00533 #endif
00534 
00535 /* The fast cycle-checker plays a dangerous game: it changes type
00536    tags. No GCs can occur here, and no thread switches. If the fast
00537    version takes to long, we back out to the general case. (We don't
00538    even check for stack overflow, so keep the max limit low.) */
00539 
00540 static int check_cycles_fast(Scheme_Object *obj, PrintParams *pp, int *fast_checker_counter)
00541 {
00542   Scheme_Type t;
00543   int cycle = 0;
00544 
00545   t = SCHEME_TYPE(obj);
00546   if (t < 0)
00547     return 1;
00548 
00549   if ((*fast_checker_counter)-- < 0)
00550     return -1;
00551 
00552   if (SCHEME_PAIRP(obj) || SCHEME_MUTABLE_PAIRP(obj)) {
00553     obj->type = -t;
00554     cycle = check_cycles_fast(SCHEME_CAR(obj), pp, fast_checker_counter);
00555     if (!cycle)
00556       cycle = check_cycles_fast(SCHEME_CDR(obj), pp, fast_checker_counter);
00557     obj->type = t;
00558   } else if (pp->print_box && SCHEME_BOXP(obj)) {
00559     obj->type = -t;
00560     cycle = check_cycles_fast(SCHEME_BOX_VAL(obj), pp, fast_checker_counter);
00561     obj->type = t;
00562   } else if (SCHEME_VECTORP(obj)) {
00563     int i, len;
00564 
00565     obj->type = -t;
00566     len = SCHEME_VEC_SIZE(obj);
00567     for (i = 0; i < len; i++) {
00568       cycle = check_cycles_fast(SCHEME_VEC_ELS(obj)[i], pp, fast_checker_counter);
00569       if (cycle)
00570        break;
00571     }
00572     obj->type = t;
00573   } else if (SAME_TYPE(t, scheme_structure_type)
00574             || SAME_TYPE(t, scheme_proc_struct_type)) {
00575     if (scheme_is_writable_struct(obj)) {
00576       if (!pp->print_unreadable)
00577        cycle = 0;
00578       else
00579        /* don't bother with fast checks for writeable structs */
00580        cycle = -1;
00581     } else if (pp->print_struct && PRINTABLE_STRUCT(obj, pp)) {
00582       int i = SCHEME_STRUCT_NUM_SLOTS(obj);
00583       
00584       obj->type = -t;
00585       while (i--) {
00586        if (scheme_inspector_sees_part(obj, pp->inspector, i)) {
00587          cycle = check_cycles_fast(((Scheme_Structure *)obj)->slots[i], pp, fast_checker_counter);
00588          if (cycle)
00589            break;
00590        }
00591       }
00592       obj->type = t;
00593     } else
00594       cycle = 0;
00595   } else if (pp->print_hash_table
00596             && SCHEME_HASHTPx(obj)) {
00597     if (!((Scheme_Hash_Table *)obj)->count)
00598       cycle = 0;
00599     else
00600       /* don't bother with fast checks for non-empty hash tables */
00601       cycle = -1;
00602   } else if (pp->print_hash_table
00603             && SCHEME_HASHTRP(obj)) {
00604     if (!((Scheme_Hash_Tree *)obj)->count)
00605       cycle = 0;
00606     else
00607       /* don't bother with fast checks for non-empty hash trees */
00608       cycle = -1;
00609   } else
00610     cycle = 0;
00611 
00612   return cycle;
00613 }
00614 
00615 #ifdef MZ_XFORM
00616 END_XFORM_SKIP;
00617 #endif
00618 
00619 #ifdef DO_STACK_CHECK
00620 static void setup_graph_table(Scheme_Object *obj, int for_write, Scheme_Hash_Table *ht, int *counter, PrintParams *pp);
00621 
00622 static Scheme_Object *setup_graph_k(void)
00623 {
00624   Scheme_Thread *p = scheme_current_thread;
00625   Scheme_Object *o = (Scheme_Object *)p->ku.k.p1;
00626   Scheme_Hash_Table *ht = (Scheme_Hash_Table *)p->ku.k.p2;
00627   int *counter = (int *)p->ku.k.p3;
00628   PrintParams *pp = (PrintParams *)p->ku.k.p4;
00629   int for_write = p->ku.k.i1;
00630 
00631   p->ku.k.p1 = NULL;
00632   p->ku.k.p2 = NULL;
00633   p->ku.k.p3 = NULL;
00634   p->ku.k.p4 = NULL;
00635 
00636   setup_graph_table(o, for_write, ht, counter, pp);
00637 
00638   return scheme_false;
00639 }
00640 #endif
00641 
00642 static void setup_graph_table(Scheme_Object *obj, int for_write, Scheme_Hash_Table *ht,
00643                            int *counter, PrintParams *pp)
00644 {
00645   if (HAS_SUBSTRUCT(obj, ssQUICKp)) {
00646     Scheme_Object *v;
00647 
00648 #ifdef DO_STACK_CHECK
00649     {
00650 # include "mzstkchk.h"
00651       {
00652        if (pp)
00653          pp = copy_print_params(pp);
00654        scheme_current_thread->ku.k.p1 = (void *)obj;
00655        scheme_current_thread->ku.k.p2 = (void *)ht;
00656        scheme_current_thread->ku.k.p3 = (void *)counter;
00657        scheme_current_thread->ku.k.p4 = (void *)pp;
00658         scheme_current_thread->ku.k.i1 = for_write;
00659        scheme_handle_stack_overflow(setup_graph_k);
00660        return;
00661       }
00662     }
00663 #endif
00664 
00665     v = scheme_hash_get(ht, obj);
00666 
00667     if (!v)
00668       scheme_hash_set(ht, obj, (Scheme_Object *)0x1);
00669     else {
00670       if ((long)v == 1) {
00671        (*counter) += 2;
00672        scheme_hash_set(ht, obj, (Scheme_Object *)(long)*counter);
00673       }
00674       return;
00675     }
00676   } else
00677     return;
00678 
00679   SCHEME_USE_FUEL(1);
00680 
00681   if (SCHEME_PAIRP(obj) || SCHEME_MUTABLE_PAIRP(obj)) {
00682     setup_graph_table(SCHEME_CAR(obj), for_write, ht, counter, pp);
00683     setup_graph_table(SCHEME_CDR(obj), for_write, ht, counter, pp);
00684   } else if ((!pp || pp->print_box) && SCHEME_BOXP(obj)) {
00685     setup_graph_table(SCHEME_BOX_VAL(obj), for_write, ht, counter, pp);
00686   } else if (SCHEME_VECTORP(obj)) {
00687     int i, len;
00688 
00689     len = SCHEME_VEC_SIZE(obj);
00690     for (i = 0; i < len; i++) {
00691       setup_graph_table(SCHEME_VEC_ELS(obj)[i], for_write, ht, counter, pp);
00692     }
00693   } else if (pp && SCHEME_STRUCTP(obj)) { /* got here => printable */
00694     if (scheme_is_writable_struct(obj)) {
00695       if (pp->print_unreadable) {
00696        obj = writable_struct_subs(obj, for_write, pp);
00697        setup_graph_table(obj, for_write, ht, counter, pp);
00698       }
00699     } else {
00700       int i = SCHEME_STRUCT_NUM_SLOTS(obj);
00701 
00702       while (i--) {
00703        if (scheme_inspector_sees_part(obj, pp->inspector, i))
00704          setup_graph_table(((Scheme_Structure *)obj)->slots[i], for_write, ht, counter, pp);
00705       }
00706     }
00707   } else if (pp && SCHEME_HASHTPx(obj)) { /* got here => printable */
00708     Scheme_Hash_Table *t;
00709     Scheme_Object **keys, **vals, *val;
00710     int i;
00711     
00712     t = (Scheme_Hash_Table *)obj;
00713     keys = t->keys;
00714     vals = t->vals;
00715     for (i = t->size; i--; ) {
00716       if (vals[i]) {
00717        val = vals[i];
00718        setup_graph_table(keys[i], for_write, ht, counter, pp);
00719        setup_graph_table(val, for_write, ht, counter, pp);
00720       }
00721     }
00722   } else if (SCHEME_HASHTRP(obj)) {
00723     /* got here => printable */
00724     Scheme_Hash_Tree *t = (Scheme_Hash_Tree *)obj;
00725     Scheme_Object *key, *val;
00726     int i;
00727     
00728     i = scheme_hash_tree_next(t, -1);
00729     while (i != -1) {
00730       scheme_hash_tree_index(t, i, &key, &val);
00731       setup_graph_table(key, for_write, ht, counter, pp);
00732       setup_graph_table(val, for_write, ht, counter, pp);
00733       i = scheme_hash_tree_next(t, i);
00734     }
00735   }
00736 }
00737 
00738 #define CACHE_HT_SIZE_LIMIT 32
00739 
00740 static Scheme_Hash_Table *setup_datum_graph(Scheme_Object *o, int for_write, void *for_print)
00741 {
00742   Scheme_Hash_Table *ht;
00743   int counter = 1;
00744 
00745   if (cache_ht) {
00746     ht = cache_ht;
00747     cache_ht = NULL;
00748   } else
00749     ht = scheme_make_hash_table(SCHEME_hash_ptr);
00750 
00751   setup_graph_table(o, for_write, ht, &counter, (PrintParams *)for_print);
00752 
00753   if (counter > 1)
00754     return ht;
00755   else {
00756     if (ht->size < CACHE_HT_SIZE_LIMIT) {
00757       int i;
00758       for (i = 0; i < ht->size; i++) {
00759        ht->keys[i] = NULL;
00760        ht->vals[i] = NULL;
00761       }
00762       cache_ht = ht;
00763     }
00764     return NULL;
00765   }
00766 }
00767 
00768 static char *
00769 print_to_string(Scheme_Object *obj, 
00770               long * volatile len, int write,
00771               Scheme_Object *port, long maxl,
00772               int check_honu)
00773 {
00774   Scheme_Hash_Table * volatile ht;
00775   Scheme_Object *v;
00776   char *ca;
00777   int cycles;
00778   Scheme_Config *config;
00779   mz_jmp_buf escape;
00780   volatile PrintParams params;
00781 
00782   params.print_allocated = 50;
00783   ca = (char *)scheme_malloc_atomic(params.print_allocated);
00784   params.print_buffer = ca;
00785   params.print_position = 0;
00786   params.print_offset = 0;
00787   params.print_maxlen = maxl;
00788   params.print_port = port;
00789 
00790   /* Getting print params can take a while, and they're irrelevant
00791      for simple things like displaying numbers. So try a shortcut: */
00792   if (!write
00793       && (SCHEME_NUMBERP(obj)
00794          || SCHEME_BYTE_STRINGP(obj)
00795          || SCHEME_CHAR_STRINGP(obj)
00796          || SCHEME_SYMBOLP(obj))) {
00797     params.print_graph = 0;
00798     params.print_box = 0;
00799     params.print_struct = 0;
00800     params.print_vec_shorthand = 0;
00801     params.print_hash_table = 0;
00802     params.print_unreadable = 1;
00803     params.print_pair_curly = 0;
00804     params.print_mpair_curly = 1;
00805     params.can_read_pipe_quote = 1;
00806     params.case_sens = 1;
00807     params.honu_mode = 0;
00808     params.inspector = scheme_false;
00809   } else {
00810     config = scheme_current_config();
00811 
00812     v = scheme_get_param(config, MZCONFIG_PRINT_GRAPH);
00813     params.print_graph = SCHEME_TRUEP(v);
00814     v = scheme_get_param(config, MZCONFIG_PRINT_BOX);
00815     params.print_box = SCHEME_TRUEP(v);
00816     v = scheme_get_param(config, MZCONFIG_PRINT_STRUCT);
00817     params.print_struct = SCHEME_TRUEP(v);
00818     v = scheme_get_param(config, MZCONFIG_PRINT_VEC_SHORTHAND);
00819     params.print_vec_shorthand = SCHEME_TRUEP(v);
00820     v = scheme_get_param(config, MZCONFIG_PRINT_HASH_TABLE);
00821     params.print_hash_table = SCHEME_TRUEP(v);
00822     if (write) {
00823       if (maxl > 0)
00824        params.print_unreadable = 1;
00825       else {
00826        v = scheme_get_param(config, MZCONFIG_PRINT_UNREADABLE);
00827        params.print_unreadable = SCHEME_TRUEP(v);
00828       }
00829     } else
00830       params.print_unreadable = 1;
00831     v = scheme_get_param(config, MZCONFIG_PRINT_PAIR_CURLY);
00832     params.print_pair_curly = SCHEME_TRUEP(v);
00833     v = scheme_get_param(config, MZCONFIG_PRINT_MPAIR_CURLY);
00834     params.print_mpair_curly = SCHEME_TRUEP(v);
00835     v = scheme_get_param(config, MZCONFIG_CAN_READ_PIPE_QUOTE);
00836     params.can_read_pipe_quote = SCHEME_TRUEP(v);
00837     v = scheme_get_param(config, MZCONFIG_CASE_SENS);
00838     params.case_sens = SCHEME_TRUEP(v);
00839     if (check_honu) {
00840       v = scheme_get_param(config, MZCONFIG_HONU_MODE);
00841       params.honu_mode = SCHEME_TRUEP(v);
00842     } else
00843       params.honu_mode = 0;
00844     v = scheme_get_param(config, MZCONFIG_INSPECTOR);
00845     params.inspector = v;
00846   }
00847 
00848   if (params.print_graph)
00849     cycles = 1;
00850   else {
00851     int fast_checker_counter = 50;
00852     cycles = check_cycles_fast(obj, (PrintParams *)&params, &fast_checker_counter);
00853     if (cycles == -1) {
00854       ht = scheme_make_hash_table(SCHEME_hash_ptr);
00855       cycles = check_cycles(obj, write, ht, (PrintParams *)&params);
00856     }
00857   }
00858 
00859   if (cycles)
00860     ht = setup_datum_graph(obj, write, (PrintParams *)&params);
00861   else
00862     ht = NULL;
00863 
00864   if (maxl > 0)
00865     params.print_escape = &escape;
00866   else
00867     params.print_escape = NULL;
00868 
00869   if ((maxl <= PRINT_MAXLEN_MIN) 
00870       || !scheme_setjmp(escape))
00871     print(obj, write, 0, ht, NULL, (PrintParams *)&params);
00872 
00873   params.print_buffer[params.print_position] = '\0';
00874 
00875   if (len)
00876     *len = params.print_position;
00877 
00878   params.inspector = NULL;
00879 
00880   return params.print_buffer;
00881 }
00882 
00883 static void 
00884 print_to_port(char *name, Scheme_Object *obj, Scheme_Object *port, int notdisplay, long maxl, int check_honu)
00885 {
00886   Scheme_Output_Port *op;
00887   char *str;
00888   long len;
00889   
00890   op = scheme_output_port_record(port);
00891   if (op->closed)
00892     scheme_raise_exn(MZEXN_FAIL, "%s: output port is closed", name);
00893 
00894   str = print_to_string(obj, &len, notdisplay, port, maxl, check_honu);
00895 
00896   scheme_write_byte_string(str, len, port);
00897 }
00898 
00899 static void print_this_string(PrintParams *pp, const char *str, int offset, int autolen)
00900      /* If str is NULL and autolen is 0, flush print buffer */
00901 {
00902   long len;
00903   char *oldstr;
00904 
00905   if (!autolen) {
00906     if (!str)
00907       len = 0;
00908     else
00909       return;
00910   } else if (autolen > 0)
00911     len = autolen;
00912   else
00913     len = strlen(str XFORM_OK_PLUS offset);
00914 
00915   if (!pp->print_buffer) {
00916     /* Just getting the length */
00917     pp->print_position += len;
00918     pp->print_offset += len;
00919     return;
00920   }
00921 
00922   if (len + pp->print_position + 1 > pp->print_allocated) {
00923     if (len + 1 >= pp->print_allocated)
00924       pp->print_allocated = 2 * pp->print_allocated + len + 1;
00925     else
00926       pp->print_allocated = 2 * pp->print_allocated;
00927 
00928     oldstr = pp->print_buffer;
00929     {
00930       char *ca;
00931       ca = (char *)scheme_malloc_atomic(pp->print_allocated);
00932       pp->print_buffer = ca;
00933     }
00934     memcpy(pp->print_buffer, oldstr, pp->print_position);
00935   }
00936 
00937   memcpy(pp->print_buffer + pp->print_position, str + offset, len);
00938   pp->print_position += len;
00939   pp->print_offset += len;
00940 
00941   /* ----------- Do not use str after this point --------------- */
00942   /*  It might be quick_buffer, and another thread might try to  */
00943   /*  use the buffer.                                            */
00944 
00945   SCHEME_USE_FUEL(len);
00946   
00947   if (pp->print_maxlen > PRINT_MAXLEN_MIN) {
00948     if (pp->print_position > pp->print_maxlen) {
00949       long l = pp->print_maxlen;
00950 
00951       pp->print_buffer[l] = 0;
00952       pp->print_buffer[l - 1] = '.';
00953       pp->print_buffer[l - 2] = '.';
00954       pp->print_buffer[l - 3] = '.';
00955 
00956       pp->print_position = l;
00957 
00958       scheme_longjmp(*pp->print_escape, 1);
00959     }
00960   } else if ((pp->print_position > MAX_PRINT_BUFFER) || !str) {
00961     if (pp->print_port) {
00962       pp->print_buffer[pp->print_position] = 0;
00963       scheme_write_byte_string(pp->print_buffer, pp->print_position, pp->print_port);
00964       
00965       pp->print_position = 0;
00966     }
00967   }
00968 }
00969 
00970 static void print_utf8_string(PrintParams *pp, const char *str, int offset, int autolen)
00971 {
00972   print_this_string(pp, str, offset, autolen);
00973 }
00974 
00975 void scheme_print_bytes(Scheme_Print_Params *pp, const char *str, int offset, int len)
00976 {
00977   print_this_string(pp, str, offset, len);
00978 }
00979 
00980 void scheme_print_utf8(Scheme_Print_Params *pp, const char *str, int offset, int len)
00981 {
00982   print_utf8_string(pp, str, offset, len);
00983 }
00984 
00985 static void print_number(PrintParams *pp, long n)
00986 {
00987   unsigned char s[4];
00988 
00989   s[0] = (unsigned char)(n & 0xFF);
00990   s[1] = (unsigned char)((n >> 8) & 0xFF);
00991   s[2] = (unsigned char)((n >> 16) & 0xFF);
00992   s[3] = (unsigned char)((n >> 24) & 0xFF);  
00993   
00994   print_this_string(pp, (char *)s, 0, 4);
00995 }
00996 
00997 static void print_short_number(PrintParams *pp, long n)
00998 {
00999   unsigned char s[2];
01000 
01001   s[0] = (unsigned char)(n & 0xFF);
01002   s[1] = (unsigned char)((n >> 8) & 0xFF);
01003   
01004   print_this_string(pp, (char *)s, 0, 2);
01005 }
01006 
01007 static void print_one_byte(PrintParams *pp, int n)
01008 {
01009   unsigned char s[1];
01010 
01011   s[0] = n;
01012   
01013   print_this_string(pp, (char *)s, 0, 1);
01014 }
01015 
01016 static void print_compact_number(PrintParams *pp, long n)
01017 {
01018   unsigned char s[2];
01019 
01020   if (n < 0) {
01021     if (n > -32) {
01022       s[0] = (unsigned char)(0xC0 | (-n));
01023       print_this_string(pp, (char *)s, 0, 1);
01024       return;
01025     } else {
01026       n = -n;
01027       s[0] = 0xE0;
01028     }
01029   } else if (n < 128) {
01030     s[0] = (unsigned char)n;
01031     print_this_string(pp, (char *)s, 0, 1);
01032     return;
01033   } else if (n < 0x4000) {
01034     s[0] = (unsigned char)(0x80 | (n & 0x3F));
01035     s[1] = (unsigned char)((n >> 6) & 0xFF);
01036     print_this_string(pp, (char *)s, 0, 2);
01037     return;
01038   } else {
01039     s[0] = 0xF0;
01040   }
01041 
01042   print_this_string(pp, (char *)s, 0, 1);
01043   print_number(pp, n);
01044 }
01045 
01046 static void do_print_string(int compact, int notdisplay, 
01047                          Scheme_Print_Params *pp, const mzchar *s, int offset, int l)
01048 {
01049   int el, reset;
01050   char *buf;
01051 
01052   el = l * MAX_UTF8_CHAR_BYTES;
01053   if (el <= QUICK_ENCODE_BUFFER_SIZE) {
01054     if (quick_encode_buffer) {
01055       buf = quick_encode_buffer;
01056       quick_encode_buffer = NULL;
01057     } else
01058       buf = (char *)scheme_malloc_atomic(QUICK_ENCODE_BUFFER_SIZE);
01059     reset = 1;
01060   } else {
01061     buf = (char *)scheme_malloc_atomic(el);
01062     reset = 0;
01063   }
01064 
01065   el = scheme_utf8_encode(s, offset, offset + l, (unsigned char *)buf, 0, 0);
01066 
01067   if (compact) {
01068     print_compact(pp, CPT_CHAR_STRING);
01069     print_compact_number(pp, el);
01070     print_compact_number(pp, l);
01071     print_this_string(pp, buf, 0, el);
01072   } else {
01073     print_char_string(buf, el, s, offset, l, notdisplay, 0, pp);
01074   }
01075 
01076   if (reset)
01077     quick_encode_buffer = buf;
01078 }
01079 
01080 void scheme_print_string(Scheme_Print_Params *pp, const mzchar *s, int offset, int l)
01081 {
01082   do_print_string(0, 0, pp, s, offset, l);
01083 }
01084 
01085 static void print_string_in_angle(PrintParams *pp, const char *start, const char *prefix, int slen)
01086 {
01087   /* Used to do something special for type symbols. No more. */
01088   print_utf8_string(pp, prefix, 0, -1);
01089   print_utf8_string(pp, start, 0, slen);
01090 }
01091 
01092 #ifdef DO_STACK_CHECK
01093 
01094 static Scheme_Object *print_k(void)
01095 {
01096   Scheme_Thread *p = scheme_current_thread;
01097   Scheme_Object *o = (Scheme_Object *)p->ku.k.p1;
01098   Scheme_Hash_Table *ht = (Scheme_Hash_Table *)p->ku.k.p2;
01099   Scheme_Marshal_Tables *mt = (Scheme_Marshal_Tables *)p->ku.k.p3;
01100   PrintParams *pp = (PrintParams *)p->ku.k.p5;
01101   mz_jmp_buf * volatile save;
01102   mz_jmp_buf newbuf;
01103 
01104   p->ku.k.p1 = NULL;
01105   p->ku.k.p2 = NULL;
01106   p->ku.k.p3 = NULL;
01107   p->ku.k.p5 = NULL;
01108 
01109   save = pp->print_escape;
01110   pp->print_escape = &newbuf;
01111   if (scheme_setjmp(newbuf)) {
01112 #ifdef MZ_PRECISE_GC
01113     scheme_make_pair(scheme_void, scheme_void);
01114 #endif
01115     pp->print_escape = save;
01116     return scheme_void;
01117   } else {
01118     return print(o, 
01119                p->ku.k.i1, 
01120                p->ku.k.i2, 
01121                ht,
01122                  mt,
01123                pp) 
01124       ? scheme_true : scheme_false;
01125   }
01126 }
01127 #endif
01128 
01129 #ifdef MZ_XFORM
01130 START_XFORM_SKIP;
01131 #endif
01132 #include "../gc2/my_qsort.c"
01133 #ifdef MZ_XFORM
01134 END_XFORM_SKIP;
01135 #endif
01136 
01137 static int compare_keys(const void *a, const void *b)
01138 {
01139   Scheme_Object *av, *bv;
01140 
01141   /* Atomic things first, because they could be used by
01142      marshaled syntax. This cuts donw on recursive reads
01143      at load time. */
01144 # define SCHEME_FIRSTP(v) (SCHEME_SYMBOLP(v) \
01145                            || SCHEME_PATHP(v) \
01146                            || SCHEME_KEYWORDP(v) \
01147                            || SCHEME_CHAR_STRINGP(v) \
01148                            || SCHEME_BYTE_STRINGP(v) \
01149                            || SCHEME_CHARP(v) \
01150                            || SAME_TYPE(SCHEME_TYPE(v), scheme_module_index_type))
01151   av = ((Scheme_Object **)a)[0];
01152   bv = ((Scheme_Object **)b)[0];
01153   if (SCHEME_FIRSTP(av)) {
01154     if (!SCHEME_FIRSTP(bv))
01155       return -1;
01156   } else if (SCHEME_FIRSTP(bv))
01157     return 1;
01158 
01159   return ((long *)a)[1] - ((long *)b)[1];
01160 }
01161 
01162 static void sort_referenced_keys(Scheme_Marshal_Tables *mt)
01163 {
01164   long j, size, pos = 0;
01165   Scheme_Object **keys;
01166   Scheme_Hash_Table *key_map;
01167 
01168   size = mt->st_refs->count;
01169   keys = MALLOC_N(Scheme_Object *, (2 * size));
01170 
01171   for (j = 0; j < mt->st_refs->size; j++) {
01172     if (mt->st_refs->vals[j]) {
01173       keys[pos] = mt->st_refs->keys[j];
01174       keys[pos + 1] = mt->st_refs->vals[j];
01175       pos += 2;
01176     }
01177   }
01178 
01179   my_qsort(keys, size, 2 * sizeof(Scheme_Object *), compare_keys);
01180 
01181   key_map = scheme_make_hash_table(SCHEME_hash_ptr);
01182   for (j = 0; j < size; j++) {
01183     scheme_hash_set(key_map, keys[(j << 1) + 1], scheme_make_integer(j+1));
01184   }
01185   mt->key_map = key_map;
01186 
01187   mt->sorted_keys = keys;
01188   mt->sorted_keys_count = size;
01189 }
01190 
01191 static void print_table_keys(int notdisplay, int compact, Scheme_Hash_Table *ht,
01192                              Scheme_Marshal_Tables *mt,
01193                              PrintParams *pp)
01194 {
01195   long j, size, offset;
01196   Scheme_Object **keys, *key, *obj;
01197 
01198   size = mt->sorted_keys_count;
01199   keys = mt->sorted_keys;
01200 
01201   for (j = 0; j < size; j++) {
01202     offset = pp->print_offset;
01203     mt->shared_offsets[j] = offset;
01204     key = keys[j << 1];
01205     if (mt->rn_saved) {
01206       obj = scheme_hash_get(mt->rn_saved, key);
01207     } else {
01208       obj = NULL;
01209     }
01210     if (!obj)
01211       obj = key;
01212     mt->print_now = j + 1;
01213     print(obj ? obj : key, notdisplay, compact, ht, mt, pp);
01214     mt->print_now = 0;
01215   }
01216 }
01217 
01218 static int
01219 print_substring(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
01220                 Scheme_Marshal_Tables *mt,
01221               PrintParams *pp, char **result, long *rlen,
01222                 int print_keys, long *klen)
01223 {
01224   int closed;
01225   long save_alloc, save_pos, save_off, save_maxl;
01226   char *save_buf;
01227   Scheme_Object *save_port;
01228 
01229   save_alloc = pp->print_allocated;
01230   save_buf = pp->print_buffer;
01231   save_pos = pp->print_position;
01232   save_off = pp->print_offset;
01233   save_maxl = pp->print_maxlen;
01234   save_port = pp->print_port;
01235   
01236   /* If result is NULL, just measure the output. */
01237   if (result) {
01238     char *ca;
01239     pp->print_allocated = 50;
01240     ca = (char *)scheme_malloc_atomic(pp->print_allocated);
01241     pp->print_buffer = ca;
01242   } else {
01243     pp->print_allocated = 0;
01244     pp->print_buffer = NULL;
01245   }
01246   pp->print_position = 0;
01247   pp->print_offset = 0;
01248   pp->print_port = NULL;
01249 
01250   if (print_keys < 0) {
01251     print_table_keys(notdisplay, compact, ht, mt, pp);
01252     *klen = pp->print_offset;
01253   }
01254 
01255   closed = print(obj, notdisplay, compact, ht, mt, pp);
01256   
01257   if (print_keys > 0) {
01258     print_table_keys(notdisplay, compact, ht, mt, pp);
01259     *klen = pp->print_offset;
01260   }
01261 
01262   if (result)
01263     *result = pp->print_buffer;
01264   *rlen = pp->print_position;
01265 
01266   pp->print_allocated = save_alloc;
01267   pp->print_buffer = save_buf;
01268   pp->print_position = save_pos;
01269   pp->print_offset = save_off;
01270   pp->print_maxlen = save_maxl;
01271   pp->print_port = save_port;
01272   
01273   return closed;
01274 }
01275 
01276 static Scheme_Object *get_symtab_idx(Scheme_Marshal_Tables *mt, Scheme_Object *obj)
01277 {
01278   Scheme_Object *idx;
01279 
01280   idx = scheme_hash_get(mt->symtab, obj);
01281 
01282   if (idx) {
01283     if (!mt->pass) {
01284       /* Record that we're referencing it */
01285       scheme_hash_set(mt->st_refs, obj, idx);
01286     }
01287   } else {
01288     if (mt->pass && mt->print_now) {
01289       idx = scheme_hash_get(mt->st_refs, obj);
01290       if (idx) {
01291         idx = scheme_hash_get(mt->key_map, idx);
01292         if (SCHEME_INT_VAL(idx) != mt->print_now)
01293           return idx; /* due to a cycle, we're refering to
01294                          something before it is printed. */
01295         idx = NULL; /* ok to print */
01296       }
01297     }
01298   }
01299 
01300   return idx;
01301 }
01302 
01303 static void set_symtab_shared(Scheme_Marshal_Tables *mt, Scheme_Object *obj)
01304 {
01305   (void)get_symtab_idx(mt, obj);
01306 }
01307 
01308 static void print_general_symtab_ref(PrintParams *pp, Scheme_Object *idx, int cpt_id)
01309 {
01310   int l;
01311   print_compact(pp, cpt_id);
01312   l = SCHEME_INT_VAL(idx);
01313   print_compact_number(pp, l);
01314 }
01315 
01316 static void print_symtab_ref(PrintParams *pp, Scheme_Object *idx)
01317 {
01318   print_general_symtab_ref(pp, idx, CPT_SYMREF);
01319 }
01320 
01321 static int add_symtab(Scheme_Marshal_Tables *mt, Scheme_Object *obj)
01322 {
01323   if (!mt->pass) {
01324     int l;
01325     l = mt->symtab->count + 1;
01326     scheme_hash_set(mt->symtab, obj, scheme_make_integer(l));
01327     return l;
01328   } else {
01329     Scheme_Object *key, *l;
01330 
01331     key = scheme_hash_get(mt->st_refs, obj);
01332     for (l = mt->st_ref_stack; !key && SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
01333       key = scheme_hash_get((Scheme_Hash_Table *)SCHEME_CAR(l), obj);
01334     }
01335 
01336     if (!key) {
01337       /* There's no other reference to this object, so use dummy slot 0. */
01338       return 0;
01339     }
01340 
01341     key = scheme_hash_get(mt->key_map, key);
01342 
01343     scheme_hash_set(mt->symtab, obj, key);
01344 
01345     return SCHEME_INT_VAL(key);
01346   }
01347 }
01348 
01349 static void symtab_set(PrintParams *pp, Scheme_Marshal_Tables *mt, Scheme_Object *obj)
01350 {
01351   (void)add_symtab(mt, obj);
01352 }
01353 
01354 static void print_symtab_set(PrintParams *pp, Scheme_Marshal_Tables *mt, Scheme_Object *obj)
01355 {
01356   int l;
01357   l = add_symtab(mt, obj);
01358   print_compact_number(pp, l);
01359 }
01360 
01361 Scheme_Object *scheme_marshal_wrap_set(Scheme_Marshal_Tables *mt, Scheme_Object *obj, Scheme_Object *val)
01362 {
01363   int l;
01364   l = add_symtab(mt, obj);
01365   if (l) {
01366     if (!mt->rn_saved) {
01367       Scheme_Hash_Table *rn_saved;
01368       rn_saved = scheme_make_hash_table(SCHEME_hash_ptr);
01369       mt->rn_saved = rn_saved;
01370     }
01371     if (mt->pass >= 2) {
01372       /* Done already */
01373     } else
01374       scheme_hash_set(mt->rn_saved, obj, val);
01375 
01376     if (mt->pass)
01377       return scheme_make_integer(l);
01378   }
01379   return val;
01380 }
01381 
01382 Scheme_Object *scheme_marshal_lookup(Scheme_Marshal_Tables *mt, Scheme_Object *obj)
01383 {
01384   return get_symtab_idx(mt, obj);
01385 }
01386 
01387 void scheme_marshal_using_key(Scheme_Marshal_Tables *mt, Scheme_Object *obj)
01388 {
01389   set_symtab_shared(mt, obj);
01390 }
01391 
01392 void scheme_marshal_push_refs(Scheme_Marshal_Tables *mt)
01393 {
01394   Scheme_Object *p;
01395   Scheme_Hash_Table *st_refs;
01396 
01397   p = scheme_make_pair((Scheme_Object *)mt->st_refs,
01398                        mt->st_ref_stack);
01399   mt->st_ref_stack = p;
01400 
01401   st_refs = scheme_make_hash_table(SCHEME_hash_ptr);
01402 
01403   mt->st_refs = st_refs;
01404 }
01405 
01406 void scheme_marshal_pop_refs(Scheme_Marshal_Tables *mt, int keep)
01407 {
01408   Scheme_Hash_Table *st_refs = mt->st_refs;
01409 
01410   mt->st_refs = (Scheme_Hash_Table *)SCHEME_CAR(mt->st_ref_stack);
01411   mt->st_ref_stack = SCHEME_CDR(mt->st_ref_stack);
01412   
01413   if (keep) {
01414     if (!mt->st_refs->count)
01415       mt->st_refs = st_refs;
01416     else {
01417       long i;
01418       for (i = 0; i < st_refs->size; i++) {
01419         if (st_refs->vals[i]) {
01420           scheme_hash_set(mt->st_refs, st_refs->keys[i], st_refs->vals[i]);
01421         }
01422       }
01423     }
01424   }
01425 }
01426 
01427 static void print_escaped(PrintParams *pp, int notdisplay, 
01428                        Scheme_Object *obj, Scheme_Hash_Table *ht,
01429                           Scheme_Marshal_Tables *mt, int shared)
01430 {
01431   char *r;
01432   long len;
01433   Scheme_Object *idx;
01434 
01435   if (shared) {
01436     idx = get_symtab_idx(mt, obj);
01437     if (idx) {
01438       print_symtab_ref(pp, idx);
01439       return;
01440     }
01441   }
01442 
01443   print_substring(obj, notdisplay, 0, ht, NULL, pp, &r, &len, 0, NULL);
01444 
01445   print_compact(pp, CPT_ESCAPE);
01446   print_compact_number(pp, len);
01447   print_this_string(pp, r, 0, len);
01448 
01449   if (mt) {
01450     symtab_set(pp, mt, obj);
01451   }
01452 }
01453 
01454 static void cannot_print(PrintParams *pp, int notdisplay, 
01455                       Scheme_Object *obj, Scheme_Hash_Table *ht,
01456                       int compact)
01457 {
01458   scheme_raise_exn(MZEXN_FAIL,
01459                  (compact
01460                   ? "%s: cannot marshal constant that is embedded in compiled code: %V"
01461                   : "%s: printing disabled for unreadable value: %V"),
01462                  notdisplay ? "write" : "display",
01463                  obj);
01464 }
01465 
01466 #ifdef SGC_STD_DEBUGGING
01467 static void printaddress(PrintParams *pp, Scheme_Object *o)
01468 {
01469   char buf[40];
01470   sprintf(buf, ":%lx", (long)o);
01471   print_this_string(pp, buf, 0, -1);
01472 }
01473 # define PRINTADDRESS(pp, obj) printaddress(pp, obj)
01474 #else
01475 # define PRINTADDRESS(pp, obj) /* empty */
01476 #endif
01477 
01478 static void print_named(Scheme_Object *obj, const char *kind,
01479                      const char *s, int len, PrintParams *pp)
01480 {
01481   print_utf8_string(pp, "#<", 0, 2);
01482   print_utf8_string(pp, kind, 0, -1);
01483 
01484   if (s) {
01485     print_utf8_string(pp, ":", 0, 1);
01486 
01487     print_utf8_string(pp, s, 0, len);
01488   }
01489    
01490   PRINTADDRESS(pp, obj);
01491   print_utf8_string(pp, ">", 0, 1);
01492 }
01493 
01494 static void always_scheme(PrintParams *pp, int reset)
01495 {
01496   if (pp->honu_mode) {
01497     print_utf8_string(pp, "#sx", 0, 3);
01498     if (reset)
01499       pp->honu_mode = 0;
01500   }
01501 }
01502 
01503 static int
01504 print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
01505       Scheme_Marshal_Tables *mt, PrintParams *pp)
01506 {
01507   int closed = 0;
01508   int save_honu_mode;
01509 
01510 #if NO_COMPACT
01511   compact = 0;
01512 #endif
01513 
01514 #ifdef DO_STACK_CHECK
01515 #define PRINT_COUNT_START 20
01516   {
01517     static int check_counter = PRINT_COUNT_START;
01518 
01519     if (!--check_counter) {
01520       check_counter = PRINT_COUNT_START;
01521       {
01522 #include "mzstkchk.h"
01523        {
01524          Scheme_Thread *p = scheme_current_thread;
01525          PrintParams *pp2;
01526 
01527          pp2 = copy_print_params(pp);
01528 
01529          p->ku.k.p1 = (void *)obj;
01530          p->ku.k.i1 = notdisplay;
01531          p->ku.k.i2 = compact;
01532          p->ku.k.p2 = (void *)ht;
01533          p->ku.k.p3 = mt;
01534          p->ku.k.p5 = pp2;
01535 
01536          obj = scheme_handle_stack_overflow(print_k);
01537 
01538          memcpy(pp, pp2, sizeof(PrintParams));
01539 
01540          if (SCHEME_VOIDP(obj)) {
01541            scheme_longjmp(*pp->print_escape, 1);
01542          }
01543 
01544          return closed;
01545        }
01546       }
01547     }
01548   }
01549 #endif
01550 
01551   if (scheme_check_print_is_obj && !scheme_check_print_is_obj(obj)) {
01552     print_utf8_string(pp, "#<" "???" ">", 0, 6);
01553     return 1;
01554   }
01555 
01556   /* Built-in functions, exception types, eof, prop:waitable, ... */
01557   if (compact && (SCHEME_PROCP(obj) 
01558                 || SCHEME_STRUCT_TYPEP(obj) 
01559                 || SCHEME_EOFP(obj)
01560                 || SAME_TYPE(scheme_always_evt_type, SCHEME_TYPE(obj))
01561                 || SAME_TYPE(scheme_never_evt_type, SCHEME_TYPE(obj))
01562                 || SAME_TYPE(scheme_struct_property_type, SCHEME_TYPE(obj)))) {
01563     /* Check whether this is a global constant */
01564     Scheme_Object *val;
01565     val = scheme_hash_get(global_constants_ht, obj);
01566     if (val) {
01567       /* val is a scheme_variable_type object, instead of something else */
01568       obj = val;
01569     }
01570   }
01571 
01572   save_honu_mode = pp->honu_mode;
01573 
01574   if (ht && HAS_SUBSTRUCT(obj, ssQUICK)) {
01575     long val;
01576     
01577     val = (long)scheme_hash_get(ht, obj);
01578     
01579     if (val) {
01580       if (val != 1) {
01581        if (compact) {
01582          print_escaped(pp, notdisplay, obj, ht, mt, 0);
01583          return 1;
01584        } else {
01585          if (val > 0) {
01586            always_scheme(pp, 1);
01587            sprintf(quick_buffer, "#%ld=", (val - 3) >> 1);
01588            print_utf8_string(pp, quick_buffer, 0, -1);
01589            scheme_hash_set(ht, obj, (Scheme_Object *)(-val));
01590          } else {
01591            always_scheme(pp, 0);
01592            sprintf(quick_buffer, "#%ld#", ((-val) - 3) >> 1);
01593            print_utf8_string(pp, quick_buffer, 0, -1);
01594            return 0;
01595          }
01596        }
01597       }
01598     }
01599   }
01600 
01601   if (SCHEME_SYMBOLP(obj)
01602       || SCHEME_KEYWORDP(obj))
01603     {
01604       int l;
01605       Scheme_Object *idx;
01606       int is_kw;
01607 
01608       is_kw = SCHEME_KEYWORDP(obj);
01609 
01610       if (compact)
01611        idx = get_symtab_idx(mt, obj);
01612       else
01613        idx = NULL;
01614 
01615       if (idx) {
01616         print_symtab_ref(pp, idx);
01617       } else if (compact) {
01618        int weird;
01619 
01620        weird = SCHEME_SYM_WEIRDP(obj);
01621        l = SCHEME_SYM_LEN(obj);
01622        if (!weird && !is_kw && (l < CPT_RANGE(SMALL_SYMBOL))) {
01623          unsigned char s[1];
01624           s[0] = l + CPT_SMALL_SYMBOL_START;
01625          print_this_string(pp, (char *)s, 0, 1);
01626        } else {
01627          print_compact(pp, (is_kw
01628                           ? CPT_KEYWORD
01629                           : (weird ? CPT_WEIRD_SYMBOL : CPT_SYMBOL)));
01630          if (weird) {
01631            print_compact_number(pp, SCHEME_SYM_UNINTERNEDP(obj) ? 1 : 0);
01632          }
01633          print_compact_number(pp, l);
01634          /* Note: the written symbol table will preserve equivalence
01635              of uninterned symbols for a single compiled
01636              expression. */
01637        }
01638        print_this_string(pp, scheme_symbol_val(obj), 0, l);
01639 
01640         symtab_set(pp, mt, obj);
01641       } else if (notdisplay) {
01642        if (pp->honu_mode) {
01643          /* Honu symbol... */
01644          if (is_kw)
01645            print_utf8_string(pp, "key(", 0, 4);
01646          else
01647            print_utf8_string(pp, "sym(", 0, 4);
01648          {
01649            int i;
01650            /* Check for fast case: */
01651            for (i = SCHEME_SYM_LEN(obj); i--; ) {
01652              if (((unsigned char *)SCHEME_SYM_VAL(obj))[i] > 127)
01653               break;
01654            }
01655            if (i < 0) {
01656              /* Fits as byte string (fast case) */
01657              print_byte_string((char *)obj, SCHEME_SYMSTR_OFFSET(obj), SCHEME_SYM_LEN(obj),
01658                             notdisplay, pp);
01659            } else {
01660              /* Coerce to string (slower) */
01661              Scheme_Object *s;
01662              s = scheme_make_sized_offset_utf8_string((char *)obj,
01663                                                  SCHEME_SYMSTR_OFFSET(obj),
01664                                                  SCHEME_SYM_LEN(obj));
01665              do_print_string(0, notdisplay, pp, SCHEME_CHAR_STR_VAL(s), 0, SCHEME_CHAR_STRLEN_VAL(s));
01666            }
01667          }
01668          print_utf8_string(pp, ")", 0, 1);
01669        } else {
01670          const char *s;
01671          
01672          if (is_kw)
01673            print_utf8_string(pp, "#:", 0, 2);
01674          s = scheme_symbol_name_and_size(obj, (unsigned int *)&l, 
01675                                      ((pp->can_read_pipe_quote 
01676                                        ? SCHEME_SNF_PIPE_QUOTE
01677                                        : SCHEME_SNF_NO_PIPE_QUOTE)
01678                                       | (pp->case_sens
01679                                          ? 0
01680                                          : SCHEME_SNF_NEED_CASE)
01681                                       | (is_kw
01682                                          ? SCHEME_SNF_KEYWORD
01683                                          : 0)));
01684          print_utf8_string(pp, s, 0, l);
01685        }
01686       } else {
01687        if (is_kw)
01688          print_utf8_string(pp, "#:", 0, 2);
01689        print_utf8_string(pp, (char *)obj, ((char *)(SCHEME_SYM_VAL(obj))) - ((char *)obj), 
01690                        SCHEME_SYM_LEN(obj));
01691       }
01692     }
01693   else if (SCHEME_BYTE_STRINGP(obj))
01694     {
01695       if (compact) {
01696        int l;
01697         Scheme_Object *idx;
01698 
01699        idx = get_symtab_idx(mt, obj);
01700         if (idx) {
01701           print_symtab_ref(pp, idx);
01702         } else {
01703           print_compact(pp, CPT_BYTE_STRING);
01704           l = SCHEME_BYTE_STRTAG_VAL(obj);
01705           print_compact_number(pp, l);
01706           print_this_string(pp, SCHEME_BYTE_STR_VAL(obj), 0, l);
01707 
01708           symtab_set(pp, mt, obj);
01709         }
01710       } else {
01711        if (notdisplay) {
01712          always_scheme(pp, 0);
01713          print_utf8_string(pp, "#", 0, 1);
01714        }
01715        print_byte_string(SCHEME_BYTE_STR_VAL(obj), 
01716                        0,
01717                        SCHEME_BYTE_STRLEN_VAL(obj), 
01718                        notdisplay, pp);
01719        closed = 1;
01720       }
01721     }
01722   else if (SCHEME_CHAR_STRINGP(obj))
01723     {
01724       Scheme_Object *idx;
01725 
01726       if (compact)
01727         idx = get_symtab_idx(mt, obj);
01728       else
01729         idx = NULL;
01730 
01731       if (idx) {
01732         print_symtab_ref(pp, idx);
01733       } else {
01734         do_print_string(compact, notdisplay, pp, 
01735                         SCHEME_CHAR_STR_VAL(obj), 0, SCHEME_CHAR_STRTAG_VAL(obj));
01736         if (compact)
01737           symtab_set(pp, mt, obj);
01738       }
01739       closed = 1;
01740     }
01741   else if (SCHEME_CHARP(obj))
01742     {
01743       if (compact) {
01744        int cv;
01745        print_compact(pp, CPT_CHAR);
01746        cv = SCHEME_CHAR_VAL(obj);
01747        print_compact_number(pp, cv);
01748       } else if (notdisplay && pp->honu_mode) {
01749        /* Honu char */
01750        char s[MAX_UTF8_CHAR_BYTES];
01751        mzchar us[1];
01752        int l;
01753        us[0] = SCHEME_CHAR_VAL(obj);
01754        l = scheme_utf8_encode(us, 0, 1, (unsigned char *)s, 0, 0);
01755        print_char_string(s, l, us, 0, 1, notdisplay, 1, pp);
01756       } else
01757        print_char(obj, notdisplay, pp);
01758     }
01759   else if (SCHEME_INTP(obj))
01760     {
01761       if (compact) {
01762        long v = SCHEME_INT_VAL(obj);
01763        if (v >= 0 && v < CPT_RANGE(SMALL_NUMBER)) {
01764          unsigned char s[1];
01765          s[0] = (unsigned char)(v + CPT_SMALL_NUMBER_START);
01766          print_this_string(pp, (char *)s, 0, 1);
01767        } else {
01768           /* Make sure it's a fixnum on all platforms... */
01769           if ((v >= -1073741824) && (v <= 1073741823)) {
01770             print_compact(pp, CPT_INT);
01771             print_compact_number(pp, v);
01772           } else {
01773             print_escaped(pp, notdisplay, obj, ht, mt, 1);
01774           }
01775        }
01776       } else {
01777        sprintf(quick_buffer, "%ld", SCHEME_INT_VAL(obj));
01778        print_utf8_string(pp, quick_buffer, 0, -1);
01779       }
01780     }
01781   else if (SCHEME_NUMBERP(obj))
01782     {
01783       if (compact) {
01784        print_escaped(pp, notdisplay, obj, ht, mt, 1);
01785        closed = 1;
01786       } else {
01787        if (SCHEME_COMPLEXP(obj))
01788          always_scheme(pp, 0);
01789        print_utf8_string(pp, scheme_number_to_string(10, obj), 0, -1);
01790       }
01791     }
01792   else if (SCHEME_NULLP(obj))
01793     {
01794       if (compact) {
01795        print_compact(pp, CPT_NULL);
01796       } else {
01797        if (pp->honu_mode)
01798          print_utf8_string(pp, "null", 0, 4);
01799        else
01800          print_utf8_string(pp, "()", 0, 2);
01801        closed = 1;
01802       }
01803     }
01804   else if (SCHEME_PAIRP(obj))
01805     {
01806       print_pair(obj, notdisplay, compact, ht, mt, pp, scheme_pair_type, !pp->print_pair_curly);
01807       closed = 1;
01808     }
01809   else if (SCHEME_MUTABLE_PAIRP(obj))
01810     {
01811       if (compact || !pp->print_unreadable)
01812        cannot_print(pp, notdisplay, obj, ht, compact);
01813       print_pair(obj, notdisplay, compact, ht, mt, pp, scheme_mutable_pair_type, !pp->print_mpair_curly);
01814       closed = 1;
01815     }
01816   else if (SCHEME_VECTORP(obj))
01817     {
01818       print_vector(obj, notdisplay, compact, ht, mt, pp, 0);
01819       closed = 1;
01820     }
01821   else if ((compact || pp->print_box) && SCHEME_BOXP(obj))
01822     {
01823       if (compact && !pp->print_box) {
01824        closed = print(scheme_protect_quote(obj), notdisplay, compact, ht, mt, pp);
01825       } else {
01826        if (compact)
01827          print_compact(pp, CPT_BOX);
01828        else {
01829          always_scheme(pp, 1);
01830          print_utf8_string(pp, "#&", 0, 2);
01831        }
01832        closed = print(SCHEME_BOX_VAL(obj), notdisplay, compact, ht, mt, pp);
01833       }
01834     }
01835   else if ((compact || pp->print_hash_table) 
01836            && (SCHEME_HASHTPx(obj) || SCHEME_HASHTRP(obj)))
01837     {
01838       Scheme_Hash_Table *t;
01839       Scheme_Hash_Tree *tr;
01840       Scheme_Object **keys, **vals, *val, *key;
01841       int i, size, did_one = 0;
01842 
01843       if (compact) {
01844        print_compact(pp, CPT_HASH_TABLE);
01845        if ((SCHEME_HASHTP(obj) && scheme_is_hash_table_equal(obj))
01846             || (SCHEME_HASHTRP(obj) && scheme_is_hash_tree_equal(obj)))
01847          print_compact_number(pp, 1);
01848        else if ((SCHEME_HASHTP(obj) && scheme_is_hash_table_eqv(obj))
01849                  || (SCHEME_HASHTRP(obj) && scheme_is_hash_tree_eqv(obj)))
01850          print_compact_number(pp, 2);
01851        else
01852          print_compact_number(pp, 0);
01853       } else {
01854        always_scheme(pp, 1);
01855        print_utf8_string(pp, "#hash", 0, 5);
01856         if (SCHEME_HASHTP(obj)) {
01857           if (!scheme_is_hash_table_equal(obj)) {
01858             if (scheme_is_hash_table_eqv(obj))
01859               print_utf8_string(pp, "eqv", 0, 3);
01860             else
01861               print_utf8_string(pp, "eq", 0, 2);
01862           }
01863         } else {
01864           if (!scheme_is_hash_tree_equal(obj)) {
01865             if (scheme_is_hash_tree_eqv(obj))
01866               print_utf8_string(pp, "eqv", 0, 3);
01867             else
01868               print_utf8_string(pp, "eq", 0, 2);
01869           }
01870         }
01871        print_utf8_string(pp, "(", 0, 1);
01872       }
01873 
01874       if (SCHEME_HASHTP(obj)) {
01875         t = (Scheme_Hash_Table *)obj;
01876         tr = NULL;
01877       } else {
01878         t = NULL;
01879         tr = (Scheme_Hash_Tree *)obj;
01880       }
01881 
01882       if (compact)
01883         print_compact_number(pp, t ? t->count : tr->count);
01884 
01885       if (t) {
01886         keys = t->keys;
01887         vals = t->vals;
01888         size = t->size;
01889       } else {
01890         keys = NULL;
01891         vals = NULL;
01892         size = tr->count;
01893       }
01894       for (i = 0; i < size; i++) {
01895        if (!vals || vals[i]) {
01896           if (!vals) {
01897             scheme_hash_tree_index(tr, i, &key, &val);
01898           } else {
01899             val = vals[i];
01900             key = keys[i];
01901           }
01902 
01903          if (!compact) {
01904            if (did_one)
01905              print_utf8_string(pp, " ", 0, 1);
01906            print_utf8_string(pp, "(", 0, 1);
01907          }
01908          print(key, notdisplay, compact, ht, mt, pp);
01909          if (!compact)
01910            print_utf8_string(pp, " . ", 0, 3);
01911          print(val, notdisplay, compact, ht, mt, pp);
01912          if (!compact)
01913            print_utf8_string(pp, ")", 0, 1);
01914          did_one++;
01915        }
01916       }
01917 
01918       if (!compact)
01919        print_utf8_string(pp, ")", 0, 1);
01920 
01921       closed = 1;
01922     }
01923   else if (compact && SCHEME_HASHTP(obj))
01924     {
01925       /* since previous case didn't catch this table, it has a 0x1 flag
01926          and should be marshalled as #t */
01927       print_compact(pp, CPT_TRUE);
01928     }
01929   else if (SAME_OBJ(obj, scheme_true))
01930     {
01931       if (compact)
01932        print_compact(pp, CPT_TRUE);
01933       else if (pp->honu_mode)
01934        print_utf8_string(pp, "true", 0, 4);
01935       else
01936        print_utf8_string(pp, "#t", 0, 2);
01937     }
01938   else if (SAME_OBJ(obj, scheme_false))
01939     {
01940       if (compact)
01941        print_compact(pp, CPT_FALSE);
01942       else if (pp->honu_mode)
01943        print_utf8_string(pp, "false", 0, 5);
01944       else
01945        print_utf8_string(pp, "#f", 0, 2);
01946     }
01947   else if (compact && SAME_OBJ(obj, scheme_void))
01948     {
01949       print_compact(pp, CPT_VOID);
01950     }
01951   else if (SCHEME_STRUCTP(obj))
01952     {
01953       if (compact && SCHEME_PREFABP(obj)) {
01954         Scheme_Object *vec, *prefab;
01955         print_compact(pp, CPT_PREFAB);
01956         prefab = ((Scheme_Structure *)obj)->stype->prefab_key;
01957         vec = scheme_struct_to_vector(obj, NULL, pp->inspector);
01958         SCHEME_VEC_ELS(vec)[0] = SCHEME_CDR(prefab);
01959         print_vector(vec, notdisplay, compact, ht, mt, pp, 1);
01960       } else if (compact || !pp->print_unreadable) {
01961         cannot_print(pp, notdisplay, obj, ht, compact);
01962       } else if (scheme_is_writable_struct(obj)) {
01963        custom_write_struct(obj, ht, mt, pp, notdisplay);
01964       } else {
01965        int pb;
01966 
01967        pb = pp->print_struct && PRINTABLE_STRUCT(obj, pp);
01968 
01969        if (pb) {
01970           Scheme_Object *vec, *prefab;
01971           prefab = ((Scheme_Structure *)obj)->stype->prefab_key;
01972          vec = scheme_struct_to_vector(obj, NULL, pp->inspector);
01973           if (prefab) {
01974             SCHEME_VEC_ELS(vec)[0] = SCHEME_CDR(prefab);
01975           }
01976           print_vector(vec, notdisplay, compact, ht, mt, pp, !!prefab);
01977          closed = 1;
01978        } else {
01979          Scheme_Object *src;
01980 
01981          if (SCHEME_PROC_STRUCTP(obj)) {
01982            /* Name by procedure? */
01983            src = scheme_proc_struct_name_source(obj);
01984          } else
01985            src = obj;
01986 
01987          if (SAME_OBJ(src, obj)) {
01988             int l;
01989             const char *s;
01990             Scheme_Object *name;
01991 
01992            print_utf8_string(pp, "#<", 0, 2); /* used to have "struct:" prefix */
01993             if (scheme_reduced_procedure_struct
01994                 && scheme_is_struct_instance(scheme_reduced_procedure_struct, obj)) {
01995               /* Since scheme_proc_struct_name_source() didn't redirect, this one
01996                  must have a name. */
01997               print_utf8_string(pp, "procedure:", 0, 10);
01998               name = ((Scheme_Structure *)obj)->slots[2];
01999             } else {
02000              name = SCHEME_STRUCT_NAME_SYM(obj);
02001             }
02002 
02003             s = scheme_symbol_name_and_size(name, (unsigned int *)&l, 
02004                                             (pp->print_struct
02005                                              ? SCHEME_SNF_FOR_TS
02006                                              : (pp->can_read_pipe_quote 
02007                                                 ? SCHEME_SNF_PIPE_QUOTE
02008                                                 : SCHEME_SNF_NO_PIPE_QUOTE)));
02009             print_utf8_string(pp, s, 0, l);
02010            PRINTADDRESS(pp, obj);
02011            print_utf8_string(pp, ">", 0, 1);
02012          } else {
02013            closed = print(src, notdisplay, compact, ht, mt, pp);
02014          }
02015        }
02016       }
02017 
02018       closed = 1;
02019     }
02020   else if (SCHEME_GENERAL_PATHP(obj))
02021     {
02022       if (compact && SCHEME_PATHP(obj)) {
02023        /* Needed for srclocs in procedure names */
02024        Scheme_Object *idx;
02025        int l;
02026        
02027        idx = get_symtab_idx(mt, obj);
02028        if (idx) {
02029           print_symtab_ref(pp, idx);
02030        } else {
02031          Scheme_Object *orig_obj = obj, *dir;
02032          
02033          dir = scheme_get_param(scheme_current_config(),
02034                              MZCONFIG_WRITE_DIRECTORY);
02035          if (SCHEME_PATHP(dir)) {
02036            obj = scheme_extract_relative_to(obj, dir);
02037          }
02038 
02039          print_compact(pp, CPT_PATH);
02040 
02041          l = SCHEME_PATH_LEN(obj);
02042          print_compact_number(pp, l);
02043          print_this_string(pp, SCHEME_PATH_VAL(obj), 0, l);
02044 
02045           symtab_set(pp, mt, orig_obj);
02046        }
02047       } else if (!pp->print_unreadable) {
02048        cannot_print(pp, notdisplay, obj, ht, compact);
02049       } else {
02050        if (notdisplay) {
02051           if (SCHEME_PATHP(obj)) {
02052             print_utf8_string(pp, "#<path:", 0, 7);
02053           } else {
02054             switch (SCHEME_TYPE(obj)) {
02055             case scheme_windows_path_type:
02056               print_utf8_string(pp, "#<windows-path:", 0, 15);
02057               break;
02058             default:
02059             case scheme_unix_path_type:
02060               print_utf8_string(pp, "#<unix-path:", 0, 12);
02061               break;
02062             }
02063           }
02064         }
02065        {
02066          Scheme_Object *str;
02067          str = scheme_path_to_char_string(obj);
02068          print(str, 0, 0, ht, mt, pp);
02069        }
02070        if (notdisplay) {
02071          PRINTADDRESS(pp, obj);
02072          print_utf8_string(pp, ">", 0, 1);
02073        }
02074       }
02075     }
02076   else if (SAME_TYPE(SCHEME_TYPE(obj), scheme_resolved_module_path_type))
02077     {
02078       if (compact || !pp->print_unreadable) {
02079        cannot_print(pp, notdisplay, obj, ht, compact);
02080       } else {
02081         int is_sym;
02082         if (notdisplay)
02083           print_utf8_string(pp, "#<resolved-module-path:", 0, 23);
02084         is_sym = SCHEME_SYMBOLP(SCHEME_PTR_VAL(obj));
02085         print_utf8_string(pp, (is_sym ? "'" : "\"") , 0, 1);
02086         print(SCHEME_PTR_VAL(obj), 0, 0, ht, mt, pp);
02087        PRINTADDRESS(pp, obj);
02088         if (!is_sym)
02089           print_utf8_string(pp, "\"" , 0, 1);
02090         if (notdisplay)
02091           print_utf8_string(pp, ">", 0, 1);
02092       }
02093       closed = notdisplay;
02094     }
02095   else if (SCHEME_PRIMP(obj) && ((Scheme_Primitive_Proc *)obj)->name)
02096     {
02097       if (compact || !pp->print_unreadable) {
02098        cannot_print(pp, notdisplay, obj, ht, compact);
02099       } else {
02100        print_utf8_string(pp, "#<", 0, 2);
02101        print_string_in_angle(pp, ((Scheme_Primitive_Proc *)obj)->name, "procedure:", -1); /* used to be "primitive:" */
02102        PRINTADDRESS(pp, obj);
02103        print_utf8_string(pp, ">", 0, 1);
02104       }
02105       closed = 1;
02106     }
02107   else if (SCHEME_CLSD_PRIMP(obj) && ((Scheme_Closed_Primitive_Proc *)obj)->name)
02108     {
02109       if (compact || !pp->print_unreadable)
02110        cannot_print(pp, notdisplay, obj, ht, compact);
02111       else {
02112        if (SCHEME_STRUCT_PROCP(obj)) {
02113          print_named(obj, "struct-procedure", 
02114                     ((Scheme_Closed_Primitive_Proc *)obj)->name, 
02115                     -1, pp);
02116        } else {
02117          print_utf8_string(pp, "#<", 0, 2);
02118          print_string_in_angle(pp, ((Scheme_Closed_Primitive_Proc *)obj)->name, "procedure:", -1); /* used to be "primitive:" */
02119          PRINTADDRESS(pp, obj);
02120          print_utf8_string(pp, ">", 0, 1);
02121        }
02122       }
02123 
02124       closed = 1;
02125     }
02126   else if (SCHEME_CLOSUREP(obj)
02127           || SAME_TYPE(SCHEME_TYPE(obj), scheme_native_closure_type))
02128     {
02129       if (compact || !pp->print_unreadable) {
02130        int done = 0;
02131        if (compact) {
02132          if (SCHEME_TYPE(obj) == scheme_closure_type) {
02133            Scheme_Closure *closure = (Scheme_Closure *)obj;
02134            if (ZERO_SIZED_CLOSUREP(closure)) {
02135              /* Print original `lambda' code. Closure conversion can cause
02136                  an empty closure to be duplicated in the code tree, so hash it. */
02137               Scheme_Object *idx;
02138               idx = get_symtab_idx(mt, obj);
02139               if (idx) {
02140                 print_symtab_ref(pp, idx);
02141               } else {
02142                 print_compact(pp, CPT_CLOSURE);
02143                 print_symtab_set(pp, mt, obj);
02144                 print((Scheme_Object *)SCHEME_COMPILED_CLOS_CODE(closure), notdisplay, compact, ht, mt, pp);
02145               }
02146               compact = 1;
02147               done = 1;
02148            }
02149          } else if (SCHEME_TYPE(obj) == scheme_case_closure_type) {
02150            obj = scheme_unclose_case_lambda(obj, 0);
02151            if (!SCHEME_PROCP(obj)) {
02152              /* Print original `case-lambda' code: */
02153              compact = print(obj, notdisplay, compact, ht, mt, pp);
02154              done = 1;
02155            }
02156          }
02157        }
02158        if (!done)
02159          cannot_print(pp, notdisplay, obj, ht, compact);
02160       } else {
02161        int len;
02162        const char *s;
02163        s = scheme_get_proc_name(obj, &len, 0);
02164        
02165        print_named(obj, "procedure", s, len, pp);
02166       }
02167       closed = 1;
02168     }
02169   else if (SAME_TYPE(SCHEME_TYPE(obj), scheme_struct_type_type))
02170     {
02171       if (compact || !pp->print_unreadable) {
02172        cannot_print(pp, notdisplay, obj, ht, compact);
02173       } else {
02174        print_utf8_string(pp, "#<", 0, 2);
02175        print_string_in_angle(pp, scheme_symbol_val(((Scheme_Struct_Type *)obj)->name),
02176                            "struct-type:",
02177                            SCHEME_SYM_LEN(((Scheme_Struct_Type *)obj)->name));
02178        PRINTADDRESS(pp, obj);
02179        print_utf8_string(pp, ">", 0, 1);
02180       }
02181     }
02182   else if (SAME_TYPE(SCHEME_TYPE(obj), scheme_struct_property_type))
02183     {
02184       if (compact || !pp->print_unreadable) {
02185        cannot_print(pp, notdisplay, obj, ht, compact);
02186       } else {
02187        print_utf8_string(pp, "#<", 0, 2);
02188        print_string_in_angle(pp, scheme_symbol_val(((Scheme_Struct_Property *)obj)->name),
02189                            "struct-type-property:", 
02190                            SCHEME_SYM_LEN(((Scheme_Struct_Property *)obj)->name));
02191        PRINTADDRESS(pp, obj);
02192        print_utf8_string(pp, ">", 0, 1);
02193       }
02194     }
02195   else if (SCHEME_THREADP(obj) && (((Scheme_Thread *)obj)->name))
02196     {
02197       if (compact || !pp->print_unreadable) {
02198        cannot_print(pp, notdisplay, obj, ht, compact);
02199       } else {
02200        Scheme_Thread *t = (Scheme_Thread *)obj;
02201        print_utf8_string(pp, "#<thread:", 0, 9);
02202        print_utf8_string(pp, scheme_symbol_val(t->name), 0, SCHEME_SYM_LEN(t->name));
02203        print_utf8_string(pp, ">", 0, 1);
02204       }
02205     }
02206   else if (SCHEME_NAMESPACEP(obj))
02207     {
02208       if (compact || !pp->print_unreadable) {
02209        cannot_print(pp, notdisplay, obj, ht, compact);
02210       } else {
02211         char s[10];
02212         
02213         print_utf8_string(pp, "#<namespace:", 0, 12);
02214 
02215         if (((Scheme_Env *)obj)->module) {
02216           Scheme_Object *modname;
02217           int is_sym;
02218           
02219           modname = ((Scheme_Env *)obj)->module->modname;
02220           is_sym = SCHEME_SYMBOLP(SCHEME_PTR_VAL(modname));
02221           print_utf8_string(pp, (is_sym ? "'" : "\""), 0, 1);
02222           print(SCHEME_PTR_VAL(modname), 0, 0, ht, mt, pp);
02223           PRINTADDRESS(pp, modname);
02224           if (!is_sym)
02225             print_utf8_string(pp, "\"" , 0, 1);
02226           print_utf8_string(pp, ":", 0, 1);
02227         }
02228 
02229         sprintf(s, "%ld", ((Scheme_Env *)obj)->phase);
02230         print_utf8_string(pp, s, 0, -1);
02231        print_utf8_string(pp, ">", 0, 1);
02232       }
02233     }
02234   else if (SCHEME_INPORTP(obj))
02235     {
02236       if (compact || !pp->print_unreadable) {
02237        cannot_print(pp, notdisplay, obj, ht, compact);
02238       } else {
02239        Scheme_Input_Port *ip;
02240        ip = (Scheme_Input_Port *)obj;
02241        print_utf8_string(pp, "#<input-port", 0, 12);
02242        if (ip->name) {
02243          if (SCHEME_PATHP(ip->name)) {
02244            print_utf8_string(pp, ":", 0, 1);
02245            print_utf8_string(pp, SCHEME_BYTE_STR_VAL(ip->name), 0, SCHEME_BYTE_STRLEN_VAL(ip->name));
02246          } else if (SCHEME_SYMBOLP(ip->name)) {
02247            print_utf8_string(pp, ":", 0, 1);
02248            print_utf8_string(pp, scheme_symbol_val(ip->name), 0, SCHEME_SYM_LEN(ip->name));
02249          }
02250        }
02251        print_utf8_string(pp, ">", 0, 1);
02252       }
02253     }
02254   else if (SAME_TYPE(SCHEME_TYPE(obj), scheme_regexp_type))
02255     {
02256        if (compact) {
02257         print_escaped(pp, notdisplay, obj, ht, mt, 1);
02258        } else {
02259         Scheme_Object *src;
02260         src = scheme_regexp_source(obj);
02261         if (src) {
02262           if (scheme_is_pregexp(obj))
02263             print_utf8_string(pp, "#px", 0, 3);
02264           else
02265             print_utf8_string(pp, "#rx", 0, 3);
02266           print(src, 1, 0, ht, mt, pp);
02267         } else if (compact || !pp->print_unreadable)
02268           cannot_print(pp, notdisplay, obj, ht, compact);
02269         else
02270           print_utf8_string(pp, "#<regexp>", 0, 9);
02271         closed = 1;
02272        }
02273     }
02274   else if (SCHEME_OUTPORTP(obj))
02275     {
02276       if (compact || !pp->print_unreadable) {
02277        cannot_print(pp, notdisplay, obj, ht, compact);
02278       } else {
02279        Scheme_Output_Port *op;
02280        op = (Scheme_Output_Port *)obj;
02281        print_utf8_string(pp, "#<output-port", 0, 13);
02282        if (op->name) {
02283          if (SCHEME_PATHP(op->name)) {
02284            print_utf8_string(pp, ":", 0, 1);
02285            print_utf8_string(pp, SCHEME_BYTE_STR_VAL(op->name), 0, SCHEME_BYTE_STRLEN_VAL(op->name));
02286          } else if (SCHEME_SYMBOLP(op->name)) {
02287            print_utf8_string(pp, ":", 0, 1);
02288            print_utf8_string(pp, scheme_symbol_val(op->name), 0, SCHEME_SYM_LEN(op->name));
02289          }
02290        }
02291        print_utf8_string(pp, ">", 0, 1);
02292       }
02293     }
02294   else if (SAME_TYPE(SCHEME_TYPE(obj), scheme_prompt_tag_type)
02295            && SCHEME_CDR(obj) && !(compact || !pp->print_unreadable))
02296     {
02297       print_utf8_string(pp, "#<", 0, 2);
02298       print_string_in_angle(pp, scheme_symbol_val(SCHEME_CDR(obj)),
02299                             "continuation-prompt-tag:", 
02300                             SCHEME_SYM_LEN(SCHEME_CDR(obj)));
02301       PRINTADDRESS(pp, obj);
02302       print_utf8_string(pp, ">", 0, 1);
02303     }
02304     else if (SCHEME_CPTRP(obj))
02305     {
02306       Scheme_Object *tag = SCHEME_CPTR_TYPE(obj);
02307       if (compact || !pp->print_unreadable) {
02308        cannot_print(pp, notdisplay, obj, ht, compact);
02309       } else if (tag == NULL) {
02310        print_utf8_string(pp, "#<cpointer>", 0, 11);
02311       } else {
02312         Scheme_Object *name = tag;
02313         if (SCHEME_PAIRP(name)) name = SCHEME_CAR(name);
02314        print_utf8_string(pp, "#<cpointer:", 0, 11);
02315         if (SCHEME_SYMBOLP(name)) {
02316           print_this_string(pp,
02317                             (char*)name,
02318                             ((char*)(SCHEME_SYM_VAL(name))) - ((char*)name),
02319                             SCHEME_SYM_LEN(name));
02320         } else if (SCHEME_BYTE_STRINGP(name)) {
02321           print_byte_string(SCHEME_BYTE_STR_VAL(name),
02322                          0,
02323                             SCHEME_BYTE_STRLEN_VAL(name),
02324                             0, pp);
02325         } else if (SCHEME_CHAR_STRINGP(name)) {
02326          scheme_print_string(pp, SCHEME_CHAR_STR_VAL(name), 0,
02327                               SCHEME_CHAR_STRTAG_VAL(name));
02328         } else {
02329           print_utf8_string(pp, "#", 0, 1);
02330         }
02331        print_utf8_string(pp, ">", 0, 1);
02332        closed = 1;
02333       }
02334     }
02335   else if (SCHEME_STXP(obj))
02336     {
02337       if (compact) {
02338        print_compact(pp, CPT_STX);
02339        
02340        /* "2" in scheme_syntax_to_datum() call preserves wraps. */
02341        closed = print(scheme_syntax_to_datum(obj, 2, mt), 
02342                      notdisplay, 1, ht, mt, pp);
02343       } else if (pp->print_unreadable) {
02344        Scheme_Stx *stx = (Scheme_Stx *)obj;
02345        if ((stx->srcloc->line >= 0) || (stx->srcloc->pos >= 0)) {
02346          print_utf8_string(pp, "#<syntax:", 0, 9);
02347          if (stx->srcloc->src && SCHEME_PATHP(stx->srcloc->src)) {
02348            print_utf8_string(pp, SCHEME_BYTE_STR_VAL(stx->srcloc->src), 0, SCHEME_BYTE_STRLEN_VAL(stx->srcloc->src));
02349            print_utf8_string(pp, ":", 0, 1);
02350          }
02351          if (stx->srcloc->line >= 0)
02352            sprintf(quick_buffer, "%ld:%ld", stx->srcloc->line, stx->srcloc->col-1);
02353          else
02354            sprintf(quick_buffer, ":%ld", stx->srcloc->pos);
02355          print_utf8_string(pp, quick_buffer, 0, -1);
02356          print_utf8_string(pp, ">", 0, 1);
02357        } else
02358          print_utf8_string(pp, "#<syntax>", 0, 9);
02359       } else {
02360        cannot_print(pp, notdisplay, obj, ht, compact);
02361       }
02362     }
02363   else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_module_index_type)) 
02364     {
02365       Scheme_Object *idx;
02366 
02367       idx = get_symtab_idx(mt, obj);
02368       if (idx) {
02369         print_symtab_ref(pp, idx);
02370       } else {
02371        print_compact(pp, CPT_MODULE_INDEX);
02372        print(((Scheme_Modidx *)obj)->path, notdisplay, 1, ht, mt, pp);
02373        print(((Scheme_Modidx *)obj)->base, notdisplay, 1, ht, mt, pp);
02374         symtab_set(pp, mt, obj);
02375       }
02376     }
02377   else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_module_variable_type))
02378     {
02379       Scheme_Object *idx;
02380 
02381       idx = get_symtab_idx(mt, obj);
02382       if (idx) {
02383         print_symtab_ref(pp, idx);
02384       } else {
02385        Module_Variable *mv;
02386 
02387        print_compact(pp, CPT_MODULE_VAR);
02388        mv = (Module_Variable *)obj;
02389         if (SAME_TYPE(SCHEME_TYPE(mv->modidx), scheme_resolved_module_path_type)
02390             && SCHEME_SYMBOLP(SCHEME_PTR_VAL(mv->modidx))) {
02391           print(SCHEME_PTR_VAL(mv->modidx), notdisplay, 1, ht, mt, pp);
02392         } else {
02393           print(mv->modidx, notdisplay, 1, ht, mt, pp);
02394         }
02395        print(mv->sym, notdisplay, 1, ht, mt, pp);
02396         if (((Module_Variable *)obj)->mod_phase) {
02397           /* mod_phase must be 1 */
02398           print_compact_number(pp, -2);
02399         }
02400         print_compact_number(pp, mv->pos);
02401 
02402         symtab_set(pp, mt, obj);
02403       }
02404     }
02405   else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_variable_type)
02406           && (((Scheme_Bucket_With_Flags *)obj)->flags & GLOB_HAS_REF_ID))
02407     {
02408       int pos;
02409       pos = ((Scheme_Bucket_With_Ref_Id *)obj)->id;
02410       print_compact(pp, CPT_REFERENCE);
02411       print_compact_number(pp, pos);
02412     }   
02413   else if (compact 
02414           && (SAME_TYPE(SCHEME_TYPE(obj), scheme_local_type)
02415               || SAME_TYPE(SCHEME_TYPE(obj), scheme_local_unbox_type)))
02416     {
02417       int unbox = SAME_TYPE(SCHEME_TYPE(obj), scheme_local_unbox_type);
02418       Scheme_Local *loc = (Scheme_Local *)obj;
02419       if ((loc->position < CPT_RANGE(SMALL_LOCAL))
02420           && !(SCHEME_LOCAL_FLAGS(loc) & SCHEME_LOCAL_CLEARING_MASK)) {
02421        unsigned char s[1];
02422        s[0] = loc->position + (unbox 
02423                             ? CPT_SMALL_LOCAL_UNBOX_START 
02424                             : CPT_SMALL_LOCAL_START);
02425        print_this_string(pp, (char *)s, 0, 1);
02426       } else {
02427         int flags;
02428        print_compact(pp, unbox ? CPT_LOCAL_UNBOX : CPT_LOCAL);
02429         flags = SCHEME_LOCAL_FLAGS(loc) & SCHEME_LOCAL_CLEARING_MASK;
02430         if (flags) {
02431           print_compact_number(pp, -(loc->position + 1));
02432           print_compact_number(pp, flags);
02433         } else
02434           print_compact_number(pp, loc->position);
02435       }
02436     }
02437   else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_application_type))
02438     {
02439       Scheme_App_Rec *app;
02440       int i;
02441 
02442       app = (Scheme_App_Rec *)obj;
02443 
02444       if (app->num_args < CPT_RANGE(SMALL_APPLICATION)) {
02445        unsigned char s[1];
02446        s[0] = CPT_SMALL_APPLICATION_START + app->num_args;
02447        print_this_string(pp, (char *)s, 0, 1);
02448       } else {
02449        print_compact(pp, CPT_APPLICATION);
02450        print_compact_number(pp, app->num_args);
02451       }
02452 
02453       for (i = 0; i < app->num_args + 1; i++) {
02454        closed = print(scheme_protect_quote(app->args[i]), notdisplay, 1, NULL, mt, pp);
02455       }
02456     }
02457   else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_application2_type))
02458     {
02459       Scheme_App2_Rec *app;
02460       unsigned char s[1];
02461 
02462       app = (Scheme_App2_Rec *)obj;
02463 
02464       s[0] = CPT_SMALL_APPLICATION_START + 1;
02465       print_this_string(pp, (char *)s, 0, 1);
02466 
02467       print(scheme_protect_quote(app->rator), notdisplay, 1, NULL, mt, pp);
02468       closed = print(scheme_protect_quote(app->rand), notdisplay, 1, NULL, mt, pp);
02469     }
02470   else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_application3_type))
02471     {
02472       Scheme_App3_Rec *app;
02473       unsigned char s[1];
02474 
02475       app = (Scheme_App3_Rec *)obj;
02476 
02477       s[0] = CPT_SMALL_APPLICATION_START + 2;
02478       print_this_string(pp, (char *)s, 0, 1);
02479 
02480       print(scheme_protect_quote(app->rator), notdisplay, 1, NULL, mt, pp);
02481       print(scheme_protect_quote(app->rand1), notdisplay, 1, NULL, mt, pp);
02482       closed = print(scheme_protect_quote(app->rand2), notdisplay, 1, NULL, mt, pp);
02483     }
02484   else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_let_one_type))
02485     {
02486       Scheme_Let_One *lo;
02487 
02488       lo = (Scheme_Let_One *)obj;
02489 
02490       print_compact(pp, CPT_LET_ONE);
02491       print(scheme_protect_quote(lo->value), notdisplay, 1, NULL, mt, pp);
02492       closed = print(scheme_protect_quote(lo->body), notdisplay, 1, NULL, mt, pp);
02493     }
02494   else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_branch_type))
02495     {
02496       Scheme_Branch_Rec *b;
02497 
02498       b = (Scheme_Branch_Rec *)obj;
02499 
02500       print_compact(pp, CPT_BRANCH);
02501       print(scheme_protect_quote(b->test), notdisplay, 1, NULL, mt, pp);
02502       print(scheme_protect_quote(b->tbranch), notdisplay, 1, NULL, mt, pp);
02503       closed = print(scheme_protect_quote(b->fbranch), notdisplay, 1, NULL, mt, pp);
02504     }
02505   else if (SAME_TYPE(SCHEME_TYPE(obj), scheme_quote_compilation_type))
02506     {
02507       Scheme_Hash_Table *q_ht;
02508       Scheme_Object *v;
02509       int counter = 1, qpht, qpb;
02510 
02511       v = SCHEME_PTR_VAL(obj);
02512 
02513       /* A quoted expression may have graph structure. We assume that
02514         this structure is local within the quoted expression. */
02515 
02516       qpht = pp->print_hash_table;
02517       qpb = pp->print_box;
02518       /* Boxes and hash tables can be literals, so we need to
02519         enable printing as we write compiled code: */
02520       pp->print_hash_table = 1;
02521       pp->print_box = 1;
02522       
02523       q_ht = scheme_make_hash_table(SCHEME_hash_ptr);
02524       setup_graph_table(v, notdisplay, q_ht, &counter, pp);
02525 
02526       if (compact)
02527        print_compact(pp, CPT_QUOTE);
02528       else {
02529 #if !NO_COMPACT
02530        /* Doesn't happen: */
02531        scheme_signal_error("internal error: non-compact quote compilation");
02532        return 0;
02533 #endif
02534       }
02535 
02536       compact = print(v, notdisplay, 1, q_ht, mt, pp);
02537 
02538       pp->print_hash_table = qpht;
02539       pp->print_box = qpb;
02540     }
02541   else if (
02542 #if !NO_COMPACT
02543           compact && 
02544 #endif
02545           SAME_TYPE(SCHEME_TYPE(obj), scheme_svector_type))
02546     {
02547       mzshort l, *v;
02548       l = SCHEME_SVEC_LEN(obj);
02549       v = (mzshort *)SCHEME_SVEC_VEC(obj);
02550       
02551 #if NO_COMPACT
02552       print_this_string(pp, "[", 0, 1);
02553       {
02554        int i; 
02555        char s[10];
02556 
02557        for (i = 0; i < l; i++) {
02558          if (i)
02559            print_this_string(pp, " ", 0, 1);
02560          sprintf(s, "%d", (int)v[i]);
02561          print_this_string(pp, s, 0, -1);
02562        }
02563       }
02564       print_this_string(pp, "]", 0, 1);
02565 #else
02566       if (l < CPT_RANGE(SMALL_SVECTOR)) {
02567        unsigned char s[1];
02568        s[0] = l + CPT_SMALL_SVECTOR_START;
02569        print_this_string(pp, (char *)s, 0, 1);
02570       } else {
02571        print_compact(pp, CPT_SVECTOR);
02572        print_compact_number(pp, l);
02573       }
02574       while (l--) {
02575        int n = v[l];
02576        print_compact_number(pp, n);
02577       }
02578 #endif
02579     }
02580   else if (compact && SAME_TYPE(SCHEME_TYPE(obj), scheme_delay_syntax_type))
02581     {
02582       /* Wraps a value that we might load on demand,
02583          instead of when the using code is loaded. */
02584       Scheme_Object *idx, *key;
02585         
02586       if (MZ_OPT_HASH_KEY(&((Scheme_Small_Object *)obj)->iso) & 0x1) {
02587         /* obj representative will stay constant across passes */
02588       } else  {
02589         key = SCHEME_PTR_VAL(obj);
02590 
02591         if (!mt->pass) {
02592           if (!mt->delay_map) {
02593             Scheme_Hash_Table *delay_map;
02594             delay_map = scheme_make_hash_table(SCHEME_hash_ptr);
02595             mt->delay_map = delay_map;
02596           }
02597           scheme_hash_set(mt->delay_map, key, obj);
02598         } else
02599           obj = scheme_hash_get(mt->delay_map, key);
02600       }
02601 
02602       idx = get_symtab_idx(mt, obj);
02603 
02604       if (idx) {
02605         print_general_symtab_ref(pp, idx, CPT_DELAY_REF);
02606       } else {      
02607         print(SCHEME_PTR_VAL(obj), notdisplay, 1, ht, mt, pp);
02608         symtab_set(pp, mt, obj);
02609         set_symtab_shared(mt, obj);
02610       }
02611     }
02612   else if (scheme_type_writers[SCHEME_TYPE(obj)]
02613 #if !NO_COMPACT
02614           && (compact || SAME_TYPE(SCHEME_TYPE(obj), scheme_compilation_top_type))
02615 #endif
02616           )
02617     {
02618       Scheme_Type t = SCHEME_TYPE(obj);
02619       Scheme_Object *v;
02620       long slen;
02621 
02622       if (t >= _scheme_last_type_) {
02623        /* Doesn't happen: */
02624        scheme_signal_error("internal error: bad type with writer");
02625        return 0;
02626       }
02627 
02628       if (!global_constants_ht) {
02629        REGISTER_SO(global_constants_ht);
02630        global_constants_ht = scheme_map_constants_to_globals();
02631       }
02632 
02633       if (compact) {
02634        if (t < CPT_RANGE(SMALL_MARSHALLED)) {
02635          unsigned char s[1];
02636          s[0] = t + CPT_SMALL_MARSHALLED_START;
02637          print_this_string(pp, (char *)s, 0, 1);
02638        } else {
02639          print_compact(pp, CPT_MARSHALLED);
02640          print_compact_number(pp, t);
02641        }
02642       } else {
02643        print_this_string(pp, "#~", 0, 2);
02644 #if NO_COMPACT
02645        if (t < _scheme_last_type_) {
02646          sprintf (quick_buffer, "%ld", (long)SCHEME_TYPE(obj));
02647          print_this_string(pp, quick_buffer, 0, -1);
02648        } else
02649          print_this_string(pp, scheme_get_type_name(t), 0, -1);
02650 #endif
02651       }
02652 
02653       {
02654        Scheme_Type_Writer writer;
02655        writer = scheme_type_writers[t];
02656        v = writer(obj);
02657       }
02658 
02659       if (compact)
02660        closed = print(v, notdisplay, 1, NULL, mt, pp);
02661       else {
02662         Scheme_Hash_Table *st_refs, *symtab, *rns, *tht;
02663         long *shared_offsets;
02664         long st_len, j, shared_offset, start_offset;
02665 
02666         mt = MALLOC_ONE_RT(Scheme_Marshal_Tables);
02667         SET_REQUIRED_TAG(mt->type = scheme_rt_marshal_info);
02668 
02669         scheme_current_thread->current_mt = mt;
02670 
02671         /* Track which shared values are referenced: */
02672         st_refs = scheme_make_hash_table(SCHEME_hash_ptr);
02673         mt->st_refs = st_refs;
02674         mt->st_ref_stack = scheme_null;
02675 
02676        /* "Print" the string once to determine graph references. On this pass,
02677            we first assume that everything is shared and make up sequential
02678            keys, but we also keep track of which things are actually shared;
02679            we'll map the original keys to a compacted set of keys for the
02680            later passes. */
02681        symtab = scheme_make_hash_table(SCHEME_hash_ptr);
02682         mt->symtab = symtab;
02683        rns = scheme_make_hash_table(SCHEME_hash_ptr);
02684         mt->rns = rns;
02685         tht = scheme_make_hash_table_equal();
02686         mt->cert_lists = tht;
02687         tht = scheme_make_hash_table(SCHEME_hash_ptr);
02688         mt->shift_map = tht;
02689         mt->reverse_map = NULL;
02690         mt->pass = 0;
02691         scheme_hash_set(symtab, scheme_void, scheme_true); /* indicates registration phase */
02692        print_substring(v, notdisplay, 1, NULL, mt, pp, NULL, &slen, 0, NULL);
02693 
02694         sort_referenced_keys(mt);
02695         mt->rn_saved = NULL;
02696 
02697        /* "Print" again, now that we know which values are actually
02698            shared. On this pass, shared values that reference other shared values
02699            are re-computed with the compacted keys. */
02700         shared_offsets = MALLOC_N_ATOMIC(long, mt->st_refs->count);
02701         mt->shared_offsets = shared_offsets;
02702        symtab = scheme_make_hash_table(SCHEME_hash_ptr);
02703         mt->symtab = symtab;
02704        rns = scheme_make_hash_table(SCHEME_hash_ptr);
02705         mt->rns = rns;
02706         mt->reverse_map = NULL;
02707         mt->top_map = NULL;
02708         mt->pass = 1;
02709        print_substring(v, notdisplay, 1, NULL, mt, pp, NULL, &slen, 
02710                         1, &st_len);
02711 
02712         /* "Print" the string again to get a measurement and symtab size. */
02713         symtab = scheme_make_hash_table(SCHEME_hash_ptr);
02714         mt->symtab = symtab;
02715        rns = scheme_make_hash_table(SCHEME_hash_ptr);
02716         mt->rns = rns;
02717         mt->reverse_map = NULL;
02718         mt->top_map = NULL;
02719         mt->pass = 2;
02720        print_substring(v, notdisplay, 1, NULL, mt, pp, NULL, &slen, 
02721                         -1, &st_len);
02722 
02723        /* Remember version: */
02724         print_one_byte(pp, strlen(MZSCHEME_VERSION));
02725        print_this_string(pp, MZSCHEME_VERSION, 0, -1);
02726 
02727         if (mt->st_refs->count != mt->sorted_keys_count)
02728           scheme_signal_error("shared key count somehow changed");
02729 
02730        print_number(pp, mt->st_refs->count + 1);
02731 
02732         /* Print shared-value offsets: */
02733         if (mt->st_refs->count) {
02734           int all_short = shared_offsets[mt->st_refs->count-1] < 0xFFFF;
02735           print_one_byte(pp, all_short);
02736           for (j = 0; j < mt->st_refs->count; j++) {
02737             if (all_short)
02738               print_short_number(pp, shared_offsets[j]);
02739             else
02740               print_number(pp, shared_offsets[j]);
02741           }
02742         } else {
02743           print_one_byte(pp, 1);
02744         }
02745         
02746        print_number(pp, st_len);
02747        print_number(pp, slen);
02748 
02749        /* Make symtab and rns again to ensure the same results 
02750            for the final print: */
02751        symtab = scheme_make_hash_table(SCHEME_hash_ptr);
02752         mt->symtab = symtab;
02753        rns = scheme_make_hash_table(SCHEME_hash_ptr);
02754         mt->rns = rns;
02755         mt->reverse_map = NULL;
02756         mt->top_map = NULL;
02757         mt->pass = 3;
02758 
02759         start_offset = pp->print_offset;
02760 
02761         /* Print shared values first, so read can easily skip them
02762            and load them lazily. */
02763         print_table_keys(notdisplay, 1, NULL, mt, pp);
02764         shared_offset = pp->print_offset;
02765        closed = print(v, notdisplay, 1, NULL, mt, pp);
02766 
02767         if (shared_offset - start_offset != st_len) {
02768           scheme_signal_error("compiled code shared printed size changed on third pass:"
02769                               " %ld versus %ld (total %ld)",
02770                               st_len, shared_offset - start_offset, slen);
02771         }
02772         if (pp->print_offset - start_offset != slen) {
02773           scheme_signal_error("compiled code printed size changed on third pass:"
02774                               " %ld versus %ld",
02775                               slen, pp->print_offset - start_offset);
02776         }
02777 
02778         scheme_current_thread->current_mt = NULL;
02779         mt = NULL;
02780       }
02781     } 
02782   else 
02783     {
02784       if (compact || !pp->print_unreadable)
02785        cannot_print(pp, notdisplay, obj, ht, compact);
02786       else if ((SCHEME_TYPE(obj) < printers_count)
02787               && printers[SCHEME_TYPE(obj)]) {
02788        Scheme_Type_Printer printer;
02789        printer = printers[SCHEME_TYPE(obj)];
02790        printer(obj, !notdisplay, pp);
02791       } else {
02792        char *s;
02793        long len = -1;
02794        s = scheme_get_type_name((SCHEME_TYPE(obj)));
02795        print_utf8_string(pp, "#", 0, 1);
02796 #ifdef SGC_STD_DEBUGGING
02797        len = strlen(s) - 1;
02798 #endif
02799        if (!s) {
02800          char s[8];
02801          print_utf8_string(pp, "<???:", 0, 5);
02802          sprintf(s, "%d", SCHEME_TYPE(obj));
02803          print_utf8_string(pp, s, 0, -1);
02804          print_utf8_string(pp, ">", 0, 1);
02805        } else {
02806          print_utf8_string(pp, s, 0, len);
02807        }
02808 #ifdef SGC_STD_DEBUGGING
02809        PRINTADDRESS(pp, obj);
02810        print_utf8_string(pp, ">", 0, 1);
02811 #endif
02812       }
02813 
02814       closed = 1;
02815     }
02816 
02817   if (save_honu_mode != pp->honu_mode)
02818     pp->honu_mode = save_honu_mode;
02819 
02820   return (closed || compact);
02821 }
02822 
02823 static void
02824 print_char_string(const char *str, int len, 
02825                 const mzchar *ustr, int delta, int ulen,
02826                 int notdisplay, int honu_char, PrintParams *pp)
02827 {
02828   char minibuf[12], *esc;
02829   int a, i, v, ui, cont_utf8 = 0, isize;
02830 
02831   if (notdisplay) {
02832     print_utf8_string(pp, honu_char ? "'" : "\"", 0, 1);
02833 
02834     for (a = i = ui = 0; i < len; i += isize, ui++) {
02835       v = ((unsigned char *)str)[i];
02836       isize = 1;
02837 
02838       switch (v) {
02839       case '\"': 
02840        if (honu_char)
02841          esc = NULL;
02842        else
02843          esc = "\\\""; 
02844        break;
02845       case '\'': 
02846        if (honu_char)
02847          esc = "\\'"; 
02848        else
02849          esc = NULL;
02850        break;
02851       case '\\': esc = "\\\\"; break;
02852       case '\a': esc = "\\a";  break;
02853       case '\b': esc = "\\b";  break;
02854       case 27: esc = "\\e";  break;
02855       case '\f': esc = "\\f";  break;
02856       case '\n': esc = "\\n";  break;
02857       case '\r': esc = "\\r";  break;
02858       case '\t': esc = "\\t";  break;
02859       case '\v': esc = "\\v";  break;
02860       default:
02861        if (v > 127) {
02862          if (cont_utf8) {
02863            cont_utf8--;
02864            ui--;
02865            esc = NULL;
02866          } else {
02867            int clen;
02868            clen = scheme_utf8_encode(ustr, ui+delta, ui+delta+1, NULL, 0, 0);
02869            if (scheme_isgraphic(ustr[ui+delta])
02870               || scheme_isblank(ustr[ui+delta])) {
02871              cont_utf8 = clen - 1;
02872              esc = NULL;
02873            } else {
02874              esc = minibuf;
02875              isize = clen;
02876            }
02877          }
02878        } else if (scheme_isgraphic(v)
02879                  || scheme_isblank(v)) {
02880          esc = NULL;
02881        } else {
02882          esc = minibuf;
02883        }
02884        break;
02885       }
02886 
02887       if (esc) {
02888        if (esc == minibuf) {
02889          if (ustr[ui+delta] > 0xFFFF) {
02890            sprintf(minibuf, "\\U%.8X", ustr[ui+delta]);
02891          } else
02892            sprintf(minibuf, "\\u%.4X", ustr[ui+delta]);
02893        }
02894 
02895         if (a < i)
02896          print_utf8_string(pp, str, a, i-a);
02897         print_utf8_string(pp, esc, 0, -1);
02898         a = i+isize;
02899       }
02900     }
02901     if (a < i)
02902       print_utf8_string(pp, str, a, i-a);
02903 
02904     print_utf8_string(pp, honu_char ? "'" : "\"", 0, 1);
02905   } else if (len) {
02906     print_utf8_string(pp, str, 0, len);
02907   }
02908 }
02909 
02910 static void
02911 print_byte_string(const char *str, int delta, int len, int notdisplay, PrintParams *pp)
02912 {
02913   char minibuf[8], *esc;
02914   int a, i, v;
02915 
02916   if (notdisplay) {
02917     print_utf8_string(pp, "\"", 0, 1);
02918 
02919     for (a = i = delta; i < delta + len; i++) {
02920       /* Escape-sequence handling by Eli Barzilay. */
02921       switch (((unsigned char *)str)[i]) {
02922       case '\"': esc = "\\\""; break;
02923       case '\\': esc = "\\\\"; break;
02924       case '\a': esc = "\\a";  break;
02925       case '\b': esc = "\\b";  break;
02926       case 27: esc = "\\e";  break;
02927       case '\f': esc = "\\f";  break;
02928       case '\n': esc = "\\n";  break;
02929       case '\r': esc = "\\r";  break;
02930       case '\t': esc = "\\t";  break;
02931       case '\v': esc = "\\v";  break;
02932       default:
02933        v = ((unsigned char *)str)[i];
02934        if (v > 127) {
02935          esc = minibuf;
02936        } else if (scheme_isgraphic(v) || scheme_isblank(v)) {
02937          esc = NULL;
02938        } else {
02939          esc = minibuf;
02940        }
02941        break;
02942       }
02943 
02944       if (esc) {
02945        if (esc == minibuf) {
02946          sprintf(minibuf,
02947                   ((i+1>=len) || (str[i+1] < '0') || (str[i+1] > '7')) ? "\\%o" : "\\%03o",
02948                   ((unsigned char *)str)[i]);
02949        }
02950 
02951         if (a < i)
02952          print_utf8_string(pp, str, a, i-a);
02953         print_utf8_string(pp, esc, 0, -1);
02954         a = i+1;
02955       }
02956     }
02957     if (a < i)
02958       print_utf8_string(pp, str, a, i-a);
02959 
02960     print_utf8_string(pp, "\"", 0, 1);
02961   } else if (len) {
02962     print_this_string(pp, str, delta, len);
02963   }
02964 }
02965 
02966 
02967 static void
02968 print_pair(Scheme_Object *pair, int notdisplay, int compact, 
02969           Scheme_Hash_Table *ht, 
02970            Scheme_Marshal_Tables *mt, 
02971           PrintParams *pp,
02972            Scheme_Type pair_type, int round_parens)
02973 {
02974   Scheme_Object *cdr;
02975   int super_compact = 0;
02976 
02977   if (compact) {
02978     int c = 0;
02979     Scheme_Object *pr;
02980 
02981     pr = pair;
02982     while (SAME_TYPE(SCHEME_TYPE(pr), pair_type)) {
02983       if (ht)
02984        if ((long)scheme_hash_get(ht, pr) != 1) {
02985          c = -1;
02986          break;
02987        }
02988       c++;
02989       pr = SCHEME_CDR(pr);
02990     }
02991 
02992     if (c > -1) {
02993       super_compact = 1;
02994       if (c < CPT_RANGE(SMALL_LIST)) {
02995        unsigned char s[1];
02996        s[0] = c + (SCHEME_NULLP(pr) 
02997                   ? CPT_SMALL_PROPER_LIST_START
02998                   : CPT_SMALL_LIST_START);
02999        print_this_string(pp, (char *)s, 0, 1);
03000       } else {
03001        print_compact(pp, CPT_LIST);
03002        print_compact_number(pp, c);
03003        super_compact = -1;
03004       }
03005     }
03006   } else if (pp->honu_mode) {
03007     /* Honu list printing */
03008     cdr = SCHEME_CDR(pair);
03009     while (SAME_TYPE(SCHEME_TYPE(cdr), pair_type)) {
03010       if (ht) {
03011        if ((long)scheme_hash_get(ht, cdr) != 1) {
03012          /* This needs a tag */
03013          break;
03014        }
03015       }
03016       cdr = SCHEME_CDR(cdr);
03017     }
03018     if (SCHEME_NULLP(cdr)) {
03019       /* Proper list without sharing. */
03020       print_utf8_string(pp, "list(", 0, 5);
03021       (void)print(SCHEME_CAR(pair), notdisplay, compact, ht, mt, pp);
03022       cdr = SCHEME_CDR(pair);
03023       while (SAME_TYPE(SCHEME_TYPE(cdr), pair_type)) {
03024        print_utf8_string(pp, ", ", 0, 2);
03025        (void)print(SCHEME_CAR(cdr), notdisplay, compact, ht, mt, pp);
03026        cdr = SCHEME_CDR(cdr);
03027       }
03028       print_utf8_string(pp, ")", 0, 1);
03029     } else {
03030       /* Use cons cells. */
03031       int cnt = 1;
03032       print_utf8_string(pp, "cons(", 0, 5);
03033       (void)print(SCHEME_CAR(pair), notdisplay, compact, ht, mt, pp);
03034       cdr = SCHEME_CDR(pair);
03035       while (SAME_TYPE(SCHEME_TYPE(cdr), pair_type)) {
03036        print_utf8_string(pp, ", ", 0, 2);
03037        if (ht) {
03038          if ((long)scheme_hash_get(ht, cdr) != 1) {
03039            /* This needs a tag */
03040            (void)print(cdr, notdisplay, compact, ht, mt, pp);
03041            break;
03042          }
03043        }
03044         
03045        print_utf8_string(pp, "cons(", 0, 5);
03046        (void)print(SCHEME_CAR(cdr), notdisplay, compact, ht, mt, pp);
03047        cnt++;
03048        cdr = SCHEME_CDR(cdr);
03049       }
03050       print_utf8_string(pp, ", ", 0, 2);
03051       (void)print(cdr, notdisplay, compact, ht, mt, pp);
03052       while (cnt--) {
03053        print_utf8_string(pp, ")", 0, 1);
03054       }
03055     }
03056     return;
03057   }
03058 
03059   if (compact) {
03060     if (!super_compact)
03061       print_compact(pp, CPT_PAIR);
03062   } else {
03063     if (round_parens)
03064       print_utf8_string(pp,"(", 0, 1);
03065     else
03066       print_utf8_string(pp,"{", 0, 1);
03067   }
03068 
03069   print(SCHEME_CAR(pair), notdisplay, compact, ht, mt, pp);
03070 
03071   cdr = SCHEME_CDR (pair);
03072   while (SAME_TYPE(SCHEME_TYPE(cdr), pair_type)) {
03073     if (ht && !super_compact) {
03074       if ((long)scheme_hash_get(ht, cdr) != 1) {
03075        /* This needs a tag */
03076        if (!compact)
03077          print_utf8_string(pp, " . ", 0, 3);
03078        (void)print(cdr, notdisplay, compact, ht, mt, pp);
03079        if (!compact) {
03080           if (round_parens)
03081             print_utf8_string(pp, ")", 0, 1);
03082           else
03083             print_utf8_string(pp, "}", 0, 1);
03084         }
03085        return;
03086       }
03087     }
03088     if (compact && !super_compact)
03089       print_compact(pp, CPT_PAIR);
03090     if (!compact)
03091       print_utf8_string(pp, " ", 0, 1);
03092     print(SCHEME_CAR(cdr), notdisplay, compact, ht, mt, pp);
03093     cdr = SCHEME_CDR(cdr);
03094   }
03095 
03096   if (!SCHEME_NULLP(cdr)) {
03097     if (!compact)
03098       print_utf8_string(pp, " . ", 0, 3);
03099     print(cdr, notdisplay, compact, ht, mt, pp);
03100   } else if (compact && (super_compact < 1))
03101     print_compact(pp, CPT_NULL);
03102 
03103   if (!compact) {
03104     if (round_parens)
03105       print_utf8_string(pp, ")", 0, 1);
03106     else
03107       print_utf8_string(pp, "}", 0, 1);
03108   }
03109 }
03110 
03111 static void
03112 print_vector(Scheme_Object *vec, int notdisplay, int compact, 
03113             Scheme_Hash_Table *ht, 
03114              Scheme_Marshal_Tables *mt,
03115             PrintParams *pp,
03116              int as_prefab)
03117 {
03118   int i, size, common = 0;
03119   Scheme_Object **elems;
03120 
03121   size = SCHEME_VEC_SIZE(vec);
03122 
03123   if (compact) {
03124     print_compact(pp, CPT_VECTOR);
03125     print_compact_number(pp, size);
03126   } else {
03127     elems = SCHEME_VEC_ELS(vec);
03128     for (i = size; i--; common++) {
03129       if (!i || (elems[i] != elems[i - 1]))
03130        break;
03131     }
03132     elems = NULL; /* Precise GC: because VEC_ELS is not aligned */
03133     
03134     if (as_prefab) {
03135       print_utf8_string(pp, "#s(", 0, 3);
03136     } else if (notdisplay && pp->print_vec_shorthand) {
03137       if (size == 0) {
03138        if (pp->honu_mode)
03139          print_utf8_string(pp, "vectorN(0", 0, 7);
03140        else
03141          print_utf8_string(pp, "#0(", 0, 3);
03142       } else {
03143        char buffer[100];
03144        sprintf(buffer, pp->honu_mode ? "vectorN(%d, " : "#%d(", size);
03145        print_utf8_string(pp, buffer, 0, -1);
03146        size -= common;
03147       }
03148     } else if (pp->honu_mode)
03149       print_utf8_string(pp, "vector(", 0, 7);
03150     else
03151       print_utf8_string(pp, "#(", 0, 2);
03152   }
03153 
03154   for (i = 0; i < size; i++) {
03155     print(SCHEME_VEC_ELS(vec)[i], notdisplay, compact, ht, mt, pp);
03156     if (i < (size - 1)) {
03157       if (!compact) {
03158        if (pp->honu_mode)
03159          print_utf8_string(pp, ", ", 0, 2);
03160        else
03161          print_utf8_string(pp, " ", 0, 1);
03162       }
03163     }
03164   }
03165 
03166   if (!compact)
03167     print_utf8_string(pp, ")", 0, 1);
03168 }
03169 
03170 static void
03171 print_char(Scheme_Object *charobj, int notdisplay, PrintParams *pp)
03172 {
03173   int ch;
03174   char minibuf[10+MAX_UTF8_CHAR_BYTES], *str;
03175   int len = -1;
03176 
03177   ch = SCHEME_CHAR_VAL(charobj);
03178   if (notdisplay) {
03179     switch ( ch )
03180       {
03181       case '\0':
03182        str = "#\\nul";
03183        break;
03184       case '\n':
03185        str = "#\\newline";
03186        break;
03187       case '\t':
03188        str = "#\\tab";
03189        break;
03190       case 0xb:
03191        str = "#\\vtab";
03192        break;
03193       case ' ':
03194        str = "#\\space";
03195        break;
03196       case '\r':
03197        str = "#\\return";
03198        break;
03199       case '\f':
03200        str = "#\\page";
03201        break;
03202       case '\b':
03203        str = "#\\backspace";
03204        break;
03205       case 0x7f:
03206        str = "#\\rubout";
03207        break;
03208       default:
03209        if (scheme_isgraphic(ch)) {
03210          minibuf[0] = '#';
03211          minibuf[1] = '\\';
03212          ch = scheme_utf8_encode((unsigned int *)&ch, 0, 1,
03213                               (unsigned char *)minibuf, 2,
03214                               0);
03215          minibuf[2 + ch] = 0;
03216        } else {
03217          if (ch > 0xFFFF)
03218            sprintf(minibuf, "#\\U%.8X", ch);
03219          else
03220            sprintf(minibuf, "#\\u%.4X", ch);
03221        }
03222        str = minibuf;
03223        break;
03224       }
03225   } else {
03226     len = scheme_utf8_encode((unsigned int *)&ch, 0, 1,
03227                           (unsigned char *)minibuf, 0,
03228                           0);
03229     minibuf[len] = 0;
03230     str = minibuf;
03231   }
03232 
03233   print_utf8_string(pp, str, 0, len);
03234 }
03235 
03236 /***************************************************/
03237 
03238 Scheme_Object *scheme_protect_quote(Scheme_Object *expr)
03239 {
03240   if (HAS_SUBSTRUCT(expr, ssALLp)) {
03241     Scheme_Object *q;
03242     q = scheme_alloc_small_object();
03243     q->type = scheme_quote_compilation_type;
03244     SCHEME_PTR_VAL(q) = expr;
03245     return q;
03246   } else
03247     return expr;
03248 }
03249 
03250 /*========================================================================*/
03251 /*                       external printers                                */
03252 /*========================================================================*/
03253 
03254 void scheme_set_type_printer(Scheme_Type stype, Scheme_Type_Printer printer)
03255 {
03256   if (!printers) {
03257     REGISTER_SO(printers);
03258   }
03259 
03260   if (stype >= printers_count) {
03261     Scheme_Type_Printer *naya;
03262     naya = MALLOC_N(Scheme_Type_Printer, stype + 10);
03263     memset(naya, 0, sizeof(Scheme_Type_Printer) * (stype + 10));
03264     memcpy(naya, printers, sizeof(Scheme_Type_Printer) * printers_count);
03265     printers_count = stype + 10;
03266     printers = naya;
03267   }
03268 
03269   printers[stype] = printer;
03270 }
03271 
03272 /*========================================================================*/
03273 /*                           custom writing                               */
03274 /*========================================================================*/
03275 
03276 static Scheme_Object *accum_write(void *_b, int argc, Scheme_Object **argv)
03277 {
03278   if (SCHEME_BOX_VAL(_b)) {
03279     Scheme_Object *v;
03280     v = scheme_make_pair(argv[0], SCHEME_BOX_VAL(_b));
03281     SCHEME_BOX_VAL(_b) = v;
03282   }
03283 
03284   return scheme_void;
03285 }
03286 
03287 static Scheme_Object *writable_struct_subs(Scheme_Object *s, int for_write, PrintParams *pp)
03288 {
03289   Scheme_Object *v, *o, *a[3], *b, *accum_proc;
03290   Scheme_Output_Port *op;
03291 
03292   v = scheme_is_writable_struct(s);
03293 
03294   o = scheme_make_null_output_port(pp->print_port
03295                                && ((Scheme_Output_Port *)pp->print_port)->write_special_fun);
03296 
03297   op = (Scheme_Output_Port *)o;
03298   
03299   b = scheme_box(scheme_null);
03300   accum_proc = scheme_make_closed_prim_w_arity(accum_write,
03301                                           b,
03302                                           "custom-write-recur-handler",
03303                                           2, 2);
03304 
03305   op->display_handler = accum_proc;
03306   op->write_handler = accum_proc;
03307   op->print_handler = accum_proc;
03308 
03309   a[0] = s;
03310   a[1] = o;
03311   a[2] = (for_write ? scheme_true : scheme_false);
03312 
03313   scheme_apply_multi(v, 3, a);
03314 
03315   scheme_close_output_port(o);
03316 
03317   v = SCHEME_BOX_VAL(b);
03318   SCHEME_BOX_VAL(b) = NULL;
03319 
03320   return v;
03321 }
03322 
03323 static void flush_from_byte_port(Scheme_Object *orig_port, PrintParams *pp)
03324 {
03325   char *bytes;
03326   long len;
03327   bytes = scheme_get_sized_byte_string_output(orig_port, &len);
03328   print_this_string(pp, bytes, 0, len);
03329 }
03330 
03331 static Scheme_Object *custom_recur(int notdisplay, void *_vec, int argc, Scheme_Object **argv)
03332 {
03333   Scheme_Hash_Table *ht = (Scheme_Hash_Table *)SCHEME_VEC_ELS(_vec)[0];
03334   Scheme_Marshal_Tables *mt = (Scheme_Marshal_Tables *)SCHEME_VEC_ELS(_vec)[1];
03335   PrintParams * volatile pp = (PrintParams *)SCHEME_VEC_ELS(_vec)[2];
03336   Scheme_Object * volatile save_port;
03337   mz_jmp_buf escape, * volatile save;
03338   volatile long save_max;
03339 
03340   if (!SCHEME_OUTPORTP(argv[1])) {
03341     scheme_wrong_type(notdisplay ? "write/recusrive" : "display/recursive",
03342                     "output-port", 1, argc, argv);
03343     return NULL;
03344   }
03345 
03346   if (SCHEME_VEC_ELS(_vec)[3]) {
03347     /* Recur: */
03348     {
03349       if (pp->print_escape) {
03350        save = pp->print_escape;
03351        pp->print_escape = &escape;
03352       } else
03353        save = NULL;
03354 
03355       save_port = pp->print_port;
03356       save_max = pp->print_maxlen;
03357       
03358       if (!pp->print_escape
03359          || !scheme_setjmp(escape)) {
03360        /* If printing to string, flush it and reset first: */
03361        Scheme_Object *sp;
03362        sp = SCHEME_VEC_ELS(_vec)[4];
03363        if (sp) {
03364          flush_from_byte_port(sp, pp);
03365          sp = scheme_make_byte_string_output_port();
03366          ((Scheme_Output_Port *)SCHEME_VEC_ELS(_vec)[5])->port_data = sp;
03367          SCHEME_VEC_ELS(_vec)[4] = sp;
03368        }
03369 
03370        /* If printing to a different output port, flush print cache,
03371           first. */
03372        if (!SAME_OBJ(save_port, argv[1])) {
03373          print_this_string(pp, NULL, 0, 0);
03374          /* Disable maxlen, because it interferes with flushing.
03375             It would be good to improve on this (to avoid work),
03376             but it's unlikey to ever matter. */
03377          pp->print_maxlen = 0;
03378        }
03379 
03380        pp->print_port = argv[1];
03381 
03382        /* Recur */
03383        print(argv[0], notdisplay, 0, ht, mt, pp);
03384 
03385        /* Flush print cache, to ensure that future writes to the
03386           port go after printed data. */
03387        print_this_string(pp, NULL, 0, 0);
03388       }
03389 
03390       pp->print_port = save_port;
03391       pp->print_escape = save;
03392       pp->print_maxlen = save_max;
03393     }
03394   }
03395 
03396   return scheme_void;
03397 }
03398 
03399 static Scheme_Object *custom_write_recur(void *_vec, int argc, Scheme_Object **argv)
03400 {
03401   return custom_recur(1, _vec, argc, argv);
03402 }
03403 
03404 static Scheme_Object *custom_display_recur(void *_vec, int argc, Scheme_Object **argv)
03405 {
03406   return custom_recur(0, _vec, argc, argv);
03407 }
03408 
03409 static void custom_write_struct(Scheme_Object *s, Scheme_Hash_Table *ht, 
03410                             Scheme_Marshal_Tables *mt,
03411                             PrintParams *orig_pp, int notdisplay)
03412 {
03413   Scheme_Object *v, *a[3], *o, *vec, *orig_port;
03414   Scheme_Output_Port *op;
03415   Scheme_Object *recur_write, *recur_display;
03416   PrintParams *pp;
03417 
03418   v = scheme_is_writable_struct(s);
03419 
03420   /* In case orig_pp is on the stack: */
03421   pp = copy_print_params(orig_pp);
03422 
03423   if (pp->print_port)
03424     orig_port = pp->print_port;
03425   else
03426     orig_port = scheme_make_byte_string_output_port();
03427 
03428   o = scheme_make_redirect_output_port(orig_port);
03429   
03430   op = (Scheme_Output_Port *)o;
03431 
03432   vec = scheme_make_vector(6, NULL);
03433   SCHEME_VEC_ELS(vec)[0] = (Scheme_Object *)ht;
03434   SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)mt;
03435   SCHEME_VEC_ELS(vec)[2] = (Scheme_Object *)pp;
03436   SCHEME_VEC_ELS(vec)[3] = scheme_true;
03437   SCHEME_VEC_ELS(vec)[4] = (pp->print_port ? NULL : orig_port);
03438   SCHEME_VEC_ELS(vec)[5] = o;
03439 
03440   recur_write = scheme_make_closed_prim_w_arity(custom_write_recur,
03441                                           vec,
03442                                           "custom-write-recur-handler",
03443                                           2, 2);
03444   recur_display = scheme_make_closed_prim_w_arity(custom_display_recur,
03445                                             vec,
03446                                             "custom-display-recur-handler",
03447                                             2, 2);
03448 
03449 
03450   op->write_handler = recur_write;
03451   op->display_handler = recur_display;
03452   op->print_handler = recur_write;
03453 
03454   /* First, flush print cache to actual port,
03455      so further writes go after current writes: */
03456   if (pp->print_port)
03457     print_this_string(pp, NULL, 0, 0);
03458 
03459   a[0] = s;
03460   a[1] = o;
03461   a[2] = (notdisplay ? scheme_true : scheme_false);
03462   scheme_apply_multi(v, 3, a);
03463 
03464   scheme_close_output_port(o);
03465 
03466   memcpy(orig_pp, pp, sizeof(PrintParams));
03467 
03468   SCHEME_VEC_ELS(vec)[3] = NULL;
03469 
03470   /* This must go last, because it might escape: */
03471   if (!orig_pp->print_port)
03472     flush_from_byte_port(SCHEME_VEC_ELS(vec)[4], orig_pp);
03473 }
03474 
03475 /*========================================================================*/
03476 /*                       precise GC traversers                            */
03477 /*========================================================================*/
03478 
03479 #ifdef MZ_PRECISE_GC
03480 
03481 START_XFORM_SKIP;
03482 
03483 #define MARKS_FOR_PRINT_C
03484 #include "mzmark.c"
03485 
03486 static void register_traversers(void)
03487 {
03488   GC_REG_TRAV(scheme_rt_print_params, mark_print_params);
03489   GC_REG_TRAV(scheme_rt_marshal_info, mark_marshal_tables);
03490 }
03491 
03492 END_XFORM_SKIP;
03493 
03494 #endif