Mercurial > hg > xemacs-beta

comparison src/elhash.c @ 5560:58b38d5b32d0

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
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
comparison
equal deleted inserted replaced
5559:f3ab0c29c246 5560:58b38d5b32d0
348 mark_object (ht->test); 348 mark_object (ht->test);
349 349
350 return Qnil; 350 return Qnil;
351 } 351 }
352 352
353 static int
354 nsubst_structures_map_hash_table (Lisp_Object key, Lisp_Object value,
355 void *extra_arg)
356 {
357 Lisp_Object number_table
358 = ((nsubst_structures_info_t *) extra_arg)->number_table;
359 Lisp_Object new_ = ((nsubst_structures_info_t *) extra_arg)->new_;
360 Lisp_Object old = ((nsubst_structures_info_t *) extra_arg)->old;
361 Lisp_Object hash_table
362 = ((nsubst_structures_info_t *) extra_arg)->current_object;
363 Boolint test_not_unboundp
364 = ((nsubst_structures_info_t *) extra_arg)->test_not_unboundp;
365
366 if (EQ (old, key) == test_not_unboundp)
367 {
368 Fremhash (key, hash_table);
369 Fputhash (new_, value, hash_table);
370 }
371 else if (LRECORDP (key) &&
372 HAS_OBJECT_METH_P (key, nsubst_structures_descend))
373 {
374 nsubst_structures_descend (new_, old, key, number_table,
375 test_not_unboundp);
376 }
377
378 if (EQ (old, value) == test_not_unboundp)
379 {
380 Fputhash (key, new_, hash_table);
381 }
382 else if (LRECORDP (value) &&
383 HAS_OBJECT_METH_P (value, nsubst_structures_descend))
384 {
385 nsubst_structures_descend (new_, old, value, number_table,
386 test_not_unboundp);
387 }
388
389 return 0;
390 }
391
392 static void
393 hash_table_nsubst_structures_descend (Lisp_Object new_, Lisp_Object old,
394 Lisp_Object object,
395 Lisp_Object number_table,
396 Boolint test_not_unboundp)
397 {
398 nsubst_structures_info_t nsubst_structures_info
399 = { number_table, new_, old, object, test_not_unboundp };
400
401 /* If we're happy with limiting nsubst_structures to use in the Lisp
402 reader, we don't have to worry about the hash table test here, because
403 the only point where NEW_ can be the test will be forms like so:
404 #%d=#:SOME-GENSYM, in which case OLD will most definitively not include
405 a hash table anywhere in its structure. */
406
407 elisp_maphash (nsubst_structures_map_hash_table, object,
408 &nsubst_structures_info);
409 }
410
411 static int
412 print_preprocess_mapper (Lisp_Object key, Lisp_Object value, void *extra_arg)
413 {
414 Lisp_Object print_number_table = ((preprocess_info_t *) extra_arg)->table;
415 Elemcount *seen_number_count = ((preprocess_info_t *) extra_arg)->count;
416
417 PRINT_PREPROCESS (key, print_number_table, seen_number_count);
418 PRINT_PREPROCESS (value, print_number_table, seen_number_count);
419
420 return 0;
421 }
422
423 static void
424 hash_table_print_preprocess (Lisp_Object obj, Lisp_Object number_table,
425 Elemcount *seen_object_count)
426 {
427 preprocess_info_t preprocess_info = { number_table,
428 seen_object_count };
429
430 print_preprocess (XHASH_TABLE_TEST (XHASH_TABLE (obj)->test)->name,
431 number_table, seen_object_count);
432
433 elisp_maphash_unsafe (print_preprocess_mapper, obj, &preprocess_info);
434 }
435
353 /* Equality of hash tables. Two hash tables are equal when they are of 436 /* Equality of hash tables. Two hash tables are equal when they are of
354 the same weakness and test function, they have the same number of 437 the same weakness and test function, they have the same number of
355 elements, and for each key in the hash table, the values are `equal'. 438 elements, and for each key in the hash table, the values are `equal'.
356 439
357 This is similar to Common Lisp `equalp' of hash tables, with the 440 This is similar to Common Lisp `equalp' of hash tables, with the
1275 amount and dispenses with all error checks. Assumes that tables does 1358 amount and dispenses with all error checks. Assumes that tables does
1276 comparison using EQ. Used by the profiling routines to avoid 1359 comparison using EQ. Used by the profiling routines to avoid
1277 overhead -- profiling overhead was being recorded at up to 15% of the 1360 overhead -- profiling overhead was being recorded at up to 15% of the
1278 total time. */ 1361 total time. */
1279 1362
1280 void 1363 htentry *
1281 inchash_eq (Lisp_Object key, Lisp_Object table, EMACS_INT offset) 1364 inchash_eq (Lisp_Object key, Lisp_Object table, EMACS_INT offset)
1282 { 1365 {
1283 Lisp_Hash_Table *ht = XHASH_TABLE (table); 1366 Lisp_Hash_Table *ht = XHASH_TABLE (table);
1284 Hash_Table_Test *http = XHASH_TABLE_TEST (ht->test); 1367 Hash_Table_Test *http = XHASH_TABLE_TEST (ht->test);
1285 htentry *entries = ht->hentries; 1368 htentry *entries = ht->hentries;
1295 { 1378 {
1296 probe->key = key; 1379 probe->key = key;
1297 probe->value = make_int (offset); 1380 probe->value = make_int (offset);
1298 1381
1299 if (++ht->count >= ht->rehash_count) 1382 if (++ht->count >= ht->rehash_count)
1300 enlarge_hash_table (ht); 1383 {
1301 } 1384 enlarge_hash_table (ht);
1385 return NULL;
1386 }
1387 }
1388
1389 return probe;
1302 } 1390 }
1303 1391
1304 DEFUN ("gethash", Fgethash, 2, 3, 0, /* 1392 DEFUN ("gethash", Fgethash, 2, 3, 0, /*
1305 Find hash value for KEY in HASH-TABLE. 1393 Find hash value for KEY in HASH-TABLE.
1306 If there is no corresponding value, return DEFAULT (which defaults to nil). 1394 If there is no corresponding value, return DEFAULT (which defaults to nil).
2239 hash_table_objects_create (void) 2327 hash_table_objects_create (void)
2240 { 2328 {
2241 #ifdef MEMORY_USAGE_STATS 2329 #ifdef MEMORY_USAGE_STATS
2242 OBJECT_HAS_METHOD (hash_table, memory_usage); 2330 OBJECT_HAS_METHOD (hash_table, memory_usage);
2243 #endif 2331 #endif
2332 OBJECT_HAS_METHOD (hash_table, print_preprocess);
2333 OBJECT_HAS_METHOD (hash_table, nsubst_structures_descend);
2244 } 2334 }
2245 2335
2246 void 2336 void
2247 syms_of_elhash (void) 2337 syms_of_elhash (void)
2248 { 2338 {