Sagittarius 0.5.0 のバグ？

pattern-match-lambda-test.scm

#!r6rs
(import (rnrs)
        (pattern-match-lambda))

(define-syntax exam
  (syntax-rules ()
    ((_ form expect)
     (begin
       (display 'form)
       (display " ... ")
       (display (if (equal? form expect) 'ok 'ng))
       (newline)))))

(define fact
  (pattern-match-lambda ()
   ((0) 1)
   ((n) (* n (fact (- n 1))))))

(exam (fact 5) 120)

(define example
  (pattern-match-lambda ()
    ((x y z) (list 'case1 x y z))
    ((x (y z)) (list 'case2 x y z))
    (((x y) z) (list 'case3 x y z))
    (else 'case3)))

(exam (example 1 2 3) '(case1 1 2 3))
(exam (example 4 '(5 6)) '(case2 4 5 6))
(exam (example '(7 8) 9) '(case3 7 8 9))
(exam (example 10 11 12 13) 'case3)

(define example2
  (pattern-match-lambda (foo bar baz)
    ((foo 1) 'foo-case-1)
    ((foo 2) 'foo-case-2)
    ((foo (x #(y z))) (list 'foo-case x y z))
    ((bar x) (list 'bar-case x))
    ((baz x) (list 'baz-case x))
    (else 'else-case)))

(exam (example2 'foo 1) 'foo-case-1)
(exam (example2 'foo '(1 #(2 3))) '(foo-case 1 2 3))
(exam (example2 'foo 2) 'foo-case-2)
(exam (example2 'baz 4) '(baz-case 4))

pattern-match-lambda.sls

#!r6rs
(library (pattern-match-lambda)
  (export pattern-match-lambda)
  (import (rnrs))
  
(define-syntax if-identifier
  (syntax-rules ()
    ((_ condition seq alt)
     (let-syntax ((foo (syntax-rules () ((_) seq))))
       (let-syntax ((test (syntax-rules ()
                            ((_ condition) (foo))
                            ((_ x) alt))))
         (test foo))))))

(define-syntax if-vector
  (syntax-rules ()
    ((_ #(x ...) seq alt) seq)
    ((_ x seq alt) alt)))

(define-syntax if-literal
  (syntax-rules ()
    ((_ p (literals ...) seq alt)
     (let-syntax ((bar (syntax-rules () ((_) seq))))
       (let-syntax ((foo (syntax-rules (literals ...)
                         ((_ literals) (bar)) ...
                         ((_ x) alt))))
       (foo p))))))

(define-syntax %if-match-vector
  (syntax-rules ()
    ((_ (literals ...) #() ind e seq alt) seq)
    ((_ (literals ...) #(p r ...) ind e seq alt)
     (%if-match (literals ...) p (vector-ref e ind)
       (let ((i ind))
         (%if-match-vector (literals ...) #(r ...) (+ i 1) e seq alt))
       alt))))

(define-syntax %if-match
  (syntax-rules ()
    ((_ (literals ...) #(p ...) e seq alt)
     (if (and (vector? e) (= (vector-length '#(p ...)) (vector-length e)))
         (%if-match-vector (literals ...) #(p ...) 0 e seq alt)
         (alt)))
    ((_ (literals ...) ((p . r1) . r2) e seq alt)
     (let ((temp e))
       (if (pair? temp)
           (%if-match (literals ...) (p . r1) (car temp)
             (%if-match (literals ...) r2 (cdr temp) seq alt)
             alt)
           (alt))))
    ((_ (literals ...) (p . r) e seq alt)
     (let ((temp e))
       (if (pair? temp)
           (if-identifier p
             (if-literal p (literals ...)
               (if (equal? 'p (car temp))
                   (%if-match (literals ...) r (cdr temp) seq alt)
                   (alt))
               (let ((p (car temp)))
                 (%if-match (literals ...) r (cdr temp) seq alt)))
             (%if-match (literals ...) p (car temp)
               (%if-match (literals ...) r (cdr temp) seq alt)
               alt))
           (alt))))
    ((_ (literals ...) () e seq alt)
     (if (null? e) seq (alt)))
    ((_ (literals ...) p e seq alt)
     (if-identifier p
       (if-literal p (literals ...)
         (if (equal? 'p e) seq (alt))
         (let ((p e)) seq))
       (if-vector p
         (%if-match-vector (literals ...) p e seq alt)
         (if (equal? p e) seq (alt)))))))

(define-syntax if-match
  (syntax-rules ()
    ((_ (literals ...) pattern lst seq alt)
     (let ((alt-thunk (lambda() alt)))
       (%if-match (literals ...) pattern lst seq alt-thunk)))))

(define-syntax %pattern-match-lambda
  (syntax-rules (else)
    ((_ (literals ...) lst) (values))
    ((_ (literals ...) lst (else action))
     action)
    ((_ (literals ...) lst (pattern action) (rest-pattern rest-action) ...)
     (if-match (literals ...) pattern lst
       action
       (%pattern-match-lambda (literals ...) lst
         (rest-pattern rest-action) ...)))))

(define-syntax pattern-match-lambda
  (syntax-rules ()
    ((_ (literals ...) (pattern action)  ...)
     (lambda lst
       (%pattern-match-lambda (literals ...) lst (pattern action) ...)))))

)