我想知道是否可以在Racket中编写一个宏来翻译每种形式的形状（c（a|d）+r-xs），其中c（a| d）+r是一个匹配car、cdr、caar、cadr。。。等等，进入第一个和第二个的相应组成。
例如，这个宏应该取（caadr’（1 2 3 4 5））并将其转换为（first（first）（rest’（1 1 2 3 5））。
沈（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)）转换为第一个/rest s表达式开始。
现在用符号构建解决方案？，symbol->字符串，regexp匹配#rx"^c（a|d）+r$"，字符串->列表，并映射
遍历输入。如果它是一个符号，请检查regexp（如果失败，则按原样返回），转换为list，然后使用启动翻译器。在嵌套表达式上重复。
编辑：这里有一些写得不好的代码，可以将源代码转换为源代码（假设目的是读取输出）
;; 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)))
正如评论中提到的，我很好奇你为什么想要一个宏。如果目的是将源代码翻译成可读的东西，难道不想捕获输出来替换原始文件吗？
Let Over Lambda是一本使用Common Lisp的书，但它有一章定义了一个可以满足您需要的宏with-all-cxrs。
以下是我的实现（现在固定为使用调用站点的car和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