call-method and make-method macros

;;; Here are the definitions of my wrapper functions.  I gave up on
;;; the restriction concerning the expansion.  Nobody will be able to
;;; use macroexpand anyway since these are local macros.

(cl:in-package #:sicl-clos)

(defun wrap-make-method-form
    (form arguments-var arguments-var-p next-methods-var)
  (let* ((arguments-var-list
           (if arguments-var-p `(,arguments-var) '())))
    `(lambda (,@arguments-var-list ,next-methods-var)
       ,@(if arguments-var-p
             '()
             `((declare (ignore ,arguments-var))))
       (flet ((next-method-p ()
                (not (null ,next-methods-var)))
              (call-next-method (&rest ,arguments-var)
                (funcall (method-function (first ,next-methods-var))
                         ,arguments-var
                         (rest ,next-methods-var))))
         ,form))))

(defun wrap-in-call-method-macrolet (form arguments-var next-methods-var)
  `(macrolet ((call-method (method &optional next-method-list)
                (cond ((and (consp method)
                            (eq (first method) 'make-method)
                            (null (rest (rest method))))
                       `(funcall ,(wrap-make-method-form
                                   (second method)
                                   ',arguments-var
                                   nil
                                   ',next-methods-var)
                                 (list ,next-method-list)))
                      ((not (consp method))
                       `(funcall (method-function ,method)
                                 ,',arguments-var
                                 (list ,next-method-list)))
                      (t (error "Malformed argument to CALL-METHOD ~s" method)))))
     ,form))

(defun wrap-in-make-method-macrolet
    (form method-class-name arguments-var next-methods-var)
  `(macrolet ((make-method (make-method-form)
                `(make-instance ',',method-class-name
                   :qualifiers '()
                   :lambda-list '()
                   :specializers '()
                   :function
                   ,(wrap-in-call-method-macrolet
                     (wrap-make-method-form make-method-form
                                            ',arguments-var
                                            t
                                            ',next-methods-var)
                     ',arguments-var
                     ',next-methods-var))))
     ,form))

(defun wrap-method-combination-form (form method-class-name)
  (let ((arguments-var (gensym "ARGUMENTS-"))
        (next-methods-var (gensym "NEXT-METHODS-")))
    `(lambda (,arguments-var)
       ,(wrap-in-call-method-macrolet
         (wrap-in-make-method-macrolet
          form method-class-name arguments-var next-methods-var)
         arguments-var next-methods-var))))

;;; I simulated a result of the standard method combination like this:

(CALL-METHOD FIRST-AROUND
             (SECOND-AROUND
              (MAKE-METHOD
               (MULTIPLE-VALUE-PROG1
                   (PROGN
                    (CALL-METHOD FIRST-BEFORE)
                    (CALL-METHOD SECOND-BEFORE)
                    (CALL-METHOD FIRST-PRIMARY (SECOND-PRIMARY)))
                 (CALL-METHOD FIRST-AFTER)
                 (CALL-METHOD SECOND-AFTER)))))

;;; I then wrapped that result using WRAP-METHOD-COMBINATION-FORM,
;;; resulting in this form:

(LAMBDA (#1=#:ARGUMENTS-62286)
  (MACROLET ((CALL-METHOD (METHOD &OPTIONAL NEXT-METHOD-LIST)
               (COND
                ((AND #2=(CONSP METHOD) (EQ (FIRST METHOD) 'MAKE-METHOD)
                      (NULL (REST (REST METHOD))))
                 `(FUNCALL
                   ,(WRAP-MAKE-METHOD-FORM (SECOND METHOD) '#1# NIL
                                           '#3=#:NEXT-METHODS-62287)
                   (LIST ,NEXT-METHOD-LIST)))
                ((NOT #2#)
                 `(FUNCALL (METHOD-FUNCTION ,METHOD) ,'#1#
                           (LIST ,NEXT-METHOD-LIST)))
                (T (ERROR "Malformed argument to CALL-METHOD ~s" METHOD)))))
    (MACROLET ((MAKE-METHOD (MAKE-METHOD-FORM)
                 `(MAKE-INSTANCE ','STANDARD-METHOD :QUALIFIERS #4='NIL
                                 :LAMBDA-LIST #4# :SPECIALIZERS #4# :FUNCTION
                                 ,(WRAP-IN-CALL-METHOD-MACROLET
                                   (WRAP-MAKE-METHOD-FORM MAKE-METHOD-FORM '#1#
                                                          T '#3#)
                                   '#1# '#3#))))
      (CALL-METHOD FIRST-AROUND
                   (SECOND-AROUND
                    (MAKE-METHOD
                     (MULTIPLE-VALUE-PROG1
                         (PROGN
                          (CALL-METHOD FIRST-BEFORE)
                          (CALL-METHOD SECOND-BEFORE)
                          (CALL-METHOD FIRST-PRIMARY (SECOND-PRIMARY)))
                       (CALL-METHOD FIRST-AFTER)
                       (CALL-METHOD SECOND-AFTER))))))))

;;; Finally, I ran my new MACROEXPAND-ALL on the wrapped for, giving this:

#'(LAMBDA (#1=#:ARGUMENTS-62286)
    (LOCALLY
     (LOCALLY
      (FUNCALL (METHOD-FUNCTION FIRST-AROUND) #1#
               (LIST
                (SECOND-AROUND
                 (MAKE-INSTANCE 'STANDARD-METHOD :QUALIFIERS 'NIL :LAMBDA-LIST
                                'NIL :SPECIALIZERS 'NIL :FUNCTION
                                (LOCALLY
                                 #'(LAMBDA (#1# #2=#:NEXT-METHODS-62287)
                                     (FLET ((NEXT-METHOD-P ()
                                              (NOT (NULL #2#)))
                                            (CALL-NEXT-METHOD (&REST #1#)
                                              (FUNCALL
                                               (METHOD-FUNCTION (FIRST #2#))
                                               #1# (REST #2#))))
                                       (MULTIPLE-VALUE-PROG1
                                           (PROGN
                                            (FUNCALL
                                             (METHOD-FUNCTION FIRST-BEFORE) #1#
                                             (LIST NIL))
                                            (FUNCALL
                                             (METHOD-FUNCTION SECOND-BEFORE)
                                             #1# (LIST NIL))
                                            (FUNCALL
                                             (METHOD-FUNCTION FIRST-PRIMARY)
                                             #1# (LIST (SECOND-PRIMARY))))
                                         (FUNCALL (METHOD-FUNCTION FIRST-AFTER)
                                                  #1# (LIST NIL))
                                         (FUNCALL
                                          (METHOD-FUNCTION SECOND-AFTER) #1#
                                          (LIST NIL)))))))))))))