From 665eea819b61f87f401ff0a9ff82f6cbdcc5c636 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Mon, 14 Aug 2006 09:21:57 +0000 Subject: [PATCH] 0.9.15.29: Before I forget: since working on a %method-function branch to fix the :function / :fast-function initarg to methods has uncovered some related-but-fixable bugs, do an early merge to clear them up: ... the special declaration for pv-table-symbol was in the wrong place, so spurious warnings were generated; ... make-emf-from-method can return a method-call (not a fast-method-call), so fix cases where both the caller and callee of a MAKE-METHOD form were non-standard. ... remove an ancient workaround for a KCL bug related to pv-table-symbol. --- NEWS | 3 +++ src/compiler/ir1tran-lambda.lisp | 4 +-- src/pcl/boot.lisp | 33 ++++++++---------------- src/pcl/combin.lisp | 19 +++++++++----- src/pcl/vector.lisp | 21 +++++++-------- tests/compiler.pure.lisp | 4 +-- tests/mop-23.impure.lisp | 55 ++++++++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 8 files changed, 97 insertions(+), 44 deletions(-) create mode 100644 tests/mop-23.impure.lisp diff --git a/NEWS b/NEWS index 136bb2d65..cc52f14fd 100644 --- a/NEWS +++ b/NEWS @@ -17,6 +17,9 @@ changes in sbcl-0.9.16 relative to sbcl-0.9.15: * fixed bug #339(c): if there are applicable methods not part of any long-form method-combination group, call INVALID-METHOD-ERROR. (reported by Bruno Haible) + * bug fix: extensions of MAKE-METHOD-LAMBDA which wrap the + system-provided lambda expression no longer cause warnings about + unbound #:|pv-table| symbols. * bug fix: improved the handling of type declarations and the detection of violations for keyword arguments with non-constant defaults. diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp index 9841e8ebf..2a92b9894 100644 --- a/src/compiler/ir1tran-lambda.lisp +++ b/src/compiler/ir1tran-lambda.lisp @@ -955,7 +955,7 @@ ;;; current compilation policy. Note that FUN may be a ;;; LAMBDA-WITH-LEXENV, so we may have to augment the environment to ;;; reflect the state at the definition site. -(defun ir1-convert-inline-lambda (fun +(defun ir1-convert-inline-lambda (fun &key (source-name '.anonymous.) debug-name @@ -1044,7 +1044,7 @@ (unless (eq inlinep :inline) (setf (defined-fun-inline-expansion var) nil)) (let ((fun (ir1-convert-inline-lambda expansion - :source-name name + :source-name name ;; prevent instrumentation of ;; known function expansions :system-lambda (and info t)))) diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 8758d017c..672e483a0 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -388,16 +388,14 @@ bootstrapping. (if proto-method (class-name (class-of proto-method)) 'standard-method) - initargs-form - (getf (getf initargs :plist) - :pv-table-symbol))))))) + initargs-form)))))) (defun interned-symbol-p (x) (and (symbolp x) (symbol-package x))) -(defun make-defmethod-form (name qualifiers specializers - unspecialized-lambda-list method-class-name - initargs-form &optional pv-table-symbol) +(defun make-defmethod-form + (name qualifiers specializers unspecialized-lambda-list + method-class-name initargs-form) (let (fn fn-lambda) (if (and (interned-symbol-p (fun-name-block-name name)) @@ -436,8 +434,7 @@ bootstrapping. unspecialized-lambda-list method-class-name `(list* ,(cadr initargs-form) #',mname - ,@(cdddr initargs-form)) - pv-table-symbol))) + ,@(cdddr initargs-form))))) (make-defmethod-form-internal name qualifiers `(list ,@(mapcar (lambda (specializer) @@ -448,12 +445,11 @@ bootstrapping. specializers)) unspecialized-lambda-list method-class-name - initargs-form - pv-table-symbol)))) + initargs-form)))) (defun make-defmethod-form-internal (name qualifiers specializers-form unspecialized-lambda-list - method-class-name initargs-form &optional pv-table-symbol) + method-class-name initargs-form) `(load-defmethod ',method-class-name ',name @@ -461,11 +457,6 @@ bootstrapping. ,specializers-form ',unspecialized-lambda-list ,initargs-form - ;; Paper over a bug in KCL by passing the cache-symbol here in - ;; addition to in the list. FIXME: We should no longer need to do - ;; this, since the CLOS code is now SBCL-specific, and doesn't - ;; need to be ported to every buggy compiler in existence. - ',pv-table-symbol (sb-c:source-location))) (defmacro make-method-function (method-lambda &environment env) @@ -1394,21 +1385,17 @@ bootstrapping. `(method-function-get ,method-function 'closure-generator)) (defun load-defmethod - (class name quals specls ll initargs pv-table-symbol source-location) + (class name quals specls ll initargs source-location) (setq initargs (copy-tree initargs)) (let ((method-spec (or (getf initargs :method-spec) (make-method-spec name quals specls)))) (setf (getf initargs :method-spec) method-spec) (load-defmethod-internal class name quals specls - ll initargs pv-table-symbol - source-location))) + ll initargs source-location))) (defun load-defmethod-internal (method-class gf-spec qualifiers specializers lambda-list - initargs pv-table-symbol source-location) - (when pv-table-symbol - (setf (getf (getf initargs :plist) :pv-table-symbol) - pv-table-symbol)) + initargs source-location) (when (and (eq *boot-state* 'complete) (fboundp gf-spec)) (let* ((gf (fdefinition gf-spec)) diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp index cfce81dde..68f41004c 100644 --- a/src/pcl/combin.lisp +++ b/src/pcl/combin.lisp @@ -141,12 +141,19 @@ (method-p arg)) arg (if (and (consp arg) (eq (car arg) 'make-method)) - (make-instance 'standard-method - :specializers nil ; XXX - :qualifiers nil - :fast-function (fast-method-call-function - (make-effective-method-function - gf (cadr arg) method-alist wrappers))) + (let ((emf (make-effective-method-function + gf (cadr arg) method-alist wrappers))) + (etypecase emf + (method-call + (make-instance 'standard-method + :specializers nil ; XXX + :qualifiers nil ; XXX + :function (method-call-function emf))) + (fast-method-call + (make-instance 'standard-method + :specializers nil ; XXX + :qualifiers nil + :fast-function (fast-method-call-function emf))))) arg)))) (make-method-call :function mf ;; FIXME: this is wrong. Very wrong. diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index c2103e9c6..a3c2970f7 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -930,16 +930,17 @@ ,(make-calls-type-declaration calls)) ,pv ,calls ,@forms) - `(let* ((.pv-table. ,pv-table-symbol) - (.pv-cell. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters)) - (,pv (car .pv-cell.)) - (,calls (cdr .pv-cell.))) - (declare ,(make-pv-type-declaration pv)) - (declare ,(make-calls-type-declaration calls)) - ,@(when (symbolp pv-table-symbol) - `((declare (special ,pv-table-symbol)))) - ,pv ,calls - ,@forms))) + `(locally + ,@(when (symbolp pv-table-symbol) + `((declare (special ,pv-table-symbol)))) + (let* ((.pv-table. ,pv-table-symbol) + (.pv-cell. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters)) + (,pv (car .pv-cell.)) + (,calls (cdr .pv-cell.))) + (declare ,(make-pv-type-declaration pv)) + (declare ,(make-calls-type-declaration calls)) + ,pv ,calls + ,@forms)))) (defvar *non-var-declarations* ;; FIXME: VALUES was in this list, conditionalized with #+CMU, but I diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 60b91b885..c5e11caf8 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -2116,9 +2116,9 @@ ;;; step instrumentation confusing the compiler, reported by Faré (handler-bind ((warning #'error)) - (compile nil '(lambda () + (compile nil '(lambda () (declare (optimize (debug 2))) ; not debug 3! (let ((val "foobar")) - (map-into (make-array (list (length val)) + (map-into (make-array (list (length val)) :element-type '(unsigned-byte 8)) #'char-code val))))) diff --git a/tests/mop-23.impure.lisp b/tests/mop-23.impure.lisp new file mode 100644 index 000000000..45d4ac80d --- /dev/null +++ b/tests/mop-23.impure.lisp @@ -0,0 +1,55 @@ +;;;; miscellaneous side-effectful tests of the MOP + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; While most of SBCL is derived from the CMU CL system, the test +;;;; files (like this one) were written from scratch after the fork +;;;; from CMU CL. +;;;; +;;;; This software is in the public domain and is provided with +;;;; absolutely no warranty. See the COPYING and CREDITS files for +;;;; more information. + +;;; Extending MAKE-METHOD-LAMBDA, and making sure that the resulting +;;; method functions compile without warnings. + +(defpackage "MOP-23" + (:use "CL" "SB-MOP")) + +(in-package "MOP-23") + +(defclass verbose-generic-function (standard-generic-function) () + (:metaclass funcallable-standard-class)) +(defmethod make-method-lambda + ((gf verbose-generic-function) method lambda env) + (multiple-value-bind (lambda initargs) + (call-next-method) + (values + `(lambda (args next-methods) + (format *trace-output* "Called a method!") + (,lambda args next-methods)) + initargs))) + +(defgeneric foo (x) + (:generic-function-class verbose-generic-function)) + +(handler-bind ((warning #'error)) + (eval '(defmethod foo ((x integer)) (1+ x)))) + +(assert (string= (with-output-to-string (*trace-output*) + (assert (= (foo 3) 4))) + "Called a method!")) + +(defclass super () ((a :initarg :a))) +(defclass sub (super) (b)) + +(handler-bind ((warning #'error)) + (eval '(defmethod foo ((x sub)) (slot-boundp x 'b))) + (eval '(defmethod foo :around ((x super)) + (list (slot-value x 'a) (call-next-method))))) + +(assert (string= (with-output-to-string (*trace-output*) + (assert (equal (foo (make-instance 'sub :a 4)) + '(4 nil)))) + "Called a method!Called a method!")) diff --git a/version.lisp-expr b/version.lisp-expr index ef7529608..758804fa3 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.15.28" +"0.9.15.29" -- 2.11.4.GIT