mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-23 13:01:42 -08:00
Code Issues Projects Releases Packages Wiki Activity

printer: remove redundancies between pretty and ordinary printer

Browse source
This commit is contained in:
Marius Gerbershagen 2019-08-18 19:31:58 +02:00
parent 2cbe875668
commit 693ce14130
5 changed files with 53 additions and 100 deletions
Download patch file Download diff file Expand all files Collapse all files

65
src/c/printer/write_object.d
View file

@ -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');
}

2
src/c/symbols_list.h
View file

@ -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},

2
src/c/symbols_list2.h
View file

@ -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"},

2
src/h/external.h
View file

@ -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);

82
src/lsp/pprint.lsp
View file

@ -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