[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
bug#25295: Represent eieio objects using object-print in backtraces and
From: |
Stefan Monnier |
Subject: |
bug#25295: Represent eieio objects using object-print in backtraces and edebug |
Date: |
Tue, 21 Feb 2017 12:23:12 -0500 |
User-agent: |
Gnus/5.13 (Gnus v5.13) Emacs/26.0.50 (gnu/linux) |
> Can we allow overriding printing of primitive types too?
> I'm wanting that for e.g., printing byte code functions in nicer ways.
Maybe we should just switch to an Elisp version of printing, in that case.
We could keep the C code for the "print-readably" case only.
The main question is whether it's fast enough.
Stefan
;;; cl-print.el --- Generic printer facilies -*- lexical-binding: t; -*-
;; Copyright (C) 2017 Stefan Monnier
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords:
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
;;;###autoload
(cl-defgeneric cl-print-object (object stream)
"Dispatcher to print OBJECT on STREAM according to its type."
(prin1 object stream))
(cl-defmethod cl-print-object ((object cons) stream)
(let ((car (pop object)))
(if (and (memq car '(\, quote \` \,@ \,.))
(consp object)
(null (cdr object)))
(progn
(princ (if (eq car 'quote) '\' car) stream)
(cl-print-object (car object) stream))
(princ "(" stream)
(cl-print-object car stream)
(while (consp object)
(princ " " stream)
(cl-print-object (pop object) stream))
(when object
(princ " . ") (cl-print-object object stream))
(princ ")"))))
(cl-defmethod cl-print-object ((object vector) stream)
(princ "[" stream)
(dotimes (i (length object))
(unless (zerop i) (princ " " stream))
(cl-print-object (aref object i) stream))
(princ "]" stream))
(cl-defmethod cl-print-object ((object compiled-function) stream)
;; FIXME: Give a prettier representation.
(princ "#<compiled-function>" stream))
(cl-defmethod cl-print-object ((object cl-structure-object) stream)
(princ "#s(")
(let* ((class (symbol-value (aref object 0)))
(slots (cl--struct-class-slots class)))
(princ (cl--struct-class-name class) stream)
(dotimes (i (length slots))
(let ((slot (aref slots i)))
(princ " :" stream)
(princ (cl--slot-descriptor-name slot) stream)
(princ " " stream)
(cl-print-object (aref object (1+ i)) stream))))
(princ ")"))
;;; Circularity and sharing.
;; I don't try to support the `print-continuous-numbering', because
;; I think it's ill defined anyway: if an object appears only once in each call
;; its sharing can't be properly preserved!
(defvar cl-print--number-index nil)
(defvar cl-print--number-table nil)
(cl-defmethod cl-print-object :around (object stream)
;; FIXME: Only put such an :around method on types where it's relevant.
(let ((n (if cl-print--number-table (gethash object cl-print--number-table))))
(if (not (numberp n))
(cl-call-next-method)
(if (> n 0)
;; Already printed. Just print a reference.
(progn (princ "#" stream) (princ n stream) (princ "#" stream))
(puthash object (- n) cl-print--number-table)
(princ "#" stream) (princ (- n) stream) (princ "=" stream)
(cl-call-next-method)))))
(defun cl-print--find-sharing (object table)
(unless
;; Skip objects which don't have identity!
(or (floatp object) (numberp object))
(let ((n (gethash object table)))
(cond
((numberp n)) ;All done.
(n ;Already seen, but only once.
(let ((n (1+ cl-print--number-index)))
(setq cl-print--number-index n)
(puthash object (- n) table)))
(t
(puthash object t table)
(pcase object
(`(,car . ,cdr)
(cl-print--find-sharing car table)
(cl-print--find-sharing cdr table))
((pred stringp)
;; We presumably won't print its text-properties.
nil)
((pred arrayp) ;FIXME: Inefficient for char-tables!
(dotimes (i (length object))
(cl-print--find-sharing (aref object i) table)))))))))
;;;###autoload
(defun cl-prin1 (object &optional stream)
(if (not print-circle)
(cl-print-object object stream)
(let ((cl-print--number-table (make-hash-table :test 'eq))
(cl-print--number-index 0))
(cl-print--find-sharing object cl-print--number-table)
(cl-print-object object stream))))
(provide 'cl-print)
;;; cl-print.el ends here