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 <http://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 (defvar cl-print-readably nil
  37   "If non-nil, try and make sure the result can be `read'.")
  38
  39 (defvar cl-print--number-table nil)
  40
  41 ;;;###autoload
  42 (cl-defgeneric cl-print-object (object stream)
  43   "Dispatcher to print OBJECT on STREAM according to its type.
  44 You can add methods to it to customize the output.
  45 But if you just want to print something, don't call this directly:
  46 call other entry points instead, such as `cl-prin1'."
  47   ;; This delegates to the C printer.  The C printer will not call us back, so
  48   ;; we should only use it for objects which don't have nesting.
  49   (prin1 object stream))
  50
  51 (cl-defmethod cl-print-object ((object cons) stream)
  52   (let ((car (pop object)))
  53     (if (and (memq car '(\, quote \` \,@ \,.))
  54              (consp object)
  55              (null (cdr object)))
  56         (progn
  57           (princ (if (eq car 'quote) '\' car) stream)
  58           (cl-print-object (car object) stream))
  59       (princ "(" stream)
  60       (cl-print-object car stream)
  61       (while (and (consp object)
  62                   (not (and cl-print--number-table
  63                             (numberp (gethash object cl-print--number-table)))))
  64         (princ " " stream)
  65         (cl-print-object (pop object) stream))
  66       (when object
  67         (princ " . " stream) (cl-print-object object stream))
  68       (princ ")" stream))))
  69
  70 (cl-defmethod cl-print-object ((object vector) stream)
  71   (princ "[" stream)
  72   (dotimes (i (length object))
  73     (unless (zerop i) (princ " " stream))
  74     (cl-print-object (aref object i) stream))
  75   (princ "]" stream))
  76
  77 (defvar cl-print-compiled nil
  78   "Control how to print byte-compiled functions.  Can be:
  79 - `static' to print the vector of constants.
  80 - `disassemble' to print the disassembly of the code.
  81 - nil to skip printing any details about the code.")
  82
  83 (cl-defmethod cl-print-object ((object compiled-function) stream)
  84   ;; We use "#f(...)" rather than "#<...>" so that pp.el gives better results.
  85   (princ "#f(compiled-function " stream)
  86   (let ((args (help-function-arglist object 'preserve-names)))
  87     (if args
  88         (prin1 args stream)
  89       (princ "()" stream)))
  90   (let ((doc (documentation object 'raw)))
  91     (when doc
  92       (princ " " stream)
  93       (prin1 doc stream)))
  94   (let ((inter (interactive-form object)))
  95     (when inter
  96       (princ " " stream)
  97       (cl-print-object
  98        (if (eq 'byte-code (car-safe (cadr inter)))
  99            `(interactive ,(make-byte-code nil (nth 1 (cadr inter))
 100                                           (nth 2 (cadr inter))
 101                                           (nth 3 (cadr inter))))
 102          inter)
 103        stream)))
 104   (if (eq cl-print-compiled 'disassemble)
 105       (princ
 106        (with-temp-buffer
 107          (insert "\n")
 108          (disassemble-1 object 0)
 109          (buffer-string))
 110        stream)
 111     (princ " #<bytecode>" stream)
 112     (when (eq cl-print-compiled 'static)
 113       (princ " " stream)
 114       (cl-print-object (aref object 2) stream)))
 115   (princ ")" stream))
 116
 117 ;; This belongs in nadvice.el, of course, but some load-ordering issues make it
 118 ;; complicated: cl-generic uses macros from cl-macs and cl-macs uses advice-add
 119 ;; from nadvice, so nadvice needs to be loaded before cl-generic and hence
 120 ;; can't use cl-defmethod.
 121 (cl-defmethod cl-print-object :extra "nadvice"
 122               ((object compiled-function) stream)
 123   (if (not (advice--p object))
 124       (cl-call-next-method)
 125     (princ "#f(advice-wrapper " stream)
 126     (when (fboundp 'advice--where)
 127       (princ (advice--where object) stream)
 128       (princ " " stream))
 129     (cl-print-object (advice--cdr object) stream)
 130     (princ " " stream)
 131     (cl-print-object (advice--car object) stream)
 132     (let ((props (advice--props object)))
 133       (when props
 134         (princ " " stream)
 135         (cl-print-object props stream)))
 136     (princ ")" stream)))
 137
 138 (cl-defmethod cl-print-object ((object cl-structure-object) stream)
 139   (princ "#s(" stream)
 140   (let* ((class (cl-find-class (type-of object)))
 141          (slots (cl--struct-class-slots class)))
 142     (princ (cl--struct-class-name class) stream)
 143     (dotimes (i (length slots))
 144       (let ((slot (aref slots i)))
 145         (princ " :" stream)
 146         (princ (cl--slot-descriptor-name slot) stream)
 147         (princ " " stream)
 148         (cl-print-object (aref object (1+ i)) stream))))
 149   (princ ")" stream))
 150
 151 ;;; Circularity and sharing.
 152
 153 ;; I don't try to support the `print-continuous-numbering', because
 154 ;; I think it's ill defined anyway: if an object appears only once in each call
 155 ;; its sharing can't be properly preserved!
 156
 157 (cl-defmethod cl-print-object :around (object stream)
 158   ;; FIXME: Only put such an :around method on types where it's relevant.
 159   (let ((n (if cl-print--number-table (gethash object cl-print--number-table))))
 160     (if (not (numberp n))
 161         (cl-call-next-method)
 162       (if (> n 0)
 163           ;; Already printed.  Just print a reference.
 164           (progn (princ "#" stream) (princ n stream) (princ "#" stream))
 165         (puthash object (- n) cl-print--number-table)
 166         (princ "#" stream) (princ (- n) stream) (princ "=" stream)
 167         (cl-call-next-method)))))
 168
 169 (defvar cl-print--number-index nil)
 170
 171 (defun cl-print--find-sharing (object table)
 172   ;; Avoid recursion: not only because it's too easy to bump into
 173   ;; `max-lisp-eval-depth', but also because function calls are fairly slow.
 174   ;; At first, I thought using a list for our stack would cause too much
 175   ;; garbage to generated, but I didn't notice any such problem in practice.
 176   ;; I experimented with using an array instead, but the result was slightly
 177   ;; slower and the reduction in GC activity was less than 1% on my test.
 178   (let ((stack (list object)))
 179     (while stack
 180       (let ((object (pop stack)))
 181         (unless
 182             ;; Skip objects which don't have identity!
 183             (or (floatp object) (numberp object)
 184                 (null object) (if (symbolp object) (intern-soft object)))
 185           (let ((n (gethash object table)))
 186             (cond
 187              ((numberp n))                   ;All done.
 188              (n                              ;Already seen, but only once.
 189               (let ((n (1+ cl-print--number-index)))
 190                 (setq cl-print--number-index n)
 191                 (puthash object (- n) table)))
 192              (t
 193               (puthash object t table)
 194               (pcase object
 195                 (`(,car . ,cdr)
 196                  (push cdr stack)
 197                  (push car stack))
 198                 ((pred stringp)
 199                  ;; We presumably won't print its text-properties.
 200                  nil)
 201                 ((or (pred arrayp) (pred byte-code-function-p))
 202                  ;; FIXME: Inefficient for char-tables!
 203                  (dotimes (i (length object))
 204                    (push (aref object i) stack))))))))))))
 205
 206 (defun cl-print--preprocess (object)
 207   (let ((print-number-table (make-hash-table :test 'eq :rehash-size 2.0)))
 208     (if (fboundp 'print--preprocess)
 209         ;; Use the predefined C version if available.
 210         (print--preprocess object)           ;Fill print-number-table!
 211       (let ((cl-print--number-index 0))
 212         (cl-print--find-sharing object print-number-table)))
 213     print-number-table))
 214
 215 ;;;###autoload
 216 (defun cl-prin1 (object &optional stream)
 217   (cond
 218    (cl-print-readably (prin1 object stream))
 219    ((not print-circle) (cl-print-object object stream))
 220    (t
 221     (let ((cl-print--number-table (cl-print--preprocess object)))
 222       (cl-print-object object stream)))))
 223
 224 ;;;###autoload
 225 (defun cl-prin1-to-string (object)
 226   (with-temp-buffer
 227     (cl-prin1 object (current-buffer))
 228     (buffer-string)))
 229
 230 (provide 'cl-print)
 231 ;;; cl-print.el ends here