# HG changeset patch # Parent bda6cf14d2c6cb9297564f46420200028c8506e3 diff -r bda6cf14d2c6 -r a0244c4841f5 src/org/armedbear/lisp/clos.lisp --- a/src/org/armedbear/lisp/clos.lisp Mon Nov 30 08:22:38 2020 +0000 +++ b/src/org/armedbear/lisp/clos.lisp Sat Dec 19 15:25:32 2020 +0100 @@ -2739,7 +2739,6 @@ (defvar *call-next-method-p*) (defvar *next-method-p-p*) -;;; FIXME this doesn't work for macroized references (defun walk-form (form) (cond ((atom form) (cond ((eq form 'call-next-method) @@ -2750,20 +2749,11 @@ (walk-form (%car form)) (walk-form (%cdr form))))) -(defmacro flet-call-next-method (args next-emfun &body body) - `(flet ((call-next-method (&rest cnm-args) - (if (null ,next-emfun) - (error "No next method for generic function.") - (funcall ,next-emfun (or cnm-args ,args)))) - (next-method-p () - (not (null ,next-emfun)))) - (declare (ignorable (function call-next-method) - (function next-method-p))) - ,@body)) - (defun compute-method-function (lambda-expression) (let ((lambda-list (allow-other-keys (cadr lambda-expression))) - (body (cddr lambda-expression))) + (body (cddr lambda-expression)) + (*call-next-method-p* nil) + (*next-method-p-p* nil)) (multiple-value-bind (body declarations) (parse-body body) (let ((ignorable-vars '())) (dolist (var lambda-list) @@ -2771,49 +2761,53 @@ (return) (push var ignorable-vars))) (push `(declare (ignorable ,@ignorable-vars)) declarations)) - (if (null (intersection lambda-list '(&rest &optional &key &allow-other-keys &aux))) + (walk-form body) + (cond ((or *call-next-method-p* *next-method-p-p*) + `(lambda (args next-emfun) + (flet ((call-next-method (&rest cnm-args) + (if (null next-emfun) + (error "No next method for generic function.") + (funcall next-emfun (or cnm-args args)))) + (next-method-p () + (not (null next-emfun)))) + (declare (ignorable (function call-next-method) + (function next-method-p))) + (apply #'(lambda ,lambda-list ,@declarations ,@body) args)))) + ((null (intersection lambda-list '(&rest &optional &key &allow-other-keys &aux))) ;; Required parameters only. (case (length lambda-list) (1 `(lambda (args next-emfun) + (declare (ignore next-emfun)) (let ((,(%car lambda-list) (%car args))) (declare (ignorable ,(%car lambda-list))) - ,@declarations - (flet-call-next-method args next-emfun - ,@body)))) + ,@declarations ,@body))) (2 `(lambda (args next-emfun) + (declare (ignore next-emfun)) (let ((,(%car lambda-list) (%car args)) (,(%cadr lambda-list) (%cadr args))) (declare (ignorable ,(%car lambda-list) ,(%cadr lambda-list))) - ,@declarations - (flet-call-next-method args next-emfun - ,@body)))) + ,@declarations ,@body))) (3 `(lambda (args next-emfun) + (declare (ignore next-emfun)) (let ((,(%car lambda-list) (%car args)) (,(%cadr lambda-list) (%cadr args)) (,(%caddr lambda-list) (%caddr args))) (declare (ignorable ,(%car lambda-list) ,(%cadr lambda-list) ,(%caddr lambda-list))) - ,@declarations - (flet-call-next-method args next-emfun - ,@body)))) + ,@declarations ,@body))) (t `(lambda (args next-emfun) - (apply #'(lambda ,lambda-list - ,@declarations - (flet-call-next-method args next-emfun - ,@body)) - args)))) + (declare (ignore next-emfun)) + (apply #'(lambda ,lambda-list ,@declarations ,@body) args))))) + (t `(lambda (args next-emfun) - (apply #'(lambda ,lambda-list - ,@declarations - (flet-call-next-method args next-emfun - ,@body)) - args)))))) + (declare (ignore next-emfun)) + (apply #'(lambda ,lambda-list ,@declarations ,@body) args))))))) (defun compute-method-fast-function (lambda-expression) (let ((lambda-list (allow-other-keys (cadr lambda-expression)))) @@ -2824,30 +2818,41 @@ (*call-next-method-p* nil) (*next-method-p-p* nil)) (multiple-value-bind (body declarations) (parse-body body) - ;;; N.b. The WALK-FORM check is bogus for "hidden" - ;;; macroizations of CALL-NEXT-METHOD and NEXT-METHOD-P but - ;;; the presence of FAST-FUNCTION slots in our CLOS is - ;;; currently necessary to bootstrap CLOS in a way I didn't - ;;; manage to easily untangle. (walk-form body) (when (or *call-next-method-p* *next-method-p-p*) (return-from compute-method-fast-function nil)) - (let ((declaration `(declare (ignorable ,@lambda-list)))) - ;;; 2020-10-19 refactored this expression from previous code - ;;; that was only declaring a fast function for one or two - ;;; element values of lamba-list - (if (< 0 (length lambda-list) 3) - `(lambda ,(cadr lambda-expression) - ,declaration - (flet ((call-next-method (&rest args) - (declare (ignore args)) - (error "No next method for generic function")) - (next-method-p () nil)) - (declare (ignorable (function call-next-method) - (function next-method-p))) - ,@body)) - nil)))))) - + (let ((decls `(declare (ignorable ,@lambda-list)))) + (setf lambda-expression + (list* (car lambda-expression) + (cadr lambda-expression) + decls + (cddr lambda-expression)))) + (case (length lambda-list) + (1 +;; `(lambda (args next-emfun) +;; (let ((,(%car lambda-list) (%car args))) +;; (declare (ignorable ,(%car lambda-list))) +;; ,@declarations ,@body))) + lambda-expression) + (2 +;; `(lambda (args next-emfun) +;; (let ((,(%car lambda-list) (%car args)) +;; (,(%cadr lambda-list) (%cadr args))) +;; (declare (ignorable ,(%car lambda-list) +;; ,(%cadr lambda-list))) +;; ,@declarations ,@body))) + lambda-expression) +;; (3 +;; `(lambda (args next-emfun) +;; (let ((,(%car lambda-list) (%car args)) +;; (,(%cadr lambda-list) (%cadr args)) +;; (,(%caddr lambda-list) (%caddr args))) +;; (declare (ignorable ,(%car lambda-list) +;; ,(%cadr lambda-list) +;; ,(%caddr lambda-list))) +;; ,@declarations ,@body))) + (t + nil)))))) (declaim (notinline make-method-lambda)) (defun make-method-lambda (generic-function method lambda-expression env) @@ -2896,9 +2901,9 @@ :lambda-list ',lambda-list :qualifiers ',qualifiers :specializers (canonicalize-specializers ,specializers-form) - ,@(when documentation `(:documentation ,documentation)) + ,@(if documentation `(:documentation ,documentation)) :function (function ,method-function) - ,@(when fast-function `(:fast-function (function ,fast-function))) + ,@(if fast-function `(:fast-function (function ,fast-function))) ))))) ;;; Reader and writer methods