Changeset 15513 for trunk/abcl/src/org/armedbear/lisp/clos.lisp

Timestamp:

08/14/21 06:21:39 (2 years ago)

Author:

Mark Evenson

Message:

Proposal fix to https://abcl.org/trac/ticket/485

File:

• trunk/abcl/src/org/armedbear/lisp/clos.lisp (modified) (14 diffs)

trunk/abcl/src/org/armedbear/lisp/clos.lisp

@@ -2179 +2179 @@
 (declaim (ftype (function * method) ensure-method))
 (defun ensure-method (name &rest all-keys)
-  (let ((method-lambda-list (getf all-keys :lambda-list))
-        (gf (find-generic-function name nil)))
+  (let* ((method-lambda-list (getf all-keys :lambda-list))
+         (gf (find-generic-function name nil))
+         (gf-lambda-list (copy-tree method-lambda-list)))
     (when (or (eq gf *gf-initialize-instance*)
               (eq gf *gf-allocate-instance*)
@@ -2190 +2191 @@
       (clrhash *make-instance-initargs-cache*)
       (clrhash *reinitialize-instance-initargs-cache*))
+
+    (let ((plist (analyze-lambda-list method-lambda-list)))
+      (when (getf plist :keywords)
+        ;; remove all keywords arguments for the generic function definition
+        (setf gf-lambda-list
+              (append (subseq gf-lambda-list 0 (position '&key gf-lambda-list))
+                      '(&key) (if (getf plist :auxiliary-args)
+                                  (subseq gf-lambda-list (position '&aux gf-lambda-list)))))))
     (if gf
   (restart-case
@@ -2196 +2205 @@
     (unbind-and-try-again () :report (lambda(s) (format s "Undefine generic function #'~a and continue" name))
       (fmakunbound name)
-      (setf gf (ensure-generic-function name :lambda-list method-lambda-list))))
-        (setf gf (ensure-generic-function name :lambda-list method-lambda-list)))
+      (setf gf (ensure-generic-function name :lambda-list gf-lambda-list))))
+        (setf gf (ensure-generic-function name :lambda-list gf-lambda-list)))
     (let ((method
            (if (eq (generic-function-method-class gf) +the-standard-method-class+)
@@ -2348 +2357 @@
                                          '(&rest &optional &key
                                            &allow-other-keys))))
-              (no-aux (null (some 
-                             (lambda (method) 
+              (no-aux (null (some
+                             (lambda (method)
                                (find '&aux (std-slot-value method 'sys::lambda-list)))
                              methods))))
@@ -2484 +2493 @@
     (let ((specializer (car specializers)))
       (if (typep specializer 'eql-specializer)
-          (if (eql (class-of (eql-specializer-object specializer)) 
+          (if (eql (class-of (eql-specializer-object specializer))
                    (car classes))
               (setf knownp nil)
@@ -2751 +2760 @@
          (walk-form (%cdr form)))))
 
-(defmacro flet-call-next-method (args next-emfun &body body) 
+(defmacro flet-call-next-method (args next-emfun &body body)
   `(flet ((call-next-method (&rest cnm-args)
             (if (null ,next-emfun)
@@ -2789 +2798 @@
                                          ,(%cadr lambda-list)))
                      ,@declarations
-                     (flet-call-next-method args next-emfun 
+                     (flet-call-next-method args next-emfun
                        ,@body))))
                (3
@@ -2800 +2809 @@
                                          ,(%caddr lambda-list)))
                      ,@declarations
-                     (flet-call-next-method args next-emfun 
+                     (flet-call-next-method args next-emfun
                        ,@body))))
                (t
@@ -2806 +2815 @@
                    (apply #'(lambda ,lambda-list
                               ,@declarations
-                              (flet-call-next-method args next-emfun 
+                              (flet-call-next-method args next-emfun
                                 ,@body))
                           args))))
@@ -2848 +2857 @@
                  ,@body))
             nil))))))
-        
+
 
 (declaim (notinline make-method-lambda))
@@ -3039 +3048 @@
          when (eq (car method-form) :method)
         collect
-        (multiple-value-bind (function-name qualifiers lambda-list specializers documentation declarations body) 
+        (multiple-value-bind (function-name qualifiers lambda-list specializers documentation declarations body)
       (mop::parse-defmethod `(,function-name ,@(rest method-form)))
           `(sys::record-source-information-for-type ',function-name '(:method ,function-name ,qualifiers ,specializers))))
@@ -3183 +3192 @@
 
 (defmethod ensure-class-using-class :before (class name  &key direct-slots
-                                             direct-default-initargs 
+                                             direct-default-initargs
                                              &allow-other-keys)
   (check-duplicate-slots direct-slots)
@@ -3323 +3332 @@
 
 ;;; Slot access
-;;; 
+;;;
 ;;; See AMOP pg. 156ff. for an overview.
-;;; 
+;;;
 ;;; AMOP specifies these generic functions to dispatch on slot objects
 ;;; (with the exception of slot-exists-p-using-class), although its
@@ -4586 +4595 @@
 
 (provide "CLOS")
-