diff --git a/src/c/printer/write_object.d b/src/c/printer/write_object.d index f8ef11980..e6559a297 100644 --- a/src/c/printer/write_object.d +++ b/src/c/printer/write_object.d @@ -41,63 +41,52 @@ _ecl_will_print_as_hash(cl_object x) to the element. */ -static cl_fixnum -search_print_circle(cl_object x) +cl_object +si_search_print_circle(cl_object x) { cl_object circle_counter = ecl_symbol_value(@'si::*circle-counter*'); cl_object circle_stack = ecl_symbol_value(@'si::*circle-stack*'); cl_object code; + code = ecl_gethash_safe(x, circle_stack, OBJNULL); if (!ECL_FIXNUMP(circle_counter)) { - code = ecl_gethash_safe(x, circle_stack, OBJNULL); if (code == OBJNULL) { /* Was not found before */ _ecl_sethash(x, circle_stack, ECL_NIL); - return 0; + return ecl_make_fixnum(0); } else if (code == ECL_NIL) { /* This object is referenced twice */ _ecl_sethash(x, circle_stack, ECL_T); - return 1; + return ecl_make_fixnum(1); } else { - return 2; + return ecl_make_fixnum(2); } } else { - code = ecl_gethash_safe(x, circle_stack, OBJNULL); if (code == OBJNULL || code == ECL_NIL) { /* Is not referenced or was not found before */ - /* _ecl_sethash(x, circle_stack, ECL_NIL); */ - return 0; + return ecl_make_fixnum(0); } else if (code == ECL_T) { /* This object is referenced twice, but has no code yet */ - cl_fixnum new_code = ecl_fixnum(circle_counter) + 1; - circle_counter = ecl_make_fixnum(new_code); + circle_counter = ecl_make_fixnum(ecl_fixnum(circle_counter) + 1); _ecl_sethash(x, circle_stack, circle_counter); ECL_SETQ(ecl_process_env(), @'si::*circle-counter*', circle_counter); - return -new_code; + return ecl_make_fixnum(-ecl_fixnum(circle_counter)); } else { - return ecl_fixnum(code); + return code; } } } cl_object -si_write_object(cl_object x, cl_object stream) +si_write_object_with_circle(cl_object x, cl_object stream, cl_object print_function) { - bool circle; -#ifdef ECL_CMU_FORMAT - if (ecl_symbol_value(@'*print-pretty*') != ECL_NIL) { - cl_object f = _ecl_funcall2(@'pprint-dispatch', x); - if (VALUES(1) != ECL_NIL) { - _ecl_funcall3(f, stream, x); - goto OUTPUT; - } - } -#endif /* ECL_CMU_FORMAT */ - circle = ecl_print_circle(); + bool circle = ecl_print_circle(); if (circle && !Null(x) && !ECL_FIXNUMP(x) && !ECL_CHARACTERP(x) && - (LISTP(x) || (x->d.t != t_symbol) || (Null(x->symbol.hpack)))) + (ecl_t_of(x) != t_symbol || (Null(x->symbol.hpack)))) { + /* everything except fixnums, characters or interned symbols can + possibly contain cycles */ cl_object circle_counter; cl_fixnum code; circle_counter = ecl_symbol_value(@'si::*circle-counter*'); @@ -110,14 +99,14 @@ si_write_object(cl_object x, cl_object stream) cl_core.rehash_threshold); ecl_bds_bind(env, @'si::*circle-counter*', ECL_T); ecl_bds_bind(env, @'si::*circle-stack*', hash); - si_write_object(x, cl_core.null_stream); + si_write_object_with_circle(x, cl_core.null_stream, print_function); ECL_SETQ(env, @'si::*circle-counter*', ecl_make_fixnum(0)); - si_write_object(x, stream); + si_write_object_with_circle(x, stream, print_function); cl_clrhash(hash); ecl_bds_unwind_n(env, 2); goto OUTPUT; } - code = search_print_circle(x); + code = ecl_fixnum(si_search_print_circle(x)); if (!ECL_FIXNUMP(circle_counter)) { /* We are only inspecting the object to be printed. */ /* Only run X if it was not referenced before */ @@ -138,7 +127,23 @@ si_write_object(cl_object x, cl_object stream) goto OUTPUT; } } - return si_write_ugly_object(x, stream); + return _ecl_funcall3(print_function, x, stream); OUTPUT: @(return x); + +} + +cl_object +si_write_object(cl_object x, cl_object stream) +{ +#ifdef ECL_CMU_FORMAT + if (ecl_symbol_value(@'*print-pretty*') != ECL_NIL) { + cl_object f = _ecl_funcall2(@'pprint-dispatch', x); + if (VALUES(1) != ECL_NIL) { + _ecl_funcall3(f, stream, x); + @(return x); + } + } +#endif /* ECL_CMU_FORMAT */ + return si_write_object_with_circle(x, stream, @'si::write-ugly-object'); } diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 695afabd3..530f8b834 100755 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1277,6 +1277,8 @@ cl_symbols[] = { {SYS_ "UNIVERSAL-ERROR-HANDLER", SI_ORDINARY, NULL, -1, OBJNULL}, {SYS_ "STACK-ERROR-HANDLER", SI_ORDINARY, NULL, -1, OBJNULL}, {SYS_ "VALID-FUNCTION-NAME-P", SI_ORDINARY, si_valid_function_name_p, 1, OBJNULL}, +{SYS_ "SEARCH-PRINT-CIRCLE", SI_SPECIAL, si_search_print_circle, 1, OBJNULL}, +{SYS_ "WRITE-OBJECT-WITH-CIRCLE", SI_SPECIAL, si_write_object_with_circle, 3, OBJNULL}, {SYS_ "WRITE-OBJECT", SI_SPECIAL, si_write_object, 2, OBJNULL}, {SYS_ "WRITE-UGLY-OBJECT", SI_SPECIAL, si_write_ugly_object, 2, OBJNULL}, diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index 3dbcaa66b..2224d3053 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1277,6 +1277,8 @@ cl_symbols[] = { {SYS_ "UNIVERSAL-ERROR-HANDLER",NULL}, {SYS_ "STACK-ERROR-HANDLER",NULL}, {SYS_ "VALID-FUNCTION-NAME-P","si_valid_function_name_p"}, +{SYS_ "SEARCH-PRINT-CIRCLE","si_search_print_circle"}, +{SYS_ "WRITE-OBJECT-WITH-CIRCLE","si_write_object_with_circle"}, {SYS_ "WRITE-OBJECT","si_write_object"}, {SYS_ "WRITE-UGLY-OBJECT","si_write_ugly_object"}, diff --git a/src/h/external.h b/src/h/external.h index c671a2e11..17aa77224 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -1450,6 +1450,8 @@ extern ECL_API cl_object cl_finish_output _ECL_ARGS((cl_narg narg, ...)); extern ECL_API cl_object cl_fresh_line _ECL_ARGS((cl_narg narg, ...)); extern ECL_API cl_object cl_force_output _ECL_ARGS((cl_narg narg, ...)); extern ECL_API cl_object cl_clear_output _ECL_ARGS((cl_narg narg, ...)); +extern ECL_API cl_object si_search_print_circle(cl_object x); +extern ECL_API cl_object si_write_object_with_circle(cl_object object, cl_object stream, cl_object print_function); extern ECL_API cl_object si_write_object(cl_object object, cl_object stream); extern ECL_API cl_object si_write_ugly_object(cl_object object, cl_object stream); diff --git a/src/lsp/pprint.lsp b/src/lsp/pprint.lsp index 17575d40d..4231796e5 100644 --- a/src/lsp/pprint.lsp +++ b/src/lsp/pprint.lsp @@ -726,15 +726,12 @@ nil) ((or (null object) (zerop count) - (fixnump object) - (characterp object) - (and (symbolp object) (symbol-package object)) (null *circle-counter*)) t) ((eql 'NULL (setf code (gethash object *circle-stack* 'NULL))) ;; We visit this part of the list for the first time and thus we must ;; register it in the hash, or we are on the second pass and have - ;; found a completely new list. This should not happend, but anyway + ;; found a completely new list. This should not happen, but anyway ;; we try to print it. (search-print-circle object) t) @@ -760,31 +757,6 @@ (t (setf *print-level* (1- *print-level*))))) -(defun search-print-circle (object) - (declare (si::c-local)) - (let ((code (gethash object *circle-stack* -1))) - (if (fixnump *circle-counter*) - (cond ((or (eql code -1) (null code)) - ;; Is not referenced or was not found before - 0) - ((eql code t) - ;; Reference twice but had no code yet - (setf (gethash object *circle-stack*) - (setf *circle-counter* (1+ *circle-counter*))) - (- *circle-counter*)) - (t code)) - (cond ((eql code -1) - ;; Was not found before - (setf (gethash object *circle-stack*) nil) - 0) - ((null code) - ;; Second reference - (setf (gethash object *circle-stack*) t) - 1) - (t - ;; Further references - 2))))) - (defun do-pprint-logical-block (function object stream prefix per-line-prefix-p suffix) (declare (si::c-local)) @@ -794,47 +766,17 @@ (when (and (not *print-readably*) (eql *print-level* 0)) (write-char #\# stream) (return-from do-pprint-logical-block nil)) - (unless (or (not *print-circle*) - (fixnump object) - (characterp object) - (and (symbolp object) (symbol-package object))) - (let (code) - (cond ((not *circle-counter*) - (let* ((hash (make-hash-table :test 'eq :size 1024 - :rehash-size 1.5 - :rehash-threshold 0.75)) - (*circle-counter* t) - (*circle-stack* hash)) - (do-pprint-logical-block function object - (make-pretty-stream (make-broadcast-stream)) - prefix per-line-prefix-p suffix) - (setf *circle-counter* 0) - (do-pprint-logical-block function object stream - prefix per-line-prefix-p suffix)) - (return-from do-pprint-logical-block nil)) - ((zerop (setf code (search-print-circle object))) - ;; Object was not referenced before: we must either traverse it - ;; or print it. - ) - ((minusp code) - ;; First definition, we write the #n=... prefix - (write-string "#" stream) - (let ((*print-radix* nil) (*print-base* 10)) - (write-ugly-object (- code) stream)) - (write-string "=" stream)) - (t - ;; Further references, we write the #n# tag and exit - (write-string "#" stream) - (let ((*print-radix* nil) (*print-base* 10)) - (write-ugly-object code stream)) - (write-string "#" stream) - (return-from do-pprint-logical-block nil))))) - (let ((*print-level* (and (not *print-readably*) - *print-level* - (1- *print-level*)))) - (start-logical-block stream prefix per-line-prefix-p suffix) - (funcall function object stream) - (end-logical-block stream)) + (write-object-with-circle + object stream + #'(lambda (object s) + (unless (pretty-stream-p s) + (setf s (make-pretty-stream s))) + (let ((*print-level* (and (not *print-readably*) + *print-level* + (1- *print-level*)))) + (start-logical-block s prefix per-line-prefix-p suffix) + (funcall function object s) + (end-logical-block s)))) nil) (defun pprint-logical-block-helper (function object stream prefix