特性
package
一个符号管理工具。
package
(defalias '!pkg
[((&rest args)
(:documentation
(or (ignore-errors
(function-documentation default))
""))
(declare (!export t if unbound)
((! see also) default))
(ignore define) ; capture define
(cond*
((bind* (s (car args)) (r (cdr args))))
((eq s 'def) (if r `(,def ,@r) `',def))
;; 因为 (cond* ((and 1 2))(t 3)) 返回 3,
;; 这里只能用 cond, 为捕获内部变量。
((bind* (p (eval
`(cond ,@pattern)
`((args . ,args)
(car . ,(car args))
,@(aref
(symbol-function package)
2))))))
(p (symbolize p) `(,p ,@args))
;; 后续分支将 ! 作为 Namespace 用。
((bind* (ef (alist-get s export))))
((bind* (f (or ef default))))
((null f) nil)
((bind* (f? (functionp f))
(m? (macrop f))))
((not (or f? m?)) `',f)
((bind* (r (if ef r args))))
((bind* (amin (car (func-arity f)))))
;; ((and (> amin (length r))) `',f)
((bind* (a (and (null r) (= amin 0)
apply0))))
((bind* (_ (and (null a) r)))
(setf a (if f? fapply mapply)))
((bind* (a (or (get f '!apply) a))))
((and a (listp a)) `(,@a ,f ,@r))
(a `(,a ,f ,@r))
(r `(,f ,@r))
(f `',f)))
((sym &rest val)
(cond*
((bind* (has-val val) (val (car val))))
((listp sym)
(setf
(alist-get sym pattern nil nil 'equal)
(if val (list `',val))))
((bind* (s (alist-get sym export))
(n (symbol-name sym)))
;; 重用空 symbol, 为 autoload.
(when (or (boundp s)
(symbol-function s))
(setf s nil)))
((and val (symbolp val) (setf s val) nil))
((or s (setf s (make-symbol n)))
;; set symbol-value/fucntion to val
(setf (alist-get sym export) s)
(if has-val (set s val))
(cond
;; ((null val) (fset s val))
((and (not (functionp val))
(not (macrop val)))
(unless (eq s val) (fset s val)))
((or define (not (eq s val)))
(let ((def (or define 'fset)))
(eval `(,def ',s ',val) t))))
s)))
((&rest FMs)
(let ((fm (make-symbol "fm"))
(name (make-symbol "name"))
code)
(dolist (FM FMs code)
(push
`(let* ((,fm ,FM)
(,name (symbol-name ',FM)))
(when (and ,fm
(not (symbolp ,fm))
(or (functionp ,fm)
(macrop ,fm)))
(setf ,name (make-symbol ,name)
,FM (fset ,name ,fm)
,FM ,name)
(set ,name ,name)))
code))
(macroexp-progn (nreverse code))))
])
(defalias '!pkg
(eval
(macroexpand-all
`(lambda (default &rest args)
(declare (!export t))
(let ((package (make-symbol "package"))
(def (make-symbol "def"))
(define (plist-get args :def))
(fapply (plist-get args :fapply))
(mapply (plist-get args :mapply))
(apply0 (plist-get args :apply0))
pattern export)
;; 因为 (#'(...) ARGS) 的 #'(...) 导致 ARGS
;; 无法被宏展开，所以我们将这些东西符号化。
(symbolize default define
fapply mapply apply0)
(defalias def
(lambda
,@(aref (symbol-function '!pkg) 1)))
(defalias package
(lambda
,@(aref (symbol-function '!pkg) 0)))
`(macro . ,(indirect-function package))))
`((symbolize
. (lambda
,@(aref (symbol-function '!pkg) 2)))))
t))
(defalias (fmakunbound '!)
(!pkg
(cons 'macro
#'(lambda (&rest args)
(declare ((! indent) (! indent cont)))
(when-let*
((R (eval'(! remove-comment)t)))
(apply R (cons '! args)))))))
(! def 'remove-comment (lambda(a &rest _)))
(! def 'package (prog1 (symbol-function '!pkg)
(fmakunbound '!pkg)))
lambda
针对匿名函数、匿名宏的简写。
匿名函数简写可为:
(![ARGLIST]BODY) ~ (lambda(ARGLIST)BODY)
匿名宏简写可为:
(!"ARGLIST"BODY) ~ (macro . ,(lambda(ARGLIST)BODY))
此外, ARGLIST 有特殊的语法扩展：
(![…]) ~ (![&rest …])
(![2]) ~ (![x0 x1])
(![n]) ~ (![x0 x1 … xn])
(![-2]) ~ (![&optional x0 x1])
(![-n]) ~ (![&optional x0 x1 … xn])
F:lambda
(! def 'macro
'(macro
. (lambda (args &rest body)
"匿名宏，可简写为 (\"ARGS\" BODY)."
(declare (!export t))
``(macro . ,(lambda ,args ,@body)))))
(! def '(stringp car)
(! def '!str (! macro (A &rest B)
(setq A (read (format "(%s)" A))
A (or (eval `(! argexp ',A) t) A))
`(! macro ,A ,@B))))
(! def 'lambda (!"args &rest body"
"匿名函数，可简写为 ([ARGS] BODY)."
(declare (!export t)) `(lambda ,args ,@body)))
(! def '(vectorp car) (! def '!vec (!"A &rest B"
(setq A (append A nil)
A (or (eval `(! argexp ',A) t) A))
`(! lambda ,A ,@B))))
(! def 'argexp (![args]
(when (and (numberp (car args)) (length= args 1))
(when (< (car args) 0)
(setq args (list (- (car args)) '&optional)))
(dotimes (i (pop args))
(push (intern (format "x%d" i)) args))
(setq args (nreverse args)))
(when (eq (car (last args)) '...)
(setq args (append (take (1-(length args)) args)
'(&rest ...))))
args))
apply
收集一些常用的 apply 函数的 apply 包。
F:apply
(! def 'apply (! package nil)) ; 一些常用的 apply
(! apply def 'id (!"f &rest A" (if A `(,f ,@A) `',f)))
(! apply def 'call (!"f &rest A" `(,f ,@A)))
<<@([[id:apply.macro]])>>
<<2026-02-11-19-36>>
一种延迟宏展开的 apply
(equal
(!let ((m (!"&rest a"`(f ,@a)))
(f ()))
(! apply macro m 1 2 3))
[1 2 3])
apply.macro
(! apply def 'macro
(let ((M (make-symbol "macro")))
(defalias M
(![m E](!"qA"
(macroexpand-all
(apply (cdr (indirect-function m))
(cadr qA))
E))))
(!"f &rest A"
"f 会被求值, A 不会"
(when (and (length< A 2) (listp (car A)))
(setq A (car A)))
(let ((m (make-symbol "m"))
(E (make-symbol "macros")))
(set E macroexpand-all-environment)
;; 宏展开时, m 尚未定义，故 quote 其参。
`(progn (fset ',m (,M (or ,f ',f) ,E))
(,m ',A))))))
comment
!注释
D:comment?
i-注释 指 首尾元素均为符号 ‘!’ 的 list 类表达式。
宏 ‘!’ 展开时, ‘!’ 中的 !-注释 将被移除。
F:comment
(! def 'A (![f &optional A] (apply f A)))
(! def 'M (![f A] (mapcar f A)))
(! def '(memq '! (last args)) (!"..."nil))
(! def 'comment? (![e]
"判断给定表达式 E 是否为 !-注释。
<<@([[id:D:comment?]])>>"
(declare (!export t))
(and (listp e) (length> e 1)
(eq (car e) '!) (memq '! (last e)) t)))
(! def 'remove-comment
(let ((self (! def 'remove-comment))) (![&rest a]
(cond*
;; ! 中的 ! 注释被移除
((not (eq (car a) '!))
(setq
a (seq-remove (! comment?) a)
a (! M (![s]
(cond
((or (atom s) (cdr (last s))) s)
((eq (car-safe s) '!)
(macroexp-macroexpand
(apply (cdr (symbol-function '!)) (cdr s))
nil))
((apply self s))))
a))
a)
;; 非 ! 中的 ! 注释展成 nil
((funcall (! comment?) a) nil)
;; 递归处理
((ignore (setq a (apply self (cdr a)))))
;; ((ignore (message "out %S" a)))
((length< a 2) (car a))
((cons 'progn a))))))
export
包符号导出工具。
F:export
(! def 'export (! package nil :apply0 (!"f"`(,f))))
<<@([[id:export.all]])>>
export.all
(! def 'M (![f A] (mapcar f A)))
(! def 'R (![f A] (seq-reduce f (cdr A) (car A))))
(! export def 'path
(let ((path (! export def 'path))) (![p]
(cond
((symbolp p)
(setq
p `(progn
(,p def '(and (eq car ',(! export))
(![...]export)))
(,p ,(! export)))
p (eval p t)))
((not(listp p)))
((length= p 1) (car p))
((length= p 2)
(alist-get (cadr p) (funcall path (car p))))
((! R path (cdr p) (car p)))))))
(! export def '(listp car) (! export path))
(! export def 'all (![&optional p]
"导出包 P 所有的符号。
P 默认为 ‘!’."
(declare (!export t))
(setq
p (! M 'cdr (eval `(! export ',(or p '!)) t))
p (nreverse (delete-dups p)))))
indent
一些 lisp 缩进函数。
F:indent
(! def 'indent (! package ()
(+ (current-column) n))))))
<<@([[id:indent.cont]])>>
D:indent.cont
连续同行缩进，缩进至最早的 !, !let, !let, let, let* 节点。
如：
(let(a)())
(let(a)
())
indent.cont
(! indent def 'cont (![p s &optional l re or]
"indent.cont
<<@([[id:D:indent.cont]])>>"
(declare (!export t))
(save-excursion
(setq s (reverse (nth 9 s)))
(goto-char (pop s))
(setq l (line-number-at-pos) p (point) or "\\|"
re (concat
"[(][ \t]*" "\\("
"!" or "!def" or "!let" or "!let*" or
"let" or "let*" "\\)"))
(while (and (= l (line-number-at-pos))
(looking-at-p re) (setq p (point)) s)
(goto-char (pop s)))
(goto-char p)
(+ (current-column) 1))))
defdoc
文档工具。
F:defdoc
(! def '(eq car :defdoc) ; 单例符号, ! 重定义后会失效。
(let ((self (make-symbol ":defdoc")))
(defalias self (!"..." `',self)) self))
(! def 'defdoc
(let ((d (make-symbol "defdoc"))
(e (make-symbol "defdoc"))
(!defdoc (! def 'defdoc))
(Pdefdoc (! :defdoc)) f g x)
(defalias d
(![sym &optional doc]
(cond*
;; 处理 Not documented
((bind* (has-doc?
(ignore-errors
(function-documentation sym)))
(doc-prop
(get sym 'function-documentation))))
((bind* (_ (and (not has-doc?)
(null doc-prop))))
(put sym 'function-documentation ""))
((bind* (_ (and has-doc?
(length= doc-prop 0))))
(put sym 'function-documentation nil))
;; doc 非空时，设置符号 sym 的属性。
(doc (eval (funcall e sym (ignore) doc) t))
((bind* (f (get sym Pdefdoc)) d)
(setf d (funcall f)))
(d (insert d "\n\n")))))
(put d Pdefdoc d)
(require 'help-fns)
(setf
f (![s] (and (symbolp s) (eq (get s Pdefdoc) s)))
x help-fns-describe-function-functions
help-fns-describe-function-functions
(seq-remove f x))
(push d help-fns-describe-function-functions)
;; 将 (! defdoc) 作为 declare form 使用。
(defalias e
(![sym args &rest values]
`(put ',sym ',Pdefdoc
,(if (stringp (car values))
`()
(car values)))))
(put e Pdefdoc e)
(setf
x (list !defdoc e)
g (![s] (funcall f (cadr s)))
macro-declarations-alist
(seq-remove g macro-declarations-alist)
defun-declarations-alist
(seq-remove g defun-declarations-alist))
(push x macro-declarations-alist)
(push x defun-declarations-alist)
(!"sym &rest doc"
(cond*
((stringp sym)
`())
((stringp (car doc))
`(,d ,sym ()))
(`(,d ,sym ,(car doc)))))))
<<@([[id:button]])>>
button
(! def 'button (![&rest A]
(setf A (flatten-list A))
(cond*
((null A) (eval '(! button) t))
((bind* (ns (car A)) (S A)))
;; (button [NAMESPACE] SYMBOLS)
((bind* (_(vectorp ns)))
(setf
ns (append ns nil)
S (! M () t))
(cdr A))))
((bind* (s S)))
((and (listp s) (length= s 1)
(setf s (car s)) nil))
;; (button SYMBOL)
((symbolp s)
(buttonize (symbol-name s)
()))
;; (button SYMBOL-LIST)
((listp s)
(concat
(mapconcat
(![s]
(buttonize
(symbol-name s)
()))
s ", ")
".")))))
test
excl 测试框架。
F:test
<<@([[id:bold]])>>
(! def 'test) ; 前置定义
(! def 'test (! package (!"&optional p" "包测试工具"
`(,@(or p '(!)) ,(! test)))
:apply0 (!"f"`(,f))))
(! test def 'all (!"&optional p"
`(,@(or p '(!)) ,(! test) all)))
(! test def 'cases (!"&optional p"
`(,@(or p '(!)) ,(! test) cases)))
(! test def 'defcase (!"p name sexp &rest cases"
`(,@p ,(! test) defcase ,name ,sexp ,@cases)))
(! test def 'run-test (![test]
(list (car test)
(eval (cadr test) t)
(cadr test))))
(! test def 'render-result (![result]
(concat
(make-separator-line)
;; title
(! bold (car result)) ": "
;; test result
(format "%s" (cadr result))
"\n\n"
;; test form
(help--docstring-quote
(pp-to-string (caddr result))))))
(! test def 'render (![sym cases &optional fc]
"执行测试集，将测试结果写入符号文档中并返回。"
(let ((fill-column (or fc fill-column))
doc title results)
(setf
cases (seq-partition (symbol-value cases) 2)
results (! M (! test run-test) cases)
title (function-documentation sym)
doc (! M (! test render-result) results)
doc (concat
(or title "")
(and (length> title 0) "\n\n")
(! bold
(format
"%d tests, %d passed.\n\n"
(length results)
(length (seq-filter 'cadr results))))
(string-join doc)))
(put sym 'function-documentation doc)
(! M () results))))
(! def 'deftest (!"p test-cases"
(declare (!export t))
(let ((test (! test))
(T (make-symbol "test")))
`(progn
(defalias ',T
(! package ()
:apply0 'funcall))
(,T def 'cases ,test-cases)
(,T def 'defcase
(![name case &rest cases]
(dolist (c `((,name ,case)
,@(seq-partition cases 2)))
(cond
((plist-member
(symbol-value (,T cases)) (car c)
'equal)
(setf
(plist-get
(symbol-value (,T cases)) (car c)
'equal)
(cadr c)))
((symbol-value (,T cases))
(setf
(cdr (last (symbol-value (,T cases))))
c))
((setf (symbol-value (,T cases)) c))))))
(,T def 'all ( 50)))
(put ',T '!export nil)
(,@p def ',test ',T)))))
bold
(! def 'bold (![string] "STRING 加粗"
(declare (!export t))
(propertize string 'face 'bold
'font-lock-face 'bold)))
DOC
excl 文档。
DOC
(! defdoc '!
"工具函数: "
(! button (seq-filter ()
(! export all '!)))
"\n\n"
"用例见: " (! button (! test (!))) ".")
(! defdoc (! defdoc)
"为（函数）符号 SYM 定义动态生成文档 DOC.
DOC 可为 string 或 求值为 string 的表达式 或 函数。
函数及表达式会延迟到 ‘describe-function’ 时执行。")
(! defdoc (! package)
"生成一个类似 ‘!’ 的 package.
通过 (PKG def NAME FUNC-OR-MACRO) 可定义新的 PKG 函宏。
PKG 函宏可通过 (PKG NAME ARGS) 调用。
DEFAULT 当控制流未进入 package 代码路径时，
控制流的流向。通常为 PKG 待实现的功能。可函可宏。
FAPPLY 如何应用函
MAPPLY 如何应用宏
APPLY0 如何应用零参函宏
DEF 如何关联符号与值。默认为 ‘defalias’.
可用 " (! button (! deftest)) " 定义 PKG 的测试。")
版本
x.1
.1, 无依赖，原始引用，一个可 buffer 执行的的自举用版本。
;;; ! -*- lexical-binding: t; -*-
<<2026-02-12-11-14>>
;;; ! 匿名函宏
<<2026-02-11-19-24>>
1.n
TARGET
<<@([[id:CORE]])>>
;;; ! 注释语法
<<@([[id:F:comment]])>>
;;; ! 包符号导出
<<@([[id:F:export]])>>
;;; ! 测试框架
<<@([[id:F:test]])>>
;;; ! 辅助函数
<<@([[id:F:defdoc]])>>
(! def '(and (eq car :def) ; 提供修改 define 的机制
(lambda (_ &rest f)
(if f (setf define (car f))
define))))
<<@([[id:F:indent]])>>
;;; ! 用例
<<@([[id:T:CORE]])>>
;;; ! 文档
<<@([[id:DOC]])>>
;;; ! apply
<<@([[id:F:apply]])>>
CORE
;;; ! -*- lexical-binding: t; -*-
<<@([[id:F:package]])>>
;;; ! 匿名函宏
<<@([[id:F:lambda]])>>
T:CORE
(! deftest (!)
`("! 中的 ! 注释被移除"
(equal
(! (! this is a comment !)
(list
(! 空气注释 !) 0
(let (!(!(范围注释)!) ((a 0))) a)
(let (!(空气注释)!) ((a 0)) a)))
(list
0
(let ((a 0)) a)
(let ((a 0)) a)))
"非 ! 中的 ! 注释展成 nil"
(equal
(! 注释 !)
nil)
"多表达式时被展成 progn"
(equal
(macroexpand-all
'(!(+ a)(-(!(+ b))(!(+ c)(+ d)))))
'(progn(+ a)(-(+ b)(progn(+ c)(+ d)))))
"(! comment?) 函数"
(equal
(funcall (! comment?) '(!(注释)!))
t)
"! macro"
(equal (!"a"a) `(macro . ,(lambda (a) a)))
"! lambda 无参"
(equal (![]a) (lambda()a))
"! lambda 有参"
(equal (![a]a) (lambda(a)a))
"! lambda 多表达式体"
(equal
(![a b]
"doc"(interactive)(declare(indent 1))
(setq a (1+ b))(+ a b))
(lambda(a b)
"doc"(interactive)(declare(indent 1))
(setq a (1+ b))(+ a b)))
"! lambda 变量及函数捕获"
(equal
(let ((a 2)(b (lambda (a) (+ 5 a))))
(funcall (! [x] (+ (funcall b a) x)) 1))
8)))
(! test all)
