module/language/scheme/amatch.scm

   1 (define-module (language scheme amatch)
   2   #:use-module (ice-9 syncase)
   3   #:export (amatch apat))
   4 ;; FIXME: shouldn't have to export apat...
   5
   6 ;; This is exactly the same as pmatch except that it unpacks annotations
   7 ;; as needed.
   8
   9 (define-syntax amatch
  10   (syntax-rules (else guard)
  11     ((_ (op arg ...) cs ...)
  12      (let ((v (op arg ...)))
  13        (amatch v cs ...)))
  14     ((_ v) (if #f #f))
  15     ((_ v (else e0 e ...)) (begin e0 e ...))
  16     ((_ v (pat (guard g ...) e0 e ...) cs ...)
  17      (let ((fk (lambda () (amatch v cs ...))))
  18        (apat v pat
  19              (if (and g ...) (begin e0 e ...) (fk))
  20              (fk))))
  21     ((_ v (pat e0 e ...) cs ...)
  22      (let ((fk (lambda () (amatch v cs ...))))
  23        (apat v pat (begin e0 e ...) (fk))))))
  24
  25 (define-syntax apat
  26   (syntax-rules (_ quote unquote)
  27     ((_ v _ kt kf) kt)
  28     ((_ v () kt kf) (if (null? v) kt kf))
  29     ((_ v (quote lit) kt kf)
  30      (if (equal? v (quote lit)) kt kf))
  31     ((_ v (unquote var) kt kf) (let ((var v)) kt))
  32     ((_ v (x . y) kt kf)
  33      (if (apair? v)
  34          (let ((vx (acar v)) (vy (acdr v)))
  35            (apat vx x (apat vy y kt kf) kf))
  36          kf))
  37     ((_ v lit kt kf) (if (eq? v (quote lit)) kt kf))))