Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
ecl
ecl
Commits
693ce141
Commit
693ce141
authored
Aug 18, 2019
by
Marius Gerbershagen
Browse files
printer: remove redundancies between pretty and ordinary printer
parent
2cbe8756
Changes
5
Hide whitespace changes
Inline
Side-by-side
src/c/printer/write_object.d
View file @
693ce141
...
...
@@ -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
'
);
}
src/c/symbols_list.h
View file @
693ce141
...
...
@@ -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
},
...
...
src/c/symbols_list2.h
View file @
693ce141
...
...
@@ -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"
},
...
...
src/h/external.h
View file @
693ce141
...
...
@@ -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
);
...
...
src/lsp/pprint.lsp
View file @
693ce141
...
...
@@ -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 happen
d
, 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
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment