Merge remote-tracking branch 'origin/master' into feature/android
This commit is contained in:
Po Lu
commit
f812d92f67
40 changed files with 537 additions and 343 deletions
|
|
@ -66,8 +66,7 @@ delimiters."
|
|||
(if (and cl-print--depth (natnump print-level)
|
||||
(> cl-print--depth print-level))
|
||||
(cl-print-insert-ellipsis object 0 stream)
|
||||
(let ((car (pop object))
|
||||
(count 1))
|
||||
(let ((car (pop object)))
|
||||
(if (and print-quoted
|
||||
(memq car '(\, quote function \` \,@ \,.))
|
||||
(consp object)
|
||||
|
|
@ -80,26 +79,12 @@ delimiters."
|
|||
stream)
|
||||
(cl-print-object (car object) stream))
|
||||
(princ "(" stream)
|
||||
(cl-print-object car stream)
|
||||
(while (and (consp object)
|
||||
(not (cond
|
||||
(cl-print--number-table
|
||||
(numberp (gethash object cl-print--number-table)))
|
||||
((memq object cl-print--currently-printing))
|
||||
(t (push object cl-print--currently-printing)
|
||||
nil))))
|
||||
(princ " " stream)
|
||||
(if (or (not (natnump print-length)) (> print-length count))
|
||||
(cl-print-object (pop object) stream)
|
||||
(cl-print-insert-ellipsis object print-length stream)
|
||||
(setq object nil))
|
||||
(cl-incf count))
|
||||
(when object
|
||||
(princ " . " stream) (cl-print-object object stream))
|
||||
(cl-print--cons-tail car object stream)
|
||||
(princ ")" stream)))))
|
||||
|
||||
(cl-defmethod cl-print-object-contents ((object cons) _start stream)
|
||||
(let ((count 0))
|
||||
(defun cl-print--cons-tail (car object stream)
|
||||
(let ((count 1))
|
||||
(cl-print-object car stream)
|
||||
(while (and (consp object)
|
||||
(not (cond
|
||||
(cl-print--number-table
|
||||
|
|
@ -107,33 +92,27 @@ delimiters."
|
|||
((memq object cl-print--currently-printing))
|
||||
(t (push object cl-print--currently-printing)
|
||||
nil))))
|
||||
(unless (zerop count)
|
||||
(princ " " stream))
|
||||
(princ " " stream)
|
||||
(if (or (not (natnump print-length)) (> print-length count))
|
||||
(cl-print-object (pop object) stream)
|
||||
(cl-print-insert-ellipsis object print-length stream)
|
||||
(cl-print-insert-ellipsis object t stream)
|
||||
(setq object nil))
|
||||
(cl-incf count))
|
||||
(when object
|
||||
(princ " . " stream) (cl-print-object object stream))))
|
||||
|
||||
(cl-defmethod cl-print-object-contents ((object cons) _start stream)
|
||||
(cl-print--cons-tail (car object) (cdr object) stream))
|
||||
|
||||
(cl-defmethod cl-print-object ((object vector) stream)
|
||||
(if (and cl-print--depth (natnump print-level)
|
||||
(> cl-print--depth print-level))
|
||||
(cl-print-insert-ellipsis object 0 stream)
|
||||
(princ "[" stream)
|
||||
(let* ((len (length object))
|
||||
(limit (if (natnump print-length)
|
||||
(min print-length len) len)))
|
||||
(dotimes (i limit)
|
||||
(unless (zerop i) (princ " " stream))
|
||||
(cl-print-object (aref object i) stream))
|
||||
(when (< limit len)
|
||||
(princ " " stream)
|
||||
(cl-print-insert-ellipsis object limit stream)))
|
||||
(cl-print--vector-contents object 0 stream)
|
||||
(princ "]" stream)))
|
||||
|
||||
(cl-defmethod cl-print-object-contents ((object vector) start stream)
|
||||
(defun cl-print--vector-contents (object start stream)
|
||||
(let* ((len (length object))
|
||||
(limit (if (natnump print-length)
|
||||
(min (+ start print-length) len) len))
|
||||
|
|
@ -146,6 +125,9 @@ delimiters."
|
|||
(princ " " stream)
|
||||
(cl-print-insert-ellipsis object limit stream))))
|
||||
|
||||
(cl-defmethod cl-print-object-contents ((object vector) start stream)
|
||||
(cl-print--vector-contents object start stream)) ;FIXME: η-redex!
|
||||
|
||||
(cl-defmethod cl-print-object ((object hash-table) stream)
|
||||
(princ "#<hash-table " stream)
|
||||
(princ (hash-table-test object) stream)
|
||||
|
|
@ -232,24 +214,11 @@ into a button whose action shows the function's disassembly.")
|
|||
(> cl-print--depth print-level))
|
||||
(cl-print-insert-ellipsis object 0 stream)
|
||||
(princ "#s(" stream)
|
||||
(let* ((class (cl-find-class (type-of object)))
|
||||
(slots (cl--struct-class-slots class))
|
||||
(len (length slots))
|
||||
(limit (if (natnump print-length)
|
||||
(min print-length len) len)))
|
||||
(princ (cl--struct-class-name class) stream)
|
||||
(dotimes (i limit)
|
||||
(let ((slot (aref slots i)))
|
||||
(princ " :" stream)
|
||||
(princ (cl--slot-descriptor-name slot) stream)
|
||||
(princ " " stream)
|
||||
(cl-print-object (aref object (1+ i)) stream)))
|
||||
(when (< limit len)
|
||||
(princ " " stream)
|
||||
(cl-print-insert-ellipsis object limit stream)))
|
||||
(princ (cl--struct-class-name (cl-find-class (type-of object))) stream)
|
||||
(cl-print--struct-contents object 0 stream)
|
||||
(princ ")" stream)))
|
||||
|
||||
(cl-defmethod cl-print-object-contents ((object cl-structure-object) start stream)
|
||||
(defun cl-print--struct-contents (object start stream)
|
||||
(let* ((class (cl-find-class (type-of object)))
|
||||
(slots (cl--struct-class-slots class))
|
||||
(len (length slots))
|
||||
|
|
@ -258,7 +227,7 @@ into a button whose action shows the function's disassembly.")
|
|||
(i start))
|
||||
(while (< i limit)
|
||||
(let ((slot (aref slots i)))
|
||||
(unless (= i start) (princ " " stream))
|
||||
(unless (and (= i start) (> i 0)) (princ " " stream))
|
||||
(princ ":" stream)
|
||||
(princ (cl--slot-descriptor-name slot) stream)
|
||||
(princ " " stream)
|
||||
|
|
@ -268,6 +237,9 @@ into a button whose action shows the function's disassembly.")
|
|||
(princ " " stream)
|
||||
(cl-print-insert-ellipsis object limit stream))))
|
||||
|
||||
(cl-defmethod cl-print-object-contents ((object cl-structure-object) start stream)
|
||||
(cl-print--struct-contents object start stream)) ;FIXME: η-redex!
|
||||
|
||||
(cl-defmethod cl-print-object ((object string) stream)
|
||||
(unless stream (setq stream standard-output))
|
||||
(let* ((has-properties (or (text-properties-at 0 object)
|
||||
|
|
@ -294,28 +266,36 @@ into a button whose action shows the function's disassembly.")
|
|||
(- (point) 1) stream)))))
|
||||
;; Print the property list.
|
||||
(when has-properties
|
||||
(let* ((interval-limit (and (natnump print-length)
|
||||
(max 1 (/ print-length 3))))
|
||||
(interval-count 0)
|
||||
(start-pos (if (text-properties-at 0 object)
|
||||
0 (next-property-change 0 object)))
|
||||
(end-pos (next-property-change start-pos object len)))
|
||||
(while (and (or (null interval-limit)
|
||||
(< interval-count interval-limit))
|
||||
(< start-pos len))
|
||||
(let ((props (text-properties-at start-pos object)))
|
||||
(when props
|
||||
(princ " " stream) (princ start-pos stream)
|
||||
(princ " " stream) (princ end-pos stream)
|
||||
(princ " " stream) (cl-print-object props stream)
|
||||
(cl-incf interval-count))
|
||||
(setq start-pos end-pos
|
||||
end-pos (next-property-change start-pos object len))))
|
||||
(when (< start-pos len)
|
||||
(princ " " stream)
|
||||
(cl-print-insert-ellipsis object (list start-pos) stream)))
|
||||
(cl-print--string-props object 0 stream)
|
||||
(princ ")" stream)))))
|
||||
|
||||
(defun cl-print--string-props (object start stream)
|
||||
(let* ((first (not (eq start 0)))
|
||||
(len (length object))
|
||||
(interval-limit (and (natnump print-length)
|
||||
(max 1 (/ print-length 3))))
|
||||
(interval-count 0)
|
||||
(start-pos (if (text-properties-at start object)
|
||||
start (next-property-change start object)))
|
||||
(end-pos (next-property-change start-pos object len)))
|
||||
(while (and (or (null interval-limit)
|
||||
(< interval-count interval-limit))
|
||||
(< start-pos len))
|
||||
(let ((props (text-properties-at start-pos object)))
|
||||
(when props
|
||||
(if first
|
||||
(setq first nil)
|
||||
(princ " " stream))
|
||||
(princ start-pos stream)
|
||||
(princ " " stream) (princ end-pos stream)
|
||||
(princ " " stream) (cl-print-object props stream)
|
||||
(cl-incf interval-count))
|
||||
(setq start-pos end-pos
|
||||
end-pos (next-property-change start-pos object len))))
|
||||
(when (< start-pos len)
|
||||
(princ " " stream)
|
||||
(cl-print-insert-ellipsis object (list start-pos) stream))))
|
||||
|
||||
(cl-defmethod cl-print-object-contents ((object string) start stream)
|
||||
;; If START is an integer, it is an index into the string, and the
|
||||
;; ellipsis that needs to be expanded is part of the string. If
|
||||
|
|
@ -328,35 +308,13 @@ into a button whose action shows the function's disassembly.")
|
|||
(min (+ start print-length) len) len))
|
||||
(substr (substring-no-properties object start limit))
|
||||
(printed (prin1-to-string substr))
|
||||
(trimmed (substring printed 1 (1- (length printed)))))
|
||||
(princ trimmed)
|
||||
(trimmed (substring printed 1 -1)))
|
||||
(princ trimmed stream)
|
||||
(when (< limit len)
|
||||
(cl-print-insert-ellipsis object limit stream)))
|
||||
|
||||
;; Print part of the property list.
|
||||
(let* ((first t)
|
||||
(interval-limit (and (natnump print-length)
|
||||
(max 1 (/ print-length 3))))
|
||||
(interval-count 0)
|
||||
(start-pos (car start))
|
||||
(end-pos (next-property-change start-pos object len)))
|
||||
(while (and (or (null interval-limit)
|
||||
(< interval-count interval-limit))
|
||||
(< start-pos len))
|
||||
(let ((props (text-properties-at start-pos object)))
|
||||
(when props
|
||||
(if first
|
||||
(setq first nil)
|
||||
(princ " " stream))
|
||||
(princ start-pos stream)
|
||||
(princ " " stream) (princ end-pos stream)
|
||||
(princ " " stream) (cl-print-object props stream)
|
||||
(cl-incf interval-count))
|
||||
(setq start-pos end-pos
|
||||
end-pos (next-property-change start-pos object len))))
|
||||
(when (< start-pos len)
|
||||
(princ " " stream)
|
||||
(cl-print-insert-ellipsis object (list start-pos) stream))))))
|
||||
(cl-print--string-props object (car start) stream))))
|
||||
|
||||
;;; Circularity and sharing.
|
||||
|
||||
|
|
|
|||
|
|
@ -177,8 +177,9 @@ it inserts and pretty-prints that arg at point."
|
|||
(< (point) end))
|
||||
(let ((beg (point))
|
||||
;; Whether we're in front of an element with paired delimiters.
|
||||
;; Can be something funky like #'(lambda ..) or ,'#s(...).
|
||||
(paired (when (looking-at "['`,#]*[[:alpha:]]*\\([({[\"]\\)")
|
||||
;; Can be something funky like #'(lambda ..) or ,'#s(...)
|
||||
;; Or also #^[..].
|
||||
(paired (when (looking-at "['`,#]*[[:alpha:]^]*\\([({[\"]\\)")
|
||||
(match-beginning 1))))
|
||||
;; Go to the end of the sexp.
|
||||
(goto-char (or (scan-sexps (or paired (point)) 1) end))
|
||||
|
|
@ -238,7 +239,15 @@ it inserts and pretty-prints that arg at point."
|
|||
(defun pp-buffer ()
|
||||
"Prettify the current buffer with printed representation of a Lisp object."
|
||||
(interactive)
|
||||
(funcall pp-default-function (point-min) (point-max))
|
||||
;; The old code used `indent-sexp' which mostly works "anywhere",
|
||||
;; so let's make sure we also work right in buffers that aren't
|
||||
;; setup specifically for Lisp.
|
||||
(if (and (eq (syntax-table) emacs-lisp-mode-syntax-table)
|
||||
(eq indent-line-function #'lisp-indent-line))
|
||||
(funcall pp-default-function (point-min) (point-max))
|
||||
(with-syntax-table emacs-lisp-mode-syntax-table
|
||||
(let ((indent-line-function #'lisp-indent-line))
|
||||
(funcall pp-default-function (point-min) (point-max)))))
|
||||
;; Preserve old behavior of (usually) finishing with a newline and
|
||||
;; with point at BOB.
|
||||
(goto-char (point-max))
|
||||
|
|
|
|||
|
|
@ -1251,6 +1251,10 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'),
|
|||
:eval (>= 3 2 2 1))
|
||||
(zerop
|
||||
:eval (zerop 0))
|
||||
(natnump
|
||||
:eval (natnump -1)
|
||||
:eval (natnump 0)
|
||||
:eval (natnump 23))
|
||||
(cl-plusp
|
||||
:eval (cl-plusp 0)
|
||||
:eval (cl-plusp 1))
|
||||
|
|
@ -1261,9 +1265,6 @@ A FUNC form can have any number of `:no-eval' (or `:no-value'),
|
|||
:eval (cl-oddp 3))
|
||||
(cl-evenp
|
||||
:eval (cl-evenp 6))
|
||||
(natnump
|
||||
:eval (natnump -1)
|
||||
:eval (natnump 23))
|
||||
(bignump
|
||||
:eval (bignump 4)
|
||||
:eval (bignump (expt 2 90)))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue