From 479ef26343b45753fc019b6535d3aa0ee54cb324 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Fri, 13 Jun 2003 15:45:03 +0000 Subject: [PATCH] 0.8.0.67: Grab bag of fixes: ... PROFILE on a string (naming a package) shouldn't try to profile macros and special operators any more; ... SB-KERNEL, not KERNEL, in "I'm deeply confused" error message strings; ... UNBOUND-SLOT is a CELL-ERROR, so use the NAME slot (and delete the SLOT slot :-) (thanks to pfdietz) ... delete the INITIALIZE-INFO slot from SLOT-CLASS (observation from Gerd Moellmann) ... DESCRIBE on unfinalized classes shouldn't cause an error (reported by kr at molecubotics sbcl-devel 2003-06-13) ... fix bug in FORMATTER revealed by shiny new exciting format string for DESCRIBE-OBJECT (CLASS T): original args aren't necessarily available in pretty-printer expansion (specifically, not for "~@< ~:>"); ... tests for some of the above. --- NEWS | 9 ++++++++- src/code/describe.lisp | 2 +- src/code/late-format.lisp | 3 ++- src/code/profile.lisp | 4 +++- src/code/toplevel.lisp | 4 ++-- src/pcl/braid.lisp | 3 +-- src/pcl/defs.lisp | 5 +---- src/pcl/describe.lisp | 20 ++++++++++++-------- src/pcl/generic-functions.lisp | 4 ---- src/pcl/slots.lisp | 7 +++---- tests/interface.pure.lisp | 5 +++-- tests/print.impure.lisp | 4 ++++ version.lisp-expr | 2 +- 13 files changed, 41 insertions(+), 31 deletions(-) diff --git a/NEWS b/NEWS index 1b76780..6617ba6 100644 --- a/NEWS +++ b/NEWS @@ -1826,6 +1826,11 @@ changes in sbcl-0.8.1 relative to sbcl-0.8.0: 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 @@ -1835,7 +1840,7 @@ changes in sbcl-0.8.1 relative to sbcl-0.8.0: ** (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. @@ -1852,6 +1857,8 @@ changes in sbcl-0.8.1 relative to sbcl-0.8.0: ** 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 diff --git a/src/code/describe.lisp b/src/code/describe.lisp index cdbfb36..afbb66c 100644 --- a/src/code/describe.lisp +++ b/src/code/describe.lisp @@ -328,7 +328,7 @@ ;; * 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))) diff --git a/src/code/late-format.lisp b/src/code/late-format.lisp index ee5deb1..3d821ad 100644 --- a/src/code/late-format.lisp +++ b/src/code/late-format.lisp @@ -1117,7 +1117,8 @@ (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) diff --git a/src/code/profile.lisp b/src/code/profile.lisp index 0a257b3..8229b1c 100644 --- a/src/code/profile.lisp +++ b/src/code/profile.lisp @@ -233,7 +233,9 @@ (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) diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index 67bb513..3f53594 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -88,7 +88,7 @@ (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") @@ -115,7 +115,7 @@ (error-error "Help! " *current-error-depth* " nested errors. " - "KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded.") + "SB-KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded.") (progn ,@forms) t) (t diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index ca1b434..ed010f8 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -304,8 +304,7 @@ 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 diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index dc12f84..2bdeb05 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -559,10 +559,7 @@ :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 diff --git a/src/pcl/describe.lisp b/src/pcl/describe.lisp index e9ae2a4..71ced2d 100644 --- a/src/pcl/describe.lisp +++ b/src/pcl/describe.lisp @@ -110,20 +110,24 @@ (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 "~&~@~%" + (ft "~&~@" name) + (ft "~&~@" + name)) + (ft "~&~@"))) + (ft "~&~@~%" (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) diff --git a/src/pcl/generic-functions.lisp b/src/pcl/generic-functions.lisp index 4c44940..f91ced0 100644 --- a/src/pcl/generic-functions.lisp +++ b/src/pcl/generic-functions.lisp @@ -72,8 +72,6 @@ (defgeneric class-incompatible-superclass-list (pcl-class)) -(defgeneric class-initialize-info (slot-class)) - (defgeneric class-name (class)) (defgeneric class-precedence-list (pcl-class)) @@ -168,8 +166,6 @@ (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)) diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp index a5bf11b..b1fcbb3 100644 --- a/src/pcl/slots.lisp +++ b/src/pcl/slots.lisp @@ -26,11 +26,10 @@ ;;;; 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)) @@ -344,7 +343,7 @@ 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 diff --git a/tests/interface.pure.lisp b/tests/interface.pure.lisp index 76171e0..c69e03e 100644 --- a/tests/interface.pure.lisp +++ b/tests/interface.pure.lisp @@ -44,6 +44,7 @@ ;;; 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)) @@ -69,7 +70,8 @@ #'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)))) @@ -96,4 +98,3 @@ ;;; DECLARE should not be a special operator (assert (not (special-operator-p 'declare))) - diff --git a/tests/print.impure.lisp b/tests/print.impure.lisp index 725b1da..c5e6d61 100644 --- a/tests/print.impure.lisp +++ b/tests/print.impure.lisp @@ -125,5 +125,9 @@ ;;; 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) diff --git a/version.lisp-expr b/version.lisp-expr index 3e61882..5a609dc 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.0.66" +"0.8.0.67" -- 1.7.10.4