Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
cmucl
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Build
Pipelines
Jobs
Pipeline schedules
Artifacts
Deploy
Releases
Package Registry
Model registry
Operate
Environments
Terraform modules
Monitor
Incidents
Service Desk
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Carl Shapiro
cmucl
Commits
a668d7bd
Commit
a668d7bd
authored
33 years ago
by
wlott
Browse files
Options
Downloads
Patches
Plain Diff
Significant rewrite to support *print-readably* at all and to better
support and *print-circle*, *print-level*, and *print-length*.
parent
bfcd7984
No related branches found
Branches containing commit
No related tags found
Tags containing commit
No related merge requests found
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
code/print.lisp
+665
-510
665 additions, 510 deletions
code/print.lisp
with
665 additions
and
510 deletions
code/print.lisp
+
665
−
510
View file @
a668d7bd
...
@@ -7,7 +7,7 @@
...
@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
;;;
(
ext:file-comment
(
ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/print.lisp,v 1.2
6
1991/1
1/16 00:22:51
wlott Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/print.lisp,v 1.2
7
1991/1
2/02 18:57:14
wlott Exp $"
)
;;;
;;;
;;; **********************************************************************
;;; **********************************************************************
;;;
;;;
...
@@ -19,152 +19,136 @@
...
@@ -19,152 +19,136 @@
(
in-package
"LISP"
)
(
in-package
"LISP"
)
(
export
'
(
*print-escape*
*print-pretty*
*print-circle*
*print-base*
(
export
'
(
*print-readably*
*print-escape*
*print-pretty*
*print-circle*
*print-radix*
*print-case*
*print-level*
*print-length*
*print-base*
*print-radix*
*print-case*
*print-gensym*
*print-level*
*print-array*
*print-gensym*
write
prin1
print
princ
*print-length*
*print-array*
*print-lines*
*print-right-margin*
write-to-string
prin1-to-string
princ-to-string
))
*print-miser-width*
with-standard-io-syntax
write
prin1
print
princ
pprint
write-to-string
prin1-to-string
princ-to-string
print-unreadable-object
))
;;;; Exported printer control variables.
(
defvar
*print-readably*
nil
"If true, all objects will printed readably. If readably printing is
impossible, an error will be signalled. This overrides the value of
*PRINT-ESCAPE*."
)
(
defvar
*print-escape*
T
(
defvar
*print-escape*
T
"Flag which indicates that slashification is on. See the manual"
)
"Flag which indicates that slashification is on. See the manual"
)
(
defvar
*print-pretty*
nil
(
defvar
*print-pretty*
nil
"Flag which indicates that pretty printing is to be used"
)
"Flag which indicates that pretty printing is to be used"
)
(
defvar
*print-base*
10.
(
defvar
*print-base*
10.
"The output base for integers and rationals."
)
"The output base for integers and rationals."
)
(
defvar
*print-radix*
()
(
defvar
*print-radix*
nil
"This flag requests to verify base when printing rationals."
)
"This flag requests to verify base when printing rationals."
)
(
defvar
*print-level*
()
(
defvar
*print-level*
nil
"How many levels deep to print. Unlimited if null."
)
"How many levels deep to print. Unlimited if null."
)
(
defvar
*print-length*
()
(
defvar
*print-length*
nil
"How many elements to print on each level. Unlimited if null."
)
"How many elements to print on each level. Unlimited if null."
)
(
defvar
*print-circle*
()
(
defvar
*print-circle*
nil
"Whether to worry about circular list structures. See the manual."
)
"Whether to worry about circular list structures. See the manual."
)
(
defvar
*print-case*
'
:upcase
(
defvar
*print-case*
:upcase
"What kind of case the printer should use by default"
)
"What kind of case the printer should use by default"
)
(
defvar
*print-array*
T
(
defvar
*print-array*
t
"Whether the array should print it's guts out"
)
"Whether the array should print it's guts out"
)
(
defvar
*print-gensym*
T
(
defvar
*print-gensym*
t
"If true, symbols with no home package are printed with a #: prefix.
"If true, symbols with no home package are printed with a #: prefix.
If false, no prefix is printed."
)
If false, no prefix is printed."
)
;;; These next two vars are *not* really fully implemented, but I added them
(
defvar
*print-lines*
nil
)
;;; here so that I wouldn't be forced to write new code incorrectly.
(
defvar
*print-right-margin*
nil
)
;;; -- Ram, 9/28/90
(
defvar
*print-miser-width*
nil
)
;;;
(
defvar
*print-pprint-dispatch*
nil
)
(
defvar
*print-readably*
nil
"If true, all objects will printed readably. If readably printing is
(
defmacro
with-standard-io-syntax
(
&body
body
)
impossible, an error will be signalled. This overrides the value of
"Bind the reader and printer control variables to values that enable READ
*PRINT-ESCAPE*. But this isn't really implemented yet."
)
to reliably read the results of PRINT. These values are:
*PACKAGE* The COMMON-LISP-USER package
(
defvar
*read-eval*
t
*PRINT-ARRAY* T
"If false, then the #. read macro is disabled. But this isn't really
*PRINT-BASE* 10
implemented yet."
)
*PRINT-CASE* :UPCASE
*PRINT-CIRCLE* NIL
*PRINT-ESCAPE* T
;;; Imported from reader.
*PRINT-GENSYM* T
;;;
*PRINT-LENGTH* NIL
(
proclaim
'
(
special
*read-default-float-format*
))
*PRINT-LEVEL* NIL
*PRINT-LINES* NIL
;;; From the package system.
*PRINT-MISER-WIDTH* NIL
;;;
*PRINT-PRETTY* NIL
(
proclaim
'
(
special
*package*
*keyword-package*
))
*PRINT-RADIX* NIL
*PRINT-READABLY* T
*PRINT-RIGHT-MARGIN* NIL
;;; DOSTRING -- Internal.
*READ-BASE* 10
;;;
*READ-DEFAULT-FLOAT-FORMAT* SINGLE-FLOAT
;;; This macro returns code which maps over a string, binding VARIABLE to each
*READ-EVAL* T
;;; successive character in the string INIT-FORM, and executing BODY with
*READ-SUPPRESS* NIL
;;; the variable so bound. This function used to be part of Common Lisp, but
*READTABLE* the standard readtable."
;;; is no more. It lives on in the printer, though.
`
(
%with-standard-io-syntax
#'
(
lambda
()
,@
body
)))
;;;
(
defmacro
dostring
((
variable
init-form
&optional
terminate-form
)
&rest
body
)
(
defun
%with-standard-io-syntax
(
function
)
(
let
((
str
(
gensym
))
(
let
((
*package*
(
find-package
"USER"
))
(
end
(
gensym
))
(
*print-array*
t
)
(
index
(
gensym
)))
(
*print-base*
10
)
`
(
let*
((
,
str
,
init-form
)
(
*print-case*
:upcase
)
(
,
end
(
length
(
the
string
,
str
)))
(
*print-circle*
nil
)
(
,
index
0
))
(
*print-escape*
t
)
(
declare
(
fixnum
,
index
,
end
))
(
*print-gensym*
t
)
(
loop
(
*print-length*
nil
)
(
when
(
=
,
index
,
end
)
(
return
,
terminate-form
))
(
*print-level*
nil
)
(
let
((
,
variable
(
char
,
str
,
index
)))
(
*print-lines*
nil
)
,@
body
)
(
*print-miser-width*
nil
)
(
incf
,
index
)))))
(
*print-pretty*
nil
)
(
*print-radix*
nil
)
(
*print-readably*
t
)
(
*print-right-margin*
nil
)
(
*read-base*
10
)
(
*read-default-float-format*
'single-float
)
(
*read-eval*
t
)
(
*read-suppress*
nil
)
(
*readtable*
std-lisp-readtable
))
(
funcall
function
)))
;;;; Printing Functions
;;;; Routines to print objects.
(
proclaim
'
(
inline
setup-printer-state
))
(
defvar
*previous-case*
()
"What the previous case selection the printer was set to."
)
;;; This variable contains the current definition of one of three symbol
;;; printers. SETUP-PRINTER-STATE sets this variable.
;;;
(
defvar
*internal-symbol-output-function*
nil
)
;;; SETUP-PRINTER-STATE -- Internal.
;;;
;;; This function sets the internal global symbol
;;; *internal-symbol-output-function* to the right function depending on the
;;; value of *print-case*. See the manual for details. The print buffer
;;; stream is also reset.
;;;
(
defun
setup-printer-state
()
(
unless
(
eq
*print-case*
*previous-case*
)
(
setq
*previous-case*
*print-case*
)
(
setq
*internal-symbol-output-function*
(
case
*print-case*
(
:upcase
#'
output-uppercase-symbol
)
(
:downcase
#'
output-lowercase-symbol
)
(
:capitalize
#'
output-capitalize-symbol
)
(
T
(
let
((
bad-case
*print-case*
))
(
setq
*print-case*
:upcase
)
(
Error
"Invalid *print-case* value: ~s"
bad-case
)))))))
(
defun
write
(
object
&key
(
defun
write
(
object
&key
((
:stream
stream
)
*standard-output*
)
((
:stream
stream
)
*standard-output*
)
((
:escape
*print-escape*
)
*print-escape*
)
((
:escape
*print-escape*
)
*print-escape*
)
((
:radix
*print-radix*
)
*print-radix*
)
((
:radix
*print-radix*
)
*print-radix*
)
((
:base
*print-base*
)
*print-base*
)
((
:base
*print-base*
)
*print-base*
)
((
:circle
*print-circle*
)
*print-circle*
)
((
:circle
*print-circle*
)
*print-circle*
)
((
:pretty
*print-pretty*
)
*print-pretty*
)
((
:pretty
*print-pretty*
)
*print-pretty*
)
((
:level
*print-level*
)
*print-level*
)
((
:level
*print-level*
)
*print-level*
)
((
:length
*print-length*
)
*print-length*
)
((
:length
*print-length*
)
*print-length*
)
((
:case
*print-case*
)
*print-case*
)
((
:case
*print-case*
)
*print-case*
)
((
:array
*print-array*
)
*print-array*
)
((
:array
*print-array*
)
*print-array*
)
((
:gensym
*print-gensym*
)
*print-gensym*
))
((
:gensym
*print-gensym*
)
*print-gensym*
)
((
:readably
*print-readably*
)
*print-readably*
)
((
:right-margin
*print-right-margin*
)
*print-right-margin*
)
((
:miser-width
*print-miser-width*
)
*print-miser-width*
)
((
:lines
*print-lines*
)
*print-lines*
)
((
:pprint-dispatch
*print-pprint-dispatch*
)
*print-pprint-dispatch*
))
"Outputs OBJECT to the specified stream, defaulting to *standard-output*"
"Outputs OBJECT to the specified stream, defaulting to *standard-output*"
(
setup-printer-state
)
(
output-object
object
(
out-synonym-of
stream
))
(
let
((
stream
(
out-synonym-of
stream
)))
(
if
*print-pretty*
(
output-pretty-object
object
stream
)
(
output-object
object
stream
)))
object
)
object
)
(
defun
prin1
(
object
&optional
stream
)
(
defun
prin1
(
object
&optional
stream
)
"Outputs a mostly READable printed representation of OBJECT on the specified
"Outputs a mostly READable printed representation of OBJECT on the specified
stream."
stream."
(
let
((
stream
(
out-synonym-of
stream
)))
(
let
((
*print-escape*
T
))
(
setup-printer-state
)
(
output-object
object
(
out-synonym-of
stream
)))
(
let
((
*print-escape*
T
))
object
)
(
if
*print-pretty*
(
output-pretty-object
object
stream
)
(
output-object
object
stream
)))
object
))
(
defun
princ
(
object
&optional
stream
)
(
defun
princ
(
object
&optional
stream
)
"Outputs an asthetic but not READable printed representation of OBJECT on the
"Outputs an asthetic but not READable printed representation of OBJECT on the
specified stream."
specified stream."
(
let
((
stream
(
out-synonym-of
stream
)))
(
let
((
*print-escape*
NIL
))
(
setup-printer-state
)
(
output-object
object
(
out-synonym-of
stream
)))
(
let
((
*print-escape*
NIL
))
object
)
(
if
*print-pretty*
(
output-pretty-object
object
stream
)
(
output-object
object
stream
)))
object
))
(
defun
print
(
object
&optional
stream
)
(
defun
print
(
object
&optional
stream
)
"Outputs a terpri, the mostly READable printed represenation of OBJECT, and
"Outputs a terpri, the mostly READable printed represenation of OBJECT, and
...
@@ -175,19 +159,35 @@
...
@@ -175,19 +159,35 @@
(
write-char
#\space
stream
)
(
write-char
#\space
stream
)
object
))
object
))
(
defun
write-to-string
(
object
&key
(
defun
pprint
(
object
&optional
stream
)
((
:escape
*print-escape*
)
*print-escape*
)
"Prettily outputs the Object preceded by a newline."
((
:radix
*print-radix*
)
*print-radix*
)
(
let
((
*print-pretty*
t
)
((
:base
*print-base*
)
*print-base*
)
(
*print-escape*
t
))
((
:circle
*print-circle*
)
*print-circle*
)
(
terpri
stream
)
((
:pretty
*print-pretty*
)
*print-pretty*
)
(
output-object
object
stream
))
((
:level
*print-level*
)
*print-level*
)
(
values
))
((
:length
*print-length*
)
*print-length*
)
((
:case
*print-case*
)
*print-case*
)
((
:array
*print-array*
)
*print-array*
)
(
defun
write-to-string
((
:gensym
*print-gensym*
)
*print-gensym*
))
(
object
&key
((
:escape
*print-escape*
)
*print-escape*
)
((
:radix
*print-radix*
)
*print-radix*
)
((
:base
*print-base*
)
*print-base*
)
((
:circle
*print-circle*
)
*print-circle*
)
((
:pretty
*print-pretty*
)
*print-pretty*
)
((
:level
*print-level*
)
*print-level*
)
((
:length
*print-length*
)
*print-length*
)
((
:case
*print-case*
)
*print-case*
)
((
:array
*print-array*
)
*print-array*
)
((
:gensym
*print-gensym*
)
*print-gensym*
)
((
:readably
*print-readably*
)
*print-readably*
)
((
:right-margin
*print-right-margin*
)
*print-right-margin*
)
((
:miser-width
*print-miser-width*
)
*print-miser-width*
)
((
:lines
*print-lines*
)
*print-lines*
)
((
:pprint-dispatch
*print-pprint-dispatch*
)
*print-pprint-dispatch*
))
"Returns the printed representation of OBJECT as a string."
"Returns the printed representation of OBJECT as a string."
(
stringify-object
object
*print-escape*
))
(
stringify-object
object
))
(
defun
prin1-to-string
(
object
)
(
defun
prin1-to-string
(
object
)
"Returns the printed representation of OBJECT as a string with
"Returns the printed representation of OBJECT as a string with
...
@@ -199,129 +199,319 @@
...
@@ -199,129 +199,319 @@
slashification off."
slashification off."
(
stringify-object
object
nil
))
(
stringify-object
object
nil
))
(
defvar
*print-string-stream*
(
make-string-output-stream
)
"Holds the string stream for the x-TO-STRING functions."
)
(
defvar
*in-stringify-object*
()
"T if in the middle of stringify-object."
)
;;; STRINGIFY-OBJECT -- Internal.
;;; STRINGIFY-OBJECT -- Internal.
;;;
;;;
;;; This produces the printed representation of an object as a string. The
;;; This produces the printed representation of an object as a string. The
;;; few ...-TO-STRING functions above call this.
;;; few ...-TO-STRING functions above call this.
;;;
;;;
(
defun
stringify-object
(
object
&optional
(
*print-escape*
nil
))
(
defvar
*string-output-streams*
())
(
let
((
stream
(
if
*in-stringify-object*
;;;
(
make-string-output-stream
)
(
defun
stringify-object
(
object
&optional
(
*print-escape*
*print-escape*
))
*print-string-stream*
))
(
let
((
stream
(
if
*string-output-streams*
(
*in-stringify-object*
t
))
(
pop
*string-output-streams*
)
(
make-string-output-stream
))))
(
setup-printer-state
)
(
setup-printer-state
)
(
if
*print-pretty*
(
output-object
object
stream
)
(
output-pretty-object
object
stream
)
(
prog1
(
output-
object
object
stream
0
)
)
(
get-
output-
stream-string
stream
)
(
get-output-
stream
-
string
stream
)))
(
push
stream
*
string
-output-
stream
s*
)
)))
;;;;
Central Print Functions.
;;;;
PRINT-UNREADABLE-OBJECT macro
;;; OUTPUT-OBJECT -- Internal.
(
defmacro
print-unreadable-object
((
object
stream
&key
type
identity
)
;;;
&body
body
)
;;; This takes an object and outputs its printed representation to stream,
`
(
%print-unreadable-object
,
object
,
stream
,
type
,
identity
;;; which typically is the internal print stream. This function is called
,
(
if
body
;;; recursively by the sub-functions which know how to print structures which
`
#'
(
lambda
()
,@
body
)
;;; can contain other lisp objects.
nil
)))
(
defun
%print-unreadable-object
(
object
stream
type
identity
body
)
(
when
*print-readably*
(
error
"~S cannot be printed readably."
object
))
(
write-string
"#<"
stream
)
(
when
type
(
write
(
type-of
object
)
:stream
stream
:circle
nil
:level
nil
:length
nil
)
(
when
(
or
body
identity
)
(
write-char
#\space
stream
)))
(
when
body
(
funcall
body
))
(
when
identity
(
when
body
(
write-char
#\space
stream
))
(
write-char
#\{
stream
)
(
write
(
get-lisp-obj-address
object
)
:stream
stream
:radix
nil
:base
16
)
(
write-char
#\}
stream
))
(
write-char
#\>
stream
))
;;;; WHITESPACE-CHAR-P
;;; This is used in other files, but is defined in this one for some reason.
(
defun
whitespace-char-p
(
char
)
"Determines whether or not the character is considered whitespace."
(
or
(
char=
char
#\space
)
(
char=
char
#\tab
)
(
char=
char
#\return
)
(
char=
char
#\linefeed
)))
;;;; Circularity detection stuff.
(
defvar
*circularity-hash-table*
nil
)
(
defvar
*circularity-counter*
nil
)
;;; CHECK-FOR-CIRCULARITY -- interface.
;;;
;;;
(
defun
output-object
(
object
stream
&optional
(
currlevel
0
))
;;; Check to see if OBJECT is a circular reference, and return T if it is and
"Outputs a string which is the printed representation of the given object."
;;; NIL if not. Note: this function must be called *exactly* once with
;; First check and make sure we aren't too deep
;;; assign T for every potentially circular object.
(
declare
(
fixnum
currlevel
))
;;;
(
if
(
and
(
not
(
null
*print-level*
))
(
defun
check-for-circularity
(
object
&optional
assign
)
(
not
(
=
*print-level*
0
))
(
cond
((
null
*print-circle*
)
(
>=
currlevel
(
the
fixnum
*print-level*
)))
;; Don't bother, nobody cares.
(
write-char
#\#
stream
)
nil
)
(
typecase
object
((
null
*circularity-hash-table*
)
(
symbol
:initiate
)
(
if
*print-escape*
((
null
*circularity-counter*
)
(
output-symbol
object
stream
)
(
ecase
(
gethash
object
*circularity-hash-table*
)
(
case
*print-case*
((
nil
)
(
:upcase
(
write-string
(
symbol-name
object
)
stream
))
;; First encounter.
(
:downcase
(
setf
(
gethash
object
*circularity-hash-table*
)
t
)
(
let
((
name
(
symbol-name
object
)))
;; We need to keep looking.
(
declare
(
simple-string
name
))
nil
)
(
dotimes
(
i
(
length
name
))
((
t
)
(
write-char
(
char-downcase
(
char
name
i
))
stream
))))
;; Second encounter.
(
:capitalize
(
setf
(
gethash
object
*circularity-hash-table*
)
0
)
(
write-string
(
string-capitalize
(
symbol-name
object
))
;; It's a circular reference.
stream
)))))
t
)
;; If a list, go through element by element, being careful
(
0
;; about not running over the printlength
;; It's a circular reference.
(
list
t
)))
(
output-list
object
stream
(
1+
currlevel
)))
(
string
(
if
*print-escape*
(
quote-string
object
stream
)
(
write-string
object
stream
)))
(
integer
(
output-integer
object
stream
))
(
float
(
output-float
object
stream
))
(
ratio
(
output-ratio
object
stream
))
(
complex
(
output-complex
object
stream
))
(
structure
(
output-structure
object
stream
currlevel
))
(
character
(
output-character
object
stream
))
(
vector
(
output-vector
object
stream
))
(
array
(
output-array
object
stream
(
1+
currlevel
)))
(
system-area-pointer
(
output-sap
object
stream
))
(
weak-pointer
(
output-weak-pointer
object
stream
))
(
t
(
t
(
if
(
and
(
fboundp
'funcallable-instance-p
)
(
let
((
value
(
gethash
object
*circularity-hash-table*
)))
(
funcallable-instance-p
object
))
(
case
value
(
pcl:print-object
object
stream
)
((
nil
)
(
output-random
object
stream
))))))
;; We found an object that wasn't there the first time around.
(
let
((
*print-circle*
nil
))
(
error
"Found an object on the second pass that wasn't there ~
on the first pass."
)))
((
t
)
;; Exactly one occurance of this object appears. That's good.
nil
)
(
0
(
if
assign
(
let
((
value
(
incf
*circularity-counter*
)))
;; First occurance of this object. Set the counter.
(
setf
(
gethash
object
*circularity-hash-table*
)
value
)
value
)
t
))
(
t
;; Second or later occurance.
(
-
value
)))))))
(
defun
handle-circularity
(
marker
stream
)
(
case
marker
(
:initiate
;; Someone forgor to initiate circularity detection.
(
let
((
*print-circle*
nil
))
(
error
"Attempt to use CHECK-FOR-CIRCULARITY when circularity ~
checking has not been initiated."
)))
((
t
)
;; It's a second (or later) reference to the object while we are
;; just looking. So don't bother groveling it again.
nil
)
(
t
(
write-char
#\#
stream
)
(
let
((
*print-base*
10
)
(
*print-radix*
nil
))
(
cond
((
minusp
marker
)
(
output-integer
(
-
marker
)
stream
)
(
write-char
#\#
stream
)
nil
)
(
t
(
output-integer
marker
stream
)
(
write-char
#\=
stream
)
t
))))))
(
defmacro
with-circularity-detection
((
object
stream
)
&body
body
)
(
let
((
user-body
(
gensym
))
(
checker
(
gensym
)))
(
once-only
((
object
object
))
`
(
labels
((
,
user-body
(
,
stream
)
,@
body
)
(
,
checker
(
,
stream
)
(
let
((
marker
(
check-for-circularity
,
object
t
)))
(
case
marker
(
:initiate
(
let
((
*circularity-hash-table*
(
make-hash-table
:test
#'
eq
)))
(
,
checker
(
make-broadcast-stream
))
(
let
((
*circularity-counter*
0
))
(
,
checker
,
stream
))))
((
nil
)
(
,
user-body
,
stream
))
(
t
(
when
(
handle-circularity
marker
,
stream
)
(
,
user-body
,
stream
)))))))
(
,
checker
,
stream
)))))
;;;; Symbol Printing Subfunctions
;;;; Level and Length abbreviations.
(
defvar
*current-level*
0
)
(
defmacro
decend-into
((
object
stream
)
&body
body
)
(
let
((
guts
`
(
let
((
*current-level*
(
1+
*current-level*
)))
,@
body
)))
`
(
if
(
and
(
null
*print-readably*
)
*print-level*
(
>=
*current-level*
*print-level*
))
(
write-char
#\#
,
stream
)
,
(
if
object
`
(
with-circularity-detection
(
,
object
,
stream
)
,
guts
)
guts
))))
(
defmacro
punt-if-too-long
(
index
stream
)
`
(
when
(
and
(
not
*print-readably*
)
*print-length*
(
>=
,
index
*print-length*
))
(
write-string
"..."
,
stream
)
(
return
)))
(
defun
output-symbol
(
object
stream
)
(
let
((
package
(
symbol-package
object
))
;;;; OUTPUT-OBJECT -- the main entry point.
(
name
(
symbol-name
object
)))
(
cond
(
defvar
*pretty-printer*
nil
)
;; If the symbol's home package is the current one, then a
;; prefix is never necessary.
(
defun
output-object
(
object
stream
)
((
eq
package
*package*
))
(
if
(
and
*print-pretty*
*pretty-printer*
)
;; If the symbol is in the keyword package, output a colon.
(
funcall
*pretty-printer*
object
stream
)
((
eq
package
*keyword-package*
)
(
output-ugly-object
object
stream
)))
(
write-char
#\:
stream
))
;; Uninterned symbols print with a leading #:.
(
defun
output-ugly-object
(
object
stream
)
((
null
package
)
(
typecase
object
(
when
*print-gensym*
(
write-string
"#:"
stream
)))
(
fixnum
(
t
(
output-integer
object
stream
))
(
multiple-value-bind
(
symbol
accessible
)
(
list
(
find-symbol
name
*package*
)
(
if
(
null
object
)
;; If we can find the symbol by looking it up, it need not be
(
output-symbol
object
stream
)
;; qualified. This can happen if the symbol has been inherited
(
output-list
object
stream
)))
;; from a package other than its home package.
(
structure
(
unless
(
and
accessible
(
eq
symbol
object
))
(
output-structure
object
stream
))
(
funcall
*internal-symbol-output-function*
(
function
(
package-name
package
)
(
if
(
and
(
fboundp
'funcallable-instance-p
)
stream
)
(
funcallable-instance-p
object
))
(
multiple-value-bind
(
symbol
externalp
)
(
pcl:print-object
object
stream
)
(
find-external-symbol
name
package
)
(
output-function
object
stream
)))
(
declare
(
ignore
symbol
))
(
symbol
(
if
externalp
(
output-symbol
object
stream
))
(
write-char
#\:
stream
)
(
number
(
write-string
"::"
stream
)))))))
(
etypecase
object
(
funcall
*internal-symbol-output-function*
name
stream
)))
(
integer
(
output-integer
object
stream
))
(
float
(
output-float
object
stream
))
(
ratio
(
output-ratio
object
stream
))
(
ratio
(
output-ratio
object
stream
))
(
complex
(
output-complex
object
stream
))))
(
character
(
output-character
object
stream
))
(
vector
(
output-vector
object
stream
))
(
array
(
output-array
object
stream
))
(
system-area-pointer
(
output-sap
object
stream
))
(
weak-pointer
(
output-weak-pointer
object
stream
))
(
t
(
output-random
object
stream
))))
;;;; Symbols.
(
defvar
*previous-case*
()
"What the previous case selection the printer was set to."
)
;;; This variable contains the current definition of one of three symbol
;;; printers. SETUP-PRINTER-STATE sets this variable.
;;;
(
defvar
*internal-symbol-output-function*
nil
)
;;; SETUP-PRINTER-STATE -- Internal.
;;;
;;; This function sets the internal global symbol
;;; *internal-symbol-output-function* to the right function depending on the
;;; value of *print-case*. See the manual for details. The print buffer
;;; stream is also reset.
;;;
(
defun
setup-printer-state
()
(
unless
(
eq
*print-case*
*previous-case*
)
(
setq
*previous-case*
*print-case*
)
(
setq
*internal-symbol-output-function*
(
case
*print-case*
(
:upcase
#'
output-uppercase-symbol
)
(
:downcase
#'
output-lowercase-symbol
)
(
:capitalize
#'
output-capitalize-symbol
)
(
T
(
let
((
bad-case
*print-case*
))
(
setq
*print-case*
:upcase
)
(
Error
"Invalid *print-case* value: ~s"
bad-case
)))))))
(
defun
output-symbol
(
object
stream
)
(
if
(
or
*print-escape*
*print-readably*
)
(
let
((
package
(
symbol-package
object
))
(
name
(
symbol-name
object
)))
(
setup-printer-state
)
(
cond
;; If the symbol's home package is the current one, then a
;; prefix is never necessary.
((
eq
package
*package*
))
;; If the symbol is in the keyword package, output a colon.
((
eq
package
*keyword-package*
)
(
write-char
#\:
stream
))
;; Uninterned symbols print with a leading #:.
((
null
package
)
(
when
(
or
*print-circle*
*print-readably*
)
(
let
((
marker
(
check-for-circularity
object
t
)))
(
case
marker
((
:initiate
nil
))
(
t
(
unless
(
handle-circularity
marker
stream
)
(
return-from
output-symbol
nil
))))))
(
when
(
or
*print-gensym*
*print-readably*
)
(
write-string
"#:"
stream
)))
(
t
(
multiple-value-bind
(
symbol
accessible
)
(
find-symbol
name
*package*
)
;; If we can find the symbol by looking it up, it need not be
;; qualified. This can happen if the symbol has been inherited
;; from a package other than its home package.
(
unless
(
and
accessible
(
eq
symbol
object
))
(
funcall
*internal-symbol-output-function*
(
package-name
package
)
stream
)
(
multiple-value-bind
(
symbol
externalp
)
(
find-external-symbol
name
package
)
(
declare
(
ignore
symbol
))
(
if
externalp
(
write-char
#\:
stream
)
(
write-string
"::"
stream
)))))))
(
funcall
*internal-symbol-output-function*
name
stream
))
(
case
*print-case*
(
:upcase
(
write-string
(
symbol-name
object
)
stream
))
(
:downcase
(
write-string
(
string-downcase
(
symbol-name
object
))
stream
))
(
:capitalize
(
write-string
(
string-capitalize
(
symbol-name
object
))
stream
)))))
;;;; Escaping symbols:
;;;; Escaping symbols:
...
@@ -536,8 +726,9 @@
...
@@ -536,8 +726,9 @@
MARKER
; Number marker in a numeric number...
MARKER
; Number marker in a numeric number...
(
when
(
test
letter
)
(
advance
OTHER
nil
))
(
when
(
test
letter
)
(
advance
OTHER
nil
))
(
go
DIGIT
))))
(
go
DIGIT
))))
;;;; P
ath
name hackery
;;;; P
rint
name hackery
;;; This function takes the pname of a symbol and adds slashes and/or
;;; This function takes the pname of a symbol and adds slashes and/or
;;; vertical bars to it to make it readable again.
;;; vertical bars to it to make it readable again.
...
@@ -605,127 +796,52 @@
...
@@ -605,127 +796,52 @@
;;;; Recursive Datatype Printing Subfunctions
;;;; Recursive objects.
(
defun
output-list
(
list
stream
&optional
(
currlevel
0
))
(
defun
output-list
(
list
stream
)
(
write-char
#\(
stream
)
(
decend-into
(
list
stream
)
(
do
((
list
list
(
cdr
list
))
(
write-char
#\(
stream
)
(
currlength
0
(
1+
currlength
)))
(
let
((
length
0
)
((
or
(
null
list
)
(
list
list
))
(
and
(
not
(
null
*print-length*
))
(
loop
(
>=
currlength
(
the
fixnum
*print-length*
))))
(
punt-if-too-long
length
stream
)
(
if
(
not
(
null
list
))
(
write-string
" ..."
stream
))
(
output-object
(
pop
list
)
stream
)
(
write-char
#\)
stream
))
(
unless
list
(
declare
(
fixnum
currlength
))
(
return
))
;;If we are not printing the first object, we should space first.
(
when
(
or
(
atom
list
)
(
check-for-circularity
list
))
(
if
(
>
currlength
0
)
(
write-char
#\space
stream
))
(
write-string
" . "
stream
)
;;Print whatever the car of the list is, at this level.
(
output-object
list
stream
)
(
output-object
(
car
list
)
stream
currlevel
)
(
return
))
(
cond
((
not
(
or
(
consp
(
cdr
list
))
(
write-char
#\space
stream
)
(
null
(
cdr
list
))))
(
incf
length
)))
(
write-string
" . "
stream
)
(
write-char
#\)
stream
)))
(
output-object
(
cdr
list
)
stream
currlevel
)
(
write-char
#\)
stream
)
(
return
())))))
(
defun
output-vector
(
vector
stream
)
(
declare
(
vector
vector
))
(
defun
output-vector
(
vector
stream
&optional
(
currlevel
0
))
(
if
(
or
*print-array*
*print-readably*
)
(
declare
(
fixnum
currlevel
))
(
typecase
vector
(
cond
((
not
*print-array*
)
(
bit-vector
(
output-terse-array
vector
stream
currlevel
))
(
write-string
"#*"
stream
)
(
T
(
dotimes
(
i
(
length
vector
))
(
if
(
bit-vector-p
vector
)
(
output-object
(
aref
vector
i
)
stream
)))
(
write-string
"#*"
stream
)
(
string
(
write-string
"#("
stream
))
(
if
(
or
*print-escape*
*print-readably*
)
(
do
((
currlength
0
(
1+
currlength
))
(
quote-string
vector
stream
)
(
vlength
(
length
(
the
vector
vector
)))
(
write-string
vector
stream
)))
(
not-bit-vector-p
(
not
(
bit-vector-p
vector
))))
((
or
(
and
(
not
(
null
*print-length*
))
(
>=
currlength
(
the
fixnum
*print-length*
)))
(
=
currlength
vlength
))
(
if
(
not
(
=
currlength
vlength
))
(
write-string
" ..."
stream
))
(
if
not-bit-vector-p
(
write-char
#\)
stream
)))
(
declare
(
fixnum
currlength
vlength
))
;;Put a space before every element except the first
;; and not in bit vectors.
(
if
(
and
(
>
currlength
0
)
not-bit-vector-p
)
(
write-char
#\space
stream
))
;;Output an element of the vector
(
output-object
(
aref
vector
currlength
)
stream
currlevel
)))))
(
defun
output-array
(
array
stream
&optional
(
currlevel
0
))
"Outputs the printed representation of any array in either the #< or #A form."
(
let
((
rank
(
array-rank
array
)))
(
cond
((
not
*print-array*
)
(
output-terse-array
array
stream
rank
))
(
T
(
output-array-guts
array
rank
stream
currlevel
)))))
;;; Master function for outputing the #A form of an array
;;;
(
defun
output-array-guts
(
array
rank
stream
currlevel
)
(
write-char
#\#
stream
)
(
let
((
*print-base*
10
))
(
output-integer
rank
stream
))
(
write-char
#\A
stream
)
(
with-array-data
((
data
array
)
(
start
)
(
end
))
(
declare
(
ignore
end
))
(
sub-output-array-guts
data
(
array-dimensions
array
)
stream
currlevel
start
)))
;;; Some Ideas stolen from Skef Wholey.
;;; Helping function for above.
(
defun
sub-output-array-guts
(
array
dimensions
stream
currlevel
index
)
(
declare
(
fixnum
currlevel
index
))
(
cond
((
null
dimensions
)
(
output-object
(
aref
array
index
)
stream
currlevel
)
(
1+
index
))
((
and
(
not
(
null
*print-level*
))
(
>=
currlevel
(
the
fixnum
*print-level*
)))
(
write-char
#\#
stream
)
index
)
(
t
(
t
(
write-char
#\(
stream
)
(
when
(
and
*print-readably*
(
do
((
index
index
)
(
not
(
eq
(
array-element-type
vector
)
't
)))
(
times
0
(
1+
times
))
(
error
"Cannot print ~S in a readable format."
vector
))
(
limit
(
pop
dimensions
)))
(
decend-into
(
vector
stream
)
((
or
(
=
times
limit
)
(
write-string
"#("
stream
)
(
and
(
not
(
null
*print-length*
))
(
dotimes
(
i
(
length
vector
))
(
=
times
*print-length*
)))
(
unless
(
zerop
i
)
(
if
(
not
(
=
times
limit
))
(
write-char
#\space
stream
))
(
write-string
" ...)"
stream
)
(
punt-if-too-long
i
stream
)
(
write-char
#\)
stream
))
(
output-object
(
aref
vector
i
)
stream
))
index
)
(
write-string
")"
stream
))))
(
declare
(
fixnum
index
times
limit
))
(
output-terse-array
vector
stream
)))
(
if
(
not
(
zerop
times
))
(
write-char
#\space
stream
))
(
setq
index
(
sub-output-array-guts
array
dimensions
stream
(
1+
currlevel
)
index
))))))
;;; Used to output the #< form of any array.
;;;
(
defun
output-terse-array
(
array
stream
rank
)
(
write-string
"#<"
stream
)
(
cond
((
vectorp
array
)
(
if
(
bit-vector-p
array
)
(
write-string
"Bit-vector"
stream
)
(
write-string
"Vector"
stream
)))
(
T
(
write-string
"Array, rank "
stream
)
(
output-integer
rank
stream
)))
(
finish-random
array
stream
))
;;; Structure Printing. These days we can always pass the buck to the
;;; Defstruct code.
(
defun
output-structure
(
structure
stream
currlevel
)
(
funcall
(
or
(
info
type
printer
(
structure-ref
structure
0
))
#'
c::default-structure-print
)
structure
stream
currlevel
))
;;;; Functions to help print strings.
;;; QUOTE-STRING -- Internal.
;;; QUOTE-STRING -- Internal.
;;;
;;;
...
@@ -744,46 +860,97 @@
...
@@ -744,46 +860,97 @@
(
write-char
char
stream
))
(
write-char
char
stream
))
(
write-char
#\"
stream
)))
(
write-char
#\"
stream
)))
(
defun
output-array
(
array
stream
)
"Outputs the printed representation of any array in either the #< or #A
form."
(
if
(
or
*print-array*
*print-readably*
)
(
output-array-guts
array
stream
)
(
output-terse-array
array
stream
)))
;;; Master function for outputing the #A form of an array
;;;
(
defun
output-array-guts
(
array
stream
)
(
when
(
and
*print-readably*
(
not
(
eq
(
array-element-type
array
)
t
)))
(
error
"Arrays of element-type ~S cannot be printed readably."
(
array-element-type
array
)))
(
write-char
#\#
stream
)
(
let
((
*print-base*
10
))
(
output-integer
(
array-rank
array
)
stream
))
(
write-char
#\A
stream
)
(
with-array-data
((
data
array
)
(
start
)
(
end
))
(
declare
(
ignore
end
))
(
sub-output-array-guts
data
(
array-dimensions
array
)
stream
start
)))
(
defun
sub-output-array-guts
(
array
dimensions
stream
index
)
(
declare
(
simple-vector
array
)
(
fixnum
index
))
(
cond
((
null
dimensions
)
(
output-object
(
svref
array
index
)
stream
))
(
t
(
decend-into
(
nil
stream
)
(
write-char
#\(
stream
)
(
let*
((
dimension
(
car
dimensions
))
(
dimensions
(
cdr
dimensions
))
(
count
(
reduce
#'
*
dimensions
)))
(
dotimes
(
i
dimension
)
(
unless
(
zerop
i
)
(
write-char
#\space
stream
))
(
punt-if-too-long
i
stream
)
(
sub-output-array-guts
array
dimensions
stream
index
)
(
incf
index
count
)))
(
write-char
#\)
stream
)))))
;;; Used to output the #< form of any array.
;;;
(
defun
output-terse-array
(
array
stream
)
(
let
((
*print-level*
nil
)
(
*print-length*
nil
))
(
print-unreadable-object
(
array
stream
:type
t
:identity
t
))))
;;; Structure Printing. These days we can always pass the buck to the
;;; Defstruct code.
(
defun
output-structure
(
structure
stream
)
(
decend-into
(
structure
stream
)
(
funcall
(
or
(
info
type
printer
(
structure-ref
structure
0
))
#'
c::default-structure-print
)
structure
stream
*current-level*
)))
(
defun
whitespace-char-p
(
char
)
"Determines whether or not the character is considered whitespace."
(
or
(
char=
char
#\space
)
(
char=
char
#\tab
)
(
char=
char
#\return
)
(
char=
char
#\linefeed
)))
;;;; Integer, ratio, complex printing.
;;;; Integer, ratio,
and
complex printing.
(i.e. everything but floats)
(
defun
output-integer
(
integer
stream
)
(
defun
output-integer
(
integer
stream
)
(
cond
((
not
(
and
(
fixnump
*print-base*
)
(
>
(
the
fixnum
*print-base*
)
1
)))
(
unless
(
and
(
fixnump
*print-base*
)
(
let
((
obase
*print-base*
))
(
<
1
*print-base*
37
))
(
setq
*print-base*
10.
)
(
let
((
obase
*print-base*
))
(
error
"~A is not a reasonable value for *Print-Base*."
obase
)))
(
setq
*print-base*
10.
)
;; Otherwise print the base
(
error
"~A is not a reasonable value for *Print-Base*."
obase
)))
(
T
(
cond
((
and
(
not
(
=
*print-base*
10.
))
(
when
(
and
(
not
(
=
*print-base*
10.
))
*print-radix*
)
*print-radix*
)
;; First print leading base information, if any.
;; First print leading base information, if any.
(
write-char
#\#
stream
)
(
write-char
#\#
stream
)
(
write-char
(
case
*print-base*
(
write-char
(
case
*print-base*
(
2.
#\b
)
(
2.
#\b
)
(
8.
#\o
)
(
8.
#\o
)
(
16.
#\x
)
(
16.
#\x
)
(
T
(
let
((
fixbase
*print-base*
)
(
T
(
let
((
fixbase
*print-base*
)
(
*print-base*
10.
)
(
*print-base*
10.
)
(
*print-radix*
()))
(
*print-radix*
()))
(
sub-output-integer
fixbase
stream
))
(
sub-output-integer
fixbase
stream
))
#\r
))
#\r
))
stream
)))
stream
))
;; Then output a minus sign if the number is negative, then output
;; Then output a minus sign if the number is negative, then output
;; the absolute value of the number.
;; the absolute value of the number.
(
cond
((
bignump
integer
)
(
print-bignum
integer
stream
))
(
cond
((
bignump
integer
)
(
print-bignum
integer
stream
))
((
<
integer
0
)
((
<
integer
0
)
(
write-char
#\-
stream
)
(
write-char
#\-
stream
)
(
sub-output-integer
(
-
integer
)
stream
))
(
sub-output-integer
(
-
integer
)
stream
))
(
T
(
sub-output-integer
integer
stream
)))
(
t
;; Print any trailing base information, if any.
(
sub-output-integer
integer
stream
)))
(
if
(
and
(
=
*print-base*
10.
)
*print-radix*
)
;; Print any trailing base information, if any.
(
write-char
#\.
stream
)))))
(
if
(
and
(
=
*print-base*
10.
)
*print-radix*
)
(
write-char
#\.
stream
)))
(
defun
sub-output-integer
(
integer
stream
)
(
defun
sub-output-integer
(
integer
stream
)
(
let
((
quotient
())
(
let
((
quotient
())
...
@@ -800,30 +967,6 @@
...
@@ -800,30 +967,6 @@
(
+
(
char-code
#\0
)
remainder
)))
(
+
(
char-code
#\0
)
remainder
)))
stream
)))
stream
)))
(
defun
output-ratio
(
ratio
stream
)
(
when
*print-radix*
(
write-char
#\#
stream
)
(
case
*print-base*
(
2
(
write-char
#\b
stream
))
(
8
(
write-char
#\o
stream
))
(
16
(
write-char
#\x
stream
))
(
t
(
write
*print-base*
:stream
stream
:radix
nil
:base
10
)))
(
write-char
#\r
stream
))
(
let
((
*print-radix*
nil
))
(
output-integer
(
numerator
ratio
)
stream
)
(
write-char
#\/
stream
)
(
output-integer
(
denominator
ratio
)
stream
)))
(
defun
output-complex
(
complex
stream
)
(
write-string
"#C("
stream
)
(
output-object
(
realpart
complex
)
stream
)
(
write-char
#\space
stream
)
(
output-object
(
imagpart
complex
)
stream
)
(
write-char
#\)
stream
))
;;;; Bignum printing
;;;; Bignum printing
;;; Written by Steven Handerson
;;; Written by Steven Handerson
...
@@ -881,7 +1024,30 @@
...
@@ -881,7 +1024,30 @@
(
sub-output-integer
fix
stream
)))))
(
sub-output-integer
fix
stream
)))))
(
defun
output-ratio
(
ratio
stream
)
(
when
*print-radix*
(
write-char
#\#
stream
)
(
case
*print-base*
(
2
(
write-char
#\b
stream
))
(
8
(
write-char
#\o
stream
))
(
16
(
write-char
#\x
stream
))
(
t
(
write
*print-base*
:stream
stream
:radix
nil
:base
10
)))
(
write-char
#\r
stream
))
(
let
((
*print-radix*
nil
))
(
output-integer
(
numerator
ratio
)
stream
)
(
write-char
#\/
stream
)
(
output-integer
(
denominator
ratio
)
stream
)))
(
defun
output-complex
(
complex
stream
)
(
write-string
"#C("
stream
)
(
output-object
(
realpart
complex
)
stream
)
(
write-char
#\space
stream
)
(
output-object
(
imagpart
complex
)
stream
)
(
write-char
#\)
stream
))
;;;; Float printing.
;;;
;;;
;;; Written by Bill Maddox
;;; Written by Bill Maddox
;;;
;;;
...
@@ -1262,17 +1428,7 @@
...
@@ -1262,17 +1428,7 @@
(
print-float-exponent
x
(
1-
ex
)
stream
)))))
(
print-float-exponent
x
(
1-
ex
)
stream
)))))
;;;; Output Character
;;;; Other leaf objects.
;;; FUNNY-CHARACTER-CHAR-P returns a predicate which determines whether a
;;; character must be slashified when being output.
;;;
(
defmacro
funny-character-char-p
(
char
)
; (and (not (zerop (char-bits ,char)))
; (not (zerop (logand (aref character-attributes (char-code ,char))
; funny-attribute))))
`
(
not
(
zerop
(
logand
(
aref
character-attributes
(
char-code
,
char
))
funny-attribute
))))
;;; OUTPUT-CHARACTER -- Internal
;;; OUTPUT-CHARACTER -- Internal
;;;
;;;
...
@@ -1280,7 +1436,7 @@
...
@@ -1280,7 +1436,7 @@
;;; character name or the character in the #\char format.
;;; character name or the character in the #\char format.
;;;
;;;
(
defun
output-character
(
char
stream
)
(
defun
output-character
(
char
stream
)
(
if
*print-escape*
(
if
(
or
*print-escape*
*print-readably*
)
(
let
((
name
(
char-name
char
)))
(
let
((
name
(
char-name
char
)))
(
write-string
"#\\"
stream
)
(
write-string
"#\\"
stream
)
(
if
name
(
if
name
...
@@ -1288,8 +1444,34 @@
...
@@ -1288,8 +1444,34 @@
(
write-char
char
stream
)))
(
write-char
char
stream
)))
(
write-char
char
stream
)))
(
write-char
char
stream
)))
(
defun
output-sap
(
sap
stream
)
(
declare
(
type
system-area-pointer
sap
))
(
cond
(
*read-eval*
(
format
stream
"#.(~S #x~8,'0X)"
'int-sap
(
sap-int
sap
)))
((
not
*print-readably*
)
(
format
stream
"#<System-Area-Pointer: #x~8,'0X>"
(
sap-int
sap
)))
(
t
(
error
"Cannot print system-area-pointers with *READ-EVAL* NIL and ~
*PRINT-READABLY* T."
))))
(
defun
output-weak-pointer
(
weak-pointer
stream
)
(
declare
(
type
weak-pointer
weak-pointer
))
(
when
*print-readably*
(
error
"Cannot print weak poinrts with *PRINT-READABLY* T."
))
(
multiple-value-bind
(
value
validp
)
(
weak-pointer-value
weak-pointer
)
(
cond
(
validp
(
write-string
"#<Weak Pointer: "
stream
)
(
write
value
:stream
stream
)
(
write-char
#\>
stream
))
(
t
(
write-string
"#<Broken Weak Pointer>"
stream
)))))
;;;;
Random and Miscellaneous Print Subfunctions
;;;;
Various flavors of function pointers.
;;; OUTPUT-FUNCTION-OBJECT outputs the main part of the printed
;;; OUTPUT-FUNCTION-OBJECT outputs the main part of the printed
...
@@ -1314,89 +1496,62 @@
...
@@ -1314,89 +1496,62 @@
(
let
((
*print-level*
3
))
(
let
((
*print-level*
3
))
(
format
stream
"Interpreted Function ~S"
(
or
name
def
)))))
(
format
stream
"Interpreted Function ~S"
(
or
name
def
)))))
(
defun
output-function
(
function
stream
)
(
print-unreadable-object
(
function
stream
:identity
t
)
(
case
(
get-type
function
)
((
#.
vm:function-header-type
#.
vm:closure-function-header-type
)
(
output-function-object
function
stream
))
(
#.
vm:closure-header-type
(
cond
((
eval:interpreted-function-p
function
)
(
output-interpreted-function
function
stream
))
(
t
(
write-string
"Closure Over "
stream
)
(
output-function-object
(
%primitive
c::closure-function
function
)
stream
)))))))
;;; FINISH-RANDOM is a helping function for OUTPUT-RANDOM below.
;;; It outputs the numerical value of the low 28 bits of
;;;; Catch-all for unknown things.
;;; RANDOM-OBJECT, enclosed in braces, followed by the closing
;;; angle-bracket (">") random objects have at the end. This
;;; is used to distringuish random objects of the same type.
(
defun
finish-random
(
random-object
stream
)
(
write-string
" {"
stream
)
(
let
((
*print-base*
16
))
(
output-integer
(
%primitive
make-fixnum
random-object
)
stream
))
(
write-string
"}>"
stream
))
;;; Functions Objects and other implmentation specific objects
;;; are output here.
(
defun
output-random
(
object
stream
)
(
defun
output-random
(
object
stream
)
(
w
ri
te-string
"#<"
stream
)
(
p
ri
nt-unreadable-object
(
object
stream
:identity
t
)
(
let
((
lowtag
(
get-lowtag
object
)))
(
let
((
lowtag
(
get-lowtag
object
)))
(
case
lowtag
(
case
lowtag
(
(
#.
vm:other-pointer-type
#.
vm:function-pointer-type
)
(
#.
vm:other-pointer-type
(
let
((
type
(
get-type
object
)))
(
let
((
type
(
get-type
object
)))
(
case
type
(
case
type
(
#.
vm:code-header-type
(
#.
vm:code-header-type
(
let
((
dinfo
(
code-header-ref
object
vm:code-debug-info-slot
)))
(
let
((
dinfo
(
code-header-ref
object
vm:code-debug-info-slot
)))
(
cond
((
eq
dinfo
:bogus-lra
)
(
cond
((
eq
dinfo
:bogus-lra
)
(
write-string
"Bogus Code Object"
stream
))
(
write-string
"Bogus Code Object"
stream
))
(
t
(
t
(
write-string
"Code Object"
stream
)
(
write-string
"Code Object"
stream
)
(
when
dinfo
(
when
dinfo
(
write-char
#\space
stream
)
(
write-char
#\space
stream
)
(
output-object
(
c::compiled-debug-info-name
dinfo
)
(
output-object
(
c::compiled-debug-info-name
dinfo
)
stream
))))))
stream
))))))
(
(
#.
vm:
function-header-type
#.
vm:closure-function
-header-type
)
(
#.
vm:
return-pc
-header-type
(
output-function-object
o
bject
stream
))
(
write-string
"Return PC O
bject
"
stream
))
(
#.
vm:
return-pc
-header-type
(
#.
vm:
value-cell
-header-type
(
write-string
"
Return PC Object
"
stream
)
)
(
write-string
"
Value Cell
"
stream
)
(
#.
vm:closure-header-type
(
output-object
(
%primitive
value-cell-ref
object
)
stream
))
(
cond
(
t
((
eval:interpreted-function-p
object
)
(
write-string
"Unknown Pointer Object, type="
stream
)
(
output-interpreted-function
object
stream
))
(
let
((
*print-base*
16
)
(
*print-radix*
t
))
(
t
(
output-integer
type
stream
))))))
(
write-string
"Closure Over "
stream
)
((
#.
vm:function-pointer-type
(
output-function-object
(
%primitive
c::closure-function
object
)
#.
vm:structure-pointer-type
stream
)))
)
#.
vm:list-pointer-type
)
(
#.
vm:value-cell-header-type
(
write-string
"Unknown Pointer Object, type="
stream
))
(
write-string
"Value Cell "
stream
)
(
t
(
output-object
(
%primitive
value-cell-ref
object
)
stream
)
)
(
case
(
get-type
object
)
(
#.
vm:unbound-marker-type
(
#.
vm:unbound-marker-type
(
write-string
"Unbound Marker"
stream
))
(
write-string
"Unbound Marker"
))
(
t
(
t
(
write-string
"Unknown Object, type="
stream
)
(
write-string
"Unknown Immediate Object, lowtag="
stream
)
(
let
((
*print-base*
2
)
(
*print-radix*
t
))
(
output-integer
lowtag
stream
))
(
write-string
", type="
stream
)
(
let
((
*print-base*
16
)
(
*print-radix*
t
))
(
let
((
*print-base*
16
)
(
*print-radix*
t
))
(
output-integer
type
stream
))))))
(
output-integer
(
get-type
object
)
stream
)))))))))
(
#.
vm:structure-pointer-type
(
write-string
"Structure?"
))
(
#.
vm:list-pointer-type
(
write-string
"List?"
))
(
t
(
write-string
"Unknown Immediate Object, lowtag="
stream
)
(
let
((
*print-base*
2
)
(
*print-radix*
t
))
(
output-integer
lowtag
stream
))
(
write-string
", type="
stream
)
(
let
((
*print-base*
16
)
(
*print-radix*
t
))
(
output-integer
(
get-type
object
)
stream
)))))
(
finish-random
object
stream
))
(
defun
output-sap
(
sap
stream
)
(
declare
(
type
system-area-pointer
sap
))
(
write-string
"#<System-Area pointer: "
stream
)
(
let
((
*print-base*
16
)
(
*print-radix*
t
))
(
output-integer
(
sap-int
sap
)
stream
))
(
write-char
#\>
stream
))
(
defun
output-weak-pointer
(
weak-pointer
stream
)
(
declare
(
type
weak-pointer
weak-pointer
))
(
multiple-value-bind
(
value
validp
)
(
weak-pointer-value
weak-pointer
)
(
cond
(
validp
(
write-string
"#<Weak Pointer: "
stream
)
(
write
value
:stream
stream
)
(
write-char
#\>
stream
))
(
t
(
write-string
"#<Broken Weak Pointer>"
stream
)))))
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment