欲用 pp 格式化 elisp 至指定列宽，然输出与预期不符，细节如下：
格式化 elisp, 列宽 42 (for phone):
(let ((fill-column 42))
(pp
'(defalias 'X
((lambda (log)
(defalias log
(lambda (fmt &rest args)
(when debug-on-error
(princ
(apply #'format
(concat
(format-time-string
"[%Y-%m-%d %H:%M:%S.%3N]"
(current-time))
fmt "\n")
args)
(get-buffer-create " *log:X*"))))))
(make-symbol "log")))))
输出：
(defalias 'X
((lambda (log)
(defalias log
(lambda (fmt &rest args)
(when debug-on-error
(princ
(apply #'format
(concat
(format-time-string
"[%Y-%m-%d %H:%M:%S.%3N]"
;; ^ column 46
(current-time))
fmt "\n")
args)
(get-buffer-create
" *log:X*"))))))
(make-symbol "log")))
预期：
(defalias 'X
((lambda (log)
(defalias log
(lambda (fmt &rest args)
(when debug-on-error
(princ
(apply
#'format
(concat
(format-time-string
"[%Y-%m-%d %H:%M:%S.%3N]"
;; ^ column 40
(current-time))
fmt "\n")
args)
(get-buffer-create
" *log:X*"))))))
(make-symbol "log")))
问题：是用法不对，还是？或者：有无其他 “代码与注释” 一起 fill 的内置工具？
注: pp → pp-default-function → pp-fill
pp-fill is an interactive native-comp-function in ‘pp.el’.
(pp-fill BEG &optional END)
Break lines in Lisp code between BEG and END so it fits within ‘fill-column’.
Presumes the current buffer has syntax and indentation properly
configured for that.
Designed under the assumption that the region occupies a single line,
tho it should also work if that’s not the case.
Can also be called with a single argument, in which case
it inserts and pretty-prints that arg at point.
参考 pp-fiil 撸了个 fill-elisp, 以将当前 elisp buffer 的 代码与注释 一同 fill. 出于保留格式的原因，暂时不管 docstring.
注：不保证正确性，不保证性能。
#+name: 2025-06-29-17-18
#+header: :tangle ~/org/fill-elisp.el
#+begin_src emacs-lisp :results silent :lexical t :noweb yes
;;; fill-elisp.el -*- lexical-binding: t; -*-
;;; Commentary:
;;; Code:
<<2025-06-29-17-24>>
<<2025-06-29-17-29>>
(defun elisp-compress (&optional remove-empty-line)
"尽可能地删除换行与空白字符。"
(interactive)
(goto-char (point-min))
(while (< (point) (point-max))
;; 移除当前行首的空白字符
(unless (nth 3 (syntax-ppss))
(goto-char (line-beginning-position))
(fixup-whitespace)
(goto-char (line-end-position)))
(cond
;; 注释行或字符串中？
((or (nth 4 (syntax-ppss)) (nth 3 (syntax-ppss)))
(forward-line 1))
;; 多行空行中或多行空行首？
((and (not remove-empty-line)
(or (eq (char-before) ?\n)
(looking-at-p "\n[ \t\r]*\n")))
(skip-chars-forward "\n"))
(t
(delete-indentation t)
;; 如果删除字符至注释行，让注释重新占据一行。
(when (looking-at-p "[ \t\r]*\\s<") (insert "\n")))))
(delete-trailing-whitespace))
(defun fill-elisp (&optional buffer-or-name)
(declare (indent 1))
(interactive)
(with-current-buffer (or buffer-or-name (current-buffer))
(!let* ((point (point))
(break-line
(lambda nil (ignore (insert "\n") (indent-according-to-mode))))
;; First sexp in the current line?
(first-sexp?
(lambda nil (save-excursion (skip-syntax-backward " ") (bolp))))
;; 视情况将当前 point 指向的 (作为某个 sexp 的子节点的)
;; sexp 折置新行。当它：非当前行内首个 sexp; point 指向行
;; 尾; 已无同级 sexp; point 指向注释。
(break-subsexp
(lambda nil
(unless
(or
;; Has no sexp in the rest of the current line?
;; 这里用 `$' 不用 `\n' 因为 `(point-max)' 之后
;; 无 `\n' 时，用 `\n' 无法正确识别“行尾”。
(looking-at-p "[ \t\r]*$")
;; Done with all child sexps?
(looking-at-p "[ \r\t]*)")
(first-sexp?)
;; 非注释
(looking-at-p "[ \r\t]*\\s<"))
(break-line))))
;; FIXME: 这个检测 list 与否的 test 可能不太完备。
(looking-at-list?
(lambda nil (looking-at-p "[',`]*(")))
;; 语法上必须 break 的 case, 否则当前 sexp 会被染红。另见
;; `font-lock-warning-face', `lisp--match-hidden-arg'.
(syntax-invalid?
(lambda ()
(ignore-errors
(save-excursion
(let* ((lbp (line-beginning-position))
(p (point))
(ppss (parse-partial-sexp lbp p -1)))
(skip-syntax-forward " )")
(unless (or (>= (car ppss) 0)
(eolp)
(looking-at-p ";")
(nth 8 (syntax-ppss)))
(and (looking-at-p ".*") (>= p (point)))))))))
(indent-if-line-change
(let ((last-line 1)) ; FIXME: what if no start from 1?
(lambda ()
(unless (eq last-line (line-number-at-pos))
(save-excursion
(let ((inhibit-message t)
(message-log-max nil))
(indent-region
(save-excursion
(goto-line last-line)
(point))
(point))))
(setq last-line (line-number-at-pos))
(indent-according-to-mode)
(skip-chars-forward " \t\r")))))
;; 判断当前 point 指向的 sexp 是否需折行，具体有两个方面：
;; 一、当前 sexp 是否需折置新行；二、当前 sexp 的子 sexp
;; 是否需折置新行。
(break-sexp?
(lambda ()
(or
;; 有些 sexp 被注释行分割为多行，如果它的 body 正好被注释
;; 分隔为两部分，且注释前的 body 和它同处一行且长度小于
;; `fill-column', 该部分 body 也许会被判定为无需折行，导
;; 致注释后的 body 与 注释前的 body 对齐，进而导致它的
;; body 部分缩进太多，页面左边留白严重。所以，这里我们一
;; 旦识别到 sexp 占据多行，我们必折其body.
(>
(let* ((sexp (thing-at-point 'sexp t))
(lines (string-split sexp "\n")))
(length lines))
1)
;; 如果单行的 sexp 长度超过 `fill-column'.
(>
(save-excursion
;; 去 sexp 尾部。
(forward-sexp)
;; 回退置最外层 sexp.
(skip-chars-forward " \t\r)")
;; current-column 从 0 起，这里 `1+' 处理。
(1+ (current-column)))
fill-column))))
(log
(lambda (fmt &rest args)
;; "[%Y-%m-%d %H:%M:%S.%6N]"
(when debug-on-error
(princ
(apply #'format
(concat
(format-time-string
"[%s.%6N]"
(current-time))
fmt "\n")
args)
(get-buffer-create " *log:fill-elisp*"))
nil)))
(log-current-sexp
(lambda ()
(let* ((sexp (thing-at-point 'sexp t))
(sexp-len (length sexp)))
(log
(concat
"line %S ccol %S len %S "
"fcol %S sexp %S "
;; "%S"
)
(line-number-at-pos)
(current-column)
(length sexp)
fill-column
(cond
((length> sexp 20) (substring sexp 0 20))
(t sexp))
;; (buffer-substring-no-properties (point) (point-max))
)))))
(ignore-errors (kill-buffer " *log:fill-elisp*"))
(elisp-compress)
(map-sexp
(lambda (lv)
;; 如果我们进入了新的行，调整新行到先前行之间的缩进，以免因这些行之
;; 间可能存在的注释行影响代码行缩进。
(indent-if-line-change)
(log-current-sexp)
;; 针对当前 point 所指的当前 sexp, 有如下决策：
;;
;; 一、当前 sexp 是否需要另起一行；
;;
;; 二、当前 sexp 的 body 子节点是否需要另起一行。
;;
;; 所以我们有两部分的处理逻辑：
;; 是否将当前 sexp 折置新行：
(cond
;; 行内首个 sexp 不再折行。
((log " >h1"))
((first-sexp?))
;; 语法上必须 break 的 case, 否则当前 sexp 会被染红。
((log " >h2"))
((syntax-invalid?) (break-line))
;; 如果 sexp 内部需要折行，而它又非行内首个 sexp,
;; 我们试着将其折置新行，看看能省多少缩进。
((log " >h3"))
((and (break-sexp?))
(let ((oldcol (current-column)))
(break-line)
;; 折后行，若缩进量无明显改变，我们取消折行。
;; 比如对 let 的 varlist 折行时,
;; varlist 的缩进量仅减一。
(when (<= (- oldcol (current-column)) 2)
(delete-indentation)
(skip-syntax-forward " "))))
;; 不折行。
((log " >he")))
;; 是否将当前 sexp 的子 sexp 折置新行：
(save-excursion
(cond
;; 非 list, 无 body 需处理；或者当前 sexp 无需折行。
((or (not (looking-at-list?)) (not (break-sexp?))))
((ignore (down-list))) ; 深入 sexp.
;; 如果当前 sexp 是嵌套 list, 把它的除首个子节点外
;; 的所有子节点全置于新行中。
((log " >b1"))
((looking-at-list?)
(while (ignore-errors (forward-sexp) t)
(break-subsexp))
t)
;; 处理 symbol.
((log " >b2"))
((when-let*
((sym (symbol-at-point))
;; symbol 的 lisp-indent-function 属性为
;; `nil', 按无参形式折行。
(lif (or (get sym 'lisp-indent-function) 0))
(lif (if (eq lif 'defun) 2 lif))
(_ (natnump lif)))
(when
(ignore-errors
;; 跳过通常作为 function 的首个 symbol.
(forward-sexp 1)
;; 跳过 lif 个参数。
(forward-sexp lif)
t)
(break-subsexp))
t))
;; 其他非 symbol 非 list 的东西，暂时不管。
((log " >be"))))))
(map-elisp-comment #'fill-comment-paragraph)
;; (delete-trailing-whitespace)
(goto-char (min point (point-max))))))
;;; End
(provide 'fill-elisp)
;;; fill-elisp.el ends here
#+end_src
map sexp 及 comment:
#+name: 2025-06-29-17-29
#+begin_src emacs-lisp :results silent :lexical t
(defun map-sexp (func &optional beg lv)
"从 beg 起，遍历当前 buffer 中的 sexp, 深度优先。"
(save-excursion
(goto-char (or beg (point-min)))
(let ((parse-sexp-ignore-comments t)
(lv (or lv 1)) r start end)
;; scan-sexps 前进时默认跑到 sexp 的末尾，
(setq end (point))
(while (ignore-errors (setq end (scan-sexps end 1)))
(goto-char end)
;; 我们在这里临时折回 sexp 的头部，调用用户函数。因为 quote 等
;; 前缀字符，我们用 `backward-sexp' 而不用 `scan-sexps'. 另外，
;; 我们这里用特殊的 marker 标记 start, 以免受 func 中的 insert
;; 操作影响。
(setq start (progn (backward-sexp) (copy-marker (point) t)))
(setq r (append r (list (funcall func lv))))
;; func 有可能已经改变了 point.
(goto-char start)
(setq end (scan-sexps (point) 1))
;; 处理 sexp 的子节点。
(ignore-errors
(down-list)
;; `down-list' 可能会跨越多个 sexp 跳入最近的 list, 比如给定
;; sexp: (^atom list), 光标位置^, 此时 `down-list' 会完全跨
;; 过作为 atom 的 sexp 进入 list, 而我们希望 `down-list' 在
;; 这种情况下报错——因非 list 无可深入，所以我们在此检测它是
;; 否跳出了当前 sexp.
(when (> (point) end) (error nil))
(setq r (append r (map-sexp func (point) (1+ lv)))))
;; 处理下个同级节点。
(goto-char start)
(setq end (scan-sexps (point) 1)))
r)))
(defun map-elisp-comment (func)
(save-excursion
(save-match-data
(goto-char (point-min))
(let (r)
(while (re-search-forward "\\s<" nil t)
(backward-char (length comment-start))
;; 我们不想处理类似大纲的注释。
(unless (or (looking-at ";;;"))
(push (funcall func) r))
(forward-comment 1))
(nreverse r)))))
#+end_src
let 改：
#+name: 2025-06-29-17-24
#+begin_src emacs-lisp :results silent :lexical t
(defmacro !let (bindings &rest body)
(declare (indent 1) (debug let))
(cond
((null bindings) `(progn ,@body))
(t
(let (vars vals lambdas)
(mapc
(lambda (binding &optional var val carval)
(setq var (or (car-safe binding) binding))
(setq val (car (cdr-safe binding)))
(setq carval (car-safe val))
(cond
((memq carval '(lambda function))
(push var lambdas))
((and (memq carval '(let let* letrec !let !let*))
(eq (car (car (last val))) 'lambda))
(push var lambdas)))
(push var vars)
(push val vals))
bindings)
(setq body `(funcall
(lambda (,@(nreverse vars))
,@body)
,@(nreverse vals)))
(cond
((null lambdas) body)
(t
`(cl-macrolet
,(mapcar
(lambda (s)
`(,s (&rest args)
`(funcall ,',s ,@args)))
(nreverse lambdas))
,body)))))))
(defmacro !let* (bindings &rest body)
(declare (indent 1) (debug let))
(if (null bindings) `(progn ,@body)
(setq bindings (reverse bindings))
(while bindings
(setq body (list `(!let (,(pop bindings)) ,@body))))
(car body)))
#+end_src
1 个赞
测试：
M-x eww RET https://emacs-china.org/t/pp-fill-lisp/29712/2 RET
M-x org-mode
M-x read-only-mode
M-x org-babel-execute-buffer