我想知道是否可以在 Racket 中编写一个宏来翻译每种形式的形状 (c(a|d)+r xs)，其中 c(a|d)+r 是匹配 car、cdr、caar 的正则表达式， cadr, ... etc，放入对应的first和rest组成。
例如，此宏应采用 (caadr '(1 2 3 4 5)) 并将其转换为 (first (first (rest '(1 2 3 4 5))))。
Shen 中的类似内容（Mark Tarver 的新编程语言）：https ://groups.google.com/group/qilang/browse_thread/thread/131eda1cf60d9094?hl=en
在 Racket 中完全可以做到这一点，而且比上面所做的要短得多。涉及两个（不是真的）技巧：
使用 Racket 的#%top宏可以凭空创建这样的绑定。这个宏被隐式地用于任何未绑定的变量引用（“top”，因为这些东西是对顶级变量的引用）。
如果你让宏做必要的最小化，剩下的留给一个函数，宏就会变得更简单。
这是带有注释和测试的完整代码（实际代码很小，大约 10 行）。
#lang racket
;; we're going to define our own #%top, so make the real one available
(require (only-in racket [#%top real-top]))
;; in case you want to use this thing as a library for other code
(provide #%top)
;; non-trick#1: doing the real work in a function is almost trivial
(define (c...r path)
(apply compose (map (λ(x) (case x [(#\a) car] [(#\d) cdr])) path)))
;; non-trick#2: define our own #%top, which expands to the above in
;; case of a `c[ad]*r', or to the real `#%top' otherwise.
(define-syntax (#%top stx)
(syntax-case stx ()
[(_ . id)
(let ([m (regexp-match #rx"^c([ad]*)r$"
(symbol->string (syntax-e #'id)))])
(if m
#`(c...r '#,(string->list (cadr m)))
#'(real-top . id)))]))
;; Tests, to see that it works:
(caadadr '(1 (2 (3 4)) 5 6))
(let ([f caadadr]) (f '(1 (2 (3 4)) 5 6))) ; works even as a value
(cr 'bleh)
(cadr '(1 2 3)) ; uses the actual `cadr' since it's bound,
;; (cadr '(1)) ; to see this, note this error message
;; (caddddr '(1)) ; versus the error in this case
(let ([cr list]) (cr 'bleh)) ; lexical scope is still respected
您当然可以编写一些内容，接收带引号的 s 表达式并将翻译输出为带引号的 s 表达式。
从简单地将格式良好的列表'(#\c #\a #\d #\r)转换为您的第一个/其余 s 表达式开始。
现在用 symbol?、symbol->string、regexp-match #rx"^c(a|d)+r$"、string->list 和 map 构建解决方案
遍历输入。如果它是一个符号，请检查正则表达式（如果失败则按原样返回），转换为列表，然后使用您的起始翻译器。递归嵌套表达式。
编辑：这里有一些写得不好的代码，可以将源代码转换为源代码（假设目的是读取输出）
;; translates a list of characters '(#\c #\a #\d #\r)
;; into first and rest equivalents
;; throw first of rst into call
(define (translate-list lst rst)
(cond [(null? lst) (raise #f)]
[(eq? #\c (first lst)) (translate-list (rest lst) rst)]
[(eq? #\r (first lst)) (first rst)]
[(eq? #\a (first lst)) (cons 'first (cons (translate-list (rest lst) rst) '()))]
[(eq? #\d (first lst)) (cons 'rest (cons (translate-list (rest lst) rst) '()))]
[else (raise #f)]))
;; translate the symbol to first/rest if it matches c(a|d)+r
;; pass through otherwise
(define (maybe-translate sym rst)
(if (regexp-match #rx"^c(a|d)+r$" (symbol->string sym))
(translate-list (string->list (symbol->string sym)) rst)
(cons sym rst)))
;; recursively first-restify a quoted s-expression
(define (translate-expression exp)
(cond [(null? exp) null]
[(symbol? (first exp)) (maybe-translate (first exp) (translate-expression (rest exp)))]
[(pair? (first exp)) (cons (translate-expression (first exp)) (translate-expression (rest exp)))]
[else exp]))
'test-2
(define test-2 '(cadr (1 2 3)))
(maybe-translate (first test-2) (rest test-2))
(translate-expression test-2)
(translate-expression '(car (cdar (list (list 1 2) 3))))
(translate-expression '(translate-list '() '(a b c)))
(translate-expression '(() (1 2)))
正如评论中提到的，我很好奇你为什么想要一个宏。如果目的是将源代码转换为可读的东西，您不想捕获输出以替换原始内容吗？
这是我的实现（现在固定使用调用站点的carand cdr，因此您可以重新定义它们，它们将正常工作）：
(define-syntax (biteme stx)
(define (id->string id)
(symbol->string (syntax->datum id)))
(define (decomp id)
(define match (regexp-match #rx"^c([ad])(.*)r$" (id->string id)))
(define func (case (string-ref (cadr match) 0)
((#\a) 'car)
((#\d) 'cdr)))
(datum->syntax id (list func (string->symbol (format "c~ar" (caddr match))))))
(syntax-case stx ()
((_ (c*r x)) (regexp-match #rx"^c[ad]+r$" (id->string #'c*r))
(with-syntax (((a d) (decomp #'c*r)))
(syntax-case #'d (cr)
(cr #'(a x))
(_ #'(a (biteme (d x)))))))))
例子：
(biteme (car '(1 2 3 4 5 6 7))) ; => 1
(biteme (cadr '(1 2 3 4 5 6 7))) ; => 2
(biteme (cddddr '(1 2 3 4 5 6 7))) ; => (5 6 7)
(biteme (caddddddr '(1 2 3 4 5 6 7))) ; => 7
(let ((car cdr)
(cdr car))
(biteme (cdaaaaar '(1 2 3 4 5 6 7)))) ; => 6
Let Over Lambda是一本使用 Common Lisp 的书，但它有一章定义了一个宏with-all-cxrs，可以做你想做的事。