34 |
;; print-length since the standard routines are being replaced. Also, |
;; print-length since the standard routines are being replaced. Also, |
35 |
;; to print custom types constructed from lists and vectors, use |
;; to print custom types constructed from lists and vectors, use |
36 |
;; custom-print-list and custom-print-vector. See the documentation |
;; custom-print-list and custom-print-vector. See the documentation |
37 |
;; strings of these variables for more details. |
;; strings of these variables for more details. |
38 |
|
|
39 |
;; If the results of your expressions contain circular references to |
;; If the results of your expressions contain circular references to |
40 |
;; other parts of the same structure, the standard Emacs print |
;; other parts of the same structure, the standard Emacs print |
131 |
;;This is defined by emacs.") |
;;This is defined by emacs.") |
132 |
|
|
133 |
(defcustom print-level nil |
(defcustom print-level nil |
134 |
"*Controls how many levels deep a nested data object will print. |
"*Controls how many levels deep a nested data object will print. |
135 |
|
|
136 |
If nil, printing proceeds recursively and may lead to |
If nil, printing proceeds recursively and may lead to |
137 |
max-lisp-eval-depth being exceeded or an error may occur: |
max-lisp-eval-depth being exceeded or an error may occur: |
147 |
|
|
148 |
|
|
149 |
(defcustom print-circle nil |
(defcustom print-circle nil |
150 |
"*Controls the printing of recursive structures. |
"*Controls the printing of recursive structures. |
151 |
|
|
152 |
If nil, printing proceeds recursively and may lead to |
If nil, printing proceeds recursively and may lead to |
153 |
`max-lisp-eval-depth' being exceeded or an error may occur: |
`max-lisp-eval-depth' being exceeded or an error may occur: |
196 |
(defun add-custom-printer (pred printer) |
(defun add-custom-printer (pred printer) |
197 |
"Add a pair of PREDICATE and PRINTER to `custom-printers'. |
"Add a pair of PREDICATE and PRINTER to `custom-printers'. |
198 |
Any pair that has the same PREDICATE is first removed." |
Any pair that has the same PREDICATE is first removed." |
199 |
(setq custom-printers (cons (cons pred printer) |
(setq custom-printers (cons (cons pred printer) |
200 |
(delq (assq pred custom-printers) |
(delq (assq pred custom-printers) |
201 |
custom-printers))) |
custom-printers))) |
202 |
;; Rather than updating here, we could wait until cust-print-top-level is called. |
;; Rather than updating here, we could wait until cust-print-top-level is called. |
220 |
;; (byte-compile |
;; (byte-compile |
221 |
`(lambda (object) |
`(lambda (object) |
222 |
(cond |
(cond |
223 |
,@(mapcar (function |
,@(mapcar (function |
224 |
(lambda (pair) |
(lambda (pair) |
225 |
`((,(car pair) object) |
`((,(car pair) object) |
226 |
(,(cdr pair) object)))) |
(,(cdr pair) object)))) |
227 |
custom-printers) |
custom-printers) |
228 |
;; Otherwise return nil. |
;; Otherwise return nil. |
236 |
;;==================================================== |
;;==================================================== |
237 |
|
|
238 |
(defun cust-print-set-function-cell (symbol-pair) |
(defun cust-print-set-function-cell (symbol-pair) |
239 |
(defalias (car symbol-pair) |
(defalias (car symbol-pair) |
240 |
(symbol-function (car (cdr symbol-pair))))) |
(symbol-function (car (cdr symbol-pair))))) |
241 |
|
|
242 |
(defun cust-print-original-princ (object &optional stream)) ; dummy def |
(defun cust-print-original-princ (object &optional stream)) ; dummy def |
268 |
(error custom-error) |
(error custom-error) |
269 |
)) |
)) |
270 |
t) |
t) |
271 |
|
|
272 |
(defun custom-print-uninstall () |
(defun custom-print-uninstall () |
273 |
"Reset print functions to their emacs subroutines." |
"Reset print functions to their emacs subroutines." |
274 |
(interactive) |
(interactive) |
335 |
|
|
336 |
This is the custom-print replacement for the standard `prin1-to-string'." |
This is the custom-print replacement for the standard `prin1-to-string'." |
337 |
(let ((buf (get-buffer-create " *custom-print-temp*"))) |
(let ((buf (get-buffer-create " *custom-print-temp*"))) |
338 |
;; We must erase the buffer before printing in case an error |
;; We must erase the buffer before printing in case an error |
339 |
;; occurred during the last prin1-to-string and we are in debugger. |
;; occurred during the last prin1-to-string and we are in debugger. |
340 |
(save-excursion |
(save-excursion |
341 |
(set-buffer buf) |
(set-buffer buf) |
364 |
|
|
365 |
|
|
366 |
(defun custom-format (fmt &rest args) |
(defun custom-format (fmt &rest args) |
367 |
"Format a string out of a control-string and arguments. |
"Format a string out of a control-string and arguments. |
368 |
The first argument is a control string. It, and subsequent arguments |
The first argument is a control string. It, and subsequent arguments |
369 |
substituted into it, become the value, which is a string. |
substituted into it, become the value, which is a string. |
370 |
It may contain %s or %d or %c to substitute successive following arguments. |
It may contain %s or %d or %c to substitute successive following arguments. |
385 |
(custom-prin1-to-string arg) |
(custom-prin1-to-string arg) |
386 |
arg))) |
arg))) |
387 |
args))) |
args))) |
388 |
|
|
389 |
|
|
390 |
(defun custom-message (fmt &rest args) |
(defun custom-message (fmt &rest args) |
391 |
"Print a one-line message at the bottom of the screen. |
"Print a one-line message at the bottom of the screen. |
392 |
The first argument is a control string. |
The first argument is a control string. |
401 |
;; It doesn't work to princ the result of custom-format as in: |
;; It doesn't work to princ the result of custom-format as in: |
402 |
;; (cust-print-original-princ (apply 'custom-format fmt args)) |
;; (cust-print-original-princ (apply 'custom-format fmt args)) |
403 |
;; because the echo area requires special handling |
;; because the echo area requires special handling |
404 |
;; to avoid duplicating the output. |
;; to avoid duplicating the output. |
405 |
;; cust-print-original-message does it right. |
;; cust-print-original-message does it right. |
406 |
(apply 'cust-print-original-message fmt |
(apply 'cust-print-original-message fmt |
407 |
(mapcar (function (lambda (arg) |
(mapcar (function (lambda (arg) |
409 |
(custom-prin1-to-string arg) |
(custom-prin1-to-string arg) |
410 |
arg))) |
arg))) |
411 |
args))) |
args))) |
412 |
|
|
413 |
|
|
414 |
(defun custom-error (fmt &rest args) |
(defun custom-error (fmt &rest args) |
415 |
"Signal an error, making error message by passing all args to `format'. |
"Signal an error, making error message by passing all args to `format'. |
435 |
;; Set up for printing. |
;; Set up for printing. |
436 |
(let ((standard-output (or stream standard-output)) |
(let ((standard-output (or stream standard-output)) |
437 |
;; circle-table will be non-nil if anything is circular. |
;; circle-table will be non-nil if anything is circular. |
438 |
(circle-table (and print-circle |
(circle-table (and print-circle |
439 |
(cust-print-preprocess-circle-tree object))) |
(cust-print-preprocess-circle-tree object))) |
440 |
(cust-print-current-level (or print-level -1))) |
(cust-print-current-level (or print-level -1))) |
441 |
|
|
442 |
(defalias 'cust-print-original-printer emacs-printer) |
(defalias 'cust-print-original-printer emacs-printer) |
443 |
(defalias 'cust-print-low-level-prin |
(defalias 'cust-print-low-level-prin |
444 |
(cond |
(cond |
445 |
((or custom-printers |
((or custom-printers |
446 |
circle-table |
circle-table |
451 |
(or print-level print-length))) |
(or print-level print-length))) |
452 |
'cust-print-print-object) |
'cust-print-print-object) |
453 |
(t 'cust-print-original-printer))) |
(t 'cust-print-original-printer))) |
454 |
(defalias 'cust-print-prin |
(defalias 'cust-print-prin |
455 |
(if circle-table 'cust-print-print-circular 'cust-print-low-level-prin)) |
(if circle-table 'cust-print-print-circular 'cust-print-low-level-prin)) |
456 |
|
|
457 |
(cust-print-prin object) |
(cust-print-prin object) |
461 |
(defun cust-print-print-object (object) |
(defun cust-print-print-object (object) |
462 |
;; Test object type and print accordingly. |
;; Test object type and print accordingly. |
463 |
;; Could be called as either cust-print-low-level-prin or cust-print-prin. |
;; Could be called as either cust-print-low-level-prin or cust-print-prin. |
464 |
(cond |
(cond |
465 |
((null object) (cust-print-original-printer object)) |
((null object) (cust-print-original-printer object)) |
466 |
((cust-print-use-custom-printer object) object) |
((cust-print-use-custom-printer object) object) |
467 |
((consp object) (cust-print-list object)) |
((consp object) (cust-print-list object)) |
561 |
;;================================== |
;;================================== |
562 |
|
|
563 |
(defun cust-print-preprocess-circle-tree (object) |
(defun cust-print-preprocess-circle-tree (object) |
564 |
;; Fill up the table. |
;; Fill up the table. |
565 |
(let (;; Table of tags for each object in an object to be printed. |
(let (;; Table of tags for each object in an object to be printed. |
566 |
;; A tag is of the form: |
;; A tag is of the form: |
567 |
;; ( <object> <nil-t-or-id-number> ) |
;; ( <object> <nil-t-or-id-number> ) |
600 |
(defun cust-print-walk-circle-tree (object) |
(defun cust-print-walk-circle-tree (object) |
601 |
(let (read-equivalent-p tag) |
(let (read-equivalent-p tag) |
602 |
(while object |
(while object |
603 |
(setq read-equivalent-p |
(setq read-equivalent-p |
604 |
(or (numberp object) |
(or (numberp object) |
605 |
(and (symbolp object) |
(and (symbolp object) |
606 |
;; Check if it is uninterned. |
;; Check if it is uninterned. |
607 |
(eq object (intern-soft (symbol-name object))))) |
(eq object (intern-soft (symbol-name object))))) |
617 |
(cons (list object) |
(cons (list object) |
618 |
(cdr circle-table))))) |
(cdr circle-table))))) |
619 |
(setq object |
(setq object |
620 |
(cond |
(cond |
621 |
(tag ;; No need to descend since we have already. |
(tag ;; No need to descend since we have already. |
622 |
nil) |
nil) |
623 |
|
|