* lisp/emacs-lisp/cl-print.el: New file
* lisp/emacs-lisp/nadvice.el (advice--where): New function. (advice--make-docstring): Use it. * src/print.c (print_number_index): Don't declare here any more. (Fprint_preprocess): New function. * test/lisp/emacs-lisp/cl-print-tests.el: New file.
This commit is contained in:
Stefan Monnier
parent
f6d2ba74f8
commit
407e650413
4 changed files with 271 additions and 15 deletions
196
lisp/emacs-lisp/cl-print.el
Normal file
196
lisp/emacs-lisp/cl-print.el
Normal file
|
|
@ -0,0 +1,196 @@
|
|||
;;; cl-print.el --- CL-style generic printer facilies -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2017 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
;; Keywords:
|
||||
;; Version: 1.0
|
||||
;; Package-Requires: ((emacs "25"))
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs 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.
|
||||
|
||||
;; GNU Emacs 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 GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Customizable print facility.
|
||||
;;
|
||||
;; The heart of it is the generic function `cl-print-object' to which you
|
||||
;; can add any method you like.
|
||||
;;
|
||||
;; The main entry point is `cl-prin1'.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(defvar cl-print-readably nil
|
||||
"If non-nil, try and make sure the result can be `read'.")
|
||||
|
||||
(defvar cl-print--number-table nil)
|
||||
|
||||
;;;###autoload
|
||||
(cl-defgeneric cl-print-object (object stream)
|
||||
"Dispatcher to print OBJECT on STREAM according to its type.
|
||||
You can add methods to it to customize the output.
|
||||
But if you just want to print something, don't call this directly:
|
||||
call other entry points instead, such as `cl-prin1'."
|
||||
;; This delegates to the C printer. The C printer will not call us back, so
|
||||
;; we should only use it for objects which don't have nesting.
|
||||
(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 (and (consp object)
|
||||
(not (and cl-print--number-table
|
||||
(numberp (gethash object cl-print--number-table)))))
|
||||
(princ " " stream)
|
||||
(cl-print-object (pop object) stream))
|
||||
(when object
|
||||
(princ " . " stream) (cl-print-object object stream))
|
||||
(princ ")" stream))))
|
||||
|
||||
(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)
|
||||
(princ "#<compiled-function " stream)
|
||||
(prin1 (help-function-arglist object 'preserve-names) stream)
|
||||
(princ " #<bytecode> >" stream))
|
||||
|
||||
;; This belongs in nadvice.el, of course, but some load-ordering issues make it
|
||||
;; complicated: cl-generic uses macros from cl-macs and cl-macs uses advice-add
|
||||
;; from nadvice, so nadvice needs to be loaded before cl-generic and hence
|
||||
;; can't use cl-defmethod.
|
||||
(cl-defmethod cl-print-object :extra "nadvice"
|
||||
((object compiled-function) stream)
|
||||
(if (not (advice--p object))
|
||||
(cl-call-next-method)
|
||||
(princ "#<advice-wrapper " stream)
|
||||
(when (fboundp 'advice--where)
|
||||
(princ (advice--where object) stream)
|
||||
(princ " " stream))
|
||||
(cl-print-object (advice--cdr object) stream)
|
||||
(princ " " stream)
|
||||
(cl-print-object (advice--car object) stream)
|
||||
(let ((props (advice--props object)))
|
||||
(when props
|
||||
(princ " " stream)
|
||||
(cl-print-object props stream)))
|
||||
(princ ">" stream)))
|
||||
|
||||
(cl-defmethod cl-print-object ((object cl-structure-object) stream)
|
||||
(princ "#s(" stream)
|
||||
(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 ")" stream))
|
||||
|
||||
;;; 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!
|
||||
|
||||
(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)))))
|
||||
|
||||
(defvar cl-print--number-index nil)
|
||||
|
||||
(defun cl-print--find-sharing (object table)
|
||||
;; Avoid recursion: not only because it's too easy to bump into
|
||||
;; `max-lisp-eval-depth', but also because function calls are fairly slow.
|
||||
;; At first, I thought using a list for our stack would cause too much
|
||||
;; garbage to generated, but I didn't notice any such problem in practice.
|
||||
;; I experimented with using an array instead, but the result was slightly
|
||||
;; slower and the reduction in GC activity was less than 1% on my test.
|
||||
(let ((stack (list object)))
|
||||
(while stack
|
||||
(let ((object (pop stack)))
|
||||
(unless
|
||||
;; Skip objects which don't have identity!
|
||||
(or (floatp object) (numberp object)
|
||||
(null object) (if (symbolp object) (intern-soft 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)
|
||||
(push cdr stack)
|
||||
(push car stack))
|
||||
((pred stringp)
|
||||
;; We presumably won't print its text-properties.
|
||||
nil)
|
||||
((or (pred arrayp) (pred byte-code-function-p))
|
||||
;; FIXME: Inefficient for char-tables!
|
||||
(dotimes (i (length object))
|
||||
(push (aref object i) stack))))))))))))
|
||||
|
||||
(defun cl-print--preprocess (object)
|
||||
(let ((print-number-table (make-hash-table :test 'eq :rehash-size 2.0)))
|
||||
(if (fboundp 'print--preprocess)
|
||||
;; Use the predefined C version if available.
|
||||
(print--preprocess object) ;Fill print-number-table!
|
||||
(let ((cl-print--number-index 0))
|
||||
(cl-print--find-sharing object print-number-table)))
|
||||
print-number-table))
|
||||
|
||||
;;;###autoload
|
||||
(defun cl-prin1 (object &optional stream)
|
||||
(cond
|
||||
(cl-print-readably (prin1 object stream))
|
||||
((not print-circle) (cl-print-object object stream))
|
||||
(t
|
||||
(let ((cl-print--number-table (cl-print--preprocess object)))
|
||||
(cl-print-object object stream)))))
|
||||
|
||||
;;;###autoload
|
||||
(defun cl-prin1-to-string (object)
|
||||
(with-temp-buffer
|
||||
(cl-prin1 object (current-buffer))
|
||||
(buffer-string)))
|
||||
|
||||
(provide 'cl-print)
|
||||
;;; cl-print.el ends here
|
||||
|
|
@ -72,6 +72,13 @@ Each element has the form (WHERE BYTECODE STACK) where:
|
|||
(setq f (advice--cdr f)))
|
||||
f)
|
||||
|
||||
(defun advice--where (f)
|
||||
(let ((bytecode (aref f 1))
|
||||
(where nil))
|
||||
(dolist (elem advice--where-alist)
|
||||
(if (eq bytecode (cadr elem)) (setq where (car elem))))
|
||||
where))
|
||||
|
||||
(defun advice--make-docstring (function)
|
||||
"Build the raw docstring for FUNCTION, presumably advised."
|
||||
(let* ((flist (indirect-function function))
|
||||
|
|
@ -79,16 +86,13 @@ Each element has the form (WHERE BYTECODE STACK) where:
|
|||
(docstring nil))
|
||||
(if (eq 'macro (car-safe flist)) (setq flist (cdr flist)))
|
||||
(while (advice--p flist)
|
||||
(let ((bytecode (aref flist 1))
|
||||
(doc (aref flist 4))
|
||||
(where nil))
|
||||
(let ((doc (aref flist 4))
|
||||
(where (advice--where flist)))
|
||||
;; Hack attack! For advices installed before calling
|
||||
;; Snarf-documentation, the integer offset into the DOC file will not
|
||||
;; be installed in the "core unadvised function" but in the advice
|
||||
;; object instead! So here we try to undo the damage.
|
||||
(if (integerp doc) (setq docfun flist))
|
||||
(dolist (elem advice--where-alist)
|
||||
(if (eq bytecode (cadr elem)) (setq where (car elem))))
|
||||
(setq docstring
|
||||
(concat
|
||||
docstring
|
||||
|
|
@ -502,6 +506,10 @@ of the piece of advice."
|
|||
(setq frame2 (backtrace-frame i #'called-interactively-p))
|
||||
;; (message "Advice Frame %d = %S" i frame2)
|
||||
(setq i (1+ i)))))
|
||||
;; FIXME: Adjust this for the new :filter advices, since they use `funcall'
|
||||
;; rather than `apply'.
|
||||
;; FIXME: Somehow this doesn't work on (advice-add :before
|
||||
;; 'call-interactively #'ignore), see bug#3984.
|
||||
(when (and (eq (nth 1 frame2) 'apply)
|
||||
(progn
|
||||
(funcall get-next-frame)
|
||||
|
|
|
|||
32
src/print.c
32
src/print.c
|
|
@ -640,7 +640,7 @@ is used instead. */)
|
|||
return object;
|
||||
}
|
||||
|
||||
/* a buffer which is used to hold output being built by prin1-to-string */
|
||||
/* A buffer which is used to hold output being built by prin1-to-string. */
|
||||
Lisp_Object Vprin1_to_string_buffer;
|
||||
|
||||
DEFUN ("prin1-to-string", Fprin1_to_string, Sprin1_to_string, 1, 2, 0,
|
||||
|
|
@ -1140,14 +1140,14 @@ print (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
|
|||
print_object (obj, printcharfun, escapeflag);
|
||||
}
|
||||
|
||||
#define PRINT_CIRCLE_CANDIDATE_P(obj) \
|
||||
(STRINGP (obj) || CONSP (obj) \
|
||||
|| (VECTORLIKEP (obj) \
|
||||
&& (VECTORP (obj) || COMPILEDP (obj) \
|
||||
|| CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) \
|
||||
|| HASH_TABLE_P (obj) || FONTP (obj))) \
|
||||
|| (! NILP (Vprint_gensym) \
|
||||
&& SYMBOLP (obj) \
|
||||
#define PRINT_CIRCLE_CANDIDATE_P(obj) \
|
||||
(STRINGP (obj) || CONSP (obj) \
|
||||
|| (VECTORLIKEP (obj) \
|
||||
&& (VECTORP (obj) || COMPILEDP (obj) \
|
||||
|| CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) \
|
||||
|| HASH_TABLE_P (obj) || FONTP (obj))) \
|
||||
|| (! NILP (Vprint_gensym) \
|
||||
&& SYMBOLP (obj) \
|
||||
&& !SYMBOL_INTERNED_P (obj)))
|
||||
|
||||
/* Construct Vprint_number_table according to the structure of OBJ.
|
||||
|
|
@ -1260,6 +1260,16 @@ print_preprocess (Lisp_Object obj)
|
|||
print_depth--;
|
||||
}
|
||||
|
||||
DEFUN ("print--preprocess", Fprint_preprocess, Sprint_preprocess, 1, 1, 0,
|
||||
doc: /* Extract sharing info from OBJECT needed to print it.
|
||||
Fills `print-number-table'. */)
|
||||
(Lisp_Object object)
|
||||
{
|
||||
print_number_index = 0;
|
||||
print_preprocess (object);
|
||||
return Qnil;
|
||||
}
|
||||
|
||||
static void
|
||||
print_preprocess_string (INTERVAL interval, Lisp_Object arg)
|
||||
{
|
||||
|
|
@ -1537,7 +1547,8 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag)
|
|||
|
||||
size_byte = SBYTES (name);
|
||||
|
||||
if (! NILP (Vprint_gensym) && !SYMBOL_INTERNED_P (obj))
|
||||
if (! NILP (Vprint_gensym)
|
||||
&& !SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (obj))
|
||||
print_c_string ("#:", printcharfun);
|
||||
else if (size_byte == 0)
|
||||
{
|
||||
|
|
@ -2344,6 +2355,7 @@ priorities. */);
|
|||
defsubr (&Sterpri);
|
||||
defsubr (&Swrite_char);
|
||||
defsubr (&Sredirect_debugging_output);
|
||||
defsubr (&Sprint_preprocess);
|
||||
|
||||
DEFSYM (Qprint_escape_newlines, "print-escape-newlines");
|
||||
DEFSYM (Qprint_escape_multibyte, "print-escape-multibyte");
|
||||
|
|
|
|||
40
test/lisp/emacs-lisp/cl-print-tests.el
Normal file
40
test/lisp/emacs-lisp/cl-print-tests.el
Normal file
|
|
@ -0,0 +1,40 @@
|
|||
;;; cl-print-tests.el --- Test suite for the cl-print facility. -*- lexical-binding:t -*-
|
||||
|
||||
;; Copyright (C) 2017 Free Software Foundation, Inc.
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; GNU Emacs 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.
|
||||
|
||||
;; GNU Emacs 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 GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'ert)
|
||||
|
||||
(cl-defstruct cl-print--test a b)
|
||||
|
||||
(ert-deftest cl-print-tests-1 ()
|
||||
"Test cl-print code."
|
||||
(let ((x (make-cl-print--test :a 1 :b 2)))
|
||||
(let ((print-circle nil))
|
||||
(should (equal (cl-prin1-to-string `((x . ,x) (y . ,x)))
|
||||
"((x . #s(cl-print--test :a 1 :b 2)) (y . #s(cl-print--test :a 1 :b 2)))")))
|
||||
(let ((print-circle t))
|
||||
(should (equal (cl-prin1-to-string `((x . ,x) (y . ,x)))
|
||||
"((x . #1=#s(cl-print--test :a 1 :b 2)) (y . #1#))")))
|
||||
(should (string-match "\\`#<compiled-function (x) .*>\\'"
|
||||
(cl-prin1-to-string (symbol-function #'caar))))))
|
||||
|
||||
;;; cl-print-tests.el ends here.
|
||||
Loading…
Add table
Reference in a new issue