Mercurial > hg > xemacs-beta
diff src/elhash.c @ 5560:58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
src/ChangeLog addition:
2011-09-04 Aidan Kehoe <kehoea@parhasard.net>
* alloc.c:
* alloc.c (ALLOC_FROB_BLOCK_LISP_OBJECT_1):
* alloc.c (ALLOC_FROB_BLOCK_LISP_OBJECT):
* alloc.c (cons_print_preprocess):
* alloc.c (vector_print_preprocess):
* alloc.c (vector_nsubst_structures_descend):
* alloc.c (Fmake_symbol):
* alloc.c (UNMARK_symbol):
* alloc.c (sweep_symbols):
* alloc.c (reinit_alloc_objects_early):
* alloc.c (reinit_alloc_early):
* bytecode.c:
* bytecode.c (compiled_function_print_preprocess):
* bytecode.c (compiled_function_nsubst_structures_descend):
* bytecode.c (set_compiled_function_arglist):
* bytecode.c (set_compiled_function_interactive):
* bytecode.c (bytecode_objects_create):
* chartab.c:
* chartab.c (print_preprocess_mapper):
* chartab.c (nsubst_structures_mapper):
* chartab.c (char_table_nsubst_structures_descend):
* chartab.c (chartab_objects_create):
* elhash.c:
* elhash.c (nsubst_structures_map_hash_table):
* elhash.c (hash_table_nsubst_structures_descend):
* elhash.c (print_preprocess_mapper):
* elhash.c (hash_table_print_preprocess):
* elhash.c (inchash_eq):
* elhash.c (hash_table_objects_create):
* elhash.c (syms_of_elhash):
* elhash.h:
* emacs.c (main_1):
* fns.c:
* fns.c (check_eq_nokey):
* fns.c (Fnsubst):
* fns.c (syms_of_fns):
* lisp.h:
* lisp.h (struct Lisp_Symbol):
* lisp.h (IN_OBARRAY):
* lisp.h (struct):
* lisp.h (PRINT_PREPROCESS):
* lread.c (read1):
* lrecord.h:
* lrecord.h (struct lrecord_implementation):
* lrecord.h (DEFINE_DUMPABLE_MODULE_LISP_OBJECT):
* print.c:
* print.c (PRINT_CIRCLE_LIMIT):
* print.c (print_continuous_numbering_changed):
* print.c (print_prepare):
* print.c (print_finish):
* print.c (Fprin1_to_string):
* print.c (print_cons):
* print.c (print_preprocess_inchash_eq):
* print.c (print_preprocess):
* print.c (print_sort_get_numbers):
* print.c (print_sort_compare_ordinals):
* print.c (print_gensym_or_circle):
* print.c (nsubst_structures_descend):
* print.c (nsubst_structures):
* print.c (print_internal):
* print.c (print_symbol):
* print.c (vars_of_print):
* rangetab.c:
* rangetab.c (range_table_print_preprocess):
* rangetab.c (range_table_nsubst_structures_descend):
* rangetab.c (rangetab_objects_create):
* rangetab.c (syms_of_rangetab):
* symbols.c:
* symbols.c (symbol_print_preprocess):
* symbols.c (Fintern):
* symbols.c (Funintern):
* symbols.c (reinit_symbol_objects_early):
* symbols.c (init_symbols_once_early):
* symsinit.h:
Implement print-circle, printing circular structures in a readable
fashion, and treating them appropriately on read. This is by means
of two new object methods, print_preprocess (detecting
circularities), and nsubst_structures_descend (replacing
placeholders with the read objects).
Expose the substitution to Lisp via #'nsubst and its new
:descend-structures keyword.
Store information as to whether symbols are interned in obarray or
not in their header, making checking for keywords and uninterned
symbols (and thus printing) cheaper.
Default print_gensym to t, as Common Lisp does, and as a
more-than-decade old comment suggests.
lisp/ChangeLog addition:
2011-09-04 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el (byte-compile-output-file-form):
* bytecomp.el (byte-compile-output-docform):
Bind print-circle, print-continuous-numbering in these functions,
now those variables are available.
* lisp.el (forward-sexp):
* lisp.el (backward-sexp):
Recognise leading #N= as being part of an expression.
tests/ChangeLog addition:
2011-09-04 Aidan Kehoe <kehoea@parhasard.net>
* automated/lisp-reader-tests.el:
* automated/lisp-tests.el (literal-with-uninterned):
* automated/symbol-tests.el (foo):
Test print-circle, for printing (mutually-)recursive and circular
structures.
Bind print-continuous-numbering where appropriate.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Sun, 04 Sep 2011 19:51:35 +0100 |
| parents | 05c1ad4f7a7b |
| children | 56144c8593a8 |
line wrap: on
line diff
--- 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