マクロではないパターン・マッチング手続き

Andrew Wright のパターン・マッチング言語のサブセットを使う 200 行以下の小規模なパターン・マッチング手続きです。 対象はリスト限定で、 ベクタやレコードへのマッチングは省略してあります。 擬似クォート・パターンも省略しています。 set! と get! も使ったことがないので、 これも省略しています。 マクロではなく、 パターン・マッチング式の生成器でもありません。 単純にマッチングをおこなって、 成功したらパターン変数の連想リストを返し、 失敗したら偽を返す、 それだけのただの手続きです。

(pattern-match '('let (((? symbol? v) a) ...) m ..1) '(let ((x 1) (y 2)) e0 e1))
;=> ((v x y) (a 1 2) (m e0 e1))
(pattern-match '('let (and (((? symbol?) _) ...) b) m ..1) '(let ((x 1) (y 2)) e0 e1))
;=> ((b (x 1) (y 2)) (m e0 e1))

リスト対象のパターンは set! と get! を除くと、 ほぼすべてを使えます。 元がマクロでパターン・マッチングをおこなう式を生成する仕組みのため、 パターンそのものを使ってパターン・マッチングを実行するのには向いておらず、 扱いやすい抽象構文木のようなコード木を作っておいてから、 パターン・マッチングに使います。 下記の波括弧で囲んでいる部分が、 コード木への変換規則を表しています。

pattern : _                                 { (any) }
        | var                               { (variable var) }
        | #t | #f | number | char | string  { (quote constant) }
        | 'symbol                           { (identifier symbol) }
        | 'datum                            { (quote datum) }
        | ()                                { (null) }
        | (? predicate pattern-list)        { (? predicate code ...) }
        | (and pattern-list)                { (and code ...) }
        | (or pattern-list)                 { (or code ...) }
        | (not pattern-list)                { (not code ...) }
        | (pattern . pattern)               { (pair code code) }
        | (_ ...) | (_ ___) | (_ ..k) | (_ __k)                            { (any... k) }
        | (var ...) | (var ___) | (var ..k) | (var __k)                    { (variable... k var) }
        | (pattern ...) | (pattern ___) | (pattern ..k) | (pattern __k)    { (list... k code) }

pattern-list : (pattern . pattern-list) | ()

処理の流れは、 parse でパターンの構文チェックをおこないつつコード木を作り、 さらにパターン変数のリストを作ります。 続いて、 パターン変数の環境を作ってから、 match-datum でコード木を使ってパターン・マッチングをおこないます。 match-datum は真偽値を返すので、 真のとき、 環境からパターン変数の連想リストをとりだして返します。

(define (pattern-match pattern datum)
;<@ 補助手続きの内部定義@>
;<@ ..k 類のパターン・マッチング手続き@>
;<@ parse@>
;<@ parse-dot-dot-k@>
;<@ parse-seq@>
;<@ match-datum@>
;<@ match-set!@>
;<@ match-list...@>
 (parse pattern '() '() (lambda (code pat-vars _)
  (let ((env (cons (map (lambda (x) (list x)) (reverse pat-vars)) '())))
   (and (match-datum code datum env) (car env))))))

match-datum は、 ペアの構造をたどってパターン・マッチングを進めます。 any コードは常に真になり、 variable コードは環境のパターン変数の束縛対へデータをセットして、 これも常に真になります。 identifier コードは eq? でデータと比較します。 quote コードは equal? でデータと比較します。 null コードは、 データが空リストかどうか調べます。 pair コードはデータも pair のとき、 car と cdr のそれぞれをパターン・マッチングします。 ? コードは述語手続きでデータを調べ、 真のときはコード列全部がマッチするかどうか調べます。 and コードはコード列全部がマッチすることを、 or コードはコード列のどれかがマッチするまで、 not コードはコード全部がマッチしないことを調べます。 any... は、 list... を使わずにリストかどうか、 長さが十分かを調べます。 variable... はリストの長さが十分なとき、 環境のパターン変数の束縛対へデータをセットします。

;<@ match-datum@>=
 (define (match-datum code d env)
  (case (car code)
   ((any) #t)
   ((variable) (match-set! (cadr code) d env))
   ((identifier) (eq? (cadr code) d))
   ((quote) (equal? (cadr code) d))
   ((null) (null? d))
   ((pair)
    (and (pair? d)
         (match-datum (cadr code) (car d) env)
         (match-datum (caddr code) (cdr d) env)))
   ((any...) (and (list? d) (>= (length d) (cadr code))))
   ((variable...)
    (and (list? d) (>= (length d) (cadr code)) (match-set! (caddr code) d env)))
   ((list...) (match-list... code d env))
   ((?) (and ((cadr code) d) (every (lambda (c) (match-datum c d env)) (cddr code))))
   ((and) (every (lambda (c) (match-datum c d env)) (cdr code)))
   ((or) (any (lambda (c) (match-datum c d env)) (cdr code)))
   ((not) (not (any (lambda (c) (match-datum c d env)) (cdr code))))
   (else (error "not yet pattern code" code))))

match-set! は、 環境のパターン変数の束縛対へデータをセットします。 そして常に真を返します。

;@< match-set!@>=
 (define (match-set! x d env)
  (set-cdr! (assq x (car env)) d)
  #t)

match-list... は、 リストの末尾までコードを繰り返しマッチングしていきます。 そのとき、 コード内に含まれるパターン変数用にローカル・スコープを環境に作ります。 そして、 繰り返しマッチングの各段階で、 ローカル・スコープの内容を一つ外のスコープの同じパターン変数の末尾へ追加します。 それと同時に、 リストの長さを count に求めて、 それがパターン ..k の k で指定した必要な最短長さ以上の長さであるかどうか判定します。 他の条件を満たしていたとしても、 正規リストのときにだけ真にします。 データが循環リストかどうかチェックしていないので、 循環リストのときは無限ループに陥ります。

;<@ match-list...@>=
 (define (match-list... code d env)
  (let ((atleast (cadr code))
        (vars (caddr code))
        (subcode (cadddr code)))
   (let loop-datum ((d d) (count 0))
    (let ((env1 (cons (map (lambda (x) (list x)) vars) env)))
     (cond
      ((null? d) (>= count atleast))
      ((not (pair? d)) #f) ; improper list
      ((match-datum subcode (car d) env1)
       (let loop-rib1 ((rib1 (car env1)))
        (if (null? rib1)
         (loop-datum (cdr d) (+ count 1))
         (let ((apair (assq (caar rib1) (car env))))
          (set-cdr! (last-pair apair) (list (cdar rib1)))
          (loop-rib1 (cdr rib1))))))
      (else #f))))))

パターン・マッチングがすっきりと記述できているのは、 そうなるように code の生成を parse にやってもらったおかげです。 parse はワンパスで、 パターンをコード木へ変換すると同時に、 パターン変数のリストを作ります。 パターン変数リストは 2 つあります。 パターン全体用の変数リストと、 ..k 類用のものです。 コード木への変換とパターン変数リスト作成を同時におこなえるように、 継続渡しスタイルにしてあり、 くどくなってしまいました。

;<@ parse@>=
 (define (parse pat vars subvars kont)
  (cond
   ((eq? pat '_) (kont '(any) vars subvars))
   ((pattern-variable? pat)
    (when (memq pat vars) (error "pattern variable duplicate" pat pattern))
    (kont `(variable ,pat) (cons pat vars) (cons pat subvars)))
   ((pattern-constant? pat) (kont `(quote ,pat) vars subvars))
   ((null? pat) (kont '(null) vars subvars))
   ((pair? pat)
    (case (car pat)
     ((quote)
      (unless (pattern-xy? pat) (error "invalid quote pattern" pat pattern))
      (if (symbol? (cadr pat))
       (kont `(identifier ,(cadr pat)) vars subvars)
       (kont pat vars subvars)))
     ((and or not)
      (unless (pattern-xy+? pat) (error "invalid pattern" pattern))
      (parse-seq (cdr pat) vars subvars (lambda (code* vars subvars)
       (kont (cons (car pat) code*) vars subvars))))
     ((?)
      (unless (pattern-xy+? pat) (error "invalid pattern" pattern))
      (let ((predicate (eval (cadr pat) (interaction-environment))))
       (parse-seq (cddr pat) vars subvars (lambda (code* vars subvars)
        (kont (cons* '? predicate code*) vars subvars)))))
     (else
      (cond
       ((and (pattern-xy? pat) (dot-dot-k? (cadr pat))) => (lambda (k)
        (parse-dot-dot-k k (car pat) vars subvars kont)))
       (else
        (parse (car pat) vars subvars (lambda (code_lhs vars subvars)
         (parse (cdr pat) vars subvars (lambda (code_rhs vars subvars)
          (kont `(pair ,code_lhs ,code_rhs) vars subvars))))))))))
   (else (error "invalid pattern" pattern))))

parse-dot-dot-k は、 リストへのパターン・マッチングをおこなうコードへ変換します。 _ ... と変数 ... は頻繁に使うので、 list... を使わないコードにします。

;@< parse-dot-dot-k@>=
 (define (parse-dot-dot-k k pat vars subvars kont)
  (cond
   ((eq? pat '_) (kont `(any... ,k) vars subvars))
   ((pattern-variable? pat)
    (parse pat vars subvars (lambda (code vars subvars)
     (kont `(variable... ,k ,pat) vars subvars))))
   (else
    (parse pat vars '() (lambda (code vars subvars1)
     (kont `(list... ,k ,subvars1 ,code) vars (append subvars subvars1)))))))

parse-seq は、 継続渡しスタイルの map を多値にしたものです。

;<@ parse-seq@>=
 (define (parse-seq pat* vars subvars kont)
  (if (null? pat*)
   (kont '() vars subvars)
   (parse (car pat*) vars subvars (lambda (code_lhs vars subvars)
    (parse-seq (cdr pat*) vars subvars (lambda (code_rhs vars subvars)
     (kont (cons code_lhs code_rhs) vars subvars)))))))

dot-dot-k? は、 ..k 類の必要な最短長さ k を数にします。

;<@ ..k 類のパターン・マッチング手続き@>=
 (define dot-dot-k?
  (let* ((digit-chset (apply char-set (string->list "0123456789")))
         (digit? (lambda (c) (char-set-contains? digit-chset c))))
   (lambda (pat)
    (and (symbol? pat)
     (cond
      ((memq pat '(... ___)) 0)
      ((memq pat '(..1 __1)) 1)
      (else
       (let ((s (symbol->string pat)))
        (and (>= (string-length s) 3)
         (let ((s0 (substring s 0 2))
               (s1 (substring s 2 (string-length s))))
          (and (or (string=? s0 "..") (string=? s0 "__"))
           (every digit? (string->list s1))
           (string->number s1)))))))))))

補助手続きのうち、 シンボルがパターン変数かどうか調べるときに、 Gauche 拡張のパターンのキーワードはすべてパターン変数にできないことにしています。

;<@ 補助手続きの内部定義@>=
 (define (pattern-variable? pat)
  (and (symbol? pat)
       (not (memq pat '(... ___ ..1 __1 _ ? and or not
                        quasiquote quote unquote unquote-splicing
                        $ struct @ object = set! get!)))
       (not (dot-dot-k? pat))))
 (define (pattern-constant? pat)
  (or (boolean? pat) (number? pat) (char? pat) (string? pat)))
 (define (pattern-xy? pat)
  (and (pair? pat) (pair? (cdr pat)) (null? (cddr pat))))
 (define (pattern-xy+? pat)
  (and (pair? pat) (pair? (cdr pat)) (list? (cddr pat))))