GNU has had this for a while. Their implementation isn’t particularly
object-oriented, and I wrote the bulk of the below before we moved to GPLv3,
so it’s very different code. If anyone’s interested in writing tests, I can
commit this, but I won’t get to writing tests myself for a while, and I’m
not in a rush to commit the change without them.
lisp/ChangeLog addition:
2011-08-11 Aidan Kehoe <kehoea(a)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.
src/ChangeLog addition:
2011-08-11 Aidan Kehoe <kehoea(a)parhasard.net>
* alloc.c:
* alloc.c (cons_print_preprocess):
* alloc.c (vector_print_preprocess):
* alloc.c (vector_nsubst_structures_descend):
* 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.h (PRINT_PREPROCESS):
* lread.c (read1):
* lrecord.h (struct lrecord_implementation):
* 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 (reinit_symbol_objects_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.
diff -r 493c487cbc3f lisp/bytecomp.el
--- a/lisp/bytecomp.el Wed Aug 10 16:50:37 2011 +0100
+++ b/lisp/bytecomp.el Thu Aug 11 17:01:22 2011 +0100
@@ -1935,12 +1935,13 @@
(byte-compile-output-docform nil nil '("\n(" 3 ")") form
nil
(memq (car form)
'(autoload custom-declare-variable)))
- (let ((print-escape-newlines t)
- (print-length nil)
- (print-level nil)
- (print-readably t) ; print #[] for bytecode, 'x for (quote x)
- (print-gensym (if byte-compile-print-gensym '(t) nil))
- print-gensym-alist)
+ (let* ((print-escape-newlines t)
+ (print-length nil)
+ (print-level nil)
+ (print-readably t) ; print #[] for bytecode, 'x for (quote x)
+ (print-gensym byte-compile-print-gensym)
+ (print-continuous-numbering print-gensym)
+ (print-circle t))
(when byte-compile-output-preface
(princ "\n(progn " byte-compile-outbuffer)
(prin1 byte-compile-output-preface byte-compile-outbuffer))
@@ -1984,18 +1985,16 @@
(> (length (nth (nth 1 info) form)) 0)
(char= (aref (nth (nth 1 info) form) 0) ?*))
(setq position (- position)))))
- (let ((print-escape-newlines t)
- (print-readably t) ; print #[] for bytecode, 'x for (quote x)
- ;; Use a cons cell to say that we want
- ;; print-gensym-alist not to be cleared between calls
- ;; to print functions.
- (print-gensym (if byte-compile-print-gensym '(t) nil))
- print-gensym-alist
- (index 0))
+ (byte-compile-flush-pending)
+ (let* ((print-escape-newlines t)
+ (print-readably t) ; print #[] for bytecode, 'x for (quote x)
+ (print-gensym byte-compile-print-gensym)
+ (print-continuous-numbering print-gensym)
+ (print-circle t)
+ (index 0))
(when byte-compile-output-preface
(princ "\n(progn " byte-compile-outbuffer)
(prin1 byte-compile-output-preface byte-compile-outbuffer))
- (byte-compile-flush-pending)
(if preface
(progn
(insert preface)
diff -r 493c487cbc3f src/alloc.c
--- a/src/alloc.c Wed Aug 10 16:50:37 2011 +0100
+++ b/src/alloc.c Thu Aug 11 17:01:22 2011 +0100
@@ -1326,6 +1326,43 @@
return 0;
}
+static void
+cons_print_preprocess (Lisp_Object object, Lisp_Object print_number_table,
+ Elemcount *seen_object_count)
+{
+ PRINT_PREPROCESS (XCAR (object), print_number_table, seen_object_count);
+ PRINT_PREPROCESS (XCDR (object), print_number_table, seen_object_count);
+}
+
+static void
+cons_nsubst_structures_descend (Lisp_Object new_, Lisp_Object old,
+ Lisp_Object object,
+ Lisp_Object number_table,
+ Boolint test_not_unboundp)
+{
+ if (EQ (old, XCAR (object)) == test_not_unboundp)
+ {
+ XSETCAR (object, new_);
+ }
+ else if (LRECORDP (XCAR (object)) &&
+ HAS_OBJECT_METH_P (XCAR (object), nsubst_structures_descend))
+ {
+ nsubst_structures_descend (new_, old, XCAR (object), number_table,
+ test_not_unboundp);
+ }
+
+ if (EQ (old, XCDR (object)))
+ {
+ XSETCDR (object, new_);
+ }
+ else if (LRECORDP (XCDR (object)) &&
+ HAS_OBJECT_METH_P (XCDR (object), nsubst_structures_descend))
+ {
+ nsubst_structures_descend (new_, old, XCDR (object), number_table,
+ test_not_unboundp);
+ }
+}
+
static const struct memory_description cons_description[] = {
{ XD_LISP_OBJECT, offsetof (Lisp_Cons, car_) },
{ XD_LISP_OBJECT, offsetof (Lisp_Cons, cdr_) },
@@ -1713,6 +1750,44 @@
depth + 1, equalp));
}
+static void
+vector_print_preprocess (Lisp_Object object, Lisp_Object print_number_table,
+ Elemcount *seen_object_count)
+{
+ Elemcount ii, len;
+
+ for (ii = 0, len = XVECTOR_LENGTH (object); ii < len; ii++)
+ {
+ PRINT_PREPROCESS (XVECTOR_DATA (object)[ii], print_number_table,
+ seen_object_count);
+ }
+}
+
+static void
+vector_nsubst_structures_descend (Lisp_Object new_, Lisp_Object old,
+ Lisp_Object object, Lisp_Object number_table,
+ Boolint test_not_unboundp)
+{
+ Elemcount ii = XVECTOR_LENGTH (object);
+ Lisp_Object *vdata = XVECTOR_DATA (object);
+
+ while (ii > 0)
+ {
+ --ii;
+
+ if (EQ (vdata[ii], old) == test_not_unboundp)
+ {
+ vdata[ii] = new_;
+ }
+ else if (LRECORDP (vdata[ii]) &&
+ HAS_OBJECT_METH_P (vdata[ii], nsubst_structures_descend))
+ {
+ nsubst_structures_descend (new_, old, vdata[ii], number_table,
+ test_not_unboundp);
+ }
+ }
+}
+
static const struct memory_description vector_description[] = {
{ XD_LONG, offsetof (Lisp_Vector, size) },
{ XD_LISP_OBJECT_ARRAY, offsetof (Lisp_Vector, contents), XD_INDIRECT(0, 0) },
@@ -5631,6 +5706,11 @@
OBJECT_HAS_METHOD (string, putprop);
OBJECT_HAS_METHOD (string, remprop);
OBJECT_HAS_METHOD (string, plist);
+
+ OBJECT_HAS_METHOD (cons, print_preprocess);
+ OBJECT_HAS_METHOD (cons, nsubst_structures_descend);
+ OBJECT_HAS_METHOD (vector, print_preprocess);
+ OBJECT_HAS_METHOD (vector, nsubst_structures_descend);
}
void
diff -r 493c487cbc3f src/bytecode.c
--- a/src/bytecode.c Wed Aug 10 16:50:37 2011 +0100
+++ b/src/bytecode.c Thu Aug 11 17:01:22 2011 +0100
@@ -95,6 +95,13 @@
Lisp_Compiled_Function_Args);
#endif /* NEW_GC */
+static void set_compiled_function_arglist (Lisp_Compiled_Function *,
+ Lisp_Object);
+static void set_compiled_function_constants (Lisp_Compiled_Function *,
+ Lisp_Object);
+static void set_compiled_function_interactive (Lisp_Compiled_Function *,
+ Lisp_Object);
+
EXFUN (Ffetch_bytecode, 1);
Lisp_Object Qbyte_code, Qcompiled_functionp, Qinvalid_byte_code;
@@ -2360,6 +2367,76 @@
f2->doc_and_interactive, depth + 1));
}
+static void
+compiled_function_print_preprocess (Lisp_Object object,
+ Lisp_Object print_number_table,
+ Elemcount *seen_object_count)
+{
+ Lisp_Compiled_Function *cf = XCOMPILED_FUNCTION (object);
+
+ PRINT_PREPROCESS (compiled_function_arglist (cf), print_number_table,
+ seen_object_count);
+
+ PRINT_PREPROCESS (compiled_function_constants (cf), print_number_table,
+ seen_object_count);
+
+ if (cf->flags.interactivep)
+ {
+ PRINT_PREPROCESS (compiled_function_interactive (cf),
+ print_number_table, seen_object_count);
+ }
+}
+
+static void
+compiled_function_nsubst_structures_descend (Lisp_Object new_, Lisp_Object old,
+ Lisp_Object object,
+ Lisp_Object number_table,
+ Boolint test_not_unboundp)
+{
+ Lisp_Compiled_Function *cf = XCOMPILED_FUNCTION (object);
+ Lisp_Object arglist = compiled_function_arglist (cf);
+ Lisp_Object constants = compiled_function_constants (cf);
+
+ if (EQ (arglist, old) == test_not_unboundp)
+ {
+ set_compiled_function_arglist (cf, new_);
+ }
+ else if (CONSP (arglist))
+ {
+ nsubst_structures_descend (new_, old, arglist, number_table,
+ test_not_unboundp);
+ }
+
+ if (EQ (constants, old) == test_not_unboundp)
+ {
+ set_compiled_function_constants (cf, new_);
+ }
+ else
+ {
+ nsubst_structures_descend (new_, old, constants, number_table,
+ test_not_unboundp);
+ }
+
+ /* We're not descending into the instructions here, because this function
+ is initially for use in the Lisp reader, where it only makes sense to
+ use the #%d= syntax for lrecords. */
+
+ if (cf->flags.interactivep)
+ {
+ Lisp_Object interactive = compiled_function_interactive (cf);
+ if (EQ (interactive, old) == test_not_unboundp)
+ {
+ set_compiled_function_interactive (cf, new_);
+ }
+ else if (LRECORDP (interactive) &&
+ HAS_OBJECT_METH_P (interactive, nsubst_structures_descend))
+ {
+ nsubst_structures_descend (new_, old, interactive, number_table,
+ test_not_unboundp);
+ }
+ }
+}
+
static Hashcode
compiled_function_hash (Lisp_Object obj, int depth, Boolint UNUSED (equalp))
{
@@ -2607,6 +2684,47 @@
}
}
+static void
+set_compiled_function_arglist (Lisp_Compiled_Function *f, Lisp_Object new_)
+{
+ CHECK_LIST (new_);
+ f->arglist = new_;
+
+ /* Recalculate the optimized version of the function, since this depends
+ on the arglist. */
+ f->instructions = compiled_function_instructions (f);
+ optimize_compiled_function (wrap_compiled_function (f));
+}
+
+static void
+set_compiled_function_constants (Lisp_Compiled_Function *f, Lisp_Object new_)
+{
+ CHECK_VECTOR (new_);
+ f->constants = new_;
+}
+
+static void
+set_compiled_function_interactive (Lisp_Compiled_Function *f, Lisp_Object new_)
+{
+ assert (f->flags.interactivep);
+
+ if (f->flags.documentationp && f->flags.domainp)
+ {
+ XSETCAR (XCDR (f->doc_and_interactive), new_);
+ }
+ else if (f->flags.documentationp)
+ {
+ XSETCDR (f->doc_and_interactive, new_);
+ }
+ else if (f->flags.domainp)
+ {
+ XSETCAR (f->doc_and_interactive, new_);
+ }
+ else
+ {
+ f->doc_and_interactive = new_;
+ }
+}
DEFUN ("compiled-function-arglist", Fcompiled_function_arglist, 1, 1, 0, /*
Return the argument list of the compiled-function object FUNCTION.
@@ -2782,6 +2900,13 @@
void
+bytecode_objects_create (void)
+{
+ OBJECT_HAS_METHOD (compiled_function, print_preprocess);
+ OBJECT_HAS_METHOD (compiled_function, nsubst_structures_descend);
+}
+
+void
syms_of_bytecode (void)
{
INIT_LISP_OBJECT (compiled_function);
diff -r 493c487cbc3f src/chartab.c
--- a/src/chartab.c Wed Aug 10 16:50:37 2011 +0100
+++ b/src/chartab.c Thu Aug 11 17:01:22 2011 +0100
@@ -94,6 +94,122 @@
/* Char Table object */
/************************************************************************/
+static int
+print_preprocess_mapper (struct chartab_range * UNUSED (range),
+ Lisp_Object UNUSED (table), Lisp_Object val,
+ void *extra_arg)
+{
+ print_preprocess (val, ((preprocess_info_t *) extra_arg)->table,
+ ((preprocess_info_t *) extra_arg)->count);
+ return 0;
+}
+
+static void
+char_table_print_preprocess (Lisp_Object object, Lisp_Object print_number_table,
+ Elemcount *seen_object_count)
+{
+ struct chartab_range ctr = { CHARTAB_RANGE_ALL, 0, Qnil, 0 };
+ preprocess_info_t preprocess_info = { print_number_table, seen_object_count };
+ map_char_table (object, &ctr, print_preprocess_mapper, &preprocess_info);
+}
+
+static void decode_char_table_range (Lisp_Object range,
+ struct chartab_range *outrange);
+
+static int
+nsubst_structures_mapper (struct chartab_range * range, Lisp_Object table,
+ Lisp_Object value, void *extra_arg)
+{
+ Lisp_Object number_table
+ = ((nsubst_structures_info_t *) extra_arg)->number_table;
+ Lisp_Object new_ = ((nsubst_structures_info_t *) extra_arg)->new_;
+ Lisp_Object old = ((nsubst_structures_info_t *) extra_arg)->old;
+ Boolint test_not_unboundp
+ = ((nsubst_structures_info_t *) extra_arg)->test_not_unboundp;
+ struct chartab_range changed = { range->type, range->ch, range->charset,
+ range->row };
+
+ switch (range->type)
+ {
+ case CHARTAB_RANGE_ALL:
+ {
+ if (EQ (old, Qt) == test_not_unboundp)
+ {
+ decode_char_table_range (new_, &changed);
+
+ put_char_table (table, range, Qunbound);
+ put_char_table (table, &changed, value);
+ }
+ break;
+ }
+ case CHARTAB_RANGE_CHARSET:
+ {
+ if (EQ (old, range->charset) == test_not_unboundp)
+ {
+ CHECK_CHARSET (new_);
+ changed.charset = new_;
+
+ put_char_table (table, range, Qunbound);
+ put_char_table (table, &changed, value);
+ }
+ else assert (!HAS_OBJECT_METH_P (range->charset,
+ nsubst_structures_descend));
+ break;
+ }
+ case CHARTAB_RANGE_ROW:
+ {
+ if (EQ (old, make_int (range->row)) == test_not_unboundp)
+ {
+ CHECK_INT (new_);
+ changed.row = XINT (new_);
+
+ put_char_table (table, range, Qunbound);
+ put_char_table (table, &changed, value);
+ }
+ break;
+ }
+ case CHARTAB_RANGE_CHAR:
+ {
+ if (EQ (old, make_char (range->ch)) == test_not_unboundp)
+ {
+ CHECK_CHAR (new_);
+ changed.ch = XCHAR (new_);
+
+ put_char_table (table, range, Qunbound);
+ put_char_table (table, &changed, value);
+ }
+ break;
+ }
+ }
+
+ if (EQ (old, value) == test_not_unboundp)
+ {
+ put_char_table (table, &changed, new_);
+ }
+ else if (LRECORDP (value) &&
+ HAS_OBJECT_METH_P (value, nsubst_structures_descend))
+ {
+ nsubst_structures_descend (new_, old, value, number_table,
+ test_not_unboundp);
+ }
+
+ return 0;
+}
+
+static void
+char_table_nsubst_structures_descend (Lisp_Object new_, Lisp_Object old,
+ Lisp_Object object,
+ Lisp_Object number_table,
+ Boolint test_not_unboundp)
+{
+ struct chartab_range ctr = { CHARTAB_RANGE_ALL, 0, Qnil, 0 };
+ nsubst_structures_info_t nsubst_structures_info
+ = { number_table, new_, old, object, test_not_unboundp };
+
+ map_char_table (object, &ctr, nsubst_structures_mapper,
+ &nsubst_structures_info);
+}
+
#ifdef MULE
static Lisp_Object
@@ -1890,6 +2006,13 @@
void
+chartab_objects_create (void)
+{
+ OBJECT_HAS_METHOD (char_table, print_preprocess);
+ OBJECT_HAS_METHOD (char_table, nsubst_structures_descend);
+}
+
+void
syms_of_chartab (void)
{
INIT_LISP_OBJECT (char_table);
diff -r 493c487cbc3f src/elhash.c
--- a/src/elhash.c Wed Aug 10 16:50:37 2011 +0100
+++ b/src/elhash.c Thu Aug 11 17:01:22 2011 +0100
@@ -350,6 +350,89 @@
return Qnil;
}
+static int
+nsubst_structures_map_hash_table (Lisp_Object key, Lisp_Object value,
+ void *extra_arg)
+{
+ Lisp_Object number_table
+ = ((nsubst_structures_info_t *) extra_arg)->number_table;
+ Lisp_Object new_ = ((nsubst_structures_info_t *) extra_arg)->new_;
+ Lisp_Object old = ((nsubst_structures_info_t *) extra_arg)->old;
+ Lisp_Object hash_table
+ = ((nsubst_structures_info_t *) extra_arg)->current_object;
+ Boolint test_not_unboundp
+ = ((nsubst_structures_info_t *) extra_arg)->test_not_unboundp;
+
+ if (EQ (old, key) == test_not_unboundp)
+ {
+ Fremhash (key, hash_table);
+ Fputhash (new_, value, hash_table);
+ }
+ else if (LRECORDP (key) &&
+ HAS_OBJECT_METH_P (key, nsubst_structures_descend))
+ {
+ nsubst_structures_descend (new_, old, key, number_table,
+ test_not_unboundp);
+ }
+
+ if (EQ (old, value) == test_not_unboundp)
+ {
+ Fputhash (key, new_, hash_table);
+ }
+ else if (LRECORDP (value) &&
+ HAS_OBJECT_METH_P (value, nsubst_structures_descend))
+ {
+ nsubst_structures_descend (new_, old, value, number_table,
+ test_not_unboundp);
+ }
+
+ return 0;
+}
+
+static void
+hash_table_nsubst_structures_descend (Lisp_Object new_, Lisp_Object old,
+ Lisp_Object object,
+ Lisp_Object number_table,
+ Boolint test_not_unboundp)
+{
+ nsubst_structures_info_t nsubst_structures_info
+ = { number_table, new_, old, object, test_not_unboundp };
+
+ /* If we're happy with limiting nsubst_structures to use in the Lisp
+ reader, we don't have to worry about the hash table test here, because
+ the only point where NEW_ can be the test will be forms like so:
+ #%d=#:SOME-GENSYM, in which case OLD will most definitively not include
+ a hash table anywhere in its structure. */
+
+ elisp_maphash (nsubst_structures_map_hash_table, object,
+ &nsubst_structures_info);
+}
+
+static int
+print_preprocess_mapper (Lisp_Object key, Lisp_Object value, void *extra_arg)
+{
+ Lisp_Object print_number_table = ((preprocess_info_t *) extra_arg)->table;
+ Elemcount *seen_number_count = ((preprocess_info_t *) extra_arg)->count;
+
+ PRINT_PREPROCESS (key, print_number_table, seen_number_count);
+ PRINT_PREPROCESS (value, print_number_table, seen_number_count);
+
+ return 0;
+}
+
+static void
+hash_table_print_preprocess (Lisp_Object obj, Lisp_Object number_table,
+ Elemcount *seen_object_count)
+{
+ preprocess_info_t preprocess_info = { number_table,
+ seen_object_count };
+
+ print_preprocess (XHASH_TABLE_TEST (XHASH_TABLE (obj)->test)->name,
+ number_table, seen_object_count);
+
+ elisp_maphash_unsafe (print_preprocess_mapper, obj, &preprocess_info);
+}
+
/* Equality of hash tables. Two hash tables are equal when they are of
the same weakness and test function, they have the same number of
elements, and for each key in the hash table, the values are `equal'.
@@ -1277,7 +1360,7 @@
overhead -- profiling overhead was being recorded at up to 15% of the
total time. */
-void
+htentry *
inchash_eq (Lisp_Object key, Lisp_Object table, EMACS_INT offset)
{
Lisp_Hash_Table *ht = XHASH_TABLE (table);
@@ -1297,8 +1380,13 @@
probe->value = make_int (offset);
if (++ht->count >= ht->rehash_count)
- enlarge_hash_table (ht);
+ {
+ enlarge_hash_table (ht);
+ return NULL;
+ }
}
+
+ return probe;
}
DEFUN ("gethash", Fgethash, 2, 3, 0, /*
@@ -2241,6 +2329,8 @@
#ifdef MEMORY_USAGE_STATS
OBJECT_HAS_METHOD (hash_table, memory_usage);
#endif
+ OBJECT_HAS_METHOD (hash_table, print_preprocess);
+ OBJECT_HAS_METHOD (hash_table, nsubst_structures_descend);
}
void
diff -r 493c487cbc3f src/elhash.h
--- a/src/elhash.h Wed Aug 10 16:50:37 2011 +0100
+++ b/src/elhash.h Thu Aug 11 17:01:22 2011 +0100
@@ -128,7 +128,7 @@
void pdump_reorganize_hash_table (Lisp_Object);
-void inchash_eq (Lisp_Object key, Lisp_Object table, EMACS_INT offset);
+htentry *inchash_eq (Lisp_Object key, Lisp_Object table, EMACS_INT offset);
htentry *find_htentry (Lisp_Object key, const Lisp_Hash_Table *ht);
diff -r 493c487cbc3f src/emacs.c
--- a/src/emacs.c Wed Aug 10 16:50:37 2011 +0100
+++ b/src/emacs.c Thu Aug 11 17:01:22 2011 +0100
@@ -1757,7 +1757,9 @@
)
{
buffer_objects_create ();
+ bytecode_objects_create ();
casetab_objects_create ();
+ chartab_objects_create ();
extent_objects_create ();
face_objects_create ();
frame_objects_create ();
@@ -1767,6 +1769,7 @@
#ifdef MULE
mule_charset_objects_create ();
#endif
+ rangetab_objects_create ();
#ifdef HAVE_SCROLLBARS
scrollbar_objects_create ();
#endif
diff -r 493c487cbc3f src/fns.c
--- a/src/fns.c Wed Aug 10 16:50:37 2011 +0100
+++ b/src/fns.c Thu Aug 11 17:01:22 2011 +0100
@@ -59,6 +59,7 @@
Lisp_Object Qsome, Qevery, Qmaplist, Qmapl, Qmapcon, Qreduce, Qsubstitute;
Lisp_Object Q_start1, Q_start2, Q_end1, Q_end2, Q_if_, Q_if_not, Q_stable;
Lisp_Object Q_test_not, Q_count, Qnsubstitute, Qdelete_duplicates, Qmismatch;
+Lisp_Object Q_descend_structures;
Lisp_Object Qintersection, Qset_difference, Qnset_difference;
Lisp_Object Qnunion, Qnintersection, Qsubsetp, Qcar_less_than_car;
@@ -207,7 +208,7 @@
/* Various test functions for #'member*, #'assoc* and the other functions
that take both TEST and KEY arguments. */
-static Boolint
+Boolint
check_eq_nokey (Lisp_Object UNUSED (test), Lisp_Object UNUSED (key),
Lisp_Object item, Lisp_Object elt)
{
@@ -9303,14 +9304,32 @@
Any element of TREE which is `eql' to OLD is changed to NEW (via a call to
`setcar').
-See `member*' for the meaning of the keywords.
-
-arguments: (NEW OLD TREE &key (TEST #'eql) (KEY #'identity) TEST-NOT)
-*/
- (int nargs, Lisp_Object *args))
-{
- Lisp_Object result, alist = noseeum_cons (noseeum_cons (args[1], args[0]),
- Qnil);
+See `member*' for the meaning of the keywords. The keyword
+:descend-structures, not specified by Common Lisp, allows callers to specify
+that non-cons objects (vectors and range tables, among others) should also
+undergo substitution. Currently this implementation is incomplete.
+
+arguments: (NEW OLD TREE &key (TEST #'eql) (KEY #'identity) TEST-NOT
DESCEND-STRUCTURES)
+*/
+ (int nargs, Lisp_Object *args))
+{
+ Lisp_Object new_ = args[0], old = args[1], tree = args[2], result, alist;
+ Boolint test_not_unboundp = 1;
+ check_test_func_t check_test = NULL;
+
+ PARSE_KEYWORDS (Fnsubst, nargs, args, 6, (test, if_, test_not, if_not, key,
+ descend_structures), NULL);
+ if (!NILP (descend_structures))
+ {
+ check_test = get_check_test_function (old, &test, test_not, if_, if_not,
+ key, &test_not_unboundp);
+
+ return nsubst_structures (new_, old, tree, check_test, test_not_unboundp,
+ test, key);
+
+ }
+
+ alist = noseeum_cons (noseeum_cons (old, new_), Qnil);
args[1] = alist;
result = Fnsublis (nargs - 1, args + 1);
free_cons (XCAR (alist));
@@ -11707,6 +11726,7 @@
DEFKEYWORD (Q_test_not);
DEFKEYWORD (Q_count);
DEFKEYWORD (Q_stable);
+ DEFKEYWORD (Q_descend_structures);
DEFSYMBOL (Qyes_or_no_p);
diff -r 493c487cbc3f src/lisp.h
--- a/src/lisp.h Wed Aug 10 16:50:37 2011 +0100
+++ b/src/lisp.h Thu Aug 11 17:01:22 2011 +0100
@@ -5267,6 +5267,8 @@
EXFUN (Fsubseq, 3);
EXFUN (Fvalid_plist_p, 1);
+extern Boolint check_eq_nokey (Lisp_Object, Lisp_Object, Lisp_Object,
+ Lisp_Object);
extern Boolint check_lss_key_car (Lisp_Object, Lisp_Object, Lisp_Object,
Lisp_Object);
extern Boolint check_string_lessp_nokey (Lisp_Object, Lisp_Object,
@@ -5275,6 +5277,20 @@
typedef Boolint (*check_test_func_t) (Lisp_Object test, Lisp_Object key,
Lisp_Object item, Lisp_Object elt);
+typedef struct
+{
+ Lisp_Object number_table;
+ Lisp_Object new_;
+ Lisp_Object old;
+ Lisp_Object current_object;
+ Boolint test_not_unboundp;
+} nsubst_structures_info_t;
+
+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 test, Lisp_Object key);
+
Lisp_Object list_merge (Lisp_Object org_l1, Lisp_Object org_l2,
check_test_func_t check_merge,
Lisp_Object predicate, Lisp_Object key_func);
@@ -5617,6 +5633,31 @@
DECLARE_DOESNT_RETURN (printing_unreadable_lisp_object (Lisp_Object obj,
const Ibyte *name));
+#define PRINT_PREPROCESS(obj, print_number_table, seen_object_count) \
+ do if (LRECORDP (obj) \
+ && XRECORD_LHEADER_IMPLEMENTATION (obj)->print_preprocess) \
+ { \
+ print_preprocess (obj, print_number_table, seen_object_count); \
+ } while (0)
+
+typedef struct { Lisp_Object table; Elemcount *count; } preprocess_info_t;
+
+void print_preprocess (Lisp_Object obj, Lisp_Object print_number_table,
+ Elemcount *seen_object_count);
+
+/* These is in print.c because they use the print_preprocess
+ infrastructure. */
+Lisp_Object nsubst_structures_descend (Lisp_Object new_, Lisp_Object old,
+ Lisp_Object object,
+ Lisp_Object number_table,
+ Boolint test_not_unboundp);
+
+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 test, Lisp_Object key);
+
extern Lisp_Object Qexternal_debugging_output;
extern Lisp_Object Qprint_length;
extern Lisp_Object Qprint_string_length;
@@ -5746,6 +5787,18 @@
extern MODULE_API Lisp_Object Qt, Qunbound;
extern Lisp_Object Vobarray;
+DECLARE_INLINE_HEADER (
+int
+uninternedp (Lisp_Object object)
+)
+{
+ Lisp_Object name = symbol_name (XSYMBOL (object)),
+ lookedup = oblookup (Vobarray, XSTRING_DATA (name), XSTRING_LENGTH (name));
+ return !EQ (object, lookedup);
+}
+
+#define UNINTERNEDP(obj) uninternedp (obj)
+
/* Defined in syntax.c */
Charbpos scan_words (struct buffer *, Charbpos, int);
EXFUN (Fchar_syntax, 2);
diff -r 493c487cbc3f src/lread.c
--- a/src/lread.c Wed Aug 10 16:50:37 2011 +0100
+++ b/src/lread.c Thu Aug 11 17:01:22 2011 +0100
@@ -2715,16 +2715,32 @@
{
/* #n=object returns object, but associates it with
n for #n#. */
- Lisp_Object obj;
if (CONSP (found))
- return Fsignal (Qinvalid_read_syntax,
- list2 (build_msg_string
- ("Multiply defined symbol label"),
- make_int (n)));
- obj = read0 (readcharfun);
- Vread_objects = Fcons (Fcons (make_int (n), obj),
- Vread_objects);
- return obj;
+ {
+ return Fsignal (Qinvalid_read_syntax,
+ list2 (build_msg_string
+ ("Multiply defined object
label"),
+ make_int (n)));
+ }
+ else
+ {
+ Lisp_Object object;
+
+ found = Fcons (make_int (n), Qnil);
+ /* Make FOUND a placeholder for the object that will
+ be read. (We've just consed it, and it's not
+ visible from Lisp, so there's no possibility of
+ confusing it with something else in the read
+ structure.) */
+ XSETCDR (found, found);
+ Vread_objects = Fcons (found, Vread_objects);
+ object = read0 (readcharfun);
+ XSETCDR (found, object);
+
+ nsubst_structures (object, XCDR (found), object,
+ check_eq_nokey, 1, Qeq, Qnil);
+ return object;
+ }
}
else if (c == '#')
{
diff -r 493c487cbc3f src/lrecord.h
--- a/src/lrecord.h Wed Aug 10 16:50:37 2011 +0100
+++ b/src/lrecord.h Thu Aug 11 17:01:22 2011 +0100
@@ -540,6 +540,14 @@
be NULL. */
void (*disksave) (Lisp_Object);
+ void (*print_preprocess) (Lisp_Object obj, Lisp_Object number_table,
+ Elemcount *seen_object_count);
+
+ void (*nsubst_structures_descend) (Lisp_Object new_, Lisp_Object old,
+ Lisp_Object object,
+ Lisp_Object number_table,
+ Boolint test_not_unboundp);
+
#ifdef MEMORY_USAGE_STATS
/* Return memory-usage information about the object in question, stored
into STATS.
diff -r 493c487cbc3f src/print.c
--- a/src/print.c Wed Aug 10 16:50:37 2011 +0100
+++ b/src/print.c Thu Aug 11 17:01:22 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. */
+Boolint print_escape_newlines;
-int print_escape_newlines;
-int print_readably;
+Boolint 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;
+/* 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,320 @@
"#<SERIOUS XEMACS BUG: %s Save your buffers immediately "
"and please report this bug>", buf);
}
+
+static 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) && !UNINTERNEDP (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 +2068,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 +2276,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) && UNINTERNEDP (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 +2340,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 +2384,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 (UNINTERNEDP (obj))
+ {
+ write_ascstring (printcharfun, "#:");
+ }
}
/* Does it look like an integer or a float? */
@@ -2690,7 +3072,7 @@
/* #### 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 +3085,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;
+ print_gensym = 0;
- 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;
+ 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
diff -r 493c487cbc3f src/rangetab.c
--- a/src/rangetab.c Wed Aug 10 16:50:37 2011 +0100
+++ b/src/rangetab.c Thu Aug 11 17:01:22 2011 +0100
@@ -134,6 +134,52 @@
write_fmt_string (printcharfun, " 0x%x>", LISP_OBJECT_UID (obj));
}
+static void
+range_table_print_preprocess (Lisp_Object object,
+ Lisp_Object print_number_table,
+ Elemcount *seen_object_count)
+{
+ Lisp_Range_Table *rt = XRANGE_TABLE (object);
+ Elemcount ii;
+
+ for (ii = 0; ii < gap_array_length (rt->entries); ii++)
+ {
+ struct range_table_entry *entry
+ = gap_array_atp (rt->entries, ii, struct range_table_entry);
+ PRINT_PREPROCESS (entry->val, print_number_table, seen_object_count);
+ }
+}
+
+static void
+range_table_nsubst_structures_descend (Lisp_Object new_, Lisp_Object old,
+ Lisp_Object object,
+ Lisp_Object number_table,
+ Boolint test_not_unboundp)
+{
+ Lisp_Range_Table *rt = XRANGE_TABLE (object);
+ Elemcount ii;
+
+ /* We don't have to worry about the range table START and END values if
+ we're limiting nsubst_descend to the Lisp reader; it's a similar case
+ to the hash table test. */
+ for (ii = 0; ii < gap_array_length (rt->entries); ii++)
+ {
+ struct range_table_entry *entry
+ = gap_array_atp (rt->entries, ii, struct range_table_entry);
+
+ if (EQ (old, entry->val) == test_not_unboundp)
+ {
+ entry->val = new_;
+ }
+ else if (LRECORDP (entry->val) &&
+ HAS_OBJECT_METH_P (entry->val, nsubst_structures_descend))
+ {
+ nsubst_structures_descend (new_, old, entry->val, number_table,
+ test_not_unboundp);
+ }
+ }
+}
+
static int
range_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth, int foldcase)
{
@@ -1033,6 +1079,12 @@
/************************************************************************/
/* Initialization */
/************************************************************************/
+void
+rangetab_objects_create (void)
+{
+ OBJECT_HAS_METHOD (range_table, print_preprocess);
+ OBJECT_HAS_METHOD (range_table, nsubst_structures_descend);
+}
void
syms_of_rangetab (void)
diff -r 493c487cbc3f src/symbols.c
--- a/src/symbols.c Wed Aug 10 16:50:37 2011 +0100
+++ b/src/symbols.c Thu Aug 11 17:01:22 2011 +0100
@@ -139,6 +139,16 @@
return external_remprop (&XSYMBOL (symbol)->plist, property, 0, ERROR_ME);
}
+static void
+symbol_print_preprocess (Lisp_Object UNUSED (symbol),
+ Lisp_Object UNUSED (print_number_table),
+ Elemcount * UNUSED (seen_object_count))
+{
+ /* This method is empty; symbols are handled specially in
+ print_preprocess, because print_preprocess_inchash_eq() is conditional
+ for them, rather than a given. */
+}
+
DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT ("symbol", symbol,
mark_symbol, print_symbol,
0, 0, 0, symbol_description,
@@ -3536,6 +3546,7 @@
OBJECT_HAS_METHOD (symbol, getprop);
OBJECT_HAS_METHOD (symbol, putprop);
OBJECT_HAS_METHOD (symbol, remprop);
+ OBJECT_HAS_METHOD (symbol, print_preprocess);
OBJECT_HAS_NAMED_METHOD (symbol, plist, Fsymbol_plist);
OBJECT_HAS_NAMED_METHOD (symbol, setplist, Fsetplist);
}
diff -r 493c487cbc3f src/symsinit.h
--- a/src/symsinit.h Wed Aug 10 16:50:37 2011 +0100
+++ b/src/symsinit.h Thu Aug 11 17:01:22 2011 +0100
@@ -208,7 +208,9 @@
Dump time and post-pdump-load-time. */
void buffer_objects_create (void);
+void bytecode_objects_create (void);
void casetab_objects_create (void);
+void chartab_objects_create (void);
void extent_objects_create (void);
void face_objects_create (void);
void frame_objects_create (void);
@@ -216,6 +218,7 @@
void hash_table_objects_create (void);
void lstream_objects_create (void);
void mule_charset_objects_create (void);
+void rangetab_objects_create (void);
void scrollbar_objects_create (void);
void specifier_objects_create (void);
void ui_gtk_objects_create (void);
--
‘Iodine deficiency was endemic in parts of the UK until, through what has been
described as “an unplanned and accidental public health triumph”, iodine was
added to cattle feed to improve milk production in the 1930s.’
(EN Pearce, Lancet, June 2011)
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches