如何使用First Class Internal Definition Context

Racket的 first class internal definition context 是一个利器，主要用途有：

#lang racket

(define a%
  (class object%
    (define/match (fact n)
      [(0) 1]
      [(n) (* n (fact (sub1 n)))])
    (public fact)
    
    (super-new)))

(send (new a%) fact 5)

在这个例子中，类a%定义了一个fact方法，用的是define/match，而不需要一个特别定制的“define-method”宏。从函数定义到类的方法需要经过复杂的变换过程，但是define/match自身是不知道自己会被用来定义方法的。 First class internal definition context 使其成为了可能。

应用示例

假设需要写这样一个宏：

(define-record (foo l)
  (match-define (list x _ y _ z) l))

需要展开为

(struct foo (x y z))
(define (make-foo l)
  (match-define (list x _ y _ z) l)
  (foo x y z))

也就是一次性从 definition context 中得到struct的字段和构造函数。

实现

准备工作

从定义开始：

(define-syntax-parser define-record
  [(_ (name:id . args:formals) body:expr ...+)
   <...>])

这里无疑要利用 first class internal definition context （以下简称 intdef-ctx ）对body进行操作了，但首先，参数的args的 binding 还没有设置好。

因此，上述的第二个用途，设置环境：

(define param-ctx (syntax-local-make-definition-context))
(syntax-local-bind-syntaxes (syntax->list #'args.params) #f param-ctx)

这里param-ctx提供一个包含了args的 binding 的环境，防止出现变量未定义或是访问到外层定义的同名 binding 。

接下来定义body的 intdef-ctx ：

(define body-ctx (syntax-local-make-definition-context))

这里parent-ctx为什么是默认的#f，不是param-ctx呢？因为parent-ctx中的 binding 默认不可见，作为代替，后面展开的时候传一个list。

接下来看看怎么对body进行展开，首先是local-expand的使用：

(define ctx (list (gensym)))
(define (expand stx)
  (local-expand
   stx ctx
   (syntax->list #'(begin define-values define-syntaxes))
   (list body-ctx param-ctx)))

因为body的定义不需对外可见，context-v使用(list (gensym))，否则可以用generate-expand-context。然后因为遇到的定义可能会相互或递归引用，必须部分展开，这里的stop-ids这三基本上是 intdef-ctx 展开不可少的，如果要其他特殊功能（例如，一个标记不需要变成结构体字段的定义的“ignore”宏），才会添加别的。body-ctx和param-ctx两个环境都要访问，因此都要传进去。

递归展开

接下来要对body进行递归展开，先定义收集字段的变量：

(define defined-ids '())

开始遍历：

(let loop ([stx #'(begin body ...)])
  (syntax-parse (expand stx) #:literals (begin define-values define-syntaxes)
    <...>
  )) 
[(begin form ...)
 #:with (expanded-form ...) (stx-map loop #'(form ...))
 #'(begin expanded-form ...)]
[(define-values (ids ...) expr)
 #:with (bd ...) (stx-map syntax-local-identifier-as-binding #'(ids ...))
 (syntax-local-bind-syntaxes (syntax->list #'(bd ...)) #f body-ctx)
 (set! defined-ids (append (syntax->list #'(bd ...)) defined-ids))
 #'(define-values (bd ...) expr)]

这里就需要对body-ctx操作了。首先syntax-local-identifier-as-binding是去除ids的 use-site scope ，为什么需要这个步骤呢？因为每次local-expand可能引入不同的 use-site scope ，要使ids对其他定义可见，必须要去除 use-site scope 。然后，用syntax-local-bind-syntaxes将去除了 use-site scope 的名字添加到body-ctx中。

[(define-syntaxes (ids ...) expr)
 #:with (bd ...) (stx-map syntax-local-identifier-as-binding #'(ids ...))
 #:with rhs (local-transformer-expand #'expr 'expression null body-ctx)
 (syntax-local-bind-syntaxes (syntax->list #'(bd ...)) #'rhs body-ctx)
 #'(define-syntaxes (bd ...) rhs)]

这里和上面不一样的是expr会被马上执行，而且要做完全展开。因为body自身不是完全展开，所以define-record的结果里仍可能会有对这些局部定义的宏的引用。为了避免expr被展开 两次 ，这里先做完全展开。

[form #'form]

收尾

按照要求的结构返回syntax对象。

注意这里的args-scoped，需要使用internal-definition-context-introduce让args带上param-ctx的scope，然后body的名字才能解析到新的定义。

这是因为args是从宏的参数提供的，原本不含有param-ctx的scope。而syntax-local-bind-syntaxes会把intdef-ctx参数的scope添加到创建的 binding 中。

因此，如果直接将args放入结果中，最终的scope set不是param-ctx里对应的 binding 的scope set的超集，将导致“ambigious binding”。

相对地，后面syntax-local-bind-syntaxes所用的 identifier 是从展开结果中获取的，需要syntax-local-identifier-as-binding。

#:with ctor-body <上面展开的结果>
#:with (field ...) defined-ids
#:with ctor (format-id #'name "make-~a" #'name #:subs? #t)
#:with args-scoped (internal-definition-context-introduce param-ctx #'args)
#'(begin (struct name (field ...))
         (define (ctor . args-scoped)
           ctor-body
           (name field ...)))

完整代码

#lang racket
(require syntax/parse/define
         (for-syntax syntax/parse/lib/function-header syntax/stx racket/syntax))

(define-syntax-parser define-record
  [(_ (name:id . args:formals) body:expr ...+)
   #:do
   [(define param-ctx (syntax-local-make-definition-context))
    (define body-ctx (syntax-local-make-definition-context))
    (syntax-local-bind-syntaxes (syntax->list #'args.params) #f param-ctx)
    (define ctx (list (gensym)))
    (define (expand stx)
      (local-expand
       stx ctx
       (syntax->list #'(begin define-values define-syntaxes))
       (list body-ctx param-ctx)))
    (define defined-ids '())
    
    (define-syntax-rule (syntax/track form)
      (syntax-case this-syntax ()
        [(head . _) (syntax-track-origin #'form this-syntax #'head)]))]
   
   #:with ctor-body
   (let loop ([stx #'(begin body ...)])
     (syntax-parse (expand stx) #:literals (begin define-values define-syntaxes)
       [(begin form ...)
        #:with (expanded-form ...) (stx-map loop #'(form ...))
        (syntax/track (begin expanded-form ...))]
       [(define-values (ids ...) expr)
        #:with (bd ...) (stx-map syntax-local-identifier-as-binding #'(ids ...))
        (syntax-local-bind-syntaxes (syntax->list #'(bd ...)) #f body-ctx)
        (set! defined-ids (append (syntax->list #'(bd ...)) defined-ids))
        (syntax/track (define-values (bd ...) expr))]
       [(define-syntaxes (ids ...) expr)
        #:with (bd ...) (stx-map syntax-local-identifier-as-binding #'(ids ...))
        #:with rhs (local-transformer-expand #'expr 'expression null body-ctx)
        (syntax-local-bind-syntaxes (syntax->list #'(bd ...)) #'rhs body-ctx)
        (syntax/track (define-syntaxes (bd ...) rhs))]
       [form #'form]))
   #:with (field ...) defined-ids
   #:with ctor (format-id #'name "make-~a" #'name #:subs? #t)
   #:with args-scoped (internal-definition-context-introduce param-ctx #'args)
   #'(begin (struct name (field ...))
            (define (ctor . args-scoped)
              ctor-body
              (name field ...)))])

注意到这里还添加了syntax/track的定义，用来协助Check Syntax。相关会在如何让DrRacket正确画出箭头中介绍。

使用示例：

> (begin
    (define-record (foo l)
      (match-define (list x _ y _ z) l))

    (define f (make-foo (list 1 2 3 4 5)))
    (list (foo-x f)
          (foo-y f)
          (foo-z f)))
'(1 3 5)

其他事项