Skip to content
Browse files

1.0.44.23: replace %METHOD-NAME and %METHOD-LAMBDA-LIST decls with sp…

…ecial variables

  This not only simplifies PCL code, but fixes a long-standing MOP-bug
  and actually gives us SB-PCL:SLOW-METHOD frames in the backtraces.

  Previously a fairly trivial MAKE-METHOD-LAMBDA method was enough
  to cause

    (defmethod foo (x) (return-from foo t))

  to break, as MAKE-METHOD-LAMBDA-INTERNAL no longer found the %METHOD-NAME
  declaration in the expected place, and hence was unable to add the block
  name.
  • Loading branch information...
1 parent 8e7660a commit 8f2883a6a64e8116ecddba619de2250e0e236efd @nikodemus nikodemus committed Nov 15, 2010
Showing with 89 additions and 100 deletions.
  1. +2 −0 NEWS
  2. +52 −77 src/pcl/boot.lisp
  3. +0 −5 src/pcl/macros.lisp
  4. +5 −16 src/pcl/vector.lisp
  5. +29 −1 tests/mop.impure.lisp
  6. +1 −1 version.lisp-expr
View
2 NEWS
@@ -15,6 +15,8 @@ changes relative to sbcl-1.0.44:
* bug fix: when SPEED > SPACE compiling CONCATENATE 'STRING with constant
long string arguments slowed the compiler down to a crawl.
* bug fix: closure VALUE-CELLs are no longer stack-allocated (lp#308934).
+ * bug fix: non-standard MAKE-METHOD-LAMBDA methods could break RETURN-FROM
+ in the DEFMETHOD body.
changes in sbcl-1.0.44 relative to sbcl-1.0.43:
* enhancement: RUN-PROGRAM accepts :EXTERNAL-FORMAT argument to select the
View
129 src/pcl/boot.lisp
@@ -388,48 +388,57 @@ bootstrapping.
(class-prototype (or (generic-function-method-class gf?)
(find-class 'standard-method)))))))
+;;; These are used to communicate the method name and lambda-list to
+;;; MAKE-METHOD-LAMBDA-INTERNAL.
+(defvar *method-name* nil)
+(defvar *method-lambda-list* nil)
+
(defun expand-defmethod (name
proto-gf
proto-method
qualifiers
lambda-list
body
env)
- (multiple-value-bind (method-lambda unspecialized-lambda-list specializers)
- (add-method-declarations name qualifiers lambda-list body env)
- (multiple-value-bind (method-function-lambda initargs)
- (make-method-lambda proto-gf proto-method method-lambda env)
- (let ((initargs-form (make-method-initargs-form
- proto-gf proto-method method-function-lambda
- initargs env))
- (specializers-form (make-method-specializers-form
- proto-gf proto-method specializers env)))
- `(progn
- ;; Note: We could DECLAIM the ftype of the generic function
- ;; here, since ANSI specifies that we create it if it does
- ;; not exist. However, I chose not to, because I think it's
- ;; more useful to support a style of programming where every
- ;; generic function has an explicit DEFGENERIC and any typos
- ;; in DEFMETHODs are warned about. Otherwise
- ;;
- ;; (DEFGENERIC FOO-BAR-BLETCH (X))
- ;; (DEFMETHOD FOO-BAR-BLETCH ((X HASH-TABLE)) ..)
- ;; (DEFMETHOD FOO-BRA-BLETCH ((X SIMPLE-VECTOR)) ..)
- ;; (DEFMETHOD FOO-BAR-BLETCH ((X VECTOR)) ..)
- ;; (DEFMETHOD FOO-BAR-BLETCH ((X ARRAY)) ..)
- ;; (DEFMETHOD FOO-BAR-BLETCH ((X LIST)) ..)
- ;;
- ;; compiles without raising an error and runs without
- ;; raising an error (since SIMPLE-VECTOR cases fall through
- ;; to VECTOR) but still doesn't do what was intended. I hate
- ;; that kind of bug (code which silently gives the wrong
- ;; answer), so we don't do a DECLAIM here. -- WHN 20000229
- ,(make-defmethod-form name qualifiers specializers-form
- unspecialized-lambda-list
- (if proto-method
- (class-name (class-of proto-method))
- 'standard-method)
- initargs-form))))))
+ (multiple-value-bind (parameters unspecialized-lambda-list specializers)
+ (parse-specialized-lambda-list lambda-list)
+ (declare (ignore parameters))
+ (let ((method-lambda `(lambda ,unspecialized-lambda-list ,@body))
+ (*method-name* `(,name ,@qualifiers ,specializers))
+ (*method-lambda-list* lambda-list))
+ (multiple-value-bind (method-function-lambda initargs)
+ (make-method-lambda proto-gf proto-method method-lambda env)
+ (let ((initargs-form (make-method-initargs-form
+ proto-gf proto-method method-function-lambda
+ initargs env))
+ (specializers-form (make-method-specializers-form
+ proto-gf proto-method specializers env)))
+ `(progn
+ ;; Note: We could DECLAIM the ftype of the generic function
+ ;; here, since ANSI specifies that we create it if it does
+ ;; not exist. However, I chose not to, because I think it's
+ ;; more useful to support a style of programming where every
+ ;; generic function has an explicit DEFGENERIC and any typos
+ ;; in DEFMETHODs are warned about. Otherwise
+ ;;
+ ;; (DEFGENERIC FOO-BAR-BLETCH (X))
+ ;; (DEFMETHOD FOO-BAR-BLETCH ((X HASH-TABLE)) ..)
+ ;; (DEFMETHOD FOO-BRA-BLETCH ((X SIMPLE-VECTOR)) ..)
+ ;; (DEFMETHOD FOO-BAR-BLETCH ((X VECTOR)) ..)
+ ;; (DEFMETHOD FOO-BAR-BLETCH ((X ARRAY)) ..)
+ ;; (DEFMETHOD FOO-BAR-BLETCH ((X LIST)) ..)
+ ;;
+ ;; compiles without raising an error and runs without
+ ;; raising an error (since SIMPLE-VECTOR cases fall through
+ ;; to VECTOR) but still doesn't do what was intended. I hate
+ ;; that kind of bug (code which silently gives the wrong
+ ;; answer), so we don't do a DECLAIM here. -- WHN 20000229
+ ,(make-defmethod-form name qualifiers specializers-form
+ unspecialized-lambda-list
+ (if proto-method
+ (class-name (class-of proto-method))
+ 'standard-method)
+ initargs-form)))))))
(defun interned-symbol-p (x)
(and (symbolp x) (symbol-package x)))
@@ -524,44 +533,6 @@ bootstrapping.
initargs
env))))
-(defun add-method-declarations (name qualifiers lambda-list body env)
- (declare (ignore env))
- (multiple-value-bind (parameters unspecialized-lambda-list specializers)
- (parse-specialized-lambda-list lambda-list)
- (multiple-value-bind (real-body declarations documentation)
- (parse-body body)
- (values `(lambda ,unspecialized-lambda-list
- ,@(when documentation `(,documentation))
- ;; (Old PCL code used a somewhat different style of
- ;; list for %METHOD-NAME values. Our names use
- ;; ,@QUALIFIERS instead of ,QUALIFIERS so that the
- ;; method names look more like what you see in a
- ;; DEFMETHOD form.)
- ;;
- ;; FIXME: As of sbcl-0.7.0.6, code elsewhere, at
- ;; least the code to set up named BLOCKs around the
- ;; bodies of methods, depends on the function's base
- ;; name being the first element of the %METHOD-NAME
- ;; list. It would be good to remove this dependency,
- ;; perhaps by building the BLOCK here, or by using
- ;; another declaration (e.g. %BLOCK-NAME), so that
- ;; our method debug names are free to have any format,
- ;; e.g. (:METHOD PRINT-OBJECT :AROUND (CLOWN T)).
- ;;
- ;; Further, as of sbcl-0.7.9.10, the code to
- ;; implement NO-NEXT-METHOD is coupled to the form of
- ;; this declaration; see the definition of
- ;; CALL-NO-NEXT-METHOD (and the passing of
- ;; METHOD-NAME-DECLARATION arguments around the
- ;; various CALL-NEXT-METHOD logic).
- (declare (%method-name (,name
- ,@qualifiers
- ,specializers)))
- (declare (%method-lambda-list ,@lambda-list))
- ,@declarations
- ,@real-body)
- unspecialized-lambda-list specializers))))
-
(defun real-make-method-initargs-form (proto-gf proto-method
method-lambda initargs env)
(declare (ignore proto-gf proto-method))
@@ -604,11 +575,15 @@ bootstrapping.
method-lambda))
(multiple-value-bind (real-body declarations documentation)
(parse-body (cddr method-lambda))
- (let* ((name-decl (get-declaration '%method-name declarations))
- (sll-decl (get-declaration '%method-lambda-list declarations))
- (method-name (when (consp name-decl) (car name-decl)))
+ ;; We have the %METHOD-NAME declaration in the place where we expect it only
+ ;; if there is are no non-standard prior MAKE-METHOD-LAMBDA methods -- or
+ ;; unless they're fantastically unintrusive.
+ (let* ((method-name *method-name*)
(generic-function-name (when method-name (car method-name)))
- (specialized-lambda-list (or sll-decl (cadr method-lambda)))
+ (specialized-lambda-list (or *method-lambda-list*
+ (ecase (car method-lambda)
+ (lambda (second method-lambda))
+ (named-lambda (third method-lambda)))))
;; the method-cell is a way of communicating what method a
;; method-function implements, for the purpose of
;; NO-NEXT-METHOD. We need something that can be shared
View
5 src/pcl/macros.lisp
@@ -29,15 +29,10 @@
(/show "starting pcl/macros.lisp")
(declaim (declaration
- ;; As of sbcl-0.7.0.6, SBCL actively uses this declaration
- ;; to propagate information needed to set up nice debug
- ;; names (as seen e.g. in BACKTRACE) for method functions.
- %method-name
;; These nonstandard declarations seem to be used privately
;; within PCL itself to pass information around, so we can't
;; just delete them.
%class
- %method-lambda-list
;; This declaration may also be used within PCL to pass
;; information around, I'm not sure. -- WHN 2000-12-30
%variable-rebinding))
View
21 src/pcl/vector.lisp
@@ -593,27 +593,16 @@
(setq body (cdr body)))
(values outer-decls inner-decls body)))
-;;; Pull a name out of the %METHOD-NAME declaration in the function
-;;; body given, or return NIL if no %METHOD-NAME declaration is found.
-(defun body-method-name (body)
- (multiple-value-bind (real-body declarations documentation)
- (parse-body body)
- (declare (ignore real-body documentation))
- (let ((name-decl (get-declaration '%method-name declarations)))
- (and name-decl
- (destructuring-bind (name) name-decl
- name)))))
-
;;; Convert a lambda expression containing a SB-PCL::%METHOD-NAME
;;; declaration (which is a naming style internal to PCL) into an
;;; SB-INT:NAMED-LAMBDA expression (which is a naming style used
;;; throughout SBCL, understood by the main compiler); or if there's
;;; no SB-PCL::%METHOD-NAME declaration, then just return the original
;;; lambda expression.
(defun name-method-lambda (method-lambda)
- (let ((method-name (body-method-name (cddr method-lambda))))
+ (let ((method-name *method-name*))
(if method-name
- `(named-lambda (slow-method ,method-name) ,(rest method-lambda))
+ `(named-lambda (slow-method ,@method-name) ,@(rest method-lambda))
method-lambda)))
(defun make-method-initargs-form-internal (method-lambda initargs env)
@@ -712,10 +701,10 @@
lambda-list))))
`(list*
:function
- (let* ((fmf (,(if (body-method-name body) 'named-lambda 'lambda)
- ,@(when (body-method-name body)
+ (let* ((fmf (,(if *method-name* 'named-lambda 'lambda)
+ ,@(when *method-name*
;; function name
- (list (cons 'fast-method (body-method-name body))))
+ (list `(fast-method ,@*method-name*)))
;; The lambda-list of the FMF
(.pv. .next-method-call. ,@fmf-lambda-list)
;; body of the function
View
30 tests/mop.impure.lisp
@@ -15,8 +15,10 @@
;;;; However, this seems a good a way as any of ensuring that we have
;;;; no regressions.
+(load "test-util.lisp")
+
(defpackage "MOP-TEST"
- (:use "CL" "SB-MOP" "ASSERTOID"))
+ (:use "CL" "SB-MOP" "ASSERTOID" "TEST-UTIL"))
(in-package "MOP-TEST")
@@ -526,5 +528,31 @@
(let ((class (find-class 'has-slots-but-isnt-finalized)))
(assert (not (sb-mop:class-finalized-p class)))
(assert (raises-error? (sb-mop:class-slots class) sb-kernel::reference-condition)))
+
+;;; Check that MAKE-METHOD-LAMBDA which wraps the original body doesn't
+;;; break RETURN-FROM.
+(defclass wrapped-generic (standard-generic-function)
+ ()
+ (:metaclass sb-mop:funcallable-standard-class))
+
+(defmethod sb-mop:make-method-lambda ((gf wrapped-generic) method lambda env)
+ (call-next-method gf method
+ `(lambda ,(second lambda)
+ (flet ((default () :default))
+ ,@(cddr lambda)))
+ env))
+
+(defgeneric wrapped (x)
+ (:generic-function-class wrapped-generic))
+
+(defmethod wrapped ((x cons))
+ (return-from wrapped (default)))
+
+(with-test (:name :make-method-lambda-wrapping+return-from)
+ (assert (eq :default (wrapped (cons t t)))))
+
+(with-test (:name :slow-method-is-fboundp)
+ (assert (fboundp '(sb-pcl::slow-method wrapped (cons))))
+ (assert (eq :default (funcall #'(sb-pcl::slow-method wrapped (cons)) (list (cons t t)) nil))))
;;;; success
View
2 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".)
-"1.0.44.22"
+"1.0.44.23"

0 comments on commit 8f2883a

Please sign in to comment.
Something went wrong with that request. Please try again.