Ticket #239: defgeneric-patch.patch

src/org/armedbear/lisp/clos.lisp

@@ -1605 +1605 @@
 ;;; defgeneric
 
 (defmacro defgeneric (function-name lambda-list
-                                    &rest options-and-method-descriptions)
+                                    &rest options-and-method-descriptions
+                                    &environment env)
   (let ((options ())
         (methods ())
         (declarations ())
-        (documentation nil))
+        (documentation nil)
+        (generic-function-class nil))
     (dolist (item options-and-method-descriptions)
       (case (car item)
         (declare
@@ -1626 +1628 @@
           `(push (defmethod ,function-name ,@(cdr item))
                  (generic-function-initial-methods (fdefinition ',function-name)))
           methods))
+        (:generic-function-class
+         (when generic-function-class
+           (error 'program-error
+                  :format-control "Generic function class was specified twice for generic function ~S."
+                  :format-arguments (list function-name)))
+         (setf generic-function-class (second item))
+         (push item options))
         (t
          (push item options))))
     (when declarations (push (list :declarations declarations) options))
     (setf options (nreverse options)
           methods (nreverse methods))
+    (when generic-function-class
+      (let ((class (find-class generic-function-class t env)))
+        (unless (typep (class-of class) 'funcallable-standard-class)
+          (warn "Supplied generic function class ~S ~_for generic function ~S ~_is not of metaclass FUNCALLABLE-STANDARD-CLASS"
+                generic-function-class function-name))))
     ;;; Since DEFGENERIC currently shares its argument parsing with
     ;;; DEFMETHOD, we perform this check here.
     (when (find '&aux lambda-list)