Changeset 15427
 Timestamp:
 10/20/20 06:45:27 (2 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

trunk/abcl/src/org/armedbear/lisp/clos.lisp
r15085 r15427 2752 2752 (defun computemethodfunction (lambdaexpression) 2753 2753 (let ((lambdalist (allowotherkeys (cadr lambdaexpression))) 2754 (body (cddr lambdaexpression)) 2755 (*callnextmethodp* nil) 2756 (*nextmethodpp* nil)) 2754 (body (cddr lambdaexpression))) 2757 2755 (multiplevaluebind (body declarations) (parsebody body) 2758 2756 (let ((ignorablevars '())) … … 2762 2760 (push var ignorablevars))) 2763 2761 (push `(declare (ignorable ,@ignorablevars)) declarations)) 2764 (walkform body) 2765 (cond ((or *callnextmethodp* *nextmethodpp*) 2766 `(lambda (args nextemfun) 2767 (flet ((callnextmethod (&rest cnmargs) 2768 (if (null nextemfun) 2769 (error "No next method for generic function.") 2770 (funcall nextemfun (or cnmargs args)))) 2771 (nextmethodp () 2772 (not (null nextemfun)))) 2773 (declare (ignorable (function callnextmethod) 2774 (function nextmethodp))) 2775 (apply #'(lambda ,lambdalist ,@declarations ,@body) args)))) 2776 ((null (intersection lambdalist '(&rest &optional &key &allowotherkeys &aux))) 2762 (if (null (intersection lambdalist '(&rest &optional &key &allowotherkeys &aux))) 2777 2763 ;; Required parameters only. 2778 2764 (case (length lambdalist) 2779 2765 (1 2780 2766 `(lambda (args nextemfun) 2781 (declare (ignore nextemfun))2782 2767 (let ((,(%car lambdalist) (%car args))) 2783 2768 (declare (ignorable ,(%car lambdalist))) 2784 ,@declarations ,@body))) 2769 ,@declarations 2770 (flet ((callnextmethod (&rest cnmargs) 2771 (if (null nextemfun) 2772 (error "No next method for generic function.") 2773 (funcall nextemfun (or cnmargs args)))) 2774 (nextmethodp () 2775 (not (null nextemfun)))) 2776 (declare (ignorable (function callnextmethod) 2777 (function nextmethodp))) 2778 ,@body)))) 2779 2785 2780 (2 2786 2781 `(lambda (args nextemfun) 2787 (declare (ignore nextemfun))2788 2782 (let ((,(%car lambdalist) (%car args)) 2789 2783 (,(%cadr lambdalist) (%cadr args))) 2790 2784 (declare (ignorable ,(%car lambdalist) 2791 2785 ,(%cadr lambdalist))) 2792 ,@declarations ,@body))) 2786 ,@declarations 2787 (flet ((callnextmethod (&rest cnmargs) 2788 (if (null nextemfun) 2789 (error "No next method for generic function.") 2790 (funcall nextemfun (or cnmargs args)))) 2791 (nextmethodp () 2792 (not (null nextemfun)))) 2793 (declare (ignorable (function callnextmethod) 2794 (function nextmethodp))) 2795 2796 ,@body)))) 2793 2797 (3 2794 2798 `(lambda (args nextemfun) 2795 (declare (ignore nextemfun))2796 2799 (let ((,(%car lambdalist) (%car args)) 2797 2800 (,(%cadr lambdalist) (%cadr args)) … … 2800 2803 ,(%cadr lambdalist) 2801 2804 ,(%caddr lambdalist))) 2802 ,@declarations ,@body))) 2805 ,@declarations 2806 (flet ((callnextmethod (&rest cnmargs) 2807 (if (null nextemfun) 2808 (error "No next method for generic function.") 2809 (funcall nextemfun (or cnmargs args)))) 2810 (nextmethodp () 2811 (not (null nextemfun)))) 2812 (declare (ignorable (function callnextmethod) 2813 (function nextmethodp))) 2814 ,@body)))) 2803 2815 (t 2804 2816 `(lambda (args nextemfun) 2805 (declare (ignore nextemfun)) 2806 (apply #'(lambda ,lambdalist ,@declarations ,@body) args))))) 2807 (t 2817 (apply #'(lambda ,lambdalist 2818 ,@declarations 2819 (flet ((callnextmethod (&rest cnmargs) 2820 (if (null nextemfun) 2821 (error "No next method for generic function.") 2822 (funcall nextemfun (or cnmargs args)))) 2823 (nextmethodp () 2824 (not (null nextemfun)))) 2825 (declare (ignorable (function callnextmethod) 2826 (function nextmethodp))) 2827 ,@body)) 2828 args)))) 2808 2829 `(lambda (args nextemfun) 2809 (declare (ignore nextemfun)) 2810 (apply #'(lambda ,lambdalist ,@declarations ,@body) args))))))) 2830 (apply #'(lambda ,lambdalist 2831 ,@declarations 2832 (flet ((callnextmethod (&rest cnmargs) 2833 (if (null nextemfun) 2834 (error "No next method for generic function.") 2835 (funcall nextemfun (or cnmargs args)))) 2836 (nextmethodp () 2837 (not (null nextemfun)))) 2838 (declare (ignorable (function callnextmethod) 2839 (function nextmethodp))) 2840 2841 ,@body)) 2842 args)))))) 2811 2843 2812 2844 (defun computemethodfastfunction (lambdaexpression) … … 2819 2851 (*nextmethodpp* nil)) 2820 2852 (multiplevaluebind (body declarations) (parsebody body) 2853 ;;; N.b. The WALKFORM check is bogus for "hidden" 2854 ;;; macroizations of CALLNEXTMETHOD and NEXTMETHODP but 2855 ;;; the presence of FASTFUNCTION slots in our CLOS is 2856 ;;; currently necessary to bootstrap CLOS in a way I didn't 2857 ;;; manage to easily untangle. 2821 2858 (walkform body) 2822 2859 (when (or *callnextmethodp* *nextmethodpp*) 2823 2860 (returnfrom computemethodfastfunction nil)) 2824 (let ((decls `(declare (ignorable ,@lambdalist)))) 2825 (setf lambdaexpression 2826 (list* (car lambdaexpression) 2827 (cadr lambdaexpression) 2828 decls 2829 (cddr lambdaexpression)))) 2830 (case (length lambdalist) 2831 (1 2832 ;; `(lambda (args nextemfun) 2833 ;; (let ((,(%car lambdalist) (%car args))) 2834 ;; (declare (ignorable ,(%car lambdalist))) 2835 ;; ,@declarations ,@body))) 2836 lambdaexpression) 2837 (2 2838 ;; `(lambda (args nextemfun) 2839 ;; (let ((,(%car lambdalist) (%car args)) 2840 ;; (,(%cadr lambdalist) (%cadr args))) 2841 ;; (declare (ignorable ,(%car lambdalist) 2842 ;; ,(%cadr lambdalist))) 2843 ;; ,@declarations ,@body))) 2844 lambdaexpression) 2845 ;; (3 2846 ;; `(lambda (args nextemfun) 2847 ;; (let ((,(%car lambdalist) (%car args)) 2848 ;; (,(%cadr lambdalist) (%cadr args)) 2849 ;; (,(%caddr lambdalist) (%caddr args))) 2850 ;; (declare (ignorable ,(%car lambdalist) 2851 ;; ,(%cadr lambdalist) 2852 ;; ,(%caddr lambdalist))) 2853 ;; ,@declarations ,@body))) 2854 (t 2855 nil)))))) 2861 (let ((declaration `(declare (ignorable ,@lambdalist)))) 2862 ;;; 20201019 refactored this expression from previous code 2863 ;;; that was only declaring a fast function for one or two 2864 ;;; element values of lambalist 2865 (if (< 0 (length lambdalist) 3) 2866 `(lambda ,(cadr lambdaexpression) 2867 ,declaration 2868 (flet ((callnextmethod (&rest args) 2869 (declare (ignore args)) 2870 (error "No next method for generic function")) 2871 (nextmethodp () nil)) 2872 (declare (ignorable (function callnextmethod) 2873 (function nextmethodp))) 2874 ,@body)) 2875 nil)))))) 2876 2856 2877 2857 2878 (declaim (notinline makemethodlambda)) … … 2902 2923 :qualifiers ',qualifiers 2903 2924 :specializers (canonicalizespecializers ,specializersform) 2904 ,@( ifdocumentation `(:documentation ,documentation))2925 ,@(when documentation `(:documentation ,documentation)) 2905 2926 :function (function ,methodfunction) 2906 ,@( iffastfunction `(:fastfunction (function ,fastfunction)))2927 ,@(when fastfunction `(:fastfunction (function ,fastfunction))) 2907 2928 ))))) 2908 2929
Note: See TracChangeset
for help on using the changeset viewer.