# HG changeset patch # User Aidan Kehoe # Date 1315162295 -3600 # Node ID 58b38d5b32d02df4fa6700143e0fc5a6c659df11 # Parent f3ab0c29c2468a3e4d96dd5d333ea3e1f04bf774 Implement print-circle, allowing recursive and circular structures to be read. src/ChangeLog addition: 2011-09-04 Aidan Kehoe * 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 * 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 * 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. diff -r f3ab0c29c246 -r 58b38d5b32d0 lisp/ChangeLog --- a/lisp/ChangeLog Sun Aug 28 10:34:54 2011 +0100 +++ b/lisp/ChangeLog Sun Sep 04 19:51:35 2011 +0100 @@ -1,3 +1,13 @@ +2011-09-04 Aidan Kehoe + + * 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. + 2011-08-24 Aidan Kehoe * process.el (shell-command-on-region): diff -r f3ab0c29c246 -r 58b38d5b32d0 lisp/bytecomp.el --- a/lisp/bytecomp.el Sun Aug 28 10:34:54 2011 +0100 +++ b/lisp/bytecomp.el Sun Sep 04 19:51:35 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 f3ab0c29c246 -r 58b38d5b32d0 lisp/lisp.el --- a/lisp/lisp.el Sun Aug 28 10:34:54 2011 +0100 +++ b/lisp/lisp.el Sun Sep 04 19:51:35 2011 +0100 @@ -69,7 +69,8 @@ (let* ((diff (- (point) (point-min))) (subject (buffer-substring (- (point) (min diff 3)) (1+ (point)))) - (matched (string-match "#s(\\|#r[uU]\\{0,1\\}\"" subject))) + (matched (string-match "#[0-9]+=\\|#s(\\|#r[uU]\\{0,1\\}\"" + subject))) (if matched (goto-char (1+ (- (point) (- (length subject) matched)))))))) diff -r f3ab0c29c246 -r 58b38d5b32d0 src/ChangeLog --- a/src/ChangeLog Sun Aug 28 10:34:54 2011 +0100 +++ b/src/ChangeLog Sun Sep 04 19:51:35 2011 +0100 @@ -1,3 +1,92 @@ +2011-09-04 Aidan Kehoe + + * 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. + 2011-08-28 Aidan Kehoe * event-Xt.c (x_to_emacs_keysym): diff -r f3ab0c29c246 -r 58b38d5b32d0 src/alloc.c --- a/src/alloc.c Sun Aug 28 10:34:54 2011 +0100 +++ b/src/alloc.c Sun Sep 04 19:51:35 2011 +0100 @@ -1266,24 +1266,26 @@ #endif /* (not) NEW_GC */ #ifdef NEW_GC -#define ALLOC_FROB_BLOCK_LISP_OBJECT(type, lisp_type, var, lrec_ptr)\ +#define ALLOC_FROB_BLOCK_LISP_OBJECT_1(type, lisp_type, var, lrec_ptr, \ + lheader) \ do { \ - (var) = (lisp_type *) XPNTR (ALLOC_NORMAL_LISP_OBJECT (type)); \ + (var) = (lisp_type *) XPNTR (ALLOC_NORMAL_LISP_OBJECT (type)); \ } while (0) -#define NOSEEUM_ALLOC_FROB_BLOCK_LISP_OBJECT(type, lisp_type, var, \ - lrec_ptr) \ +#define NOSEEUM_ALLOC_FROB_BLOCK_LISP_OBJECT_1(type, lisp_type, var, \ + lrec_ptr, lheader) \ do { \ (var) = (lisp_type *) XPNTR (noseeum_alloc_lrecord (lrec_ptr)); \ } while (0) #else /* not NEW_GC */ -#define ALLOC_FROB_BLOCK_LISP_OBJECT(type, lisp_type, var, lrec_ptr) \ +#define ALLOC_FROB_BLOCK_LISP_OBJECT_1(type, lisp_type, var, lrec_ptr, \ + lheader) \ do \ { \ ALLOCATE_FIXED_TYPE (type, lisp_type, var); \ set_lheader_implementation (&(var)->lheader, lrec_ptr); \ } while (0) -#define NOSEEUM_ALLOC_FROB_BLOCK_LISP_OBJECT(type, lisp_type, var, \ - lrec_ptr) \ +#define NOSEEUM_ALLOC_FROB_BLOCK_LISP_OBJECT_1(type, lisp_type, var, \ + lrec_ptr, lheader) \ do \ { \ NOSEEUM_ALLOCATE_FIXED_TYPE (type, lisp_type, var); \ @@ -1291,7 +1293,12 @@ } while (0) #endif /* not NEW_GC */ - +#define ALLOC_FROB_BLOCK_LISP_OBJECT(type, lisp_type, var, lrec_ptr) \ + ALLOC_FROB_BLOCK_LISP_OBJECT_1(type, lisp_type, var, lrec_ptr, lheader) + +#define NOSEEUM_ALLOC_FROB_BLOCK_LISP_OBJECT(type, lisp_type, var, lrec_ptr) \ + NOSEEUM_ALLOC_FROB_BLOCK_LISP_OBJECT_1(type, lisp_type, var, lrec_ptr, \ + lheader) /************************************************************************/ /* Cons allocation */ @@ -1326,6 +1333,66 @@ return 0; } +extern Elemcount +print_preprocess_inchash_eq (Lisp_Object obj, Lisp_Object table, + Elemcount *seen_object_count); + +static void +cons_print_preprocess (Lisp_Object object, Lisp_Object print_number_table, + Elemcount *seen_object_count) +{ + /* Special-case conses, don't recurse down the cdr if the cdr is a cons. */ + for (;;) + { + PRINT_PREPROCESS (XCAR (object), print_number_table, seen_object_count); + object = XCDR (object); + + if (!CONSP (object)) + { + break; + } + + if (print_preprocess_inchash_eq (object, print_number_table, + seen_object_count) > 1) + { + return; + } + } + + PRINT_PREPROCESS (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) +{ + /* No need for a special case, nsubst_structures_descend is called much + less frequently than is print_preprocess. */ + 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)) == test_not_unboundp) + { + 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 +1780,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) }, @@ -2115,7 +2220,11 @@ CHECK_STRING (name); - ALLOC_FROB_BLOCK_LISP_OBJECT (symbol, Lisp_Symbol, p, &lrecord_symbol); + ALLOC_FROB_BLOCK_LISP_OBJECT_1 (symbol, Lisp_Symbol, p, &lrecord_symbol, + u.lheader); + p->u.v.package_count = 0; + p->u.v.first_package_id = 0; + p->name = name; p->plist = Qnil; p->value = Qunbound; @@ -4789,10 +4898,10 @@ static void sweep_symbols (void) { -#define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&((ptr)->lheader)) +#define UNMARK_symbol(ptr) UNMARK_RECORD_HEADER (&(((ptr)->u.lheader))) #define ADDITIONAL_FREE_symbol(ptr) - SWEEP_FIXED_TYPE_BLOCK (symbol, Lisp_Symbol); + SWEEP_FIXED_TYPE_BLOCK_1 (symbol, Lisp_Symbol, u.lheader); } static void @@ -5631,6 +5740,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 f3ab0c29c246 -r 58b38d5b32d0 src/bytecode.c --- a/src/bytecode.c Sun Aug 28 10:34:54 2011 +0100 +++ b/src/bytecode.c Sun Sep 04 19:51:35 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 f3ab0c29c246 -r 58b38d5b32d0 src/chartab.c --- a/src/chartab.c Sun Aug 28 10:34:54 2011 +0100 +++ b/src/chartab.c Sun Sep 04 19:51:35 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 f3ab0c29c246 -r 58b38d5b32d0 src/elhash.c --- a/src/elhash.c Sun Aug 28 10:34:54 2011 +0100 +++ b/src/elhash.c Sun Sep 04 19:51:35 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 f3ab0c29c246 -r 58b38d5b32d0 src/elhash.h --- a/src/elhash.h Sun Aug 28 10:34:54 2011 +0100 +++ b/src/elhash.h Sun Sep 04 19:51:35 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 f3ab0c29c246 -r 58b38d5b32d0 src/emacs.c --- a/src/emacs.c Sun Aug 28 10:34:54 2011 +0100 +++ b/src/emacs.c Sun Sep 04 19:51:35 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 f3ab0c29c246 -r 58b38d5b32d0 src/fns.c --- a/src/fns.c Sun Aug 28 10:34:54 2011 +0100 +++ b/src/fns.c Sun Sep 04 19:51:35 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) +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. + +arguments: (NEW OLD TREE &key (TEST #'eql) (KEY #'identity) TEST-NOT DESCEND-STRUCTURES) */ (int nargs, Lisp_Object *args)) { - Lisp_Object result, alist = noseeum_cons (noseeum_cons (args[1], args[0]), - Qnil); + 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 f3ab0c29c246 -r 58b38d5b32d0 src/lisp.h --- a/src/lisp.h Sun Aug 28 10:34:54 2011 +0100 +++ b/src/lisp.h Sun Sep 04 19:51:35 2011 +0100 @@ -2816,7 +2816,37 @@ typedef struct Lisp_Symbol Lisp_Symbol; struct Lisp_Symbol { - FROB_BLOCK_LISP_OBJECT_HEADER lheader; + union + { + FROB_BLOCK_LISP_OBJECT_HEADER lheader; + struct + { + /* Everything before package_count must agree exactly with struct + lrecord_header. */ + unsigned int type :8; +#ifdef NEW_GC + unsigned int lisp_readonly :1; + unsigned int free :1; + /* Number of packages this symbol is interned in, zero, one, or many. + Packages aren't yet implemented, but we have a design in Common + Lisp's. */ + unsigned int package_count :2; + /* ID of the first package this symbol was interned in. Zero is + uninterned, one is obarray. */ + unsigned int first_package_id :20; +#else /* not NEW_GC */ + unsigned int mark :1; + unsigned int c_readonly :1; + unsigned int lisp_readonly :1; + /* Number of packages this symbol is interned in, zero, one, or many. */ + unsigned int package_count :2; + /* ID of the first package this symbol was interned in. Zero is + uninterned, one is obarray. */ + unsigned int first_package_id :19; +#endif /* not NEW_GC */ + } v; + } u; + /* next symbol in this obarray bucket */ Lisp_Symbol *next; Lisp_Object name; @@ -2825,11 +2855,12 @@ Lisp_Object plist; }; -#define SYMBOL_IS_KEYWORD(sym) \ - ((string_byte (symbol_name (XSYMBOL (sym)), 0) == ':') \ - && EQ (sym, oblookup (Vobarray, \ - XSTRING_DATA (symbol_name (XSYMBOL (sym))), \ - XSTRING_LENGTH (symbol_name (XSYMBOL (sym)))))) +#define IN_OBARRAY(symbol) ((XSYMBOL (symbol)->u.v.first_package_id) == 1) + +#define SYMBOL_IS_KEYWORD(sym) (IN_OBARRAY (sym) && \ + (string_byte (symbol_name (XSYMBOL (sym)), \ + 0) == ':')) + #define KEYWORDP(obj) (SYMBOLP (obj) && SYMBOL_IS_KEYWORD (obj)) DECLARE_MODULE_API_LISP_OBJECT (symbol, Lisp_Symbol); @@ -2852,6 +2883,7 @@ #define XSYMBOL_PLIST(s) (XSYMBOL (s)->plist) + /*------------------------------- subr ---------------------------------*/ /* A function that takes no arguments and returns a Lisp_Object. @@ -5267,6 +5299,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 +5309,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 +5665,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; diff -r f3ab0c29c246 -r 58b38d5b32d0 src/lread.c --- a/src/lread.c Sun Aug 28 10:34:54 2011 +0100 +++ b/src/lread.c Sun Sep 04 19:51:35 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, found, object, check_eq_nokey, + 1, Qeq, Qnil); + return object; + } } else if (c == '#') { diff -r f3ab0c29c246 -r 58b38d5b32d0 src/lrecord.h --- a/src/lrecord.h Sun Aug 28 10:34:54 2011 +0100 +++ b/src/lrecord.h Sun Sep 04 19:51:35 2011 +0100 @@ -511,6 +511,19 @@ unsigned int frob_block_p :1; #endif /* not NEW_GC */ + /* The next two methods are for objects that may be recursive; + print_preprocess descends OBJ, adding any encountered subobjects to + NUMBER_TABLE if it's not already there. This is used by #'print when + print-circle or relatedly print-gensym are non-nil. */ + 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); + /**********************************************************************/ /* Remaining stuff is not assignable statically using DEFINE_*_LISP_OBJECT, but must be assigned with OBJECT_HAS_METHOD, @@ -1432,6 +1445,29 @@ size, sizer, lrecord_type_##c_name, frob_block_p } #endif /* not NEW_GC */ +#ifdef NEW_GC +#define MAKE_RECURSIVE_LISP_OBJECT(name,c_name,dumpable,marker,printer, \ + nuker,equal,hash,desc,size,sizer, \ + frob_block_p,structtype, \ + print_preprocess, \ + nsubst_structures_descend) \ +DECLARE_ERROR_CHECK_TYPES(c_name, structtype) \ +struct lrecord_implementation lrecord_##c_name = \ + { name, dumpable, marker, printer, nuker, equal, hash, desc, \ + size, sizer, lrecord_type_##c_name, print_preprocess, \ + nsubst_structures_descend } +#else /* not NEW_GC */ +#define MAKE_RECURSIVE_LISP_OBJECT(name,c_name,dumpable,marker,printer, \ + nuker,equal,hash,desc,size,sizer, \ + frob_block_p,structtype, \ + print_preprocess, \ + nsubst_structures_descend) \ +DECLARE_ERROR_CHECK_TYPES(c_name, structtype) \ +struct lrecord_implementation lrecord_##c_name = \ + { name, dumpable, marker, printer, nuker, equal, hash, desc, \ + size, sizer, lrecord_type_##c_name, frob_block_p, print_preprocess, \ + nsubst_structures_descend } +#endif /* not NEW_GC */ /********* The module dumpable versions *********** */ diff -r f3ab0c29c246 -r 58b38d5b32d0 src/print.c --- 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 /* 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, "... "); - 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, "... "); + 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 @@ "#", 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 diff -r f3ab0c29c246 -r 58b38d5b32d0 src/rangetab.c --- a/src/rangetab.c Sun Aug 28 10:34:54 2011 +0100 +++ b/src/rangetab.c Sun Sep 04 19:51:35 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 f3ab0c29c246 -r 58b38d5b32d0 src/symbols.c --- a/src/symbols.c Sun Aug 28 10:34:54 2011 +0100 +++ b/src/symbols.c Sun Sep 04 19:51:35 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, @@ -250,6 +260,9 @@ XSYMBOL_NEXT (symbol) = 0; *ptr = object; + XSYMBOL (object)->u.v.package_count = 1; + XSYMBOL (object)->u.v.first_package_id = (EQ (obarray, Vobarray)) ? 1 : 2; + if (string_byte (XSYMBOL_NAME (symbol), 0) == ':' && EQ (obarray, Vobarray)) { /* The LISP way is to put keywords in their own package, but we @@ -329,10 +342,19 @@ if (EQ (XVECTOR_DATA (obarray)[hash], tem)) { + unsigned int package_count = XSYMBOL (tem)->u.v.package_count; if (XSYMBOL (tem)->next) XVECTOR_DATA (obarray)[hash] = wrap_symbol (XSYMBOL (tem)->next); else XVECTOR_DATA (obarray)[hash] = Qzero; + if (package_count > 0) + { + if (1 == package_count) + { + XSYMBOL (tem)->u.v.first_package_id = 0; + } + XSYMBOL (tem)->u.v.package_count = package_count - 1; + } } else { @@ -345,7 +367,17 @@ following = wrap_symbol (XSYMBOL (tail)->next); if (EQ (following, tem)) { + unsigned int package_count = XSYMBOL (tem)->u.v.package_count; XSYMBOL (tail)->next = XSYMBOL (following)->next; + + if (package_count > 0) + { + if (1 == package_count) + { + XSYMBOL (tem)->u.v.first_package_id = 0; + } + XSYMBOL (tem)->u.v.package_count = package_count - 1; + } break; } } @@ -3536,6 +3568,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); } @@ -3557,6 +3590,8 @@ XSTRING_PLIST (XSYMBOL (Qnil)->name) = Qnil; XSYMBOL (Qnil)->value = Qnil; /* Nihil ex nihilo */ XSYMBOL (Qnil)->plist = Qnil; + XSYMBOL (Qnil)->u.v.package_count = 1; + XSYMBOL (Qnil)->u.v.first_package_id = 1; Vobarray = make_vector (OBARRAY_SIZE, Qzero); initial_obarray = Vobarray; diff -r f3ab0c29c246 -r 58b38d5b32d0 src/symsinit.h --- a/src/symsinit.h Sun Aug 28 10:34:54 2011 +0100 +++ b/src/symsinit.h Sun Sep 04 19:51:35 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); diff -r f3ab0c29c246 -r 58b38d5b32d0 tests/ChangeLog --- a/tests/ChangeLog Sun Aug 28 10:34:54 2011 +0100 +++ b/tests/ChangeLog Sun Sep 04 19:51:35 2011 +0100 @@ -1,3 +1,12 @@ +2011-09-04 Aidan Kehoe + + * 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. + 2011-08-24 Aidan Kehoe * automated/lisp-tests.el: diff -r f3ab0c29c246 -r 58b38d5b32d0 tests/automated/lisp-reader-tests.el --- a/tests/automated/lisp-reader-tests.el Sun Aug 28 10:34:54 2011 +0100 +++ b/tests/automated/lisp-reader-tests.el Sun Sep 04 19:51:35 2011 +0100 @@ -87,3 +87,66 @@ (read (format "+%d" (1- most-positive-fixnum)))) "checking leading + is handled properly if reading a fixnum")) +;; Test print-circle. +(let ((cons '#1=(1 2 3 4 5 6 . #1#)) + (vector #2=[1 2 3 4 5 6 #2#]) + (compiled-function #3=#[(argument) "\xc2\x09\x08\"\x87" + [pi argument #3#] 3]) + (char-table #4=#s(char-table :type generic :data (?\u0080 #4#))) + (hash-table #5=#s(hash-table :test eql :data (a b c #5# e f))) + (range-table #6=#s(range-table :type start-closed-end-open + :data ((#x00 #xff) hello + (#x100 #x1ff) #6# + (#x200 #x2ff) everyone))) + (print-readably t) + (print-circle t) + deserialized-cons deserialized-vector deserialized-compiled-function + deserialized-char-table deserialized-hash-table deserialized-range-table) + (Assert (eq (nthcdr 6 cons) cons) + "checking basic recursive cons read properly") + (Assert (eq vector (aref vector (1- (length vector)))) + "checking basic recursive vector read properly") + (Assert (eq compiled-function + (find-if #'compiled-function-p + (compiled-function-constants compiled-function))) + "checking basic recursive compiled-function read properly") + (Check-Error wrong-number-of-arguments (funcall compiled-function 3)) + (Assert (eq char-table (get-char-table ?\u0080 char-table)) + "checking basic recursive char table read properly") + (Assert (eq hash-table (gethash 'c hash-table)) + "checking basic recursive hash table read properly") + (Assert (eq range-table (get-range-table #x180 range-table)) + "checking basic recursive range table read properly") + (setf (gethash 'g hash-table) cons + (car cons) hash-table + deserialized-hash-table (read (prin1-to-string hash-table))) + (Assert (not (eq deserialized-hash-table hash-table)) + "checking printing and reading hash-table creates a new object") + (Assert (eq deserialized-hash-table (gethash 'c deserialized-hash-table)) + "checking the lisp reader handles deserialized hash-table identity") + (Assert (eq deserialized-hash-table + (car (gethash 'g deserialized-hash-table))) + "checking the reader handles deserialization identity, hash-table") + (setf (get-char-table ?a char-table) cons + (car cons) char-table + deserialized-char-table (read (prin1-to-string char-table))) + (Assert (not (eq deserialized-char-table char-table)) + "checking printing and reading creates a new object") + (Assert (eq deserialized-char-table + (get-char-table ?\u0080 deserialized-char-table)) + "checking the lisp reader handles deserialization identity") + (Assert (eq deserialized-char-table + (car (get-char-table ?a deserialized-char-table))) + "checking the lisp reader handles deserialization identity, mixed") + (put-range-table #x1000 #x1010 cons range-table) + (setf (car cons) range-table + deserialized-range-table (read (prin1-to-string range-table))) + (Assert (not (eq deserialized-range-table range-table)) + "checking printing and reading creates a new object") + (Assert (eq deserialized-range-table + (get-range-table #x101 deserialized-range-table)) + "checking the lisp reader handles deserialization identity") + (Assert (eq deserialized-range-table + (car (get-range-table #x1001 deserialized-range-table))) + "checking the lisp reader handles deserialization identity, mixed")) + diff -r f3ab0c29c246 -r 58b38d5b32d0 tests/automated/lisp-tests.el --- a/tests/automated/lisp-tests.el Sun Aug 28 10:34:54 2011 +0100 +++ b/tests/automated/lisp-tests.el Sun Sep 04 19:51:35 2011 +0100 @@ -1480,6 +1480,7 @@ #5=#:G32970 #6=#:G32972])) (print-readably t) (print-gensym t) + (print-continuous-numbering t) (printed-with-uninterned (prin1-to-string literal-with-uninterned)) (awkward-regexp "#1=#") (first-match-start (string-match awkward-regexp diff -r f3ab0c29c246 -r 58b38d5b32d0 tests/automated/symbol-tests.el --- a/tests/automated/symbol-tests.el Sun Aug 28 10:34:54 2011 +0100 +++ b/tests/automated/symbol-tests.el Sun Sep 04 19:51:35 2011 +0100 @@ -143,6 +143,7 @@ (printed-list (prin1-to-string list))) (Assert (equal printed-list "(foo foo bar bar foo bar)"))) (let* ((print-gensym t) + (print-continuous-numbering t) (printed-list (prin1-to-string list))) (Assert (equal printed-list "(#1=#:foo #1# #2=#:bar #2# #1# #2#)"))))