(defun report-case-failure (condition stream)
  (format stream "~S fell through ~S expression.~%Wanted one of ~:S."
          (type-error-datum condition)
          (case-failure-name condition)
          (case-failure-possibilities condition)))

(define-condition case-failure (type-error)
  ((name :reader case-failure-name :initarg :name)
   (possibilities :reader case-failure-possibilities :initarg :possibilities))
  (:report report-case-failure))

(defun store-value-read-evaluated-form ()
  (format *query-io* "~&;; Type a form to be evaluated:~%")
  (list (eval (read *query-io*))))

(defun expand-case-failure (datum complex-type operator-name keys)
  `(error 'case-failure :datum ,datum
                        :expected-type '(,complex-type ,@keys)
                        :name ',operator-name
                        :possibilities ',keys))

(defun case-transform-t-otherwise-cases (cases)
  (loop for (key . forms) in cases
        if (member key '(t otherwise))
          collect `((,key) ,@forms)
        else collect
        `(,key ,@forms)))

(defun case-accumulate-keys (cases)
  (loop for case in cases
        for key-or-keys = (first case)
        if (listp key-or-keys)
          append key-or-keys
        else
          collect key-or-keys))

(defun expand-with-store-value-restart (temp-var place tag forms)
  (let ((report-var (gensym "STORE-VALUE-REPORT"))
        (new-value-var (gensym "NEW-VALUE"))
        (form-or-forms (if (= 1 (length forms)) (first forms) `(progn ,@forms))))
    `(flet ((,report-var (stream)
              (format stream "Supply a new value of ~S." ',place)))
       (restart-case ,form-or-forms
         (store-value (,new-value-var)
           :report ,report-var
           :interactive store-value-read-evaluated-form
           (setf ,temp-var ,new-value-var
                 ,place ,new-value-var)
           (go ,tag))))))

(defmacro with-store-value-restart ((temp-var place tag) &body forms)
  (expand-with-store-value-restart temp-var place tag forms))

(defun expand-ccase (keyform cases)
  (let ((keys (case-accumulate-keys cases))
        (variable (gensym "CCASE-VARIABLE"))
        (block-name (gensym "CCASE-BLOCK"))
        (tag (gensym "CCASE-TAG")))
    `(block ,block-name
       (let ((,variable ,keyform))
         (tagbody ,tag
            (return-from ,block-name
              (case ,variable ,@(case-transform-t-otherwise-cases cases)
                    (t (with-store-value-restart (,variable ,keyform ,tag)
                         ,(expand-case-failure variable 'member 'ccase keys))))))))))

(defmacro my-ccase (keyform &rest cases)
  (expand-ccase keyform cases))

(defvar *x* 42)

(my-ccase (symbol-value (print '*x*)) (24 :t))