続・スロット番号付き cut を R5RS 範囲内で書く

Scheme には部分適用のための構文 cut がある。 srfi-26 で定義されている。

この cut のスロットを番号で指定して、より柔軟に使えるようにしたものを R5RS の範囲内で実装しようとしたのが先日のこと。

http://saito.hatenablog.jp/entry/20100927/1285584328

だが、これは R5RS では未定義になっている挙動に依存してしまっていることが判明した。

http://saito.hatenablog.jp/entry/20101003/1286095807

しかし、原因ははっきりしている。

問題があった部分をどうにか修正したのが以下だ。 今度こそ R5RS に適合しているはず。 一応 rhizome/pi と scheme48 で期待通り動作することは確認した。

(define-syntax %%%%cutn
  (syntax-rules ()
    ((_ (rsx ...) adrsx a slt)
     (%%%cutn (rsx ... adrsx) a slt slt))))

(define-syntax %%%%cutnt
  (syntax-rules ()
    ((_ (args ...) adrsx (slots ...))
     (lambda(slots ... . <...>)(apply args ... <...>)))))

(define-syntax %%%cutn
  (syntax-rules ()
    ((_ args () slots _1)
     (lambda slots args))
    ((_ r (a0 a1 ...) (slots ...) sls)
     (letrec-syntax ((ex (syntax-rules (slots ... <...>)
                           ((_ slots)
                            (sx r slots sls))
                           ...
                           ((_ <...>)
                            (rx r a0 sls a1 ...))
                           ((_ x)
                            (sx r a0 sls))))
                     (sx (syntax-rules ()
                           ((_ rsx adrsx slt)
                            (%%%%cutn rsx adrsx (a1 ...) slt))))
                     (rx (syntax-rules ()
                           ((_ args adrsx slt)
                            (%%%%cutnt args adrsx slt)
                             ))))
       (ex a0)))))

(define-syntax %%cutn
  (syntax-rules ()
    ((_ args _1 slots _2 ())
     (%%%cutn () args slots slots))
    ((_ args (r1 ...) (r2 ...) (u ...) (s ss ...))
     (letrec-syntax ((ex (syntax-rules (u ...)
                           ((_ u)
                            (sx))
                           ...
                           ((_ x)
                            (%%cutn args (r1 ... s) (r2 ...)
                                    (u ...) (ss ...)))))
                     (sx (syntax-rules ()
                           ((_)
                            (%%cutn args (r1 ... s) (r1 ... s)
                                    (u ...) (ss ...))))))
       (ex s)))))

(define-syntax %cutn
  (syntax-rules ()
    ((_ args r slots)
     (%%cutn args () () r slots))
    ((_ args (r ...) (slots ...) a0 a1 ...)
     (letrec-syntax ((ex (syntax-rules (slots ...)
                           ((_ slots)
                            (sx slots))
                           ...
                           ((_ _1)
                            (%cutn args (r ...) (slots ...) a1 ...))
                           ))
                     (sx (syntax-rules ()
                           ((_ sls)
                            (%cutn args (r ... sls) (slots ...) a1 ...)))))
       (ex a0)))))

(define-syntax cutn
  (syntax-rules ()
    ((_ args ...)
     (%cutn (args ...) ()
            (<0> <1> <2> <3> <4> <5> <6> <7> <8> <9>) args ...))))

但し、今回も Gauche では動かない。 うろ覚えだが、 Gauche の既知のバグだとどこかで見たように思う。
問題を再現する小さなコードを載せておく。

(define-syntax hoge
  (syntax-rules ()
    ((_ x)
     (letrec-syntax ((huga (syntax-rules () ((_ y)(hage y))))
                     (hage (syntax-rules () ((_ z)(display z)))))
       (huga x)))))

(hoge 'a)

Document ID: 19568ac9045e6c404b750836668f4036