Changeset 15427


Ignore:
Timestamp:
10/20/20 06:45:27 (3 years ago)
Author:
Mark Evenson
Message:

Always define CALL-NEXT-METHOD and NEXT-METHOD-P as local functions

This doesn't seem to entirely work. Need a better test?

Attempts to address <​https://github.com/armedbear/abcl/issues/301>

File:
1 edited

Legend:

Unmodified
Added
Removed

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

    r15085 r15427  
    27522752(defun compute-method-function (lambda-expression)
    27532753  (let ((lambda-list (allow-other-keys (cadr lambda-expression)))
    2754         (body (cddr lambda-expression))
    2755         (*call-next-method-p* nil)
    2756         (*next-method-p-p* nil))
     2754        (body (cddr lambda-expression)))
    27572755    (multiple-value-bind (body declarations) (parse-body body)
    27582756      (let ((ignorable-vars '()))
    … …  
    27622760              (push var ignorable-vars)))
    27632761        (push `(declare (ignorable ,@ignorable-vars)) declarations))
    2764       (walk-form body)
    2765       (cond ((or *call-next-method-p* *next-method-p-p*)
    2766              `(lambda (args next-emfun)
    2767                 (flet ((call-next-method (&rest cnm-args)
    2768                          (if (null next-emfun)
    2769                              (error "No next method for generic function.")
    2770                              (funcall next-emfun (or cnm-args args))))
    2771                        (next-method-p ()
    2772                          (not (null next-emfun))))
    2773                   (declare (ignorable (function call-next-method)
    2774                                       (function next-method-p)))
    2775                   (apply #'(lambda ,lambda-list ,@declarations ,@body) args))))
    2776             ((null (intersection lambda-list '(&rest &optional &key &allow-other-keys &aux)))
     2762      (if (null (intersection lambda-list '(&rest &optional &key &allow-other-keys &aux)))
    27772763             ;; Required parameters only.
    27782764             (case (length lambda-list)
    27792765               (1
    27802766                `(lambda (args next-emfun)
    2781                    (declare (ignore next-emfun))
    27822767                   (let ((,(%car lambda-list) (%car args)))
    27832768                     (declare (ignorable ,(%car lambda-list)))
    2784                      ,@declarations ,@body)))
     2769                     ,@declarations
     2770                     (flet ((call-next-method (&rest cnm-args)
     2771                              (if (null next-emfun)
     2772                                  (error "No next method for generic function.")
     2773                                  (funcall next-emfun (or cnm-args args))))
     2774                            (next-method-p ()
     2775                              (not (null next-emfun))))
     2776                       (declare (ignorable (function call-next-method)
     2777                                           (function next-method-p)))
     2778                       ,@body))))
     2779                     
    27852780               (2
    27862781                `(lambda (args next-emfun)
    2787                    (declare (ignore next-emfun))
    27882782                   (let ((,(%car lambda-list) (%car args))
    27892783                         (,(%cadr lambda-list) (%cadr args)))
    27902784                     (declare (ignorable ,(%car lambda-list)
    27912785                                         ,(%cadr lambda-list)))
    2792                      ,@declarations ,@body)))
     2786                     ,@declarations
     2787                     (flet ((call-next-method (&rest cnm-args)
     2788                              (if (null next-emfun)
     2789                                  (error "No next method for generic function.")
     2790                                  (funcall next-emfun (or cnm-args args))))
     2791                            (next-method-p ()
     2792                              (not (null next-emfun))))
     2793                       (declare (ignorable (function call-next-method)
     2794                                           (function next-method-p)))
     2795
     2796                       ,@body))))
    27932797               (3
    27942798                `(lambda (args next-emfun)
    2795                    (declare (ignore next-emfun))
    27962799                   (let ((,(%car lambda-list) (%car args))
    27972800                         (,(%cadr lambda-list) (%cadr args))
    … …  
    28002803                                         ,(%cadr lambda-list)
    28012804                                         ,(%caddr lambda-list)))
    2802                      ,@declarations ,@body)))
     2805                     ,@declarations
     2806                     (flet ((call-next-method (&rest cnm-args)
     2807                              (if (null next-emfun)
     2808                                  (error "No next method for generic function.")
     2809                                  (funcall next-emfun (or cnm-args args))))
     2810                            (next-method-p ()
     2811                              (not (null next-emfun))))
     2812                       (declare (ignorable (function call-next-method)
     2813                                           (function next-method-p)))
     2814                       ,@body))))
    28032815               (t
    28042816                `(lambda (args next-emfun)
    2805                    (declare (ignore next-emfun))
    2806                    (apply #'(lambda ,lambda-list ,@declarations ,@body) args)))))
    2807             (t
     2817                   (apply #'(lambda ,lambda-list
     2818                              ,@declarations
     2819                              (flet ((call-next-method (&rest cnm-args)
     2820                                       (if (null next-emfun)
     2821                                           (error "No next method for generic function.")
     2822                                           (funcall next-emfun (or cnm-args args))))
     2823                                     (next-method-p ()
     2824                                       (not (null next-emfun))))
     2825                                (declare (ignorable (function call-next-method)
     2826                                                    (function next-method-p)))
     2827                                ,@body))
     2828                          args))))
    28082829             `(lambda (args next-emfun)
    2809                 (declare (ignore next-emfun))
    2810                 (apply #'(lambda ,lambda-list ,@declarations ,@body) args)))))))
     2830                (apply #'(lambda ,lambda-list
     2831                           ,@declarations
     2832                           (flet ((call-next-method (&rest cnm-args)
     2833                                    (if (null next-emfun)
     2834                                        (error "No next method for generic function.")
     2835                                        (funcall next-emfun (or cnm-args args))))
     2836                                  (next-method-p ()
     2837                                    (not (null next-emfun))))
     2838                             (declare (ignorable (function call-next-method)
     2839                                                 (function next-method-p)))
     2840                             
     2841                             ,@body))
     2842                       args))))))
    28112843
    28122844(defun compute-method-fast-function (lambda-expression)
    … …  
    28192851          (*next-method-p-p* nil))
    28202852      (multiple-value-bind (body declarations) (parse-body body)
     2853        ;;; N.b. The WALK-FORM check is bogus for "hidden"
     2854        ;;; macroizations of CALL-NEXT-METHOD and NEXT-METHOD-P but
     2855        ;;; the presence of FAST-FUNCTION slots in our CLOS is
     2856        ;;; currently necessary to bootstrap CLOS in a way I didn't
     2857        ;;; manage to easily untangle.
    28212858        (walk-form body)
    28222859        (when (or *call-next-method-p* *next-method-p-p*)
    28232860          (return-from compute-method-fast-function nil))
    2824         (let ((decls `(declare (ignorable ,@lambda-list))))
    2825           (setf lambda-expression
    2826                 (list* (car lambda-expression)
    2827                        (cadr lambda-expression)
    2828                        decls
    2829                        (cddr lambda-expression))))
    2830         (case (length lambda-list)
    2831           (1
    2832 ;;            `(lambda (args next-emfun)
    2833 ;;               (let ((,(%car lambda-list) (%car args)))
    2834 ;;                 (declare (ignorable ,(%car lambda-list)))
    2835 ;;                 ,@declarations ,@body)))
    2836            lambda-expression)
    2837           (2
    2838 ;;            `(lambda (args next-emfun)
    2839 ;;               (let ((,(%car lambda-list) (%car args))
    2840 ;;                     (,(%cadr lambda-list) (%cadr args)))
    2841 ;;                 (declare (ignorable ,(%car lambda-list)
    2842 ;;                                     ,(%cadr lambda-list)))
    2843 ;;                 ,@declarations ,@body)))
    2844            lambda-expression)
    2845 ;;           (3
    2846 ;;            `(lambda (args next-emfun)
    2847 ;;               (let ((,(%car lambda-list) (%car args))
    2848 ;;                     (,(%cadr lambda-list) (%cadr args))
    2849 ;;                     (,(%caddr lambda-list) (%caddr args)))
    2850 ;;                 (declare (ignorable ,(%car lambda-list)
    2851 ;;                                     ,(%cadr lambda-list)
    2852 ;;                                     ,(%caddr lambda-list)))
    2853 ;;                 ,@declarations ,@body)))
    2854           (t
    2855            nil))))))
     2861        (let ((declaration `(declare (ignorable ,@lambda-list))))
     2862          ;;; 2020-10-19 refactored this expression from previous code
     2863          ;;; that was only declaring a fast function for one or two
     2864          ;;; element values of lamba-list
     2865          (if (< 0 (length lambda-list) 3)
     2866            `(lambda ,(cadr lambda-expression)
     2867               ,declaration
     2868               (flet ((call-next-method (&rest args)
     2869                        (declare (ignore args))
     2870                        (error "No next method for generic function"))
     2871                      (next-method-p () nil))
     2872                 (declare (ignorable (function call-next-method)
     2873                                    (function next-method-p)))
     2874                 ,@body))
     2875            nil))))))
     2876       
    28562877
    28572878(declaim (notinline make-method-lambda))
    … …  
    29022923                        :qualifiers ',qualifiers
    29032924                        :specializers (canonicalize-specializers ,specializers-form)
    2904                         ,@(if documentation `(:documentation ,documentation))
     2925                        ,@(when documentation `(:documentation ,documentation))
    29052926                        :function (function ,method-function)
    2906                         ,@(if fast-function `(:fast-function (function ,fast-function)))
     2927                        ,@(when fast-function `(:fast-function (function ,fast-function)))
    29072928                        )))))
    29082929
Note: See TracChangeset for help on using the changeset viewer.