From 67dc5cf478dfe5e3f517001febb9a8f7b922eacf Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Mon, 18 Oct 2004 12:16:35 +0000 Subject: [PATCH] 0.8.15.15: Removing non-ANSI FTYPE proclaims and TYPE declarares from PCL * Use internal machinary for accessor FTYPE information instead of PROCLAIM. * Don't declare TYPE for special DEFMETHOD parameters: setq-p hack doesn't work for those. Python not happy, but no can do right now. * Incidentally these changes also fix all current known package-lock bugs. --- NEWS | 6 +++ src/compiler/ir1tran.lisp | 4 +- src/pcl/boot.lisp | 11 +++++ src/pcl/defclass.lisp | 75 ++++++++++++++++++------------ src/pcl/std-class.lisp | 96 ++++++++++++++++++++------------------- tests/clos.impure.lisp | 11 +++++ tests/package-locks.impure.lisp | 36 +++++++++++++-- version.lisp-expr | 2 +- 8 files changed, 158 insertions(+), 83 deletions(-) diff --git a/NEWS b/NEWS index b95d794..b269696 100644 --- a/NEWS +++ b/NEWS @@ -1,4 +1,10 @@ changes in sbcl-0.8.16 relative to sbcl-0.8.15: + * bug fix: defining classes whose accessors are methods on existing + generic functions in other (locked) packages no longer signals + bogus package lock violations. (reported by François-René Rideau) + * bug fix: special variables as DEFMETHOD parameters no longer have + associated bogus type declarations. (reported by David Wragg and + Bruno Haible) * bug fix: read-write consistency on streams of element-type (SIGNED-BYTE N) for N > 32. (reported by Bruno Haible for CMUCL) * bug fix: redefiniton of the only method of a generic function with diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 9f4a5e3..73060c5 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -917,8 +917,8 @@ (new-vars nil cons)) (dolist (var-name (rest decl)) (when (boundp var-name) - (compiler-assert-symbol-home-package-unlocked var-name - "declaring the type of ~A")) + (compiler-assert-symbol-home-package-unlocked + var-name "declaring the type of ~A")) (let* ((bound-var (find-in-bindings vars var-name)) (var (or bound-var (lexenv-find var-name vars) diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 1f7a23b..e90518b 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -607,6 +607,17 @@ bootstrapping. ;; second argument.) Hopefully it only does this kind of ;; weirdness when bootstrapping.. -- WHN 20000610 '(ignorable)) + ((var-globally-special-p parameter) + ;; KLUDGE: Don't declare types for global special variables + ;; -- our rebinding magic for SETQ cases don't work right + ;; there. + ;; + ;; FIXME: It would be better to detect the SETQ earlier and + ;; skip declarations for specials only when needed, not + ;; always. + ;; + ;; --NS 2004-10-14 + '(ignoreable)) (t ;; Otherwise, we can usually make Python very happy. (let ((type (info :type :kind specializer))) diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp index 09bf800..363c960 100644 --- a/src/pcl/defclass.lisp +++ b/src/pcl/defclass.lisp @@ -44,6 +44,28 @@ (setf (info :type :kind name) :forthcoming-defclass-type)) (values)) +(defun preinform-compiler-about-accessors (readers writers slots) + (flet ((inform (name type) + ;; FIXME: This matches what PROCLAIM FTYPE does, except + ;; that :WHERE-FROM is :DEFINED, not :DECLARED, and should + ;; probably be factored into a common function -- eg. + ;; (%proclaim-ftype name declared-or-defined). + (when (eq (info :function :where-from name) :assumed) + (proclaim-as-fun-name name) + (note-name-defined name :function) + (setf (info :function :where-from name) :defined + (info :function :type name) type)))) + (let ((rtype (specifier-type '(function (t) t))) + (wtype (specifier-type '(function (t t) t)))) + (dolist (reader readers) + (inform reader rtype)) + (dolist (writer writers) + (inform writer wtype)) + (dolist (slot slots) + (inform (slot-reader-name slot) rtype) + (inform (slot-boundp-name slot) rtype) + (inform (slot-writer-name slot) wtype))))) + ;;; state for the current DEFCLASS expansion (defvar *initfunctions-for-this-defclass*) (defvar *readers-for-this-defclass*) @@ -97,21 +119,19 @@ (*subtypep mclass *the-class-structure-class*)))))) - (let ((defclass-form - `(progn - (let ,(mapcar #'cdr *initfunctions-for-this-defclass*) - (%compiler-defclass ',name - ',*readers-for-this-defclass* - ',*writers-for-this-defclass* - ',*slot-names-for-this-defclass*) - (load-defclass ',name - ',metaclass - ',supers - (list ,@canonical-slots) - (list ,@(apply #'append - (when defstruct-p - '(:from-defclass-p t)) - other-initargs))))))) + (let* ((defclass-form + `(let ,(mapcar #'cdr *initfunctions-for-this-defclass*) + (load-defclass ',name + ',metaclass + ',supers + (list ,@canonical-slots) + (list ,@(apply #'append + (when defstruct-p + '(:from-defclass-p t)) + other-initargs)) + ',*readers-for-this-defclass* + ',*writers-for-this-defclass* + ',*slot-names-for-this-defclass*)))) (if defstruct-p (progn ;; FIXME: (YUK!) Why do we do this? Because in order @@ -150,22 +170,16 @@ ;; full-blown class, so the "a class of this name is ;; coming" note we write here would be irrelevant. (eval-when (:compile-toplevel) - (%compiler-defclass ',name - ',*readers-for-this-defclass* - ',*writers-for-this-defclass* - ',*slot-names-for-this-defclass*)) + (%compiler-defclass ',name + ',*readers-for-this-defclass* + ',*writers-for-this-defclass* + ',*slot-names-for-this-defclass*)) (eval-when (:load-toplevel :execute) ,defclass-form))))))))) -(defun %compiler-defclass (name readers writers slot-names) - (with-single-package-locked-error (:symbol name "defining ~A as a class") - (preinform-compiler-about-class-type name) - (proclaim `(ftype (function (t) t) - ,@readers - ,@(mapcar #'slot-reader-name slot-names) - ,@(mapcar #'slot-boundp-name slot-names))) - (proclaim `(ftype (function (t t) t) - ,@writers ,@(mapcar #'slot-writer-name slot-names))))) +(defun %compiler-defclass (name readers writers slots) + (preinform-compiler-about-class-type name) + (preinform-compiler-about-accessors readers writers slots)) (defun make-initfunction (initform) (cond ((or (eq initform t) @@ -416,7 +430,10 @@ (!bootstrap-get-slot 'class class 'direct-subclasses)) (declaim (notinline load-defclass)) -(defun load-defclass (name metaclass supers canonical-slots canonical-options) +(defun load-defclass (name metaclass supers canonical-slots canonical-options + readers writers slot-names) + (%compiler-defclass name readers writers slot-names) + (preinform-compiler-about-accessors readers writers slot-names) (setq supers (copy-tree supers) canonical-slots (copy-tree canonical-slots) canonical-options (copy-tree canonical-options)) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 5cbb272..cec50b1 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -291,14 +291,17 @@ (constantly (make-member-type :members (list (specializer-object specl)))))) -(defun real-load-defclass (name metaclass-name supers slots other) - (let ((res (apply #'ensure-class name :metaclass metaclass-name - :direct-superclasses supers - :direct-slots slots - :definition-source `((defclass ,name) - ,*load-pathname*) - other))) - res)) +(defun real-load-defclass (name metaclass-name supers slots other + readers writers slot-names) + (with-single-package-locked-error (:symbol name "defining ~S as a class") + (%compiler-defclass name readers writers slot-names) + (let ((res (apply #'ensure-class name :metaclass metaclass-name + :direct-superclasses supers + :direct-slots slots + :definition-source `((defclass ,name) + ,*load-pathname*) + other))) + res))) (setf (gdefinition 'load-defclass) #'real-load-defclass) @@ -312,25 +315,25 @@ args)) (defmethod ensure-class-using-class ((class null) name &rest args &key) - (without-package-locks - (multiple-value-bind (meta initargs) - (ensure-class-values class args) - (set-class-type-translation (class-prototype meta) name) - (setf class (apply #'make-instance meta :name name initargs) - (find-class name) class) - (set-class-type-translation class name) - class))) + (multiple-value-bind (meta initargs) + (ensure-class-values class args) + (set-class-type-translation (class-prototype meta) name) + (setf class (apply #'make-instance meta :name name initargs)) + (without-package-locks + (setf (find-class name) class)) + (set-class-type-translation class name) + class)) (defmethod ensure-class-using-class ((class pcl-class) name &rest args &key) - (without-package-locks - (multiple-value-bind (meta initargs) - (ensure-class-values class args) - (unless (eq (class-of class) meta) - (apply #'change-class class meta initargs)) - (apply #'reinitialize-instance class initargs) - (setf (find-class name) class) - (set-class-type-translation class name) - class))) + (multiple-value-bind (meta initargs) + (ensure-class-values class args) + (unless (eq (class-of class) meta) + (apply #'change-class class meta initargs)) + (apply #'reinitialize-instance class initargs) + (without-package-locks + (setf (find-class name) class)) + (set-class-type-translation class name) + class)) (defmethod class-predicate-name ((class t)) 'constantly-nil) @@ -813,28 +816,27 @@ (fix-slot-accessors class dslotds 'remove)) (defun fix-slot-accessors (class dslotds add/remove) - ;; We disable package locks here, since defining a class can trigger - ;; the update of the accessors of another class -- which might lead - ;; to package lock violations if we didn't. - (without-package-locks - (flet ((fix (gfspec name r/w) - (let* ((ll (case r/w (r '(object)) (w '(new-value object)))) - (gf (if (fboundp gfspec) - (ensure-generic-function gfspec) - (ensure-generic-function gfspec :lambda-list ll)))) - (case r/w - (r (if (eq add/remove 'add) - (add-reader-method class gf name) - (remove-reader-method class gf))) - (w (if (eq add/remove 'add) - (add-writer-method class gf name) - (remove-writer-method class gf))))))) - (dolist (dslotd dslotds) - (let ((slot-name (slot-definition-name dslotd))) - (dolist (r (slot-definition-readers dslotd)) - (fix r slot-name 'r)) - (dolist (w (slot-definition-writers dslotd)) - (fix w slot-name 'w))))))) + (flet ((fix (gfspec name r/w) + (let ((gf (if (fboundp gfspec) + (without-package-locks + (ensure-generic-function gfspec)) + (ensure-generic-function + gfspec :lambda-list (case r/w + (r '(object)) + (w '(new-value object))))))) + (case r/w + (r (if (eq add/remove 'add) + (add-reader-method class gf name) + (remove-reader-method class gf))) + (w (if (eq add/remove 'add) + (add-writer-method class gf name) + (remove-writer-method class gf))))))) + (dolist (dslotd dslotds) + (let ((slot-name (slot-definition-name dslotd))) + (dolist (r (slot-definition-readers dslotd)) + (fix r slot-name 'r)) + (dolist (w (slot-definition-writers dslotd)) + (fix w slot-name 'w)))))) (defun add-direct-subclasses (class supers) (dolist (super supers) diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index c0b4d5a..a857c29 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -831,6 +831,17 @@ (setf x (/ x 2)) x) (assert (= (fum 3) 3/2)) +(defmethod fii ((x fixnum)) + (declare (special x)) + (setf x (/ x 2)) + x) +(assert (= (fii 1) 1/2)) +(defvar *faa*) +(defmethod faa ((*faa* string-stream)) + (setq *faa* (make-broadcast-stream *faa*)) + (write-line "Break, you sucker!" *faa*) + 'ok) +(assert (eq 'ok (faa (make-string-output-stream)))) ;;; Bug reported by Zach Beane; incorrect return of (function ;;; ',fun-name) in defgeneric diff --git a/tests/package-locks.impure.lisp b/tests/package-locks.impure.lisp index 9acdd24..427a8ec 100644 --- a/tests/package-locks.impure.lisp +++ b/tests/package-locks.impure.lisp @@ -25,7 +25,7 @@ (defpackage :test-unused) -(defpackage :test-aux (:export #:noslot)) +(defpackage :test-aux (:export #:noslot #:noslot2)) (defpackage :test (:use :test-used) @@ -94,7 +94,7 @@ (defconstant test:constant 'test:constant) (intern "UNUSED" :test) (dolist (s '(test:nocondition-slot test:noclass-slot test:nostruct-slot - test-aux:noslot)) + test-aux:noslot test-aux:noslot2)) (fmakunbound s)) (ignore-errors (progn (fmakunbound 'test:unused) @@ -265,7 +265,7 @@ (defvar *illegal-double-forms* '((defclass test:noclass () ((x :accessor test-aux:noslot))) (define-condition test:nocondition (error) - ((x :accessor test-aux:noslot))))) + ((x :accessor test-aux:noslot2))))) ;;; A collection of forms that cause compile-time package lock ;;; violations on TEST, and will not signal an error on LOAD if first @@ -376,7 +376,7 @@ (reset-test) (set-test-locks t) (dolist (form (append *illegal-runtime-forms* *illegal-compile-time-forms*)) - (with-error-info ("one error per form: ~S~%") + (with-error-info ("one error per form: ~S~%" form) (let ((errorp nil)) (handler-bind ((package-lock-violation (lambda (e) (when errorp @@ -449,5 +449,33 @@ ;;;; anything. (assert (trace test:function :break t)) +;;;; No bogus violations from defclass with accessors in a locked +;;;; package. Reported by by François-René Rideau. +(assert (package-locked-p :sb-gray)) +(multiple-value-bind (fun compile-errors) + (ignore-errors + (compile nil + '(lambda () + (defclass fare-class () + ((line-column :initform 0 :reader sb-gray:stream-line-column)))))) + (assert (not compile-errors)) + (assert fun) + (multiple-value-bind (class run-errors) (ignore-errors (funcall fun)) + (assert (not run-errors)) + (assert (eq class (find-class 'fare-class))))) + +;;;; No bogus violations from DECLARE's done by PCL behind the +;;;; scenes. Reported by David Wragg on sbcl-help. +(reset-test) +(set-test-locks t) +(defmethod pcl-type-declaration-method-bug ((test:*special* stream)) + test:*special*) +(assert (eq *terminal-io* (pcl-type-declaration-method-bug *terminal-io*))) +(assert (raises-error? + (eval '(defmethod pcl-type-declaration-method-bug ((test:*special* stream)) + (declare (type stream test:*special*)) + test:*special*)) + package-lock-violation)) + ;;; WOOT! Done. (sb-ext:quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index 648cade..c18ac4d 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.8.15.14" +"0.8.15.15" -- 1.7.10.4