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
(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)
;; 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)))
(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*)
(*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
;; 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)
(!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))
(constantly (make-member-type :members (list (specializer-object specl))))))
\f
-(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)
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)
(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))))))
\f
(defun add-direct-subclasses (class supers)
(dolist (super supers)
(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
(defpackage :test-unused)
-(defpackage :test-aux (:export #:noslot))
+(defpackage :test-aux (:export #:noslot #:noslot2))
(defpackage :test
(:use :test-used)
(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)
(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
(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
;;;; 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)
;;; 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"
projects / sbcl.git / commitdiff