module/system/base/pmatch.scm

   1 (define-module (system base pmatch)
   2   #:use-module (ice-9 syncase)
   3   #:export (pmatch ppat))
   4 ;; FIXME: shouldn't have to export ppat...
   5
   6 ;; Originally written by Oleg Kiselyov. Taken from:
   7 ;; αKanren: A Fresh Name in Nominal Logic Programming
   8 ;; by William E. Byrd and Daniel P. Friedman
   9 ;; Proceedings of the 2007 Workshop on Scheme and Functional Programming
  10 ;; Université Laval Technical Report DIUL-RT-0701
  11
  12 ;; Licensing unclear. Probably need to ask Oleg for a disclaimer.
  13
  14 (define-syntax pmatch
  15   (syntax-rules (else guard)
  16     ((_ (op arg ...) cs ...)
  17      (let ((v (op arg ...)))
  18        (pmatch v cs ...)))
  19     ((_ v) (if #f #f))
  20     ((_ v (else e0 e ...)) (begin e0 e ...))
  21     ((_ v (pat (guard g ...) e0 e ...) cs ...)
  22      (let ((fk (lambda () (pmatch v cs ...))))
  23        (ppat v pat
  24              (if (and g ...) (begin e0 e ...) (fk))
  25              (fk))))
  26     ((_ v (pat e0 e ...) cs ...)
  27      (let ((fk (lambda () (pmatch v cs ...))))
  28        (ppat v pat (begin e0 e ...) (fk))))))
  29
  30 (define-syntax ppat
  31   (syntax-rules (_ quote unquote)
  32     ((_ v _ kt kf) kt)
  33     ((_ v () kt kf) (if (null? v) kt kf))
  34     ((_ v (quote lit) kt kf)
  35      (if (equal? v (quote lit)) kt kf))
  36     ((_ v (unquote var) kt kf) (let ((var v)) kt))
  37     ((_ v (x . y) kt kf)
  38      (if (pair? v)
  39          (let ((vx (car v)) (vy (cdr v)))
  40            (ppat vx x (ppat vy y kt kf) kf))
  41          kf))
  42     ((_ v lit kt kf) (if (eq? v (quote lit)) kt kf))))