being compiled no longer causes an unhandled error at compile
time, but signals a compile-time warning.
* fixed simple vector readable printing.
+ * bug fix: DESCRIBE takes more care over whether the class
+ precedence list slot of a class is bound before accessing it.
+ (reported by Markus Krummenacker)
+ * bug fix: FORMATTER can successfully compile pretty-printer format
+ strings which use variants of the ~* directive inside.
* fixed some bugs revealed by Paul Dietz' test suite:
** NIL is now allowed as a structure slot name.
** arbitrary numbers, not just reals, are allowed in certain
** (SETF FIND-CLASS) now accepts NIL as an argument to remove the
association between the name and a class.
** generic functions with non-standard method-combination and over
- six methods all of which return constants no longer return NIL
+ five methods all of which return constants no longer return NIL
after the first few invocations. (thanks to Gerd Moellmann)
** CALL-NEXT-METHOD with no arguments now passes the original
values of the arguments, even in the presence of assignment.
** DEFCLASS only redefines the class named by its class-name
argument if that name is the proper name of the class;
otherwise, it creates a new class.
+ ** SLOT-UNBOUND now correctly initalizes the CELL-ERROR-NAME slot
+ of the UNBOUND-SLOT condition to the name of the slot.
planned incompatible changes in 0.8.x:
* (not done yet, but planned:) When the profiling interface settles
;; * NIL, in which case there's nothing to see here, move along.
(when (eq (info :type :kind x) :defined)
(format s "~&It names a type specifier."))
- (let ((symbol-named-class (find-classoid x nil)))
+ (let ((symbol-named-class (find-class x nil)))
(when symbol-named-class
(format s "~&It names a class ~A." symbol-named-class)
(describe symbol-named-class s)))
(block nil
,@(let ((*expander-next-arg-macro* 'expander-pprint-next-arg)
(*only-simple-args* nil)
- (*orig-args-available* t))
+ (*orig-args-available*
+ (if atsignp *orig-args-available* t)))
(expand-directive-list insides)))))))
(defun expand-format-justification (segments colonp atsignp first-semi params)
(string (let ((package (find-undeleted-package-or-lose name)))
(do-symbols (symbol package)
(when (eq (symbol-package symbol) package)
- (when (fboundp symbol)
+ (when (and (fboundp symbol)
+ (not (macro-function symbol))
+ (not (special-operator-p symbol)))
(funcall function symbol))
(let ((setf-name `(setf ,symbol)))
(when (fboundp setf-name)
(error-error "Help! "
*current-error-depth*
" nested errors. "
- "KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded.")
+ "SB-KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded.")
t)
(t
(/show0 "returning normally from INFINITE-ERROR-PROTECTOR")
(error-error "Help! "
*current-error-depth*
" nested errors. "
- "KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded.")
+ "SB-KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded.")
(progn ,@forms)
t)
(t
structure-class condition-class
slot-class std-class))
(set-slot 'direct-slots direct-slots)
- (set-slot 'slots slots)
- (set-slot 'initialize-info nil))
+ (set-slot 'slots slots))
;; For all direct superclasses SUPER of CLASS, make sure CLASS is
;; a direct subclass of SUPER. Note that METACLASS-NAME doesn't
:accessor class-direct-slots)
(slots
:initform ()
- :accessor class-slots)
- (initialize-info
- :initform nil
- :accessor class-initialize-info)))
+ :accessor class-slots)))
;;; The class STD-CLASS is an implementation-specific common
;;; superclass of the classes STANDARD-CLASS and
(defmethod describe-object ((class class) stream)
(flet ((pretty-class (c) (or (class-name c) c)))
(macrolet ((ft (string &rest args) `(format stream ,string ,@args)))
- (ft "~&~S is a class. It is an instance of ~S."
+ (ft "~&~@<~S is a class. It is an instance of ~S.~:@>"
class (pretty-class (class-of class)))
(let ((name (class-name class)))
(if name
(if (eq class (find-class name nil))
- (ft "~&Its proper name is ~S." name)
- (ft "~&Its name is ~S, but this is not a proper name." name))
- (ft "It has no name (the name is NIL).~%")))
- (ft "~&~@<The direct superclasses are: ~:S, and the direct~%~
- subclasses are: ~:S. The class precedence list is:~2I~_~S~I~_~
- There are ~S methods specialized for this class.~:>~%"
+ (ft "~&~@<Its proper name is ~S.~@:>" name)
+ (ft "~&~@<Its name is ~S, but this is not a proper name.~@:>"
+ name))
+ (ft "~&~@<It has no name (the name is NIL).~@:>")))
+ (ft "~&~@<The direct superclasses are: ~:S, and the direct ~
+ subclasses are: ~:S.~I~_The class is ~:[not ~;~]finalized~
+ ~:[. ~;; its class precedence list is:~2I~_~:*~S.~]~I~_~
+ There ~[are~;is~:;are~] ~:*~S method~:P specialized for ~
+ this class.~:@>~%"
(mapcar #'pretty-class (class-direct-superclasses class))
(mapcar #'pretty-class (class-direct-subclasses class))
- (mapcar #'pretty-class (class-precedence-list class))
+ (class-finalized-p class)
+ (mapcar #'pretty-class (cpl-or-nil class))
(length (specializer-direct-methods class))))))
(defmethod describe-object ((package package) stream)
(defgeneric class-incompatible-superclass-list (pcl-class))
-(defgeneric class-initialize-info (slot-class))
-
(defgeneric class-name (class))
(defgeneric class-precedence-list (pcl-class))
(defgeneric (setf class-incompatible-superclass-list) (new-value pcl-class))
-(defgeneric (setf class-initialize-info) (new-value slot-class))
-
(defgeneric (setf class-name) (new-value class))
(defgeneric (setf class-slots) (new-value slot-class))
;;;; ANSI CL condition for unbound slots
(define-condition unbound-slot (cell-error)
- ((instance :reader unbound-slot-instance :initarg :instance)
- (slot :reader unbound-slot-slot :initarg :slot))
+ ((instance :reader unbound-slot-instance :initarg :instance))
(:report (lambda (condition stream)
(format stream "The slot ~S is unbound in the object ~S."
- (unbound-slot-slot condition)
+ (cell-error-name condition)
(unbound-slot-instance condition)))))
(defmethod wrapper-fetcher ((class standard-class))
instance))
(defmethod slot-unbound ((class t) instance slot-name)
- (error 'unbound-slot :slot slot-name :instance instance))
+ (error 'unbound-slot :name slot-name :instance instance))
(defun slot-unbound-internal (instance position)
(slot-unbound (class-of instance) instance
;;; support for DESCRIBE tests
(defstruct to-be-described a b)
+(defclass forward-describe-class (forward-describe-ref) (a))
;;; DESCRIBE should run without signalling an error.
(describe (make-to-be-described))
#'car #'make-to-be-described (lambda (x) (+ x 11))
(constantly 'foo) #'(setf to-be-described-a)
#'describe-object (find-class 'to-be-described)
- (find-class 'cons)))
+ (find-class 'forward-describe-class)
+ (find-class 'forward-describe-ref) (find-class 'cons)))
(let ((s (with-output-to-string (s)
(write-char #\x s)
(describe i s))))
;;; DECLARE should not be a special operator
(assert (not (special-operator-p 'declare)))
-
;;; before 0.8.0.66 it signalled UNBOUND-VARIABLE
(write #(1 2 3) :pretty nil :readably t)
+;;; another UNBOUND-VARIABLE, this time due to a bug in FORMATTER
+;;; expanders.
+(funcall (formatter "~@<~A~:*~A~:>") nil 3)
+
;;; success
(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.0.66"
+"0.8.0.67"
projects / sbcl.git / commitdiff