From 1da7e361946dc94df2fae31cd8f2bad2497fa1d0 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Wed, 11 May 2005 07:49:18 +0000 Subject: [PATCH] 0.9.0.27: fix bug 281, plus a tiny PCL cleanup * COMPUTE-EFFECTIVE-METHOD-COMBINATION for SHORT-METHOD-COMBINATION should not signal an error for a bogus qualifier, but merely return a form that takes care of the signalling later. * EWTF: ESETF cannot be an optimization anymore, if it ever was. --- BUGS | 18 --------- NEWS | 2 + src/pcl/boot.lisp | 102 ++++++++++++++++++++++-------------------------- src/pcl/defcombin.lisp | 6 +-- tests/clos.impure.lisp | 12 ++++++ version.lisp-expr | 2 +- 6 files changed, 64 insertions(+), 78 deletions(-) diff --git a/BUGS b/BUGS index a5468fe..d7c3679 100644 --- a/BUGS +++ b/BUGS @@ -919,24 +919,6 @@ WORKAROUND: (see also bug 117) -281: COMPUTE-EFFECTIVE-METHOD error signalling. - (slightly obscured by a non-0 default value for - SB-PCL::*MAX-EMF-PRECOMPUTE-METHODS*) - It would be natural for COMPUTE-EFFECTIVE-METHOD to signal errors - when it finds a method with invalid qualifiers. However, it - shouldn't signal errors when any such methods are not applicable to - the particular call being evaluated, and certainly it shouldn't when - simply precomputing effective methods that may never be called. - (setf sb-pcl::*max-emf-precompute-methods* 0) - (defgeneric foo (x) - (:method-combination +) - (:method ((x symbol)) 1) - (:method + ((x number)) x)) - (foo 1) -> ERROR, but should simply return 1 - - The issue seems to be that construction of a discriminating function - calls COMPUTE-EFFECTIVE-METHOD with methods that are not all applicable. - 283: Thread safety: libc functions There are places that we call unsafe-for-threading libc functions that we should find alternatives for, or put locks around. Known or diff --git a/NEWS b/NEWS index 8ab65ac..da81148 100644 --- a/NEWS +++ b/NEWS @@ -3,6 +3,8 @@ changes in sbcl-0.9.1 relative to sbcl-0.9.0: target with a 64-bit host compiler. * fixed a bug in CLOSE :ABORT T: no longer attempts to remove files opened with :IF-EXISTS :OVERWRITE. + * fixed bug 281: error for an invalid qualifier in a short-form method + combination method is not signalled until the faulty method is called. * bug fix: iteration variable type inferrer failed to deal with open intervals. (reported by Alan Shields) * compiled code is not steppable if COMPILATION-SPEED >= DEBUG. diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index b277f87..2f9d65f 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -1641,13 +1641,6 @@ bootstrapping. (defun arg-info-nkeys (arg-info) (count-if (lambda (x) (neq x t)) (arg-info-metatypes arg-info))) -;;; Keep pages clean by not setting if the value is already the same. -(defmacro esetf (pos val) - (with-unique-names (valsym) - `(let ((,valsym ,val)) - (unless (equal ,pos ,valsym) - (setf ,pos ,valsym))))) - (defun create-gf-lambda-list (lambda-list) ;;; Create a gf lambda list from a method lambda list (loop for x in lambda-list @@ -1681,22 +1674,21 @@ bootstrapping. (error "The lambda-list ~S is incompatible with ~ existing methods of ~S." lambda-list gf)))) - (esetf (arg-info-lambda-list arg-info) - (if lambda-list-p - lambda-list + (setf (arg-info-lambda-list arg-info) + (if lambda-list-p + lambda-list (create-gf-lambda-list lambda-list))) (when (or lambda-list-p argument-precedence-order (null (arg-info-precedence arg-info))) - (esetf (arg-info-precedence arg-info) - (compute-precedence lambda-list nreq - argument-precedence-order))) - (esetf (arg-info-metatypes arg-info) (make-list nreq)) - (esetf (arg-info-number-optional arg-info) nopt) - (esetf (arg-info-key/rest-p arg-info) (not (null (or keysp restp)))) - (esetf (arg-info-keys arg-info) - (if lambda-list-p - (if allow-other-keys-p t keywords) - (arg-info-key/rest-p arg-info))))) + (setf (arg-info-precedence arg-info) + (compute-precedence lambda-list nreq argument-precedence-order))) + (setf (arg-info-metatypes arg-info) (make-list nreq)) + (setf (arg-info-number-optional arg-info) nopt) + (setf (arg-info-key/rest-p arg-info) (not (null (or keysp restp)))) + (setf (arg-info-keys arg-info) + (if lambda-list-p + (if allow-other-keys-p t keywords) + (arg-info-key/rest-p arg-info))))) (when new-method (check-method-arg-info gf arg-info new-method)) (set-arg-info1 gf arg-info new-method methods was-valid-p first-p) @@ -1771,52 +1763,52 @@ bootstrapping. (setq type (cond ((null type) new-type) ((eq type new-type) type) (t nil))))) - (esetf (arg-info-metatypes arg-info) metatypes) - (esetf (gf-info-simple-accessor-type arg-info) type))) + (setf (arg-info-metatypes arg-info) metatypes) + (setf (gf-info-simple-accessor-type arg-info) type))) (when (or (not was-valid-p) first-p) (multiple-value-bind (c-a-m-emf std-p) (if (early-gf-p gf) (values t t) (compute-applicable-methods-emf gf)) - (esetf (gf-info-static-c-a-m-emf arg-info) c-a-m-emf) - (esetf (gf-info-c-a-m-emf-std-p arg-info) std-p) + (setf (gf-info-static-c-a-m-emf arg-info) c-a-m-emf) + (setf (gf-info-c-a-m-emf-std-p arg-info) std-p) (unless (gf-info-c-a-m-emf-std-p arg-info) - (esetf (gf-info-simple-accessor-type arg-info) t)))) + (setf (gf-info-simple-accessor-type arg-info) t)))) (unless was-valid-p (let ((name (if (eq *boot-state* 'complete) (generic-function-name gf) (!early-gf-name gf)))) - (esetf (gf-precompute-dfun-and-emf-p arg-info) - (cond - ((and (consp name) - (member (car name) - *internal-pcl-generalized-fun-name-symbols*)) + (setf (gf-precompute-dfun-and-emf-p arg-info) + (cond + ((and (consp name) + (member (car name) + *internal-pcl-generalized-fun-name-symbols*)) nil) - (t (let* ((symbol (fun-name-block-name name)) - (package (symbol-package symbol))) - (and (or (eq package *pcl-package*) - (memq package (package-use-list *pcl-package*))) - ;; FIXME: this test will eventually be - ;; superseded by the *internal-pcl...* test, - ;; above. While we are in a process of - ;; transition, however, it should probably - ;; remain. - (not (find #\Space (symbol-name symbol)))))))))) - (esetf (gf-info-fast-mf-p arg-info) - (or (not (eq *boot-state* 'complete)) - (let* ((method-class (generic-function-method-class gf)) - (methods (compute-applicable-methods - #'make-method-lambda - (list gf (class-prototype method-class) - '(lambda) nil)))) - (and methods (null (cdr methods)) - (let ((specls (method-specializers (car methods)))) - (and (classp (car specls)) - (eq 'standard-generic-function - (class-name (car specls))) - (classp (cadr specls)) - (eq 'standard-method - (class-name (cadr specls))))))))) + (t (let* ((symbol (fun-name-block-name name)) + (package (symbol-package symbol))) + (and (or (eq package *pcl-package*) + (memq package (package-use-list *pcl-package*))) + ;; FIXME: this test will eventually be + ;; superseded by the *internal-pcl...* test, + ;; above. While we are in a process of + ;; transition, however, it should probably + ;; remain. + (not (find #\Space (symbol-name symbol)))))))))) + (setf (gf-info-fast-mf-p arg-info) + (or (not (eq *boot-state* 'complete)) + (let* ((method-class (generic-function-method-class gf)) + (methods (compute-applicable-methods + #'make-method-lambda + (list gf (class-prototype method-class) + '(lambda) nil)))) + (and methods (null (cdr methods)) + (let ((specls (method-specializers (car methods)))) + (and (classp (car specls)) + (eq 'standard-generic-function + (class-name (car specls))) + (classp (cadr specls)) + (eq 'standard-method + (class-name (cadr specls))))))))) arg-info) ;;; This is the early definition of ENSURE-GENERIC-FUNCTION-USING-CLASS. diff --git a/src/pcl/defcombin.lisp b/src/pcl/defcombin.lisp index 44f8fdb..ecda4e6 100644 --- a/src/pcl/defcombin.lisp +++ b/src/pcl/defcombin.lisp @@ -133,10 +133,8 @@ (around ()) (primary ())) (flet ((invalid (gf combin m) - (if *in-precompute-effective-methods-p* - (return-from compute-effective-method - `(%invalid-qualifiers ',gf ',combin ',m)) - (invalid-qualifiers gf combin m)))) + (return-from compute-effective-method + `(%invalid-qualifiers ',gf ',combin ',m)))) (dolist (m applicable-methods) (let ((qualifiers (method-qualifiers m))) (cond ((null qualifiers) (invalid generic-function combin m)) diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index 3d5bb34..05b8f87 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -1051,5 +1051,17 @@ (1+ x)) (assert (= (method-on-defined-type-and-class 3) 4)) +;; bug 281 +(let ((sb-pcl::*max-emf-precomputation-methods* 0)) + (eval '(defgeneric bug-281 (x) + (:method-combination +) + (:method ((x symbol)) 1) + (:method + ((x number)) x))) + (assert (= 1 (bug-281 1))) + (assert (= 4.2 (bug-281 4.2))) + (multiple-value-bind (val err) (ignore-errors (bug-281 'symbol)) + (assert (not val)) + (assert (typep err 'error)))) + ;;;; success (sb-ext:quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index 4e50646..84cdf6b 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.0.26" +"0.9.0.27" -- 1.7.10.4