我正在尝试使用语法参数，以便在我需要注入的地方注入新语法 . 然后在其他语法中使用此结果 . 但是，它没有像我期望的那样工作 . 这是一个最小的工作示例：
#lang racket
(require (for-syntax racket/contract))
(require racket/stxparam)
;; A list for holding the instructions
(define instructions-db
'())
;===================================
; MACRO FOR DEFINING AN INSTRUCTION
;===================================
(provide define-instruction)
(define-syntax (define-instruction stx)
(syntax-case stx ()
[(_ id (attrs ...))
;; Insert instruction into database
#'(set! instructions-db (append instructions-db '(id (attrs ...))))]))
;=============================================================
; MACRO TO MIMIC 'FOR' BUT TO BE USED WITH DEFINE-INSTRUCTION
;=============================================================
(begin-for-syntax
; Gets the head of each list within the given list of syntax lists. If any of
; the lists are empty, an empty list is returned.
(define/contract (stx-heads ls)
((listof (syntax/c list?)) . -> . (listof (syntax/c any/c)))
(let loop ([ls ls]
[hs '()])
(if (null? ls)
hs
(let ([l (syntax-e (car ls))])
(if (null? l)
'()
(loop (cdr ls) (append hs (list (car l)))))))))
; Gets the tail of each list within the given list of syntax lists. If any of
; the lists are empty, an empty list is returned.
(define/contract (stx-tails ls)
((listof (syntax/c list?)) . -> . (listof (syntax/c list?)))
(let loop ([ls ls]
[ts '()])
(if (null? ls)
ts
(let* ([stx-l (car ls)]
[l (syntax-e stx-l)])
(if (null? l)
'()
(loop (cdr ls) (append ts (list
(datum->syntax stx-l
(cdr l)
stx-l
stx-l)))))))))
(define (define-instruction-stx? stx)
(if (syntax? stx)
(let ([e (syntax-e stx)])
(and (pair? e)
(syntax? (car e))
(equal? (syntax-e (car e)) 'define-instruction)))
#f))
;; Given a syntax object, an identifier, and a replacement value, construct a
;; new syntax object where any occurrence of the identifier is substituted for
;; the value.
(define (stx-id-substitute id replacement stx)
(let loop ([e stx])
(cond [(and (identifier? e)
(bound-identifier=? e id))
replacement]
[(syntax? e)
(datum->syntax e (loop (syntax-e e)) e e)]
[(pair? e)
(cons (loop (car e)) (loop (cdr e)))]
[else e])))
;; Given a 'define-instruction' syntax object, extends its ID with the given
;; string. If any other object is given, it is left intact and returned.
(define (extend-id-of-define-instruction-stx suffix stx)
(if (define-instruction-stx? stx)
(let* ([e (syntax-e stx)]
[stx-construct (car e)]
[stx-id (cadr e)]
[new-stx-id
(datum->syntax stx-id
(string->symbol
(format "~a~a"
(symbol->string (syntax-e stx-id))
suffix))
stx-id
stx-id)]
[stx-attrs (caddr e)])
(datum->syntax stx
`(,stx-construct ,new-stx-id ,stx-attrs)
stx
stx))
stx))
;; Given a list of variable-value pairs and define-instruction body, construct
;; a new body where all varible occurrences have been replaced with its
;; values.
(define (instr-for-body-args-sub var-val-pairs stx-body)
(let loop ([var-val-pairs var-val-pairs]
[stx-body stx-body])
(if (null? var-val-pairs)
stx-body
(let* ([var-val-p (car var-val-pairs)]
[var (car var-val-p)]
[val (cdr var-val-p)]
[new-stx-body (stx-id-substitute var val stx-body)]
[rest-var-val-pairs (cdr var-val-pairs)])
(loop rest-var-val-pairs new-stx-body)))))
;; Given a list of variable-value pairs and define-instruction body, construct
;; a new body where all varible occurrences have been replaced with its
;; values. Also, an index is appended to the identifier of the new
;; define-instruction body.
(define (instr-for-body-args var-val-pairs instr-index stx-body0)
(let* ([stx-body1 (instr-for-body-args-sub var-val-pairs stx-body0)]
[stx-body2 (let loop ([e stx-body1])
(cond [(define-instruction-stx? e)
(extend-id-of-define-instruction-stx
(format ":~a" instr-index)
e)]
[(syntax? e)
(datum->syntax e (loop (syntax-e e)) e e)]
[(pair? e)
(cons (loop (car e)) (loop (cdr e)))]
[else e]))])
stx-body2))
;; Given a list of iteration arguments and an define-instruction body,
;; construct a list of define-instruction bodies.
(define (instr-for-body stx-args stx-body)
(let ([stx-vars (stx-heads (syntax-e stx-args))])
(let loop ([stx-val-lists (stx-heads (stx-tails (syntax-e stx-args)))]
[instr-index 0])
(if (null? stx-val-lists)
'() ;; No more values to iterate over
(let ([stx-vals (stx-heads stx-val-lists)])
(if (null? stx-vals)
'() ;; At least one arg list has no more values
(let ([stx-arg-val-pairs (map cons stx-vars stx-vals)])
(cons (instr-for-body-args stx-arg-val-pairs
instr-index
stx-body)
(loop (stx-tails stx-val-lists)
(+ instr-index 1)))))))))))
(provide instr-for)
(define-syntax (instr-for stx)
(syntax-case stx ()
[(_ args body ...)
(with-syntax ([(replaced-body ...)
(foldl
(lambda (stx-body replaced-stx-bodies)
(append (instr-for-body #'args stx-body)
replaced-stx-bodies))
'()
(syntax-e #'(body ...)))])
#'(begin replaced-body ...))]))
;===============================================
; MACROS TO SIMPLIFY DEFINITION OF INSTRUCTIONS
;===============================================
(define-syntax-parameter mem-op-addr
(lambda (stx)
(raise-syntax-error
(syntax-e stx)
"can only be used inside define-modrm-mem-op-instruction")))
(provide define-complex-addr-mode-instructions)
(define-syntax (define-complex-addr-mode-instructions stx)
(syntax-case stx ()
[(_ id (attrs ...))
#'(begin
(instr-for ([addr (#'reg1
#'[inttoptr 32 offset 32]
#'[inttoptr 32 (add 32 rbase rindex) 32]
#'[inttoptr 32 (add 32
#' rbase
#' (add 32 rindex offset))
#' 32])])
(let ([_addr (syntax->datum addr)])
(syntax-parameterize ([mem-op-addr
(make-rename-transformer #'_addr)])
(define-instruction id (attrs ...))))))]))
此代码用于定义指令并将其放入数据库的位置 . 然后，该数据库的指令的语义将用于生成代码 .
现在说我要宣布一条指令 . 这样做如下：
(define-instruction ADD:0
((semantics (add 8 reg0 reg1))))
(displayln instructions-db)
产生：
(ADD:0 ((semantics (add 8 reg0 reg1))
要处理不同的位宽，我们可以这样做：
(define-instruction ADD:0
((semantics (add 8 reg0 reg1))))
(define-instruction ADD:1
((semantics (add 16 reg0 reg1))))
(define-instruction ADD:2
((semantics (add 32 reg0 reg1))))
(displayln instructions-db)
或者只是使用我的 instr-for 宏：
(instr-for ([i (8 16 32)])
(define-instruction ADD
((semantics (add i reg0 reg1)))))
(displayln instructions-db)
它给出了与上面相同的结果：
([ADD:0 ((semantics (add 8 reg0 reg1)))]
[ADD:1 ((semantics (add 16 reg0 reg1)))]
[ADD:2 ((semantics (add 32 reg0 reg1)))])
现在，一些指令具有复杂的寻址模式，它们出现在多个指令中 . 例如：
; some ADD instructions
(define-instruction ADD:0
((semantics
(add 32 reg0 (load-mem 32 reg1)))))
(define-instruction ADD:1
((semantics
(add 32 reg0 (load-mem 32 [inttoptr 32 offset 32])))))
(define-instruction ADD:2
((semantics
(add 32 reg0 (load-mem 32 [inttoptr 32 (add 32 rbase rindex) 32])))))
(define-instruction ADD:3
((semantics
(add 32 reg0 (load-mem 32 [inttoptr 32 (add 32
rbase
(add 32 rindex offset))
32])))))
; some SUB instructions, with the same addressing modes
(define-instruction SUB:0
((semantics
(sub 32 reg0 (load-mem 32 reg1)))))
(define-instruction SUB:1
((semantics
(sub 32 reg0 (load-mem 32 [inttoptr 32 offset 32])))))
(define-instruction SUB:2
((semantics
(sub 32 reg0 (load-mem 32 [inttoptr 32 (add 32 rbase rindex) 32])))))
(define-instruction SUB:3
((semantics
(sub 32 reg0 (load-mem 32 [inttoptr 32 (add 32
rbase
(add 32 rindex offset))
32])))))
为了避免复制粘贴，我已经定义了一个新的宏 define-complex-addr-mode-instructions ，允许我们使用以下命令声明与上面相同的指令：
(define-complex-addr-mode-instructions ADD
((semantics (add 32 reg0 (load-mem 32 mem-op-addr)))))
(define-complex-addr-mode-instructions SUB
((semantics (add 32 reg0 (load-mem 32 mem-op-addr)))))
(displayln instructions-db)
但是，这会产生：
([ADD:0 ((semantics (add 32 reg0 (load-mem 32 mem-op-addr))))]
[ADD:1 ((semantics (add 32 reg0 (load-mem 32 mem-op-addr))))]
[ADD:2 ((semantics (add 32 reg0 (load-mem 32 mem-op-addr))))]
[ADD:3 ((semantics (add 32 reg0 (load-mem 32 mem-op-addr))))]
[SUB:0 ((semantics (add 32 reg0 (load-mem 32 mem-op-addr))))]
[SUB:1 ((semantics (add 32 reg0 (load-mem 32 mem-op-addr))))]
[SUB:2 ((semantics (add 32 reg0 (load-mem 32 mem-op-addr))))]
[SUB:3 ((semantics (add 32 reg0 (load-mem 32 mem-op-addr))))])
阅读Greg Hendershott的guide on macros，我尝试使用语法参数实现 define-complex-addr-mode-instructions ，因为使用 syntax->datum 尝试执行此操作显然很糟糕 . 我是否误解了语法参数的工作原理，还是我需要使用 datum->syntax 的情况？我注意到如果我将 instr-for 中的 bound-identifier=? 替换为 free-identifier=? ，它会起作用，但我怀疑这不是正确的方法 .