Changeset 15003

Timestamp:

05/15/17 20:37:19 (6 years ago)

Author:

Mark Evenson

Message:

Fix ENSURE-GENERIC-FUNCTION when removing definition

(Olof-Joachim Frahm)

Merges <​https://github.com/armedbear/abcl/pull/42>.

Location:

trunk/abcl

Files:

• src/org/armedbear/lisp/clos.lisp (modified) (1 diff)
• test/lisp/abcl/mop-tests.lisp (modified) (1 diff)

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

@@ -4314 +4314 @@
 (defmethod shared-initialize :after ((instance standard-generic-function)
                                      slot-names
-                                     &key lambda-list argument-precedence-order
+                                     &key (lambda-list nil lambda-list-p)
+                                       (argument-precedence-order nil a-p-o-p)
                                        (method-combination '(standard))
                                      &allow-other-keys)
-  (let* ((plist (analyze-lambda-list lambda-list))
-         (required-args (getf plist ':required-args)))
-    (setf (std-slot-value instance 'sys::required-args) required-args)
-    (setf (std-slot-value instance 'sys::optional-args)
-          (getf plist :optional-args)) 
-    (setf (std-slot-value instance 'sys::argument-precedence-order)
-          (or argument-precedence-order required-args)))
+  (when lambda-list-p
+    (let* ((plist (analyze-lambda-list lambda-list))
+           (required-args (getf plist ':required-args)))
+      (setf (std-slot-value instance 'sys::required-args) required-args)
+      (setf (std-slot-value instance 'sys::optional-args)
+            (getf plist :optional-args))
+      (setf (std-slot-value instance 'sys::argument-precedence-order)
+            (or (and a-p-o-p argument-precedence-order) required-args))))
   (unless (typep (generic-function-method-combination instance)
                  'method-combination)

trunk/abcl/test/lisp/abcl/mop-tests.lisp

@@ -310 +310 @@
           (return (equal (princ-to-string error) "foo")))))
   t)
+
+;; ensure-generic-function shouldn't kill existing definition
+(deftest ensure-generic-function.1
+    (progn
+      (ensure-generic-function 'mop-test.foo)
+      (not (null (mop:generic-function-argument-precedence-order #'mop-test.foo))))
+  t)