/[emacs]/emacs/lisp/emacs-lisp/cust-print.el
ViewVC logotype

Diff of /emacs/lisp/emacs-lisp/cust-print.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 2.4 by pj, Mon Jul 16 12:22:59 2001 UTC revision 2.4.8.1 by miles, Fri Apr 4 06:20:16 2003 UTC
# Line 34  Line 34 
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
# Line 131  Line 131 
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:
# Line 147  level 1." Line 147  level 1."
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:
# Line 196  Don't modify this variable directly.  Us Line 196  Don't modify this variable directly.  Us
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.
# Line 220  Any pair that has the same PREDICATE is Line 220  Any pair that has the same PREDICATE is
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.
# Line 236  Any pair that has the same PREDICATE is Line 236  Any pair that has the same PREDICATE is
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
# Line 268  by running `custom-print-uninstall'." Line 268  by running `custom-print-uninstall'."
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)
# Line 335  second argument NOESCAPE is non-nil. Line 335  second argument NOESCAPE is non-nil.
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)
# Line 364  This is the custom-print replacement for Line 364  This is the custom-print replacement for
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.
# Line 385  characters." Line 385  characters."
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.
# Line 401  See `custom-format' for the details." Line 401  See `custom-format' for the details."
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)
# Line 409  See `custom-format' for the details." Line 409  See `custom-format' for the details."
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'.
# Line 435  See `custom-format' for the details." Line 435  See `custom-format' for the details."
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
# Line 451  See `custom-format' for the details." Line 451  See `custom-format' for the details."
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)
# Line 461  See `custom-format' for the details." Line 461  See `custom-format' for the details."
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))
# Line 561  See `custom-format' for the details." Line 561  See `custom-format' for the details."
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> )
# Line 600  See `custom-format' for the details." Line 600  See `custom-format' for the details."
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)))))
# Line 617  See `custom-format' for the details." Line 617  See `custom-format' for the details."
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    

Legend:
Removed from v.2.4  
changed lines
  Added in v.2.4.8.1

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26