lisp/emacs-lisp/cl-print.el

   1 ;;; cl-print.el --- CL-style generic printing  -*- lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2017  Free Software Foundation, Inc.
   4
   5 ;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
   6 ;; Keywords:
   7 ;; Version: 1.0
   8 ;; Package-Requires: ((emacs "25"))
   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 3 of the License, or
  15 ;; (at your option) 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.  If not, see <https://www.gnu.org/licenses/>.
  24
  25 ;;; Commentary:
  26
  27 ;; Customizable print facility.
  28 ;;
  29 ;; The heart of it is the generic function `cl-print-object' to which you
  30 ;; can add any method you like.
  31 ;;
  32 ;; The main entry point is `cl-prin1'.
  33
  34 ;;; Code:
  35
  36 (require 'button)
  37
  38 (defvar cl-print-readably nil
  39   "If non-nil, try and make sure the result can be `read'.")
  40
  41 (defvar cl-print--number-table nil)
  42 (defvar cl-print--currently-printing nil)
  43
  44 ;;;###autoload
  45 (cl-defgeneric cl-print-object (object stream)
  46   "Dispatcher to print OBJECT on STREAM according to its type.
  47 You can add methods to it to customize the output.
  48 But if you just want to print something, don't call this directly:
  49 call other entry points instead, such as `cl-prin1'."
  50   ;; This delegates to the C printer.  The C printer will not call us back, so
  51   ;; we should only use it for objects which don't have nesting.
  52   (prin1 object stream))
  53
  54 (cl-defmethod cl-print-object ((object cons) stream)
  55   (let ((car (pop object)))
  56     (if (and (memq car '(\, quote \` \,@ \,.))
  57              (consp object)
  58              (null (cdr object)))
  59         (progn
  60           (princ (if (eq car 'quote) '\' car) stream)
  61           (cl-print-object (car object) stream))
  62       (princ "(" stream)
  63       (cl-print-object car stream)
  64       (while (and (consp object)
  65                   (not (if cl-print--number-table
  66                            (numberp (gethash object cl-print--number-table))
  67                          (memq object cl-print--currently-printing))))
  68         (princ " " stream)
  69         (cl-print-object (pop object) stream))
  70       (when object
  71         (princ " . " stream) (cl-print-object object stream))
  72       (princ ")" stream))))
  73
  74 (cl-defmethod cl-print-object ((object vector) stream)
  75   (princ "[" stream)
  76   (dotimes (i (length object))
  77     (unless (zerop i) (princ " " stream))
  78     (cl-print-object (aref object i) stream))
  79   (princ "]" stream))
  80
  81 (cl-defmethod cl-print-object ((object hash-table) stream)
  82   (princ "#<hash-table " stream)
  83   (princ (hash-table-test object) stream)
  84   (princ " " stream)
  85   (princ (hash-table-count object) stream)
  86   (princ "/" stream)
  87   (princ (hash-table-size object) stream)
  88   (princ (format " 0x%x" (sxhash object)) stream)
  89   (princ ">" stream))
  90
  91 (define-button-type 'help-byte-code
  92   'follow-link t
  93   'action (lambda (button)
  94             (disassemble (button-get button 'byte-code-function)))
  95   'help-echo (purecopy "mouse-2, RET: disassemble this function"))
  96
  97 (defvar cl-print-compiled nil
  98   "Control how to print byte-compiled functions.
  99 Acceptable values include:
 100 - `static' to print the vector of constants.
 101 - `disassemble' to print the disassembly of the code.
 102 - nil to skip printing any details about the code.")
 103
 104 (defvar cl-print-compiled-button t
 105   "Control how to print byte-compiled functions into buffers.
 106 When the stream is a buffer, make the bytecode part of the output
 107 into a button whose action shows the function's disassembly.")
 108
 109 (autoload 'disassemble-1 "disass")
 110
 111 (cl-defmethod cl-print-object ((object compiled-function) stream)
 112   (unless stream (setq stream standard-output))
 113   ;; We use "#f(...)" rather than "#<...>" so that pp.el gives better results.
 114   (princ "#f(compiled-function " stream)
 115   (let ((args (help-function-arglist object 'preserve-names)))
 116     (if args
 117         (prin1 args stream)
 118       (princ "()" stream)))
 119   (pcase (help-split-fundoc (documentation object 'raw) object)
 120     ;; Drop args which `help-function-arglist' already printed.
 121     (`(,_usage . ,(and doc (guard (stringp doc))))
 122      (princ " " stream)
 123      (prin1 doc stream)))
 124   (let ((inter (interactive-form object)))
 125     (when inter
 126       (princ " " stream)
 127       (cl-print-object
 128        (if (eq 'byte-code (car-safe (cadr inter)))
 129            `(interactive ,(make-byte-code nil (nth 1 (cadr inter))
 130                                           (nth 2 (cadr inter))
 131                                           (nth 3 (cadr inter))))
 132          inter)
 133        stream)))
 134   (if (eq cl-print-compiled 'disassemble)
 135       (princ
 136        (with-temp-buffer
 137          (insert "\n")
 138          (disassemble-1 object 0)
 139          (buffer-string))
 140        stream)
 141     (princ " " stream)
 142     (let ((button-start (and cl-print-compiled-button
 143                              (bufferp stream)
 144                              (with-current-buffer stream (point)))))
 145       (princ (format "#<bytecode 0x%x>" (sxhash object)) stream)
 146       (when (eq cl-print-compiled 'static)
 147         (princ " " stream)
 148         (cl-print-object (aref object 2) stream))
 149       (when button-start
 150         (with-current-buffer stream
 151           (make-text-button button-start (point)
 152                             :type 'help-byte-code
 153                             'byte-code-function object)))))
 154   (princ ")" stream))
 155
 156 ;; This belongs in nadvice.el, of course, but some load-ordering issues make it
 157 ;; complicated: cl-generic uses macros from cl-macs and cl-macs uses advice-add
 158 ;; from nadvice, so nadvice needs to be loaded before cl-generic and hence
 159 ;; can't use cl-defmethod.
 160 (cl-defmethod cl-print-object :extra "nadvice"
 161               ((object compiled-function) stream)
 162   (if (not (advice--p object))
 163       (cl-call-next-method)
 164     (princ "#f(advice-wrapper " stream)
 165     (when (fboundp 'advice--where)
 166       (princ (advice--where object) stream)
 167       (princ " " stream))
 168     (cl-print-object (advice--cdr object) stream)
 169     (princ " " stream)
 170     (cl-print-object (advice--car object) stream)
 171     (let ((props (advice--props object)))
 172       (when props
 173         (princ " " stream)
 174         (cl-print-object props stream)))
 175     (princ ")" stream)))
 176
 177 (cl-defmethod cl-print-object ((object cl-structure-object) stream)
 178   (princ "#s(" stream)
 179   (let* ((class (cl-find-class (type-of object)))
 180          (slots (cl--struct-class-slots class)))
 181     (princ (cl--struct-class-name class) stream)
 182     (dotimes (i (length slots))
 183       (let ((slot (aref slots i)))
 184         (princ " :" stream)
 185         (princ (cl--slot-descriptor-name slot) stream)
 186         (princ " " stream)
 187         (cl-print-object (aref object (1+ i)) stream))))
 188   (princ ")" stream))
 189
 190 ;;; Circularity and sharing.
 191
 192 ;; I don't try to support the `print-continuous-numbering', because
 193 ;; I think it's ill defined anyway: if an object appears only once in each call
 194 ;; its sharing can't be properly preserved!
 195
 196 (cl-defmethod cl-print-object :around (object stream)
 197   ;; FIXME: Only put such an :around method on types where it's relevant.
 198   (cond
 199    (print-circle
 200     (let ((n (gethash object cl-print--number-table)))
 201       (if (not (numberp n))
 202           (cl-call-next-method)
 203         (if (> n 0)
 204             ;; Already printed.  Just print a reference.
 205             (progn (princ "#" stream) (princ n stream) (princ "#" stream))
 206           (puthash object (- n) cl-print--number-table)
 207           (princ "#" stream) (princ (- n) stream) (princ "=" stream)
 208           (cl-call-next-method)))))
 209    ((let ((already-printing (memq object cl-print--currently-printing)))
 210       (when already-printing
 211         ;; Currently printing, just print reference to avoid endless
 212         ;; recursion.
 213         (princ "#" stream)
 214         (princ (length (cdr already-printing)) stream))))
 215     (t (let ((cl-print--currently-printing
 216               (cons object cl-print--currently-printing)))
 217          (cl-call-next-method)))))
 218
 219 (defvar cl-print--number-index nil)
 220
 221 (defun cl-print--find-sharing (object table)
 222   ;; Avoid recursion: not only because it's too easy to bump into
 223   ;; `max-lisp-eval-depth', but also because function calls are fairly slow.
 224   ;; At first, I thought using a list for our stack would cause too much
 225   ;; garbage to generated, but I didn't notice any such problem in practice.
 226   ;; I experimented with using an array instead, but the result was slightly
 227   ;; slower and the reduction in GC activity was less than 1% on my test.
 228   (let ((stack (list object)))
 229     (while stack
 230       (let ((object (pop stack)))
 231         (unless
 232             ;; Skip objects which don't have identity!
 233             (or (floatp object) (numberp object)
 234                 (null object) (if (symbolp object) (intern-soft object)))
 235           (let ((n (gethash object table)))
 236             (cond
 237              ((numberp n))                   ;All done.
 238              (n                              ;Already seen, but only once.
 239               (let ((n (1+ cl-print--number-index)))
 240                 (setq cl-print--number-index n)
 241                 (puthash object (- n) table)))
 242              (t
 243               (puthash object t table)
 244               (pcase object
 245                 (`(,car . ,cdr)
 246                  (push cdr stack)
 247                  (push car stack))
 248                 ((pred stringp)
 249                  ;; We presumably won't print its text-properties.
 250                  nil)
 251                 ((or (pred arrayp) (pred byte-code-function-p))
 252                  ;; FIXME: Inefficient for char-tables!
 253                  (dotimes (i (length object))
 254                    (push (aref object i) stack))))))))))))
 255
 256 (defun cl-print--preprocess (object)
 257   (let ((print-number-table (make-hash-table :test 'eq :rehash-size 2.0)))
 258     (if (fboundp 'print--preprocess)
 259         ;; Use the predefined C version if available.
 260         (print--preprocess object)           ;Fill print-number-table!
 261       (let ((cl-print--number-index 0))
 262         (cl-print--find-sharing object print-number-table)))
 263     print-number-table))
 264
 265 ;;;###autoload
 266 (defun cl-prin1 (object &optional stream)
 267   "Print OBJECT on STREAM according to its type.
 268 Output is further controlled by the variables
 269 `cl-print-readably', `cl-print-compiled', along with output
 270 variables for the standard printing functions.  See Info
 271 node `(elisp)Output Variables'."
 272   (if cl-print-readably
 273       (prin1 object stream)
 274     (with-demoted-errors "cl-prin1: %S"
 275       (if (not print-circle)
 276           (cl-print-object object stream)
 277         (let ((cl-print--number-table (cl-print--preprocess object)))
 278           (cl-print-object object stream))))))
 279
 280 ;;;###autoload
 281 (defun cl-prin1-to-string (object)
 282   "Return a string containing the `cl-prin1'-printed representation of OBJECT."
 283   (with-temp-buffer
 284     (cl-prin1 object (current-buffer))
 285     (buffer-string)))
 286
 287 (provide 'cl-print)
 288 ;;; cl-print.el ends here