aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorRichard M. Stallman1992-10-07 09:09:19 +0000
committerRichard M. Stallman1992-10-07 09:09:19 +0000
commitfb252f97f1875b6e06ff5bf95b088557caf6cdcd (patch)
tree6a2a0e95e5b5768980eb1d77e36ac12be78220cc
parent72b2181785d12fe97e4518bb62c4fe034c49915c (diff)
downloademacs-fb252f97f1875b6e06ff5bf95b088557caf6cdcd.tar.gz
emacs-fb252f97f1875b6e06ff5bf95b088557caf6cdcd.zip
CP:: changed to cust-print- in all names.
Lots of doc fixes.
-rw-r--r--lisp/emacs-lisp/cust-print.el261
1 files changed, 130 insertions, 131 deletions
diff --git a/lisp/emacs-lisp/cust-print.el b/lisp/emacs-lisp/cust-print.el
index 2dc18d43f93..6ce301cd3d5 100644
--- a/lisp/emacs-lisp/cust-print.el
+++ b/lisp/emacs-lisp/cust-print.el
@@ -93,7 +93,6 @@
93;;; Code: 93;;; Code:
94 94
95(provide 'custom-print) 95(provide 'custom-print)
96;; Abbreviated package name: "CP"
97 96
98;;(defvar print-length nil 97;;(defvar print-length nil
99;; "*Controls how many elements of a list, at each level, are printed. 98;; "*Controls how many elements of a list, at each level, are printed.
@@ -104,10 +103,10 @@
104 103
105If nil, printing proceeds recursively and may lead to 104If nil, printing proceeds recursively and may lead to
106max-lisp-eval-depth being exceeded or an untrappable error may occur: 105max-lisp-eval-depth being exceeded or an untrappable error may occur:
107\"Apparently circular structure being printed.\" Also see 106`Apparently circular structure being printed.'
108print-length and print-circle. 107Also see `print-length' and `print-circle'.
109 108
110If non-nil, components at levels equal to or greater than print-level 109If non-nil, components at levels equal to or greater than `print-level'
111are printed simply as \"#\". The object to be printed is at level 0, 110are printed simply as \"#\". The object to be printed is at level 0,
112and if the object is a list or vector, its top-level components are at 111and if the object is a list or vector, its top-level components are at
113level 1.") 112level 1.")
@@ -117,14 +116,14 @@ level 1.")
117 "*Controls the printing of recursive structures. 116 "*Controls the printing of recursive structures.
118 117
119If nil, printing proceeds recursively and may lead to 118If nil, printing proceeds recursively and may lead to
120max-lisp-eval-depth being exceeded or an untrappable error may occur: 119`max-lisp-eval-depth' being exceeded or an untrappable error may occur:
121\"Apparently circular structure being printed.\" Also see 120\"Apparently circular structure being printed.\" Also see
122print-length and print-level. 121`print-length' and `print-level'.
123 122
124If non-nil, shared substructures anywhere in the structure are printed 123If non-nil, shared substructures anywhere in the structure are printed
125with \"#n=\" before the first occurance (in the order of the print 124with `#N=' before the first occurance (in the order of the print
126representation) and \"#n#\" in place of each subsequent occurance, 125representation) and `#N#' in place of each subsequent occurance,
127where n is a positive decimal integer. 126where N is a positive decimal integer.
128 127
129Currently, there is no way to read this representation in Emacs.") 128Currently, there is no way to read this representation in Emacs.")
130 129
@@ -132,23 +131,23 @@ Currently, there is no way to read this representation in Emacs.")
132(defconst custom-print-list 131(defconst custom-print-list
133 nil 132 nil
134 ;; e.g. '((floatp . float-to-string)) 133 ;; e.g. '((floatp . float-to-string))
135 "If non-nil, an alist for printing of custom list objects. 134 "An alist for custom printing of lists.
136Pairs are of the form (pred . converter). If the predicate is true 135Pairs are of the form (PRED . CONVERTER). If PREDICATE is true
137for an object, the converter is called with the object and should 136for an object, then CONVERTER is called with the object and should
138return a string which will be printed with princ. 137return a string to be printed with `princ'.
139Also see custom-print-vector.") 138Also see `custom-print-vector'.")
140 139
141(defconst custom-print-vector 140(defconst custom-print-vector
142 nil 141 nil
143 "If non-nil, an alist for printing of custom vector objects. 142 "An alist for custom printing of vectors.
144Pairs are of the form (pred . converter). If the predicate is true 143Pairs are of the form (PRED . CONVERTER). If PREDICATE is true
145for an object, the converter is called with the object and should 144for an object, then CONVERTER is called with the object and should
146return a string which will be printed with princ. 145return a string to be printed with `princ'.
147Also see custom-print-list.") 146Also see `custom-print-list'.")
148 147
149 148
150(defun add-custom-print-list (pred converter) 149(defun add-custom-print-list (pred converter)
151 "Add the pair, a PREDICATE and a CONVERTER, to custom-print-list. 150 "Add a pair of PREDICATE and CONVERTER to `custom-print-list'.
152Any pair that has the same PREDICATE is first removed." 151Any pair that has the same PREDICATE is first removed."
153 (setq custom-print-list (cons (cons pred converter) 152 (setq custom-print-list (cons (cons pred converter)
154 (delq (assq pred custom-print-list) 153 (delq (assq pred custom-print-list)
@@ -157,7 +156,7 @@ Any pair that has the same PREDICATE is first removed."
157 156
158 157
159(defun add-custom-print-vector (pred converter) 158(defun add-custom-print-vector (pred converter)
160 "Add the pair, a PREDICATE and a CONVERTER, to custom-print-vector. 159 "Add a pair of PREDICATE and CONVERTER to `custom-print-vector'.
161Any pair that has the same PREDICATE is first removed." 160Any pair that has the same PREDICATE is first removed."
162 (setq custom-print-vector (cons (cons pred converter) 161 (setq custom-print-vector (cons (cons pred converter)
163 (delq (assq pred custom-print-vector) 162 (delq (assq pred custom-print-vector)
@@ -167,28 +166,28 @@ Any pair that has the same PREDICATE is first removed."
167;;==================================================== 166;;====================================================
168;; Saving and restoring internal printing routines. 167;; Saving and restoring internal printing routines.
169 168
170(defun CP::set-function-cell (symbol-pair) 169(defun cust-print-set-function-cell (symbol-pair)
171 (fset (car symbol-pair) 170 (fset (car symbol-pair)
172 (symbol-function (car (cdr symbol-pair))))) 171 (symbol-function (car (cdr symbol-pair)))))
173 172
174 173
175(if (not (fboundp 'CP::internal-prin1)) 174(if (not (fboundp 'cust-print-internal-prin1))
176 (mapcar 'CP::set-function-cell 175 (mapcar 'cust-print-set-function-cell
177 '((CP::internal-prin1 prin1) 176 '((cust-print-internal-prin1 prin1)
178 (CP::internal-princ princ) 177 (cust-print-internal-princ princ)
179 (CP::internal-print print) 178 (cust-print-internal-print print)
180 (CP::internal-prin1-to-string prin1-to-string) 179 (cust-print-internal-prin1-to-string prin1-to-string)
181 (CP::internal-format format) 180 (cust-print-internal-format format)
182 (CP::internal-message message) 181 (cust-print-internal-message message)
183 (CP::internal-error error)))) 182 (cust-print-internal-error error))))
184 183
185 184
186(defun install-custom-print-funcs () 185(defun install-custom-print-funcs ()
187 "Replace print functions with general, customizable, lisp versions. 186 "Replace print functions with general, customizable, Lisp versions.
188The internal subroutines are saved away and may be recovered with 187The internal subroutines are saved away, and you can reinstall them
189uninstall-custom-print-funcs." 188by running `uninstall-custom-print-funcs'."
190 (interactive) 189 (interactive)
191 (mapcar 'CP::set-function-cell 190 (mapcar 'cust-print-set-function-cell
192 '((prin1 custom-prin1) 191 '((prin1 custom-prin1)
193 (princ custom-princ) 192 (princ custom-princ)
194 (print custom-print) 193 (print custom-print)
@@ -201,14 +200,14 @@ uninstall-custom-print-funcs."
201(defun uninstall-custom-print-funcs () 200(defun uninstall-custom-print-funcs ()
202 "Reset print functions to their internal subroutines." 201 "Reset print functions to their internal subroutines."
203 (interactive) 202 (interactive)
204 (mapcar 'CP::set-function-cell 203 (mapcar 'cust-print-set-function-cell
205 '((prin1 CP::internal-prin1) 204 '((prin1 cust-print-internal-prin1)
206 (princ CP::internal-princ) 205 (princ cust-print-internal-princ)
207 (print CP::internal-print) 206 (print cust-print-internal-print)
208 (prin1-to-string CP::internal-prin1-to-string) 207 (prin1-to-string cust-print-internal-prin1-to-string)
209 (format CP::internal-format) 208 (format cust-print-internal-format)
210 (message CP::internal-message) 209 (message cust-print-internal-message)
211 (error CP::internal-error) 210 (error cust-print-internal-error)
212 ))) 211 )))
213 212
214 213
@@ -217,47 +216,47 @@ uninstall-custom-print-funcs."
217;; (or princ) -- so far only the printing and formatting subrs. 216;; (or princ) -- so far only the printing and formatting subrs.
218 217
219(defun custom-prin1 (object &optional stream) 218(defun custom-prin1 (object &optional stream)
220 "Replacement for standard prin1. 219 "Replacement for standard `prin1'.
221Uses the appropriate printer depending on the values of print-level 220Uses the appropriate printer depending on the values of `print-level'
222and print-circle (which see). 221and `print-circle' (which see).
223 222
224Output the printed representation of OBJECT, any Lisp object. 223Output the printed representation of OBJECT, any Lisp object.
225Quoting characters are printed when needed to make output that `read' 224Quoting characters are printed when needed to make output that `read'
226can handle, whenever this is possible. 225can handle, whenever this is possible.
227Output stream is STREAM, or value of `standard-output' (which see)." 226Output stream is STREAM, or value of `standard-output' (which see)."
228 (CP::top-level object stream 'CP::internal-prin1)) 227 (cust-print-top-level object stream 'cust-print-internal-prin1))
229 228
230 229
231(defun custom-princ (object &optional stream) 230(defun custom-princ (object &optional stream)
232 "Same as custom-prin1 except no quoting." 231 "Same as `custom-prin1' except no quoting."
233 (CP::top-level object stream 'CP::internal-princ)) 232 (cust-print-top-level object stream 'cust-print-internal-princ))
234 233
235(defun custom-prin1-to-string-func (c) 234(defun custom-prin1-to-string-func (c)
236 "Stream function for custom-prin1-to-string." 235 "Stream function for `custom-prin1-to-string'."
237 (setq prin1-chars (cons c prin1-chars))) 236 (setq prin1-chars (cons c prin1-chars)))
238 237
239(defun custom-prin1-to-string (object) 238(defun custom-prin1-to-string (object)
240 "Replacement for standard prin1-to-string." 239 "Replacement for standard `prin1-to-string'."
241 (let ((prin1-chars nil)) 240 (let ((prin1-chars nil))
242 (custom-prin1 object 'custom-prin1-to-string-func) 241 (custom-prin1 object 'custom-prin1-to-string-func)
243 (concat (nreverse prin1-chars)))) 242 (concat (nreverse prin1-chars))))
244 243
245 244
246(defun custom-print (object &optional stream) 245(defun custom-print (object &optional stream)
247 "Replacement for standard print." 246 "Replacement for standard `print'."
248 (CP::internal-princ "\n") 247 (cust-print-internal-princ "\n")
249 (custom-prin1 object stream) 248 (custom-prin1 object stream)
250 (CP::internal-princ "\n")) 249 (cust-print-internal-princ "\n"))
251 250
252 251
253(defun custom-format (fmt &rest args) 252(defun custom-format (fmt &rest args)
254 "Replacement for standard format. 253 "Replacement for standard `format'.
255 254
256Calls format after first making strings for list or vector args. 255Calls format after first making strings for list or vector args.
257The format specification for such args should be %s in any case, so a 256The format specification for such args should be `%s' in any case, so a
258string argument will also work. The string is generated with 257string argument will also work. The string is generated with
259custom-prin1-to-string, which quotes quotable characters." 258`custom-prin1-to-string', which quotes quotable characters."
260 (apply 'CP::internal-format fmt 259 (apply 'cust-print-internal-format fmt
261 (mapcar (function (lambda (arg) 260 (mapcar (function (lambda (arg)
262 (if (or (listp arg) (vectorp arg)) 261 (if (or (listp arg) (vectorp arg))
263 (custom-prin1-to-string arg) 262 (custom-prin1-to-string arg)
@@ -267,12 +266,12 @@ custom-prin1-to-string, which quotes quotable characters."
267 266
268 267
269(defun custom-message (fmt &rest args) 268(defun custom-message (fmt &rest args)
270 "Replacement for standard message that works like custom-format." 269 "Replacement for standard `message' that works like `custom-format'."
271 ;; It doesnt work to princ the result of custom-format 270 ;; It doesnt work to princ the result of custom-format
272 ;; because the echo area requires special handling 271 ;; because the echo area requires special handling
273 ;; to avoid duplicating the output. CP::internal-message does it right. 272 ;; to avoid duplicating the output. cust-print-internal-message does it right.
274 ;; (CP::internal-princ (apply 'custom-format fmt args)) 273 ;; (cust-print-internal-princ (apply 'custom-format fmt args))
275 (apply 'CP::internal-message fmt 274 (apply 'cust-print-internal-message fmt
276 (mapcar (function (lambda (arg) 275 (mapcar (function (lambda (arg)
277 (if (or (listp arg) (vectorp arg)) 276 (if (or (listp arg) (vectorp arg))
278 (custom-prin1-to-string arg) 277 (custom-prin1-to-string arg)
@@ -281,87 +280,87 @@ custom-prin1-to-string, which quotes quotable characters."
281 280
282 281
283(defun custom-error (fmt &rest args) 282(defun custom-error (fmt &rest args)
284 "Replacement for standard error that uses custom-format" 283 "Replacement for standard `error' that uses `custom-format'"
285 (signal 'error (list (apply 'custom-format fmt args)))) 284 (signal 'error (list (apply 'custom-format fmt args))))
286 285
287 286
288;;========================================= 287;;=========================================
289;; Support for custom prin1 and princ 288;; Support for custom prin1 and princ
290 289
291(defun CP::top-level (object stream internal-printer) 290(defun cust-print-top-level (object stream internal-printer)
292 "Set up for printing." 291 "Set up for printing."
293 (let ((standard-output (or stream standard-output)) 292 (let ((standard-output (or stream standard-output))
294 (circle-table (and print-circle (CP::preprocess-circle-tree object))) 293 (circle-table (and print-circle (cust-print-preprocess-circle-tree object)))
295 (level (or print-level -1)) 294 (level (or print-level -1))
296 ) 295 )
297 296
298 (fset 'CP::internal-printer internal-printer) 297 (fset 'cust-print-internal-printer internal-printer)
299 (fset 'CP::low-level-prin 298 (fset 'cust-print-low-level-prin
300 (cond 299 (cond
301 ((or custom-print-list 300 ((or custom-print-list
302 custom-print-vector 301 custom-print-vector
303 print-level ; comment out for version 19 302 print-level ; comment out for version 19
304 ) 303 )
305 'CP::custom-object) 304 'cust-print-custom-object)
306 (circle-table 305 (circle-table
307 'CP::object) 306 'cust-print-object)
308 (t 'CP::internal-printer))) 307 (t 'cust-print-internal-printer)))
309 (fset 'CP::prin (if circle-table 'CP::circular 'CP::low-level-prin)) 308 (fset 'cust-print-prin (if circle-table 'cust-print-circular 'cust-print-low-level-prin))
310 309
311 (CP::prin object) 310 (cust-print-prin object)
312 object)) 311 object))
313 312
314 313
315(defun CP::object (object) 314;; Test object type and print accordingly.
316 "Test object type and print accordingly." 315(defun cust-print-object (object)
317 ;; Could be called as either CP::low-level-prin or CP::prin. 316 ;; Could be called as either cust-print-low-level-prin or cust-print-prin.
318 (cond 317 (cond
319 ((null object) (CP::internal-printer object)) 318 ((null object) (cust-print-internal-printer object))
320 ((consp object) (CP::list object)) 319 ((consp object) (cust-print-list object))
321 ((vectorp object) (CP::vector object)) 320 ((vectorp object) (cust-print-vector object))
322 ;; All other types, just print. 321 ;; All other types, just print.
323 (t (CP::internal-printer object)))) 322 (t (cust-print-internal-printer object))))
324 323
325 324
326(defun CP::custom-object (object) 325;; Test object type and print accordingly.
327 "Test object type and print accordingly." 326(defun cust-print-custom-object (object)
328 ;; Could be called as either CP::low-level-prin or CP::prin. 327 ;; Could be called as either cust-print-low-level-prin or cust-print-prin.
329 (cond 328 (cond
330 ((null object) (CP::internal-printer object)) 329 ((null object) (cust-print-internal-printer object))
331 330
332 ((consp object) 331 ((consp object)
333 (or (and custom-print-list 332 (or (and custom-print-list
334 (CP::custom-object1 object custom-print-list)) 333 (cust-print-custom-object1 object custom-print-list))
335 (CP::list object))) 334 (cust-print-list object)))
336 335
337 ((vectorp object) 336 ((vectorp object)
338 (or (and custom-print-vector 337 (or (and custom-print-vector
339 (CP::custom-object1 object custom-print-vector)) 338 (cust-print-custom-object1 object custom-print-vector))
340 (CP::vector object))) 339 (cust-print-vector object)))
341 340
342 ;; All other types, just print. 341 ;; All other types, just print.
343 (t (CP::internal-printer object)))) 342 (t (cust-print-internal-printer object))))
344 343
345 344
346(defun CP::custom-object1 (object alist) 345;; Helper for cust-print-custom-object.
347 "Helper for CP::custom-object. 346;; Print the custom OBJECT using the custom type ALIST.
348Print the custom OBJECT using the custom type ALIST. 347;; For the first predicate that matches the object, the corresponding
349For the first predicate that matches the object, the corresponding 348;; converter is evaluated with the object and the string that results is
350converter is evaluated with the object and the string that results is 349;; printed with princ. Return nil if no predicte matches the object.
351printed with princ. Return nil if no predicte matches the object." 350(defun cust-print-custom-object1 (object alist)
352 (while (and alist (not (funcall (car (car alist)) object))) 351 (while (and alist (not (funcall (car (car alist)) object)))
353 (setq alist (cdr alist))) 352 (setq alist (cdr alist)))
354 ;; If alist is not null, then something matched. 353 ;; If alist is not null, then something matched.
355 (if alist 354 (if alist
356 (CP::internal-princ 355 (cust-print-internal-princ
357 (funcall (cdr (car alist)) object) ; returns string 356 (funcall (cdr (car alist)) object) ; returns string
358 ))) 357 )))
359 358
360 359
361(defun CP::circular (object) 360(defun cust-print-circular (object)
362 "Printer for prin1 and princ that handles circular structures. 361 "Printer for `prin1' and `princ' that handles circular structures.
363If OBJECT appears multiply, and has not yet been printed, 362If OBJECT appears multiply, and has not yet been printed,
364prefix with label; if it has been printed, use #n# instead. 363prefix with label; if it has been printed, use `#N#' instead.
365Otherwise, print normally." 364Otherwise, print normally."
366 (let ((tag (assq object circle-table))) 365 (let ((tag (assq object circle-table)))
367 (if tag 366 (if tag
@@ -369,35 +368,35 @@ Otherwise, print normally."
369 (if (> id 0) 368 (if (> id 0)
370 (progn 369 (progn
371 ;; Already printed, so just print id. 370 ;; Already printed, so just print id.
372 (CP::internal-princ "#") 371 (cust-print-internal-princ "#")
373 (CP::internal-princ id) 372 (cust-print-internal-princ id)
374 (CP::internal-princ "#")) 373 (cust-print-internal-princ "#"))
375 ;; Not printed yet, so label with id and print object. 374 ;; Not printed yet, so label with id and print object.
376 (setcdr tag (- id)) ; mark it as printed 375 (setcdr tag (- id)) ; mark it as printed
377 (CP::internal-princ "#") 376 (cust-print-internal-princ "#")
378 (CP::internal-princ (- id)) 377 (cust-print-internal-princ (- id))
379 (CP::internal-princ "=") 378 (cust-print-internal-princ "=")
380 (CP::low-level-prin object) 379 (cust-print-low-level-prin object)
381 )) 380 ))
382 ;; Not repeated in structure. 381 ;; Not repeated in structure.
383 (CP::low-level-prin object)))) 382 (cust-print-low-level-prin object))))
384 383
385 384
386;;================================================ 385;;================================================
387;; List and vector processing for print functions. 386;; List and vector processing for print functions.
388 387
389(defun CP::list (list) 388;; Print a list using print-length, print-level, and print-circle.
390 "Print a list using print-length, print-level, and print-circle." 389(defun cust-print-list (list)
391 (if (= level 0) 390 (if (= level 0)
392 (CP::internal-princ "#") 391 (cust-print-internal-princ "#")
393 (let ((level (1- level))) 392 (let ((level (1- level)))
394 (CP::internal-princ "(") 393 (cust-print-internal-princ "(")
395 (let ((length (or print-length 0))) 394 (let ((length (or print-length 0)))
396 395
397 ;; Print the first element always (even if length = 0). 396 ;; Print the first element always (even if length = 0).
398 (CP::prin (car list)) 397 (cust-print-prin (car list))
399 (setq list (cdr list)) 398 (setq list (cdr list))
400 (if list (CP::internal-princ " ")) 399 (if list (cust-print-internal-princ " "))
401 (setq length (1- length)) 400 (setq length (1- length))
402 401
403 ;; Print the rest of the elements. 402 ;; Print the rest of the elements.
@@ -405,41 +404,41 @@ Otherwise, print normally."
405 (if (and (listp list) 404 (if (and (listp list)
406 (not (assq list circle-table))) 405 (not (assq list circle-table)))
407 (progn 406 (progn
408 (CP::prin (car list)) 407 (cust-print-prin (car list))
409 (setq list (cdr list))) 408 (setq list (cdr list)))
410 409
411 ;; cdr is not a list, or it is in circle-table. 410 ;; cdr is not a list, or it is in circle-table.
412 (CP::internal-princ ". ") 411 (cust-print-internal-princ ". ")
413 (CP::prin list) 412 (cust-print-prin list)
414 (setq list nil)) 413 (setq list nil))
415 414
416 (setq length (1- length)) 415 (setq length (1- length))
417 (if list (CP::internal-princ " "))) 416 (if list (cust-print-internal-princ " ")))
418 417
419 (if (and list (= length 0)) (CP::internal-princ "...")) 418 (if (and list (= length 0)) (cust-print-internal-princ "..."))
420 (CP::internal-princ ")")))) 419 (cust-print-internal-princ ")"))))
421 list) 420 list)
422 421
423 422
424(defun CP::vector (vector) 423;; Print a vector according to print-length, print-level, and print-circle.
425 "Print a vector using print-length, print-level, and print-circle." 424(defun cust-print-vector (vector)
426 (if (= level 0) 425 (if (= level 0)
427 (CP::internal-princ "#") 426 (cust-print-internal-princ "#")
428 (let ((level (1- level)) 427 (let ((level (1- level))
429 (i 0) 428 (i 0)
430 (len (length vector))) 429 (len (length vector)))
431 (CP::internal-princ "[") 430 (cust-print-internal-princ "[")
432 431
433 (if print-length 432 (if print-length
434 (setq len (min print-length len))) 433 (setq len (min print-length len)))
435 ;; Print the elements 434 ;; Print the elements
436 (while (< i len) 435 (while (< i len)
437 (CP::prin (aref vector i)) 436 (cust-print-prin (aref vector i))
438 (setq i (1+ i)) 437 (setq i (1+ i))
439 (if (< i (length vector)) (CP::internal-princ " "))) 438 (if (< i (length vector)) (cust-print-internal-princ " ")))
440 439
441 (if (< i (length vector)) (CP::internal-princ "...")) 440 (if (< i (length vector)) (cust-print-internal-princ "..."))
442 (CP::internal-princ "]") 441 (cust-print-internal-princ "]")
443 )) 442 ))
444 vector) 443 vector)
445 444
@@ -447,7 +446,7 @@ Otherwise, print normally."
447;;================================== 446;;==================================
448;; Circular structure preprocessing 447;; Circular structure preprocessing
449 448
450(defun CP::preprocess-circle-tree (object) 449(defun cust-print-preprocess-circle-tree (object)
451 ;; Fill up the table. 450 ;; Fill up the table.
452 (let (;; Table of tags for each object in an object to be printed. 451 (let (;; Table of tags for each object in an object to be printed.
453 ;; A tag is of the form: 452 ;; A tag is of the form:
@@ -457,7 +456,7 @@ Otherwise, print normally."
457 ;; can use setcdr to add new elements instead of having to setq the 456 ;; can use setcdr to add new elements instead of having to setq the
458 ;; variable sometimes (poor man's locf). 457 ;; variable sometimes (poor man's locf).
459 (circle-table (list nil))) 458 (circle-table (list nil)))
460 (CP::walk-circle-tree object) 459 (cust-print-walk-circle-tree object)
461 460
462 ;; Reverse table so it is in the order that the objects will be printed. 461 ;; Reverse table so it is in the order that the objects will be printed.
463 ;; This pass could be avoided if we always added to the end of the 462 ;; This pass could be avoided if we always added to the end of the
@@ -484,7 +483,7 @@ Otherwise, print normally."
484 483
485 484
486 485
487(defun CP::walk-circle-tree (object) 486(defun cust-print-walk-circle-tree (object)
488 (let (read-equivalent-p tag) 487 (let (read-equivalent-p tag)
489 (while object 488 (while object
490 (setq read-equivalent-p (or (numberp object) (symbolp object)) 489 (setq read-equivalent-p (or (numberp object) (symbolp object))
@@ -506,7 +505,7 @@ Otherwise, print normally."
506 505
507 ((consp object) 506 ((consp object)
508 ;; Walk the car of the list recursively. 507 ;; Walk the car of the list recursively.
509 (CP::walk-circle-tree (car object)) 508 (cust-print-walk-circle-tree (car object))
510 ;; But walk the cdr with the above while loop 509 ;; But walk the cdr with the above while loop
511 ;; to avoid problems with max-lisp-eval-depth. 510 ;; to avoid problems with max-lisp-eval-depth.
512 ;; And it should be faster than recursion. 511 ;; And it should be faster than recursion.
@@ -517,7 +516,7 @@ Otherwise, print normally."
517 (let ((i (length object)) 516 (let ((i (length object))
518 (j 0)) 517 (j 0))
519 (while (< j i) 518 (while (< j i)
520 (CP::walk-circle-tree (aref object j)) 519 (cust-print-walk-circle-tree (aref object j))
521 (setq j (1+ j)))))))))) 520 (setq j (1+ j))))))))))
522 521
523 522