Clojure風の無名関数構文

Arcには角括弧で無名関数を作る構文があります。

例:

> (map [if _ (+ 1 _) 1] '(1 -1 nil))
(2 0 1)

便利そうなのでマクロで模倣して喜んでいたんですが、1引数の関数しか作れないのが不便に感じることもありました。

で、最近Clojureにはその多変数版みたいなものがあるらしいのを知り、取り入れてみることにしました。

方針としては、従来のアンダースコアのみの識別子に加えて、その後に数字が付いているものも有効な変数と見なすようにします。

(define (underscore? stx)
  (and (identifier? stx)
       (let ((s (symbol->string (syntax-e stx))))
         (and (positive? (string-length s))
              (char=? (string-ref s 0) #\_)
              (let ((t (substring s 1)))
                (or (zero? (string-length t))  ; _
                    (string->number t)))))))   ; _[0-9]+

そして、マクロ展開時にコードからアンダースコア変数を抽出し、必要となる位置引数を調べます。この際、最初の引数を _1 に対応させることとします。

これらを数字の順番に並べてラムダのパラメータにすれば完成、となるはずです。

その作業を行うのがこちらです。

(define (pos x)
  (or (string->number
       (substring (symbol->string (syntax-e x)) 1))
      1))

(define (positional-vars vars)
  (let loop ((n 1)
             (l (sort (map (lambda (v)
                             (cons (pos v) v))
                           vars)
                      (lambda (x y)
                        (< (car x) (car y)))))
             (r '()))
    (cond ((null? l)
           ;; append rest parameter
           (append (reverse (map cdr r)) (gensym)))
          ((= (caar l) n)
           (loop (add1 n)
                 (cdr l)
                 (cons (car l) r)))
          (else
           (loop n
                 (cons (cons n (gensym)) l)
                 r)))))

アンダースコア変数が例えば _3 だけ、ということもあり得るので、抜けている変数は gensym で補うようにします。

positional-vars の返り値はドット対で、そのままラムダのパラメータ位置に埋め込まれます。

あまり普段はしない使い方だと思いますが、append の最後の引数が非リストの場合はドット・リストが作られます。ドットの後のシンボルがちょうど残余パラメータの役割を果たしてくれるわけです。

これにより、例えばこんな関数が定義できるようになります。

(define second [values _2])  ; values as identity
> (second 'a 'b 'c)
b
> (call-with-values (lambda () (values 'a 'b 'c))
    second)
b

有りそうで無かった感じがしません?


続き。マクロ本体

(define-syntax (make-brackets-funny stx)
  (syntax-case stx (as)
    ((make-brackets-funny (orig as name))
     (with-syntax ((tmp
                    (string->symbol (format "tmp-~a" (syntax-e #'orig)))))
       (syntax/loc stx
         (begin
           (define-syntax (tmp stx~)
             (syntax-case stx~ ()
               ((tmp . expr)
                (bracketed? stx~)
                (with-syntax ((vars
                               (positional-vars
                                (uniq-ids
                                 (filter underscore?
                                         (stx-filter
                                          (lambda (x)
                                            (or (identifier? x)
                                                (bracketed? x)))
                                          (unbracket #'expr)))))))
                  (syntax/loc stx~
                    (lambda vars (orig . expr)))))
               ((tmp . expr)
                (syntax/loc stx~ (orig . expr)))))
           (provide (rename-out (tmp name)))))))
    ((make-brackets-funny orig)
     (syntax/loc stx
       (make-brackets-funny (orig as orig))))
    ((make-brackets-funny orig . rest)
     (syntax/loc stx
       (begin (make-brackets-funny orig)
              (make-brackets-funny . rest))))))

色々省略しましたが、大枠は以上です。

アンダースコア変数を取り出す際に、ネストされている角括弧構文は探索しないようにするのがポイントです (stx-filterの部分)。

(make-brackets-funny #%app if ...)

のようにして利用します。Arcのようにリーダーに手を入れているわけではないので (そうすべきなのかも知れませんが)、無名関数化したい構文ごとに構文を再定義する必要があるんです。


ファイル:
arcfun.ss mlfun.ss

環境を汚さないrequire

トップレベルで作業をする時に、どうしてもライブラリを利用したくなりますが、その時にrequireで幾つもロードしていると、何となくREPLを汚してしまってるような気分になります。

実際それで困ることはまず無いんですが、たまに基本構文のセマンティクスが変わって戸惑うこともあったりします。

そこで思い出したのが名前空間です。

PLT Schemeでは名前空間が第一級オブジェクトなので、式評価の環境を自在に作ったり変更したりできるんです。

例えば

> (current-namespace (make-empty-namespace))

とするとREPLの環境がまっさらな状態になる、という具合です (関数適用すらできなくなります)。

これを利用して、ローカルな環境の中だけでライブラリを読み込む構文を作ってみました。

(begin-for-syntax
  (define req-specs
    (append '(for-meta for-syntax for-template for-label just-meta)
            '(only prefix all-except prefix-all-except rename)))

  (define (req-spec? spec)
    (or (module-path? spec)
        (and (pair? spec)
             (memq (car spec) req-specs)))))

(define-syntax (with-require stx)
  (syntax-case stx ()
    ((with-require mod . body)
     (req-spec? (syntax->datum #'mod))
     #'(with-require (mod) . body))
    ((with-require (mod ...) . body)
     (andmap req-spec? (syntax->datum #'(mod ...)))
     #'(parameterize ((current-namespace (make-base-namespace)))
         (for-each namespace-require '(mod ...))
         (eval '(begin . body))))))

> (with-require "prelude.ss"
    (aif 0 (add1 it)))
1
> aif
reference to undefined identifier: aif


参考:
http://docs.plt-scheme.org/guide/eval.html
http://docs.plt-scheme.org/guide/mk-namespace.html

Purely Functional Red-Black Tree

ちょっと思い立って作ってみました。

最初はProgramming Praxisで示されている実装から出発したんですが、結果的にはHaskell版の実装に近い形に変化していきました。

アルゴリズム等の解説はWikipediaに譲ることにして、ここではマクロを活用して煩雑なパターンマッチをHaskellっぽく簡潔に行う方法など、テクニック的な話題や応用例を紹介したいと思います。

ツリー構文

まず、ツリーの構造を定義します。

(define-struct tree (color left node right))

(define empty (make-tree 'black #f (cons #f #f) #f))
(define (empty? t) (eq? t empty))

キーと値は cons で纏めて node として一体的に扱うことにします (最初は別々にしていたんですが、あまりにもコーディングが煩雑になったので…)。

構造体を利用する際に便利なのが match 構文です。

> (match (make-tree 'black empty '(1 . #f) empty)
    ((struct tree ('black (? empty?) x (? empty?)))
     "This is a black tree with both subtrees empty."))
"This is a black tree with both subtrees empty."

このように、アクセサ関数を使わずとも色の判定ができたりして、コードが簡潔になります。

でも、もっと簡潔にすることはできないでしょうか?

例えば

(match (T B E '(1 . #f) E)
  ((T B E x E)
   "This is a black tree with both subtrees empty."))

のように書ければ素晴らしいですよね。

define-match-expander というマクロを使うと、それが可能になります。

(define-match-expander T
  (lambda (stx)
    (syntax-case stx ()
      ((T C a x b)
       (syntax/loc stx
         (struct tree (C a x b))))))
  (lambda (stx)
    (syntax-case stx ()
      ((T C a x b)
       (syntax/loc stx
         (make-tree C a x b))))))

最初のラムダがマッチ構文内での展開形、2番目は式として呼ばれた場合の展開形の定義です。

(define-match-expander R
  (lambda (stx)
    (syntax-case stx ()
      (R (syntax 'red))))
  (lambda (stx)
    (syntax-case stx ()
      (R (syntax 'red)))))

(define-match-expander B
  (lambda (stx)
    (syntax-case stx ()
      (B (syntax 'black))))
  (lambda (stx)
    (syntax-case stx ()
      (B (syntax 'black)))))

空ツリー

(define-match-expander E
  (lambda (stx)
    (syntax-case stx ()
      (E (syntax/loc stx (? empty?)))))
  (lambda (stx)
    (syntax-case stx ()
      (E (syntax/loc stx empty)))))

R、B、E が、マクロでありながら値のように扱えることを確認してみましょう。

> (list R B E)
(red black #s(tree black #f (#f . #f) #f))

構文の準備ができると、例えば赤い木を黒くする関数が、このように書けるようになります。

(fun (blacken (and t (T B _ _ _))) t
  \| (blacken (T _ a x b))         (T B a x b))

パターンマッチとツリーの生成とが同じ形式になっていますね (2行目)。

1行目は、木が既に黒ければそのまま返すというパターンです。and が ML や Haskell の as パターンと同じ意味で使えるということです。

もちろんネスティングも可能です。

> (match (T R E '(1) (T B (T R E '(2) E) '(3) E))
    ((T R _ x (T B (T R _ y _) z _))
     (append x y z)))
(1 2 3)

このHaskell風の構文糖衣が無ければいかに煩雑なコードになるか、想像に難くないでしょう。

キーの比較

ツリーのバランスを保ったり、要素を検索したりする上で必要なのが、キーの比較関数です。

数値や文字列、シンボルなど、比較可能なものであれば何でもキーにできるようにしたいんですが、比較方法を利用側で指定するのはやや面倒なんですね。

そこで、型変換ライブラリと同じような要領で、予め既知のデータ型については比較関数を用意しておいて、キーが与えられた時にそれに合ったものを選ぶ、という方式を考えました。

(fun (hany f h)
  (prompt
    (hash-for-each h
                   (fn (k v)
                     (aif (f k v)
                       (control _ it))))
    #f))

(fun (cmp = < x y)
  (if (= x y) '=
      (< x y) '<
              '>))

(define-values (install-cmp comparator)
  (let ((h (make-hasheq)))
    (values (fn (? = <)
              (hash-set! h ? (cmp = <)))
            (fn (x)
              (hany (fn (? cmp)
                      (and (? x) cmp))
                    h)))))

データ型に応じた比較関数を以下のようにインストールしておきます。

(install-cmp number? = <)
(install-cmp symbol? eq? (fn (x y)
                           (string<? (symbol->string x)
                                     (symbol->string y))))
...

テスト

> (let ((cmp ((comparator 0) 0)))
    (values (cmp 1) (cmp 0) (cmp -1)))
<
=
>

これにより、ユーザーに対して具体的な比較方法を意識させない仕方でツリー生成関数を提供できることになります。すなわち、比較関数ではなく代表的なキーの値を与えさせるわけです。

(fun (make-tree~ k) (cons (comparator k) empty))

(make-tree は構造体の生成関数なので、ライブラリ中ではチルダを付けておいて、エクスポート時にチルダを外すようにします)

ツリーの利用者はこのインターフェース関数を呼び出して空のツリーと比較関数を (無意識に) 作ります。

なおライブラリ側では、全てのツリー操作を通じて最初に作られた比較関数を使い回すようにすべきでしょう。

> (let* ((l '(4 1 2 5 3))
         (t (make-tree (car l))))
    (eq? (car (foldl (lambda (x t)
                       (tree-set t x '()))
                     t
                     l))
         (car t)))
#t

ツリー更新

ツリーに新しいノードを追加するための基本関数を、このように定義してみました。

(fun (tree-set~ reduce (cons cmp t) k v)
  (cons cmp
        (blacken
         (let loop (((and t
                          (T C a (and x (cons k~ v~)) b))
                     t))
           (if (empty? t)
               (T R E (cons k v) E)
               (case (cmp k k~)
                 (< (if (black? t)
                        (balance (loop a) x b)
                        (T R (loop a) x b)))
                 (= (T C a (cons k (reduce k v~ v)) b))
                 (> (if (black? t)
                        (balance a x (loop b))
                        (T R a x (loop b))))))))))

既に同じキーの要素が存在した場合の対応をパラメータ化することで (reduce)、以下のように自在に派生関数を作り出すことができます。

上書き版

(define tree-set (tree-set~ (fn (k old new) new)))

更新版

(fun (tree-add + t k v)
  (tree-set~ (fn (k old new) (+ old new)) t k v))

追加版

(fun (tree-cons t k v)
  (tree-add append t k (list v)))

なお balance 関数は、Haskell 版そのまんまです。

(define-syntax defmatch
  (syntax-rules ()
    ((defmatch name ((pat ...) . body) ...)
     (define name
       (match-lambda** ((pat ...) . body) ...)))))

(defmatch balance
  (((T R a x b) y (T R c z d))
   (T R (T B a x b) y (T B c z d)))
  (((T R (T R a x b) y c) z d)
   (T R (T B a x b) y (T B c z d)))
  (((T R a x (T R b y c)) z d)
   (T R (T B a x b) y (T B c z d)))
  ((a x (T R b y (T R c z d)))
   (T R (T B a x b) y (T B c z d)))
  ((a x (T R (T R b y c) z d))
   (T R (T B a x b) y (T B c z d)))
  ((a x b)
   (T B a x b)))

応用例 (素因数分解)

tree-add を利用する例として、同じオブジェクトの出現回数を数える、というケースが考えられます。ここでは整数を素因数のリストに変換して、それをさらにSchemeの数式に変換する、という問題を解きます。

(fun (factorize~ n)
  (let loop ((n n) (d 2) (l '()))
    (if (< (/ n d) d)
        (cons n l)
        (receive (q r) (quotient/remainder n d)
          (if (zero? r)
              (loop q d (cons d l))
              (loop n (+ (if (= d 2) 1 2) d) l))))))

中身はあまり重要ではないので結果だけ見てください。

> (factorize~ 1984)
(31 2 2 2 2 2 2)

これにシンボル * を cons すればそのまま掛け算の式になりますが、そうではなく、同じ数の掛け算は指数の形に変換したいです。

こんな時、tree-add が使えます。

(fun (factorize n)
  (let ((l (map (fn ((cons n p))
                  (if (= p 1) n `(expt ,n ,p)))
                (tree->alist
                 (foldl (fn (x t)
                          (tree-add + (or t (make-tree x)) x 1))
                        #f
                        (factorize~ n))))))
    (if (null? (cdr l))
        (car l)        ; prime number
        (cons '* l))))

いちおう検算

> (apply values
         (map ((fn (x f) (f x)) 1984)
              (list factorize~
                    factorize
                    (compose eval factorize))))
(31 2 2 2 2 2 2)
(* (expt 2 6) 31)
1984

2番目の値がツリーの活用の成果です。細かいですが、2の指数の項が先に来ているのは偶然ではなく、キーの並び順通りにリスト化された結果です。

なお、ツリーからリストへの変換は以下のように定義しています。

(fun (tree-fold (cons _ t) f seed)
  (let loop (((and t
                   (T _ a (cons k v) b))
              t)
             (seed seed))
    (if (empty? t)
        seed
        (loop a
              (f k v (loop b seed))))))

(fun (tree-map f t)
  (tree-fold t (fn (k v l) (cons (f k v) l)) '()))

(define tree-keys (tree-map (fn (k _) k)))
(define tree-values (tree-map (fn (_ v) v)))
(define tree->alist (tree-map cons))

既存ノードの更新

キーが既に存在する場合のみ値を更新したい、という要求が生じることもあります。

これを単純に、ツリーを検索して見つかれば tree-set で更新、というやり方にしてしまうと、同じ検索を2回繰り返すという無駄が生じます。

また、見つからなければ何もしない、というのは tree-set~ では表現できないことなので、別な関数が必要になります。

(fun (tree-reset new (cons cmp t) k)
  (cons cmp
        (or (let loop (((and t
                             (T C a (and x (cons k~ v)) b))
                        t))
              (if (empty? t)
                  #f
                  (case (cmp k k~)
                    (< (aif (loop a) (T C it x b)))
                    (= (T C a (cons k (new v)) b))
                    (> (aif (loop b) (T C a x it))))))
            t)))

ツリーが空になった (キーが見つからなかった) 場合に、#f の代わりに空ツリーを返すようにすれば or や aif は不要になるんですが、不要なツリー生成をしないためにこのように工夫してあります。



マクロ: anaphora.ss arcfun.ss arcif.ss letfun.ss mlfun.ss

連想リストを適用可能にするために必要なこと

連想リストから値を検索する際に、このように lookup 関数を毎度毎度呼び出すのが面倒だなーと思うことがあります。

(let ((al '((a . 1) (b . 2) (c . 3))))
  (list (lookup 'a al) (lookup 'b al) (lookup 'c al)))

これを、

(al 'a)

のように書けたら楽ですよね。(特に、データの提供者と利用者とを分離して、データを集めて提供する側でこのように適用可能な形にして返してくれるのが理想的だと思います。)

ここで、キーとオブジェクトの順序が lookup の呼び出しとは逆になっていることに着目すると、

(lambda (al) (lambda (k) (lookup k al)))

lookup の上に、引数を逆順に受け取るようにして lambda を被せてやれば良いことが分かります。

この操作を一般化したものを Haskell では flip と呼びます。

定義

(fun (flip f x y) (f y x))

実行例

> (let ((obj (flip lookup '((a . 1) (b . 2) (c . 3)))))
    (list (obj 'a) (obj 'b) (obj 'c)))
(1 2 3)

他のものでも試してみましょう。

例えばリストですが、list-ref は語順が lookup と逆なので、flip で適用可能にすることはできません。

でも、flip の2乗ならば?

> (define flip^2 (compose flip flip))
> (let ((obj ((flip^2 list-ref) '(a b c))))
    (list (obj 0) (obj 1) (obj 2)))
(a b c)

できました。vector-ref や string-ref 等でも同様です。

fun マクロによって flip が (ひいては f が) 部分適用可能になることで、適用可能なオブジェクトが自動的に作られている、というのが今回の要点です。

いずれにせよ2引数関数にしか使えない技ですが。

ifのセマンティクスをarc風にする試み

anaphoric ifを使っていて時々感じるんですが、やはり空リストが偽として扱われない Scheme の意味論は、実用上どうしても不便なことが多いです。

例えば、cdr が空でなければループを続ける

(if (pair? (cdr l))
    (loop (cdr l))
    ...)

というパターンを

(aif (cdr l)
     (loop it)
     ...)

と書けないようでは、aif の魅力も半減と言わざるを得ません。

そこで、if 及び関連の構文を arc 風のものに大胆に置き換えることで、上記のようなプログラミングができるようにしようと考えました。


まず、どの値を偽とするかを決めます。

(define (ar-false? x)
  (or (not x) (null? x)))

シンボルの nil は、もともと使ってないので偽としては扱わないことにします。代わりに、

(define-values (t nil) (values #t #f))

として nil の意味をブール値の偽と定めます。

空リストとしては使えませんが、元来の if に基づいて書かれた関数群 (filter とか) とも共存する必要があるため、この決定はやむを得ません。

以上に基づいて、arc 風 if はこのように再帰的に定義することができます。

(defarc-syntax ar-if
  (syntax-rules ()
    ((ar-if) nil)
    ((ar-if expr) expr)
    ((ar-if test then . else)
     (if (ar-false? test) (ar-if . else) then))))

(defarc-syntax は ar-if を if にリネームしてエクスポートするマクロです)

MzScheme の if はelse部を省略できない3引数の構文ですが、これはゼロ引数以上のいわゆる variadic な構文です。ちなみにこれのおかげで arc には cond がありません。

その他

(defarc-syntax ar-and
  (syntax-rules ()
    ((ar-and) t)
    ((ar-and expr) expr)
    ((ar-and expr . rest)
     (ar-if expr (ar-and . rest)))))

(defarc-syntax ar-or
  (syntax-rules ()
    ((ar-or) nil)
    ((ar-or expr) expr)
    ((ar-or expr . rest)
     (let ((val expr))
       (ar-if val val (ar-or . rest))))))

(defarc-syntax ar-when
  (syntax-rules ()
    ((ar-when test . body)
     (ar-if test (begin . body)))))

(defarc-syntax ar-unless
  (syntax-rules ()
    ((ar-unless test . body)
     (ar-if test nil (begin . body)))))


評価例:

> (require "arcif.ss")
> (if)
#f
> (if (values 1 2))
1
2
> (if nil
       (/ 1 0)
      (cdr '(x))
       ((lambda (x) (x x))
        (lambda (x) (x x)))
      t)
#t


自分のモジュールに恐るおそるこれらの構文を導入してみて、エラーが出まくるかなと心配したんですが、案外すんなりと新しい (いや、古い、ですね) パラダイムに移行できたように思います。もう元の世界には戻れないかも知れません。


追記:

if のインデント用のelispを書いてみました。引数が2の場合は when と同様に、4引数以上の場合は cond っぽくインデントします。

(defun arc-indent-if (state indent-point normal-indent)
  (let* ((containing-form-start (elt state 1))
         (count+pos (count-sexp-args containing-form-start
                                     indent-point)))
    (when count+pos
      (let ((count (car count+pos))
            (pos (cdr count+pos)))
        (cond ((= count 2)
               (goto-char containing-form-start)
               (+ (current-column) lisp-body-indent))
              ((= count 3) normal-indent)
              ((> count 3)
               (setq normal-indent
                     (progn (goto-char containing-form-start)
                            (forward-char 1)
                            (forward-sexp 1)
                            (1+ (current-column))))
               (list (if (evenp pos)
                         (1+ normal-indent)
                       normal-indent)
                     containing-form-start)))))))

(defun count-sexp-args (containing-form-start indent-point)
  (goto-char containing-form-start)
  (let ((end
         (condition-case ()
             (save-excursion
               (forward-sexp 1)
               (backward-char 1)
               (skip-chars-backward " \t")
               (point))
           (error nil)))
        (count 0)
        (pos nil))
    (when end
      (condition-case ()
          (progn
            (forward-char 1)
            (forward-sexp 1)
            (while (< (point) end)
              (forward-sexp 1)
              (setq count (1+ count))
              (unless (or pos (< (point) indent-point))
                (setq pos count)))
            (cons count pos))
        (error nil)))))

(mapc (lambda (symbol)
        (put symbol 'scheme-indent-function 'arc-indent-if))
      '(if aif))


ファイル:
arcif.ss arcfun.ss mlfun.ss anaphora.ss

Threaded OR (in PLT Scheme)

ある必要があって、複数のリソースから最初に返答の得られたものを値として採用する、という構文を作ってみました。

実装:

(define-syntax spawn
  (syntax-rules ()
    ((spawn . e)
     (thread (lambda () . e)))))

;; cf: http://scheme.com/tspl4/examples.html#./examples:h11

(define (any-true thunks)
  (let ((cust (make-custodian)))
    (let loop ((engs
                (parameterize ((current-custodian cust))
                  (map (lambda (t)
                         (let ((c (make-channel)))
                           (spawn (channel-put c (t)))
                           (handle-evt c (lambda (v) (or v c)))))
                       thunks))))
      (and (pair? engs)
           (let ((v (apply sync engs)))
             (if (channel? v)
                 (loop (remove v engs))
                 (begin (custodian-shutdown-all cust)
                        v)))))))

(define-syntax por                      ;paralell or
  (syntax-rules ()
    ((por e ...)
     (any-true (list (lambda () e) ...)))))

書いている時は意識しなかったんですが、TSPL の「エンジン」の例で出てくる por という構文とそっくりだったので、そのようにリネームしました。

(sync evt ...)

で最も反応の早かったイベント (の値) が得られるんですが、それが #f だった場合は他のイベントを待つ必要があります。そのために handle-evt という関数で、値が #f の時は値でなくイベント自体を返すように工夫をしています。

例:

;; Don't try this at home ;-)
> (por ((lambda (x) (x x)) (lambda (x) (x x)))
       (begin (sleep (expt 2 32)) 1))
1

flet & labels in Scheme

ループ処理を書く時などに、全く同じ関数呼び出しを複数回書くことがあると思うんですが、それがどうも面倒*1なので、ローカル関数を手軽に作る構文を書いてみました。

マクロ:

(require "mlfun.ss")

(define-syntax define-flet
  (syntax-rules ()
    ((define-flet flet let)
     (define-syntax flet
       (syntax-rules ()
         ((flet ((name params . expr) (... ...)) . body)
          (let ((name (fn params . expr)) (... ...)) . body)))))))

(define-flet flet let)
(define-flet flet* let*)
(define-flet fletrec letrec)            ;`labels' in CL

(関数は lambda でも良いんですが、自動カリー化とかパターンマッチを組み込んである自作の fn を使っています)

例:

(fun (read-header in)
  (fletrec ((line () (read-line in 'any))
            (loop (l r)
              (if (string=? l "")
                  (reverse r)
                  (loop (line) (cons l r)))))
    (loop (line) '())))


追記:

let での変数のバインディングと flet のそれとではアリティーが違うことに着目して、変数と関数を両方バインドできるようにしてみました。

(define-syntax define-flet
  (syntax-rules ()
    ((define-flet flet let)
     (define-syntax (flet stx)
       (syntax-case stx ()
         ((flet loop . rest)
          (and (identifier? #'loop)
               (eq? (syntax->datum #'let) 'let))
          (syntax/loc stx
            (let loop . rest)))
         ((flet (bind (... ...)) . body)
          (quasisyntax/loc stx
            (let #,(map (lambda (x)
                          (syntax-case x ()
                            ((v e) x)
                            ((v p . e)
                             (syntax/loc x
                               (v (fn p . e))))))
                        (syntax->list #'(bind (... ...))))
              . body))))))))

モジュールのエクスポート時に flet を let にリネームすれば、let と flet の構文を統合することが出来ますね。


追記2:

let で関数束縛の構文を使った際に emacs でラムダっぽくインデントするようにしてみました。

(defadvice scheme-indent-function (after flet-hack activate)
  (unless ad-return-value
    (setq ad-return-value
          (scheme-indent-flet (ad-get-arg 0) (ad-get-arg 1)))))

(defun scheme-indent-flet (indent-point state)
  (goto-char (elt state 2))
  (when (and (eq (char-after) ?\()                 ;start of params
             (< (progn (forward-sexp 1) (point))   ;end of params
                indent-point))
    (condition-case ()
        (progn
          (backward-up-list 3)
          (forward-char 1)
          (when (and (looking-at "\\=let")
                     (< indent-point
                        ;; end of binding
			(progn (forward-sexp 2) (point))))
            (goto-char (elt state 1))
            (+ (current-column) lisp-body-indent)))
      (error nil))))

実は cl-indent.el で flet をどうやってインデントしているか調べようとしたんですが、難し過ぎて諦めかけました。


ライブラリ:
mlfun.ss

*1:インターナルdefineを使う方も多いと思うんですが、それだとdefineを何度も書くのが面倒、letだとlambdaを書くのが面倒、ということです