From a389eeacea06e065bc7d7b747c6d95143bcb66b5 Mon Sep 17 00:00:00 2001
From: Stelian Ionescu <sionescu@common-lisp.net>
Date: Thu, 14 Feb 2008 01:14:59 +0100
Subject: [PATCH] Make it possible to specify the test in MULTIPLE-VALUE-CASE,
 various improvements.

Signed-off-by: Stelian Ionescu <sionescu@common-lisp.net>
---
 net.sockets/common.lisp         | 18 +++++++++++++-----
 net.sockets/make-socket.lisp    |  6 +++---
 net.sockets/socket-methods.lisp |  2 +-
 3 files changed, 17 insertions(+), 9 deletions(-)

diff --git a/net.sockets/common.lisp b/net.sockets/common.lisp
index e03e118..cbf508b 100644
--- a/net.sockets/common.lisp
+++ b/net.sockets/common.lisp
@@ -250,20 +250,27 @@
 (defun memq (value list)
   (member value list :test #'eq))
 
-(defmacro multiple-value-case (values &body body)
+(defmacro multiple-value-case ((values &key (test 'eq)) &body body)
   (setf values (ensure-list values))
+  (setf test (alexandria::extract-function-name test))
   (assert values () "Must provide at least one value to test")
   (labels ((%do-var (var val)
              (cond
                ((and (symbolp var) (member var '("_" "*") :test #'string=))
                 t)
                ((consp var)
-                `(memq ,val ',var))
+                (if (eq 'eq test)
+                    `(memq ,val ',var)
+                    `(member ,val ',var :test ,test)))
                (t
-                `(eq ,val ',var))))
+                `(,test ,val ',var))))
            (%do-clause (c gensyms)
-             (destructuring-bind ((&rest vals) &rest code) c
-               `((and ,@(mapcar #'%do-var vals gensyms)) ,@code)))
+             (destructuring-bind (vals &rest code) c
+               (let* ((tests (remove t (mapcar #'%do-var (ensure-list vals) gensyms)))
+                      (clause-test (if (> 2 (length tests))
+                                       (first tests)
+                                       `(and ,@tests))))
+                 `(,clause-test ,@code))))
            (%do-last-clause (c gensyms)
              (when c
                (destructuring-bind (test &rest code) c
@@ -273,6 +280,7 @@
     (let ((gensyms (mapcar #'(lambda (v) (gensym (string v)))
                            values)))
       `(let ,(mapcar #'list gensyms values)
+         (declare (ignorable ,@gensyms))
          (cond ,@(append (mapcar #'(lambda (c) (%do-clause c gensyms))
                                  (butlast body))
                          (%do-last-clause (lastcar body) gensyms)))))))
diff --git a/net.sockets/make-socket.lisp b/net.sockets/make-socket.lisp
index 9ea310d..5f0bb18 100644
--- a/net.sockets/make-socket.lisp
+++ b/net.sockets/make-socket.lisp
@@ -248,7 +248,7 @@ If a non-local exit occurs during the execution of `BODY' call CLOSE with :ABORT
     (when (eq :ipv4 family) (setf ipv6 nil))
     (let ((*ipv6* ipv6))
       (when (eq :internet family) (setf family +default-inet-family+))
-      (multiple-value-case (family type connect)
+      (multiple-value-case ((family type connect))
         (((:ipv4 :ipv6) :stream :active)
          (%make-internet-stream-active-socket args family external-format))
         (((:ipv4 :ipv6) :stream :passive)
@@ -271,7 +271,7 @@ If a non-local exit occurs during the execution of `BODY' call CLOSE with :ABORT
      (check-type type (member :stream :datagram) "either :STREAM or :DATAGRAM")
      (check-type connect (member :active :passive) "either :ACTIVE or :PASSIVE")
      (let ((lower-function
-            (multiple-value-case (family type connect)
+            (multiple-value-case ((family type connect))
               (((:ipv4 :ipv6 :internet) :stream :active) '%make-internet-stream-active-socket)
               (((:ipv4 :ipv6 :internet) :stream :passive) '%make-internet-stream-passive-socket)
               ((:local :stream :active) '%make-local-stream-active-socket)
@@ -279,7 +279,7 @@ If a non-local exit occurs during the execution of `BODY' call CLOSE with :ABORT
               (((:ipv4 :ipv6 :internet) :datagram) '%make-internet-datagram-socket)
               ((:local :datagram) '%make-local-datagram-socket)))
            (newargs (remove-from-plist args :family :type :connect :external-format :ipv6)))
-       (case family
+       (multiple-value-case (family)
          (:internet (setf family '+default-inet-family+))
          (:ipv4     (setf ipv6 nil)))
        (let ((expansion `(,lower-function (list ,@newargs) ,family ,external-format)))
diff --git a/net.sockets/socket-methods.lisp b/net.sockets/socket-methods.lisp
index 6397bb5..a104bf0 100644
--- a/net.sockets/socket-methods.lisp
+++ b/net.sockets/socket-methods.lisp
@@ -348,7 +348,7 @@
   (assert (or read write) (read write)
           "You must select at least one direction to shut down.")
   (%shutdown (fd-of socket)
-             (multiple-value-case (read write)
+             (multiple-value-case ((read write))
                ((_   nil) shut-rd)
                ((nil _)   shut-wr)
                (t         shut-rdwr)))
-- 
2.11.4.GIT