code.delx.au - gnu-emacs/blob - lisp/emacs-lisp/cust-print.el

   1 ;; cust-print.el -- handles print-level and print-circle.
   2
   3 ;; Copyright (C) 1992 Free Software Foundation, Inc.
   4
   5 ;; Author: Daniel LaLiberte <liberte@cs.uiuc.edu>
   6 ;; Version: 1.0
   7 ;; Adapted-By: ESR
   8 ;; Keyword: extensions
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  24 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  25
  26 ;;; Commentary:
  27
  28 ;; This package provides a general print handler for prin1 and princ
  29 ;; that supports print-level and print-circle, and by the way,
  30 ;; print-length since the standard routines are being replaced.  Also,
  31 ;; to print custom types constructed from lists and vectors, use
  32 ;; custom-print-list and custom-print-vector.  See the documentation
  33 ;; strings of these variables for more details.
  34
  35 ;; If the results of your expressions contain circular references to
  36 ;; other parts of the same structure, the standard Emacs print
  37 ;; subroutines may fail to print with an untrappable error,
  38 ;; "Apparently circular structure being printed".  If you only use cdr
  39 ;; circular lists (where cdrs of lists point back; what is the right
  40 ;; term here?), you can limit the length of printing with
  41 ;; print-length.  But car circular lists and circular vectors generate
  42 ;; the above mentioned untrappable error in Emacs version 18.  Version
  43 ;; 19 will support print-level, but it is often useful to get a better
  44 ;; print representation of circular structures; the print-circle
  45 ;; option may be used to print more concise representations.
  46
  47 ;; There are two main ways to use this package.  First, you may
  48 ;; replace prin1, princ, and some subroutines that use them by calling
  49 ;; install-custom-print-funcs so that any use of these functions in
  50 ;; lisp code will be affected.  Second, you could call the custom
  51 ;; routines directly, thus only affecting the printing that requires
  52 ;; them.
  53
  54 ;; Note that subroutines which call print subroutines directly will not
  55 ;; use the custom print functions.  In particular, the evaluation
  56 ;; functions like eval-region call the print subroutines directly.
  57 ;; Therefore, evaluating (aref circ-list 0), which calls error
  58 ;; directly (because circ-list is not an array), will jump to the top
  59 ;; level instead of printing the circular list.
  60
  61 ;; Obviously the right way to implement this custom-print facility
  62 ;; is in C.  Please volunteer since I don't have the time or need.
  63
  64 ;; Implementation design: we want to use the same list and vector
  65 ;; processing algorithm for all versions of prin1 and princ, since how
  66 ;; the processing is done depends on print-length, print-level, and
  67 ;; print-circle.  For circle printing, a preprocessing step is
  68 ;; required before the final printing.  Thanks to Jamie Zawinski
  69 ;; for motivation and algorithms.
  70
  71 ;;=========================================================
  72 ;; export list:
  73
  74 ;; print-level
  75 ;; print-circle
  76
  77 ;; custom-print-list
  78 ;; custom-print-vector
  79 ;; add-custom-print-list
  80 ;; add-custom-print-vector
  81
  82 ;; install-custom-print-funcs
  83 ;; uninstall-custom-print-funcs
  84
  85 ;; custom-prin1
  86 ;; custom-princ
  87 ;; custom-prin1-to-string
  88 ;; custom-print
  89 ;; custom-format
  90 ;; custom-message
  91 ;; custom-error
  92
  93 ;;; Code:
  94
  95 (provide 'custom-print)
  96
  97 ;;(defvar print-length nil
  98 ;;  "*Controls how many elements of a list, at each level, are printed.
  99 ;;This is defined by emacs.")
 100
 101 (defvar print-level nil
 102   "*Controls how many levels deep a nested data object will print.
 103
 104 If nil, printing proceeds recursively and may lead to
 105 max-lisp-eval-depth being exceeded or an untrappable error may occur:
 106 `Apparently circular structure being printed.'
 107 Also see `print-length' and `print-circle'.
 108
 109 If non-nil, components at levels equal to or greater than `print-level'
 110 are printed simply as `#'.  The object to be printed is at level 0,
 111 and if the object is a list or vector, its top-level components are at
 112 level 1.")
 113
 114
 115 (defvar print-circle nil
 116   "*Controls the printing of recursive structures.
 117
 118 If nil, printing proceeds recursively and may lead to
 119 `max-lisp-eval-depth' being exceeded or an untrappable error may occur:
 120 \"Apparently circular structure being printed.\"  Also see
 121 `print-length' and `print-level'.
 122
 123 If non-nil, shared substructures anywhere in the structure are printed
 124 with `#N=' before the first occurance (in the order of the print
 125 representation) and `#N#' in place of each subsequent occurance,
 126 where N is a positive decimal integer.
 127
 128 Currently, there is no way to read this representation in Emacs.")
 129
 130
 131 (defconst custom-print-list
 132   nil
 133   ;; e.g.  '((floatp . float-to-string))
 134   "An alist for custom printing of lists.
 135 Pairs are of the form (PRED . CONVERTER).  If PREDICATE is true
 136 for an object, then CONVERTER is called with the object and should
 137 return a string to be printed with `princ'.
 138 Also see `custom-print-vector'.")
 139
 140 (defconst custom-print-vector
 141   nil
 142   "An alist for custom printing of vectors.
 143 Pairs are of the form (PRED . CONVERTER).  If PREDICATE is true
 144 for an object, then CONVERTER is called with the object and should
 145 return a string to be printed with `princ'.
 146 Also see `custom-print-list'.")
 147
 148
 149 (defun add-custom-print-list (pred converter)
 150   "Add a pair of PREDICATE and CONVERTER to `custom-print-list'.
 151 Any pair that has the same PREDICATE is first removed."
 152   (setq custom-print-list (cons (cons pred converter)
 153                                 (delq (assq pred custom-print-list)
 154                                       custom-print-list))))
 155 ;; e.g. (add-custom-print-list 'floatp 'float-to-string)
 156
 157
 158 (defun add-custom-print-vector (pred converter)
 159   "Add a pair of PREDICATE and CONVERTER to `custom-print-vector'.
 160 Any pair that has the same PREDICATE is first removed."
 161   (setq custom-print-vector (cons (cons pred converter)
 162                                   (delq (assq pred custom-print-vector)
 163                                         custom-print-vector))))
 164
 165
 166 ;;====================================================
 167 ;; Saving and restoring internal printing routines.
 168
 169 (defun cust-print-set-function-cell (symbol-pair)
 170   (fset (car symbol-pair)
 171         (symbol-function (car (cdr symbol-pair)))))
 172
 173
 174 (if (not (fboundp 'cust-print-internal-prin1))
 175     (mapcar 'cust-print-set-function-cell
 176             '((cust-print-internal-prin1 prin1)
 177               (cust-print-internal-princ princ)
 178               (cust-print-internal-print print)
 179               (cust-print-internal-prin1-to-string prin1-to-string)
 180               (cust-print-internal-format format)
 181               (cust-print-internal-message message)
 182               (cust-print-internal-error error))))
 183
 184
 185 (defun install-custom-print-funcs ()
 186   "Replace print functions with general, customizable, Lisp versions.
 187 The internal subroutines are saved away, and you can reinstall them
 188 by running `uninstall-custom-print-funcs'."
 189   (interactive)
 190   (mapcar 'cust-print-set-function-cell
 191           '((prin1 custom-prin1)
 192             (princ custom-princ)
 193             (print custom-print)
 194             (prin1-to-string custom-prin1-to-string)
 195             (format custom-format)
 196             (message custom-message)
 197             (error custom-error)
 198             )))
 199
 200 (defun uninstall-custom-print-funcs ()
 201   "Reset print functions to their internal subroutines."
 202   (interactive)
 203   (mapcar 'cust-print-set-function-cell
 204           '((prin1 cust-print-internal-prin1)
 205             (princ cust-print-internal-princ)
 206             (print cust-print-internal-print)
 207             (prin1-to-string cust-print-internal-prin1-to-string)
 208             (format cust-print-internal-format)
 209             (message cust-print-internal-message)
 210             (error cust-print-internal-error)
 211             )))
 212
 213
 214 ;;===============================================================
 215 ;; Lisp replacements for prin1 and princ and for subrs that use prin1
 216 ;; (or princ) -- so far only the printing and formatting subrs.
 217
 218 (defun custom-prin1 (object &optional stream)
 219   "Replacement for standard `prin1'.
 220 Uses the appropriate printer depending on the values of `print-level'
 221 and `print-circle' (which see).
 222
 223 Output the printed representation of OBJECT, any Lisp object.
 224 Quoting characters are printed when needed to make output that `read'
 225 can handle, whenever this is possible.
 226 Output stream is STREAM, or value of `standard-output' (which see)."
 227   (cust-print-top-level object stream 'cust-print-internal-prin1))
 228
 229
 230 (defun custom-princ (object &optional stream)
 231   "Same as `custom-prin1' except no quoting."
 232   (cust-print-top-level object stream 'cust-print-internal-princ))
 233
 234 (defvar custom-prin1-chars)
 235
 236 (defun custom-prin1-to-string-func (c)
 237   "Stream function for `custom-prin1-to-string'."
 238   (setq custom-prin1-chars (cons c custom-prin1-chars)))
 239
 240 (defun custom-prin1-to-string (object)
 241   "Replacement for standard `prin1-to-string'."
 242   (let ((custom-prin1-chars nil))
 243     (custom-prin1 object 'custom-prin1-to-string-func)
 244     (concat (nreverse custom-prin1-chars))))
 245
 246
 247 (defun custom-print (object &optional stream)
 248   "Replacement for standard `print'."
 249   (cust-print-internal-princ "\n")
 250   (custom-prin1 object stream)
 251   (cust-print-internal-princ "\n"))
 252
 253
 254 (defun custom-format (fmt &rest args)
 255   "Replacement for standard `format'.
 256
 257 Calls format after first making strings for list or vector args.
 258 The format specification for such args should be `%s' in any case, so a
 259 string argument will also work.  The string is generated with
 260 `custom-prin1-to-string', which quotes quotable characters."
 261   (apply 'cust-print-internal-format fmt
 262          (mapcar (function (lambda (arg)
 263                              (if (or (listp arg) (vectorp arg))
 264                                  (custom-prin1-to-string arg)
 265                                arg)))
 266                  args)))
 267
 268
 269
 270 (defun custom-message (fmt &rest args)
 271   "Replacement for standard `message' that works like `custom-format'."
 272   ;; It doesnt work to princ the result of custom-format
 273   ;; because the echo area requires special handling
 274   ;; to avoid duplicating the output.  cust-print-internal-message does it right.
 275   ;; (cust-print-internal-princ (apply 'custom-format fmt args))
 276   (apply 'cust-print-internal-message  fmt
 277          (mapcar (function (lambda (arg)
 278                              (if (or (listp arg) (vectorp arg))
 279                                  (custom-prin1-to-string arg)
 280                                arg)))
 281                  args)))
 282
 283
 284 (defun custom-error (fmt &rest args)
 285   "Replacement for standard `error' that uses `custom-format'"
 286   (signal 'error (list (apply 'custom-format fmt args))))
 287
 288
 289 ;;=========================================
 290 ;; Support for custom prin1 and princ
 291
 292 (defvar circle-table)
 293 (defvar circle-tree)
 294 (defvar circle-level)
 295
 296 (defun cust-print-top-level (object stream internal-printer)
 297   "Set up for printing."
 298   (let ((standard-output (or stream standard-output))
 299         (circle-table (and print-circle (cust-print-preprocess-circle-tree object)))
 300         (circle-level (or print-level -1))
 301         )
 302
 303     (fset 'cust-print-internal-printer internal-printer)
 304     (fset 'cust-print-low-level-prin
 305           (cond
 306            ((or custom-print-list
 307                 custom-print-vector
 308                 print-level ; comment out for version 19
 309                 )
 310             'cust-print-custom-object)
 311            (circle-table
 312             'cust-print-object)
 313            (t 'cust-print-internal-printer)))
 314     (fset 'cust-print-prin (if circle-table 'cust-print-circular 'cust-print-low-level-prin))
 315
 316     (cust-print-prin object)
 317     object))
 318
 319
 320 ;; Test object type and print accordingly.
 321 (defun cust-print-object (object)
 322   ;; Could be called as either cust-print-low-level-prin or cust-print-prin.
 323   (cond
 324    ((null object) (cust-print-internal-printer object))
 325    ((consp object) (cust-print-list object))
 326    ((vectorp object) (cust-print-vector object))
 327    ;; All other types, just print.
 328    (t (cust-print-internal-printer object))))
 329
 330
 331 ;; Test object type and print accordingly.
 332 (defun cust-print-custom-object (object)
 333   ;; Could be called as either cust-print-low-level-prin or cust-print-prin.
 334   (cond
 335    ((null object) (cust-print-internal-printer object))
 336
 337    ((consp object)
 338     (or (and custom-print-list
 339              (cust-print-custom-object1 object custom-print-list))
 340         (cust-print-list object)))
 341
 342    ((vectorp object)
 343     (or (and custom-print-vector
 344              (cust-print-custom-object1 object custom-print-vector))
 345         (cust-print-vector object)))
 346
 347    ;; All other types, just print.
 348    (t (cust-print-internal-printer object))))
 349
 350
 351 ;; Helper for cust-print-custom-object.
 352 ;; Print the custom OBJECT using the custom type ALIST.
 353 ;; For the first predicate that matches the object, the corresponding
 354 ;; converter is evaluated with the object and the string that results is
 355 ;; printed with princ.  Return nil if no predicte matches the object.
 356 (defun cust-print-custom-object1 (object alist)
 357   (while (and alist (not (funcall (car (car alist)) object)))
 358     (setq alist (cdr alist)))
 359   ;; If alist is not null, then something matched.
 360   (if alist
 361       (cust-print-internal-princ
 362        (funcall (cdr (car alist)) object) ; returns string
 363        )))
 364
 365
 366 (defun cust-print-circular (object)
 367   "Printer for `prin1' and `princ' that handles circular structures.
 368 If OBJECT appears multiply, and has not yet been printed,
 369 prefix with label; if it has been printed, use `#N#' instead.
 370 Otherwise, print normally."
 371   (let ((tag (assq object circle-table)))
 372     (if tag
 373         (let ((id (cdr tag)))
 374           (if (> id 0)
 375               (progn
 376                 ;; Already printed, so just print id.
 377                 (cust-print-internal-princ "#")
 378                 (cust-print-internal-princ id)
 379                 (cust-print-internal-princ "#"))
 380             ;; Not printed yet, so label with id and print object.
 381             (setcdr tag (- id)) ; mark it as printed
 382             (cust-print-internal-princ "#")
 383             (cust-print-internal-princ (- id))
 384             (cust-print-internal-princ "=")
 385             (cust-print-low-level-prin object)
 386             ))
 387       ;; Not repeated in structure.
 388       (cust-print-low-level-prin object))))
 389
 390
 391 ;;================================================
 392 ;; List and vector processing for print functions.
 393
 394 ;; Print a list using print-length, print-level, and print-circle.
 395 (defun cust-print-list (list)
 396   (if (= circle-level 0)
 397       (cust-print-internal-princ "#")
 398     (let ((circle-level (1- circle-level)))
 399       (cust-print-internal-princ "(")
 400       (let ((length (or print-length 0)))
 401
 402         ;; Print the first element always (even if length = 0).
 403         (cust-print-prin (car list))
 404         (setq list (cdr list))
 405         (if list (cust-print-internal-princ " "))
 406         (setq length (1- length))
 407
 408         ;; Print the rest of the elements.
 409         (while (and list (/= 0 length))
 410           (if (and (listp list)
 411                    (not (assq list circle-table)))
 412               (progn
 413                 (cust-print-prin (car list))
 414                 (setq list (cdr list)))
 415
 416             ;; cdr is not a list, or it is in circle-table.
 417             (cust-print-internal-princ ". ")
 418             (cust-print-prin list)
 419             (setq list nil))
 420
 421           (setq length (1- length))
 422           (if list (cust-print-internal-princ " ")))
 423
 424         (if (and list (= length 0)) (cust-print-internal-princ "..."))
 425         (cust-print-internal-princ ")"))))
 426   list)
 427
 428
 429 ;; Print a vector according to print-length, print-level, and print-circle.
 430 (defun cust-print-vector (vector)
 431   (if (= circle-level 0)
 432       (cust-print-internal-princ "#")
 433     (let ((circle-level (1- circle-level))
 434           (i 0)
 435           (len (length vector)))
 436       (cust-print-internal-princ "[")
 437
 438       (if print-length
 439           (setq len (min print-length len)))
 440       ;; Print the elements
 441       (while (< i len)
 442         (cust-print-prin (aref vector i))
 443         (setq i (1+ i))
 444         (if (< i (length vector)) (cust-print-internal-princ " ")))
 445
 446       (if (< i (length vector)) (cust-print-internal-princ "..."))
 447       (cust-print-internal-princ "]")
 448       ))
 449   vector)
 450
 451
 452 ;;==================================
 453 ;; Circular structure preprocessing
 454
 455 (defun cust-print-preprocess-circle-tree (object)
 456   ;; Fill up the table.
 457   (let (;; Table of tags for each object in an object to be printed.
 458         ;; A tag is of the form:
 459         ;; ( <object> <nil-t-or-id-number> )
 460         ;; The id-number is generated after the entire table has been computed.
 461         ;; During walk through, the real circle-table lives in the cdr so we
 462         ;; can use setcdr to add new elements instead of having to setq the
 463         ;; variable sometimes (poor man's locf).
 464         (circle-table (list nil)))
 465     (cust-print-walk-circle-tree object)
 466
 467     ;; Reverse table so it is in the order that the objects will be printed.
 468     ;; This pass could be avoided if we always added to the end of the
 469     ;; table with setcdr in walk-circle-tree.
 470     (setcdr circle-table (nreverse (cdr circle-table)))
 471
 472     ;; Walk through the table, assigning id-numbers to those
 473     ;; objects which will be printed using #N= syntax.  Delete those
 474     ;; objects which will be printed only once (to speed up assq later).
 475     (let ((rest circle-table)
 476           (id -1))
 477       (while (cdr rest)
 478         (let ((tag (car (cdr rest))))
 479           (cond ((cdr tag)
 480                  (setcdr tag id)
 481                  (setq id (1- id))
 482                  (setq rest (cdr rest)))
 483                 ;; Else delete this object.
 484                 (t (setcdr rest (cdr (cdr rest))))))
 485         ))
 486     ;; Drop the car.
 487     (cdr circle-table)
 488     ))
 489
 490
 491
 492 (defun cust-print-walk-circle-tree (object)
 493   (let (read-equivalent-p tag)
 494     (while object
 495       (setq read-equivalent-p (or (numberp object) (symbolp object))
 496             tag (and (not read-equivalent-p)
 497                      (assq object (cdr circle-table))))
 498       (cond (tag
 499              ;; Seen this object already, so note that.
 500              (setcdr tag t))
 501
 502             ((not read-equivalent-p)
 503              ;; Add a tag for this object.
 504              (setcdr circle-table
 505                      (cons (list object)
 506                            (cdr circle-table)))))
 507       (setq object
 508             (cond
 509              (tag ;; No need to descend since we have already.
 510               nil)
 511
 512              ((consp object)
 513               ;; Walk the car of the list recursively.
 514               (cust-print-walk-circle-tree (car object))
 515               ;; But walk the cdr with the above while loop
 516               ;; to avoid problems with max-lisp-eval-depth.
 517               ;; And it should be faster than recursion.
 518               (cdr object))
 519
 520              ((vectorp object)
 521               ;; Walk the vector.
 522               (let ((i (length object))
 523                     (j 0))
 524                 (while (< j i)
 525                   (cust-print-walk-circle-tree (aref object j))
 526                   (setq j (1+ j))))))))))
 527
 528
 529
 530 ;;=======================================
 531
 532 ;; Example.
 533
 534 ;;;; Create some circular structures.
 535 ;;(setq circ-sym (let ((x (make-symbol "FOO"))) (list x x)))
 536 ;;(setq circ-list (list 'a 'b (vector 1 2 3 4) 'd 'e 'f))
 537 ;;(setcar (nthcdr 3 circ-list) circ-list)
 538 ;;(aset (nth 2 circ-list) 2 circ-list)
 539 ;;(setq dotted-circ-list (list 'a 'b 'c))
 540 ;;(setcdr (cdr (cdr dotted-circ-list)) dotted-circ-list)
 541 ;;(setq circ-vector (vector 1 2 3 4 (list 'a 'b 'c 'd) 6 7))
 542 ;;(aset circ-vector 5 (make-symbol "-gensym-"))
 543 ;;(setcar (cdr (aref circ-vector 4)) (aref circ-vector 5))
 544
 545 ;;(install-custom-print-funcs)
 546 ;;;; (setq print-circle t)
 547
 548 ;;(let ((print-circle t))
 549 ;;  (or (equal (prin1-to-string circ-list) "#1=(a b [1 2 #1# 4] #1# e f)")
 550 ;;      (error "circular object with array printing")))
 551
 552 ;;(let ((print-circle t))
 553 ;;  (or (equal (prin1-to-string dotted-circ-list) "#1=(a b c . #1#)")
 554 ;;      (error "circular object with array printing")))
 555
 556 ;;(let* ((print-circle t)
 557 ;;       (x (list 'p 'q))
 558 ;;       (y (list (list 'a 'b) x 'foo x)))
 559 ;;  (setcdr (cdr (cdr (cdr y))) (cdr y))
 560 ;;  (or (equal (prin1-to-string y) "((a b) . #1=(#2=(p q) foo #2# . #1#))"
 561 ;;           )
 562 ;;      (error "circular list example from CL manual")))
 563
 564 ;;;; There's no special handling of uninterned symbols in custom-print.
 565 ;;(let ((print-circle nil))
 566 ;;  (or (equal (prin1-to-string circ-sym) "(#:FOO #:FOO)")
 567 ;;      (error "uninterned symbols in list")))
 568 ;;(let ((print-circle t))
 569 ;;  (or (equal (prin1-to-string circ-sym) "(#1=FOO #1#)")
 570 ;;      (error "circular uninterned symbols in list")))
 571 ;;(uninstall-custom-print-funcs)
 572
 573 ;;; cust-print.el ends here