Mercurial > hg > xemacs-beta
diff src/print.c @ 5560:58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
src/ChangeLog addition:
2011-09-04 Aidan Kehoe <kehoea@parhasard.net>
* alloc.c:
* alloc.c (ALLOC_FROB_BLOCK_LISP_OBJECT_1):
* alloc.c (ALLOC_FROB_BLOCK_LISP_OBJECT):
* alloc.c (cons_print_preprocess):
* alloc.c (vector_print_preprocess):
* alloc.c (vector_nsubst_structures_descend):
* alloc.c (Fmake_symbol):
* alloc.c (UNMARK_symbol):
* alloc.c (sweep_symbols):
* alloc.c (reinit_alloc_objects_early):
* alloc.c (reinit_alloc_early):
* bytecode.c:
* bytecode.c (compiled_function_print_preprocess):
* bytecode.c (compiled_function_nsubst_structures_descend):
* bytecode.c (set_compiled_function_arglist):
* bytecode.c (set_compiled_function_interactive):
* bytecode.c (bytecode_objects_create):
* chartab.c:
* chartab.c (print_preprocess_mapper):
* chartab.c (nsubst_structures_mapper):
* chartab.c (char_table_nsubst_structures_descend):
* chartab.c (chartab_objects_create):
* elhash.c:
* elhash.c (nsubst_structures_map_hash_table):
* elhash.c (hash_table_nsubst_structures_descend):
* elhash.c (print_preprocess_mapper):
* elhash.c (hash_table_print_preprocess):
* elhash.c (inchash_eq):
* elhash.c (hash_table_objects_create):
* elhash.c (syms_of_elhash):
* elhash.h:
* emacs.c (main_1):
* fns.c:
* fns.c (check_eq_nokey):
* fns.c (Fnsubst):
* fns.c (syms_of_fns):
* lisp.h:
* lisp.h (struct Lisp_Symbol):
* lisp.h (IN_OBARRAY):
* lisp.h (struct):
* lisp.h (PRINT_PREPROCESS):
* lread.c (read1):
* lrecord.h:
* lrecord.h (struct lrecord_implementation):
* lrecord.h (DEFINE_DUMPABLE_MODULE_LISP_OBJECT):
* print.c:
* print.c (PRINT_CIRCLE_LIMIT):
* print.c (print_continuous_numbering_changed):
* print.c (print_prepare):
* print.c (print_finish):
* print.c (Fprin1_to_string):
* print.c (print_cons):
* print.c (print_preprocess_inchash_eq):
* print.c (print_preprocess):
* print.c (print_sort_get_numbers):
* print.c (print_sort_compare_ordinals):
* print.c (print_gensym_or_circle):
* print.c (nsubst_structures_descend):
* print.c (nsubst_structures):
* print.c (print_internal):
* print.c (print_symbol):
* print.c (vars_of_print):
* rangetab.c:
* rangetab.c (range_table_print_preprocess):
* rangetab.c (range_table_nsubst_structures_descend):
* rangetab.c (rangetab_objects_create):
* rangetab.c (syms_of_rangetab):
* symbols.c:
* symbols.c (symbol_print_preprocess):
* symbols.c (Fintern):
* symbols.c (Funintern):
* symbols.c (reinit_symbol_objects_early):
* symbols.c (init_symbols_once_early):
* symsinit.h:
Implement print-circle, printing circular structures in a readable
fashion, and treating them appropriately on read. This is by means
of two new object methods, print_preprocess (detecting
circularities), and nsubst_structures_descend (replacing
placeholders with the read objects).
Expose the substitution to Lisp via #'nsubst and its new
:descend-structures keyword.
Store information as to whether symbols are interned in obarray or
not in their header, making checking for keywords and uninterned
symbols (and thus printing) cheaper.
Default print_gensym to t, as Common Lisp does, and as a
more-than-decade old comment suggests.
lisp/ChangeLog addition:
2011-09-04 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el (byte-compile-output-file-form):
* bytecomp.el (byte-compile-output-docform):
Bind print-circle, print-continuous-numbering in these functions,
now those variables are available.
* lisp.el (forward-sexp):
* lisp.el (backward-sexp):
Recognise leading #N= as being part of an expression.
tests/ChangeLog addition:
2011-09-04 Aidan Kehoe <kehoea@parhasard.net>
* automated/lisp-reader-tests.el:
* automated/lisp-tests.el (literal-with-uninterned):
* automated/symbol-tests.el (foo):
Test print-circle, for printing (mutually-)recursive and circular
structures.
Bind print-continuous-numbering where appropriate.
author | Aidan Kehoe <kehoea@parhasard.net> |
---|---|
date | Sun, 04 Sep 2011 19:51:35 +0100 |
parents | b9167d522a9a |
children | 56144c8593a8 |
line wrap: on
line diff
--- a/src/print.c Sun Aug 28 10:34:54 2011 +0100 +++ b/src/print.c Sun Sep 04 19:51:35 2011 +0100 @@ -50,6 +50,7 @@ #endif #include "sysfile.h" +#include "elhash.h" #include <float.h> /* Define if not in float.h */ @@ -71,8 +72,8 @@ static int print_depth; /* Detect most circularities to print finite output. */ -#define PRINT_CIRCLE 200 -static Lisp_Object being_printed[PRINT_CIRCLE]; +#define PRINT_CIRCLE_LIMIT 200 +static Lisp_Object being_printed[PRINT_CIRCLE_LIMIT]; /* Maximum length of list or vector to print in full; noninteger means effectively infinity */ @@ -96,15 +97,48 @@ Lisp_Object Vprint_message_label; /* Nonzero means print newlines in strings as \n. */ - -int print_escape_newlines; -int print_readably; - -/* Non-nil means print #: before uninterned symbols. - Neither t nor nil means so that and don't clear Vprint_gensym_alist - on entry to and exit from print functions. */ -Lisp_Object Vprint_gensym; -Lisp_Object Vprint_gensym_alist; +Boolint print_escape_newlines; + +Boolint print_readably; + +/* Non-zero means print #: before uninterned symbols, and use the #n= and + #n# syntax for them. */ +Boolint print_gensym; + +/* Non-zero means print recursive structures using #n= and #n# syntax. */ +Boolint print_circle; + +/* Non-zero means keep continuous numbers for #n= and #n# syntax between + several print functions. Setting or binding the corresponding Lisp + variable to a non-nil value silently *clears* Vprint_number_table. */ +Boolint print_continuous_numbering; + +/* Vprint_number_table is a hash table mapping objects to their statuses for + this print operation. The statuses are represented by integers. */ +Lisp_Object Vprint_number_table; + +/* These describe the bit fields of the integers in Vprint_number_table. */ +enum PRINT_NUMBER_FIELDS { + /* Lowest four bits describe the number of times a given object has + been seen, allowing entries to be manipulated cheaply by + inchash_eq() when encountered. */ + PRINT_NUMBER_SEEN_MASK = 0xF, + + /* The next twenty-five bits give the sequence number for the object, + corresponding to the order in which print_preprocess encountered the + objects; as such, it's related to print_number_index. */ + PRINT_NUMBER_ORDINAL_MASK = 0x1FFFFFF0, + PRINT_NUMBER_ORDINAL_SHIFT = 4, + + /* And the next bit describes whether the object has already been printed + in this print operation (or in these print operations, if + print-continuous-numbering is relevant). */ + PRINT_NUMBER_PRINTED_MASK = 0x20000000, +}; + +/* Reflects the number of repeated or possibly-repeated objects encountered + by print_preprocess(); reset whenever Vprint_number_table is cleared. */ +Elemcount print_number_index; Lisp_Object Qdisplay_error; Lisp_Object Qprint_message_label; @@ -540,11 +574,29 @@ UNGCPRO; } -#define RESET_PRINT_GENSYM do { \ - if (!CONSP (Vprint_gensym)) \ - Vprint_gensym_alist = Qnil; \ -} while (0) - +static int +print_continuous_numbering_changed (Lisp_Object UNUSED (sym), + Lisp_Object *val, + Lisp_Object UNUSED (in_object), + int UNUSED (flags)) +{ + if (!NILP (*val) && !print_continuous_numbering) + { + Fclrhash (Vprint_number_table); + print_number_index = 0; + } + + return 0; +} + +#define RESET_PRINT_NUMBER_TABLE do { \ + if (!print_continuous_numbering) \ + { \ + Fclrhash (Vprint_number_table); \ + print_number_index = 0; \ + } \ + } while (0) + Lisp_Object canonicalize_printcharfun (Lisp_Object printcharfun) { @@ -565,8 +617,8 @@ if (gc_in_progress) return Qnil; #endif - - RESET_PRINT_GENSYM; + + RESET_PRINT_NUMBER_TABLE; printcharfun = canonicalize_printcharfun (printcharfun); @@ -612,8 +664,8 @@ if (gc_in_progress) return; #endif - - RESET_PRINT_GENSYM; + + RESET_PRINT_NUMBER_TABLE; /* See the comment in print_prepare(). */ if (FRAMEP (frame_kludge)) @@ -935,9 +987,9 @@ /* This function can GC */ Lisp_Object result = Qnil; - RESET_PRINT_GENSYM; + RESET_PRINT_NUMBER_TABLE; result = prin1_to_string (object, !(EQ(noescape, Qnil))); - RESET_PRINT_GENSYM; + RESET_PRINT_NUMBER_TABLE; return result; } @@ -1415,30 +1467,56 @@ obj = XCDR (obj), len++) { if (len > 0) - write_ascstring (printcharfun, " "); - if (EQ (obj, tortoise) && len > 0) - { - if (print_readably) - printing_unreadable_object_fmt ("circular list"); - else - write_ascstring (printcharfun, "... <circular list>"); - break; - } - if (len & 1) - tortoise = XCDR (tortoise); - if (len > max) - { - write_ascstring (printcharfun, "..."); - break; - } + { + write_ascstring (printcharfun, " "); + + /* Note that print_cons is the only object method that does any + circularity checking itself, because a cons that is the cdr + of OBJ is not handed to print_internal in the ordinary course + of events. All the other possibly-repeated structures always + hand sub-objects to print_internal(). */ + if (print_circle && + INTP (Fgethash (obj, Vprint_number_table, Qnil))) + { + write_ascstring (printcharfun, ". "); + print_internal (obj, printcharfun, escapeflag); + /* We have printed the list's tail, print_cons() is done. */ + break; + } + + if (EQ (obj, tortoise)) + { + if (print_readably) + { + printing_unreadable_object_fmt ("circular list"); + } + + write_ascstring (printcharfun, "... <circular list>"); + break; + } + + if (len & 1) + { + tortoise = XCDR (tortoise); + } + + if (len > max) + { + write_ascstring (printcharfun, "..."); + break; + } + } + print_internal (XCAR (obj), printcharfun, escapeflag); } } + if (!LISTP (obj)) { write_ascstring (printcharfun, " . "); print_internal (obj, printcharfun, escapeflag); } + UNGCPRO; write_ascstring (printcharfun, ")"); @@ -1638,13 +1716,323 @@ "#<SERIOUS XEMACS BUG: %s Save your buffers immediately " "and please report this bug>", buf); } - + +/* Not static only because of print_preprocess_cons. */ +Elemcount print_preprocess_inchash_eq (Lisp_Object, Lisp_Object, Elemcount *); + +Elemcount +print_preprocess_inchash_eq (Lisp_Object obj, Lisp_Object table, + Elemcount *seen_object_count) +{ + htentry *hte = inchash_eq (obj, table, 1); + Elemcount extracted; + + /* If the hash table had to be resized, hte is NULL. */ + if (hte == NULL) + { + hte = find_htentry (obj, XHASH_TABLE (table)); + } + + extracted = XINT (hte->value); + if (1 == extracted) + { + *seen_object_count += 1; + hte->value + = make_int (1 | (*seen_object_count << PRINT_NUMBER_ORDINAL_SHIFT)); + } + else if ((extracted & PRINT_NUMBER_SEEN_MASK) == PRINT_NUMBER_SEEN_MASK) + { + /* Avoid the number overflowing the bit field. */ + extracted = (extracted & ~PRINT_NUMBER_SEEN_MASK) | 2; + hte->value = make_int (extracted); + } + + return extracted & PRINT_NUMBER_SEEN_MASK; +} + +/* Fill in Vprint_number_table according to the structure of OBJ. OBJ itself + and all its elements will be added to Vprint_number_table recursively if + its type has the print_preprocess method implemented. Objects with the + print_preprocess method implemented include cons, vector, compiled + function, hash table, char table, range table, and symbol. Symbol is an + exceptional type in that it is impossible to construct a recursive symbol + structure, but is here for the print-gensym feature. */ + +void +print_preprocess (Lisp_Object object, Lisp_Object print_number_table, + Elemcount *seen_object_count) +{ + if (!LRECORDP (object) || !HAS_OBJECT_METH_P (object, print_preprocess)) + { + return; + } + + if (SYMBOLP (object) && IN_OBARRAY (object)) + { + /* Handle symbols specially. We do this here rather than in symbols.c + because we don't want to have all the other print_preprocess methods + worry about print_preprocess_inchash_eq. */ + return; + } + + if (print_preprocess_inchash_eq (object, print_number_table, + seen_object_count) > 1) + { + return; + } + + OBJECT_METH (object, print_preprocess, (object, print_number_table, + seen_object_count)); +} + +typedef struct { Lisp_Object key; Elemcount count; } preprocess_sort_t; + +static int +print_seen_once (Lisp_Object UNUSED (key), Lisp_Object value, + void * UNUSED (extra_arg)) +{ + return 1 == ((XINT (value) & PRINT_NUMBER_SEEN_MASK)); +} + +static int +print_nonsymbol_seen_once (Lisp_Object key, Lisp_Object value, + void * UNUSED (extra_arg)) +{ + /* print_continuous_numbering is used for symbols, so we don't delete them + from the print info hash table. It's less useful for other objects at + the moment, though. */ + return !SYMBOLP (key) && (1 == ((XINT (value) & PRINT_NUMBER_SEEN_MASK))); +} + +static int +print_sort_get_numbers (Lisp_Object key, Lisp_Object value, void *extra_arg) +{ + preprocess_sort_t **preprocess_sort_ptr = (preprocess_sort_t **) extra_arg; + preprocess_sort_t *preprocess_sort = *preprocess_sort_ptr; + + *preprocess_sort_ptr += 1; + preprocess_sort->key = key; + preprocess_sort->count = XINT (value); + + return 0; +} + +static int +print_sort_compare_ordinals (const void *object1, const void *object2) +{ + Elemcount a = ((preprocess_sort_t *) object1)->count + & PRINT_NUMBER_ORDINAL_MASK; + Elemcount b = ((preprocess_sort_t *) object2)->count + & PRINT_NUMBER_ORDINAL_MASK; + + return a - b; +} + +enum print_gensym_status + { + PRINT_GENSYM_DONE, + PRINT_GENSYM_PRINT, + PRINT_GENSYM_PRINT_AND_CLEANUP_TABLE, + }; + +/* Check for any circular objects or repeated uninterned symbols. + + If OBJ is a repeated structure (or symbol) and it has been printed + already, print it now in the #%d# format, and return 1, to indicate + print_internal is done. + + If OBJ is a repeated structure and it has not yet been printed, print + #%d= before the object, mark it as printed, and return zero, to indicate + print_internal should continue as usual. + + If OBJ is not a repeated structure, do nothing, and return zero, to + indicate print_internal should continue as usual. */ +static enum print_gensym_status +print_gensym_or_circle (Lisp_Object obj, Lisp_Object printcharfun) +{ + Lisp_Object seen = Fgethash (obj, Vprint_number_table, Qnil); + if (NILP (seen)) + { + Elemcount old_print_number_index = print_number_index; + + print_preprocess (obj, Vprint_number_table, &print_number_index); + + if (old_print_number_index != print_number_index) + { + Elemcount new_print_number_index, ii; + + /* We support up to 25 bits' worth of repeated objects, which is + 33 million or so, far more than we support in, say, a + compiled-function constants vector. */ + assert (print_number_index <= + (PRINT_NUMBER_ORDINAL_MASK >> PRINT_NUMBER_ORDINAL_SHIFT)); + + /* If any objects have been seen once and once only, remove them + from Vprint_number_table. This is a bit of an arbitrary + decision; we could keep them around for the sake of + print_continuous_numbering, but there's the reasonable worry + about Vprint_number_table getting awkwardly large. */ + elisp_map_remhash (print_continuous_numbering ? + print_nonsymbol_seen_once : print_seen_once, + Vprint_number_table, NULL); + + new_print_number_index + = XINT (Fhash_table_count (Vprint_number_table)); + + if (new_print_number_index != print_number_index + && new_print_number_index != old_print_number_index) + { + preprocess_sort_t *preprocess_sort + = alloca_array (preprocess_sort_t, new_print_number_index); + preprocess_sort_t *preprocess_sort_ptr = preprocess_sort; + + /* There are new objects in Vprint_number_table, but their + ordinal values don't necessarily represent the order they + were seen in, there will be gaps corresponding to the + non-symbols that were seen only once. Correct this. */ + elisp_maphash_unsafe (print_sort_get_numbers, Vprint_number_table, + &preprocess_sort_ptr); + + qsort (preprocess_sort, new_print_number_index, + sizeof (preprocess_sort_t), print_sort_compare_ordinals); + + for (ii = old_print_number_index; + ii < new_print_number_index; + ii++) + { + Fputhash (preprocess_sort[ii].key, + make_int ((preprocess_sort[ii].count + & ~PRINT_NUMBER_ORDINAL_MASK) + | ((ii + 1) + << PRINT_NUMBER_ORDINAL_SHIFT)), + Vprint_number_table); + } + } + + print_number_index = new_print_number_index; + + /* The new objects may include OBJ; update SEEN to reflect + this. */ + seen = Fgethash (obj, Vprint_number_table, Qnil); + if (INTP (seen)) + { + goto prefix_this; + } + } + } + else + { + prefix_this: + if ((XINT (seen) & PRINT_NUMBER_SEEN_MASK) == 1 + && !(print_continuous_numbering && SYMBOLP (obj))) + { + return PRINT_GENSYM_PRINT_AND_CLEANUP_TABLE; + } + else if (XINT (seen) & PRINT_NUMBER_PRINTED_MASK) + { + write_fmt_string (printcharfun, "#%d#", + (XINT (seen) & PRINT_NUMBER_ORDINAL_MASK) + >> PRINT_NUMBER_ORDINAL_SHIFT); + + /* We're finished printing this object. */ + return PRINT_GENSYM_DONE; + } + else + { + write_fmt_string (printcharfun, "#%d=", + (XINT (seen) & PRINT_NUMBER_ORDINAL_MASK) + >> PRINT_NUMBER_ORDINAL_SHIFT); + + /* We set PRINT_NUMBER_PRINTED_MASK immediately here, so the + object itself is written as #%d# when printing its contents. */ + Fputhash (obj, make_int (XINT (seen) | PRINT_NUMBER_PRINTED_MASK), + Vprint_number_table); + + /* This is the first time the object has been seen while + printing the recursive object; we still have to go ahead + and do the actual print. */ + } + } + + return PRINT_GENSYM_PRINT; +} + +Lisp_Object +nsubst_structures_descend (Lisp_Object new_, Lisp_Object old, + Lisp_Object tree, + Lisp_Object number_table, Boolint test_not_unboundp) +{ + Lisp_Object seen; + + if (!LRECORDP (tree) || !HAS_OBJECT_METH_P (tree, nsubst_structures_descend)) + { + return tree; + } + + seen = Fgethash (tree, number_table, Qnil); + + if (INTP (seen)) + { + if (XINT (seen) & PRINT_NUMBER_PRINTED_MASK) + { + return tree; + } + + Fputhash (tree, make_int (XINT (seen) | PRINT_NUMBER_PRINTED_MASK), + number_table); + } + + OBJECT_METH (tree, nsubst_structures_descend, + (new_, old, tree, number_table, test_not_unboundp)); + + return tree; +} + +/* Descend TREE, replacing the Lisp object OLD each time it is encountered + with the Lisp object NEW_. TREE can be recursive or circular, and this is + handled correctly. */ +Lisp_Object +nsubst_structures (Lisp_Object new_, Lisp_Object old, Lisp_Object tree, + check_test_func_t check_test, Boolint test_not_unboundp, + Lisp_Object UNUSED (test), Lisp_Object UNUSED (key)) +{ + Lisp_Object number_table, result; + Elemcount ordinal = 0; + struct gcpro gcpro1; + + if (check_test != check_eq_nokey || !LRECORDP (old)) + { + signal_error (Qunimplemented, + ":descend-structures not yet finished, nsubst", + Qunbound); + } + + if (!LRECORDP (tree) || !HAS_OBJECT_METH_P (tree, nsubst_structures_descend)) + { + return tree; + } + + number_table = make_lisp_hash_table (16, HASH_TABLE_NON_WEAK, Qeq); + GCPRO1 (number_table); + + print_preprocess (tree, number_table, &ordinal); + + /* This function can GC by means of the hash table test functions, when + replacing hash table entries. */ + result = nsubst_structures_descend (new_, old, tree, number_table, + test_not_unboundp); + Fclrhash (number_table); + + RETURN_UNGCPRO (result); +} + void print_internal (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag) { /* This function can GC */ int specdepth = 0; struct gcpro gcpro1, gcpro2; + Boolint cleanup_table = 0; QUIT; @@ -1683,9 +2071,12 @@ { specdepth = internal_bind_int (&print_depth, print_depth + 1); - if (print_depth > PRINT_CIRCLE) - signal_error (Qstack_overflow, - "Apparently circular structure being printed", Qunbound); + if (print_depth > PRINT_CIRCLE_LIMIT) + { + signal_error (Qstack_overflow, + "Apparently circular structure being printed", + Qunbound); + } } switch (XTYPE (obj)) @@ -1888,10 +2279,25 @@ } } - /* Detect circularities and truncate them. - No need to offer any alternative--this is better than an error. */ - if (CONSP (obj) || VECTORP (obj) || COMPILED_FUNCTIONP (obj)) - { + if (LRECORDP (obj) && + ((print_circle && HAS_OBJECT_METH_P (obj, print_preprocess)) || + (print_gensym && SYMBOLP (obj) && !IN_OBARRAY (obj)))) + { + enum print_gensym_status status + = print_gensym_or_circle (obj, printcharfun); + + cleanup_table = (PRINT_GENSYM_PRINT_AND_CLEANUP_TABLE == status); + + if (PRINT_GENSYM_DONE == status) + { + break; + } + } + else if (!print_circle && + /* Could this structure be recursive? */ + LRECORDP (obj) + && HAS_OBJECT_METH_P (obj, nsubst_structures_descend)) + { int i; for (i = 0; i < print_depth - 1; i++) if (EQ (obj, being_printed[i])) @@ -1937,6 +2343,19 @@ } } + if (cleanup_table) + { + /* If any objects have been seen once and once only, remove them from + Vprint_number_table. This is a bit of an arbitrary decision; we + could keep them around for the sake of print_continuous_numbering, + but there's the reasonable worry about Vprint_number_table getting + awkwardly large. */ + elisp_map_remhash (print_continuous_numbering ? + print_nonsymbol_seen_once : print_seen_once, + Vprint_number_table, NULL); + + } + if (!inhibit_non_essential_conversion_operations) unbind_to (specdepth); UNGCPRO; @@ -1968,49 +2387,15 @@ output_string (printcharfun, 0, name, 0, size); return; } + GCPRO2 (obj, printcharfun); - /* If we print an uninterned symbol as part of a complex object and - the flag print-gensym is non-nil, prefix it with #n= to read the - object back with the #n# reader syntax later if needed. */ - if (!NILP (Vprint_gensym) - /* #### Test whether this produces a noticeable slow-down for - printing when print-gensym is non-nil. */ - && !EQ (obj, oblookup (Vobarray, - XSTRING_DATA (symbol_name (XSYMBOL (obj))), - XSTRING_LENGTH (symbol_name (XSYMBOL (obj)))))) + if (print_gensym) { - if (print_depth > 1) - { - Lisp_Object tem = Fassq (obj, Vprint_gensym_alist); - if (CONSP (tem)) - { - write_ascstring (printcharfun, "#"); - print_internal (XCDR (tem), printcharfun, escapeflag); - write_ascstring (printcharfun, "#"); - UNGCPRO; - return; - } - else - { - if (CONSP (Vprint_gensym_alist)) - { - /* Vprint_gensym_alist is exposed to Lisp, so we - have to be careful. */ - CHECK_CONS (XCAR (Vprint_gensym_alist)); - CHECK_INT (XCDR (XCAR (Vprint_gensym_alist))); - tem = make_int (XINT (XCDR (XCAR (Vprint_gensym_alist))) + 1); - } - else - tem = make_int (1); - Vprint_gensym_alist = Fcons (Fcons (obj, tem), Vprint_gensym_alist); - - write_ascstring (printcharfun, "#"); - print_internal (tem, printcharfun, escapeflag); - write_ascstring (printcharfun, "="); - } - } - write_ascstring (printcharfun, "#:"); + if (!IN_OBARRAY (obj)) + { + write_ascstring (printcharfun, "#:"); + } } /* Does it look like an integer or a float? */ @@ -2688,9 +3073,7 @@ */ ); print_readably = 0; - /* #### I think this should default to t. But we'd better wait - until we see that it works out. */ - DEFVAR_LISP ("print-gensym", &Vprint_gensym /* + DEFVAR_BOOL ("print-gensym", &print_gensym /* If non-nil, then uninterned symbols will be printed specially. Uninterned symbols are those which are not present in `obarray', that is, those which were made with `make-symbol' or by calling `intern' with a @@ -2703,19 +3086,43 @@ two pointers to the same uninterned symbol, `read' will not duplicate that structure. -If the value of `print-gensym' is a cons cell, then in addition -refrain from clearing `print-gensym-alist' on entry to and exit from -printing functions, so that the use of #...# and #...= can carry over -for several separately printed objects. +If the value of `print-continuous-numbering' is non-nil, the table used by +`print-gensym' and `print-circle' (which see) will not be reset on entry to +and exit from printing functions, so that the use of #...# and #...= can +carry over for several separately printed objects. */ ); - Vprint_gensym = Qnil; - - DEFVAR_LISP ("print-gensym-alist", &Vprint_gensym_alist /* -Association list of elements (GENSYM . N) to guide use of #N# and #N=. -In each element, GENSYM is an uninterned symbol that has been associated -with #N= for the specified value of N. -*/ ); - Vprint_gensym_alist = Qnil; + print_gensym = 1; + + DEFVAR_BOOL ("print-circle", &print_circle /* +Non-nil means print recursive structures using #N= and #N# syntax. + +If nil, XEmacs detects recursive structures and truncates them in an +unreadable fashion. + +If non-nil, shared substructures anywhere in the structure are printed +with `#N=' before the first occurrence (in the order of the print +representation) and `#N#' in place of each subsequent occurrence, +where N is a positive decimal integer. + +If the value of `print-continuous-numbering' is non-nil, the table used by +`print-gensym' (which see) and `print-circle' will not be reset on entry to +and exit from printing functions, so that the use of #...# and #...= can +carry over for several separately printed objects. +*/); + print_circle = 0; + + DEFVAR_BOOL_MAGIC ("print-continuous-numbering", + &print_continuous_numbering /* +Non-nil means number continuously across print calls, mostly for symbols. +This affects the numbers printed for #N= labels and #M# references. +See also `print-circle' and `print-gensym'. +This variable should not be set with `setq'; bind it with a `let' instead. +*/ , + print_continuous_numbering_changed); + print_continuous_numbering = 0; + + staticpro (&Vprint_number_table); + Vprint_number_table = make_lisp_hash_table (16, HASH_TABLE_KEY_WEAK, Qeq); DEFVAR_LISP ("print-message-label", &Vprint_message_label /* Label for minibuffer messages created with `print'. This should