base/matching.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- Match utils
   4 ;;;
   5
   6 (in-package :iolib.base)
   7
   8 (defmacro multiple-value-case ((values &key (test 'eql)) &body body)
   9   (setf values (ensure-list values))
  10   (when (symbolp test) (setf test `(quote ,test)))
  11   (assert values () "Must provide at least one value to test")
  12   (let ((test-name (alexandria::extract-function-name test)))
  13     (labels ((%do-var (var val)
  14                (cond
  15                  ((and (symbolp var) (member var '("_" "*") :test #'string=))
  16                   t)
  17                  ((consp var)
  18                   `(member ,val ',var :test ,test))
  19                  (t
  20                   `(,test-name ,val ',var))))
  21              (%do-clause (c gensyms)
  22                (destructuring-bind (vals &rest code) c
  23                  (let* ((tests (remove t (mapcar #'%do-var (ensure-list vals) gensyms)))
  24                         (clause-test (if (> 2 (length tests))
  25                                          (first tests)
  26                                          `(and ,@tests))))
  27                    `(,clause-test ,@code))))
  28              (%do-last-clause (c gensyms)
  29                (when c
  30                  (destructuring-bind (test &rest code) c
  31                    (if (member test '(otherwise t))
  32                        `((t ,@code))
  33                        `(,(%do-clause c gensyms)))))))
  34       (let ((gensyms (mapcar (lambda (v) (gensym (string v)))
  35                              values)))
  36         `(let ,(mapcar #'list gensyms values)
  37            (declare (ignorable ,@gensyms))
  38            (cond ,@(append (mapcar (lambda (c) (%do-clause c gensyms))
  39                                    (butlast body))
  40                            (%do-last-clause (lastcar body) gensyms))))))))
  41
  42 (defmacro flags-case (mask &body clauses)
  43   (once-only (mask)
  44     `(progn ,@(mapcar (lambda (clause)
  45                         `(when
  46                            (logtest ,(let ((flags (first clause)))
  47                                        (if (listp flags)
  48                                            `(logior ,@flags)
  49                                            flags))
  50                                     ,mask)
  51                            ,(second clause)))
  52                       clauses))))