LCOV - code coverage report
Current view: top level - lisp/emacs-lisp - cl-print.el (source / functions) Hit Total Coverage
Test: tramp-tests.info Lines: 40 98 40.8 %
Date: 2017-08-27 09:44:50 Functions: 4 9 44.4 %

          Line data    Source code
       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             : (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        1762 :   (let ((car (pop object)))
      56         881 :     (if (and (memq car '(\, quote \` \,@ \,.))
      57          15 :              (consp object)
      58         881 :              (null (cdr object)))
      59          15 :         (progn
      60          15 :           (princ (if (eq car 'quote) '\' car) stream)
      61          15 :           (cl-print-object (car object) stream))
      62         866 :       (princ "(" stream)
      63         866 :       (cl-print-object car stream)
      64        2587 :       (while (and (consp object)
      65        1721 :                   (not (if cl-print--number-table
      66           0 :                            (numberp (gethash object cl-print--number-table))
      67        2587 :                          (memq object cl-print--currently-printing))))
      68        1721 :         (princ " " stream)
      69        3442 :         (cl-print-object (pop object) stream))
      70         866 :       (when object
      71         866 :         (princ " . " stream) (cl-print-object object stream))
      72         881 :       (princ ")" stream))))
      73             : 
      74             : (cl-defmethod cl-print-object ((object vector) stream)
      75           0 :   (princ "[" stream)
      76           0 :   (dotimes (i (length object))
      77           0 :     (unless (zerop i) (princ " " stream))
      78           0 :     (cl-print-object (aref object i) stream))
      79           0 :   (princ "]" stream))
      80             : 
      81             : (define-button-type 'help-byte-code
      82             :   'follow-link t
      83             :   'action (lambda (button)
      84             :             (disassemble (button-get button 'byte-code-function)))
      85             :   'help-echo (purecopy "mouse-2, RET: disassemble this function"))
      86             : 
      87             : (defvar cl-print-compiled nil
      88             :   "Control how to print byte-compiled functions.  Can be:
      89             : - `static' to print the vector of constants.
      90             : - `disassemble' to print the disassembly of the code.
      91             : - nil to skip printing any details about the code.")
      92             : 
      93             : (defvar cl-print-compiled-button t
      94             :   "Control how to print byte-compiled functions into buffers.
      95             : When the stream is a buffer, make the bytecode part of the output
      96             : into a button whose action shows the function's disassembly.")
      97             : 
      98             : (autoload 'disassemble-1 "disass")
      99             : 
     100             : (cl-defmethod cl-print-object ((object compiled-function) stream)
     101             :   (unless stream (setq stream standard-output))
     102             :   ;; We use "#f(...)" rather than "#<...>" so that pp.el gives better results.
     103             :   (princ "#f(compiled-function " stream)
     104             :   (let ((args (help-function-arglist object 'preserve-names)))
     105             :     (if args
     106             :         (prin1 args stream)
     107             :       (princ "()" stream)))
     108             :   (pcase (help-split-fundoc (documentation object 'raw) object)
     109             :     ;; Drop args which `help-function-arglist' already printed.
     110             :     (`(,_usage . ,(and doc (guard (stringp doc))))
     111             :      (princ " " stream)
     112             :      (prin1 doc stream)))
     113             :   (let ((inter (interactive-form object)))
     114             :     (when inter
     115             :       (princ " " stream)
     116             :       (cl-print-object
     117             :        (if (eq 'byte-code (car-safe (cadr inter)))
     118             :            `(interactive ,(make-byte-code nil (nth 1 (cadr inter))
     119             :                                           (nth 2 (cadr inter))
     120             :                                           (nth 3 (cadr inter))))
     121             :          inter)
     122             :        stream)))
     123             :   (if (eq cl-print-compiled 'disassemble)
     124             :       (princ
     125             :        (with-temp-buffer
     126             :          (insert "\n")
     127             :          (disassemble-1 object 0)
     128             :          (buffer-string))
     129             :        stream)
     130             :     (princ " " stream)
     131             :     (let ((button-start (and cl-print-compiled-button
     132             :                              (bufferp stream)
     133             :                              (with-current-buffer stream (point)))))
     134             :       (princ "#<bytecode>" stream)
     135             :       (when (eq cl-print-compiled 'static)
     136             :         (princ " " stream)
     137             :         (cl-print-object (aref object 2) stream))
     138             :       (when button-start
     139             :         (with-current-buffer stream
     140             :           (make-text-button button-start (point)
     141             :                             :type 'help-byte-code
     142             :                             'byte-code-function object)))))
     143             :   (princ ")" stream))
     144             : 
     145             : ;; This belongs in nadvice.el, of course, but some load-ordering issues make it
     146             : ;; complicated: cl-generic uses macros from cl-macs and cl-macs uses advice-add
     147             : ;; from nadvice, so nadvice needs to be loaded before cl-generic and hence
     148             : ;; can't use cl-defmethod.
     149             : (cl-defmethod cl-print-object :extra "nadvice"
     150             :               ((object compiled-function) stream)
     151           4 :   (if (not (advice--p object))
     152           4 :       (cl-call-next-method)
     153           2 :     (princ "#f(advice-wrapper " stream)
     154           2 :     (when (fboundp 'advice--where)
     155           2 :       (princ (advice--where object) stream)
     156           2 :       (princ " " stream))
     157           2 :     (cl-print-object (advice--cdr object) stream)
     158           2 :     (princ " " stream)
     159           0 :     (cl-print-object (advice--car object) stream)
     160           2 :     (let ((props (advice--props object)))
     161           2 :       (when props
     162           2 :         (princ " " stream)
     163           0 :         (cl-print-object props stream)))
     164           0 :     (princ ")" stream)))
     165             : 
     166             : (cl-defmethod cl-print-object ((object cl-structure-object) stream)
     167           0 :   (princ "#s(" stream)
     168           0 :   (let* ((class (cl-find-class (type-of object)))
     169           0 :          (slots (cl--struct-class-slots class)))
     170           0 :     (princ (cl--struct-class-name class) stream)
     171           0 :     (dotimes (i (length slots))
     172           0 :       (let ((slot (aref slots i)))
     173           0 :         (princ " :" stream)
     174           0 :         (princ (cl--slot-descriptor-name slot) stream)
     175           0 :         (princ " " stream)
     176           0 :         (cl-print-object (aref object (1+ i)) stream))))
     177           0 :   (princ ")" stream))
     178             : 
     179             : ;;; Circularity and sharing.
     180             : 
     181             : ;; I don't try to support the `print-continuous-numbering', because
     182             : ;; I think it's ill defined anyway: if an object appears only once in each call
     183             : ;; its sharing can't be properly preserved!
     184             : 
     185             : (cl-defmethod cl-print-object :around (object stream)
     186             :   ;; FIXME: Only put such an :around method on types where it's relevant.
     187        2617 :   (cond
     188        2617 :    (print-circle
     189           0 :     (let ((n (gethash object cl-print--number-table)))
     190           0 :       (if (not (numberp n))
     191           0 :           (cl-call-next-method)
     192           0 :         (if (> n 0)
     193             :             ;; Already printed.  Just print a reference.
     194           0 :             (progn (princ "#" stream) (princ n stream) (princ "#" stream))
     195           0 :           (puthash object (- n) cl-print--number-table)
     196           0 :           (princ "#" stream) (princ (- n) stream) (princ "=" stream)
     197           0 :           (cl-call-next-method)))))
     198        2617 :    ((let ((already-printing (memq object cl-print--currently-printing)))
     199        2617 :       (when already-printing
     200             :         ;; Currently printing, just print reference to avoid endless
     201             :         ;; recursion.
     202           0 :         (princ "#" stream)
     203        2617 :         (princ (length (cdr already-printing)) stream))))
     204        2617 :     (t (let ((cl-print--currently-printing
     205        2617 :               (cons object cl-print--currently-printing)))
     206        2617 :          (cl-call-next-method)))))
     207             : 
     208             : (defvar cl-print--number-index nil)
     209             : 
     210             : (defun cl-print--find-sharing (object table)
     211             :   ;; Avoid recursion: not only because it's too easy to bump into
     212             :   ;; `max-lisp-eval-depth', but also because function calls are fairly slow.
     213             :   ;; At first, I thought using a list for our stack would cause too much
     214             :   ;; garbage to generated, but I didn't notice any such problem in practice.
     215             :   ;; I experimented with using an array instead, but the result was slightly
     216             :   ;; slower and the reduction in GC activity was less than 1% on my test.
     217           0 :   (let ((stack (list object)))
     218           0 :     (while stack
     219           0 :       (let ((object (pop stack)))
     220           0 :         (unless
     221             :             ;; Skip objects which don't have identity!
     222           0 :             (or (floatp object) (numberp object)
     223           0 :                 (null object) (if (symbolp object) (intern-soft object)))
     224           0 :           (let ((n (gethash object table)))
     225           0 :             (cond
     226           0 :              ((numberp n))                   ;All done.
     227           0 :              (n                              ;Already seen, but only once.
     228           0 :               (let ((n (1+ cl-print--number-index)))
     229           0 :                 (setq cl-print--number-index n)
     230           0 :                 (puthash object (- n) table)))
     231             :              (t
     232           0 :               (puthash object t table)
     233           0 :               (pcase object
     234             :                 (`(,car . ,cdr)
     235           0 :                  (push cdr stack)
     236           0 :                  (push car stack))
     237             :                 ((pred stringp)
     238             :                  ;; We presumably won't print its text-properties.
     239             :                  nil)
     240             :                 ((or (pred arrayp) (pred byte-code-function-p))
     241             :                  ;; FIXME: Inefficient for char-tables!
     242           0 :                  (dotimes (i (length object))
     243           0 :                    (push (aref object i) stack))))))))))))
     244             : 
     245             : (defun cl-print--preprocess (object)
     246           0 :   (let ((print-number-table (make-hash-table :test 'eq :rehash-size 2.0)))
     247           0 :     (if (fboundp 'print--preprocess)
     248             :         ;; Use the predefined C version if available.
     249           0 :         (print--preprocess object)           ;Fill print-number-table!
     250           0 :       (let ((cl-print--number-index 0))
     251           0 :         (cl-print--find-sharing object print-number-table)))
     252           0 :     print-number-table))
     253             : 
     254             : ;;;###autoload
     255             : (defun cl-prin1 (object &optional stream)
     256          15 :   (cond
     257          15 :    (cl-print-readably (prin1 object stream))
     258          15 :    ((not print-circle) (cl-print-object object stream))
     259             :    (t
     260           0 :     (let ((cl-print--number-table (cl-print--preprocess object)))
     261          14 :       (cl-print-object object stream)))))
     262             : 
     263             : ;;;###autoload
     264             : (defun cl-prin1-to-string (object)
     265           0 :   (with-temp-buffer
     266           0 :     (cl-prin1 object (current-buffer))
     267           0 :     (buffer-string)))
     268             : 
     269             : (provide 'cl-print)
     270             : ;;; cl-print.el ends here

Generated by: LCOV version 1.12