From f847c099be72ce8715c1aa16389e4f7ee7a2bce4 Mon Sep 17 00:00:00 2001 From: gerd <gerd> Date: Fri, 6 Jun 2003 12:22:33 +0000 Subject: [PATCH] Various problems with TYPE-OF found by Paul Dietz. * src/pcl/methods.lisp (setf class-name) <before>: New method setting the kernel class' name. * src/code/pred.lisp (type-of): Don't return list function types. Return boolean for t, (integer n n) for integers, keyword for keywords, standard-char for standard characters. Return the CLOS class for classes not having a proper name. --- code/pred.lisp | 38 +++++++++++++++++++++++------------- general-info/release-19a.txt | 5 ++++- pcl/methods.lisp | 5 ++++- 3 files changed, 32 insertions(+), 16 deletions(-) diff --git a/code/pred.lisp b/code/pred.lisp index f2dcf91dc..35b3c38b6 100644 --- a/code/pred.lisp +++ b/code/pred.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pred.lisp,v 1.58 2003/04/27 14:52:27 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pred.lisp,v 1.59 2003/06/06 12:22:33 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -130,19 +130,29 @@ ;;; (defun type-of (object) "Return the type of OBJECT." - (if (typep object '(or function array complex)) - (type-specifier (ctype-of object)) - (let* ((class (layout-class (layout-of object))) - (name (%class-name class))) - (if (%instancep object) - (case name - (alien-internals:alien-value - `(alien:alien - ,(alien-internals:unparse-alien-type - (alien-internals:alien-value-type object)))) - (t - (class-proper-name class))) - name)))) + (typecase object + ((or array complex) + (type-specifier (ctype-of object))) + (integer + `(integer ,object ,object)) + ((member t) + 'boolean) + (keyword + 'keyword) + (standard-char + 'standard-char) + (t + (let* ((class (layout-class (layout-of object))) + (name (%class-name class))) + (if (%instancep object) + (if (eq name 'alien-internals:alien-value) + `(alien:alien ,(alien-internals:unparse-alien-type + (alien-internals:alien-value-type object))) + (let ((proper-name (class-proper-name class))) + (if (kernel::class-p proper-name) + (%class-pcl-class proper-name) + proper-name))) + name))))) ;;;; UPGRADED-ARRAY-ELEMENT-TYPE -- public diff --git a/general-info/release-19a.txt b/general-info/release-19a.txt index e3e23dcef..717325706 100644 --- a/general-info/release-19a.txt +++ b/general-info/release-19a.txt @@ -99,6 +99,10 @@ New in this release: - FIND-METHOD signaling an error when called with specializers not corresponding to the number of required arguments of the supplied generic function. + - TYPE-OF returning KEYWORD for keywords, STANDARD-CHAR for + standard characters, BOOLEAN for T, (INTEGER <N> <N>) for + integers N, non-list types for functions, and CLOS classes for + instances whose class doesn't have a proper name. * Numerous bugfixes: - NSET-EXCLUSIVE-OR returns the same results as SET-EXCLUSIVE-OR @@ -117,7 +121,6 @@ New in this release: it now has an extra argument that describes the nature of the error or warning. - * Numerous improvements to the PCL implementation of CLOS: - Gerd's PCL has been added, which fixes numerous bugs and ANSI/ AMOP non-compliances, and adds various new optimizations (also diff --git a/pcl/methods.lisp b/pcl/methods.lisp index aece039e2..a2c42ea6d 100644 --- a/pcl/methods.lisp +++ b/pcl/methods.lisp @@ -26,7 +26,7 @@ ;;; (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.38 2003/06/05 08:33:45 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.39 2003/06/06 12:22:32 gerd Exp $") (in-package :pcl) @@ -1539,3 +1539,6 @@ (declare (ignore nreq nopt keysp restp)) (values keywords allow-other-keys-p))) +(defmethod (setf class-name) :before (new-name (class class)) + (let ((kernel-class (kernel::find-class (class-name class)))) + (setf (kernel:%class-name kernel-class) new-name))) -- GitLab