* 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.
;;; 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
(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))))
(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))
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)
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
,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)
`(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))
(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.
,(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
;;; 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)))))
--- /dev/null
+;;;; 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!"))
;;; 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"
projects / sbcl.git / commitdiff