Gaucheでクラスのフィールド名を変数に束縛する。

HaskellでいうNamedFieldPunsのようなものです。
クラスのインスタンスと、スロット名のリストを渡すことによって、スロット名と同名の変数にスロットの値を束縛するマクロを書きました。

使用例は記事の下の方にあります。

;; macro let-slots (((slot-name ...) expr) ...) body ...
;; インスタンスexprのスロットslot-nameを同名の変数に束縛し、bodyを評価する。
(define-macro (let-slots inits . body)
  ;; symbol の頭に prefix を付けた新たなシンボルを返す。
  ;; また、 prefix が #f である場合は、単に symbol を返す
  (define (add-prefix prefix symbol)
    (if (not prefix)
        symbol
        (if (symbol? prefix)
            (string->symbol (apply string-append
                                   (map symbol->string (list prefix symbol))))
            (errorf "prefix must be symbol: ~s" prefix))))
  ;; exprと、exprを束縛した新しい変数名varと、
  ;; (slot-name (slot-ref var 'slot-name))の式のリスト
  ;; の3つ組を作成する
  ;; prefixが指定された場合、スロット名の頭にプレフィックスを追加したものが
  ;; 対応するスロットを束縛する名前となる。
  (define (init-form->var&expr&slots slot-names expr :optional (prefix #f))
    (let* ((var (gensym))
           (init-exprs (map (^(slot-name)
                              `(,(add-prefix prefix slot-name)
                                (slot-ref ,var ',slot-name)))
                            slot-names)))
      (values expr var init-exprs)))
  (define var-name-and-init-exprs
    (let loop ((inits inits))
      (match inits
        (() '())
        (((slot-names expr) rest ...)
         (receive (expr var init-exprs)
             (init-form->var&expr&slots slot-names expr)
           (cons (list expr var init-exprs)
                 (loop rest))))

        (((slot-names expr :prefix prefix) rest ...)
         (receive (expr var init-exprs)
             (init-form->var&expr&slots slot-names expr prefix)
           (cons (list expr var init-exprs)
                 (loop rest))))

        (_ (errorf "malformed let-slots: ~s" inits)))))
  (define expr-inits
    (map (match-lambda
           ((expr var _) `(,var ,expr)))
         var-name-and-init-exprs))
  (define slot-inits
    (apply append
           (map (match-lambda
                  ((_ _ init-exprs) init-exprs))
                var-name-and-init-exprs)))
  `(let ,expr-inits
     (let ,slot-inits
       ,@body)))

使用例:

(define-class <person> ()
  ((name :init-keyword :name)
   (age :init-keyword :age)
   (pref :init-keyword :pref)))

(define taro (make <person> :name "Taro" :age 20 :pref "Tokyo"))
(define jiro (make <person> :name "Jiro" :age 15 :pref "Kyoto"))

(define (print-person person)
  ;; name が (slot-ref person 'name) に束縛される。age, pref も同様
  (let-slots (((name age pref) person))
    (format #t "Name: ~a, Age: ~s, Pref.: ~a" name age pref)))

(print-person taro)
;; => Name: Taro, Age: 20, Pref.: Tokyo

(define (person-eq? me you)
  ;; :prefix で束縛される変数名のプレフィックスを指定できる
  (let-slots (((name age pref) me :prefix my-)
              ((name age pref) you :prefix your-))
    (and (string=? my-name your-name)
         (= my-age your-age)
         (string=? my-pref your-pref))))

(person-eq? taro jiro)
;; => #f

(person-eq? taro taro)
;; => #t

こういったマクロはer-macroがあればもう少し健全に書くことができるのですが、うちのGaucheは未だ0.9.4なので、アップデートし次第er-macroを使って書き換えてみたいと思います。

Gaucheでクラスのフィールド名を変数に束縛する。

関連記事