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