(require-extension expand-full)

(define-syntax stream-match-pattern
  (syntax-rules (_)
    ((stream-match-pattern STRM () (BINDING ...) BODY)
     (and (stream-null? STRM) (let (BINDING ...) BODY)))
    ((stream-match-pattern STRM (_ . REST) (BINDING ...) BODY)
     (and (stream-pair? STRM)
          (let ((STRM (stream-cdr STRM)))
            (stream-match-pattern STRM REST (BINDING ...) BODY))))
    ((stream-match-pattern STRM (VAR . REST) (BINDING ...) BODY)
     (and (stream-pair? STRM)
          (let ((temp (stream-car STRM)) (STRM (stream-cdr STRM)))
            (stream-match-pattern STRM REST ((VAR temp) BINDING ...) BODY))))
    ((stream-match-pattern STRM _ (BINDING ...) BODY)
     (let (BINDING ...) BODY))
    ((stream-match-pattern STRM VAR (BINDING ...) BODY)
     (let ((VAR STRM) BINDING ...) BODY))))

(define-syntax stream-match-test
  (syntax-rules ()
    ((stream-match-test STRM (PATTERN FENDER EXPR))
     (stream-match-pattern STRM PATTERN () (and FENDER (list EXPR))))
    ((stream-match-test STRM (PATTERN EXPR))
     (stream-match-pattern STRM PATTERN () (list EXPR)))))

(define-syntax stream-match
  (syntax-rules ()
    ((stream-match STRM-EXPR CLAUSE ...)
     (let ((strm STRM-EXPR))
       (cond ((not (stream? strm)) (error-invalid-stream 'stream-match strm))
             ((stream-match-test strm CLAUSE) => car) ...
             (else (error 'stream-match "pattern failure")))))))

(ppexpand*
  '(stream-match yy
    (() (stream (stream x)))
    ((y . ys)
      (stream-append
        (stream (stream-cons x yy))
        (stream-map (lambda (z) (stream-cons y z))
                    (stream-intersperse ys x))))) )

(ppexpand*  '(and a b))