From 26c8e18750248cb62772f52db733d32836d32dc1 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= <daniel@turtleware.eu>
Date: Thu, 19 Jan 2023 19:52:56 +0100
Subject: [PATCH 1/8] cmputil: fix invalid iteration

Instead of using the iteration variable we've used the same list repeatedly.
---
 src/cmp/cmputil.lsp | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/src/cmp/cmputil.lsp b/src/cmp/cmputil.lsp
index 4332c0ee2..ce0cde058 100644
--- a/src/cmp/cmputil.lsp
+++ b/src/cmp/cmputil.lsp
@@ -613,9 +613,9 @@ keyword argument, the compiler-macro declines to provide an expansion.
                   parse-forms-pass2))
           ;; 5. &aux vars: these are simply set to their initforms after
           ;; parsing of keywords has finished
-          (loop for a on auxs
-                do (push (first auxs) bindings-for-body)
-                   (push `(setf ,(first auxs) ,(second auxs)) aux-setf-forms))
+          (loop for a on auxs by #'cddr
+                do (push (first a) bindings-for-body)
+                   (push `(setf ,(first a) ,(second a)) aux-setf-forms))
           ;; 6. Finally, we are ready to create the compiler-macro definition
           `(define-compiler-macro ,name ,(nreverse new-lambda-list)
              (let* ,(nreverse bindings-for-body)

From b62cf6b7ed42078fe2556922f26aa52eb7da6a60 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= <daniel@turtleware.eu>
Date: Fri, 20 Jan 2023 16:32:59 +0100
Subject: [PATCH 2/8] cmuutil: don't use setf to enable use in early macros

There was no real utility in using SETF there yet it made using collect macros
not possible in macros that are used to define ECL.
---
 src/lsp/cmuutil.lsp | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/src/lsp/cmuutil.lsp b/src/lsp/cmuutil.lsp
index db2fddb51..fb1925041 100644
--- a/src/lsp/cmuutil.lsp
+++ b/src/lsp/cmuutil.lsp
@@ -43,7 +43,7 @@
       ,@(mapcar #'(lambda (form)
                     `(let ((,n-res (cons ,form nil)))
                        (cond (,n-tail
-                              (setf (cdr ,n-tail) ,n-res)
+                              (rplacd ,n-tail ,n-res)
                               (setq ,n-tail ,n-res))
                              (t
                               (setq ,n-tail ,n-res  ,n-value ,n-res)))))
@@ -95,7 +95,7 @@ Example:
   (let (macros binds)
     (dolist (spec collections)
       (cond ((atom spec)
-             (setf spec (list spec)))
+             (setq spec (list spec)))
             ((not (<= 1 (length spec) 3))
              (error "Malformed collection specifier: ~S." spec)))
       (let ((n-value (gensym))
@@ -150,7 +150,7 @@ Example:
                  `(progn ,@body)
                  (let ((spec (first specs)))
                    (cond ((atom spec)
-                          (setf spec (list spec spec)))
+                          (setq spec (list spec spec)))
                          ((/= (length spec) 2)
                           (error "Malformed Once-Only binding spec: ~S." spec)))
                    (let ((name (first spec))

From 8ba1bb888ad25fe7a440e26b2ba1e41a95488f25 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= <daniel@turtleware.eu>
Date: Thu, 19 Jan 2023 20:04:21 +0100
Subject: [PATCH 3/8] si_process_lambda_list: process all variables in an
 uniform manner

The comment mentioned that aux variables (the sixth value) are returned the
same way as requireds, optionals and keywords however factually that was not
the case - the number of variables was not the first element of the list. This
commit updates the function and all its callers.
---
 src/c/compiler.d          | 26 +++++++++++++-------------
 src/cmp/cmppass1-call.lsp |  3 ++-
 src/cmp/cmppass1-fun.lsp  |  2 +-
 src/cmp/cmputil.lsp       |  2 +-
 src/lsp/defmacro.lsp      |  2 +-
 5 files changed, 18 insertions(+), 17 deletions(-)

diff --git a/src/c/compiler.d b/src/c/compiler.d
index 5e0e4e0ed..a8a922ab7 100644
--- a/src/c/compiler.d
+++ b/src/c/compiler.d
@@ -2885,16 +2885,15 @@ si_process_lambda(cl_object lambda)
  * VALUES(5) = allow-other-keys                 ; flag &allow-other-keys
  * VALUES(6) = (N aux1 init1 ... )              ; auxiliary variables
  *
- * 1°) The prefix "N" is an integer value denoting the number of
- * variables which are declared within this section of the lambda
- * list.
+ * 1) The prefix "N" is an integer value denoting the number of variables
+ * which are declared within this section of the lambda list.
  *
- * 2°) The INIT* arguments are lisp forms which are evaluated when
- * no value is provided.
+ * 2) The INIT* arguments are lisp forms which are evaluated when no value is
+ * provided.
  *
- * 3°) The FLAG* arguments is the name of a variable which holds a
- * boolean value in case an optional or keyword argument was
- * provided. If it is NIL, no such variable exists.
+ * 3) The FLAG* arguments is the name of a variable which holds a boolean
+ * value in case an optional or keyword argument was provided. If it is NIL,
+ * no such variable exists.
  */
 
 cl_object
@@ -3088,15 +3087,16 @@ si_process_lambda_list(cl_object org_lambda_list, cl_object context)
 
  OUTPUT:
   if ((nreq+nopt+(!Null(rest))+nkey) >= ECL_CALL_ARGUMENTS_LIMIT)
-    FEprogram_error("LAMBDA: Argument list is too long, ~S.", 1,
-                             org_lambda_list);
-  @(return CONS(ecl_make_fixnum(nreq), lists[0])
+    FEprogram_error("LAMBDA: Argument list is too long, ~S.", 1, org_lambda_list);
+
+  @(return
+    CONS(ecl_make_fixnum(nreq), lists[0])
     CONS(ecl_make_fixnum(nopt), lists[1])
     rest
     key_flag
     CONS(ecl_make_fixnum(nkey), lists[2])
     allow_other_keys
-    lists[3]);
+    CONS(ecl_make_fixnum(naux), lists[3]))
 
  ILLEGAL_LAMBDA:
   FEprogram_error("LAMBDA: Illegal lambda list ~S.", 1, org_lambda_list);
@@ -3195,7 +3195,7 @@ ecl_make_lambda(cl_env_ptr env, cl_object name, cl_object lambda) {
     }
     ECL_RPLACD(aux, names);
   }
-
+  auxs = ECL_CONS_CDR(auxs);
   while (!Null(auxs)) {                   /* Local bindings */
     cl_object var = pop(&auxs);
     cl_object value = pop(&auxs);
diff --git a/src/cmp/cmppass1-call.lsp b/src/cmp/cmppass1-call.lsp
index 85f618868..6435629c3 100644
--- a/src/cmp/cmppass1-call.lsp
+++ b/src/cmp/cmppass1-call.lsp
@@ -353,8 +353,9 @@
     (when (and key-flag (not allow-other-keys))
       (push `(si::check-keyword ,rest ',all-keys) extra-stmts))
     ;; 7. construct body
+    (pop aux-vars)
     (loop while aux-vars
-       do (push (list (pop aux-vars) (pop aux-vars)) let-vars))
+          do (push (list (pop aux-vars) (pop aux-vars)) let-vars))
     (values (nreverse (delete-if-not #'first let-vars))
             `(,@(and apply-var `((declare (ignorable ,apply-var))))
               ,@(multiple-value-bind (decl body)
diff --git a/src/cmp/cmppass1-fun.lsp b/src/cmp/cmppass1-fun.lsp
index a20fe733c..5f4c0809d 100644
--- a/src/cmp/cmppass1-fun.lsp
+++ b/src/cmp/cmppass1-fun.lsp
@@ -303,7 +303,7 @@
           (extract-lambda-type-checks function-name requireds optionals
                                       keywords ts other-decls)
         (let* ((declarations other-decls)
-               (let-vars (loop for spec on (nconc new-auxs aux-vars)
+               (let-vars (loop for spec on (nconc new-auxs (rest aux-vars))
                             by #'cddr
                             for name = (first spec)
                             for init = (second spec)
diff --git a/src/cmp/cmputil.lsp b/src/cmp/cmputil.lsp
index ce0cde058..614e99700 100644
--- a/src/cmp/cmputil.lsp
+++ b/src/cmp/cmputil.lsp
@@ -613,7 +613,7 @@ keyword argument, the compiler-macro declines to provide an expansion.
                   parse-forms-pass2))
           ;; 5. &aux vars: these are simply set to their initforms after
           ;; parsing of keywords has finished
-          (loop for a on auxs by #'cddr
+          (loop for a on (rest auxs) by #'cddr
                 do (push (first a) bindings-for-body)
                    (push `(setf ,(first a) ,(second a)) aux-setf-forms))
           ;; 6. Finally, we are ready to create the compiler-macro definition
diff --git a/src/lsp/defmacro.lsp b/src/lsp/defmacro.lsp
index cfa8f7063..212778301 100644
--- a/src/lsp/defmacro.lsp
+++ b/src/lsp/defmacro.lsp
@@ -155,7 +155,7 @@
                      (dm-v v `(if (eq ,temp 'missing-keyword) ,init ,temp))
                      (when sv (dm-v sv `(not (eq ,temp 'missing-keyword))))
                      (push k all-keywords)))
-                 (do ((l auxs (cddr l))) ((endp l))
+                 (do ((l (rest auxs) (cddr l))) ((endp l))
                    (let* ((v (first l))
                           (init (second l)))
                      (dm-v v init)))

From 3064bac62bf04f1e4eb714effcdda0f33d690adb Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= <daniel@turtleware.eu>
Date: Thu, 19 Jan 2023 15:28:06 +0100
Subject: [PATCH 4/8] tests: add regression tests for define-method-combination

---
 src/tests/ecl-tests.asd         |  1 +
 src/tests/normal-tests/clos.lsp | 52 +++++++++++++++++++++++++++++++++
 2 files changed, 53 insertions(+)
 create mode 100644 src/tests/normal-tests/clos.lsp

diff --git a/src/tests/ecl-tests.asd b/src/tests/ecl-tests.asd
index 83ed00f6a..1b6fe54fb 100644
--- a/src/tests/ecl-tests.asd
+++ b/src/tests/ecl-tests.asd
@@ -13,6 +13,7 @@
                         :default-component-class asdf:cl-source-file.lsp
                         :components
                         ((:file "ansi")
+                         (:file "clos")
                          (:file "mixed")
                          (:file "compiler")
                          (:file "executable-cli")
diff --git a/src/tests/normal-tests/clos.lsp b/src/tests/normal-tests/clos.lsp
new file mode 100644
index 000000000..3ece872d6
--- /dev/null
+++ b/src/tests/normal-tests/clos.lsp
@@ -0,0 +1,52 @@
+;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil -*-
+;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
+
+;;;; Author:   Daniel Kochmański
+;;;; Created:  2023-01-19
+;;;; Contains: CLOS tests
+
+(in-package #:cl-test)
+
+(suite 'clos)
+
+
+;;; Method combination long form
+
+;;; Check whether different types of wildcard patterns are correctly handled.
+;;; Most notably the symbol * in a pattern matches any method qualifier on
+;;; that position.
+(ext:with-clean-symbols (combin gf)
+  (test clos.0001.combin/wildcard
+    (define-method-combination combin ()
+      ((p1 (:wild :no))
+       (p2 (:wild * *))
+       (p3 (:wild . *))
+       (pr *))
+      `(list ,(length p1)
+             ,(length p2)
+             ,(length p3)
+             ,(length pr)))
+    (defgeneric gf ()
+      (:method-combination combin))
+    (finishes (defmethod gf :wild :no ()))   ; p1
+    (finishes (defmethod gf :wild :x :y ())) ; p2
+    (finishes (defmethod gf :wild ()))       ; p3
+    (finishes (defmethod gf :wild :foobar ())) ; p3
+    (finishes (defmethod gf :wild :no :a :b ())) ; p3
+    (finishes (defmethod gf :xxx :yyy 34 23 ())) ; p4
+    (is-equal '(1 1 3 1) (gf))))
+
+;;; This test checks whether define-method-combination handles arguments
+;;; :GENERIC-FUNCTION and :ARGUMENTS &WHOLE ARGS.
+(ext:with-clean-symbols (combin f1 f2)
+  (test clos.0002.combin/arguments
+    (define-method-combination combin ()
+      ((method-list *))
+      (:arguments &whole args)
+      (:generic-function gf)
+      `(list ,gf ,args))
+    (defgeneric f1 (a &key key-1)
+      (:method-combination combin)
+      (:method (a &key key-1 key-2)
+        (declare (ignore a key-1 key-2))))
+    (is-equal (list #'f1 1 :key-1 2) (f1 1 :key-1 2))))

From 78abe40fb9cb0e63a6c83bb38054a0c5a5a8df33 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= <daniel@turtleware.eu>
Date: Thu, 19 Jan 2023 15:28:23 +0100
Subject: [PATCH 5/8] clos: handle correctly the pattern * in
 define-method-combination

The pattern in the long form of the define-method-combination may contain * as
a list element meaning "any" qualifier. For example:

(define-method-combination foo ()
    ((bar (:xxx * :yyy)))
  ...)

In this case qualifiers `:xxx 3 :yyy' and `:xxx :zzz :yyy' will match.
---
 src/clos/combin.lsp | 49 +++++++++++++++++++++++++++------------------
 1 file changed, 29 insertions(+), 20 deletions(-)

diff --git a/src/clos/combin.lsp b/src/clos/combin.lsp
index 93311a269..d9de097e2 100644
--- a/src/clos/combin.lsp
+++ b/src/clos/combin.lsp
@@ -360,11 +360,28 @@
           (generic-function-lambda-list ,generic-function)
           result)))))
 
+(defun parse-qualifier-pattern (pattern)
+  (declare (si::c-local))
+  (cond ((eq pattern '*)   't)
+        ((eq pattern nil)  '(null .method-qualifiers.))
+        ((symbolp pattern) `(,pattern .method-qualifiers.))
+        ((listp pattern)
+         `(do ((pattern ',pattern (cdr pattern))
+               (qualifiers .method-qualifiers. (cdr qualifiers)))
+              ((or (eq pattern '*)
+                   (and (null pattern)
+                        (null qualifiers)))
+               t)
+            (unless (and pattern qualifiers
+                         (or (eq (car pattern) '*)
+                             (eq (car pattern) (car qualifiers))))
+              (return nil))))
+        (t nil)))
+
 (defun define-complex-method-combination (form)
   (declare (si::c-local))
   (flet ((syntax-error ()
-           (error "~S is not a valid DEFINE-METHOD-COMBINATION form"
-                  form)))
+           (error "~S is not a valid DEFINE-METHOD-COMBINATION form." form)))
     (destructuring-bind (name lambda-list method-groups &rest body &aux
                          (group-names '())
                          (group-checks '())
@@ -373,7 +390,8 @@
                          (method-arguments '())
                          decls documentation arguments-lambda-list)
         form
-      (unless (symbolp name) (syntax-error))
+      (unless (symbolp name)
+        (syntax-error))
       (let ((x (first body)))
         (when (and (consp x) (eql (first x) :ARGUMENTS))
           (setf body (rest body)
@@ -392,23 +410,13 @@
           (if (symbolp group-name)
               (push group-name group-names)
               (syntax-error))
-          (let ((condition
-                (cond ((eql predicate '*) 'T)
-                      ((and predicate (symbolp predicate))
-                       `(,predicate .METHOD-QUALIFIERS.))
-                      ((and (listp predicate)
-                            (let* ((q (last predicate 0))
-                                   (p (copy-list (butlast predicate 0))))
-                              (when (every #'symbolp p)
-                                (if (eql q '*)
-                                    `(every #'equal ',p .METHOD-QUALIFIERS.)
-                                    `(equal ',p .METHOD-QUALIFIERS.))))))
-                      (t (syntax-error)))))
-            (push `(,condition (push .METHOD. ,group-name)) group-checks))
+          (if-let ((condition (parse-qualifier-pattern predicate)))
+            (push `(,condition (push .METHOD. ,group-name)) group-checks)
+            (syntax-error))
           (when required
             (push `(unless ,group-name
-                    (error "Method combination: ~S. No methods ~
-                            in required group ~S." ',name ,group-name))
+                     (error "Method combination: ~S. No methods ~
+                             in required group ~S." ',name ,group-name))
                   group-after))
           (case order
             (:most-specific-first
@@ -433,10 +441,11 @@
                    `(let (,@group-names)
                       (dolist (.method. .methods-list.)
                         (let ((.method-qualifiers. (method-qualifiers .method.)))
+                          (declare (ignorable .method-qualifiers.))
                           (cond ,@(nreverse group-checks)
                                 (t (invalid-method-error .method.
-                                                         "Method qualifiers ~S are not allowed in the method-~
-                                  combination ~S." .method-qualifiers. ',name)))))
+                                    "Method qualifiers ~S are not allowed in the ~
+                                     method combination ~S." .method-qualifiers. ',name)))))
                       ,@group-after
                       ,@body))
                  t))))))))

From dea75e6bb5850bfaf91dec0b06f131ff64e211b4 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= <daniel@turtleware.eu>
Date: Fri, 20 Jan 2023 17:22:55 +0100
Subject: [PATCH 6/8] clos: refactor define-complex-method-combination

Factor out a macro WITH-METHOD-GROUPS. The function PARSE-QUALIFIER-PATTERN is
put as a local function in this new macro.
---
 src/clos/combin.lsp | 130 +++++++++++++++++++++-----------------------
 1 file changed, 63 insertions(+), 67 deletions(-)

diff --git a/src/clos/combin.lsp b/src/clos/combin.lsp
index d9de097e2..bf8b1c3df 100644
--- a/src/clos/combin.lsp
+++ b/src/clos/combin.lsp
@@ -316,7 +316,8 @@
                       ,body))
                 .combined-method-args.)))))
 
-(defun process-define-method-combination-arguments-lambda-list (lambda-list generic-function body)
+(defun process-define-method-combination-arguments-lambda-list
+    (lambda-list generic-function body)
   (declare (si::c-local))
   (when (null lambda-list)
     (return-from process-define-method-combination-arguments-lambda-list body))
@@ -360,74 +361,78 @@
           (generic-function-lambda-list ,generic-function)
           result)))))
 
-(defun parse-qualifier-pattern (pattern)
-  (declare (si::c-local))
-  (cond ((eq pattern '*)   't)
-        ((eq pattern nil)  '(null .method-qualifiers.))
-        ((symbolp pattern) `(,pattern .method-qualifiers.))
-        ((listp pattern)
-         `(do ((pattern ',pattern (cdr pattern))
-               (qualifiers .method-qualifiers. (cdr qualifiers)))
-              ((or (eq pattern '*)
-                   (and (null pattern)
-                        (null qualifiers)))
-               t)
-            (unless (and pattern qualifiers
-                         (or (eq (car pattern) '*)
-                             (eq (car pattern) (car qualifiers))))
-              (return nil))))
-        (t nil)))
+(defmacro with-method-groups ((&rest method-groups) &body body)
+  (let (group-names matchers cleanup)
+    (flet ((parse-qualifier-pattern (pattern)
+             (cond ((eq pattern '*)   't)
+                   ((eq pattern nil)  '(null .method-qualifiers.))
+                   ((symbolp pattern) `(,pattern .method-qualifiers.))
+                   ((listp pattern)
+                    `(do ((pattern ',pattern (cdr pattern))
+                          (qualifiers .method-qualifiers. (cdr qualifiers)))
+                         ((or (eq pattern '*)
+                              (and (null pattern)
+                                   (null qualifiers)))
+                          t)
+                       (unless (and pattern qualifiers
+                                    (or (eq (car pattern) '*)
+                                        (eq (car pattern) (car qualifiers))))
+                         (return nil))))
+                   (t
+                    (error "Invalid method group pattern ~s." pattern)))))
+      (dolist (group method-groups)
+        (destructuring-bind (name pattern &key description
+                                               (order :most-specific-first)
+                                               (required nil))
+            group
+          (declare (ignore description))
+          (push name group-names)
+          (push `(,(parse-qualifier-pattern pattern) (push .method. ,name))
+                matchers)
+          (when required
+            (push `(unless ,name
+                     (error "No methods in required group ~S." ',name))
+                  cleanup))
+          (case order
+            (:most-specific-first
+             (push `(setf ,name (nreverse ,name)) cleanup))
+            (:most-specific-last)
+            (otherwise
+             (push `(when (eq ,order :most-specific-first)
+                      (setf ,name (nreverse ,name)))
+                   cleanup))))))
+    `(let ,group-names
+       (dolist (.method. .methods-list.)
+         (let ((.method-qualifiers. (method-qualifiers .method.)))
+           (declare (ignorable .method-qualifiers.))
+           (cond ,@(nreverse matchers)
+                 ,@(unless (member t matchers :key #'car)
+                     `((t (invalid-method-error
+                           .method.
+                           "Method qualifiers ~s are not allowed." .method-qualifiers.)))))))
+       ,@cleanup
+       ,@body)))
 
 (defun define-complex-method-combination (form)
   (declare (si::c-local))
   (flet ((syntax-error ()
            (error "~S is not a valid DEFINE-METHOD-COMBINATION form." form)))
-    (destructuring-bind (name lambda-list method-groups &rest body &aux
-                         (group-names '())
-                         (group-checks '())
-                         (group-after '())
-                         (generic-function '.generic-function.)
-                         (method-arguments '())
-                         decls documentation arguments-lambda-list)
+    (destructuring-bind (name lambda-list method-groups &rest body
+                         &aux (generic-function '.generic-function.)
+                              (arguments nil))
         form
-      (unless (symbolp name)
-        (syntax-error))
       (let ((x (first body)))
         (when (and (consp x) (eql (first x) :ARGUMENTS))
-          (setf body (rest body)
-                arguments-lambda-list (rest x))))
+          (setf body (rest body))
+          (setf arguments (rest x))))
       (let ((x (first body)))
         (when (and (consp x) (eql (first x) :GENERIC-FUNCTION))
           (setf body (rest body))
-          (unless (symbolp (setf generic-function (second x)))
-            (syntax-error))))
+          (setf generic-function (second x))))
+      (unless (and (symbolp name) (symbolp generic-function))
+        (error "~S is not a valid DEFINE-METHOD-COMBINATION form." form))
       (multiple-value-setq (decls body documentation)
         (si::find-declarations body t))
-      (dolist (group method-groups)
-        (destructuring-bind (group-name predicate &key description
-                                  (order :most-specific-first) (required nil))
-            group
-          (if (symbolp group-name)
-              (push group-name group-names)
-              (syntax-error))
-          (if-let ((condition (parse-qualifier-pattern predicate)))
-            (push `(,condition (push .METHOD. ,group-name)) group-checks)
-            (syntax-error))
-          (when required
-            (push `(unless ,group-name
-                     (error "Method combination: ~S. No methods ~
-                             in required group ~S." ',name ,group-name))
-                  group-after))
-          (case order
-            (:most-specific-first
-             (push `(setf ,group-name (nreverse ,group-name)) group-after))
-            (:most-specific-last)
-            (otherwise
-             (let ((order-var (gensym)))
-               (setf group-names (append group-names (list (list order-var order)))
-                     group-after (list* `(when (eq ,order-var :most-specific-first)
-                                           (setf ,group-name (nreverse ,group-name)))
-                                        group-after)))))))
       `(progn
          ,@(si::expand-set-documentation name 'method-combination documentation)
          (install-method-combination ',name
@@ -437,17 +442,8 @@
               (block ,name
                 (effective-method-function
                  ,(process-define-method-combination-arguments-lambda-list
-                   arguments-lambda-list generic-function
-                   `(let (,@group-names)
-                      (dolist (.method. .methods-list.)
-                        (let ((.method-qualifiers. (method-qualifiers .method.)))
-                          (declare (ignorable .method-qualifiers.))
-                          (cond ,@(nreverse group-checks)
-                                (t (invalid-method-error .method.
-                                    "Method qualifiers ~S are not allowed in the ~
-                                     method combination ~S." .method-qualifiers. ',name)))))
-                      ,@group-after
-                      ,@body))
+                   arguments generic-function
+                   `(with-method-groups ,method-groups ,@body))
                  t))))))))
 
 (defmacro define-method-combination (name &body body)

From 2ba822836637985f21cd6c4ccc59004d6679f408 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= <daniel@turtleware.eu>
Date: Sun, 22 Jan 2023 20:30:49 +0100
Subject: [PATCH 7/8] clos: move define-method-combination to a separate file

---
 src/clos/combin.lsp    | 307 +--------------------------------------
 src/clos/defcombin.lsp | 316 +++++++++++++++++++++++++++++++++++++++++
 src/clos/load.lsp.in   |   1 +
 3 files changed, 318 insertions(+), 306 deletions(-)
 create mode 100644 src/clos/defcombin.lsp

diff --git a/src/clos/combin.lsp b/src/clos/combin.lsp
index bf8b1c3df..480584a60 100644
--- a/src/clos/combin.lsp
+++ b/src/clos/combin.lsp
@@ -167,299 +167,7 @@
                                       (nconc (rest around) main)))
           (if (or before after)
               (standard-main-effective-method before primary after)
-              (combine-method-functions (first primary) (rest primary))))
-      )))
-
-;; ----------------------------------------------------------------------
-;; DEFINE-METHOD-COMBINATION
-;;
-;; METHOD-COMBINATION objects are just a list
-;;      (name arg*)
-;; where NAME is the name of the method combination type defined with
-;; DEFINE-METHOD-COMBINATION, and ARG* is zero or more arguments.
-;;
-;; For each method combination type there is an associated function,
-;; and the list of all known method combination types is kept in
-;; *METHOD-COMBINATIONS* in the form of property list:
-;;      (mc-type-name1 function1 mc-type-name2 function2 ....)
-;;
-;; FUNCTIONn is the function associated to a method combination. It
-;; is of type (FUNCTION (generic-function method-list) FUNCTION),
-;; and it outputs an anonymous function which is the effective method.
-;;
-
-#+threads
-(defparameter *method-combinations-lock* (mp:make-lock :name 'find-method-combination))
-(defparameter *method-combinations* (make-hash-table :size 32 :test 'eq))
-
-(defun search-method-combination (name)
-  (mp:with-lock (*method-combinations-lock*)
-    (or (gethash name *method-combinations*)
-        (error "~A does not name a method combination" name))))
-
-(defun install-method-combination (name function)
-  (mp:with-lock (*method-combinations-lock*)
-    (setf (gethash name *method-combinations*) function))
-  name)
-
-(defun make-method-combination (name compiler options)
-  (with-early-make-instance +method-combination-slots+
-    (o (find-class 'method-combination)
-       :name name
-       :compiler compiler
-       :options options)
-    o))
-
-(defun find-method-combination (gf method-combination-type-name method-combination-options)
-  (declare (ignore gf))
-  (make-method-combination method-combination-type-name
-                           (search-method-combination method-combination-type-name)
-                           method-combination-options
-                           ))
-
-(defun define-simple-method-combination (name &key documentation
-                                         identity-with-one-argument
-                                         (operator name))
-  `(define-method-combination ,name (&optional (order :MOST-SPECIFIC-FIRST))
-     ((around (:AROUND))
-      (principal (,name) :REQUIRED t))
-     ,documentation
-     (let ((main-effective-method
-            `(,',operator ,@(mapcar #'(lambda (x) `(CALL-METHOD ,x NIL))
-                                    (if (eql order :MOST-SPECIFIC-LAST)
-                                        (reverse principal)
-                                        principal)))))
-       (cond (around
-              `(call-method ,(first around)
-                (,@(rest around) (make-method ,main-effective-method))))
-             (,(if identity-with-one-argument
-                   '(rest principal)
-                   t)
-              main-effective-method)
-             (t (second main-effective-method))))))
-
-(defun method-combination-arguments-reshuffling (mc-whole-arg mc-lambda-list gf-lambda-list body)
-  ;; Implement the reshuffling of arguments to the generic function
-  ;; into arguments for a method-combination arguments lambda list
-  ;; required for the long form of DEFINE-METHOD-COMBINATION. The
-  ;; generic function arguments are stored in the variable
-  ;; .COMBINED-METHOD-ARGS. of type STACK-FRAME. To extract the
-  ;; arguments we apply to this stack frame a function whose
-  ;; lambda-list is built below by reshaping the method-combination
-  ;; lambda-list to fit the form of the generic-function lambda-list.
-  (let ((lambda-list '())
-        (let-statements '())
-        (ignored-vars '())
-        n-gf-requireds n-gf-optionals)
-    (multiple-value-bind (mc-requireds mc-optionals mc-rest mc-key-flag mc-keywords
-                          mc-allow-other-keys mc-aux-vars)
-        (si::process-lambda-list mc-lambda-list 'function)
-      (declare (ignore mc-allow-other-keys))
-      (multiple-value-bind (gf-requireds gf-optionals)
-          (si::process-lambda-list gf-lambda-list 'function)
-        (setf n-gf-requireds (first gf-requireds)
-              n-gf-optionals (first gf-optionals))
-        (when mc-whole-arg
-          (push `(,mc-whole-arg (apply #'list .combined-method-args.))
-                let-statements))
-        (loop for r in (rest mc-requireds) by #'cdr
-              for i from 0
-              if (< i n-gf-requireds)
-                do (push r lambda-list)
-              else ; excess required args of the method-combination
-                   ; are set to nil
-              do (push `(,r nil) let-statements))
-        ;; excess required args of the generic-function are ignored
-        (loop repeat (- n-gf-requireds (first mc-requireds))
-              for v = (gensym)
-              do (push v lambda-list)
-                 (push v ignored-vars))
-        (push '&optional lambda-list)
-        (loop for o on (rest mc-optionals) by #'cdddr
-              for i from 0
-              if (< i n-gf-optionals)
-                do (push (if (third o)
-                             `(,(first o) ,(second o) ,(third o))
-                             `(,(first o) ,(second o)))
-                         lambda-list)
-              else ; excess optional args of the method-combination
-                   ; are set to their init forms
-                do (push `(,(first o) ,(second o)) let-statements)
-                   (when (third o)
-                     (push `(,(third o) nil) let-statements)))
-        ;; excess args of the generic-function are ignored
-        (loop repeat (- n-gf-optionals (first mc-optionals))
-              for v = (gensym)
-              do (push v lambda-list)
-                 (push v ignored-vars))
-        (unless mc-rest
-          (setf mc-rest (gensym))
-          (push mc-rest ignored-vars))
-        ;; rest, keyword and aux args are treated as usual
-        (push '&rest lambda-list)
-        (push mc-rest lambda-list)
-        (when mc-key-flag
-          (push '&key lambda-list)
-          (loop for k on (rest mc-keywords) by #'cddddr
-                do (push (if (fourth k)
-                             `((,(first k) ,(second k)) ,(third k) ,(fourth k))
-                             `((,(first k) ,(second k)) ,(third k)))
-                         lambda-list))
-          (push '&allow-other-keys lambda-list))
-        (when mc-aux-vars
-          (push '&aux lambda-list)
-          (loop for a on mc-aux-vars by #'cddr
-                do (push `(,(first a) ,(second a)) lambda-list)))
-        `(apply #'(lambda ,(nreverse lambda-list)
-                    (declare (ignore ,@ignored-vars))
-                    (let ,(nreverse let-statements)
-                      ,body))
-                .combined-method-args.)))))
-
-(defun process-define-method-combination-arguments-lambda-list
-    (lambda-list generic-function body)
-  (declare (si::c-local))
-  (when (null lambda-list)
-    (return-from process-define-method-combination-arguments-lambda-list body))
-  (let ((whole (when (eq (first lambda-list) '&whole)
-                 (prog1 (second lambda-list)
-                   (setf lambda-list (cddr lambda-list))))))
-    (multiple-value-bind (requireds optionals rest key-flag keywords
-                          allow-other-keys aux-vars)
-        (si::process-lambda-list lambda-list 'function)
-      (declare (ignore allow-other-keys key-flag))
-      ;; This is a little complicated. We are constructing a form
-      ;; which when evaluated constructs another form that finally
-      ;; implements the desired destructuring of arguments supplied to
-      ;; the generic function.
-      ;;
-      ;; First evaluate the body form containing the grouping of the
-      ;; methods and the user-supplied method-combination body in a
-      ;; context in which all free variables are bound to fresh
-      ;; symbols (we use the name of the free variable itself). This
-      ;; part happens when the method combination is defined.
-      `(let ((result (let ,(mapcar #'(lambda (v) `(,v ',v))
-                                   (append (when whole (list whole))
-                                           (rest requireds)
-                                           (loop for o on (rest optionals) by #'cdddr
-                                                 collect (first o)
-                                                 when (third o) collect (third o))
-                                           (when rest (list rest))
-                                           (loop for k on (rest keywords) by #'cddddr
-                                                 collect (second k)
-                                                 when (fourth k) collect (fourth k))
-                                           (loop for a on (rest aux-vars) by #'cddr
-                                                 collect (first a))))
-                       ,body)))
-         ;; Second, construct a form which implements the required
-         ;; complex reshuffling of arguments. This part happens after
-         ;; a generic function using the method combination is
-         ;; defined.
-         (method-combination-arguments-reshuffling
-          ',whole
-          ',lambda-list
-          (generic-function-lambda-list ,generic-function)
-          result)))))
-
-(defmacro with-method-groups ((&rest method-groups) &body body)
-  (let (group-names matchers cleanup)
-    (flet ((parse-qualifier-pattern (pattern)
-             (cond ((eq pattern '*)   't)
-                   ((eq pattern nil)  '(null .method-qualifiers.))
-                   ((symbolp pattern) `(,pattern .method-qualifiers.))
-                   ((listp pattern)
-                    `(do ((pattern ',pattern (cdr pattern))
-                          (qualifiers .method-qualifiers. (cdr qualifiers)))
-                         ((or (eq pattern '*)
-                              (and (null pattern)
-                                   (null qualifiers)))
-                          t)
-                       (unless (and pattern qualifiers
-                                    (or (eq (car pattern) '*)
-                                        (eq (car pattern) (car qualifiers))))
-                         (return nil))))
-                   (t
-                    (error "Invalid method group pattern ~s." pattern)))))
-      (dolist (group method-groups)
-        (destructuring-bind (name pattern &key description
-                                               (order :most-specific-first)
-                                               (required nil))
-            group
-          (declare (ignore description))
-          (push name group-names)
-          (push `(,(parse-qualifier-pattern pattern) (push .method. ,name))
-                matchers)
-          (when required
-            (push `(unless ,name
-                     (error "No methods in required group ~S." ',name))
-                  cleanup))
-          (case order
-            (:most-specific-first
-             (push `(setf ,name (nreverse ,name)) cleanup))
-            (:most-specific-last)
-            (otherwise
-             (push `(when (eq ,order :most-specific-first)
-                      (setf ,name (nreverse ,name)))
-                   cleanup))))))
-    `(let ,group-names
-       (dolist (.method. .methods-list.)
-         (let ((.method-qualifiers. (method-qualifiers .method.)))
-           (declare (ignorable .method-qualifiers.))
-           (cond ,@(nreverse matchers)
-                 ,@(unless (member t matchers :key #'car)
-                     `((t (invalid-method-error
-                           .method.
-                           "Method qualifiers ~s are not allowed." .method-qualifiers.)))))))
-       ,@cleanup
-       ,@body)))
-
-(defun define-complex-method-combination (form)
-  (declare (si::c-local))
-  (flet ((syntax-error ()
-           (error "~S is not a valid DEFINE-METHOD-COMBINATION form." form)))
-    (destructuring-bind (name lambda-list method-groups &rest body
-                         &aux (generic-function '.generic-function.)
-                              (arguments nil))
-        form
-      (let ((x (first body)))
-        (when (and (consp x) (eql (first x) :ARGUMENTS))
-          (setf body (rest body))
-          (setf arguments (rest x))))
-      (let ((x (first body)))
-        (when (and (consp x) (eql (first x) :GENERIC-FUNCTION))
-          (setf body (rest body))
-          (setf generic-function (second x))))
-      (unless (and (symbolp name) (symbolp generic-function))
-        (error "~S is not a valid DEFINE-METHOD-COMBINATION form." form))
-      (multiple-value-setq (decls body documentation)
-        (si::find-declarations body t))
-      `(progn
-         ,@(si::expand-set-documentation name 'method-combination documentation)
-         (install-method-combination ',name
-            (lambda (,generic-function .methods-list. ,@lambda-list)
-              (declare (ignorable ,generic-function))
-              ,@decls
-              (block ,name
-                (effective-method-function
-                 ,(process-define-method-combination-arguments-lambda-list
-                   arguments generic-function
-                   `(with-method-groups ,method-groups ,@body))
-                 t))))))))
-
-(defmacro define-method-combination (name &body body)
-  (if (and body (listp (first body)))
-      (define-complex-method-combination (list* name body))
-      (apply #'define-simple-method-combination name body)))
-
-(defun method-combination-error (format-control &rest args)
-  ;; FIXME! We should emit a more detailed error!
-  (error "Method-combination error:~%~S"
-         (apply #'format nil format-control args)))
-
-(defun invalid-method-error (method format-control &rest args)
-  (error "Invalid method error for ~A~%~S"
-         method
-         (apply #'format nil format-control args)))
+              (combine-method-functions (first primary) (rest primary)))) )))
 
 ;;; ----------------------------------------------------------------------
 ;;; COMPUTE-EFFECTIVE-METHOD
@@ -501,16 +209,3 @@
 (defun compute-effective-method (gf method-combination applicable-methods)
   `(funcall ,(std-compute-effective-method gf method-combination applicable-methods)
             .combined-method-args. *next-methods*))
-
-(install-method-combination 'standard 'standard-compute-effective-method)
-(progn
-  (define-method-combination progn :identity-with-one-argument t)
-  (define-method-combination and :identity-with-one-argument t)
-  (define-method-combination max :identity-with-one-argument t)
-  (define-method-combination + :identity-with-one-argument t)
-  (define-method-combination nconc :identity-with-one-argument t)
-  (define-method-combination append :identity-with-one-argument nil)
-  (define-method-combination list :identity-with-one-argument nil)
-  (define-method-combination min :identity-with-one-argument t)
-  (define-method-combination or :identity-with-one-argument t))
-
diff --git a/src/clos/defcombin.lsp b/src/clos/defcombin.lsp
new file mode 100644
index 000000000..fee4c7146
--- /dev/null
+++ b/src/clos/defcombin.lsp
@@ -0,0 +1,316 @@
+;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: CLOS -*-
+;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
+
+;;;;
+;;;;  Copyright (c) 1992, Giuseppe Attardi
+;;;;  Copyright (c) 2001, Juan Jose Garcia Ripoll
+;;;;  Copyright (c) 2023, Daniel Kochmański
+;;;;  Copyright (c) 2023, Marius Gerbershagen 
+;;;;
+;;;;    See file '../Copyright' for full details.
+;;;;
+
+(in-package "CLOS")
+
+;; ----------------------------------------------------------------------
+;; DEFINE-METHOD-COMBINATION
+;;
+;; METHOD-COMBINATION objects are just a list
+;;      (name arg*)
+;; where NAME is the name of the method combination type defined with
+;; DEFINE-METHOD-COMBINATION, and ARG* is zero or more arguments.
+;;
+;; For each method combination type there is an associated function,
+;; and the list of all known method combination types is kept in
+;; *METHOD-COMBINATIONS* in the form of property list:
+;;      (mc-type-name1 function1 mc-type-name2 function2 ....)
+;;
+;; FUNCTIONn is the function associated to a method combination. It
+;; is of type (FUNCTION (generic-function method-list) FUNCTION),
+;; and it outputs an anonymous function which is the effective method.
+;;
+
+#+threads
+(defparameter *method-combinations-lock* (mp:make-lock :name 'find-method-combination))
+(defparameter *method-combinations* (make-hash-table :size 32 :test 'eq))
+
+(defun search-method-combination (name)
+  (mp:with-lock (*method-combinations-lock*)
+    (or (gethash name *method-combinations*)
+        (error "~A does not name a method combination" name))))
+
+(defun install-method-combination (name function)
+  (mp:with-lock (*method-combinations-lock*)
+    (setf (gethash name *method-combinations*) function))
+  name)
+
+(defun make-method-combination (name compiler options)
+  (with-early-make-instance +method-combination-slots+
+    (o (find-class 'method-combination)
+       :name name
+       :compiler compiler
+       :options options)
+    o))
+
+(defun find-method-combination (gf method-combination-type-name method-combination-options)
+  (declare (ignore gf))
+  (make-method-combination method-combination-type-name
+                           (search-method-combination method-combination-type-name)
+                           method-combination-options
+                           ))
+
+(defun define-simple-method-combination (name &key documentation
+                                         identity-with-one-argument
+                                         (operator name))
+  `(define-method-combination ,name (&optional (order :MOST-SPECIFIC-FIRST))
+     ((around (:AROUND))
+      (principal (,name) :REQUIRED t))
+     ,documentation
+     (let ((main-effective-method
+            `(,',operator ,@(mapcar #'(lambda (x) `(CALL-METHOD ,x NIL))
+                                    (if (eql order :MOST-SPECIFIC-LAST)
+                                        (reverse principal)
+                                        principal)))))
+       (cond (around
+              `(call-method ,(first around)
+                (,@(rest around) (make-method ,main-effective-method))))
+             (,(if identity-with-one-argument
+                   '(rest principal)
+                   t)
+              main-effective-method)
+             (t (second main-effective-method))))))
+
+(defun method-combination-arguments-reshuffling (mc-whole-arg mc-lambda-list gf-lambda-list body)
+  ;; Implement the reshuffling of arguments to the generic function
+  ;; into arguments for a method-combination arguments lambda list
+  ;; required for the long form of DEFINE-METHOD-COMBINATION. The
+  ;; generic function arguments are stored in the variable
+  ;; .COMBINED-METHOD-ARGS. of type STACK-FRAME. To extract the
+  ;; arguments we apply to this stack frame a function whose
+  ;; lambda-list is built below by reshaping the method-combination
+  ;; lambda-list to fit the form of the generic-function lambda-list.
+  (let ((lambda-list '())
+        (let-statements '())
+        (ignored-vars '())
+        n-gf-requireds n-gf-optionals)
+    (multiple-value-bind (mc-requireds mc-optionals mc-rest mc-key-flag mc-keywords
+                          mc-allow-other-keys mc-aux-vars)
+        (si::process-lambda-list mc-lambda-list 'function)
+      (declare (ignore mc-allow-other-keys))
+      (multiple-value-bind (gf-requireds gf-optionals)
+          (si::process-lambda-list gf-lambda-list 'function)
+        (setf n-gf-requireds (first gf-requireds)
+              n-gf-optionals (first gf-optionals))
+        (when mc-whole-arg
+          (push `(,mc-whole-arg (apply #'list .combined-method-args.))
+                let-statements))
+        (loop for r in (rest mc-requireds) by #'cdr
+              for i from 0
+              if (< i n-gf-requireds)
+                do (push r lambda-list)
+              else ; excess required args of the method-combination
+                   ; are set to nil
+              do (push `(,r nil) let-statements))
+        ;; excess required args of the generic-function are ignored
+        (loop repeat (- n-gf-requireds (first mc-requireds))
+              for v = (gensym)
+              do (push v lambda-list)
+                 (push v ignored-vars))
+        (push '&optional lambda-list)
+        (loop for o on (rest mc-optionals) by #'cdddr
+              for i from 0
+              if (< i n-gf-optionals)
+                do (push (if (third o)
+                             `(,(first o) ,(second o) ,(third o))
+                             `(,(first o) ,(second o)))
+                         lambda-list)
+              else ; excess optional args of the method-combination
+                   ; are set to their init forms
+                do (push `(,(first o) ,(second o)) let-statements)
+                   (when (third o)
+                     (push `(,(third o) nil) let-statements)))
+        ;; excess args of the generic-function are ignored
+        (loop repeat (- n-gf-optionals (first mc-optionals))
+              for v = (gensym)
+              do (push v lambda-list)
+                 (push v ignored-vars))
+        (unless mc-rest
+          (setf mc-rest (gensym))
+          (push mc-rest ignored-vars))
+        ;; rest, keyword and aux args are treated as usual
+        (push '&rest lambda-list)
+        (push mc-rest lambda-list)
+        (when mc-key-flag
+          (push '&key lambda-list)
+          (loop for k on (rest mc-keywords) by #'cddddr
+                do (push (if (fourth k)
+                             `((,(first k) ,(second k)) ,(third k) ,(fourth k))
+                             `((,(first k) ,(second k)) ,(third k)))
+                         lambda-list))
+          (push '&allow-other-keys lambda-list))
+        (when mc-aux-vars
+          (push '&aux lambda-list)
+          (loop for a on mc-aux-vars by #'cddr
+                do (push `(,(first a) ,(second a)) lambda-list)))
+        `(apply #'(lambda ,(nreverse lambda-list)
+                    (declare (ignore ,@ignored-vars))
+                    (let ,(nreverse let-statements)
+                      ,body))
+                .combined-method-args.)))))
+
+(defun process-define-method-combination-arguments-lambda-list
+    (lambda-list generic-function body)
+  (declare (si::c-local))
+  (when (null lambda-list)
+    (return-from process-define-method-combination-arguments-lambda-list body))
+  (let ((whole (when (eq (first lambda-list) '&whole)
+                 (prog1 (second lambda-list)
+                   (setf lambda-list (cddr lambda-list))))))
+    (multiple-value-bind (requireds optionals rest key-flag keywords
+                          allow-other-keys aux-vars)
+        (si::process-lambda-list lambda-list 'function)
+      (declare (ignore allow-other-keys key-flag))
+      ;; This is a little complicated. We are constructing a form
+      ;; which when evaluated constructs another form that finally
+      ;; implements the desired destructuring of arguments supplied to
+      ;; the generic function.
+      ;;
+      ;; First evaluate the body form containing the grouping of the
+      ;; methods and the user-supplied method-combination body in a
+      ;; context in which all free variables are bound to fresh
+      ;; symbols (we use the name of the free variable itself). This
+      ;; part happens when the method combination is defined.
+      `(let ((result (let ,(mapcar #'(lambda (v) `(,v ',v))
+                                   (append (when whole (list whole))
+                                           (rest requireds)
+                                           (loop for o on (rest optionals) by #'cdddr
+                                                 collect (first o)
+                                                 when (third o) collect (third o))
+                                           (when rest (list rest))
+                                           (loop for k on (rest keywords) by #'cddddr
+                                                 collect (second k)
+                                                 when (fourth k) collect (fourth k))
+                                           (loop for a on (rest aux-vars) by #'cddr
+                                                 collect (first a))))
+                       ,body)))
+         ;; Second, construct a form which implements the required
+         ;; complex reshuffling of arguments. This part happens after
+         ;; a generic function using the method combination is
+         ;; defined.
+         (method-combination-arguments-reshuffling
+          ',whole
+          ',lambda-list
+          (generic-function-lambda-list ,generic-function)
+          result)))))
+
+(defmacro with-method-groups ((&rest method-groups) &body body)
+  (let (group-names matchers cleanup)
+    (flet ((parse-qualifier-pattern (pattern)
+             (cond ((eq pattern '*)   't)
+                   ((eq pattern nil)  '(null .method-qualifiers.))
+                   ((symbolp pattern) `(,pattern .method-qualifiers.))
+                   ((listp pattern)
+                    `(do ((pattern ',pattern (cdr pattern))
+                          (qualifiers .method-qualifiers. (cdr qualifiers)))
+                         ((or (eq pattern '*)
+                              (and (null pattern)
+                                   (null qualifiers)))
+                          t)
+                       (unless (and pattern qualifiers
+                                    (or (eq (car pattern) '*)
+                                        (eq (car pattern) (car qualifiers))))
+                         (return nil))))
+                   (t
+                    (error "Invalid method group pattern ~s." pattern)))))
+      (dolist (group method-groups)
+        (destructuring-bind (name pattern &key description
+                                               (order :most-specific-first)
+                                               (required nil))
+            group
+          (declare (ignore description))
+          (push name group-names)
+          (push `(,(parse-qualifier-pattern pattern) (push .method. ,name))
+                matchers)
+          (when required
+            (push `(unless ,name
+                     (error "No methods in required group ~S." ',name))
+                  cleanup))
+          (case order
+            (:most-specific-first
+             (push `(setf ,name (nreverse ,name)) cleanup))
+            (:most-specific-last)
+            (otherwise
+             (push `(when (eq ,order :most-specific-first)
+                      (setf ,name (nreverse ,name)))
+                   cleanup))))))
+    `(let ,group-names
+       (dolist (.method. .methods-list.)
+         (let ((.method-qualifiers. (method-qualifiers .method.)))
+           (declare (ignorable .method-qualifiers.))
+           (cond ,@(nreverse matchers)
+                 ,@(unless (member t matchers :key #'car)
+                     `((t (invalid-method-error
+                           .method.
+                           "Method qualifiers ~s are not allowed." .method-qualifiers.)))))))
+       ,@cleanup
+       ,@body)))
+
+(defun define-complex-method-combination (form)
+  (declare (si::c-local))
+  (flet ((syntax-error ()
+           (error "~S is not a valid DEFINE-METHOD-COMBINATION form." form)))
+    (destructuring-bind (name lambda-list method-groups &rest body
+                         &aux (generic-function '.generic-function.)
+                              (arguments nil))
+        form
+      (let ((x (first body)))
+        (when (and (consp x) (eql (first x) :ARGUMENTS))
+          (setf body (rest body))
+          (setf arguments (rest x))))
+      (let ((x (first body)))
+        (when (and (consp x) (eql (first x) :GENERIC-FUNCTION))
+          (setf body (rest body))
+          (setf generic-function (second x))))
+      (unless (and (symbolp name) (symbolp generic-function))
+        (error "~S is not a valid DEFINE-METHOD-COMBINATION form." form))
+      (multiple-value-setq (decls body documentation)
+        (si::find-declarations body t))
+      `(progn
+         ,@(si::expand-set-documentation name 'method-combination documentation)
+         (install-method-combination ',name
+            (lambda (,generic-function .methods-list. ,@lambda-list)
+              (declare (ignorable ,generic-function))
+              ,@decls
+              (block ,name
+                (effective-method-function
+                 ,(process-define-method-combination-arguments-lambda-list
+                   arguments generic-function
+                   `(with-method-groups ,method-groups ,@body))
+                 t))))))))
+
+(defmacro define-method-combination (name &body body)
+  (if (and body (listp (first body)))
+      (define-complex-method-combination (list* name body))
+      (apply #'define-simple-method-combination name body)))
+
+(defun method-combination-error (format-control &rest args)
+  ;; FIXME! We should emit a more detailed error!
+  (error "Method-combination error:~%~S"
+         (apply #'format nil format-control args)))
+
+(defun invalid-method-error (method format-control &rest args)
+  (error "Invalid method error for ~A~%~S"
+         method
+         (apply #'format nil format-control args)))
+
+(install-method-combination 'standard 'standard-compute-effective-method)
+(progn
+  (define-method-combination progn :identity-with-one-argument t)
+  (define-method-combination and :identity-with-one-argument t)
+  (define-method-combination max :identity-with-one-argument t)
+  (define-method-combination + :identity-with-one-argument t)
+  (define-method-combination nconc :identity-with-one-argument t)
+  (define-method-combination append :identity-with-one-argument nil)
+  (define-method-combination list :identity-with-one-argument nil)
+  (define-method-combination min :identity-with-one-argument t)
+  (define-method-combination or :identity-with-one-argument t))
diff --git a/src/clos/load.lsp.in b/src/clos/load.lsp.in
index 8fabcd346..5ce4b46aa 100644
--- a/src/clos/load.lsp.in
+++ b/src/clos/load.lsp.in
@@ -13,6 +13,7 @@
   "src:clos;kernel.lsp"
   "src:clos;method.lsp"
   "src:clos;combin.lsp"
+  "src:clos;defcombin.lsp"
   "src:clos;std-accessors.lsp"
   "src:clos;defclass.lsp"
   "src:clos;slotvalue.lsp"

From 7db7e0545f936aad955b9f7ab6c4e141799e059d Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= <daniel@turtleware.eu>
Date: Sat, 28 Jan 2023 22:15:54 +0100
Subject: [PATCH 8/8] clos: defcombin: fix regressions

---
 src/clos/defcombin.lsp | 5 +++--
 1 file changed, 3 insertions(+), 2 deletions(-)

diff --git a/src/clos/defcombin.lsp b/src/clos/defcombin.lsp
index fee4c7146..753018d11 100644
--- a/src/clos/defcombin.lsp
+++ b/src/clos/defcombin.lsp
@@ -150,7 +150,7 @@
           (push '&allow-other-keys lambda-list))
         (when mc-aux-vars
           (push '&aux lambda-list)
-          (loop for a on mc-aux-vars by #'cddr
+          (loop for a on (rest mc-aux-vars) by #'cddr
                 do (push `(,(first a) ,(second a)) lambda-list)))
         `(apply #'(lambda ,(nreverse lambda-list)
                     (declare (ignore ,@ignored-vars))
@@ -261,7 +261,8 @@
            (error "~S is not a valid DEFINE-METHOD-COMBINATION form." form)))
     (destructuring-bind (name lambda-list method-groups &rest body
                          &aux (generic-function '.generic-function.)
-                              (arguments nil))
+                              (arguments nil)
+                              decls documentation)
         form
       (let ((x (first body)))
         (when (and (consp x) (eql (first x) :ARGUMENTS))