Ticket #479: reverse-clos-flet.patch

File reverse-clos-flet.patch, 8.6 KB (added by Mark Evenson, 4 years ago)

Reverse CLOS work

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

    # HG changeset patch
# Parent  bda6cf14d2c6cb9297564f46420200028c8506e3

diff -r bda6cf14d2c6 -r a0244c4841f5 src/org/armedbear/lisp/clos.lisp
    a b  
    27392739(defvar *call-next-method-p*)
    27402740(defvar *next-method-p-p*)
    27412741
    2742 ;;; FIXME this doesn't work for macroized references
    27432742(defun walk-form (form)
    27442743  (cond ((atom form)
    27452744         (cond ((eq form 'call-next-method)
    … …  
    27502749         (walk-form (%car form))
    27512750         (walk-form (%cdr form)))))
    27522751
    2753 (defmacro flet-call-next-method (args next-emfun &body body)
    2754   `(flet ((call-next-method (&rest cnm-args)
    2755             (if (null ,next-emfun)
    2756                 (error "No next method for generic function.")
    2757                 (funcall ,next-emfun (or cnm-args ,args))))
    2758           (next-method-p ()
    2759             (not (null ,next-emfun))))
    2760      (declare (ignorable (function call-next-method)
    2761                          (function next-method-p)))
    2762      ,@body))
    2763 
    27642752(defun compute-method-function (lambda-expression)
    27652753  (let ((lambda-list (allow-other-keys (cadr lambda-expression)))
    2766         (body (cddr lambda-expression)))
     2754        (body (cddr lambda-expression))
     2755        (*call-next-method-p* nil)
     2756        (*next-method-p-p* nil))
    27672757    (multiple-value-bind (body declarations) (parse-body body)
    27682758      (let ((ignorable-vars '()))
    27692759        (dolist (var lambda-list)
    … …  
    27712761              (return)
    27722762              (push var ignorable-vars)))
    27732763        (push `(declare (ignorable ,@ignorable-vars)) declarations))
    2774       (if (null (intersection lambda-list '(&rest &optional &key &allow-other-keys &aux)))
     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)))
    27752777             ;; Required parameters only.
    27762778             (case (length lambda-list)
    27772779               (1
    27782780                `(lambda (args next-emfun)
     2781                   (declare (ignore next-emfun))
    27792782                   (let ((,(%car lambda-list) (%car args)))
    27802783                     (declare (ignorable ,(%car lambda-list)))
    2781                      ,@declarations
    2782                      (flet-call-next-method args next-emfun
    2783                        ,@body))))
     2784                     ,@declarations ,@body)))
    27842785               (2
    27852786                `(lambda (args next-emfun)
     2787                   (declare (ignore next-emfun))
    27862788                   (let ((,(%car lambda-list) (%car args))
    27872789                         (,(%cadr lambda-list) (%cadr args)))
    27882790                     (declare (ignorable ,(%car lambda-list)
    27892791                                         ,(%cadr lambda-list)))
    2790                      ,@declarations
    2791                      (flet-call-next-method args next-emfun
    2792                        ,@body))))
     2792                     ,@declarations ,@body)))
    27932793               (3
    27942794                `(lambda (args next-emfun)
     2795                   (declare (ignore next-emfun))
    27952796                   (let ((,(%car lambda-list) (%car args))
    27962797                         (,(%cadr lambda-list) (%cadr args))
    27972798                         (,(%caddr lambda-list) (%caddr args)))
    27982799                     (declare (ignorable ,(%car lambda-list)
    27992800                                         ,(%cadr lambda-list)
    28002801                                         ,(%caddr lambda-list)))
    2801                      ,@declarations
    2802                      (flet-call-next-method args next-emfun
    2803                        ,@body))))
     2802                     ,@declarations ,@body)))
    28042803               (t
    28052804                `(lambda (args next-emfun)
    2806                    (apply #'(lambda ,lambda-list
    2807                               ,@declarations
    2808                               (flet-call-next-method args next-emfun
    2809                                 ,@body))
    2810                           args))))
     2805                   (declare (ignore next-emfun))
     2806                   (apply #'(lambda ,lambda-list ,@declarations ,@body) args)))))
     2807            (t
    28112808             `(lambda (args next-emfun)
    2812                 (apply #'(lambda ,lambda-list
    2813                            ,@declarations
    2814                            (flet-call-next-method args next-emfun
    2815                              ,@body))
    2816                        args))))))
     2809                (declare (ignore next-emfun))
     2810                (apply #'(lambda ,lambda-list ,@declarations ,@body) args)))))))
    28172811
    28182812(defun compute-method-fast-function (lambda-expression)
    28192813  (let ((lambda-list (allow-other-keys (cadr lambda-expression))))
    … …  
    28242818          (*call-next-method-p* nil)
    28252819          (*next-method-p-p* nil))
    28262820      (multiple-value-bind (body declarations) (parse-body body)
    2827         ;;; N.b. The WALK-FORM check is bogus for "hidden"
    2828         ;;; macroizations of CALL-NEXT-METHOD and NEXT-METHOD-P but
    2829         ;;; the presence of FAST-FUNCTION slots in our CLOS is
    2830         ;;; currently necessary to bootstrap CLOS in a way I didn't
    2831         ;;; manage to easily untangle.
    28322821        (walk-form body)
    28332822        (when (or *call-next-method-p* *next-method-p-p*)
    28342823          (return-from compute-method-fast-function nil))
    2835         (let ((declaration `(declare (ignorable ,@lambda-list))))
    2836           ;;; 2020-10-19 refactored this expression from previous code
    2837           ;;; that was only declaring a fast function for one or two
    2838           ;;; element values of lamba-list
    2839           (if (< 0 (length lambda-list) 3)
    2840             `(lambda ,(cadr lambda-expression)
    2841                ,declaration
    2842                (flet ((call-next-method (&rest args)
    2843                         (declare (ignore args))
    2844                         (error "No next method for generic function"))
    2845                       (next-method-p () nil))
    2846                  (declare (ignorable (function call-next-method)
    2847                                      (function next-method-p)))
    2848                  ,@body))
    2849             nil))))))
    2850        
     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))))))
    28512856
    28522857(declaim (notinline make-method-lambda))
    28532858(defun make-method-lambda (generic-function method lambda-expression env)
    … …  
    28962901                        :lambda-list ',lambda-list
    28972902                        :qualifiers ',qualifiers
    28982903                        :specializers (canonicalize-specializers ,specializers-form)
    2899                         ,@(when documentation `(:documentation ,documentation))
     2904                        ,@(if documentation `(:documentation ,documentation))
    29002905                        :function (function ,method-function)
    2901                         ,@(when fast-function `(:fast-function (function ,fast-function)))
     2906                        ,@(if fast-function `(:fast-function (function ,fast-function)))
    29022907                        )))))
    29032908
    29042909;;; Reader and writer methods